Reduce expansion from type and contract generation.

typed-racket-lib/typed-racket/base-env/base-contracted.rkt

@@ -31,6 +31,7 @@
 (begin-for-syntax
   (module* #%type-decl #f
     (#%plain-module-begin
+     (#%declare #:empty-namespace)
      (require typed-racket/env/global-env
               typed-racket/types/abbrev
               typed-racket/rep/type-rep)
@@ -43,3 +44,9 @@
       ;;
       ;;       Also, this type works better with inference.
       (-> (make-Prompt-Tagof Univ (-> Univ ManyUniv)))))))
+
+;; we also have to manually add these submodules which extra-env-lang.rkt would do for us
+(begin-for-syntax
+  (module* #%contract-defs-names #f (#%plain-module-begin (#%declare #:empty-namespace))))
+(module* #%contract-defs #f (#%plain-module-begin (#%declare #:empty-namespace)))
+

typed-racket-lib/typed-racket/base-env/base-types.rkt

@@ -93,7 +93,7 @@
 
 [Void -Void]
 [Undefined -Undefined] ; initial value of letrec bindings
-;; [Unsafe-Undefined -Unsafe-Undefined] ; not clear that it makes sense to export this
+[Unsafe-Undefined -Unsafe-Undefined] ; not clear that it makes sense to export this
 [Boolean -Boolean]
 [Symbol -Symbol]
 [String -String]

typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt

@@ -78,8 +78,20 @@
 
 (define-syntax (-#%module-begin stx)
   (syntax-parse stx
+    [(mb #:contract-defs e ...)
+     #'(#%plain-module-begin
+        (require (for-syntax typed-racket/env/env-req))
+        e ...
+        ;; need to register this module
+        (begin-for-syntax (add-mod! (variable-reference->module-path-index
+                                     (#%variable-reference)))))]
     [(mb e ...)
      #'(#%plain-module-begin
+        ;; auto-generate these modules unless they are explicitly provided
+        ;; use #%plain-module-begin to avoid adding add-mod! calls in them
+        (begin-for-syntax (module* #%contract-defs-names #f
+                            (#%plain-module-begin (#%declare #:empty-namespace))))
+        (module* #%contract-defs #f (#%plain-module-begin (#%declare #:empty-namespace)))
         (require (for-syntax typed-racket/env/env-req))
         e ...
         ;; need to register this module

typed-racket-lib/typed-racket/base-env/prims.rkt

@@ -141,6 +141,7 @@ the typed racket language.
 ;; contracted bindings in typed modules) values that are contracted
 ;; for _all_ typed programs.
 (module+ #%contract-defs
+  (#%declare #:empty-namespace)
   (require "base-contracted.rkt")
   (provide (all-from-out "base-contracted.rkt")))
 

typed-racket-lib/typed-racket/env/env-req.rkt

@@ -1,13 +1,54 @@
 #lang racket/base
+(require syntax/modresolve syntax/modcollapse (for-template racket/base) racket/match)
 (define to-require null)
 (define (add-mod! m)
   (set! to-require (cons m to-require)))
 
+;; produce code for all the requires we need to load types
+(define (get-requires)
+  (for/list ([m (in-list to-require)]
+             #:when m)
+    (define path (->mp m '#%type-decl))
+    #`(#%require (only #,(adjust path)))))
+
+;; dynamically do all of the above requires
+;; populates the type name tables
 (define (do-requires [ns (current-namespace)])
   (parameterize ([current-namespace ns])
     (for ([m (in-list to-require)]
           #:when m)
       (dynamic-require (module-path-index-join '(submod "." #%type-decl) m)
                        #f))))
 
-(provide add-mod! do-requires)
+;; adjust: require-spec -> require-spec
+;; rewrite a spec that works in a module M to one that works in a submodule of M
+(define (adjust p)
+  (match p
+    [`(submod "." ,r0 ,rest ...)
+     `(submod ".." ,r0 . ,rest)]
+    [`(submod ,(and up (or "." "..")) ,rest ...)
+     `(submod ".." ,up . ,rest)]
+    [_ p]))
+
+;; ->mp : module-path-index? symbol? -> module-path-index?
+;; combine module-path-index with a submodule, producing an sexp we can manipulate
+(define (->mp mpi submod)
+  (collapse-module-path-index (module-path-index-join `(submod "." ,submod) mpi)))
+
+;; generate code to require the modules that have the definitions of the contracts
+(define (get-contract-requires)
+  (for/list ([m (in-list to-require)] #:when m)
+    #`(#%require (only #,(adjust (->mp m '#%contract-defs))))))
+
+;; dynamically do the above requires
+;; populates the table that tells us what names get us what contracts
+(define (do-contract-requires [ns (current-namespace)])
+  (parameterize ([current-namespace ns])
+    (for ([m (in-list to-require)]
+          #:when m)
+      (dynamic-require
+       (module-path-index-join '(submod "." #%contract-defs-names) m)
+       #f))))
+
+(provide add-mod! do-requires get-requires
+         get-contract-requires do-contract-requires)

typed-racket-lib/typed-racket/env/init-envs.rkt

@@ -61,13 +61,15 @@
 ;; Compute for a given type how many times each type inside of it
 ;; is referenced
 (define (compute-popularity x)
+  (define v (hash-ref pop-table x 0))
   (when (Type? x)
-    (hash-update! pop-table x add1 0))
-  (when (Rep? x)
+    (hash-set! pop-table x (add1 v)))
+  (when (and (Rep? x) (zero? v))
     (Rep-for-each x compute-popularity)))
 
+;; types that are popular (referenced more than once) get their own definition
 (define (popular? ty)
-  (> (hash-ref pop-table ty 0) 5))
+  (> (hash-ref pop-table ty 0) 1))
 
 ;; Type -> S-Exp
 ;; Convert a type to an s-expression to evaluate
@@ -81,8 +83,8 @@
                  ;; predefined table
                  [(and (not (identifier? *res))
                        (popular? ty))
-                  (define id (gensym))
-                  (enqueue! type-definitions #`(define #,id #,*res))
+                  (define id (car (generate-temporaries '(g))))
+                  (enqueue! type-definitions #`(define/decl #,id #,*res))
                   id]
                  [else *res]))
         (hash-set! type-cache ty res)
@@ -168,6 +170,15 @@
                                               (TrueProp:))
                                     (Empty:)))))))
      `(simple-> (list ,@(map type->sexp dom)) ,(type->sexp t))]
+    [(Fun: (list (Arrow: dom #f '()
+                         (Values:
+                          (list
+                           (Result: t
+                                    (PropSet: (TrueProp:)
+                                              (TrueProp:))
+                                    (Empty:))
+                           ...)))))
+     `(simple->values (list ,@(map type->sexp dom)) (list ,@(map type->sexp t)))]
     [(Fun: (list (Arrow: dom #f'()
                          (Values:
                           (list
@@ -197,7 +208,7 @@
      (match-define (Arrow: fdoms _ kws rng) (first arrs))
      (match-define (Arrow: ldoms rst _ _) (last arrs))
      (define opts (drop ldoms (length fdoms)))
-     `(opt-fn
+     `(opt-fn*
        (list ,@(map type->sexp fdoms))
        (list ,@(map type->sexp opts))
        ,(type->sexp rng)
@@ -278,10 +289,10 @@
                            `(quote ,n)))
                      ,(type->sexp b))]
     [(PolyRow-names: ns c b)
-     `(make-PolyRow (list ,@(for/list ([n (in-list ns)])
-                              `(quote ,n)))
-                    (quote ,c)
-                    ,(type->sexp b))]
+     `(make-PolyRow-simple (list ,@(for/list ([n (in-list ns)])
+                                     `(quote ,n)))
+                           (quote ,c)
+                           ,(type->sexp b))]
     [(Row: inits fields methods augments init-rest)
      `(make-Row (list ,@(convert-row-clause inits #t))
                 (list ,@(convert-row-clause fields))
@@ -295,6 +306,7 @@
                   (list ,@(convert-row-clause methods))
                   (list ,@(convert-row-clause augments))
                   ,(and init-rest (type->sexp init-rest)))]
+    [(Instance: (Name: n 0 #f)) `(simple-inst (quote-syntax ,n))]
     [(Instance: ty) `(make-Instance ,(type->sexp ty))]
     [(Signature: name extends mapping)
      (define (serialize-mapping m)
@@ -312,15 +324,9 @@
                  (list ,@(map type->sexp exports))
                  (list ,@(map type->sexp init-depends))
                  ,(type->sexp result))]
-    [(Arrow: dom #f '()
-             (Values: (list (Result: t (PropSet: (TrueProp:)
-                                                 (TrueProp:))
-                                     (Empty:)))))
-     `(-Arrow (list ,@(map type->sexp dom))
-              ,(type->sexp t))]
     [(Arrow: dom #f '() rng)
-     `(-Arrow (list ,@(map type->sexp dom))
-              ,(type->sexp rng))]
+     `(simple-arrow (list ,@(map type->sexp dom))
+                    ,(type->sexp rng))]
     [(Arrow: dom rest kws rng)
      `(make-Arrow
        (list ,@(map type->sexp dom))

typed-racket-lib/typed-racket/private/type-contract.rkt

@@ -2,12 +2,14 @@
 
 ;; Contract generation for Typed Racket
 
+
+
 (require
  "../utils/utils.rkt"
  syntax/parse
  (rep type-rep prop-rep object-rep fme-utils)
  (utils tc-utils prefab identifier)
- (env type-name-env row-constraint-env)
+ (env type-name-env row-constraint-env env-req)
  (rep core-rep rep-utils free-ids type-mask values-rep
       base-types numeric-base-types)
  (types resolve utils printer match-expanders union subtype)
@@ -27,13 +29,15 @@
 
 (provide
   (c:contract-out
-    [type->static-contract
-      (c:parametric->/c (a) ((Type? (c:-> #:reason (c:or/c #f string?) a))
-                             (#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
+   [type->contract c:any/c]
+   [type->static-contract
+    (c:parametric->/c (a) ((Type? (c:-> #:reason (c:or/c #f string?) a))
+                           (#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
 
 (provide change-contract-fixups
          change-provide-fixups
          any-wrap/sc
+         from-typed?
          extra-requires
          include-extra-requires?)
 
@@ -163,7 +167,8 @@
   (and (identifier? ctc-stx)
        (let ([match? (assoc ctc-stx (hash-values cache) free-identifier=?)])
          (and match?
-              (should-inline-contract? (cdr match?))
+              (or (should-inline-contract? (cdr match?))
+                  (function-contract? (cdr match?)))
               (cdr match?)))))
 
 ;; The below requires are needed since they provide identifiers that
@@ -172,20 +177,26 @@
 ;; TODO: It would be better to have individual contracts specify which
 ;; modules should be required, but for now this is just all of them.
 (define extra-requires
-  #'(require
-      (submod typed-racket/private/type-contract predicates)
-      typed-racket/utils/utils
-      (for-syntax typed-racket/utils/utils)
-      typed-racket/utils/any-wrap typed-racket/utils/struct-type-c
-      typed-racket/utils/prefab-c
-      typed-racket/utils/opaque-object
-      typed-racket/utils/evt-contract
-      typed-racket/utils/hash-contract
-      typed-racket/utils/sealing-contract
-      typed-racket/utils/promise-not-name-contract
-      typed-racket/utils/simple-result-arrow
-      racket/sequence
-      racket/contract/parametric))
+  #`(require
+     ;; some built-in types that aren't available in `racket/base`
+     (submod typed-racket/private/type-contract predicates)
+     ;; a table of contracts that are defined in other modules so they aren't
+     ;; repeated
+     (submod typed-racket/static-contracts/instantiate predefined-contracts)
+     ;; utility functions
+     typed-racket/utils/utils
+     (for-syntax typed-racket/utils/utils)
+     racket/sequence
+     ;; contract combinators
+     typed-racket/utils/any-wrap typed-racket/utils/struct-type-c
+     typed-racket/utils/prefab-c
+     typed-racket/utils/opaque-object
+     typed-racket/utils/evt-contract
+     typed-racket/utils/hash-contract
+     typed-racket/utils/sealing-contract
+     typed-racket/utils/promise-not-name-contract
+     typed-racket/utils/simple-result-arrow
+     racket/contract/parametric))
 
 ;; Should the above requires be included in the output?
 ;;   This box is only used for contracts generated for `require/typed`
@@ -314,7 +325,7 @@
 ;; Macro to simplify (and avoid reindentation) of the match below
 ;;
 ;; The sc-cache hashtable is used to memoize static contracts. The keys are
-;; a pair of the Type-seq number for a type and 'untyped or 'typed
+;; a pair of the type and 'untyped or 'typed
 (define-syntax (cached-match stx)
   (syntax-case stx ()
     [(_ sc-cache type-expr typed-side-expr match-clause ...)
@@ -401,6 +412,9 @@
             sc))
       (cached-match
        sc-cache type typed-side
+       [(app (lambda (t) (hash-ref predef-contracts (cons t typed-side) #f))
+             (? values con-id))
+        (impersonator/sc (syntax-local-introduce con-id))]
        ;; Applications of implicit recursive type aliases
        ;;
        ;; We special case this rather than just resorting to standard
@@ -1008,6 +1022,8 @@
   (define extflnonnegative? (lambda (x) (extfl>= x 0.0t0)))
   (define extflnonpositive? (lambda (x) (extfl<= x 0.0t0))))
 
+(require (submod "../static-contracts/instantiate.rkt" predefined-contracts))
+
 (module numeric-contracts racket/base
   (require
     "../utils/utils.rkt"