X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/492c1cff68a2da969a559627725369c211470c92..6be996d467429cc09f81becd3fd4e294ae1871ae:/src/tycheck.sml

diff --git a/src/tycheck.sml b/src/tycheck.sml
index fa006df..30a1d86 100644
--- a/src/tycheck.sml
+++ b/src/tycheck.sml
@@ -281,6 +281,18 @@ fun whnorm (tAll as (t, loc)) =
 	TUnif (_, ref (SOME tAll)) => whnorm tAll
       | _ => tAll
 
+fun hasTyp (e, t1, t2) =
+    case whnorm t2 of
+	(TBase name, _) =>
+	(case typeRule name of
+	     NONE => subTyp (t1, t2)
+	   | SOME rule =>
+	     if rule e then
+		 ()
+	     else
+		 subTyp (t1, t2))
+      | _ => subTyp (t1, t2)
+
 fun checkTyp G (tAll as (t, loc)) =
     let
 	val err = ErrorMsg.error (SOME loc)
@@ -316,7 +328,7 @@ fun checkExp G (eAll as (e, loc)) =
 			  let
 			      val t' = checkExp G e'
 			  in
-			      (subTyp (t', t);
+			      (hasTyp (eAll, t', t);
 			       if isError t' then
 				   (TList (TError, loc), loc)
 			       else
@@ -356,8 +368,8 @@ fun checkExp G (eAll as (e, loc)) =
 		val tf = checkExp G func
 		val ta = checkExp G arg
 	    in
-		(subTyp (tf, (TArrow (dom, ran), loc));
-		 subTyp (ta, dom)
+		(hasTyp (func, tf, (TArrow (dom, ran), loc));
+		 hasTyp (arg, ta, dom)
 		 handle Unify ue =>
 			dte (WrongType ("Function argument",
 					arg,
@@ -637,7 +649,7 @@ fun checkDecl G (d, _, loc) =
 
 	    val t = checkExp G e
 	in
-	    subTyp (t, to)
+	    hasTyp (e, t, to)
 	    handle Unify ue =>
 		   describe_type_error loc
 				       (WrongType ("Bound value",
@@ -658,7 +670,7 @@ fun checkFile G tInit (ds, eo) =
 	    let
 		val t = checkExp G' e
 	    in
-		subTyp (t, tInit)
+		hasTyp (e, t, tInit)
 		handle Unify ue =>
 		       (ErrorMsg.error (SOME loc) "Bad type for final expression of source file.";
 			preface ("Actual:", p_typ t);