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

Added typed/untyped-utils (just require/untyped-contract for now)

Browse Source 
original commit: cdcf8f64327565e4665924b419468fbb9124129c
This commit is contained in:
Neil Toronto 2012-10-14 16:49:58 -04:00 committed by Vincent St-Amour
parent 905416ec80
commit 2d549d13b1
1 changed files with 48 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/typed/untyped-utils.rkt Normal file
View File

@ -0,0 +1,48 @@
#lang racket/base
(require (for-syntax racket/base
syntax/parse
racket/syntax))
(provide require/untyped-contract)
(define-syntax (require/untyped-contract stx)
(syntax-parse stx #:literals (begin)
[(_ (begin form ...) from-module-spec:expr [name:id T:expr] ...)
(with-syntax* ([(typed-name ...) (generate-temporaries #'(name ...))]
[(untyped-name ...) (generate-temporaries #'(name ...))]
[(untyped2-name ...) (generate-temporaries #'(name ...))]
[(macro-name ...) (generate-temporaries #'(name ...))]
[typed-module (generate-temporary #'typed-module)]
[untyped-module (generate-temporary #'untyped-module)])
(syntax/loc stx
(begin
(module typed-module typed/racket/base
(begin form ...)
(require (only-in from-module-spec name ...))
(provide untyped-name ...)
(: untyped-name T) ...
(define untyped-name name) ...)
(module untyped-module racket/base
(require (for-syntax racket/base
typed-racket/utils/tc-utils)
(rename-in from-module-spec [name typed-name] ...)
(rename-in (submod ".." typed-module) [untyped-name untyped2-name] ...))
(provide macro-name ...)
(define-for-syntax (rename-head stx id)
(syntax-case stx ()
[(_ . args) (quasisyntax/loc stx (#,id . args))]
[_ (quasisyntax/loc stx #,id)]))
(define-syntax (macro-name stx)
(if (unbox typed-context?)
(rename-head stx #'typed-name)
(rename-head stx #'untyped2-name)))
...)
(require (rename-in (submod "." untyped-module) [macro-name name] ...)))))]
[(_ from-module-spec:expr [name:id T:expr] ...)
(syntax/loc stx (require/untyped-contract (begin) from-module-spec [name T] ...))]))