From fef047b54e8d148f3c38fb02cbe83e417a389321 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 4 Nov 2014 17:04:02 -0500 Subject: [PATCH] Simplify contract generation code Don't export type->contract except for testing. This discourages direct use of type->contract in favor of using the change-contract-fixup approach. Also consolidate most of the contract-related syntax properties into a single property containing a prefab struct instance. original commit: b374902bf3dd24e06f64017aa3d89e29ec6ffd42 --- .../typed-racket/base-env/prims.rkt | 15 +++--- .../private/syntax-properties.rkt | 4 -- .../typed-racket/private/type-contract.rkt | 53 +++++++------------ .../typed-racket/private/with-types.rkt | 18 +++---- .../typecheck/provide-handling.rkt | 4 +- .../typed-racket/typecheck/tc-toplevel.rkt | 5 +- .../unit-tests/contract-tests.rkt | 1 + 7 files changed, 39 insertions(+), 61 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index bcd18892..fd3d8ebe 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -212,13 +212,10 @@ This file defines two sorts of primitives. All of them are provided into any mod (define/with-syntax sm (if (attribute parent) #'(#:struct-maker parent) #'())) - (define property - (if (attribute parent) - contract-def/maker-property - contract-def-property)) ;; define `cnt*` to be fixed up later by the module type-checking (define cnt* - (syntax-local-lift-expression (property #'#f #'ty))) + (syntax-local-lift-expression + (make-contract-def-rhs #'ty #f (attribute parent)))) (quasisyntax/loc stx (begin #,(internal #'(require/typed-internal hidden ty . sm)) @@ -268,6 +265,10 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; make-predicate ;; cast +;; Helper to construct syntax for contract definitions +(define-for-syntax (make-contract-def-rhs type flat? maker?) + (contract-def-property #'#f `#s(contract-def ,type ,flat? ,maker? untyped))) + (define-syntax (define-predicate stx) (syntax-parse stx [(_ name:id ty:expr) @@ -285,7 +286,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx [(_ ty:expr) (define name (syntax-local-lift-expression - (flat-contract-def-property #'#f #'ty))) + (make-contract-def-rhs #'ty #t #f))) (define (check-valid-type _) (define type (parse-type #'ty)) (define vars (fv type)) @@ -320,7 +321,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #'v] [else (define ctc (syntax-local-lift-expression - (contract-def-property #'#f #'ty))) + (make-contract-def-rhs #'ty #f #f))) (define (check-valid-type _) (define type (parse-type #'ty)) (define vars (fv type)) 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 6de31571..164a8c8b 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 @@ -50,12 +50,8 @@ (ignore typechecker:ignore #:mark) (ignore-some typechecker:ignore-some #:mark) (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) (with-type typechecker:with-type #:mark) (type-ascription type-ascription) 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 18ceb003..6465a1ec 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 @@ -31,39 +31,24 @@ (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 +(provide 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 -;; expression to the module level will put the property on the body. -(define-syntax (contract-finders stx) - (define-syntax-class clause - (pattern name:id - #:with external-name (format-id #'name "typechecker:~a" #'name) - #:with syntax-class-name (format-id #'name "~a^" #'name))) - (syntax-parse stx - [(_ #:union union-name:id :clause ... ) - #'(begin - (define external-name - (syntax-parser - #:literal-sets (kernel-literals) - [(~or (~var v syntax-class-name) - (define-values (_) (~var v syntax-class-name))) - (attribute v.value)] - [_ #f])) ... - (define (union-name stx) - (or (external-name stx) ...)))])) +;; submod for testing +(module* test-exports #f (provide type->contract)) -(contract-finders - #:union define/fixup-contract? - contract-def flat-contract-def contract-def/maker contract-def/with-type) +(struct contract-def (type flat? maker? typed-side) #:prefab) + +;; Checks if the given syntax needs to be fixed up for contract generation +;; and if yes it returns the information stored in the property +(define (get-contract-def-property stx) + (syntax-parse stx + #:literal-sets (kernel-literals) + [(define-values (_) e) (contract-def-property #'e)] + [_ #f])) ;; type->contract-fail : Syntax Type #:ctc-str String ;; -> #:reason (Option String) -> Void @@ -80,11 +65,9 @@ to-check)) (define (generate-contract-def stx) - (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 prop (get-contract-def-property stx)) + (match-define (contract-def type-stx flat? maker? typed-side) prop) + (define typ (parse-type type-stx)) (define kind (if flat? 'flat 'impersonator)) (syntax-parse stx #:literals (define-values) [(define-values (n) _) @@ -95,10 +78,10 @@ typ ;; this value is from the typed side (require/typed, make-predicate, etc) ;; unless it's used for with-type - #:typed-side typed? + #:typed-side (from-typed? typed-side) #:kind kind (type->contract-fail - typ prop + typ type-stx #:ctc-str (if flat? "predicate" "contract")))]) (ignore ; should be ignored by the optimizer (quasisyntax/loc stx (define-values (n) cnt)))))] @@ -153,7 +136,7 @@ (define (change-contract-fixups forms) (for/list ((e (in-list forms))) - (if (not (define/fixup-contract? e)) + (if (not (get-contract-def-property e)) e (begin (set-box! include-extra-requires? #t) (generate-contract-def e))))) 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 ee829891..859e7021 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 @@ -43,8 +43,6 @@ (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) (do-standard-inits) (define fv-types (for/list ([t (in-syntax fvtys)]) @@ -52,13 +50,12 @@ (define ex-types (for/list ([t (in-syntax extys)]) (parse-type t))) (define-values (fv-ctc-ids fv-ctc-defs) - (type-stxs->ids+defs (syntax->list fvtys) contract-def-property)) + (type-stxs->ids+defs (syntax->list fvtys) 'untyped)) (define-values (ex-ctc-ids ex-ctc-defs) - (type-stxs->ids+defs (syntax->list extys) contract-def/with-type-property)) + (type-stxs->ids+defs (syntax->list extys) 'typed)) (define-values (region-ctc-ids region-ctc-defs) (if expr? - (type-stxs->ids+defs (values-stx->type-stxs resty) - contract-def/with-type-property) + (type-stxs->ids+defs (values-stx->type-stxs resty) 'typed) (values null null))) (define region-tc-result (and expr? (parse-tc-results resty))) @@ -153,12 +150,15 @@ (syntax->list #'(t ...))] [t (list #'t)])) -;; type-stxs->ids+defs : (Listof Syntax) Procedure -> (Listof Id Syntax) +;; type-stxs->ids+defs : (Listof Syntax) Symbol -> (Listof Id Syntax) ;; Create identifiers and definition syntaxes for contract generation -(define (type-stxs->ids+defs type-stxs property) +(define (type-stxs->ids+defs type-stxs typed-side) (for/lists (_1 _2) ([t (in-list type-stxs)]) (define ctc-id (generate-temporary)) - (values ctc-id #`(define-values (#,ctc-id) #,(property #'#f t))))) + (values ctc-id + #`(define-values (#,ctc-id) + #,(contract-def-property + #'#f `#s(contract-def ,t #f #f ,typed-side)))))) (define (wt-core stx) (define-syntax-class typed-id 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 bedd3151..85800003 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 @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" 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?) + (only-in (private type-contract) include-extra-requires?) (private syntax-properties) (types printer) (typecheck renamer def-binding) @@ -135,8 +135,6 @@ ;; 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]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 4301ff2b..84bdbeb8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -275,15 +275,14 @@ (define (type-check forms0) (define forms (syntax->list forms0)) (do-time "before form splitting") - (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs) + (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs) (filter-multiple forms type-alias? (lambda (e) (or (typed-struct? e) (typed-struct/exec? e))) parse-syntax-def parse-def - provide? - define/fixup-contract?)) + provide?)) (do-time "Form splitting done") (define-values (type-alias-names type-alias-map) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt index d073d491..e9462d05 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt @@ -9,6 +9,7 @@ (types abbrev numeric-tower union) (static-contracts combinators optimize) (submod typed-racket/private/type-contract numeric-contracts) + (submod typed-racket/private/type-contract test-exports) (only-in racket/contract contract) rackunit) (provide tests)