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

Fix require/typed/provide in no-check context.

Browse Source 
Closes PR 14821.
This commit is contained in:
Sam Tobin-Hochstadt 2014-11-03 09:14:13 -05:00
parent 96c3808460
commit 2221fa279c
1 changed files with 50 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4,7 +4,7 @@
(require
(except-in typed-racket/base-env/prims
require/typed require/opaque-type require-typed-struct)
require/typed require/opaque-type require-typed-struct require/typed/provide)
typed-racket/base-env/base-types-extra
(for-syntax racket/base syntax/parse syntax/struct
syntax/parse/experimental/template))
@ -14,39 +14,55 @@
typed-racket/base-env/base-types-extra))
(define-syntax (require/typed stx)
(define-syntax-class opt-rename
#:attributes (nm spec)
(pattern nm:id
#:with spec #'nm)
(pattern (orig-nm:id internal-nm:id)
#:with spec #'(orig-nm internal-nm)
#:with nm #'internal-nm))
(define-syntax-class simple-clause
#:attributes (nm ty)
(pattern [nm:opt-rename ty]))
(define-syntax-class struct-clause
#:attributes (nm (body 1) (opts 1))
(pattern [(~or #:struct (~datum struct)) nm:opt-rename (body ...)
opts:struct-option ...]))
(define-syntax-class opaque-clause
#:attributes (ty pred opt)
(pattern [(~or #:opaque (~datum opaque)) ty:id pred:id]
#:with opt #'())
(pattern [(~or #:opaque (~datum opaque)) ty:id pred:id #:name-exists]
#: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) ...)
(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))]))
(define-syntaxes (require/typed require/typed/provide)
(let ()
(define-syntax-class opt-rename
#:attributes (nm spec)
(pattern nm:id
#:with spec #'nm)
(pattern (orig-nm:id internal-nm:id)
#:with spec #'(orig-nm internal-nm)
#:with nm #'internal-nm))
(define-syntax-class simple-clause
#:attributes (nm ty name)
(pattern [nm:opt-rename ty]
#:with name (attribute nm.nm)))
(define-syntax-class struct-clause
#:attributes (nm (body 1) (opts 1))
(pattern [(~or #:struct (~datum struct)) nm:opt-rename (body ...)
opts:struct-option ...]))
(define-syntax-class opaque-clause
#:attributes (ty pred opt)
(pattern [(~or #:opaque (~datum opaque)) ty:id pred:id]
#:with opt #'())
(pattern [(~or #:opaque (~datum opaque)) ty:id pred:id #:name-exists]
#:with opt #'(#:name-exists)))
(define-splicing-syntax-class struct-option
(pattern (~seq #:constructor-name cname:id))
(pattern (~seq #:extra-constructor-name extra-cname:id)))
(values
(syntax-parser
[(_ lib (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
(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))])
(syntax-parser
[(_ lib (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
(template
(begin
(require/opaque-type oc.ty oc.pred lib . oc.opt) ...
(provide oc.pred) ...
(require/typed sc.nm sc.ty lib) ...
(provide sc.nm) ...
(require-typed-struct strc.nm (strc.body ...) (?@ . strc.opts) ... lib) ...
(provide (struct-out strc.nm)) ...))]
[(_ nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
#'(begin (require (only-in lib nm.spec))
(provide nm.nm))]))))
(define-syntax-rule (require/opaque-type ty pred lib . _)
(require (only-in lib pred)))