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

Add syntax for poly structs in require/typed

Browse Source 
Currently only works in unsafe requires. In other cases
it will emit an error instead.

Also bump version
This commit is contained in:
Asumu Takikawa 2016-04-07 13:15:29 -04:00
parent 98d0657141
commit 10eb2542c6
12 changed files with 77 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
typed-racket-compatibility/info.rkt
View File

@ -11,4 +11,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.6")

4
typed-racket-doc/info.rkt
View File

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

9
typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl
View File

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

3
typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl
View File

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

2
typed-racket-lib/info.rkt
View File

@ -11,4 +11,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.6")

25
typed-racket-lib/typed-racket/base-env/prims-contract.rkt
View File

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

11
typed-racket-lib/typed-racket/private/type-contract.rkt
View File

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

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

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

2
typed-racket-more/info.rkt
View File

@ -21,4 +21,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.6")

2
typed-racket-test/info.rkt
View File

@ -28,7 +28,7 @@
(define pkg-authors '(samth stamourv endobson asumu))
(define version "1.5")
(define version "1.6")
;; Collection info

28
typed-racket-test/succeed/unsafe-require-poly-struct.rkt Normal file
View File

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

2
typed-racket/info.rkt
View File

@ -11,4 +11,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.6")