1#lang racket/base
2(require racket/match/match-expander
3         (for-syntax racket/base
4                     racket/struct-info
5                     racket/list
6                     "../private/struct-util.rkt"))
7
8(define-for-syntax (extract-field-names orig-stx the-struct-info)
9  (define accessors (list-ref the-struct-info 3))
10  (define parent (list-ref the-struct-info 5))
11  (define num-fields (length accessors))
12  (define num-super-fields
13    (if (identifier? parent)
14        (length (cadddr (id->struct-info parent orig-stx)))
15        0))
16  (define num-own-fields (- num-fields num-super-fields))
17  (define own-accessors (take accessors num-own-fields))
18  (define struct-name (predicate->struct-name 'struct* orig-stx (list-ref the-struct-info 2)))
19  (for/list ([accessor (in-list own-accessors)])
20    ;; add1 for hyphen
21    (string->symbol (substring (symbol->string (syntax-e accessor))
22                               (add1 (string-length struct-name))))))
23
24(define-for-syntax (id->struct-info id stx)
25  (define compile-time-info (syntax-local-value id (lambda () #f)))
26  (unless (struct-info? compile-time-info)
27    (raise-syntax-error #f "identifier is not bound to a structure type" stx id))
28  (extract-struct-info compile-time-info))
29
30(define-match-expander
31  struct*
32  (lambda (stx)
33    (syntax-case stx ()
34      [(_ struct-name (field+pat ...))
35       (let* ([fail (lambda ()
36                      (raise-syntax-error
37                       'struct* "not a structure definition"
38                       stx #'struct-name))]
39              [v (if (identifier? #'struct-name)
40                     (syntax-local-value #'struct-name fail)
41                     (fail))]
42              [field->pattern (make-hash)])
43         (unless (struct-info? v) (fail))
44         (define the-struct-info (extract-struct-info v))
45
46         ;; own-fields and all-accessors are in the reverse order
47         (define all-accessors (list-ref the-struct-info 3))
48         (define own-fields
49           (if (struct-field-info? v)
50               (struct-field-info-list v)
51               (extract-field-names stx the-struct-info)))
52         ;; Use hash instead of set so that we don't need to require racket/set
53         (define field-set (for/hash ([field own-fields]) (values field #t)))
54
55         ;; Check that all field names are valid
56         (for ([an (in-list (syntax->list #'(field+pat ...)))])
57           (syntax-case an ()
58             [(field pat)
59              (let ([fail-field (λ (msg) (raise-syntax-error 'struct* msg stx #'field))])
60                (unless (identifier? #'field)
61                  (fail-field "not an identifier for field name"))
62                (define name (syntax-e #'field))
63                (unless (hash-has-key? field-set name)
64                  (fail-field "field name not associated with given structure type"))
65                (when (hash-has-key? field->pattern name)
66                  (fail-field "field name appears twice"))
67                (hash-set! field->pattern name #'pat))]
68             [_ (raise-syntax-error
69                 'struct* "expected a field pattern of the form (<field-id> <pat>)"
70                 stx an)]))
71
72         ;; pats is in the reverse order
73         (define pats
74           (for/list ([field (in-sequences (in-list own-fields)
75                                           (in-cycle '(#f)))]
76                      [accessor (in-list all-accessors)]
77                      #:when accessor)
78             (hash-ref field->pattern field (syntax/loc stx _))))
79         (quasisyntax/loc stx (struct struct-name #,(reverse pats))))])))
80
81(provide struct* ==)
82
83(define-match-expander
84  ==
85  (lambda (stx)
86    (syntax-case stx ()
87      [(_ val comp)
88       #'(? (lambda (x) (comp val x)))]
89      [(_ val) #'(? (lambda (x) (equal? val x)))])))
90