From b6d98917f56c141ae358ae439990c1a3518144c4 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 3 Nov 2014 21:36:44 -0500 Subject: [PATCH] Adjust contract generation for provides in TR Use the same mechanism as ordinary require/typed to generate contracts for provide forms. original commit: 34076af389b717cb9840b960adb9a8761bd05db7 --- .../typed-racket-lib/typed-racket/core.rkt | 7 ++- .../private/syntax-properties.rkt | 1 + .../typed-racket/private/type-contract.rkt | 51 +++++++++++++++++-- .../typecheck/provide-handling.rkt | 28 +++------- 4 files changed, 61 insertions(+), 26 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt index f3eebb3e..38ec1649 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt @@ -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 ) to see more.]") diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt index 808b9053..a0863e13 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index 527b4cc5..e80c75e5 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt index 2f29c4a2..bedd3151 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt @@ -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)))