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

Add `struct:'

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-22 13:42:10 -04:00
parent b286673c69
commit 6e1954d79b
5 changed files with 95 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/tests/typed-scheme/succeed/racket-struct.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang typed/racket
(struct: x ([y : Number]))
(x 1)
(x-y (x 7))
(ann x? (Any -> Boolean : x))

87
collects/typed-scheme/private/prims.rkt
View File

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

20
collects/typed-scheme/scribblings/ts-reference.scrbl
View File

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

3
collects/typed-scheme/typecheck/tc-structs.rkt
View File

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

10
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

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