From 53e501bb8b7b9a941157aa461d9c772462cffde6 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 10 Nov 2015 16:39:12 -0600
Subject: [PATCH] Avoid generating contraints for optimized-away contract
 definitions.

Closes #214.
---
 .../static-contracts/instantiate.rkt          | 37 ++++++++++++++++++-
 typed-racket-test/succeed/gh-issue-214.rkt    | 21 +++++++++++
 2 files changed, 56 insertions(+), 2 deletions(-)
 create mode 100644 typed-racket-test/succeed/gh-issue-214.rkt

diff --git a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
index 76a3a299..bca74d72 100644
--- a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
+++ b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
@@ -47,9 +47,42 @@
             (contract-restrict-recursive-values (compute-constraints sc kind)))
           cache))))
 
+;; computes the definitions that are in / used by `sc`
+;; `(get-all-name-defs)` is not what we want directly, since it also includes
+;; definitions that were optimized away
+;; we restrict it to only variables bound in `sc`
+(define (compute-defs sc)
+  (define all-name-defs (get-all-name-defs))
+  ;; all-name-defs maps lists of ids to defs
+  ;; we want to match if any id in the list matches
+  (define (ref b) (for/first ([(k v) (in-dict all-name-defs)]
+                              #:when (for/or ([k* (in-list k)])
+                                       (free-identifier=? b k*)))
+                    (cons k v)))
+  (define bound '())
+  ;; ignores its second argument (variance, passed by sc-traverse)
+  (let loop ([sc sc] [_ #f])
+    (match sc
+      [(name/sc: name*)
+       (unless (member name* bound free-identifier=?)
+         (set! bound (cons name* bound))
+         ;; traverse what `name` refers to
+         (define r (ref name*))
+         ;; ref returns a rib, get the one definition we want
+         (define target (for/first ([k (car r)]
+                                    [v (cdr r)]
+                                    #:when (free-identifier=? name* k))
+                          v))
+         (loop target #f))]
+      [else (sc-traverse sc loop)]))
+  (for*/hash ([b (in-list bound)]
+              [v (in-value (ref b))]
+              #:when v)
+    (values (car v) (cdr v))))
+
 (define (compute-constraints sc max-kind)
   (define memo-table (make-hash))
-  (define name-defs (get-all-name-defs))
+  (define name-defs (compute-defs sc))
   (define (recur sc)
     (cond [(hash-ref memo-table sc #f)]
           [else
@@ -138,7 +171,7 @@
       [(? sc? sc)
        (sc->contract sc recur)]))
   (define ctc (recur sc))
-  (define name-defs (get-all-name-defs))
+  (define name-defs (compute-defs sc))
   ;; These are extra contract definitions for the name static contracts
   ;; that are used for this type. Since these are shared across multiple
   ;; contracts from a single contract fixup pass, we use the name-defined
diff --git a/typed-racket-test/succeed/gh-issue-214.rkt b/typed-racket-test/succeed/gh-issue-214.rkt
new file mode 100644
index 00000000..ba6e4a45
--- /dev/null
+++ b/typed-racket-test/succeed/gh-issue-214.rkt
@@ -0,0 +1,21 @@
+#lang typed/racket
+
+(struct (A B) Fum ([a : A] [b : B]))
+(struct Fi ())
+(struct Foo ())
+
+(define-type Tail
+  (Rec T
+   (U (Fum (Listof Value) T)
+       Fi)))
+
+(define-type Value
+ (Rec V
+  (U (Fum (Listof Value) V)
+     Foo)))
+
+(provide fun1)
+
+(: fun1 (-> Tail))
+(define (fun1)
+  (error 'foo1))