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

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

@ -133,7 +133,8 @@ 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 (eq? (syntax-local-context) 'top-level)
;; if we're at the top-level, we can generate the contract ;; if we're at the top-level, we can generate the contract
;; immediately, but otherwise the contract will be fixed up ;; immediately, but otherwise the contract will be fixed up
;; by the module type-checking pass later ;; by the module type-checking pass later
@ -141,20 +142,21 @@ This file defines two sorts of primitives. All of them are provided into any mod
(ignore (ignore
(type->contract (type->contract
typ typ
;; this is for a `require/typed', so the value is not from the typed side ;; this is for a `require/typed', so the value is not
;; from the typed side
#:typed-side #f #:typed-side #f
(lambda () (lambda ()
(tc-error/stx #'ty "Type ~a could not be converted to a contract." typ))))) (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 ;; in the fix-up case, the contract is just an identifier
;; that is defined below ;; that is defined below
(generate-temporary #'nm.nm))] (generate-temporary #'nm.nm)))
[hidden (generate-temporary #'nm.nm)] (define/with-syntax hidden (generate-temporary #'nm.nm))
[sm (if (attribute parent) (define/with-syntax sm (if (attribute parent)
#'(#:struct-maker parent) #'(#:struct-maker parent)
#'())]) #'()))
(let ([prop-name (if (attribute parent) (define prop-name (if (attribute parent)
'typechecker:contract-def/maker 'typechecker:contract-def/maker
'typechecker:contract-def)]) 'typechecker:contract-def))
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
;; define `cnt*` to be fixed up later by the module ;; define `cnt*` to be fixed up later by the module
@ -164,7 +166,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#'() #'()
#`(#,(syntax-property #'(define cnt* #f) prop-name #'ty)))) #`(#,(syntax-property #'(define cnt* #f) prop-name #'ty))))
#,(internal #'(require/typed-internal hidden ty . sm)) #,(internal #'(require/typed-internal hidden ty . sm))
#,(ignore #'(require/contract nm.spec hidden cnt* lib))))))])) #,(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] ...)