Move generated contracted provides to a submodule.
This allows the main TR module not to explicitly depend on the contract library. Each exported name can be redirected to either the original name (for a typed client) or to another macro (for an untyped client) which expands to a `local-require` for the relevant submodule (named `#%contract-defs`). Thanks to Matthew for the initial idea and an implementation in plai-typed that this is based on.
This commit is contained in:
Sam Tobin-Hochstadt
parent
6c09d52b2e
commit
ae0717d970
|
|
@ -16,6 +16,7 @@
|
|||
racket/format
|
||||
racket/dict
|
||||
unstable/list
|
||||
syntax/flatten-begin
|
||||
(only-in (types abbrev) -Bottom)
|
||||
(static-contracts instantiate optimize structures combinators)
|
||||
;; TODO make this from contract-req
|
||||
|
|
@ -133,10 +134,13 @@
|
|||
#,(syntax-position orig-id)
|
||||
#,(syntax-span orig-id))))])]))
|
||||
|
||||
;; The below requires are needed since they provide identifiers that
|
||||
;; may appear in the residual program.
|
||||
|
||||
;; TODO: It would be better to have individual contracts specify which
|
||||
;; modules should be required, but for now this is just all of them.
|
||||
(define extra-requires
|
||||
#'(require
|
||||
;; the below requires are needed since they provide identifiers
|
||||
;; that may appear in the residual program
|
||||
(submod typed-racket/private/type-contract predicates)
|
||||
typed-racket/utils/utils
|
||||
(for-syntax typed-racket/utils/utils)
|
||||
|
|
@ -144,7 +148,10 @@
|
|||
typed-racket/utils/evt-contract
|
||||
unstable/contract racket/contract/parametric))
|
||||
|
||||
;; should the above requires be included in the output?
|
||||
;; Should the above requires be included in the output?
|
||||
;; This box is only used for contracts generated for `require/typed`
|
||||
;; and `cast`, contracts for `provides go into the `#%contract-defs`
|
||||
;; submodule, which always has the above `require`s.
|
||||
(define include-extra-requires? (box #f))
|
||||
|
||||
(define (change-contract-fixups forms)
|
||||
|
|
@ -157,15 +164,26 @@
|
|||
(begin (set-box! include-extra-requires? #t)
|
||||
(generate-contract-def e ctc-cache sc-cache))))))
|
||||
|
||||
(define (change-provide-fixups forms)
|
||||
(define ctc-cache (make-hash))
|
||||
(define sc-cache (make-hash))
|
||||
;; TODO: These are probably all in a specific place, which could avoid
|
||||
;; the big traversal
|
||||
(define (change-provide-fixups forms [ctc-cache (make-hash)] [sc-cache (make-hash)])
|
||||
(with-new-name-tables
|
||||
(for/list ([form (in-list forms)])
|
||||
(cond [(contract-def/provide-property form)
|
||||
(set-box! include-extra-requires? #t)
|
||||
(generate-contract-def/provide form ctc-cache sc-cache)]
|
||||
[else form]))))
|
||||
(syntax-parse form #:literal-sets (kernel-literals)
|
||||
[_
|
||||
#:when (contract-def/provide-property form)
|
||||
(generate-contract-def/provide form ctc-cache sc-cache)]
|
||||
[(module* name #f forms ...)
|
||||
(quasisyntax/loc form
|
||||
(module* name #f
|
||||
#,@(change-provide-fixups (syntax->list #'(forms ...))
|
||||
ctc-cache sc-cache)))]
|
||||
[((~literal #%plain-module-begin) forms ...)
|
||||
(quasisyntax/loc form
|
||||
(#%plain-module-begin
|
||||
#,@(change-provide-fixups (flatten-all-begins #'(begin forms ...))
|
||||
ctc-cache sc-cache)))]
|
||||
[_ form]))))
|
||||
|
||||
;; To avoid misspellings
|
||||
(define impersonator-sym 'impersonator)
|
||||
|
|
@ -234,9 +252,6 @@
|
|||
kind
|
||||
#:cache cache)))
|
||||
|
||||
|
||||
|
||||
|
||||
(define any-wrap/sc (chaperone/sc #'any-wrap/c))
|
||||
|
||||
(define (no-duplicates l)
|
||||
|
|
|
|||
|
|
@ -26,35 +26,44 @@
|
|||
(define (freshen-id id)
|
||||
((make-syntax-introducer) id))
|
||||
|
||||
;; generate-prov : dict[id -> def-binding] dict[id -> list[id]] id
|
||||
;; generate-prov : dict[id -> def-binding] dict[id -> list[id]] id id
|
||||
;; -> (values listof[syntax] listof[listof[list[id id]]])
|
||||
;; defs: defines in this module
|
||||
;; provs: provides in this module
|
||||
;; pos-blame-id: a #%variable-reference for the module
|
||||
;; mk-redirect-id: the name of a definition created by `make-make-redirect-to-contract`
|
||||
|
||||
;; The first returned value is a syntax object of definitions that defines the
|
||||
;; contracted versions of the provided identifiers, and the corresponding
|
||||
;; provides.
|
||||
;;
|
||||
;; The second value is a list of two element lists, which are type name aliases.
|
||||
(define (generate-prov defs provs pos-blame-id)
|
||||
(define (generate-prov defs provs pos-blame-id mk-redirect-id)
|
||||
;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
|
||||
(define mapping (make-free-id-table))
|
||||
|
||||
;; triple/c in the signatures corresponds to three values:
|
||||
;; (values syntax? identfier? (listof (list/c identifier? identifier?))
|
||||
;; First return value is a syntax object of definitions
|
||||
;; Second is the id to export
|
||||
;; Third is a list of two element lists representing type aliases
|
||||
;; quad/c in the signatures corresponds to four values:
|
||||
;; (values syntax? syntax? identfier? (listof (list/c identifier? identifier?))
|
||||
;; First return value is a syntax object of definitions, which will go in
|
||||
;; the #%contract-defs submodule
|
||||
;; Second is a syntax object of definitions to go in the main module, including
|
||||
;; the defintion to be exported
|
||||
;; Third is the id to export
|
||||
;; Fourth is a list of two element lists representing type aliases
|
||||
|
||||
;; mk : id -> triple/c
|
||||
|
||||
;; mk-ignored-quad : identifier -> quad/c
|
||||
(define (mk-ignored-quad i) (values #'(begin) #'(begin) i null))
|
||||
|
||||
;; mk : id -> quad/c
|
||||
;;
|
||||
;; internal-id : the id being provided
|
||||
;; if `internal-id' is defined in this module, we will produce a (begin def ... provide) block
|
||||
;; internal-id : the id being provided. If `internal-id' is defined
|
||||
;; in this module, we will produce a (begin def ... provide) block
|
||||
;; and a name to provide instead of internal-id.
|
||||
;;
|
||||
;; Anything already recorded in the mapping is given an empty (begin) and the already-recorded id
|
||||
;; otherwise, we will map internal-id to the fresh id in `mapping'
|
||||
;; Anything already recorded in the mapping is given an empty
|
||||
;; (begin) and the already-recorded id otherwise, we will map
|
||||
;; internal-id to the fresh id in `mapping'
|
||||
(define (mk internal-id)
|
||||
(define new-id (freshen-id internal-id))
|
||||
(cond
|
||||
|
|
@ -62,35 +71,38 @@
|
|||
[(dict-ref mapping internal-id
|
||||
;; if it wasn't there, put it in, and skip this case
|
||||
(λ () (dict-set! mapping internal-id new-id) #f))
|
||||
=> (λ (mapped-id) (values #'(begin) mapped-id null))]
|
||||
=> mk-ignored-quad]
|
||||
[(dict-ref defs internal-id #f)
|
||||
=>
|
||||
(match-lambda
|
||||
[(def-binding _ ty)
|
||||
(mk-value-triple internal-id new-id ty)]
|
||||
(mk-value-quad internal-id new-id ty)]
|
||||
[(def-struct-stx-binding _ (? struct-info? si) constr-type)
|
||||
(mk-struct-syntax-triple internal-id new-id si constr-type)]
|
||||
(mk-struct-syntax-quad internal-id new-id si constr-type)]
|
||||
[(def-stx-binding _)
|
||||
(mk-syntax-triple internal-id new-id)])]
|
||||
(mk-syntax-quad internal-id new-id)])]
|
||||
;; otherwise, not defined in this module, not our problem
|
||||
[else (values #'(begin) internal-id null)]))
|
||||
[else (mk-ignored-quad internal-id)]))
|
||||
|
||||
;; mk-struct-syntax-triple : identifier? identifier? struct-info? Type/c -> triple/c
|
||||
(define (mk-struct-syntax-triple internal-id new-id si constr-type)
|
||||
;; mk-struct-syntax-quad : identifier? identifier? struct-info? Type/c -> quad/c
|
||||
;; This handles `(provide s)` where `s` was defined with `(struct s ...)`.
|
||||
(define (mk-struct-syntax-quad internal-id new-id si constr-type)
|
||||
(define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)
|
||||
(match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si))
|
||||
(define-values (defns new-ids aliases)
|
||||
(map/values 3
|
||||
(define-values (defns export-defns new-ids aliases)
|
||||
(map/values 4
|
||||
(lambda (e) (if (identifier? e)
|
||||
(mk e)
|
||||
(values #'(begin) e null)))
|
||||
(mk-ignored-quad e)))
|
||||
(list* type-desc pred super accs)))
|
||||
(define-values (constr-defn constr-new-id constr-aliases)
|
||||
;; Here, we recursively handle all of the identifiers referenced
|
||||
;; in this static struct info.
|
||||
(define-values (constr-defn constr-export-defn constr-new-id constr-aliases)
|
||||
(cond
|
||||
[(not (identifier? constr))
|
||||
(values #'(begin) #f null)]
|
||||
(values #'(begin) #'(begin) #f null)]
|
||||
[(free-identifier=? constr internal-id)
|
||||
(mk-value-triple constr (generate-temporary constr) constr-type)]
|
||||
(mk-value-quad constr (generate-temporary constr) constr-type)]
|
||||
[else
|
||||
(mk constr)]))
|
||||
|
||||
|
|
@ -104,7 +116,20 @@
|
|||
(values
|
||||
#`(begin
|
||||
#,constr-defn
|
||||
#,@defns
|
||||
#,@defns)
|
||||
#`(begin
|
||||
#,constr-export-defn
|
||||
#,@export-defns
|
||||
;; Here, we construct a new static struct identifier whose
|
||||
;; contents point to newly-defined identifiers that are
|
||||
;; themselves redirections. Unlike for value exports, we
|
||||
;; don't provide two distinct identifiers, one for typed
|
||||
;; code and one for untyped code, because they both have
|
||||
;; to accessible by `syntax-local-value` and thus have to
|
||||
;; be protected from re-export regardless of whether the
|
||||
;; identifiers are copied out. Additionally, we can't put
|
||||
;; a protected version in the submodule, since that
|
||||
;; wouldn't be accessible by `syntax-local-value`.
|
||||
(define-syntax protected-id
|
||||
(let ((info (list type-desc* (syntax export-id) pred* (list accs* ...)
|
||||
(list #,@(map (lambda (x) #'#f) accs)) super*)))
|
||||
|
|
@ -112,47 +137,58 @@
|
|||
#'(make-struct-info-self-ctor constr* info)
|
||||
#'info)))
|
||||
(def-export export-id protected-id protected-id))
|
||||
new-id
|
||||
#'export-id
|
||||
(cons (list #'export-id internal-id)
|
||||
(apply append constr-aliases aliases)))))
|
||||
|
||||
|
||||
;; mk-syntax-triple : identifier? identifier? -> triple/c
|
||||
(define (mk-syntax-triple internal-id new-id)
|
||||
;; mk-syntax-quad : identifier? identifier? -> quad/c
|
||||
(define (mk-syntax-quad internal-id new-id)
|
||||
(with-syntax* ([id internal-id]
|
||||
[export-id new-id]
|
||||
[untyped-id (freshen-id #'id)])
|
||||
(define/with-syntax def
|
||||
#`(define-syntax untyped-id
|
||||
(lambda (stx)
|
||||
(tc-error/stx stx "Macro ~a from typed module used in untyped code" 'untyped-id))))
|
||||
(values
|
||||
#`(begin def (def-export export-id id untyped-id))
|
||||
#`(begin)
|
||||
;; There's no need to put this macro in the submodule since it
|
||||
;; has no dependencies.
|
||||
#`(begin
|
||||
(define-syntax (untyped-id stx)
|
||||
(tc-error/stx stx "Macro ~a from typed module used in untyped code" 'untyped-id))
|
||||
(def-export export-id id untyped-id))
|
||||
new-id
|
||||
(list (list #'export-id #'id)))))
|
||||
|
||||
;; mk-value-triple : identifier? identifier? (or/c Type #f) -> triple/c
|
||||
(define (mk-value-triple internal-id new-id ty)
|
||||
;; mk-value-quad : identifier? identifier? (or/c Type #f) -> quad/c
|
||||
(define (mk-value-quad internal-id new-id ty)
|
||||
(with-syntax* ([id internal-id]
|
||||
[untyped-id (freshen-id #'id)]
|
||||
[local-untyped-id (freshen-id #'id)]
|
||||
[export-id new-id])
|
||||
(define/with-syntax ctc (generate-temporary 'generated-contract))
|
||||
;; Create the definitions of the contract and the contracted export.
|
||||
(define/with-syntax definitions
|
||||
(contract-def/provide-property
|
||||
#'(define-values (ctc) #f)
|
||||
(list ty #'untyped-id #'id pos-blame-id)))
|
||||
(values
|
||||
#'(begin definitions (def-export export-id id untyped-id))
|
||||
new-id
|
||||
null)))
|
||||
;; For the submodule
|
||||
#`(begin definitions (provide untyped-id))
|
||||
;; For the main module
|
||||
#`(begin (define-syntax local-untyped-id (#,mk-redirect-id (quote-syntax untyped-id)))
|
||||
(def-export export-id id local-untyped-id))
|
||||
new-id
|
||||
null)))
|
||||
|
||||
|
||||
;; Build the final provide with auxilliary definitions
|
||||
(for/lists (l l*) ([(internal-id external-ids) (in-dict provs)])
|
||||
(define-values (defs id alias) (mk internal-id))
|
||||
(for/lists (defs export-defs provides aliases) ([(internal-id external-ids) (in-dict provs)])
|
||||
(define-values (defs export-def id alias) (mk internal-id))
|
||||
(define provide-forms
|
||||
(for/list ([external-id (in-list external-ids)])
|
||||
#`(rename-out [#,id #,external-id])))
|
||||
(when (pair? external-ids) (set-box! include-extra-requires? #t))
|
||||
(values #`(begin #,defs (provide #,@provide-forms))
|
||||
(if (free-identifier=? id external-id)
|
||||
id
|
||||
#`(rename-out [#,id #,external-id]))))
|
||||
(values #`(begin #,defs)
|
||||
export-def
|
||||
#`(provide #,@provide-forms)
|
||||
alias)))
|
||||
|
|
|
|||
|
|
@ -6,13 +6,13 @@
|
|||
(prefix-in c: (contract-req))
|
||||
(rep type-rep)
|
||||
(types utils abbrev type-table struct-table)
|
||||
(private parse-type type-annotation syntax-properties)
|
||||
(private parse-type type-annotation syntax-properties type-contract)
|
||||
(env global-env init-envs type-name-env type-alias-env
|
||||
lexical-env env-req mvar-env scoped-tvar-env
|
||||
type-alias-helper)
|
||||
(utils tc-utils)
|
||||
(typecheck provide-handling def-binding tc-structs
|
||||
typechecker internal-forms)
|
||||
(utils tc-utils redirect-contract)
|
||||
"provide-handling.rkt" "def-binding.rkt" "tc-structs.rkt"
|
||||
"typechecker.rkt" "internal-forms.rkt"
|
||||
syntax/location
|
||||
racket/format
|
||||
(for-template
|
||||
|
|
@ -269,6 +269,15 @@
|
|||
[(define-syntaxes (nm ...) . rest) (syntax->list #'(nm ...))]
|
||||
[_ #f]))
|
||||
|
||||
(define-syntax-class unknown-provide-form
|
||||
(pattern
|
||||
(~and name
|
||||
(~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta)
|
||||
(~datum struct) (~datum all-from) (~datum all-from-except)
|
||||
(~datum all-defined) (~datum all-defined-except)
|
||||
(~datum prefix-all-defined) (~datum prefix-all-defined-except)
|
||||
(~datum expand)))))
|
||||
|
||||
;; actually do the work on a module
|
||||
;; produces prelude and post-lude syntax objects
|
||||
;; syntax-list -> (values syntax syntax)
|
||||
|
|
@ -322,6 +331,10 @@
|
|||
(define defs (append *defs (apply append (map tc-toplevel/pass1.5 forms))))
|
||||
(do-time "Finished pass1")
|
||||
;; separate the definitions into structures we'll handle for provides
|
||||
;; def-tbl : hash[id, binding]
|
||||
;; the id is the name defined by the binding
|
||||
;; XXX: why is it ever possible that we get duplicates here?
|
||||
;; iow, why isn't `merge-def-binding` always `error`?
|
||||
(define def-tbl
|
||||
(for/fold ([h (make-immutable-free-id-table)])
|
||||
([def (in-list defs)])
|
||||
|
|
@ -333,8 +346,7 @@
|
|||
[(not other-def) def]
|
||||
[(plain-stx-binding? def) other-def]
|
||||
[(plain-stx-binding? other-def) def]
|
||||
[else
|
||||
(int-err "Two conflicting definitions: ~a ~a" def other-def)]))
|
||||
[else (int-err "Two conflicting definitions: ~a ~a" def other-def)]))
|
||||
(dict-update h (binding-name def) merge-def-bindings #f)))
|
||||
(do-time "computed def-tbl")
|
||||
;; typecheck the expressions and the rhss of defintions
|
||||
|
|
@ -350,63 +362,130 @@
|
|||
(list (syntax-property #'(void) 'mouse-over-tooltips (type-table->tooltips))))
|
||||
;; report delayed errors
|
||||
(report-all-errors)
|
||||
;; provide-tbl : hash[id, listof[id]]
|
||||
;; maps internal names to all the names they're provided as
|
||||
;; XXX: should the external names be symbols instead of identifiers?
|
||||
(define provide-tbl
|
||||
(for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)])
|
||||
(define-syntax-class unknown-provide-form
|
||||
(pattern
|
||||
(~and name
|
||||
(~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta)
|
||||
(~datum struct) (~datum all-from) (~datum all-from-except)
|
||||
(~datum all-defined) (~datum all-defined-except)
|
||||
(~datum prefix-all-defined) (~datum prefix-all-defined-except)
|
||||
(~datum expand)))))
|
||||
(syntax-parse p #:literal-sets (kernel-literals)
|
||||
[(#%provide form ...)
|
||||
(for/fold ([h h]) ([f (in-syntax #'(form ...))])
|
||||
(parameterize ([current-orig-stx f])
|
||||
(syntax-parse f
|
||||
[i:id
|
||||
(dict-update h #'i (lambda (tail) (cons #'i tail)) '())]
|
||||
[((~datum rename) in out)
|
||||
(dict-update h #'in (lambda (tail) (cons #'out tail)) '())]
|
||||
[(name:unknown-provide-form . _)
|
||||
(tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name))]
|
||||
[_ (int-err "unknown provide form")])))]
|
||||
(syntax-parse f
|
||||
[i:id
|
||||
(dict-update h #'i (lambda (tail) (cons #'i tail)) '())]
|
||||
[((~datum rename) in out)
|
||||
(dict-update h #'in (lambda (tail) (cons #'out tail)) '())]
|
||||
[(name:unknown-provide-form . _)
|
||||
(parameterize ([current-orig-stx f])
|
||||
(tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name)))]
|
||||
[_ (parameterize ([current-orig-stx f])
|
||||
(int-err "unknown provide form"))]))]
|
||||
[_ (int-err "non-provide form! ~a" (syntax->datum p))])))
|
||||
;; compute the new provides
|
||||
(define-values (new-stx/pre new-stx/post)
|
||||
(with-syntax*
|
||||
([the-variable-reference (generate-temporary #'blame)])
|
||||
(define-values (code aliasess)
|
||||
(generate-prov def-tbl provide-tbl #'the-variable-reference))
|
||||
(define aliases (apply append aliasess))
|
||||
(define/with-syntax (new-provs ...) code)
|
||||
(values
|
||||
#`(begin
|
||||
(begin-for-syntax
|
||||
(module* #%type-decl #f
|
||||
(#%plain-module-begin ;; avoid top-level printing and config
|
||||
(require typed-racket/types/numeric-tower typed-racket/env/type-name-env
|
||||
typed-racket/env/global-env typed-racket/env/type-alias-env
|
||||
typed-racket/types/struct-table typed-racket/types/abbrev
|
||||
(rename-in racket/private/sort [sort raw-sort]))
|
||||
#,(env-init-code)
|
||||
#,(talias-env-init-code)
|
||||
#,(tname-env-init-code)
|
||||
#,(tvariance-env-init-code)
|
||||
#,(mvar-env-init-code mvar-env)
|
||||
#,(make-struct-table-code)
|
||||
#,@(for/list ([a (in-list aliases)])
|
||||
(match a
|
||||
[(list from to)
|
||||
#`(add-alias (quote-syntax #,from) (quote-syntax #,to))])))))
|
||||
(begin-for-syntax (add-mod! (variable-reference->module-path-index
|
||||
(#%variable-reference)))))
|
||||
#`(begin
|
||||
#,(if (null? (syntax-e #'(new-provs ...)))
|
||||
#'(begin)
|
||||
#'(define the-variable-reference (quote-module-name)))
|
||||
new-provs ...))))
|
||||
([the-variable-reference (generate-temporary #'blame)]
|
||||
[mk-redirect (generate-temporary #'make-redirect)])
|
||||
(define-values (defs export-defs provs aliasess)
|
||||
(generate-prov def-tbl provide-tbl #'the-variable-reference #'mk-redirect))
|
||||
(define aliases (apply append aliasess))
|
||||
(define/with-syntax (new-defs ...) defs)
|
||||
(define/with-syntax (new-export-defs ...) export-defs)
|
||||
(define/with-syntax (new-provs ...) provs)
|
||||
(values
|
||||
#`(begin
|
||||
;; This syntax-time submodule records all the types for all
|
||||
;; definitions in this module, as well as type alias
|
||||
;; definitions, structure defintions, variance information,
|
||||
;; etc. It is `dynamic-require`d by the typechecker for any
|
||||
;; typed module that (transitively) depends on this
|
||||
;; module. We keep this in a submodule and use
|
||||
;; `dynamic-require` so that we don't load any of this code
|
||||
;; (and in particular all of its dependencies on the type
|
||||
;; checker) when just running a typed module.
|
||||
(begin-for-syntax
|
||||
(module* #%type-decl #f
|
||||
(#%plain-module-begin ;; avoid top-level printing and config
|
||||
(require typed-racket/types/numeric-tower typed-racket/env/type-name-env
|
||||
typed-racket/env/global-env typed-racket/env/type-alias-env
|
||||
typed-racket/types/struct-table typed-racket/types/abbrev
|
||||
(rename-in racket/private/sort [sort raw-sort]))
|
||||
#,(env-init-code)
|
||||
#,(talias-env-init-code)
|
||||
#,(tname-env-init-code)
|
||||
#,(tvariance-env-init-code)
|
||||
#,(mvar-env-init-code mvar-env)
|
||||
#,(make-struct-table-code)
|
||||
#,@(for/list ([a (in-list aliases)])
|
||||
(match-define (list from to) a)
|
||||
#`(add-alias (quote-syntax #,from) (quote-syntax #,to))))))
|
||||
(begin-for-syntax (add-mod! (variable-reference->module-path-index
|
||||
(#%variable-reference)))))
|
||||
#`(begin
|
||||
;; FIXME: share this variable reference with the one below
|
||||
(define the-variable-reference (quote-module-name))
|
||||
;; Here we construct the redirector for the #%contract-defs
|
||||
;; submodule. The `mk-redirect` identifier is also used in
|
||||
;; the `new-export-defs`.
|
||||
(begin-for-syntax
|
||||
;; We explicitly insert a `require` here since this module
|
||||
;; is `lazy-require`d and thus just doing a `require`
|
||||
;; outside wouldn't actually make the module
|
||||
;; available. The alternative would be to add an
|
||||
;; appropriate-phase `require` statically in a module
|
||||
;; that's non-dynamically depended on by
|
||||
;; `typed/racket`. That makes for confusing non-local
|
||||
;; dependencies, though, so we do it here.
|
||||
(require typed-racket/utils/redirect-contract)
|
||||
(define mk-redirect
|
||||
(make-make-redirect-to-contract (#%variable-reference))))
|
||||
|
||||
;; This submodule contains all the definitions of
|
||||
;; contracted identifiers. For an exported definition like
|
||||
;; (define f : T e)
|
||||
;; we generate the following defintions that go in the
|
||||
;; submodule:
|
||||
;; (define con ,(type->contract T))
|
||||
;; (define f* (contract con 'pos 'neg f))
|
||||
;; (provide (rename-out [f* f]))
|
||||
;; This is the `new-defs ...`.
|
||||
;; The `extra-requires` which go in the submodule are used
|
||||
;; (potentially) in the implementation of the contracts.
|
||||
;;
|
||||
;; The reason to construct this submodule is to avoid
|
||||
;; loading the contracts (or the `racket/contract` library
|
||||
;; itself) at the runtime of typed modules that don't need
|
||||
;; them. This is similar to the reason for the
|
||||
;; `#%type-decl` submodule.
|
||||
(module* #%contract-defs #f
|
||||
(#%plain-module-begin
|
||||
#,extra-requires
|
||||
new-defs ...))
|
||||
|
||||
;; Now we create definitions that are actually provided
|
||||
;; from the module itself. There are two levels of
|
||||
;; indirection here (see the implementation in
|
||||
;; provide-handling.rkt).
|
||||
;;
|
||||
;; First, we generate a macro that expands to a
|
||||
;; `local-require` of the contracted identifier in the
|
||||
;; #%contract-defs submodule:
|
||||
;; (define-syntax con-f (mk-redirect f))
|
||||
;;
|
||||
;; Then, we define a macro that is a rename-transformer for
|
||||
;; either the original `f` or `con-f`.
|
||||
;; (define-syntax export-f (renamer f con-f))
|
||||
;;
|
||||
;; Note that we can't combine any of these indirections,
|
||||
;; because it's important for `export-f` to be a
|
||||
;; rename-transformer (making things like
|
||||
;; `syntax-local-value` work right), but `con-f` can't be,
|
||||
;; since it expands to a `local-require`.
|
||||
new-export-defs ...
|
||||
|
||||
;; Finally, we do the export:
|
||||
;; (provide (rename-out [export-f f]))
|
||||
new-provs ...))))
|
||||
(do-time "finished provide generation")
|
||||
(values new-stx/pre new-stx/post))
|
||||
|
||||
|
|
|
|||
45
typed-racket-lib/typed-racket/utils/redirect-contract.rkt
Normal file
45
typed-racket-lib/typed-racket/utils/redirect-contract.rkt
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/modcollapse (for-template racket/base))
|
||||
(provide make-make-redirect-to-contract)
|
||||
|
||||
;; This is used to define identifiers that expand to a local-require
|
||||
;; of something else. It's used to implement identifiers that are
|
||||
;; protected on export from TR with contracts, but where the
|
||||
;; contracted defintion is in the #%contract-defs submodule.
|
||||
|
||||
;; varref: a variable reference to the typed module that has the
|
||||
;; appropriate submodule in it
|
||||
|
||||
;; id: the name of the export from the submodule which will be
|
||||
;; redirected-to by the local-require
|
||||
|
||||
;; stx: the syntax object that's the argument to the macro (that is,
|
||||
;; the stx object that's the reference to the typed identifier in
|
||||
;; a untyped module). The funny eta-expansion with `redirect` is
|
||||
;; so that we can recursively invoke it when the redirected id is
|
||||
;; used in operator position.
|
||||
|
||||
;; This code was originally written by mflatt for the plai-typed
|
||||
;; language, and then slightly adapted for TR by samth.
|
||||
|
||||
(define ((make-make-redirect-to-contract varref) id)
|
||||
(define (redirect stx)
|
||||
(cond
|
||||
[(identifier? stx)
|
||||
(with-syntax ([mp (collapse-module-path-index
|
||||
(module-path-index-join
|
||||
'(submod "." #%contract-defs)
|
||||
(variable-reference->module-path-index
|
||||
varref)))]
|
||||
[i (datum->syntax id (syntax-e id) stx stx)])
|
||||
#`(let ()
|
||||
(local-require (only-in mp [#,(datum->syntax #'mp (syntax-e #'i)) i]))
|
||||
i))]
|
||||
[else
|
||||
(datum->syntax stx
|
||||
(cons (redirect (car (syntax-e stx)))
|
||||
(cdr (syntax-e stx)))
|
||||
stx
|
||||
stx)]))
|
||||
redirect)
|
||||
Loading…
Reference in New Issue
Block a user