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

Allow the types created for structs to be specified manually

Browse Source 
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
This commit is contained in:
Alexis King 2015-12-30 12:54:06 -08:00
parent 6c4e584946
commit a3ca5aeefc
9 changed files with 178 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl
View File

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

2
typed-racket-lib/info.rkt
View File

@ -12,4 +12,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.3")
(define version "1.4")

55
typed-racket-lib/typed-racket/base-env/prims-contract.rkt
View File

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

76
typed-racket-lib/typed-racket/base-env/prims-struct.rkt
View File

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

6
typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
View File

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

15
typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View File

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

6
typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

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

10
typed-racket-test/succeed/require-typed-struct-custom-type.rkt Normal file
View File

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

12
typed-racket-test/succeed/struct-custom-type.rkt Normal file
View File

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