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

Add #:name and #:extra-name to struct

Browse Source 
A `#:name` identifier picks the name that is bound to static
information about a structure type. An `#:extra-name` identifier
specifies an additional name to be bound to the information.
This pair of options is analogous to `#:constructor-name`
and `#:extra-constructor-name`.

Based on Jen Axel's suggestion and implementation.

Closes #1309
This commit is contained in:
Matthew Flatt 2016-04-16 18:37:43 -06:00
parent 4d9427af44
commit 8993398033
3 changed files with 149 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
pkgs/racket-doc/scribblings/reference/define-struct.scrbl
View File

@ -24,6 +24,8 @@
(code:line #:property prop-expr val-expr) (code:line #:property prop-expr val-expr)
(code:line #:transparent) (code:line #:transparent)
(code:line #:prefab) (code:line #:prefab)
(code:line #:name name-id)
(code:line #:extra-name name-id)
(code:line #:constructor-name constructor-id) (code:line #:constructor-name constructor-id)
(code:line #:extra-constructor-name constructor-id) (code:line #:extra-constructor-name constructor-id)
(code:line #:reflection-name symbol-expr) (code:line #:reflection-name symbol-expr)
@ -54,23 +56,24 @@ to @math{4+2n} names:
@math{m} is the number of @racket[field]s that do not include @math{m} is the number of @racket[field]s that do not include
an @racket[#:auto] option.} an @racket[#:auto] option.}
@item{@racket[id], a @tech{transformer} binding that encapsulates @item{@racket[name-id] (which defaults to @racket[id]),
a @tech{transformer} binding that encapsulates
information about the structure type declaration. This binding information about the structure type declaration. This binding
is used to define subtypes, and it also works with the is used to define subtypes, and it also works with the
@racket[shared] and @racket[match] forms. For detailed @racket[shared] and @racket[match] forms. For detailed
information about the binding of @racket[id], see information about the binding of @racket[name-id], see
@secref["structinfo"]. @secref["structinfo"].
The @racket[constructor-id] and @racket[id] can be the same, in The @racket[constructor-id] and @racket[name-id] can be the same, in
which case @racket[id] performs both roles. In that case, the which case @racket[name-id] performs both roles. In that case, the
expansion of @racket[id] as an expression produces an otherwise expansion of @racket[name-id] as an expression produces an otherwise
inaccessible identifier that is bound to the constructor inaccessible identifier that is bound to the constructor
procedure; the expanded identifier has a procedure; the expanded identifier has a
@racket['constructor-for] property whose value is an identifier @racket['constructor-for] property whose value is an identifier
that is @racket[free-identifier=?] to @racket[id] as well as that is @racket[free-identifier=?] to @racket[name-id] as well as
a syntax property accessible via a syntax property accessible via
@racket[syntax-procedure-alias-property] with an identifier @racket[syntax-procedure-alias-property] with an identifier
that is @racket[free-identifier=?] to @racket[id].} that is @racket[free-identifier=?] to @racket[name-id].}
@item{@racket[id]@racketidfont{?}, a @deftech{predicate} procedure @item{@racket[id]@racketidfont{?}, a @deftech{predicate} procedure
that returns @racket[#t] for instances of the @tech{structure that returns @racket[#t] for instances of the @tech{structure
@ -95,7 +98,7 @@ to @math{4+2n} names:
] ]
If @racket[super-id] is provided, it must have a transformer binding If @racket[super-id] is provided, it must have a transformer binding
of the same sort bound to @racket[id] (see @secref["structinfo"]), of the same sort bound to @racket[name-id] (see @secref["structinfo"]),
and it specifies a supertype for the structure type. Alternately, and it specifies a supertype for the structure type. Alternately,
the @racket[#:super] option can be used to specify an expression that the @racket[#:super] option can be used to specify an expression that
must produce a @tech{structure type descriptor}. See must produce a @tech{structure type descriptor}. See
@ -163,8 +166,20 @@ must also be a @tech{prefab} structure type.
(prefab-point? #s(prefab-point 1 2)) (prefab-point? #s(prefab-point 1 2))
] ]
If @racket[name-id] is supplied via @racket[#:extra-name] and it is
not @racket[id], then both @racket[name-id] and @racket[id] are bound
to information about the structure type. Only one of
@racket[#:extra-name] and @racket[#:name] can be provided within a
@racket[struct] form.
@examples[#:eval posn-eval
(struct ghost (color name) #:prefab #:extra-name GHOST)
(match (ghost 'red 'blinky)
[(GHOST c n) c])
]
If @racket[constructor-id] is supplied, then the @tech{transformer} If @racket[constructor-id] is supplied, then the @tech{transformer}
binding of @racket[id] records @racket[constructor-id] as the binding of @racket[name-id] records @racket[constructor-id] as the
constructor binding; as a result, for example, @racket[struct-out] constructor binding; as a result, for example, @racket[struct-out]
includes @racket[constructor-id] as an export. If includes @racket[constructor-id] as an export. If
@racket[constructor-id] is supplied via @racket[constructor-id] is supplied via
@ -172,7 +187,7 @@ includes @racket[constructor-id] as an export. If
@racket[object-name] on the constructor produces the symbolic form of @racket[object-name] on the constructor produces the symbolic form of
@racket[id] rather than @racket[constructor-id]. If @racket[id] rather than @racket[constructor-id]. If
@racket[constructor-id] is supplied via @racket[#:constructor-name] @racket[constructor-id] is supplied via @racket[#:constructor-name]
and it is not the same as @racket[id], then @racket[id] does not serve and it is not the same as @racket[name-id], then @racket[name-id] does not serve
as a constructor, and @racket[object-name] on the constructor produces as a constructor, and @racket[object-name] on the constructor produces
the symbolic form of @racket[constructor-id]. Only one of the symbolic form of @racket[constructor-id]. Only one of
@racket[#:extra-constructor-name] and @racket[#:constructor-name] @racket[#:extra-constructor-name] and @racket[#:constructor-name]
@ -217,7 +232,8 @@ and expressions may also appear in @racket[method-defs].
] ]
If the @racket[#:omit-define-syntaxes] option is supplied, then If the @racket[#:omit-define-syntaxes] option is supplied, then
@racket[id] is not bound as a transformer. If the @racket[name-id] (and @racket[id], if @racket[#:extra-name] is specified])
is not bound as a transformer. If the
@racket[#:omit-define-values] option is supplied, then none of the @racket[#:omit-define-values] option is supplied, then none of the
usual variables are bound, but @racket[id] is bound. If both are usual variables are bound, but @racket[id] is bound. If both are
supplied, then the @racket[struct] form is equivalent to supplied, then the @racket[struct] form is equivalent to

22
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -1142,6 +1142,28 @@
(test #t struct? (make-prefab-struct '(foo 5 (1 #f) #(1) bar 2 #()) 1 2 3 4 5 6 7 8)) (test #t struct? (make-prefab-struct '(foo 5 (1 #f) #(1) bar 2 #()) 1 2 3 4 5 6 7 8))
(test #t struct? (make-prefab-struct '(foo 5 (1 #f) #(1) bar 0 #()) 1 2 3 4 5 6)) (test #t struct? (make-prefab-struct '(foo 5 (1 #f) #(1) bar 0 #()) 1 2 3 4 5 6))
;; ----------------------------------------
;; Check `#:name` and `#:extra-name`:
(let ()
(struct ghost (color name) #:extra-name GHOST)
(test 'blinky ghost-name (ghost 'red 'blinky))
(struct running-ghost GHOST (edible?))
(test 'blinky ghost-name (running-ghost 'red 'blinky #f)))
(let ()
(struct ghost (color name) #:name GHOST)
(struct running-ghost GHOST (edible?))
(test 'blinky ghost-name (running-ghost 'red 'blinky #f)))
(syntax-test #'(struct ghost (color name) #:name gHoSt #:extra-name GHOST))
(struct ghost (color name) #:name GHOST)
(test #t procedure? ghost)
(test #t ghost? (ghost 'red 'blinky))
(test 'blinky ghost-name (struct-copy GHOST (ghost 'red 'blinky)))
(syntax-test #'GHOST)
;; ---------------------------------------- ;; ----------------------------------------
(report-errs) (report-errs)

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

@ -236,8 +236,10 @@
(#:mutable . #f) (#:mutable . #f)
(#:guard . #f) (#:guard . #f)
(#:constructor-name . #f) (#:constructor-name . #f)
(#:reflection-name . #f)
(#:only-constructor? . #f) (#:only-constructor? . #f)
(#:reflection-name . #f)
(#:name . #f)
(#:only-name? . #f)
(#:omit-define-values . #f) (#:omit-define-values . #f)
(#:omit-define-syntaxes . #f))] (#:omit-define-syntaxes . #f))]
[nongen? #f]) [nongen? #f])
@ -329,6 +331,18 @@
'#:only-constructor? '#:only-constructor?
(eq? '#:constructor-name (syntax-e (car p)))) (eq? '#:constructor-name (syntax-e (car p))))
nongen?)] nongen?)]
[(or (eq? '#:name (syntax-e (car p)))
(eq? '#:extra-name (syntax-e (car p))))
(check-exprs 1 p "identifier")
(when (lookup config '#:name)
(bad "multiple" "#:name or #:extra-name" "s" (car p)))
(unless (identifier? (cadr p))
(bad "need an identifier after" (car p) "" (cadr p)))
(loop (cddr p)
(extend-config (extend-config config '#:name (cadr p))
'#:only-name?
(eq? '#:name (syntax-e (car p))))
nongen?)]
[(eq? '#:reflection-name (syntax-e (car p))) [(eq? '#:reflection-name (syntax-e (car p)))
(check-exprs 1 p "expression") (check-exprs 1 p "expression")
(when (lookup config '#:reflection-name) (when (lookup config '#:reflection-name)
@ -433,7 +447,8 @@
(loop (cdr fields) (cdr field-stxes) #f)]))]) (loop (cdr fields) (cdr field-stxes) #f)]))])
(let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only? (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only?
reflect-name-expr mutable? reflect-name-expr mutable?
omit-define-values? omit-define-syntaxes?) omit-define-values? omit-define-syntaxes?
info-name name-only?)
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)]) (let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
(values (lookup config '#:inspector) (values (lookup config '#:inspector)
(lookup config '#:super) (lookup config '#:super)
@ -445,9 +460,14 @@
(lookup config '#:reflection-name) (lookup config '#:reflection-name)
(lookup config '#:mutable) (lookup config '#:mutable)
(lookup config '#:omit-define-values) (lookup config '#:omit-define-values)
(lookup config '#:omit-define-syntaxes)))] (lookup config '#:omit-define-syntaxes)
(lookup config '#:name)
(lookup config '#:only-name?)))]
[(self-ctor?) [(self-ctor?)
(and ctor-name (bound-identifier=? id ctor-name))] (and ctor-name (or (and (not name-only?)
(bound-identifier=? id ctor-name))
(and info-name
(bound-identifier=? info-name ctor-name))))]
[(name-as-ctor?) (or self-ctor? (not ctor-only?))]) [(name-as-ctor?) (or self-ctor? (not ctor-only?))])
(when mutable? (when mutable?
(for-each (lambda (f f-stx) (for-each (lambda (f f-stx)
@ -569,7 +589,7 @@
#f)) #f))
sets))) sets)))
(let ([run-time-defns (let* ([run-time-defns
(lambda () (lambda ()
(quasisyntax/loc stx (quasisyntax/loc stx
(define-values (#,struct: #,make- #,? #,@sels #,@sets) (define-values (#,struct: #,make- #,? #,@sels #,@sets)
@ -620,7 +640,7 @@
(cons #`(make-struct-field-mutator -set! #,i '#,(field-id (car fields))) (cons #`(make-struct-field-mutator -set! #,i '#,(field-id (car fields)))
(loop (add1 i) (cdr fields)))))))))))] (loop (add1 i) (cdr fields)))))))))))]
[compile-time-defns [compile-time-defns
(lambda () (lambda (body-only?)
(let* ([protect (lambda (sel) (let* ([protect (lambda (sel)
(and sel (and sel
(if (syntax-e sel) (if (syntax-e sel)
@ -640,10 +660,9 @@
#'make-self-ctor-struct-info #'make-self-ctor-struct-info
(if include-autos? (if include-autos?
#'make-struct-auto-info #'make-struct-auto-info
#'make-struct-info)))]) #'make-struct-info)))]
(quasisyntax/loc stx [define-syntax-body
(define-syntaxes (#,id) #`(#,mk-info
(#,mk-info
(lambda () (lambda ()
(list (list
(quote-syntax #,(prune struct:)) (quote-syntax #,(prune struct:))
@ -692,7 +711,19 @@
null) null)
#,@(if name-as-ctor? #,@(if name-as-ctor?
(list #`(lambda () (quote-syntax #,make-))) (list #`(lambda () (quote-syntax #,make-)))
null))))))]) null))])
(if body-only?
define-syntax-body
(quasisyntax/loc stx
(define-syntaxes (#,(if name-only? info-name id))
#,define-syntax-body)))))]
[extra-compile-time-defs
(lambda ()
(cond
[(and info-name (not name-only?))
; reuse existing value
(list #`(define-syntaxes (#,info-name) (syntax-local-value #'#,id)))]
[else null]))])
(let ([result (let ([result
(cond (cond
[(and (not omit-define-values?) (not omit-define-syntaxes?)) [(and (not omit-define-values?) (not omit-define-syntaxes?))
@ -704,16 +735,22 @@
;; in the body of a property value that is a procedure) ;; in the body of a property value that is a procedure)
#`(begin #`(begin
(define-syntaxes (#,struct: #,make- #,? #,@sels #,@sets) (values)) (define-syntaxes (#,struct: #,make- #,? #,@sels #,@sets) (values))
#,(compile-time-defns) #,(compile-time-defns #f)
#,@(extra-compile-time-defs)
#,(run-time-defns)) #,(run-time-defns))
;; Other contexts: order should't matter: ;; Other contexts: order should't matter:
#`(begin #`(begin
#,(run-time-defns) #,(run-time-defns)
#,(compile-time-defns)))] #,(compile-time-defns #f)
#,@(extra-compile-time-defs)))]
[omit-define-syntaxes? [omit-define-syntaxes?
(run-time-defns)] #`(begin
#,(run-time-defns)
#,@(extra-compile-time-defs))]
[omit-define-values? [omit-define-values?
(compile-time-defns)] #`(begin
#,(compile-time-defns #f)
#,@(extra-compile-time-defs))]
[else #'(begin)])]) [else #'(begin)])])
(syntax-protect (syntax-protect
(syntax-property (syntax-property