X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/07d66c3691fac5239dfa1f5a8858623ef542c71f..f0d740ca26aab28b2aea7bdeed2f5641d7634a05:/src/describe.sml

diff --git a/src/describe.sml b/src/describe.sml
index a753ddb..e5850e2 100644
--- a/src/describe.sml
+++ b/src/describe.sml
@@ -112,11 +112,22 @@ fun will_be_action (t, _) =
 
 fun get_first_arg (t, _) =
     case t of
-	TArrow (t', _) => t'
+	TArrow (t', _) => SOME t'
       | TUnif (_, ref (SOME t')) => get_first_arg t'
-      | _ => raise Fail "get_first_arg failed!"
+      | _ => NONE
 
-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.");
@@ -126,9 +137,12 @@ fun describe_type_error loc te =
 	 Option.app (describe_unification_error t1) ueo)
       |	WrongForm (place, form, e, t, ueo) =>
 	if form = "action" andalso will_be_action t then
-	    (ErrorMsg.error (SOME loc) "Not enough arguments passed to configuration function.";
-	     preface (" Expression so far:", p_exp e);
-	     preface ("Next argument type:", p_typ (get_first_arg t)))
+	    (case get_first_arg t of
+		 NONE => ErrorMsg.error (SOME loc) "You probably forgot a 'with' clause here."
+	       | SOME t' =>
+		 (ErrorMsg.error (SOME loc) ("Not enough arguments passed to configuration function. (" ^ place ^ ")");
+		  preface (" Expression so far:", p_exp e);
+		  preface ("Next argument type:", p_typ t')))
 	else
 	    (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type.");
 	     preface ("Expression:", p_exp e);
@@ -141,4 +155,29 @@ fun describe_type_error loc te =
 	 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