From e678abfda96412fdb71b8256963d99ebd4cecaf8 Mon Sep 17 00:00:00 2001
From: Luke Lau <luke_lau@icloud.com>
Date: Thu, 1 Aug 2019 16:35:05 +0100
Subject: [PATCH] Add clash constraints when merging

---
 typecheck.scm | 40 ++++++++++++++++++++++++++--------------
 1 file changed, 26 insertions(+), 14 deletions(-)

diff --git a/typecheck.scm b/typecheck.scm
index 6a99869..df85cc1 100644
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -278,9 +278,9 @@
 					; composes constraints a onto b and merges, i.e. applies a to b
 					; a should be the "more important" constraints
 (define (constraint-merge a b)
-  (define (f constraint)
+  (define (f cs constraint)
     (cons (car constraint)
-	  (substitute a (cdr constraint))))
+	  (substitute cs (cdr constraint))))
   
   (define (most-concrete a b)
     (cond
@@ -293,24 +293,36 @@
      [(abs? b) a]
      [else (error #f "impossible! most-concrete")]))
 
-  (define (union p q)
-    (cond
-     [(null? p) q]
-     [(null? q) p]
-     [else
-      (let ([x (car q)])
-	(if (assoc (car x) p)
-	    (if (eqv? (most-concrete (cddr (assoc (car x) p))
-				     (cdr x))
-		      (cdr x))
-		(cons x (union (filter (p) (not (eqv? 
+  (define (clashes)
+    (define (gen acc x)
+      (if (assoc (car x) a)
+	  (cons (cons (car x) (most-concrete (cdr (assoc (car x) a))
+			       (cdr x)))
+		acc)
+	  acc))
+    (fold-left gen '() b))
+
+  ;; (define (union p q)
+  ;;   (cond
+  ;;    [(null? p) q]
+  ;;    [(null? q) p]
+  ;;    [else
+  ;;     (let ([x (car q)])
+  ;; 	(if (assoc (car x) p)
+  ;; 	    (if (eqv? (most-concrete (cddr (assoc (car x) p))
+  ;; 				     (cdr x))
+  ;; 		      (cdr x))
+  ;; 		(cons x (union (filter (p) (not (eqv? 
 	
   
   (define (union p q)
     (append (filter (lambda (x) (not (assoc (car x) p)))
 		    q)
 	    p))
-  (union a (map f b)))
+  (display "clashes: ")
+  (display (clashes))
+  (newline)
+  (append (clashes) (union a (map (lambda (z) (f a z)) b))))
 
 
 ;; 					; a1 -> a2 ~ a3 -> a4;
-- 
2.30.2