suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make struct* use static struct field information

Browse Source 
This PR is largely based on #732

Fixes #3265
Closes #732
This commit is contained in:
sorawee 2020-08-21 04:47:07 -07:00 committed by GitHub
parent da5f77e277
commit a5b69b6594
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 113 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-doc/scribblings/reference/match.scrbl
View File

@ -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)])
]
}

26
pkgs/racket-test/tests/match/main.rkt
View File

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

17
racket/collects/racket/contract/private/provide.rkt
View File

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

107
racket/collects/racket/match/struct.rkt
View File

@ -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 (<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-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 (<field-id> <pat>)"
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* ==)

15
racket/collects/racket/private/define-struct.rkt
View File

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

22
racket/collects/racket/private/struct-util.rkt Normal file
View File

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