Revert "Revert accidentally-pushed changes with HISTORY update."

This reverts commit c662043.

Author: capfredf

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

@@ -57,10 +57,11 @@
     (map vertex-data component)))
 
 
-;; register-all-type-aliases : Listof<Syntax> -> Void
+;; register-all-type-aliases : Listof<Syntax> IDTable<ID, Listof<ID>> -> Void
 ;;
 ;; register all type alias definitions carried by the input syntaxes
-(define (register-all-type-aliases type-aliases)
+;; dependency-map accounts for the dependencies of struct declarations
+(define (register-all-type-aliases type-aliases [dependency-map (make-immutable-free-id-table)])
   (parameterize ([incomplete-name-alias-map (make-free-id-table)])
     (define-values (type-alias-names type-alias-map)
       (for/lists (_1 _2 #:result (values _1 (make-free-id-table
@@ -74,7 +75,7 @@
         (values id (list id type-stx args))))
 
     (begin0
-      (register-all-type-alias-info type-alias-names type-alias-map)
+      (register-all-type-alias-info type-alias-names type-alias-map dependency-map)
       (unless (zero? (free-id-table-count (incomplete-name-alias-map)))
         (define names (free-id-table-keys (incomplete-name-alias-map)))
         (int-err "not all type alias names are fully registered: ~n ~a"
@@ -91,7 +92,7 @@
 ;; of actually registering the type aliases. If struct names or
 ;; other definitions need to be registered, do that before calling
 ;; this function.
-(define (register-all-type-alias-info type-alias-names type-alias-map)
+(define (register-all-type-alias-info type-alias-names type-alias-map dependency-map)
   ;; Find type alias dependencies
   ;; The two maps defined here contains the dependency structure
   ;; of type aliases in two senses:
@@ -102,8 +103,19 @@
   ;; The second is necessary in order to prevent recursive
   ;; #:implements clauses and to determine the order in which
   ;; recursive type aliases should be initialized.
+
+  (define (free-id-table-union! a b)
+    (define struct-names (list->set (free-id-table-keys b)))
+    (for ([(id deps) (in-free-id-table b)])
+      (free-id-table-set! a id (filter (lambda (v)
+                                         (or (free-id-table-ref type-alias-map v #f)
+                                             (set-member? struct-names v)))
+                                       deps))))
+
   (define-values (type-alias-dependency-map type-alias-class-map type-alias-productivity-map)
-    (for/lists (_1 _2 _3 #:result (values (make-free-id-table _1)
+    (for/lists (_1 _2 _3 #:result (values (let ([tbl1 (make-free-id-table _1)])
+                                            (free-id-table-union! tbl1 dependency-map)
+                                            tbl1)
                                           (make-free-id-table _2)
                                           (make-free-id-table _3)))
                ([(name alias-info) (in-free-id-table type-alias-map)])
@@ -167,6 +179,7 @@
                               recursive-aliases
                               free-identifier=?))
       (car component)))
+
   (define other-recursive-aliases
     (for/list ([alias (in-list recursive-aliases)]
                #:unless (member alias
@@ -204,8 +217,9 @@
   ;; reverse order of that to avoid unbound type aliases.
   (define acyclic-constr-names
     (for/fold ([acc '()])
-              ([id (in-list acyclic-singletons)])
-      (match-define (list _ type-stx args) (free-id-table-ref type-alias-map id))
+              ([id (in-list acyclic-singletons)]
+               #:when (free-id-table-ref type-alias-map id #f))
+      (match-define (list _ type-stx args) (free-id-table-ref type-alias-map id #f))
       (define acc^
         (cond
           [(not (null? args))
@@ -251,7 +265,8 @@
                #:result
                (values (reverse type-records)
                        (reverse type-op-records)))
-              ([id (in-list (append other-recursive-aliases class-aliases))])
+              ([id (in-list (append other-recursive-aliases class-aliases))]
+               #:when (free-id-table-ref type-alias-map id #f))
       (define record (free-id-table-ref type-alias-map id))
       (match-define (list _ type-stx args) record)
       (if (null? args)
@@ -292,7 +307,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/env/type-constr-env.rkt

@@ -2,10 +2,12 @@
 (require "../rep/type-constr.rkt"
          syntax/id-table
          "../env/env-utils.rkt"
+         "../private/user-defined-type-constr.rkt"
          "../typecheck/renamer.rkt")
 
 (provide register-type-constructor!
          lookup-type-constructor
+         simple-type-constructor?
          kind-env-map)
 
 (define kind-env (make-free-id-table))
@@ -21,3 +23,14 @@
 
 (define (register-type-constructor! name type-constr)
   (free-id-table-set! kind-env name type-constr))
+
+
+;; returns true if id refers to a built-in or non-recursive type constructor
+(define (simple-type-constructor? id)
+  (cond
+    [(lookup-type-constructor id)
+     =>
+     (lambda (constr)
+       (not (and (user-defined-type-constr? constr)
+                 (recursive-type-constr? constr))))]
+    [else #f]))

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,10 @@
                                    var-kind-level-env
                                    #:mode mode)))
 
-  (make-type-constr (user-defined-type-op syms res)
+  (make-type-constr (user-defined-type-op syms res (if (equal? (symbol->string (syntax-e name))
+                                                               "Formula")
+                                                       #t
+                                                       recursive?))
                     (length syms)
                     (free-id-table-ref type-op-productivity-map name #f)
                     #:variances
@@ -1299,7 +1304,8 @@
                    (add-disappeared-use (syntax-local-introduce #'id)))
               t)]
            [else
-            (parse-error #:delayed? #t (~a "type name `" v "' is unbound"))
+            (unless (side-effect-mode? mode)
+              (parse-error #:delayed? #t (~a "type name `" v "' is unbound")))
             Err])]
         [(:Opaque^ . rest)
          (parse-error "bad syntax in Opaque")]

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

@@ -17,6 +17,7 @@
  "../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 +413,23 @@
         ;; 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*))])]
+        (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.
+          [(simple-type-constructor? name)
+           (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/rep/type-rep.rkt

@@ -185,13 +185,12 @@
              #:with fld-frees #'(make-invariant (frees name))))
   (syntax-parse stx
     [(_ name:var-name ((~var flds (structural-flds #'frees)) ...) . rst)
-     (with-syntax ([contructor-name (format-id #'name "make-~a-rep" (syntax-e #'name))]
+     (with-syntax ([constructor-name (format-id #'name "make-~a-rep" (syntax-e #'name))]
                    [type-constructor-name (format-id #'name "make-~a" (syntax-e #'name))])
        (define arity (length (syntax->list #'(flds ...))))
        (quasisyntax/loc stx
          (begin
            (def-rep (name #:constructor-name constructor-name) ([flds.name Type?] ...)
-             #:no-provide (constructor-name)
              [#:parent Type]
              [#:frees (frees) . #,(if (= 1 (length (syntax->list #'(flds.name ...))))
                                       #'(flds.fld-frees ...)

typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt

@@ -10,6 +10,7 @@
          "../find-annotation.rkt"
          "../tc-metafunctions.rkt"
          "../../types/abbrev.rkt"
+         "../../types/resolve.rkt"
          "../../types/utils.rkt"
          "../../types/generalize.rkt"
          "../../types/type-table.rkt"
@@ -108,8 +109,8 @@
                        (generalize (tc-expr/t ac)))))]
            [acc-ty (or
                     (type-annotation #'val #:infer #t)
-                    (match expected
-                      [(tc-result1: (and t (Listof: _))) t]
+                    (match (resolve expected)
+                      [(tc-result1: (app resolve (and t (Listof: _)))) t]
                       [_ #f])
                     (generalize -Null))])
        ;; this check is needed because the type annotation may come

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

@@ -44,7 +44,9 @@
 (provide tc/struct
          tc/struct-prop-values
          tc/make-struct-type-property
-         name-of-struct d-s
+         name-of-struct
+         names-referred-in-struct
+         d-s
          register-parsed-struct-sty!
          register-parsed-struct-bindings!)
 
@@ -90,6 +92,21 @@
   (syntax-parse stx
     [t:typed-struct #'t.type-name]))
 
+(define (names-referred-in-struct stx)
+  (define-values (tvars field-types)
+    (syntax-parse stx
+      [t:typed-struct (values (attribute t.tvars)
+                              (attribute t.types))]))
+  (define name (name-of-struct stx))
+
+  (cond
+    [(null? tvars) null]
+    [else
+     (append-map (lambda (t)
+                   (define-values (r _ __) (parse-for-effects name (cons tvars t)))
+                   r)
+                 field-types)]))
+
 ;; a simple wrapper to get proc from a polymorphic or monomorhpic structure
 (define/cond-contract (get-struct-proc sty)
   (c:-> (c:or/c Struct? Poly?) (c:or/c #f Fun?))
@@ -233,7 +250,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-lib/typed-racket/typecheck/tc-toplevel.rkt

@@ -428,17 +428,23 @@
               (~datum expand)))))
 
 ;; finish registering struct definitions in two steps with the second one being
-;; the return thunk, which can be invoked on demand.
-;; Listof[Expr] -> Promise[Listof[binding]]
+;; the return thunk, which can be invoked on demand. The function also returns a
+;; dependency mappping from struct type names to the type names used in their
+;; definitions.
+
+;; Listof[Expr] -> Values[Promise[Listof[binding]], FreeIDTable[Identifer, Identifer]]
 (define (register-struct-type-info! form-li)
   ;; register type name and alias first
-  (define-values (poly-names binding-reg)
+  (define-values (poly-names binding-reg dependency-map)
     (for/fold ([poly-names '()]
                [binding-reg '()]
+               [dependency-map (make-immutable-free-id-table)]
                #:result (values (reverse poly-names)
-                                (reverse binding-reg)))
+                                (reverse binding-reg)
+                                dependency-map))
               ([form (in-list form-li)])
       (define name (name-of-struct form))
+      (define other-names (names-referred-in-struct form))
       (define tvars (type-vars-of-struct form))
       (register-resolved-type-alias name (make-Name name (length tvars) #t))
       (register-type-name name)
@@ -448,11 +454,14 @@
                                name))
                     poly-names)
               (cons (delay (register-parsed-struct-bindings! (force parsed)))
-                    binding-reg))))
-  (delay (lambda (names)
-           (refine-user-defined-constructor-variances!
-            (append names (filter-map force poly-names)))
-           (map force binding-reg))))
+                    binding-reg)
+              (free-id-table-set dependency-map name other-names))))
+  (values
+   (delay (lambda (names)
+            (refine-user-defined-constructor-variances!
+             (append names (filter-map force poly-names)))
+            (map force binding-reg)))
+   dependency-map))
 
 
   ;; the resulting thunk finishes the rest work)
@@ -481,11 +490,11 @@
     (parse-and-register-signature! sig-form))
 
   ;; Add the struct names to the type table, but not with a type
-  (define promise-reg-sty-info (register-struct-type-info! struct-defs))
+  (define-values (promise-reg-sty-info dependency-map) (register-struct-type-info! struct-defs))
 
   (do-time "after adding type names")
 
-  (define names (register-all-type-aliases type-aliases))
+  (define names (register-all-type-aliases type-aliases dependency-map))
 
   (finalize-signatures!)
 
@@ -718,7 +727,8 @@
                                       'no-type)]
     [else
      (when (typed-struct? form)
-       ((force (register-struct-type-info! (list form))) null))
+       (define-values (after-reg _) (register-struct-type-info! (list form)))
+       ((force after-reg) null))
      (define all-forms (cond
                          [(typed-struct? form)
                           ;; after a struct type is registered, check the pending forms is in receiving order