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.

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))

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)

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
+(provide change-contract-fixups
-         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
+;; submod for testing
-;; property. Normally the define form will have the property but lifting an
+(module* test-exports #f (provide type->contract))
-;; 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) ...)))]))
 
-(contract-finders
+(struct contract-def (type flat? maker? typed-side) #:prefab)
-  #:union define/fixup-contract?
+
-  contract-def flat-contract-def contract-def/maker contract-def/with-type)
+;; 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 prop (get-contract-def-property stx))
-  (define maker? (typechecker:contract-def/maker stx))
+  (match-define (contract-def type-stx flat? maker? typed-side) prop)
-  (define flat? (typechecker:flat-contract-def stx))
+  (define typ (parse-type type-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)
     [(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)))))

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)
+        (type-stxs->ids+defs (values-stx->type-stxs resty) 'typed)
-                             contract-def/with-type-property)
         (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

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])

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?
+     provide?))
-     define/fixup-contract?))
   (do-time "Form splitting done")
 
   (define-values (type-alias-names type-alias-map)

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)