Hint Monster

diff --git a/src/describe.sig b/src/describe.sig
index 268a9e1..8333c26 100644 (file)
--- a/src/describe.sig
+++ b/src/describe.sig
@@ -26,6 +26,6 @@ signature DESCRIBE = sig
 
     val describe_type_error : Ast.position -> Ast.type_error -> unit
 
 
     val describe_type_error : Ast.position -> Ast.type_error -> unit
 

-
+    val ununify : Ast.typ -> Ast.typ

 
 end
 
 end

diff --git a/src/describe.sml b/src/describe.sml
index a753ddb..1e81550 100644 (file)
--- a/src/describe.sml
+++ b/src/describe.sml
@@ -116,7 +116,18 @@ fun get_first_arg (t, _) =
       | TUnif (_, ref (SOME t')) => get_first_arg t'
       | _ => raise Fail "get_first_arg failed!"
 
       | TUnif (_, ref (SOME t')) => get_first_arg t'
       | _ => raise Fail "get_first_arg failed!"
 

-fun describe_type_error loc te =
+fun hint te =
+    case te of
+       WrongType (_, _, (TBase "string", _), (TBase "your_domain", _), _) =>
+       SOME "Did you forget to request permission to configure this domain?  See:\n\thttps://members.hcoop.net/portal/domain"
+      | WrongType (_, (EString dom, _), (TBase "string", _), (TBase "domain", _), _) =>
+       if CharVector.exists Char.isUpper dom then
+           SOME "Uppercase letters aren't allowed in domain strings."
+       else
+           NONE
+      | _ => NONE
+
+fun describe_type_error' loc te =

     case te of
        WrongType (place, e, t1, t2, ueo) =>
        (ErrorMsg.error (SOME loc) (place ^ " has wrong type.");
     case te of
        WrongType (place, e, t1, t2, ueo) =>
        (ErrorMsg.error (SOME loc) (place ^ " has wrong type.");


@@ -141,4 +152,29 @@ fun describe_type_error loc te =
         preface ("Have:", p_pred p1);
         preface ("Need:", p_pred p2))
 
         preface ("Have:", p_pred p1);
         preface ("Need:", p_pred p2))
 

+fun ununify (tAll as (t, _)) =
+    case t of
+       TUnif (_, ref (SOME t)) => ununify t
+      | _ => tAll
+
+fun normalize_error err =
+    case err of
+       WrongType (s, e, t1, t2, ueo) =>
+       WrongType (s, e, ununify t1, ununify t2, ueo)
+      | WrongForm (s1, s2, e, t, ueo) =>
+       WrongForm (s1, s2, e, ununify t, ueo)
+      | UnboundVariable _ => err
+      | WrongPred _ => err
+
+fun describe_type_error loc te =
+    let
+       val te = normalize_error te
+    in
+       describe_type_error' loc te;
+       Option.app (fn s => (print "Hint Monster says:\n";
+                            print s;
+                            print "\n"))
+                  (hint te)
+    end
+

 end
 end

diff --git a/src/tycheck.sml b/src/tycheck.sml
index d5b3f1e..d83a5c0 100644 (file)
--- a/src/tycheck.sml
+++ b/src/tycheck.sml
@@ -258,10 +258,7 @@ fun envVarSetFrom v (e, _) =
 
       | _ => NONE
 
 
       | _ => NONE
 

-fun ununify (tAll as (t, _)) =
-    case t of
-       TUnif (_, ref (SOME t)) => ununify t
-      | _ => tAll
+val ununify = Describe.ununify

 
 fun checkExp G (eAll as (e, loc)) =
     let
 
 fun checkExp G (eAll as (e, loc)) =
     let