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

This is now in SVN available in scheme/match with tests and documentation.

Jay

On Tue, Jun 2, 2009 at 8:49 PM, Jay McCarthy<jay.mccarthy at gmail.com> wrote:
> 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
>



-- 
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