Adjust contract generation for provides in TR
Use the same mechanism as ordinary require/typed to generate contracts for provide forms. original commit: 34076af389b717cb9840b960adb9a8761bd05db7
This commit is contained in:
Asumu Takikawa
parent
aba90ebcff
commit
b6d98917f5
|
|
@ -6,6 +6,7 @@
|
|||
(private with-types type-contract)
|
||||
(except-in syntax/parse id)
|
||||
racket/match racket/syntax
|
||||
syntax/flatten-begin
|
||||
(types utils abbrev generalize type-table)
|
||||
(typecheck provide-handling tc-toplevel tc-app-helper)
|
||||
(rep type-rep)
|
||||
|
|
@ -26,7 +27,7 @@
|
|||
(parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?))
|
||||
(and (attribute opt?) (syntax-e (attribute opt?))))])
|
||||
(tc-module/full stx pmb-form
|
||||
(λ (new-mod before-code after-code)
|
||||
(λ (new-mod before-code pre-after-code)
|
||||
(with-syntax*
|
||||
(;; pmb = #%plain-module-begin
|
||||
[(pmb . body2) new-mod]
|
||||
|
|
@ -34,6 +35,8 @@
|
|||
[transformed-body (begin0 (remove-provides #'body2) (do-time "Removed provides"))]
|
||||
;; add the real definitions of contracts on requires
|
||||
[transformed-body (begin0 (change-contract-fixups #'transformed-body) (do-time "Fixed contract ids"))]
|
||||
;; add the real definitions of contracts on the after-code
|
||||
[(after-code ...) (change-provide-fixups (flatten-all-begins pre-after-code))]
|
||||
;; potentially optimize the code based on the type information
|
||||
[(optimized-body ...) (maybe-optimize #'transformed-body)] ;; has own call to do-time
|
||||
;; add in syntax property on useless expression to draw check-syntax arrows
|
||||
|
|
@ -48,7 +51,7 @@
|
|||
#,(if (unbox include-extra-requires?)
|
||||
extra-requires
|
||||
#'(begin))
|
||||
#,before-code optimized-body ... #,after-code check-syntax-help)))))))]))
|
||||
#,before-code optimized-body ... after-code ... check-syntax-help)))))))]))
|
||||
|
||||
(define did-I-suggest-:print-type-already? #f)
|
||||
(define :print-type-message " ... [Use (:print-type <expr>) to see more.]")
|
||||
|
|
|
|||
|
|
@ -52,6 +52,7 @@
|
|||
(ignore-some-expr typechecker:ignore-some)
|
||||
(contract-def/maker typechecker:contract-def/maker)
|
||||
(contract-def typechecker:contract-def)
|
||||
(contract-def/provide typechecker:contract-def/provide)
|
||||
(flat-contract-def typechecker:flat-contract-def)
|
||||
(external-check typechecker:external-check)
|
||||
(with-type typechecker:with-type #:mark)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
(utils tc-utils)
|
||||
(env type-name-env type-alias-env)
|
||||
(rep rep-utils)
|
||||
(types resolve union utils kw-types)
|
||||
(types resolve union utils kw-types printer)
|
||||
(prefix-in t: (types abbrev numeric-tower))
|
||||
(private parse-type syntax-properties)
|
||||
racket/match racket/syntax racket/list
|
||||
|
|
@ -31,8 +31,14 @@
|
|||
(c:parametric->/c (a) ((Type/c (c:-> #:reason (c:or/c #f string?) a))
|
||||
(#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
|
||||
|
||||
(provide type->contract define/fixup-contract? change-contract-fixups
|
||||
type->contract-fail any-wrap/sc extra-requires include-extra-requires?)
|
||||
(provide type->contract
|
||||
define/fixup-contract?
|
||||
change-contract-fixups
|
||||
change-provide-fixups
|
||||
type->contract-fail
|
||||
any-wrap/sc
|
||||
extra-requires
|
||||
include-extra-requires?)
|
||||
|
||||
;; These check if either the define form or the body form has the syntax
|
||||
;; property. Normally the define form will have the property but lifting an
|
||||
|
|
@ -95,6 +101,38 @@
|
|||
[_ (int-err "should never happen - not a define-values: ~a"
|
||||
(syntax->datum stx))]))
|
||||
|
||||
;; Generate a contract for a TR provide form
|
||||
(define (generate-contract-def/provide stx)
|
||||
(match-define (list type untyped-id orig-id blame-id)
|
||||
(contract-def/provide-property stx))
|
||||
(define failure-reason #f)
|
||||
(define ctc
|
||||
(type->contract type
|
||||
#:typed-side #t
|
||||
#:kind 'impersonator
|
||||
;; FIXME: get rid of this interface, make it functional
|
||||
(λ (#:reason [reason #f]) (set! failure-reason reason))))
|
||||
(syntax-parse stx
|
||||
#:literal-sets (kernel-literals)
|
||||
[(define-values ctc-id _)
|
||||
;; no need for ignore, the optimizer doesn't run on this code
|
||||
(if failure-reason
|
||||
#`(define-syntax (#,untyped-id stx)
|
||||
(tc-error/fields #:stx stx
|
||||
"could not convert type to a contract"
|
||||
#:more #,failure-reason
|
||||
"identifier" #,(symbol->string (syntax-e orig-id))
|
||||
"type" #,(pretty-format-type type #:indent 8)))
|
||||
#`(begin (define ctc-id #,ctc)
|
||||
(define-module-boundary-contract #,untyped-id
|
||||
#,orig-id ctc-id
|
||||
#:pos-source #,blame-id
|
||||
#:srcloc (vector (quote #,(syntax-source orig-id))
|
||||
#,(syntax-line orig-id)
|
||||
#,(syntax-column orig-id)
|
||||
#,(syntax-position orig-id)
|
||||
#,(syntax-span orig-id)))))]))
|
||||
|
||||
(define extra-requires
|
||||
#'(require
|
||||
;; the below requires are needed since they provide identifiers
|
||||
|
|
@ -116,6 +154,13 @@
|
|||
(begin (set-box! include-extra-requires? #t)
|
||||
(generate-contract-def e)))))
|
||||
|
||||
(define (change-provide-fixups forms)
|
||||
(for/list ([form (in-list forms)])
|
||||
(cond [(contract-def/provide-property form)
|
||||
(set-box! include-extra-requires? #t)
|
||||
(generate-contract-def/provide form)]
|
||||
[else form])))
|
||||
|
||||
;; To avoid misspellings
|
||||
(define impersonator-sym 'impersonator)
|
||||
(define chaperone-sym 'chaperone)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
unstable/list unstable/sequence syntax/id-table racket/dict racket/syntax
|
||||
racket/struct-info racket/match syntax/parse
|
||||
(only-in (private type-contract) type->contract include-extra-requires?)
|
||||
(private syntax-properties)
|
||||
(types printer)
|
||||
(typecheck renamer def-binding)
|
||||
(utils tc-utils)
|
||||
|
|
@ -132,35 +133,20 @@
|
|||
new-id
|
||||
(list (list #'export-id #'id)))))
|
||||
|
||||
;; mk-value-triple : identifier? identifier? (or/c syntax? #f) -> triple/c
|
||||
;; mk-value-triple : identifier? identifier? (or/c Type #f) -> triple/c
|
||||
(define (mk-value-triple internal-id new-id ty)
|
||||
(define contract (type->contract ty (λ (#:reason [reason #f]) reason)))
|
||||
|
||||
(with-syntax* ([id internal-id]
|
||||
[untyped-id (freshen-id #'id)]
|
||||
[export-id new-id])
|
||||
(define/with-syntax ctc (generate-temporary 'generated-contract))
|
||||
(define/with-syntax definitions
|
||||
(if (syntax? contract)
|
||||
(with-syntax* ([module-source pos-blame-id]
|
||||
[the-contract (generate-temporary 'generated-contract)])
|
||||
#`(define-module-boundary-contract untyped-id
|
||||
id #,contract
|
||||
#:pos-source module-source
|
||||
#:srcloc (vector '#,(syntax-source #'id)
|
||||
#,(syntax-line #'id)
|
||||
#,(syntax-column #'id)
|
||||
#,(syntax-position #'id)
|
||||
#,(syntax-span #'id))))
|
||||
#`(define-syntax (untyped-id stx)
|
||||
(tc-error/fields #:stx stx
|
||||
"could not convert type to a contract"
|
||||
#:more #,contract
|
||||
"for identifier" #,(symbol->string (syntax-e #'id))
|
||||
"type" #,(pretty-format-type ty #:indent 8)))))
|
||||
(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))
|
||||
#'(begin definitions (def-export export-id id untyped-id))
|
||||
new-id
|
||||
null)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user