Fix regeneration of multi-file dependencies

[hcoop/domtool2.git] / src / describe.sml

diff --git a/src/describe.sml b/src/describe.sml
index a39faeb..e5850e2 100644 (file)
--- a/src/describe.sml
+++ b/src/describe.sml
@@ -100,9 +100,34 @@ fun describe_unification_error t ue =
            (print "Reason: Occurs check failed for ";
             print name;
             print " in:\n";
-            printd (p_typ t))
+            output (p_typ t))
+
+fun will_be_action (t, _) =
+    case t of
+       TArrow (_, t') => will_be_action t'
+      | TAction _ => true
+      | TNested _ => true
+      | TUnif (_, ref (SOME t')) => will_be_action t'
+      | _ => false
 
-fun describe_type_error loc te =
+fun get_first_arg (t, _) =
+    case t of
+       TArrow (t', _) => SOME t'
+      | TUnif (_, ref (SOME t')) => get_first_arg t'
+      | _ => NONE
+
+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.");
@@ -111,10 +136,18 @@ fun describe_type_error loc te =
         preface ("Needed type:", p_typ t2);
         Option.app (describe_unification_error t1) ueo)
       |        WrongForm (place, form, e, t, ueo) =>
-       (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type.");
-        preface ("Expression:", p_exp e);
-        preface ("      Type:", p_typ t);
-        Option.app (describe_unification_error t) ueo)
+       if form = "action" andalso will_be_action t then
+           (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);
+            preface ("      Type:", p_typ t);
+            Option.app (describe_unification_error t) ueo)
       | UnboundVariable name =>
        ErrorMsg.error (SOME loc) ("Unbound variable " ^ name ^ ".\n")
       |        WrongPred (place, p1, p2) =>
@@ -122,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