1 files changed, 47 insertions, 0 deletions
diff --git a/type/default.scm b/type/default.scm
new file mode 100644
index 0000000..529f4f8
--- /dev/null
+++ b/type/default.scm
@@ -0,0 +1,47 @@
+;;; This handles the default rule.
+
+(define (maybe-default-ambiguous-tyvar type def module)
+  (let ((classes (ntyvar-context type)))
+   (and (not (null? classes)) ; this happens only during cleanup after an error
+    (let ((non-standard? '#f)
+	  (numeric? '#f))
+      (dolist (class classes)
+	(cond ((eq? (class-kind class) 'numeric)
+	       (setf numeric? '#t))
+	      ((not (eq? (class-kind class) 'standard))
+	       (setf non-standard? '#t))))
+      (cond ((or non-standard? (not numeric?))
+	     (remember-context def
+ 	       (phase-error 'Non-defaultable-ambiguous-context
+"An ambiguous context, ~A, cannot be defaulted.~%Ambiguity in call to ~A~%"
+                  classes def))
+	     '#f)
+	    (else
+	     (find-default-type type classes classes
+			(tuple-2-2 (assq module *default-decls*)))))))))
+
+(define (find-default-type tyvar classes all-classes defaults)
+  (cond ((null? defaults)
+	 (phase-error 'no-default-applies
+	    "Ambiguous context: ~A~%No default applies.~%"
+	    all-classes)
+	 '#f)
+	((null? classes)
+	 (instantiate-tyvar tyvar (car defaults))
+	 '#t)
+	((type-in-class? (car defaults) (car classes))
+	 (find-default-type tyvar (cdr classes) all-classes defaults))
+	(else
+	 (find-default-type tyvar all-classes all-classes (cdr defaults)))))
+	 
+(define (type-in-class? ntype class)
+  (let* ((ntype (expand-ntype-synonym ntype))
+	 (alg (ntycon-tycon ntype))
+	 (inst (lookup-instance alg class)))
+    (if (eq? inst '#f)
+	'#f
+	(let ((res '#t))
+	  (do-contexts (c (instance-context inst)) (ty (ntycon-args ntype))
+	    (when (not (type-in-class? ty c))
+	      (setf res '#f)))
+	  res))))