Add clash constraints when merging

diff --git a/typecheck.scm b/typecheck.scm
index 6a99869c0697302f361a9e28ac216013f5d018d6..df85cc1607209a6f61968092c4636b7027023142 100644 (file)
--- 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;