From fc809e370e3a0491ddd7dea3d4ba181a63cd5379 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 7 Dec 2015 00:00:56 -0500 Subject: [PATCH] Add support for #:extra-constructor-name to struct Simplify TR's define-struct to expand to struct --- .../typed-racket/base-env/prims-struct.rkt | 73 ++++++++++--------- .../typed-racket/typecheck/internal-forms.rkt | 9 ++- .../typed-racket/typecheck/tc-structs.rkt | 30 +++++--- .../typed-racket/typecheck/tc-toplevel.rkt | 1 + 4 files changed, 68 insertions(+), 45 deletions(-) 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 0cc2f20d..f50daf31 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-struct.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-struct.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt index 85e1e0c4..d2316d6e 100644 --- a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt +++ b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt @@ -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 ...) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index d8bd34c5..cb430d33 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -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)) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 5a65b5f9..301c0b7a 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -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