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

Replace init argument with direct calls to do-standard-inits.

Browse Source 
original commit: a9e8324a388e9cb3835965614fb403d91b4f679a
This commit is contained in:
Eric Dobson 2013-12-15 09:45:22 -08:00
parent cbce6e45b9
commit 0175943443
6 changed files with 30 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt
View File

@ -50,7 +50,7 @@
(provide
:type-impl :print-type-impl :query-type/args-impl :query-type/result-impl)
(define (:type-impl stx init)
(define (:type-impl stx)
(syntax-parse stx
[(_ (~optional (~and #:verbose verbose-kw)) ty:expr)
(parameterize ([current-print-type-fuel
@ -61,7 +61,6 @@
[current-type-names
(if (attribute verbose-kw) '() (current-type-names))]
[current-print-unexpanded (box '())])
(init)
(define type (format "~a" (parse-type #'ty)))
(define unexpanded
(remove-duplicates (unbox (current-print-unexpanded))))
@ -75,10 +74,10 @@
;; TODO what should be done with stx
;; Prints the _entire_ type. May be quite large.
(define (:print-type-impl stx init)
(define (:print-type-impl stx)
(syntax-parse stx
[(_ e)
(tc-setup stx #'e 'top-level init tc-toplevel-form
(tc-setup stx #'e 'top-level tc-toplevel-form
(lambda (expanded before type)
#`(display
#,(parameterize ([print-multi-line-case-> #t])
@ -90,7 +89,7 @@
(raise-syntax-error #f "must be applied to exactly one argument" #'form)]))
;; given a function and input types, display the result type
(define (:query-type/args-impl stx init)
(define (:query-type/args-impl stx)
(syntax-parse stx
[(_ op arg-type ...)
(with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
@ -99,7 +98,7 @@
#`(lambda #,(stx-map type-label-property
#'(dummy-arg ...) #'(arg-type ...))
(op dummy-arg ...))
'top-level init tc-toplevel-form
'top-level tc-toplevel-form
(lambda (expanded before type)
#`(display
#,(format "~a\n"
@ -109,12 +108,11 @@
(raise-syntax-error #f "must be applied to at least one argument" #'form)]))
;; given a function and a desired return type, fill in the blanks
(define (:query-type/result-impl stx init)
(define (:query-type/result-impl stx)
(syntax-parse stx
[(_ op desired-type)
(init)
(let ([expected (parse-type #'desired-type)])
(tc-setup stx #'op 'top-level init tc-toplevel-form
(tc-setup stx #'op 'top-level tc-toplevel-form
(lambda (expanded before type)
(match type
[(tc-result1: (and t (Function: _)) f o)

16
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt
View File

@ -11,11 +11,12 @@
(rep type-rep)
(for-template (base-env top-interaction))
(utils utils tc-utils arm)
"standard-inits.rkt"
"tc-setup.rkt")
(provide mb-core ti-core wt-core)
(define (mb-core stx init)
(define (mb-core stx)
(syntax-parse stx
[(mb (~optional (~or (~and #:optimize (~bind [opt? #'#t])) ; kept for backward compatibility
(~and #:no-optimize (~bind [opt? #'#f]))))
@ -24,7 +25,7 @@
(parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?))
(and (attribute opt?) (syntax-e (attribute opt?))))])
(tc-setup
stx pmb-form 'module-begin init tc-module
stx pmb-form 'module-begin tc-module
(λ (new-mod before-code after-code)
(with-syntax*
(;; pmb = #%plain-module-begin
@ -47,18 +48,21 @@
(define did-I-suggest-:print-type-already? #f)
(define :print-type-message " ... [Use (:print-type <expr>) to see more.]")
(define (ti-core stx init)
(define (ti-core stx )
(current-type-names (init-current-type-names))
(syntax-parse stx
#:literal-sets (kernel-literals)
[(_ . (module . rest))
#'(module . rest)]
[(_ . (~and form ((~var command (static interactive-command? #f)) . _)))
((interactive-command-procedure (attribute command.value)) #'form init)]
(do-standard-inits)
((interactive-command-procedure (attribute command.value)) #'form)]
[(_ . form)
(init)
;; TODO(endobson): Remove the call to do-standard-inits when it is no longer necessary
;; Cast at the top-level still needs this for some reason
(do-standard-inits)
(tc-setup
stx #'form 'top-level void tc-toplevel-form
stx #'form 'top-level tc-toplevel-form
(λ (body2 before type)
(with-syntax*
([(optimized-body . _) (maybe-optimize #`(#,body2))])

11
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt
View File

@ -8,6 +8,7 @@
(prefix-in c: (combine-in racket/contract/region racket/contract/base)))
"../base-env/extra-procs.rkt" (except-in "../base-env/prims.rkt" with-handlers λ lambda define)
"../tc-setup.rkt"
"../standard-inits.rkt"
syntax/parse racket/match
unstable/sequence "../base-env/base-types-extra.rkt"
(path-up "env/type-name-env.rkt"
@ -23,14 +24,14 @@
(provide wt-core)
(define (with-type-helper stx init body fvids fvtys exids extys resty expr? ctx)
(define (with-type-helper stx body fvids fvtys exids extys resty expr? ctx)
(define old-context (unbox typed-context?))
(unless (not old-context)
(tc-error/stx stx "with-type cannot be used in a typed module."))
(define (no-contract t [stx stx])
(type->contract-fail t stx))
(set-box! typed-context? #t)
(init)
(do-standard-inits)
(define fv-types (for/list ([t (in-syntax fvtys)])
(parse-type t)))
(define fv-cnts (for/list ([t (in-list fv-types)]
@ -113,7 +114,7 @@
([ex-id ex-cnt] ...)
(define-values (ex-id ...) body)))))))
(define (wt-core stx init)
(define (wt-core stx)
(define-syntax-class typed-id
#:description "[id type]"
[pattern (id ty)])
@ -135,7 +136,7 @@
[pattern (~seq #:result ty:expr)])
(syntax-parse stx
[(_ :typed-ids fv:free-vars . body)
(with-type-helper stx init #'body #'(fv.id ...) #'(fv.ty ...) #'(id ...) #'(ty ...) #f #f (syntax-local-context))]
(with-type-helper stx #'body #'(fv.id ...) #'(fv.ty ...) #'(id ...) #'(ty ...) #f #f (syntax-local-context))]
[(_ :result-ty fv:free-vars . body)
(with-type-helper stx init #'body #'(fv.id ...) #'(fv.ty ...) #'() #'() #'ty #t (syntax-local-context))]))
(with-type-helper stx #'body #'(fv.id ...) #'(fv.ty ...) #'() #'() #'ty #t (syntax-local-context))]))

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt
View File

@ -5,6 +5,7 @@
racket/pretty racket/promise racket/lazy-require
(env type-name-env type-alias-env mvar-env)
(utils tc-utils disarm mutated-vars)
"standard-inits.rkt"
(for-syntax racket/base)
(for-template racket/base))
(lazy-require [typed-racket/optimizer/optimizer (optimize-top)])
@ -38,7 +39,7 @@
(define-logger online-check-syntax)
(define (tc-setup orig-stx stx expand-ctxt init checker f)
(define (tc-setup orig-stx stx expand-ctxt checker f)
(set-box! typed-context? #t)
;(start-timing (syntax-property stx 'enclosing-module-name))
(with-handlers
@ -64,7 +65,9 @@
'info
"TR's expanded syntax objects; this message is ignored"
(cdr exprs))))
(init)
;; We do standard inits here because it is costly (~250 msec), and we want
;; expansion errors to happen with out paying that cost
(do-standard-inits)
(do-time "Initialized Envs")
(find-mutated-vars fully-expanded-stx mvar-env)
(parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)]

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt
View File

@ -24,7 +24,7 @@
(define-syntax (name stx)
(do-time (format "Calling ~a driver" 'name))
(do-time (format "Loaded core ~a" 'sym))
(begin0 (sym stx do-standard-inits)
(begin0 (sym stx)
(do-time "Finished, returning to Racket")))
...))

2
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt
View File

@ -19,7 +19,7 @@
(utils tc-utils) (typecheck typechecker))
typed-racket/base-env/prims
typed-racket/base-env/base-types
(only-in typed-racket/typed-racket do-standard-inits))
(for-syntax typed-racket/standard-inits))
(begin-for-syntax (do-standard-inits))