;;;----------------------------------------------------------------------
;;; A datatype macro for Scheme:

(define-syntax define-datatype
  (letrec ([as-string (lambda (x)
                        (cond
                         [(identifier? x) (as-string (syntax-object->datum x))]
                         [(symbol? x) (symbol->string x)]
                         [(string? x) x]
                         [else (error 'define-datatype
                                      "cannot construct an identifier using ~s"
                                      x)]))]
           [construct-id (lambda (context . parts)
                           (datum->syntax-object context
                                                 (string->symbol
                                                  (apply string-append
                                                         (map as-string parts)))))])
    (lambda (x)
      (syntax-case x ()
        [(_ ?name (?variant ?field ...) ...)
         (and (identifier? (syntax ?name))
              (andmap identifier? (syntax (?variant ...))))
         (with-syntax ([(?constructor ...)
                        (map (lambda (variant)
                               (construct-id (syntax ?name) "make-" variant))
                             (syntax (?variant ...)))]
                       [(?recycler ...)
                        (map (lambda (variant)
                               (construct-id (syntax ?name) "recycle-as-" variant))
                             (syntax (?variant ...)))]
                       [?datatype-predicate
                        (construct-id (syntax ?name) (syntax ?name) "?")]
                       [(?field-count ...)
                        (map (lambda (fields)
                               (datum->syntax-object (syntax ?name) (length fields)))
                             (syntax ((?field ...) ...)))]
                       [(((?field-name ?predicate) ...) ...)
                        (map (lambda (fields)
                               (map (lambda (field)
                                      (syntax-case field ()
                                       [(?field-name ?predicate)
                                        (identifier? (syntax ?field-name))
                                        field]
                                       [?field-name
                                        (identifier? (syntax ?field-name))
                                        (syntax (?field-name (lambda (x) #t)))]))
                                    fields))
                             (syntax ((?field ...) ...)))])
           (syntax
            (begin
              (begin
                (define ?constructor
                  (lambda (?field-name ...)
                    (if (and (?predicate ?field-name) ...)
                        (vector '?name '?variant ?field-name ...)
                        (error '?constructor "invalid argument types"))))
                (define-syntax ?recycler
                  (let ([fields (list '?field-name ...)])
                    (letrec ([lookup-index (lambda (target source start)
                                             (cond
                                              [(null? source)
                                               (error '?recycler
                                                      "unrecognized field name: ~a"
                                                      source)]
                                              [(eqv? target (car source))
                                               start]
                                              [else
                                               (lookup-index target (cdr source) (+ start 1))]))])
                      (lambda (x)
                        (syntax-case x ()
                         [(__ ??old [??delta-field ??delta-value] (... ...))
                          (with-syntax ([(??delta-index (... ...))
                                         (map (lambda (field)
                                                (datum->syntax-object (syntax __)
                                                  (lookup-index (syntax-object->datum field) fields 2)))
                                              (syntax (??delta-field (... ...))))])
                            (syntax
                             (let ([new ??old])
                               (if (and (vector? new)
                                        (= (vector-length new) (+ ?field-count 2)))
                                   (begin
                                     (vector-set! new 0 '?name)
                                     (vector-set! new 1 '?variant)
                                     (vector-set! new ??delta-index ??delta-value)
                                     (... ...)
                                     new)
                                   (error '?recycler
                                          "~s cannot be recycled as a ~a"
                                          new
                                          '?variant)))))])))))) ...
              (define ?datatype-predicate
                (lambda (x)
                  (and (vector? x)
                       (>= (vector-length x) 2)
                       (eqv? (vector-ref x 0) '?name))))
              (define-syntax ?name
                (letrec ([build-indices (lambda (context variant-name vars table)
                                          (let ([entry (assoc variant-name table)])
                                            (if entry
                                                (let ([field-count (cdr entry)])
                                                  (if (= field-count (length vars))
                                                      (make-range context 2 (+ field-count 2))
                                                      (error 'type-case
                                                             "incorrect number of fields in ~a"
                                                             variant-name)))
                                                (error 'type-case
                                                       "~a is not a variant of ~a"
                                                       variant-name
                                                       (syntax-object->datum (syntax ?name))))))]
                         [make-range (lambda (context start end)
                                       (cond
                                        [(>= start end) '()]
                                        [else (cons (datum->syntax-object context start)
                                                    (make-range context (+ start 1) end))]))])
                  (let ([variant-table (list (cons '?variant '?field-count) ...)])
                    (lambda (x)
                      (syntax-case x ()
                       [(__ ??exp ??clause0 ??clause1 (... ...))
                        (with-syntax
                            ([??body (let caseloop ([clause0 (syntax ??clause0)]
                                                    [others (syntax (??clause1 (... ...)))])
                                       (cond
                                        [(null? others)
                                         (syntax-case clause0 (else)
                                          [(else ??body (... ...))
                                           (syntax (begin ??body (... ...)))]
                                          [((??variant ??var (... ...)) ??body (... ...))
                                           (with-syntax ([(??index (... ...))
                                                          (build-indices (syntax ?name)
                                                                         (syntax-object->datum (syntax ??variant))
                                                                         (syntax (??var (... ...)))
                                                                         variant-table)])
                                             (syntax
                                              (if (eqv? variant-tag '??variant)
                                                  (let ([??var (vector-ref case-val ??index)] (... ...))
                                                    ??body (... ...))
                                                  (error 'type-case "no matching clause for ~s" case-val))))])]
                                        [else
                                         (syntax-case clause0 (else)
                                          [((??variant ??var (... ...)) ??body (... ...))
                                           (with-syntax ([??rest
                                                          (caseloop (car others) (cdr others))]
                                                         [(??index (... ...))
                                                          (build-indices (syntax ?name)
                                                                         (syntax-object->datum (syntax ??variant))
                                                                         (syntax (??var (... ...)))
                                                                         variant-table)])
                                             (syntax
                                              (if (eqv? (vector-ref case-val 1) '??variant)
                                                  (let ([??var (vector-ref case-val ??index)] (... ...))
                                                    ??body (... ...))
                                                  ??rest)))])]))])
                          (syntax
                           (let ([case-val ??exp])
                             (if (?datatype-predicate case-val)
                                 (let ([variant-tag (vector-ref case-val 1)])
                                   ??body)
                                 (error 'type-case
                                        "~s is not a ~a"
                                        case-val
                                        '?name)))))]))))))))]))))
(define-syntax type-case
  (lambda (x)
    (syntax-case x ()
      ((_ ?type-name ?exp ?clause ...)
       (syntax (?type-name ?exp ?clause ...))))))