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.");
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);
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