diff --git a/collects/tests/typed-scheme/succeed/racket-struct.rkt b/collects/tests/typed-scheme/succeed/racket-struct.rkt new file mode 100644 index 0000000000..354a669886 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/racket-struct.rkt @@ -0,0 +1,7 @@ +#lang typed/racket + +(struct: x ([y : Number])) + +(x 1) +(x-y (x 7)) +(ann x? (Any -> Boolean : x)) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index 4905f2046f..a1ae955029 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -26,6 +26,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [define-typed-struct/exec define-struct/exec:])) (require "../utils/utils.rkt" + racket/base (for-syntax syntax/parse syntax/private/util @@ -296,31 +297,64 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-typed-struct-internal (vars ...) #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))])) -(define-syntax (define-typed-struct stx) - (define-syntax-class fld-spec - #:literals (:) - #:description "[field-name : type]" - (pattern [fld:id : ty])) - (define-syntax-class struct-name - #:description "struct name (with optional super-struct name)" - #:attributes (name super) - (pattern (name:id super:id)) - (pattern name:id - #:with super #f)) - (syntax-parse stx - [(_ nm:struct-name (fs:fld-spec ...) . opts) - (let ([mutable (if (memq '#:mutable (syntax->datum #'opts)) - '(#:mutable) - '())]) - (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) - 'typechecker:ignore #t)] - [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))]) - #'(begin d-s dtsi)))] - [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts) - (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) - 'typechecker:ignore #t)] - [dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))]) - #'(begin d-s dtsi))])) +(define-syntaxes (define-typed-struct struct:) + (let () + (define-syntax-class fld-spec + #:literals (:) + #:description "[field-name : type]" + (pattern [fld:id : ty])) + (define-syntax-class struct-name + #:description "struct name (with optional super-struct name)" + #:attributes (name super) + (pattern (name:id super:id)) + (pattern name:id + #:with super #f)) + (define-splicing-syntax-class struct-name/new + #:description "struct name (with optional super-struct name)" + (pattern (~seq name:id super:id) + #:attr old-spec #'(name super) + #:with new-spec #'(name super)) + (pattern name:id + #:with super #f + #:attr old-spec #'name + #:with new-spec #'(name))) + (define (mutable? opts) + (if (memq '#:mutable (syntax->datum opts)) '(#:mutable) '())) + (values + (lambda (stx) + (syntax-parse stx + [(_ nm:struct-name (fs:fld-spec ...) . opts) + (let ([mutable (mutable? #'opts)]) + (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) + 'typechecker:ignore #t)] + [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))]) + #'(begin d-s dtsi)))] + [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts) + (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) + 'typechecker:ignore #t)] + [dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))]) + #'(begin d-s dtsi))])) + (lambda (stx) + (syntax-parse stx + [(_ nm:struct-name/new (fs:fld-spec ...) . opts) + (let ([mutable (mutable? #'opts)] + [cname (datum->syntax #f (syntax-e #'nm.name))]) + (with-syntax ([d-s (syntax-property (quasisyntax/loc stx + (struct #,@(attribute nm.new-spec) (fs.fld ...) + #:extra-constructor-name #,cname + . opts)) + 'typechecker:ignore #t)] + [dtsi (quasisyntax/loc stx (dtsi* () nm.old-spec (fs ...) #:maker #,cname #,@mutable))]) + #'(begin d-s dtsi)))] + [(_ (vars:id ...) nm:struct-name/new (fs:fld-spec ...) . opts) + (let ([cname (datum->syntax #f (syntax-e #'nm.name))]) + (with-syntax ([d-s (syntax-property (quasisyntax/loc stx + (struct #,@(attribute nm.new-spec) (fs.fld ...) + #:extra-constructor-name #,cname + . opts)) + 'typechecker:ignore #t)] + [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname))]) + #'(begin d-s dtsi)))]))))) (define-syntax (require-typed-struct stx) (syntax-parse stx #:literals (:) @@ -347,8 +381,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ (nm parent) ([fld : ty] ...) lib) (and (identifier? #'nm) (identifier? #'parent)) (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] - [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] - #;[(parent-tys ...) (Struct-flds (parse-type #'parent))]) + [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]) #`(begin (require (only-in lib struct-info)) (define-syntax nm (make-struct-info diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 43b7cb403b..8d8ae382f7 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -367,14 +367,26 @@ types. In most cases, use of @racket[:] is preferred to use of @racket[define:] @subsection{Structure Definitions} @defform/subs[ -(define-struct: maybe-type-vars name-spec ([f : t] ...)) +(struct: maybe-type-vars name-spec ([f : t] ...) options ...) ([maybe-type-vars code:blank (v ...)] - [name-spec name (name parent)])]{ + [name-spec name (code:line name parent)] + [options #:transparent #:mutable])]{ Defines a @rtech{structure} with the name @racket[name], where the - fields @racket[f] have types @racket[t]. When @racket[parent], the + fields @racket[f] have types @racket[t], similar to the behavior of @racket[struct]. + When @racket[parent] is present, the structure is a substructure of @racket[parent]. When @racket[maybe-type-vars] is present, the structure is polymorphic in the type - variables @racket[v].} + variables @racket[v]. + +Options provided have the same meaning as for the @racket[struct] form.} + + +@defform/subs[ +(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 @racket[define-struct].} @defform/subs[ (define-struct/exec: name-spec ([f : t] ...) [e : proc-t]) diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 45c3a44682..66ddbb108d 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -173,7 +173,7 @@ ;; check and register types for a polymorphic define struct ;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void -(define (tc/poly-struct vars nm/par flds tys) +(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f]) ;; parent field types can't actually be determined here (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par)) ;; create type variables for the new type parameters @@ -197,6 +197,7 @@ ;; that the outside world will see ;; then register them (mk/register-sty nm flds parent-name parent-field-types types + #:maker maker ;; wrap everything in the approriate forall #:wrapper (λ (t) (make-Poly tvars t)) #:type-wrapper (λ (t) (make-App t new-tvars #f)) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 03569cac40..e970654bf7 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -94,6 +94,16 @@ (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)] + [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) + #:maker m)) + (#%plain-app values))) + (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + #:maker #'m)] + [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) + #:maker m)) + (#%plain-app values))) + (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + #:maker #'m)] [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only)) (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]