racket/collects/mzlib/private/match/struct-helper.scm

(module struct-helper mzscheme
  (require (lib "list.ss"))
  (require-for-template mzscheme)
  (provide (all-defined))
  
  (define-struct field-decl (field ref mut posn immutable? auto?) (make-inspector))
  
  (define (sym+ . items)
    (define (->string x)
      (cond [(string? x) x]
            [(symbol? x) (symbol->string x)]
            [(identifier? x) (symbol->string (syntax-e x))]))
    (string->symbol (apply string-append (map ->string items))))
  
  (define (identifier/tf? stx)
    (or (identifier? stx) 
        (not stx) 
        (eq? (syntax-e stx) #t)
        (eq? (syntax-e stx) #f)))
  
  (define (id/tf stx stx2)
    (cond [(identifier? stx)
           stx]
          [(eq? (syntax-e stx) #t)
           stx2]
          [else #f]))
  
  (define (mk-parse-field-decl name-id)
    (define (parse-field-decl stx)
      (syntax-case stx ()
        [(field (flag ...) ref mut)
         (and (identifier? #'field)
              (identifier/tf? #'ref)
              (identifier/tf? #'mut)
              (andmap identifier? (syntax->list #'(flag ...))))
         (let ((flags (syntax-object->datum #'(flag ...))))
           (make-field-decl
            (id/tf #'field #f)
            (id/tf #'ref (datum->syntax-object name-id (sym+ name-id '- #'field)))
            (id/tf #'mut (datum->syntax-object name-id (sym+ 'set- name-id '- #'field '!)))
            #f
            (memq 'immutable flags)
            (memq 'auto flags)))]
        [(field (flag ...) ref)
         (parse-field-decl #'(field (flag ...) ref #t))]
        [(field (flag ...))
         (parse-field-decl
          #`(field 
             (flag ...)
             #t
             #t))]
        [field
         (identifier? #'field)
         (parse-field-decl
          #`(field () #t #t))]))
    (lambda (stx)
      (let ((r (parse-field-decl stx)))
        #;(printf "parse-field-decl returned ~s~n" r)
        r)))
  
  (define-struct decl:super (super struct:super))
  (define-struct decl:auto (value))
  (define-struct decl:property (key value))
  (define-struct decl:inspector (value))
  (define-struct decl:procedure-field (field))
  (define-struct decl:procedure (value))
  (define-struct decl:guard (value))
  (define-struct decl:option (value))
  
  (define (fetch-struct:super type)
    (let ((struct-info (syntax-local-value type)))
      (car struct-info)))
  
  (define (parse-decl stx)
    (syntax-case stx (super struct:super
                            auto-value property inspector transparent
                            procedure procedure-field guard
                            omit-define-values
                            omit-static-info
                            clone
                            replace
                            )
      [(super type)
       (identifier? #'type)
       (make-decl:super #'type (fetch-struct:super #'type))]
      [(struct:super value)
       (make-decl:super #f #'value)]
      [(auto-value value)
       (make-decl:auto #'value)]
      [(property key value)
       (make-decl:property #'key #'value)]
      [(inspector value)
       (make-decl:inspector #'value)]
      [transparent
       (make-decl:inspector #'(make-inspector))]
      [(procedure proc)
       (make-decl:procedure #'proc)]
      [(procedure-field field)
       (identifier? #'field)
       (make-decl:procedure-field #'field)]
      [(guard proc)
       (make-decl:guard #'proc)]
      [omit-define-values
       (make-decl:option 'omit-define-values)]
      [omit-static-info
       (make-decl:option 'omit-static-info)]
      [clone
       (make-decl:option 'include-clone)]
      [replace
       (make-decl:option 'include-replace)]))
  
  (define-struct info (type super auto-k auto-v 
                            props insp proc-spec imm-k-list guard
                            ref-fields ref-posns ref-names
                            mut-fields mut-posns mut-names
                            options fdecls))
  (define (make-null-info type)
    (make-info type #f 0 #f
               '() #f #f '() #f
               '() '() '()
               '() '() '()
               '() '()))
  (define (create-info type decls field-decls)
    (let ((info (make-null-info type)))
      (let loop ((fdecls field-decls) (posn 0) (first-auto #f))
        (if (pair? fdecls)
            (let ((fdecl (car fdecls)))
              (set-field-decl-posn! fdecl posn)
              (when (and first-auto (not (field-decl-auto? fdecl)))
                (raise-syntax-error 'define-struct* 
                                    "non-auto field came after auto field"
                                    (field-decl-field fdecl)))
              (when (field-decl-ref fdecl)
                (set-info-ref-fields! info 
                                      (cons (field-decl-field fdecl) (info-ref-fields info)))
                (set-info-ref-posns! info 
                                     (cons posn (info-ref-posns info)))
                (set-info-ref-names! info 
                                     (cons (field-decl-ref fdecl) (info-ref-names info))))
              (when (field-decl-mut fdecl)
                (set-info-mut-fields! info 
                                      (cons (field-decl-field fdecl) (info-mut-fields info)))
                (set-info-mut-posns! info 
                                     (cons posn (info-mut-posns info)))
                (set-info-mut-names! info 
                                     (cons (field-decl-mut fdecl) (info-mut-names info))))
              (loop (cdr fdecls)
                    (add1 posn)
                    (or first-auto (if (field-decl-auto? fdecl) posn #f))))
            (begin (set-info-auto-k! info 
                                     (if first-auto (- posn first-auto) 0)))))
      (set-info-ref-fields! info (reverse (info-ref-fields info)))
      (set-info-ref-posns! info (reverse (info-ref-posns info)))
      (set-info-ref-names! info (reverse (info-ref-names info)))
      (set-info-mut-fields! info (reverse (info-mut-fields info)))
      (set-info-mut-posns! info (reverse (info-mut-posns info)))
      (set-info-mut-names! info (reverse (info-mut-names info)))
      (set-info-fdecls! info field-decls)
      (for-each 
       (lambda (decl)
         (cond [(decl:super? decl) (set-info-super! info decl)]
               [(decl:auto? decl) (set-info-auto-v! info (decl:auto-value decl))]
               [(decl:property? decl)
                (set-info-props! info (cons (cons (decl:property-key decl)
                                                  (decl:property-value decl))
                                            (info-props info)))]
               [(decl:inspector? decl)
                (set-info-insp! info (decl:inspector-value decl))]
               [(decl:procedure? decl)
                (set-info-proc-spec! info (decl:procedure-value decl))]
               [(decl:procedure-field? decl)
                (set-info-proc-spec! 
                 info
                 (let loop ((fields (map field-decl-field field-decls)) (i 0))
                   (cond
                     [(null? fields)
                      (raise-syntax-error 'define-struct*
                                          "procedure-field not in field set"
                                          (decl:procedure-field-field decl))]
                     [(module-identifier=? (decl:procedure-field-field decl)
                                           (car fields))
                      i]
                     [else (loop (cdr fields) (add1 i))])))]
               [(decl:guard? decl)
                (set-info-guard! info (decl:guard-value decl))]
               [(decl:option? decl)
                (set-info-options! info (cons (decl:option-value decl)
                                              (info-options info)))]
               ))
       decls)
      (when (and (info-include-replacers? info) (pair? (info-auto-fields info)))
        (error 'define-struct* "cannot define replacers with auto-fields"))
      info))
  
  (define (info-init-fields info)
    (filter (lambda (fdecl) (not (field-decl-auto? fdecl)))
            (info-fdecls info)))
  (define (info-auto-fields info)
    (filter (lambda (fdecl) (field-decl-auto? fdecl))
            (info-fdecls info)))
  
  (define (info-include-define-values? info)
    (not (memq 'omit-define-values (info-options info))))
  
  (define (info-include-static-info? info)
    (not (memq 'omit-static-info (info-options info))))
  (define (info-include-replacers? info)
    (memq 'include-replace (info-options info)))
  (define (info-include-clone? info)
    (memq 'include-clone (info-options info)))
  
  (define (info-include-x-ref? info)
    #f)
  (define (info-include-x-set!? info)
    #f)
  
  
  (define (info-name:struct-record info)
    (let ((type (info-type info)))
      (datum->syntax-object type (sym+ 'struct: type))))
  (define (info-name:constructor info)
    (let ((type (info-type info)))
      (datum->syntax-object type (sym+ 'make- type))))
  (define (info-name:predicate info)
    (let ((type (info-type info)))
      (datum->syntax-object type (sym+ type '?))))
  (define (info-defined-names info)
    (let ((type (info-type info)))
      (append (list (info-name:struct-record info)
                    (info-name:constructor info)
                    (info-name:predicate info))
              (info-ref-names info)
              (info-mut-names info))))
  
  )