-(define (consolidate x y)
- (define (merge a b)
- (cond ((null? a) b)
- ((null? b) a)
- (else (if (member (car b) a)
- (merge a (cdr b))
- (cons (car b) (merge a (cdr b)))))))
- (define (overlap? a b)
- (if (or (null? a) (null? b))
- #f
- (if (fold-left (lambda (acc v)
- (or acc (eq? v (car a))))
- #f b)
- #t
- (overlap? (cdr a) b))))
-
- (cond ((null? y) x)
- ((null? x) y)
- (else
- (let* ((a (car y))
- (merged (fold-left
- (lambda (acc b)
- (if acc
- acc
- (if (overlap? a b)
- (cons (merge a b) b)
- #f)))
- #f x))
- (removed (if merged
- (filter (lambda (b) (not (eq? b (cdr merged)))) x)
- x)))
- (if merged
- (consolidate removed (cons (car merged) (cdr y)))
- (consolidate (cons a x) (cdr y)))))))
-
- ; a1 -> a2 ~ a3 -> a4;
- ; a1 -> a2 !~ bool -> bool
- ; basically can the tvars be renamed
+ ; 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)
+ (cons (car constraint)
+ (substitute a (cdr constraint))))
+
+ (define (most-concrete a b)
+ (cond
+ [(tvar? a) b]
+ [(tvar? b) a]
+ [(and (abs? a) (abs? b))
+ `(abs ,(most-concrete (cadr a) (cadr b))
+ ,(most-concrete (caddr a) (caddr b)))]
+ [(abs? a) b]
+ [(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 (union p q)
+ (append (filter (lambda (x) (not (assoc (car x) p)))
+ q)
+ p))
+ (union a (map f b)))
+
+
+;; ; a1 -> a2 ~ a3 -> a4;
+;; ; a1 -> a2 !~ bool -> bool
+;; ; basically can the tvars be renamed