contract: repair contract generation for type application

Author: capfredf

typed-racket-lib/typed-racket/env/type-alias-helper.rkt

@@ -292,7 +292,8 @@
                                                          (define res (in-same-component? id x))
                                                          res)
                                                        type-alias-productivity-map
-                                                       #:delay-variances? #t))
+                                                       #:delay-variances? #t
+                                                       #:recursive? #t))
         (register-type-constructor! id ty-op)
         (complete-type-alias-registration! id)
         (reset-resolver-cache!)

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

@@ -66,7 +66,8 @@
  [parse-type-operator-abstraction (c:->* (identifier? (c:listof identifier?) syntax?)
                                          ((c:or/c (c:-> identifier? boolean?) #f)
                                           (free-id-table/c identifier? boolean?)
-                                          #:delay-variances? boolean?)
+                                          #:delay-variances? boolean?
+                                          #:recursive? boolean?)
                                          TypeConstructor?)]
  [parse-for-effects (c:-> identifier? (c:cons/c (c:listof identifier?) syntax?)
                           (values (c:listof identifier?)
@@ -651,7 +652,8 @@
 (define (parse-type-operator-abstraction name arg-names stx [opt-in-same-component? #f]
                                          [type-op-productivity-map (make-immutable-free-id-table)]
                                          #:delay-variances?
-                                         [delay-variances? #f])
+                                         [delay-variances? #f]
+                                         #:recursive? [recursive? #f])
   (define syms (map syntax-e arg-names))
   (define mode (synth-mode name syms opt-in-same-component?))
   (define var-kind-level-env
@@ -670,7 +672,7 @@
                                    var-kind-level-env
                                    #:mode mode)))
 
-  (make-type-constr (user-defined-type-op syms res)
+  (make-type-constr (user-defined-type-op syms res recursive?)
                     (length syms)
                     (free-id-table-ref type-op-productivity-map name #f)
                     #:variances

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

@@ -14,9 +14,12 @@
  "../utils/prefab.rkt"
  "../utils/identifier.rkt"
 
+ "../private/user-defined-type-constr.rkt"
+
  "../env/type-name-env.rkt"
  "../env/row-constraint-env.rkt"
  "../env/lexical-env.rkt"
+ "../env/type-constr-env.rkt"
 
  "../rep/core-rep.rkt"
  "../rep/rep-utils.rkt"
@@ -412,17 +415,25 @@
         ;; Key with (cons name 'app) instead of just name because the
         ;; application of the Name is not necessarily the same as the
         ;; Name type alone
-        (cond [(hash-ref recursive-values (cons name 'app) #f)]
-              [else
-               (define name* (generate-temporary name))
-               (recursive-sc (list name*)
-                             (list
-                              (t->sc (resolve-once type)
-                                     #:recursive-values
-                                     (hash-set recursive-values
-                                               (cons name 'app)
-                                               (recursive-sc-use name*))))
-                             (recursive-sc-use name*))])]
+        (define constr (lookup-type-constructor name))
+        (cond
+          ;; when constr is a built-in or non-recursive user-defined type
+          ;; constructor, don't generate a recursive static contract
+          ;; for the resulting type.
+          [(not (and (user-defined-type-constr? constr)
+                     (recursive-type-constr? constr)))
+           (t->sc (resolve-once type))]
+          [(hash-ref recursive-values (cons name 'app) #f)]
+          [else
+           (define name* (generate-temporary name))
+           (recursive-sc (list name*)
+                         (list
+                          (t->sc (resolve-once type)
+                                 #:recursive-values
+                                 (hash-set recursive-values
+                                           (cons name 'app)
+                                           (recursive-sc-use name*))))
+                         (recursive-sc-use name*))])]
        ;; Implicit recursive aliases
        [(Name: name-id args #f)
         (cond [;; recursive references are looked up in a special table

typed-racket-lib/typed-racket/private/user-defined-type-constr.rkt

@@ -7,22 +7,30 @@
                (subst-all make-simple-substitution)])
 
 (provide (struct-out user-defined-type-op)
-         user-defined-type-constr?)
+         user-defined-type-constr?
+         recursive-type-constr?)
 
-(struct user-defined-type-op (vars type) #:transparent
+(struct user-defined-type-op (vars type recursive?) #:transparent
   #:methods gen:type-rep-maker
   [(define (gen-create-type-rep me args)
-     (match-define (user-defined-type-op vars type) me)
+     (match-define (user-defined-type-op vars type recursive?) me)
      (subst-all (make-simple-substitution vars args)
                 type))
    (define (gen-serialize-type-rep me t->s)
-     (match-define (user-defined-type-op vars type) me)
+     (match-define (user-defined-type-op vars type recursive?) me)
      `(user-defined-type-op (list ,@(for/list ([i (in-list vars)])
                                       `(quote ,i)))
-                            ,(t->s type)))])
+                            ,(t->s type)
+                            ,recursive?))])
 
 (define (user-defined-type-constr? constr-rep)
   (match constr-rep
     [(struct* TypeConstructor ([real-trep-constr (? user-defined-type-op?)]))
      #t]
     [_ #f]))
+
+(define (recursive-type-constr? constr)
+  (match constr
+    [(struct* TypeConstructor
+              ([real-trep-constr (struct* user-defined-type-op ([recursive? recursive?]))]))
+     recursive?]))

typed-racket-lib/typed-racket/rep/free-variance.rkt

@@ -210,7 +210,7 @@
         (match-define (struct* TypeConstructor ([real-trep-constr maker]
                                                 [variances old-variances]))
           constr)
-        (match-define (struct user-defined-type-op [tvars type]) maker)
+        (match-define (struct user-defined-type-op [tvars type _]) maker)
         (cond
           [(or (not tvars) (null? tvars)) #t]
           [else

typed-racket-lib/typed-racket/typecheck/tc-structs.rkt

@@ -233,7 +233,7 @@
                       (make-Poly (struct-desc-tvars desc) sty))
   (unless (empty? (struct-desc-tvars desc))
     (define variances (map (lambda _ variance:const) (struct-desc-tvars desc)))
-    (define ty-op (make-type-constr (user-defined-type-op (struct-desc-tvars desc) sty)
+    (define ty-op (make-type-constr (user-defined-type-op (struct-desc-tvars desc) sty #f)
                                     (length (struct-desc-tvars desc))
                                     #:variances
                                     variances))

typed-racket-test/succeed/type-constr-contract.rkt

@@ -0,0 +1,11 @@
+#lang racket
+
+(module typed typed/racket/base
+
+  (define-type (LV a) (Listof a))
+  (provide make)
+  (define (make [in : (LV (LV Natural))]) : Void
+    (void)))
+
+(require 'typed)
+(make '((1 1) (2 2) (3 3) (4 4)))