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

Fix require/typed in no-check mode for structs

Browse Source 
The constructor name was handled incorrectly for TR's current
defaults. Also support the extra keyword arguments.

original commit: 6e8ad865240aa9a92b6dd6fef91f42dcb117e4b2
This commit is contained in:
Asumu Takikawa 2014-04-29 21:50:50 -04:00
parent 36a34fd3ea
commit bab7477b80
2 changed files with 57 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
pkgs/typed-racket-pkgs/typed-racket-lib/typed/private/no-check-helper.rkt
View File

@ -4,7 +4,8 @@
(except-in typed-racket/base-env/prims
require/typed require/opaque-type require-typed-struct)
typed-racket/base-env/base-types-extra
(for-syntax racket/base syntax/parse syntax/struct))
(for-syntax racket/base syntax/parse syntax/struct
syntax/parse/experimental/template))
(provide (all-from-out racket/base)
(all-defined-out)
(all-from-out typed-racket/base-env/prims
@ -24,10 +25,9 @@
(pattern [nm:opt-rename ty]))
(define-syntax-class struct-clause
;#:literals (struct)
#:attributes (nm (body 1))
(pattern [#:struct nm:opt-rename (body ...)])
(pattern [struct nm:opt-rename (body ...)]
#:fail-unless (eq? 'struct (syntax-e #'struct)) #f))
#:attributes (nm (body 1) (opts 1))
(pattern [(~or #:struct (~datum struct)) nm:opt-rename (body ...)
opts:struct-option ...]))
(define-syntax-class opaque-clause
;#:literals (opaque)
#:attributes (ty pred opt)
@ -41,12 +41,16 @@
(pattern [opaque ty:id pred:id #:name-exists]
#:fail-unless (eq? 'opaque (syntax-e #'opaque)) #f
#:with opt #'(#:name-exists)))
(define-splicing-syntax-class struct-option
(pattern (~seq #:constructor-name cname:id))
(pattern (~seq #:extra-constructor-name extra-cname:id)))
(syntax-parse stx
[(_ lib (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
#'(begin
(require/opaque-type oc.ty oc.pred lib . oc.opt) ...
(require/typed sc.nm sc.ty lib) ...
(require-typed-struct strc.nm (strc.body ...) lib) ...)]
(template
(begin
(require/opaque-type oc.ty oc.pred lib . oc.opt) ...
(require/typed sc.nm sc.ty lib) ...
(require-typed-struct strc.nm (strc.body ...) (?@ . strc.opts) ... lib) ...))]
[(_ nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
#'(require (only-in lib nm.spec))]))
@ -55,7 +59,22 @@
(define-syntax (require-typed-struct stx)
(syntax-parse stx #:literals (:)
[(_ (~or nm:id (nm:id _:id)) ([fld : ty] ...) lib)
(with-syntax ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)])
#'(require (only-in lib struct-info maker pred sel ...)))]))
[(_ (~or nm:id (nm:id _:id)) ([fld : ty] ...)
(~or (~and (~seq) (~bind [cname #'#f] [extra-cname #'#f]))
(~and (~seq #:constructor-name cname)
(~bind [extra-cname #'#f]))
(~and (~seq #:extra-constructor-name extra-cname)
(~bind [cname #'#f])))
lib)
(with-syntax ([(struct-info maker pred sel ...)
(build-struct-names #'nm (syntax->list #'(fld ...)) #f #t
#:constructor-name
(if (syntax-e #'cname) #'cname #'nm))])
#`(require (only-in lib
struct-info
maker
#,@(if (syntax-e #'extra-cname)
#'(extra-cname)
#'())
pred sel ...)))]))

26
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/require-typed-no-check.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang typed/racket/no-check
;; This test checks require/typed options under no-check mode
(module untyped racket
(define f values)
(struct bar (x y))
(struct baz (x y))
(define-struct quux (x y))
(provide f
(struct-out bar)
(struct-out baz)
(struct-out quux)))
;; opaque is tested in pr14463.rkt
(require/typed 'untyped
[f (-> String String)]
[(f g) (-> String String)]
[struct bar ([x : Integer] [y : Integer])]
[#:struct baz ([x : Integer] [y : Integer])]
[#:struct quux ([x : Integer] [y : Integer])
#:constructor-name make-quux])
(f 3) (g 3)
(bar 1 2)
(make-quux 1 2)