;; Macros for define-record and variant-case
;; By Erik Hilsdale, adapted rpj 2009
;; A very simple define-record and variant-case package for
;; use with the syntax-case macro system.
;;  -- ehilsdal 

;; (define-record name (field ...)) generates definitons for
;; the procedures make-name, name?, and one name->field for every
;; field given.

;; (variant-case exp0 (name (field ...) exp1 exp2 ...) ...)
;; will try to match exp0 to a name record.  If it matches, it binds the
;; variables field ... to the appropriate fields from the record, and
;; evaluates exp1 and exp2 ... .
;; If it doesn't match, it tries the next clause.  If nothing matches,
;; an error is signalled.

;; --------------------

;; build-name is the same for both define-record and variant-case, but
;; there's no safe (read: portable) way to abstract it out.

;; All the predicates here could be made with the define-integrable
;; macro if performance is an issue.  The pred checks inside the
;; accessors could be removed at a higher optimization level.

(define-syntax define-record
  (letrec ((build-name
             (lambda (tem . args)
               (datum->syntax-object tem
                 (string->symbol
                   (apply string-append
                     (map (lambda (x)
                            (if (string? x)
                              x
                              (symbol->string (syntax-object->datum x))))
                       args)))))))
    (lambda (x)
      (syntax-case x ()
        [(_ name (field ...))
         (and (identifier? (syntax name))
           (andmap identifier? (syntax (field ...))))
         (with-syntax
           ([maker (build-name (syntax name) "make-" (syntax name))]
            [pred (build-name (syntax name) (syntax name) "?")]
            [(acc ...)
             (map (lambda (f) (build-name f (syntax name) "->" f))
               (syntax (field ...)))]
            [(mut ...)
             (map (lambda (f) (build-name (syntax name) "set-" (syntax name) "->" f "!"))
               (syntax (field ...)))]
            [len (add1 (length (syntax (field ...))))]
            [(index ...)
             (let loop ((n 1) (ls (syntax (field ...))))
               (if (null? ls) '()
                 (cons n (loop (add1 n) (cdr ls)))))])
           (syntax
             (begin
               (define maker
                 (lambda (field ...)
                   (vector 'name field ...)))
               (define pred
                 (lambda (obj)
                   (and (vector? obj)
                     (= (vector-length obj) len)
                     (eq? (vector-ref obj 0) 'name))))
               (define acc
                 (lambda (obj)
                   (if (pred obj)
                     (vector-ref obj index)
                     (error 'acc "~s is not a ~s record" obj 'name))))
               ...
               (define mut
                 (lambda (obj val)
                   (if (pred obj)
                       (vector-set! obj index val)
                       (error 'mut "~s is not a ~s record" obj 'name))))
               ...
               )))]))))

;; hygene warning: this macro transforms into calls to the record
;; accessors and predicates presumably generated by define-record.  If
;; this macro appears in a context where these accessors and
;; predicates have been shadowed, too bad.

(define-syntax variant-case
  (let ((build-name
          (lambda (tem . args)
            (datum->syntax-object tem
              (string->symbol
                (apply string-append
                  (map (lambda (x)
                         (if (string? x)
                           x
                           (symbol->string (syntax-object->datum x))))
                    args)))))))
    (lambda (x)
      (syntax-case x (else)
        [(_ thing clause ...)
         (not (identifier? (syntax thing)))
         (syntax
           (let ((v thing))
             (variant-case v clause ...)))]
        [(_ v)
         (syntax (error 'variant-case "No matching clause for ~s" v))]
        [(_ v (else exp0 exp1 ...))
         (syntax (begin exp0 exp1 ...))]
        [(_ v (name (field ...) exp0 exp1 ...) clause ...)
         (and (identifier? (syntax name))
           (andmap identifier? (syntax (field ...))))
         (with-syntax
           ([pred (build-name (syntax name) (syntax name) "?")]
            [(acc ...)
             (map (lambda (x) (build-name x (syntax name) "->" x))
               (syntax (field ...)))])
           (syntax
             (if (pred v)
               (let ((field (acc v)) ...)
                 exp0 exp1 ...)
               (variant-case v clause ...))))]))))