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

Refactor to reduce right-ward drift

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-14 14:36:14 -04:00
parent 67beb11cf6
commit e0cff038c8
1 changed files with 34 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -133,38 +133,40 @@ 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* (if (eq? (syntax-local-context) 'top-level) (define/with-syntax cnt*
;; if we're at the top-level, we can generate the contract (if (eq? (syntax-local-context) 'top-level)
;; immediately, but otherwise the contract will be fixed up ;; if we're at the top-level, we can generate the contract
;; by the module type-checking pass later ;; immediately, but otherwise the contract will be fixed up
(let ([typ (parse-type #'ty)]) ;; by the module type-checking pass later
(ignore (let ([typ (parse-type #'ty)])
(type->contract (ignore
typ (type->contract
;; this is for a `require/typed', so the value is not from the typed side typ
#:typed-side #f ;; this is for a `require/typed', so the value is not
(lambda () ;; from the typed side
(tc-error/stx #'ty "Type ~a could not be converted to a contract." typ))))) #:typed-side #f
;; in the fix-up case, the contract is just an identifier (lambda ()
;; that is defined below (tc-error/stx #'ty "Type ~a could not be converted to a contract." typ)))))
(generate-temporary #'nm.nm))] ;; in the fix-up case, the contract is just an identifier
[hidden (generate-temporary #'nm.nm)] ;; that is defined below
[sm (if (attribute parent) (generate-temporary #'nm.nm)))
#'(#:struct-maker parent) (define/with-syntax hidden (generate-temporary #'nm.nm))
#'())]) (define/with-syntax sm (if (attribute parent)
(let ([prop-name (if (attribute parent) #'(#:struct-maker parent)
'typechecker:contract-def/maker #'()))
'typechecker:contract-def)]) (define prop-name (if (attribute parent)
(quasisyntax/loc stx 'typechecker:contract-def/maker
(begin 'typechecker:contract-def))
;; define `cnt*` to be fixed up later by the module (quasisyntax/loc stx
;; type-checking (not defined at top-level since it (begin
;; doesn't work with local expansion) ;; define `cnt*` to be fixed up later by the module
#,@(ignore (if (eq? (syntax-local-context) 'top-level) ;; type-checking (not defined at top-level since it
#'() ;; doesn't work with local expansion)
#`(#,(syntax-property #'(define cnt* #f) prop-name #'ty)))) #,@(ignore (if (eq? (syntax-local-context) 'top-level)
#,(internal #'(require/typed-internal hidden ty . sm)) #'()
#,(ignore #'(require/contract nm.spec hidden cnt* lib))))))])) #`(#,(syntax-property #'(define cnt* #f) prop-name #'ty))))
#,(internal #'(require/typed-internal hidden ty . sm))
#,(ignore #'(require/contract nm.spec hidden cnt* lib))))]))
(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] ...)