From 10eb2542c615d1cfbc1b68b6da034a935174f54e Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 7 Apr 2016 13:15:29 -0400 Subject: [PATCH] Add syntax for poly structs in require/typed Currently only works in unsafe requires. In other cases it will emit an error instead. Also bump version --- typed-racket-compatibility/info.rkt | 2 +- typed-racket-doc/info.rkt | 4 +-- .../scribblings/reference/special-forms.scrbl | 9 ++++-- .../scribblings/reference/unsafe.scrbl | 3 +- typed-racket-lib/info.rkt | 2 +- .../typed-racket/base-env/prims-contract.rkt | 25 +++++++++++++---- .../typed-racket/private/type-contract.rkt | 11 ++++++-- .../typed-racket/typecheck/tc-toplevel.rkt | 9 ++++-- typed-racket-more/info.rkt | 2 +- typed-racket-test/info.rkt | 2 +- .../succeed/unsafe-require-poly-struct.rkt | 28 +++++++++++++++++++ typed-racket/info.rkt | 2 +- 12 files changed, 77 insertions(+), 22 deletions(-) create mode 100644 typed-racket-test/succeed/unsafe-require-poly-struct.rkt diff --git a/typed-racket-compatibility/info.rkt b/typed-racket-compatibility/info.rkt index 18ba31f6..d494ffd4 100644 --- a/typed-racket-compatibility/info.rkt +++ b/typed-racket-compatibility/info.rkt @@ -11,4 +11,4 @@ (define pkg-authors '(samth stamourv)) -(define version "1.5") +(define version "1.6") diff --git a/typed-racket-doc/info.rkt b/typed-racket-doc/info.rkt index 7cfbae52..c36cd7fd 100644 --- a/typed-racket-doc/info.rkt +++ b/typed-racket-doc/info.rkt @@ -12,7 +12,7 @@ "at-exp-lib" ("scribble-lib" #:version "1.16") "pict-lib" - ("typed-racket-lib" #:version "1.5") + ("typed-racket-lib" #:version "1.6") "typed-racket-compatibility" "typed-racket-more" "racket-doc" @@ -24,4 +24,4 @@ (define pkg-authors '(samth stamourv)) -(define version "1.5") +(define version "1.6") diff --git a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl index c5b7816a..914d2675 100644 --- a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl +++ b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl @@ -586,14 +586,16 @@ optionally-renamed identifier. @defform/subs[#:literals (struct :) (require/typed m rt-clause ...) ([rt-clause [maybe-renamed t] - [#:struct name-id ([f : t] ...) + [#:struct maybe-tvars name-id ([f : t] ...) struct-option ...] - [#:struct (name-id parent) ([f : t] ...) + [#:struct maybe-tvars (name-id parent) ([f : t] ...) struct-option ...] [#:opaque t pred] [#:signature name ([id : t] ...)]] [maybe-renamed id (orig-id new-id)] + [maybe-tvars (code:line) + (type-variable ...)] [struct-option (code:line #:constructor-name constructor-id) (code:line #:extra-constructor-name constructor-id) @@ -671,7 +673,8 @@ a @racket[require/typed] form. Here is an example of using @racket[file-or-directory-modify-seconds] has some arguments which are optional, so we need to use @racket[case->]. -@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]} +@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.} + #:changed "1.6" "Added syntax for struct type variables, only works in unsafe requires"]} @defform[(require/typed/provide m rt-clause ...)]{ Similar to @racket[require/typed], but also provides the imported identifiers. diff --git a/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl b/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl index 4d417c46..4636383e 100644 --- a/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl +++ b/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl @@ -31,7 +31,8 @@ behavior and may even crash Typed Racket. (values "foo") ] - @history[#:added "1.3"] + @history[#:added "1.3" + #:changed "1.6" "Added support for struct type variables"] } @defform[(unsafe-provide provide-spec ...)]{ diff --git a/typed-racket-lib/info.rkt b/typed-racket-lib/info.rkt index 52927ceb..e5686824 100644 --- a/typed-racket-lib/info.rkt +++ b/typed-racket-lib/info.rkt @@ -11,4 +11,4 @@ (define pkg-authors '(samth stamourv)) -(define version "1.5") +(define version "1.6") diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt index 42f8bc59..4d554dfb 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -139,8 +139,9 @@ #'())))) (define-syntax-class (struct-clause legacy) - #:attributes (nm type (body 1) (constructor-parts 1)) + #:attributes (nm type (body 1) (constructor-parts 1) (tvar 1)) (pattern [(~or (~datum struct) #:struct) + (~optional (~seq (tvar ...)) #:defaults ([(tvar 1) '()])) nm:opt-parent (body ...) (~var opts (struct-opts legacy #'nm.nm))] #:with (constructor-parts ...) #'opts.ctor-value @@ -164,7 +165,8 @@ (pattern oc:opaque-clause #:attr spec #`(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 ... + #`(require-typed-struct strc.nm (strc.tvar ...) + (strc.body ...) strc.constructor-parts ... #:type-name strc.type #,@(if unsafe? #'(unsafe-kw) #'()) #,lib)) @@ -444,6 +446,7 @@ (define ((rts legacy) stx) (syntax-parse stx #:literals (:) [(_ name:opt-parent + (~optional (~seq (tvar:id ...)) #:defaults ([(tvar 1) '()])) ([fld : ty] ...) (~var input-maker (constructor-term legacy #'name.nm)) (~optional (~seq #:type-name type:id) #:defaults ([type #'name.nm])) @@ -468,7 +471,17 @@ [real-maker (if (syntax-e #'id-is-ctor?) #'internal-maker #'maker-name)] [extra-maker (and (attribute input-maker.extra) (not (bound-identifier=? #'make-name #'nm)) - #'maker-name)]) + #'maker-name)] + ;; the type for a polymorphic use of the struct name + [poly-type #`(type tvar ...)] + ;; the struct type to use for the constructor/selectors + [self-type (if (null? (syntax->list #'(tvar ...))) + #'type + #'poly-type)]) + (when (and (not (attribute unsafe.unsafe?)) + (pair? (syntax->list #'(tvar ...)))) + (tc-error/stx stx "polymorphic structs are not supported")) + (define (maybe-add-quote-syntax stx) (if (and stx (syntax-e stx)) #`(quote-syntax #,stx) stx)) @@ -524,7 +537,7 @@ (make-struct-info-self-ctor #'internal-maker si) si)) - (dtsi* () spec type ([fld : ty] ...) #:maker maker-name #:type-only) + (dtsi* (tvar ...) 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 : type))) (require/typed #:internal (maker-name real-maker) type lib @@ -544,8 +557,8 @@ #'(begin)) #,@(if (attribute unsafe.unsafe?) - #'((require/typed #:internal sel (type -> ty) lib unsafe-kw) ...) - #'((require/typed lib [sel (type -> ty)]) ...)))))])) + #'((require/typed #:internal sel (All (tvar ...) (self-type -> ty)) lib unsafe-kw) ...) + #'((require/typed lib [sel (All (tvar ...) (self-type -> ty))]) ...)))))])) (values (rts #t) (rts #f)))) diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 92eaeb4d..91a10da1 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -88,9 +88,14 @@ (syntax-parse stx #:literals (define-values) [(define-values (n) _) (define typ - (if maker? - ((map fld-t (Struct-flds (lookup-type-name (Name-id *typ)))) #f . t:->* . *typ) - *typ)) + (cond [maker? + (match (lookup-type-name (Name-id *typ)) + [(Poly-names: names body) + (make-Poly names + ((map fld-t (Struct-flds body)) #f . t:->* . *typ))] + [ty + ((map fld-t (Struct-flds ty)) #f . t:->* . *typ)])] + [else *typ])) (match-define (list defs ctc) (type->contract typ diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 7633e4d2..aade0448 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -97,8 +97,13 @@ [r:typed-require/struct (let* ([t (parse-type #'r.type)] - [flds (map fld-t (Struct-flds (lookup-type-name (Name-id t))))] - [mk-ty (flds #f . ->* . t)]) + [struct-type (lookup-type-name (Name-id t))] + [mk-ty (match struct-type + [(Poly-names: ns body) + (make-Poly ns + ((map fld-t (Struct-flds body)) #f . ->* . (make-App t (map make-F ns) #f)))] + [else + ((map fld-t (Struct-flds struct-type)) #f . ->* . t)])]) (register-type #'r.name mk-ty) (list (make-def-binding #'r.name mk-ty)))] diff --git a/typed-racket-more/info.rkt b/typed-racket-more/info.rkt index a5c9e02b..f2b2ccef 100644 --- a/typed-racket-more/info.rkt +++ b/typed-racket-more/info.rkt @@ -21,4 +21,4 @@ (define pkg-authors '(samth stamourv)) -(define version "1.5") +(define version "1.6") diff --git a/typed-racket-test/info.rkt b/typed-racket-test/info.rkt index a4368ae4..4a70932b 100644 --- a/typed-racket-test/info.rkt +++ b/typed-racket-test/info.rkt @@ -28,7 +28,7 @@ (define pkg-authors '(samth stamourv endobson asumu)) -(define version "1.5") +(define version "1.6") ;; Collection info diff --git a/typed-racket-test/succeed/unsafe-require-poly-struct.rkt b/typed-racket-test/succeed/unsafe-require-poly-struct.rkt new file mode 100644 index 00000000..fb084c06 --- /dev/null +++ b/typed-racket-test/succeed/unsafe-require-poly-struct.rkt @@ -0,0 +1,28 @@ +#lang typed/racket/base + +;; Test unsafe require with a polymorphic struct + +(require typed/racket/unsafe) + +(module a racket/base + (struct foo (x y)) + (define a-foo (foo 1 2)) + (provide (struct-out foo) a-foo)) + +(unsafe-require/typed (submod "." a) + [#:struct (X Y) foo ([x : X] [y : Y])] + [a-foo (foo Integer Integer)]) + +(add1 (foo-x (foo 3 4))) +(add1 (foo-y a-foo)) + +(module b racket/base + (struct bar (x y)) + (struct baz bar (z)) + (provide (struct-out bar) (struct-out baz))) + +(unsafe-require/typed (submod "." b) + [#:struct (X Y) bar ([x : X] [y : Y])] + [#:struct (X Y Z) (baz bar) ([z : Z])]) + +(add1 (bar-x (baz 1 2 3))) diff --git a/typed-racket/info.rkt b/typed-racket/info.rkt index fe344130..99cba353 100644 --- a/typed-racket/info.rkt +++ b/typed-racket/info.rkt @@ -11,4 +11,4 @@ (define pkg-authors '(samth stamourv)) -(define version "1.5") +(define version "1.6")