From a3ca5aeefcca4b1d291db6ed85947b4e736ece28 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 30 Dec 2015 12:54:06 -0800 Subject: [PATCH] Allow the types created for structs to be specified manually This allows the types generated by the struct form, as well as #:struct clauses of require/typed, to be specified explicitly using a #:type-name option. This allows the name of a struct and the type it is assigned to be different. Closes #261 --- .../scribblings/reference/special-forms.scrbl | 80 +++++++++++-------- typed-racket-lib/info.rkt | 2 +- .../typed-racket/base-env/prims-contract.rkt | 55 ++++++++----- .../typed-racket/base-env/prims-struct.rkt | 76 +++++++++++++----- .../typed-racket/typecheck/internal-forms.rkt | 6 +- .../typed-racket/typecheck/tc-structs.rkt | 15 ++-- .../typed-racket/typecheck/tc-toplevel.rkt | 6 +- .../require-typed-struct-custom-type.rkt | 10 +++ .../succeed/struct-custom-type.rkt | 12 +++ 9 files changed, 178 insertions(+), 84 deletions(-) create mode 100644 typed-racket-test/succeed/require-typed-struct-custom-type.rkt create mode 100644 typed-racket-test/succeed/struct-custom-type.rkt diff --git a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl index fa44b723..daa91885 100644 --- a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl +++ b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl @@ -378,16 +378,19 @@ those functions. @section{Structure Definitions} -@defform/subs[ +@defform/subs[#:literals (:) (struct maybe-type-vars name-spec ([f : t] ...) options ...) ([maybe-type-vars code:blank (v ...)] - [name-spec name (code:line name parent)] + [name-spec name-id (code:line name-id parent)] [options #:transparent #:mutable #:prefab (code:line #:constructor-name constructor-id) - (code:line #:extra-constructor-name constructor-id)])]{ - Defines a @rtech{structure} with the name @racket[name], where the + (code:line #:extra-constructor-name constructor-id) + (code:line #:type-name type-id)])]{ + Defines a @rtech{structure} with the name @racket[name-id], where the fields @racket[f] have types @racket[t], similar to the behavior of @|struct-id| - from @racketmodname[racket/base]. + from @racketmodname[racket/base]. If @racket[type-id] is specified, then it will + be used for the name of the type associated with instances of the declared + structure, otherwise @racket[name-id] will be used for both. When @racket[parent] is present, the structure is a substructure of @racket[parent]. @@ -408,32 +411,43 @@ amount it needs. ] Options provided have the same meaning as for the @|struct-id| form -from @racketmodname[racket/base]. +from @racketmodname[racket/base] (with the exception of @racket[#:type-name], as +described above). -A prefab structure type declaration will bind the given @racket[name] to a -@racket[Prefab] type. Unlike in @racketmodname[racket/base], a non-prefab -structure type cannot extend a prefab structure type. +A prefab structure type declaration will bind the given @racket[name-id] +or @racket[type-id] to a @racket[Prefab] type. Unlike the @|struct-id| form from +@racketmodname[racket/base], a non-prefab structure type cannot extend +a prefab structure type. @ex[ (struct a-prefab ([x : String]) #:prefab) (:type a-prefab) (eval:error (struct not-allowed a-prefab ())) ] + +@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}] } -@defform/subs[ +@defform/subs[#:literals (:) (define-struct maybe-type-vars name-spec ([f : t] ...) options ...) ([maybe-type-vars code:blank (v ...)] - [name-spec name (name parent)] - [options #:transparent #:mutable])]{Legacy version of @racket[struct], -corresponding to @|define-struct-id| from @racketmodname[racket/base].} + [name-spec name-id (code:line name-id parent)] + [options #:transparent #:mutable + (code:line #:type-name type-id)])]{ +Legacy version of @racket[struct], corresponding to @|define-struct-id| +from @racketmodname[racket/base]. +@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]} -@defform/subs[ -(define-struct/exec name-spec ([f : t] ...) [e : proc-t]) -([name-spec name (name parent)])]{ +@defform/subs[#:literals (:) +(define-struct/exec name-spec ([f : t] ...) [e : proc-t] maybe-type-name) +([name-spec name-id (code:line name-id parent)] + [maybe-type-name (code:line) + (code:line #:type-name type-id)])]{ Like @racket[define-struct], but defines a procedural structure. - The procdure @racket[e] is used as the value for @racket[prop:procedure], and must have type @racket[proc-t].} + The procedure @racket[e] is used as the value for @racket[prop:procedure], + and must have type @racket[proc-t]. +@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]} @section{Names for Types} @defform*[[(define-type name t maybe-omit-def) @@ -560,12 +574,12 @@ Here, @racket[_m] is a module spec, @racket[_pred] is an identifier naming a predicate, and @racket[_maybe-renamed] is an optionally-renamed identifier. -@defform/subs[#:literals (struct) +@defform/subs[#:literals (struct :) (require/typed m rt-clause ...) ([rt-clause [maybe-renamed t] - [#:struct name ([f : t] ...) + [#:struct name-id ([f : t] ...) struct-option ...] - [#:struct (name parent) ([f : t] ...) + [#:struct (name-id parent) ([f : t] ...) struct-option ...] [#:opaque t pred] [#:signature name ([id : t] ...)]] @@ -573,21 +587,21 @@ optionally-renamed identifier. (orig-id new-id)] [struct-option (code:line #:constructor-name constructor-id) - (code:line #:extra-constructor-name constructor-id)])] + (code:line #:extra-constructor-name constructor-id) + (code:line #:type-name type-id)])] This form requires identifiers from the module @racket[m], giving them the specified types. -The first case requires @racket[_maybe-renamed], giving it type -@racket[t]. +The first case requires @racket[_maybe-renamed], giving it type @racket[t]. -@index["struct"]{The second and third cases} require the struct with name @racket[name] -with fields @racket[f ...], where each field has type @racket[t]. The -third case allows a @racket[parent] structure type to be specified. -The parent type must already be a structure type known to Typed -Racket, either built-in or via @racket[require/typed]. The -structure predicate has the appropriate Typed Racket filter type so -that it may be used as a predicate in @racket[if] expressions in Typed -Racket. +@index["struct"]{The second and third cases} require the struct with name +@racket[name-id] and creates a new type with the name @racket[type-id], or +@racket[name-id] if no @racket[type-id] is provided, with fields @racket[f ...], +where each field has type @racket[t]. The third case allows a @racket[parent] +structure type to be specified. The parent type must already be a structure type +known to Typed Racket, either built-in or via @racket[require/typed]. The +structure predicate has the appropriate Typed Racket filter type so that it may +be used as a predicate in @racket[if] expressions in Typed Racket. @ex[(module UNTYPED racket/base @@ -646,7 +660,9 @@ a @racket[require/typed] form. Here is an example of using Any])])) @racket[file-or-directory-modify-seconds] has some arguments which are optional, -so we need to use @racket[case->].} +so we need to use @racket[case->]. + +@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]} @defform[(require/typed/provide m rt-clause ...)]{ Similar to @racket[require/typed], but also provides the imported identifiers. diff --git a/typed-racket-lib/info.rkt b/typed-racket-lib/info.rkt index 13ce937f..dde5e9db 100644 --- a/typed-racket-lib/info.rkt +++ b/typed-racket-lib/info.rkt @@ -12,4 +12,4 @@ (define pkg-authors '(samth stamourv)) -(define version "1.3") +(define version "1.4") diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt index 90da2c27..7a91f02e 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -115,23 +115,24 @@ #:attributes (nm ty) (pattern [nm:opt-rename ty])) - (define-splicing-syntax-class (opt-constructor legacy struct-name) - #:attributes (value) - (pattern (~seq) - #:attr value (if legacy - #`(#:extra-constructor-name - #,(format-id struct-name "make-~a" struct-name)) - #'())) - (pattern (~seq (~and key (~or #:extra-constructor-name #:constructor-name)) name:id) - #:attr value #'(key name))) + (define-splicing-syntax-class (struct-opts legacy struct-name) + #:attributes (ctor-value type) + (pattern (~seq (~optional (~seq (~and key (~or #:extra-constructor-name #:constructor-name)) + name:id)) + (~optional (~seq #:type-name type:id) #:defaults ([type struct-name]))) + #:attr ctor-value (if (attribute key) #'(key name) + (if legacy + #`(#:extra-constructor-name + #,(format-id struct-name "make-~a" struct-name)) + #'())))) (define-syntax-class (struct-clause legacy) - ;#:literals (struct) - #:attributes (nm (body 1) (constructor-parts 1)) + #:attributes (nm type (body 1) (constructor-parts 1)) (pattern [(~or (~datum struct) #:struct) nm:opt-parent (body ...) - (~var constructor (opt-constructor legacy #'nm.nm))] - #:with (constructor-parts ...) #'constructor.value)) + (~var opts (struct-opts legacy #'nm.nm))] + #:with (constructor-parts ...) #'opts.ctor-value + #:attr type #'opts.type)) (define-syntax-class signature-clause #:literals (:) @@ -152,6 +153,7 @@ #`(require/opaque-type oc.ty oc.pred #,lib . oc.opt)) (pattern (~var strc (struct-clause legacy)) #:attr spec #`(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... + #:type-name strc.type #,@(if unsafe? #'(unsafe-kw) #'()) #,lib)) (pattern sig:signature-clause #:attr spec @@ -391,6 +393,7 @@ [(_ name:opt-parent ([fld : ty] ...) (~var input-maker (constructor-term legacy #'name.nm)) + (~optional (~seq #:type-name type:id) #:defaults ([type #'name.nm])) unsafe:unsafe-clause lib) (with-syntax* ([nm #'name.nm] @@ -468,24 +471,38 @@ (make-struct-info-self-ctor #'internal-maker si) si)) - (dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only) + (dtsi* () spec type ([fld : ty] ...) #:maker maker-name #:type-only) #,(ignore #'(require/contract pred hidden (or/c struct-predicate-procedure?/c (c-> any-wrap/c boolean?)) lib)) - #,(internal #'(require/typed-internal hidden (Any -> Boolean : nm))) - (require/typed #:internal (maker-name real-maker) nm lib + #,(internal #'(require/typed-internal hidden (Any -> Boolean : type))) + (require/typed #:internal (maker-name real-maker) type lib #:struct-maker parent #,@(if (attribute unsafe.unsafe?) #'(unsafe-kw) #'())) ;This needs to be a different identifier to meet the specifications ;of struct (the id constructor shouldn't expand to it) #,(if (syntax-e #'extra-maker) - #`(require/typed #:internal (maker-name extra-maker) nm lib + #`(require/typed #:internal (maker-name extra-maker) type lib #:struct-maker parent #,@(if (attribute unsafe.unsafe?) #'(unsafe-kw) #'())) #'(begin)) + #,(if (not (free-identifier=? #'nm #'type)) + #'(define-syntax type + (lambda (stx) + (raise-syntax-error + 'type-check + (format "type name ~a used out of context in ~a" + (syntax->datum (if (stx-pair? stx) + (stx-car stx) + stx)) + (syntax->datum stx)) + stx + (and (stx-pair? stx) (stx-car stx))))) + #'(begin)) + #,@(if (attribute unsafe.unsafe?) - #'((require/typed #:internal sel (nm -> ty) lib unsafe-kw) ...) - #'((require/typed lib [sel (nm -> ty)]) ...)))))])) + #'((require/typed #:internal sel (type -> ty) lib unsafe-kw) ...) + #'((require/typed lib [sel (type -> ty)]) ...)))))])) (values (rts #t) (rts #f)))) diff --git a/typed-racket-lib/typed-racket/base-env/prims-struct.rkt b/typed-racket-lib/typed-racket/base-env/prims-struct.rkt index 7d6f8a39..4918234b 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-struct.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-struct.rkt @@ -46,7 +46,7 @@ (format "field `~a' requires a type annotation" (syntax-e #'fld)) #:with form 'dummy)) - + (define-syntax-class struct-name #:description "struct name (with optional super-struct name)" #:attributes (name super) @@ -72,7 +72,7 @@ (define-splicing-syntax-class struct-options #:description "typed structure type options" - #:attributes (guard mutable? transparent? prefab? cname ecname + #:attributes (guard mutable? transparent? prefab? cname ecname type untyped [prop 1] [prop-val 1]) (pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?))) (~optional (~seq (~and #:transparent transparent?))) @@ -81,12 +81,22 @@ (~bind [ecname #f])) (~and (~seq #:extra-constructor-name ecname) (~bind [cname #f])))) + (~optional (~seq #:type-name type:id)) ;; FIXME: unsound, but relied on in core libraries ;; #:guard ought to be supportable with some work ;; #:property is harder (~optional (~seq #:guard guard:expr)) (~seq #:property prop:expr prop-val:expr)) - ...))) + ...) + #:attr untyped #`(#,@(if (attribute mutable?) #'(#:mutable) #'()) + #,@(if (attribute transparent?) #'(#:transparent) #'()) + #,@(if (attribute prefab?) #'(#:prefab) #'()) + #,@(if (attribute cname) #'(#:constructor-name cname) #'()) + #,@(if (attribute ecname) #'(#:extra-constructor-name ecname) #'()) + #,@(if (attribute guard) #'(#:guard guard) #'()) + #,@(append* (for/list ([prop (in-list (attribute prop))] + [prop-val (in-list (attribute prop-val))]) + (list #'#:property prop prop-val)))))) (define-syntax-class dtsi-struct-name #:description "struct name (with optional super-struct name)" @@ -99,13 +109,27 @@ (define-syntax (define-typed-struct/exec stx) (syntax-parse stx #:literals (:) - [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) + [(_ nm:struct-name ((~describe "field specification" [fld:optionally-annotated-name]) ...) + [proc : proc-ty] (~optional (~seq #:type-name type:id))) (with-syntax* - ([proc* (with-type* #'proc #'proc-ty)] + ([type (or (attribute type) #'nm.name)] + [proc* (with-type* #'proc #'proc-ty)] [d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...) #:property prop:procedure proc*)))] - [dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))]) - #'(begin d-s dtsi))])) + [stx-err-fun (if (not (free-identifier=? #'nm.name #'type)) + (syntax/loc stx + (define-syntax type + (lambda (stx) + (raise-syntax-error + 'type-check + (format "type name ~a used out of context in ~a" + (syntax->datum (if (stx-pair? stx) (stx-car stx) stx)) + (syntax->datum stx)) + stx + (and (stx-pair? stx) (stx-car stx)))))) + #'(begin))] + [dtsi (quasisyntax/loc stx (dtsi/exec* () nm.name type (fld ...) proc-ty))]) + #'(begin d-s stx-err-fun dtsi))])) (define-syntaxes (dtsi* dtsi/exec*) (let () @@ -157,18 +181,32 @@ [extra-maker (if (attribute opts.ecname) #`(#:extra-maker #,(attribute opts.ecname)) #'())]) - (with-syntax ([d-s (ignore (quasisyntax/loc stx - (struct #,@(attribute nm.new-spec) (fs.fld ...) - . opts)))] - [dtsi (quasisyntax/loc stx - (dtsi* (vars.vars ...) - nm.old-spec (fs.form ...) - #,@mutable? - #,@prefab? - #,@maker - #,@extra-maker))]) - #'(begin d-s dtsi)))])) - + (with-syntax* ([type (or (attribute opts.type) #'nm.name)] + [d-s (ignore (quasisyntax/loc stx + (struct #,@(attribute nm.new-spec) (fs.fld ...) + . opts.untyped)))] + [stx-err-fun (if (not (free-identifier=? #'nm.name #'type)) + (syntax/loc stx + (define-syntax type + (lambda (stx) + (raise-syntax-error + 'type-check + (format "type name ~a used out of context in ~a" + (syntax->datum (if (stx-pair? stx) + (stx-car stx) + stx)) + (syntax->datum stx)) + stx + (and (stx-pair? stx) (stx-car stx)))))) + #'(begin))] + [dtsi (quasisyntax/loc stx + (dtsi* (vars.vars ...) + nm.old-spec type (fs.form ...) + #,@mutable? + #,@prefab? + #,@maker + #,@extra-maker))]) + #'(begin d-s stx-err-fun dtsi)))])) ;; this has to live here because it's used below (define-syntax (define-type-alias stx) diff --git a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt index d2316d6e..670b404d 100644 --- a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt +++ b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt @@ -89,10 +89,10 @@ (define-syntax-class define-typed-struct-body - #:attributes (name mutable prefab type-only maker extra-maker nm + #:attributes (name type-name mutable prefab type-only maker extra-maker nm (tvars 1) (fields 1) (types 1)) (pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null))) - nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields) + nm:struct-name type-name:id ([fields:id : types:expr] ...) options:dtsi-fields) #:attr name #'nm.nm #:attr mutable (attribute options.mutable) #:attr prefab (attribute options.prefab) @@ -151,7 +151,7 @@ [typed-struct (define-typed-struct-internal . :define-typed-struct-body)] [typed-struct/exec - (define-typed-struct/exec-internal nm ([fields:id : types] ...) proc-type)] + (define-typed-struct/exec-internal nm type-name ([fields:id : types] ...) proc-type)] [typed-require (require/typed-internal name type)] [typed-require/struct diff --git a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index cb430d33..0d335ce1 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -52,8 +52,7 @@ (define (name-of-struct stx) (syntax-parse stx [(~or t:typed-struct t:typed-struct/exec) - #:with nm/par:parent #'t.nm - #'nm/par.name])) + #'t.type-name])) ;; parse name field of struct, determining whether a parent struct was specified @@ -81,7 +80,7 @@ ;; and optional constructor name ;; all have syntax loc of name ;; identifier listof[identifier] Option[identifier] -> struct-names -(define (get-struct-names nm flds maker* extra-maker) +(define (get-struct-names type-name nm flds maker* extra-maker) (define (split l) (let loop ([l l] [getters '()] [setters '()]) (if (null? l) @@ -90,7 +89,7 @@ (match (build-struct-names nm flds #f #f nm #:constructor-name maker*) [(list sty maker pred getters/setters ...) (let-values ([(getters setters) (split getters/setters)]) - (struct-names nm sty maker extra-maker pred getters setters))])) + (struct-names type-name sty maker extra-maker pred getters setters))])) ;; gets the fields of the parent type, if they exist ;; Option[Struct-Ty] -> Listof[Type] @@ -246,7 +245,7 @@ ;; tc/struct : Listof[identifier] (U identifier (list identifier identifier)) ;; Listof[identifier] Listof[syntax] ;; -> void -(define (tc/struct vars nm/par fld-names tys +(define (tc/struct vars nm/par type-name fld-names tys #:proc-ty [proc-ty #f] #:maker [maker #f] #:extra-maker [extra-maker #f] @@ -262,7 +261,7 @@ (define types ;; add the type parameters of this structure to the tvar env (extend-tvars tvars - (parameterize ([current-poly-struct `#s(poly ,nm ,new-tvars)]) + (parameterize ([current-poly-struct `#s(poly ,type-name ,new-tvars)]) ;; parse the field types (map parse-type tys)))) ;; instantiate the parent if necessary, with new-tvars @@ -277,7 +276,7 @@ ;; create the actual structure type, and the types of the fields ;; that the outside world will see ;; then register it - (define names (get-struct-names nm fld-names maker extra-maker)) + (define names (get-struct-names type-name nm fld-names maker extra-maker)) (cond [prefab? (define-values (parent-key parent-fields) @@ -322,7 +321,7 @@ (and parent (resolve-name (make-Name parent 0 #t)))) (define parent-tys (map fld-t (get-flds parent-type))) - (define names (get-struct-names nm fld-names #f #f)) + (define names (get-struct-names nm nm fld-names #f #f)) (define desc (struct-desc parent-tys tys null #t #f)) (define sty (mk/inner-struct-type names desc parent-type)) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 301c0b7a..7550a59d 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -36,14 +36,16 @@ (parameterize ([current-orig-stx form]) (syntax-parse form [t:typed-struct - (tc/struct (attribute t.tvars) #'t.nm (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...)) + (tc/struct (attribute t.tvars) #'t.nm #'t.type-name + (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...)) #:mutable (attribute t.mutable) #:maker (attribute t.maker) #:extra-maker (attribute t.extra-maker) #:type-only (attribute t.type-only) #:prefab? (attribute t.prefab))] [t:typed-struct/exec - (tc/struct null #'t.nm (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...)) + (tc/struct null #'t.nm #'t.type-name + (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...)) #:proc-ty #'t.proc-type)]))) (define (type-vars-of-struct form) diff --git a/typed-racket-test/succeed/require-typed-struct-custom-type.rkt b/typed-racket-test/succeed/require-typed-struct-custom-type.rkt new file mode 100644 index 00000000..c2f644fc --- /dev/null +++ b/typed-racket-test/succeed/require-typed-struct-custom-type.rkt @@ -0,0 +1,10 @@ +#lang typed/racket/base + +(require/typed + net/url-structs + [#:struct path/param + ([path : (U String 'up 'same)] + [param : (Listof String)]) + #:type-name Path/Param]) + +(ann (path/param "path" null) Path/Param) diff --git a/typed-racket-test/succeed/struct-custom-type.rkt b/typed-racket-test/succeed/struct-custom-type.rkt new file mode 100644 index 00000000..bfede8f3 --- /dev/null +++ b/typed-racket-test/succeed/struct-custom-type.rkt @@ -0,0 +1,12 @@ +#lang typed/racket/base + +(struct (A) s ([f : A]) #:type-name S) + +(define si : (S String) (s "foo")) +(ann (s-f si) String) + +(define-struct/exec exec () + [(λ (e x) (add1 x)) : (Exec Real -> Real)] + #:type-name Exec) + +((ann (exec) Exec) 3)