[plt-dev] struct match-expander a la struct-copy

The structure patterns in scheme/match have always bugged me that they
didn't let you put the fields in any order and you had to put in _ for
the fields you didn't care about.

I've remedied this with a new match expander, struct*. I'd like to put
in the tree. Do people agree?

-- Use cases --

(define-struct super-tree (left right extra))

(define example1
  (make-super-tree 1 2 "And a pony!"))

(match example1
  [(struct* super-tree
            ([left (? number? l)]
             [right (? number? r)]))
   (printf "All numbers! ~a ~a~n" l r)])

(match example1
  [(struct* super-tree
            ([right (? number? r)]
             [left (? number? l)]))
   (printf "Look ma, any order! ~a ~a~n" l r)])

(define-struct (even-better-tree super-tree) (more-extra-good))

(define example2
  (make-even-better-tree 1 2 "And a pony!" "And a giraffe!"))

(match example2
  [(struct* super-tree
            ([left (? number? l)]
             [right (? number? r)]))
   (printf "All numbers! ~a ~a~n" l r)])

(match example2
  [(struct* even-better-tree
            ([more-extra-good (? string? m)]))
   (printf "~a~n" m)])

-- Code & Test Cases --

#lang scheme
(require (for-syntax scheme/struct-info
                     syntax/boundmap
                     scheme/list))

(define-match-expander
  struct*
  (lambda (stx)
    (syntax-case stx ()
      [(_ struct-name (field+pat ...))
       (let* ([fail (lambda ()
                      (raise-syntax-error
                       'struct* "not a structure definition"
                       stx #'struct-name))]
              [v (syntax-local-value #'struct-name fail)]
              [field-acc->pattern (make-free-identifier-mapping)])
         (unless (struct-info? v) (fail))
         ; Check each pattern and capture the field-accessor name
         (for-each (lambda (an)
                     (syntax-case an ()
                       [(field pat)
                        (unless (identifier? #'field)
                          (raise-syntax-error
                           'struct* "not an identifier for field name"
                           stx #'field))
                        (let ([field-acc
                               (datum->syntax #'field
                                              (string->symbol
                                               (format "~a-~a"
                                                       (syntax-e #'struct-name)
                                                       (syntax-e #'field)))
                                              #'field)])
                          (when (free-identifier-mapping-get
field-acc->pattern field-acc (lambda () #f))
                            (raise-syntax-error 'struct* "Field name
appears twice" stx #'field))
                          (free-identifier-mapping-put!
field-acc->pattern field-acc #'pat))]
                       [_
                        (raise-syntax-error
                         'struct* "expected a field pattern of the
form (<field-id> <pat>)"
                         stx an)]))
                   (syntax->list #'(field+pat ...)))
         (let* (; Get the structure info
                [acc (fourth (extract-struct-info v))]
                ;; the accessors come in reverse order
                [acc (reverse acc)]
                ;; remove the first element, if it's #f
                [acc (cond [(empty? acc) acc]
                           [(not (first acc)) (rest acc)]
                           [else acc])]
                ; Order the patterns in the order of the accessors
                [pats-in-order
                 (for/list ([field-acc (in-list acc)])
                   (begin0
                     (free-identifier-mapping-get
                      field-acc->pattern field-acc
                      (lambda () (syntax/loc stx _)))
                     ; Use up pattern
                     (free-identifier-mapping-put!
                      field-acc->pattern field-acc #f)))])
           ; Check that all patterns were used
           (free-identifier-mapping-for-each
            field-acc->pattern
            (lambda (field-acc pat)
              (when pat
                (raise-syntax-error 'struct* "field name not
associated with given structure type"
                                    stx field-acc))))
           (quasisyntax/loc stx
             (struct struct-name #,pats-in-order))))])))

; Comment out to test syntax errors

; Bad struct info id
#;(match example1
    [(struct* some-tree
              ([left (? number? l)]
               [right (? number? r)]))
     (printf "Just the facts: ~a ~a~n"
             l r)])

; Bad struct info
(define-for-syntax uncool-tree #f)
#;(match example1
    [(struct* uncool-tree
              ([left (? number? l)]
               [right (? number? r)]))
     (printf "Just the facts: ~a ~a~n"
             l r)])

; Bad syntax form
#;(match example1
    [(struct* super-tree
              ([foo]
               [right (? number? r)]))
     (printf "Just the facts: ~a ~a~n"
             l r)])

; Not an id for field
#;(match example1
    [(struct* super-tree
              ([(+ 1 1) (? number? l)]
               [right (? number? r)]))
     (printf "Just the facts: ~a ~a~n"
             l r)])

; Field appears twice
#;(match example1
    [(struct* super-tree
              ([right _]
               [right (? number? r)]))
     (printf "Just the facts: ~a~n"
             r)])

; Not a field id
#;(match example1
  [(struct* super-tree
            ([feet (? number?)]
             [right (? number? r)]))
   (printf "Just the facts: ~a~n"
           r)])

; Super structs don't work
#;(match example2
  [(struct* even-better-tree
            ([left (? number? l)]
             [right (? number? r)]
             [more-extra-good (? string? s)]))
   (printf "All numbers (+ 1 string)! ~a ~a ~a~n" l r s)])

; Super structs don't work
#;(match example2
  [(struct* even-better-tree
            ([left (? number? l)]
             [extra (? string? e)]
             [right (? number? r)]
             [more-extra-good (? string? m)]))
   (printf "All numbers (+ 2 strings)! ~a ~a ~a ~a~n" l e r m)])

-- 
Jay McCarthy <jay at cs.byu.edu>
Assistant Professor / Brigham Young University
http://teammccarthy.org/jay

"The glory of God is Intelligence" - D&C 93