diff --git a/pkgs/racket-doc/scribblings/reference/match.scrbl b/pkgs/racket-doc/scribblings/reference/match.scrbl index 81c12bcbb1..d884858b73 100644 --- a/pkgs/racket-doc/scribblings/reference/match.scrbl +++ b/pkgs/racket-doc/scribblings/reference/match.scrbl @@ -808,6 +808,7 @@ not provided, it defaults to @racket[equal?]. A @racket[match] pattern form that matches an instance of a structure type named @racket[struct-id], where the field @racket[field] in the instance matches the corresponding @racket[pat]. + The fields do not include those from super types. Any field of @racket[struct-id] may be omitted, and such fields can occur in any order. @@ -815,11 +816,16 @@ not provided, it defaults to @racket[equal?]. @examples[ #:eval match-eval (eval:no-prompt - (struct tree (val left right))) + (struct tree (val left right)) + (struct tree* tree (val))) (match (tree 0 (tree 1 #f #f) #f) [(struct* tree ([val a] [left (struct* tree ([right #f] [val b]))])) (list a b)]) + (match (tree* 0 #f #f 42) + [(and (struct* tree* ([val a])) + (struct* tree ([val b]))) + (list a b)]) ] } diff --git a/pkgs/racket-test/tests/match/main.rkt b/pkgs/racket-test/tests/match/main.rkt index c9b7402d50..d554e06bc0 100644 --- a/pkgs/racket-test/tests/match/main.rkt +++ b/pkgs/racket-test/tests/match/main.rkt @@ -3,7 +3,8 @@ (require (for-syntax scheme/base) "match-tests.rkt" "match-exn-tests.rkt" "other-plt-tests.rkt" "other-tests.rkt" "examples.rkt" - rackunit rackunit/text-ui) + rackunit rackunit/text-ui + (only-in racket/base local-require)) (require mzlib/plt-match) @@ -300,6 +301,10 @@ )) +(module test-struct*-struct-info racket/base + (struct foo (a)) + (provide (rename-out [foo bar]))) + (define struct*-tests (test-suite "Tests of struct*" @@ -381,7 +386,24 @@ [val b]))])) (make-tree 0 (make-tree 1 #f #f) #f)) (check = 0 a) - (check = 1 b))))) + (check = 1 b))) + (test-case "also from documentation" + (let () + (define-struct tree (val left right)) + (define-struct (tree* tree) (val)) + (match-define + (and (struct* tree* ([val a])) + (struct* tree ([val b]))) + (tree* 0 #f #f 42)) + (check = 42 a) + (check = 0 b))) + (test-case "hygiene" + (let () + (local-require 'test-struct*-struct-info) + (match-define + (struct* bar ([a x])) + (bar 1)) + (check = x 1))))) (define plt-match-tests (test-suite "Tests for plt-match.rkt" diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 856ef1be64..941eb177ff 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -18,6 +18,7 @@ racket/string racket/struct-info setup/path-to-relative + "../../private/struct-util.rkt" "application-arity-checking.rkt" "arr-i-parse.rkt" (prefix-in a: "helpers.rkt") @@ -1085,20 +1086,6 @@ (loop (cdr l1) (+ i 1)))]))) - (define (predicate->struct-name orig-stx stx) - (if stx - (let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))]) - (cond - [m (cadr m)] - [else (raise-syntax-error - who - "unable to cope with a struct supertype whose predicate doesn't end with `?'" - orig-stx)])) - (raise-syntax-error - who - "unable to cope with a struct whose predicate is unknown" - orig-stx))) - ;; get-field-names/no-field-info :: string? ;; (listof identifier?) ;; (or/c identifier? boolean?) @@ -1137,7 +1124,7 @@ (define predicate (list-ref struct-info-list 2)) (define accessors (list-ref struct-info-list 3)) (define super-info (list-ref struct-info-list 5)) - (define struct-name (predicate->struct-name provide-stx predicate)) + (define struct-name (predicate->struct-name who provide-stx predicate)) (define immediate-field-names (if (struct-field-info? the-struct-info) (struct-field-info-list the-struct-info) diff --git a/racket/collects/racket/match/struct.rkt b/racket/collects/racket/match/struct.rkt index 8b34d24cc3..7053724cb1 100644 --- a/racket/collects/racket/match/struct.rkt +++ b/racket/collects/racket/match/struct.rkt @@ -2,8 +2,24 @@ (require racket/match/match-expander (for-syntax racket/base racket/struct-info - syntax/id-table - racket/list)) + racket/list + "../private/struct-util.rkt")) + +(define-for-syntax (extract-field-names orig-stx the-struct-info) + (define accessors (list-ref the-struct-info 3)) + (define parent (list-ref the-struct-info 5)) + (define num-fields (length accessors)) + (define num-super-fields + (if (identifier? parent) + (length (cadddr (syntax-local-value parent))) + 0)) + (define num-own-fields (- num-fields num-super-fields)) + (define own-accessors (take accessors num-own-fields)) + (define struct-name (predicate->struct-name 'struct* orig-stx (list-ref the-struct-info 2))) + (for/list ([accessor (in-list own-accessors)]) + ;; add1 for hyphen + (string->symbol (substring (symbol->string (syntax-e accessor)) + (add1 (string-length struct-name)))))) (define-match-expander struct* @@ -17,57 +33,44 @@ [v (if (identifier? #'struct-name) (syntax-local-value #'struct-name fail) (fail))] - [field-acc->pattern (make-free-id-table)]) + [field->pattern (make-hash)]) (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-id-table-ref field-acc->pattern field-acc #f) - (raise-syntax-error 'struct* "Field name appears twice" stx #'field)) - (free-id-table-set! field-acc->pattern field-acc #'pat))] - [_ - (raise-syntax-error - 'struct* "expected a field pattern of the form ( )" - 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-id-table-ref - field-acc->pattern field-acc - (syntax/loc stx _)) - ; Use up pattern - (free-id-table-remove! field-acc->pattern field-acc)))]) - ; Check that all patterns were used - (free-id-table-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))))]))) + (define the-struct-info (extract-struct-info v)) + + ;; own-fields and all-accessors are in the reverse order + (define all-accessors (list-ref the-struct-info 3)) + (define own-fields + (if (struct-field-info? v) + (struct-field-info-list v) + (extract-field-names stx the-struct-info))) + ;; Use hash instead of set so that we don't need to require racket/set + (define field-set (for/hash ([field own-fields]) (values field #t))) + + ;; Check that all field names are valid + (for ([an (in-list (syntax->list #'(field+pat ...)))]) + (syntax-case an () + [(field pat) + (let ([fail-field (λ (msg) (raise-syntax-error 'struct* msg stx #'field))]) + (unless (identifier? #'field) + (fail-field "not an identifier for field name")) + (define name (syntax-e #'field)) + (unless (hash-has-key? field-set name) + (fail-field "field name not associated with given structure type")) + (when (hash-has-key? field->pattern name) + (fail-field "field name appears twice")) + (hash-set! field->pattern name #'pat))] + [_ (raise-syntax-error + 'struct* "expected a field pattern of the form ( )" + stx an)])) + + ;; pats is in the reverse order + (define pats + (for/list ([field (in-sequences (in-list own-fields) + (in-cycle '(#f)))] + [accessor (in-list all-accessors)] + #:when accessor) + (hash-ref field->pattern field (syntax/loc stx _)))) + (quasisyntax/loc stx (struct struct-name #,(reverse pats))))]))) (provide struct* ==) diff --git a/racket/collects/racket/private/define-struct.rkt b/racket/collects/racket/private/define-struct.rkt index fe4f87b64c..93b80dd130 100644 --- a/racket/collects/racket/private/define-struct.rkt +++ b/racket/collects/racket/private/define-struct.rkt @@ -10,7 +10,8 @@ "stx.rkt" "stxcase-scheme.rkt" "qq-and-or.rkt" "cond.rkt" "define-et-al.rkt" "stxloc.rkt" "qqstx.rkt" - "struct-info.rkt")) + "struct-info.rkt" + "struct-util.rkt")) (#%provide define-struct* define-struct/derived @@ -899,16 +900,6 @@ [(null? xs) xs] [else (cons (car xs) (take (cdr xs) (sub1 n)))])) - ;; modified from racket/collects/racket/contract/private/provide.rkt - (define-for-syntax (predicate->struct-name orig-stx stx) - (cond - [(regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx))) => cadr] - [else - (raise-syntax-error - #f - "unable to cope with a struct type whose predicate doesn't end with `?'" - orig-stx)])) - (define-for-syntax (find-accessor/no-field-info the-struct-info fld stx) (define accessors (list-ref the-struct-info 3)) (define parent (list-ref the-struct-info 5)) @@ -920,7 +911,7 @@ 0)) (define num-own-fields (- num-fields num-super-fields)) (define own-accessors (take accessors num-own-fields)) - (define struct-name (predicate->struct-name stx (list-ref the-struct-info 2))) + (define struct-name (predicate->struct-name #f stx (list-ref the-struct-info 2))) (define accessor-name (string->symbol (format "~a-~a" struct-name (syntax-e fld)))) (or (findf (λ (a) (eq? accessor-name (syntax-e a))) own-accessors) (raise-syntax-error diff --git a/racket/collects/racket/private/struct-util.rkt b/racket/collects/racket/private/struct-util.rkt new file mode 100644 index 0000000000..d3e1a2858f --- /dev/null +++ b/racket/collects/racket/private/struct-util.rkt @@ -0,0 +1,22 @@ +(module struct-util '#%kernel + (#%require "define.rkt" + "cond.rkt") + + (#%provide predicate->struct-name) + + ;; predicate->struct-name : any/c syntax? (or/c identifier? #f) -> string? + ;; Infers struct name from a predicate identifier. This is used as a fallback + ;; method to extract field names when struct-field-info is not available. + (define (predicate->struct-name who orig-stx stx) + (if stx + (cond + [(regexp-match #rx"^(.*)[?]$" (symbol->string (syntax-e stx))) => cadr] + [else + (raise-syntax-error + who + "unable to cope with a struct type whose predicate doesn't end with `?'" + orig-stx)]) + (raise-syntax-error + who + "unable to cope with a struct whose predicate is unknown" + orig-stx))))