From 541dcded61eb4e6625c74b92a9289d1e2e99d1d8 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 4 Nov 2014 17:01:08 -0500 Subject: [PATCH] Avoid direct use of type->contract in with-type Eliminates the last remaining use of type->contract outside of the type-contract.rkt file. This allows all contract generation to go through a single point of control. original commit: 7b6ae09a2dcf04a5755f6f9256ff82369cc52403 --- .../private/syntax-properties.rkt | 2 + .../typed-racket/private/type-contract.rkt | 8 ++- .../typed-racket/private/with-types.rkt | 69 ++++++++++++------- 3 files changed, 50 insertions(+), 29 deletions(-) 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 a0863e13..6de31571 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,8 @@ (ignore-some-expr typechecker:ignore-some) (contract-def/maker typechecker:contract-def/maker) (contract-def typechecker:contract-def) + ;; for exporting from a with-type expression + (contract-def/with-type typechecker:contract-def/with-type) (contract-def/provide typechecker:contract-def/provide) (flat-contract-def typechecker:flat-contract-def) (external-check typechecker:external-check) 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 388417e7..18ceb003 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 @@ -63,7 +63,7 @@ (contract-finders #:union define/fixup-contract? - contract-def flat-contract-def contract-def/maker) + contract-def flat-contract-def contract-def/maker contract-def/with-type) ;; type->contract-fail : Syntax Type #:ctc-str String ;; -> #:reason (Option String) -> Void @@ -83,6 +83,7 @@ (define prop (define/fixup-contract? stx)) (define maker? (typechecker:contract-def/maker stx)) (define flat? (typechecker:flat-contract-def stx)) + (define typed? (and (typechecker:contract-def/with-type stx) #t)) (define typ (parse-type prop)) (define kind (if flat? 'flat 'impersonator)) (syntax-parse stx #:literals (define-values) @@ -92,8 +93,9 @@ typ)]) (with-syntax ([cnt (type->contract typ - ;; this is for a `require/typed', so the value is not from the typed side - #:typed-side #f + ;; this value is from the typed side (require/typed, make-predicate, etc) + ;; unless it's used for with-type + #:typed-side typed? #:kind kind (type->contract-fail typ prop diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt index 85a656dc..ee829891 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt @@ -5,13 +5,15 @@ (except-in (base-env prims) with-handlers λ lambda define) (env type-name-env type-alias-env type-env-structs global-env tvar-env) - (private parse-type type-contract) + (private parse-type type-contract syntax-properties) (typecheck tc-toplevel typechecker) (types utils) - (utils lift tc-utils disarm arm) + (utils lift tc-utils disarm arm literal-syntax-class) racket/match racket/promise racket/require + racket/syntax + syntax/flatten-begin syntax/parse unstable/sequence "../tc-setup.rkt" @@ -28,7 +30,12 @@ for*/or for*/sum for*/product for*/first for*/last for*/fold) (base-env prims) - (prefix-in c: (combine-in racket/contract/region racket/contract/base)))) + (prefix-in c: (combine-in racket/contract/region racket/contract/base))) + (for-label racket/base + (base-env base-types-extra))) + +(define-literal-syntax-class #:for-label Values) +(define-literal-syntax-class #:for-label values) (provide wt-core) @@ -42,27 +49,19 @@ (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)] - [stx (in-syntax fvtys)]) - (type->contract t #:typed-side #f (no-contract t)))) (define ex-types (for/list ([t (in-syntax extys)]) (parse-type t))) - (define ex-cnts (for/list ([t (in-list ex-types)] - [stx (in-syntax extys)]) - (type->contract t #:typed-side #t (no-contract t)))) + (define-values (fv-ctc-ids fv-ctc-defs) + (type-stxs->ids+defs (syntax->list fvtys) contract-def-property)) + (define-values (ex-ctc-ids ex-ctc-defs) + (type-stxs->ids+defs (syntax->list extys) contract-def/with-type-property)) + (define-values (region-ctc-ids region-ctc-defs) + (if expr? + (type-stxs->ids+defs (values-stx->type-stxs resty) + contract-def/with-type-property) + (values null null))) (define region-tc-result (and expr? (parse-tc-results resty))) - (define region-cnts - (if region-tc-result - (match region-tc-result - [(tc-result1: t) - (list (type->contract t #:typed-side #t (no-contract t #'region-ty-stx)))] - [(tc-results: ts) - (for/list ([t (in-list ts)]) - (type->contract - t #:typed-side #t - (no-contract t #'region-ty-stx)))]) - null)) (for ([i (in-syntax fvids)] [ty (in-list fv-types)]) (register-type i ty)) @@ -102,10 +101,10 @@ (for ([i (in-syntax fvids)]) (unregister-type i)) (with-syntax ([(fv.id ...) fvids] - [(cnt ...) fv-cnts] + [(cnt ...) fv-ctc-ids] [(ex-id ...) exids] - [(ex-cnt ...) ex-cnts] - [(region-cnt ...) region-cnts] + [(ex-cnt ...) ex-ctc-ids] + [(region-cnt ...) region-ctc-ids] [(body) (maybe-optimize #`(#,expanded-body))] [check-syntax-help (syntax-property (syntax-property @@ -113,25 +112,29 @@ 'disappeared-binding (disappeared-bindings-todo)) 'disappeared-use (disappeared-use-todo))]) (define fixed-up-definitions - (change-contract-fixups lifted-definitions)) + (change-contract-fixups + (flatten-all-begins + #`(begin #,lifted-definitions + #,@(if expr? (append region-ctc-defs fv-ctc-defs) null) + #,@(if (not expr?) ex-ctc-defs null))))) (arm (if expr? (quasisyntax/loc stx (let () check-syntax-help (local-require #,@(cdr (syntax-e extra-requires))) + #,@fixed-up-definitions (c:with-contract typed-region #:results (region-cnt ...) #:freevars ([fv.id cnt] ...) - #,fixed-up-definitions body))) (quasisyntax/loc stx (begin (local-require #,@(cdr (syntax-e extra-requires))) (define-values () (begin check-syntax-help (values))) + #,@fixed-up-definitions (c:with-contract typed-region ([ex-id ex-cnt] ...) - #,fixed-up-definitions (define-values (ex-id ...) body)))))))) ;; Syntax (U Symbol List) -> (values Syntax Syntax) @@ -143,6 +146,20 @@ (values (disarm* #'(begin (define-values (x ...) e ...) ...)) (disarm* (local-expand/capture* #'(let-values () . body) ctx null)))])) +;; Deconstruct values type stx that the user wrote +(define (values-stx->type-stxs values-stx) + (syntax-parse values-stx + [((~or :Values^ :values^) t ...) + (syntax->list #'(t ...))] + [t (list #'t)])) + +;; type-stxs->ids+defs : (Listof Syntax) Procedure -> (Listof Id Syntax) +;; Create identifiers and definition syntaxes for contract generation +(define (type-stxs->ids+defs type-stxs property) + (for/lists (_1 _2) ([t (in-list type-stxs)]) + (define ctc-id (generate-temporary)) + (values ctc-id #`(define-values (#,ctc-id) #,(property #'#f t))))) + (define (wt-core stx) (define-syntax-class typed-id #:description "[id type]"