Add #:name and #:extra-name to struct
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
parent
4d9427af44
commit
8993398033
|
|
@ -24,6 +24,8 @@
|
|||
(code:line #:property prop-expr val-expr)
|
||||
(code:line #:transparent)
|
||||
(code:line #:prefab)
|
||||
(code:line #:name name-id)
|
||||
(code:line #:extra-name name-id)
|
||||
(code:line #:constructor-name constructor-id)
|
||||
(code:line #:extra-constructor-name constructor-id)
|
||||
(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
|
||||
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
|
||||
is used to define subtypes, and it also works with the
|
||||
@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"].
|
||||
|
||||
The @racket[constructor-id] and @racket[id] can be the same, in
|
||||
which case @racket[id] performs both roles. In that case, the
|
||||
expansion of @racket[id] as an expression produces an otherwise
|
||||
The @racket[constructor-id] and @racket[name-id] can be the same, in
|
||||
which case @racket[name-id] performs both roles. In that case, the
|
||||
expansion of @racket[name-id] as an expression produces an otherwise
|
||||
inaccessible identifier that is bound to the constructor
|
||||
procedure; the expanded identifier has a
|
||||
@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
|
||||
@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
|
||||
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
|
||||
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,
|
||||
the @racket[#:super] option can be used to specify an expression that
|
||||
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))
|
||||
]
|
||||
|
||||
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}
|
||||
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]
|
||||
includes @racket[constructor-id] as an export. If
|
||||
@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[id] rather than @racket[constructor-id]. If
|
||||
@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
|
||||
the symbolic form of @racket[constructor-id]. Only one of
|
||||
@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
|
||||
@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
|
||||
usual variables are bound, but @racket[id] is bound. If both are
|
||||
supplied, then the @racket[struct] form is equivalent to
|
||||
|
|
|
|||
|
|
@ -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 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)
|
||||
|
|
|
|||
|
|
@ -236,8 +236,10 @@
|
|||
(#:mutable . #f)
|
||||
(#:guard . #f)
|
||||
(#:constructor-name . #f)
|
||||
(#:reflection-name . #f)
|
||||
(#:only-constructor? . #f)
|
||||
(#:reflection-name . #f)
|
||||
(#:name . #f)
|
||||
(#:only-name? . #f)
|
||||
(#:omit-define-values . #f)
|
||||
(#:omit-define-syntaxes . #f))]
|
||||
[nongen? #f])
|
||||
|
|
@ -329,6 +331,18 @@
|
|||
'#:only-constructor?
|
||||
(eq? '#:constructor-name (syntax-e (car p))))
|
||||
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)))
|
||||
(check-exprs 1 p "expression")
|
||||
(when (lookup config '#:reflection-name)
|
||||
|
|
@ -433,7 +447,8 @@
|
|||
(loop (cdr fields) (cdr field-stxes) #f)]))])
|
||||
(let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only?
|
||||
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)])
|
||||
(values (lookup config '#:inspector)
|
||||
(lookup config '#:super)
|
||||
|
|
@ -445,9 +460,14 @@
|
|||
(lookup config '#:reflection-name)
|
||||
(lookup config '#:mutable)
|
||||
(lookup config '#:omit-define-values)
|
||||
(lookup config '#:omit-define-syntaxes)))]
|
||||
(lookup config '#:omit-define-syntaxes)
|
||||
(lookup config '#:name)
|
||||
(lookup config '#:only-name?)))]
|
||||
[(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?))])
|
||||
(when mutable?
|
||||
(for-each (lambda (f f-stx)
|
||||
|
|
@ -569,7 +589,7 @@
|
|||
#f))
|
||||
sets)))
|
||||
|
||||
(let ([run-time-defns
|
||||
(let* ([run-time-defns
|
||||
(lambda ()
|
||||
(quasisyntax/loc stx
|
||||
(define-values (#,struct: #,make- #,? #,@sels #,@sets)
|
||||
|
|
@ -620,7 +640,7 @@
|
|||
(cons #`(make-struct-field-mutator -set! #,i '#,(field-id (car fields)))
|
||||
(loop (add1 i) (cdr fields)))))))))))]
|
||||
[compile-time-defns
|
||||
(lambda ()
|
||||
(lambda (body-only?)
|
||||
(let* ([protect (lambda (sel)
|
||||
(and sel
|
||||
(if (syntax-e sel)
|
||||
|
|
@ -640,59 +660,70 @@
|
|||
#'make-self-ctor-struct-info
|
||||
(if include-autos?
|
||||
#'make-struct-auto-info
|
||||
#'make-struct-info)))])
|
||||
(quasisyntax/loc stx
|
||||
(define-syntaxes (#,id)
|
||||
(#,mk-info
|
||||
(lambda ()
|
||||
(list
|
||||
(quote-syntax #,(prune struct:))
|
||||
(quote-syntax #,(prune (if (and ctor-name self-ctor?)
|
||||
id
|
||||
make-)))
|
||||
(quote-syntax #,(prune ?))
|
||||
(list
|
||||
#,@(map protect (reverse sels))
|
||||
#,@(if super-info
|
||||
(map protect (list-ref super-info 3))
|
||||
(if super-expr
|
||||
'(#f)
|
||||
null)))
|
||||
(list
|
||||
#,@(reverse
|
||||
(let loop ([fields fields][sets sets])
|
||||
(cond
|
||||
[(null? fields) null]
|
||||
[(not (or mutable? (field-mutable? (car fields))))
|
||||
(cons #f (loop (cdr fields) sets))]
|
||||
[else
|
||||
(cons (protect (car sets))
|
||||
(loop (cdr fields) (cdr sets)))])))
|
||||
#,@(if super-info
|
||||
(map protect (list-ref super-info 4))
|
||||
(if super-expr
|
||||
'(#f)
|
||||
null)))
|
||||
#,(if super-id
|
||||
(protect super-id)
|
||||
(if super-expr
|
||||
#f
|
||||
#t))))
|
||||
#,@(if include-autos?
|
||||
(list #`(list (list #,@(map protect
|
||||
(list-tail sels (- (length sels) auto-count)))
|
||||
#,@(if super-autos
|
||||
(map protect (car super-autos))
|
||||
null))
|
||||
(list #,@(map protect
|
||||
(list-tail sets (max 0 (- (length sets) auto-count))))
|
||||
#,@(if super-autos
|
||||
(map protect (cadr super-autos))
|
||||
null))))
|
||||
null)
|
||||
#,@(if name-as-ctor?
|
||||
(list #`(lambda () (quote-syntax #,make-)))
|
||||
null))))))])
|
||||
#'make-struct-info)))]
|
||||
[define-syntax-body
|
||||
#`(#,mk-info
|
||||
(lambda ()
|
||||
(list
|
||||
(quote-syntax #,(prune struct:))
|
||||
(quote-syntax #,(prune (if (and ctor-name self-ctor?)
|
||||
id
|
||||
make-)))
|
||||
(quote-syntax #,(prune ?))
|
||||
(list
|
||||
#,@(map protect (reverse sels))
|
||||
#,@(if super-info
|
||||
(map protect (list-ref super-info 3))
|
||||
(if super-expr
|
||||
'(#f)
|
||||
null)))
|
||||
(list
|
||||
#,@(reverse
|
||||
(let loop ([fields fields][sets sets])
|
||||
(cond
|
||||
[(null? fields) null]
|
||||
[(not (or mutable? (field-mutable? (car fields))))
|
||||
(cons #f (loop (cdr fields) sets))]
|
||||
[else
|
||||
(cons (protect (car sets))
|
||||
(loop (cdr fields) (cdr sets)))])))
|
||||
#,@(if super-info
|
||||
(map protect (list-ref super-info 4))
|
||||
(if super-expr
|
||||
'(#f)
|
||||
null)))
|
||||
#,(if super-id
|
||||
(protect super-id)
|
||||
(if super-expr
|
||||
#f
|
||||
#t))))
|
||||
#,@(if include-autos?
|
||||
(list #`(list (list #,@(map protect
|
||||
(list-tail sels (- (length sels) auto-count)))
|
||||
#,@(if super-autos
|
||||
(map protect (car super-autos))
|
||||
null))
|
||||
(list #,@(map protect
|
||||
(list-tail sets (max 0 (- (length sets) auto-count))))
|
||||
#,@(if super-autos
|
||||
(map protect (cadr super-autos))
|
||||
null))))
|
||||
null)
|
||||
#,@(if name-as-ctor?
|
||||
(list #`(lambda () (quote-syntax #,make-)))
|
||||
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
|
||||
(cond
|
||||
[(and (not omit-define-values?) (not omit-define-syntaxes?))
|
||||
|
|
@ -704,16 +735,22 @@
|
|||
;; in the body of a property value that is a procedure)
|
||||
#`(begin
|
||||
(define-syntaxes (#,struct: #,make- #,? #,@sels #,@sets) (values))
|
||||
#,(compile-time-defns)
|
||||
#,(compile-time-defns #f)
|
||||
#,@(extra-compile-time-defs)
|
||||
#,(run-time-defns))
|
||||
;; Other contexts: order should't matter:
|
||||
#`(begin
|
||||
#,(run-time-defns)
|
||||
#,(compile-time-defns)))]
|
||||
#,(compile-time-defns #f)
|
||||
#,@(extra-compile-time-defs)))]
|
||||
[omit-define-syntaxes?
|
||||
(run-time-defns)]
|
||||
#`(begin
|
||||
#,(run-time-defns)
|
||||
#,@(extra-compile-time-defs))]
|
||||
[omit-define-values?
|
||||
(compile-time-defns)]
|
||||
#`(begin
|
||||
#,(compile-time-defns #f)
|
||||
#,@(extra-compile-time-defs))]
|
||||
[else #'(begin)])])
|
||||
(syntax-protect
|
||||
(syntax-property
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user