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

Make require/typed work at top-level

Browse Source 
Closes PR 13747
This commit is contained in:
Asumu Takikawa 2013-05-14 09:23:15 -04:00
parent 2c042998b9
commit 67beb11cf6
3 changed files with 48 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/tests/typed-racket/succeed/pr13747.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket
;; Test that `require/typed` works at the top-level
(require racket/sandbox)
(define evaluator
(call-with-trusted-sandbox-configuration
(λ () (make-evaluator 'typed/racket))))
(evaluator '(require/typed racket/base [values (Integer -> Integer)]))
(evaluator '(values 1))

36
collects/typed-racket/base-env/prims.rkt
View File

@ -133,7 +133,21 @@ This file defines two sorts of primitives. All of them are provided into any mod
(raise-syntax-error #f "at least one specification is required" stx)) (raise-syntax-error #f "at least one specification is required" stx))
#`(begin c.spec ...)] #`(begin c.spec ...)]
[(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
(with-syntax ([cnt* (generate-temporary #'nm.nm)] (with-syntax ([cnt* (if (eq? (syntax-local-context) 'top-level)
;; if we're at the top-level, we can generate the contract
;; immediately, but otherwise the contract will be fixed up
;; by the module type-checking pass later
(let ([typ (parse-type #'ty)])
(ignore
(type->contract
typ
;; this is for a `require/typed', so the value is not from the typed side
#:typed-side #f
(lambda ()
(tc-error/stx #'ty "Type ~a could not be converted to a contract." typ)))))
;; in the fix-up case, the contract is just an identifier
;; that is defined below
(generate-temporary #'nm.nm))]
[hidden (generate-temporary #'nm.nm)] [hidden (generate-temporary #'nm.nm)]
[sm (if (attribute parent) [sm (if (attribute parent)
#'(#:struct-maker parent) #'(#:struct-maker parent)
@ -143,20 +157,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typechecker:contract-def)]) 'typechecker:contract-def)])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
#,(syntax-property (if (eq? (syntax-local-context) 'top-level) ;; define `cnt*` to be fixed up later by the module
(let ([typ (parse-type #'ty)]) ;; type-checking (not defined at top-level since it
#`(define cnt* ;; doesn't work with local expansion)
#,(type->contract #,@(ignore (if (eq? (syntax-local-context) 'top-level)
typ #'()
;; this is for a `require/typed', so the value is not from the typed side #`(#,(syntax-property #'(define cnt* #f) prop-name #'ty))))
#:typed-side #f
(lambda () (tc-error/stx #'ty "Type ~a could not be converted to a contract." typ)))))
(syntax-property #'(define cnt* #f)
prop-name #'ty))
'typechecker:ignore #t)
#,(internal #'(require/typed-internal hidden ty . sm)) #,(internal #'(require/typed-internal hidden ty . sm))
#,(syntax-property #'(require/contract nm.spec hidden cnt* lib) #,(ignore #'(require/contract nm.spec hidden cnt* lib))))))]))
'typechecker:ignore #t)))))]))
(values (r/t-maker #t) (r/t-maker #f)))) (values (r/t-maker #t) (r/t-maker #f))))
(define-syntax-rule (require/typed/provide lib [nm t] ...) (define-syntax-rule (require/typed/provide lib [nm t] ...)

21
collects/typed-racket/utils/require-contract.rkt
View File

@ -48,16 +48,21 @@
(syntax-parse stx (syntax-parse stx
[(require/contract nm:renameable hidden:id cnt lib) [(require/contract nm:renameable hidden:id cnt lib)
#`(begin (require (only-in lib [nm.orig-nm nm.orig-nm-r])) #`(begin (define-syntax nm.nm
(define-syntax nm.nm
(make-rename-transformer (make-rename-transformer
(syntax-property (syntax-property (quote-syntax hidden) (syntax-property (syntax-property (quote-syntax hidden)
'not-free-identifier=? #t) 'not-free-identifier=? #t)
'not-provide-all-defined #t))) 'not-provide-all-defined #t)))
(define-ignored hidden (define-ignored hidden
(contract cnt (let ()
(get-alternate nm.orig-nm-r) ;; Use `local-require` in order to use this internal
'(interface for #,(syntax->datum #'nm.nm)) ;; definition context instead of defining at the top-level.
(current-contract-region) ;; This avoids top-level hopelessness to do with
(quote nm.nm) ;; `local-expand` and definitions.
(quote-srcloc nm.nm))))])) (local-require (only-in lib [nm.orig-nm nm.orig-nm-r]))
(contract cnt
(get-alternate nm.orig-nm-r)
'(interface for #,(syntax->datum #'nm.nm))
(current-contract-region)
(quote nm.nm)
(quote-srcloc nm.nm)))))]))