From 7383b66bf30708da4a764d23e90cd692e9c7b032 Mon Sep 17 00:00:00 2001
From: Yarin Heffes <yarin.heffes@gmail.com>
Date: Fri, 3 Jan 2025 12:16:10 -0800
Subject: [PATCH] fix i1340

---
 src/typechecker/define-instance.lisp | 48 +++++++++++++++-------------
 tests/test-files/define-instance.txt | 15 +++++++++
 2 files changed, 40 insertions(+), 23 deletions(-)

diff --git a/src/typechecker/define-instance.lisp b/src/typechecker/define-instance.lisp
index 1517a1e65..a8f63da27 100644
--- a/src/typechecker/define-instance.lisp
+++ b/src/typechecker/define-instance.lisp
@@ -183,29 +183,31 @@
 
           :for superclass := (tc:apply-substitution instance-subs superclass_)
 
-          :for superclass-instance
-            := (or (tc:lookup-class-instance
-                    env
-                    superclass
-                    :no-error t)
-                   (tc-error "Instance missing context"
-                             (tc-location (parser:toplevel-define-instance-head-location unparsed-instance)
-                                          "No instance for ~S" superclass)))
-
-          :for additional-context
-            := (tc:apply-substitution
-                (tc:predicate-match
-                 (tc:apply-substitution instance-subs (tc:ty-class-instance-predicate superclass-instance))
-                 superclass)
-                (tc:ty-class-instance-constraints superclass-instance))
-
-          :do (loop :for pred :in additional-context
-                    :do (unless (tc:entail env context pred)
-                          (tc-error "Instance missing context"
-                                    (tc-location (parser:toplevel-define-instance-head-location unparsed-instance)
-                                                 "No instance for ~S arising from constraints of superclasses ~S"
-                                                 pred
-                                                 superclass)))))
+          :unless (tc:entail env context superclass)
+
+            :do (loop :for superclass-instance
+                        := (or (tc:lookup-class-instance
+                                env
+                                superclass
+                                :no-error t)
+                               (tc-error "Instance missing context"
+                                         (tc-location (parser:toplevel-define-instance-head-location unparsed-instance)
+                                                      "No instance for ~S" superclass)))
+
+                      :for additional-context
+                        := (tc:apply-substitution
+                            (tc:predicate-match
+                             (tc:apply-substitution instance-subs (tc:ty-class-instance-predicate superclass-instance))
+                             superclass)
+                            (tc:ty-class-instance-constraints superclass-instance))
+
+                      :do (loop :for pred :in additional-context
+                                :do (unless (tc:entail env context pred)
+                                      (tc-error "Instance missing context"
+                                                (tc-location (parser:toplevel-define-instance-head-location unparsed-instance)
+                                                             "No instance for ~S arising from constraints of superclasses ~S"
+                                                             pred
+                                                             superclass))))))
 
     (check-duplicates
      (parser:toplevel-define-instance-methods unparsed-instance)
diff --git a/tests/test-files/define-instance.txt b/tests/test-files/define-instance.txt
index eb8a1028a..0fe3a0052 100644
--- a/tests/test-files/define-instance.txt
+++ b/tests/test-files/define-instance.txt
@@ -102,6 +102,21 @@
 (define-instance (Eq C)
   (define (== _ _) True))
 
+================================================================================
+10 Define instance
+================================================================================
+
+(package coalton-unit-tests)
+
+;; see issue #1340
+
+(define-type (T :a))
+(define-class (P :a))
+(define-class (C :a :b))
+(define-class ((P :a) (C :b :a) => PC :b :a))
+(define-instance (C (T :a) :a))
+(define-instance (P :a => PC (T :a) :a))
+
 ================================================================================
 100 Malformed method definition
 ================================================================================