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

Add support for #:extra-constructor-name to struct

Browse Source 
Simplify TR's define-struct to expand to struct
This commit is contained in:
Asumu Takikawa 2015-12-07 00:00:56 -05:00
parent 70afdf6f70
commit fc809e370e
4 changed files with 68 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -72,10 +72,12 @@
(define-splicing-syntax-class struct-options
#:description "typed structure type options"
#:attributes (guard mutable? transparent? prefab? [prop 1] [prop-val 1])
#:attributes (guard mutable? transparent? prefab? ecname
[prop 1] [prop-val 1])
(pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?)))
(~optional (~seq (~and #:transparent transparent?)))
(~optional (~seq (~and #:prefab prefab?)))
(~optional (~seq #:extra-constructor-name ecname))
;; FIXME: unsound, but relied on in core libraries
;; #:guard ought to be supportable with some work
;; #:property is harder
@ -121,38 +123,43 @@
;; User-facing macros for defining typed structure types
(define-syntaxes (define-typed-struct -struct)
(values
(lambda (stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[cname (second (build-struct-names #'nm.name null #t #t))]
[prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())])
(with-syntax ([d-s (ignore-some
(syntax/loc stx (define-struct nm (fs.fld ...) . opts)))]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...) nm (fs.form ...)
#:maker #,cname
#,@mutable?
#,@prefab?))])
#'(begin d-s dtsi)))]))
(lambda (stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())])
(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?))])
#'(begin d-s dtsi)))]))))
(define-syntax (define-typed-struct stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) opts:struct-options)
(quasisyntax/loc stx
(-struct #,@#'vars
#,@(if (stx-pair? #'nm)
#'nm
(list #'nm))
(fs ...)
;; If there's already an extra constructor name supplied,
;; then Racket's `define-struct` doesn't define a `make-`
;; constructor either so don't pass anything extra.
#,@(if (attribute opts.ecname)
null
(list #'#:extra-constructor-name
(second (build-struct-names #'nm.name null #t #t))))
. opts))]))
(define-syntax (-struct stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())]
[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?
#,@extra-maker))])
#'(begin d-s dtsi)))]))
;; this has to live here because it's used below

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

@ -74,12 +74,13 @@
;;; Helpers
(define-splicing-syntax-class dtsi-fields
#:attributes (mutable prefab type-only maker)
#:attributes (mutable prefab type-only maker extra-maker)
(pattern
(~seq
(~or (~optional (~and #:mutable (~bind (mutable #t))))
(~optional (~and #:prefab (~bind (prefab #t))))
(~optional (~and #:type-only (~bind (type-only #t))))
(~optional (~seq #:extra-maker extra-maker))
(~optional (~seq #:maker maker))) ...)))
(define-syntax-class struct-name
@ -88,14 +89,16 @@
(define-syntax-class define-typed-struct-body
#:attributes (name mutable prefab type-only maker nm (tvars 1) (fields 1) (types 1))
#:attributes (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)
#:attr name #'nm.nm
#:attr mutable (attribute options.mutable)
#:attr prefab (attribute options.prefab)
#:attr type-only (attribute options.type-only)
#:attr maker (or (attribute options.maker) #'nm.nm)))
#:attr maker (or (attribute options.maker) #'nm.nm)
#:attr extra-maker (attribute options.extra-maker)))
(define-syntax-class dviu-import/export
(pattern (sig-id:id member-id:id ...)

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

@ -35,10 +35,11 @@
;; type-name : Id
;; struct-type : Id
;; constructor : Id
;; extra-constructor : (Option Id)
;; predicate : Id
;; getters : Listof[Id]
;; setters : Listof[Id] or #f
(struct struct-names (type-name struct-type constructor predicate getters setters) #:transparent)
(struct struct-names (type-name struct-type constructor extra-constructor predicate getters setters) #:transparent)
;;struct-fields: holds all the relevant information about a struct type's types
(struct struct-desc (parent-fields self-fields tvars mutable proc-ty) #:transparent)
@ -79,9 +80,8 @@
;; generate struct names given type name, field names
;; and optional constructor name
;; all have syntax loc of name
;; identifier listof[identifier] Option[identifier] ->
;; (values identifier identifier list[identifier] list[identifier])
(define (get-struct-names nm flds maker*)
;; identifier listof[identifier] Option[identifier] -> struct-names
(define (get-struct-names nm flds maker* extra-maker)
(define (split l)
(let loop ([l l] [getters '()] [setters '()])
(if (null? l)
@ -90,7 +90,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 pred getters setters))]))
(struct-names nm sty maker extra-maker pred getters setters))]))
;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type]
@ -192,12 +192,23 @@
(make-def-binding s (poly-wrapper (->* (list poly-base t) -Void))))
null))))
(define extra-constructor (struct-names-extra-constructor names))
(add-struct-constructor! (struct-names-constructor names))
(when extra-constructor
(add-struct-constructor! extra-constructor))
(define constructor-binding
(make-def-binding (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base))))
(make-def-binding (struct-names-constructor names)
(poly-wrapper (->* all-fields poly-base))))
(define constructor-bindings
(cons constructor-binding
(if extra-constructor
(list (make-def-binding extra-constructor
(poly-wrapper (->* all-fields poly-base))))
null)))
(for ([b (cons constructor-binding bindings)])
(for ([b (append constructor-bindings bindings)])
(register-type (binding-name b) (def-binding-ty b)))
(append
@ -238,6 +249,7 @@
(define (tc/struct vars nm/par fld-names tys
#:proc-ty [proc-ty #f]
#:maker [maker #f]
#:extra-maker [extra-maker #f]
#:mutable [mutable #f]
#:type-only [type-only #f]
#:prefab? [prefab? #f])
@ -265,7 +277,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))
(define names (get-struct-names nm fld-names maker extra-maker))
(cond [prefab?
(define-values (parent-key parent-fields)
@ -310,7 +322,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))
(define names (get-struct-names 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))

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

@ -39,6 +39,7 @@
(tc/struct (attribute t.tvars) #'t.nm (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