print full types instead of lock field heuristics in overload resolution if the heuristic is misleading

1 files changed, 17 insertions, 3 deletions

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index e485e8957..d63ce7258 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -690,9 +690,17 @@ getOverload env@gr mt ot = case appForm ot of
          return (mkApp fun tts, val)
        ([],[]) -> do
          ---- let prtType _ = prt  -- to debug grammars
+         let sought = unwords (map (prtType env) tys)
+         let showTypes ty = case unwords (map (prtType env) ty) of
+               s | s == sought -> 
+                 s +++ "  -- i.e." +++ unwords (map prt ty) ++++
+                 "     where we sought" +++ unwords (map prt tys)
+               s -> s
          raise $ "no overload instance of" +++ prt f +++ 
-           "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ 
-           unlines ["  " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++
+           "for" +++ 
+           sought +++
+           "among" ++++ 
+           unlines ["  " ++ showTypes ty | (ty,_) <- typs] ++
            maybe [] (("with value type" +++) . prtType env) mt
 
        (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
@@ -752,7 +760,7 @@ checkLType env trm typ0 = do
                           check c b'
           checkReset
           return $ (Abs x c', Prod x a b')
-        _ -> raise $ "product expected instead of" +++ prtType env typ
+        _ -> raise $ "function type expected instead of" +++ prtType env typ
 
     App f a -> do
        over <- getOverload env (Just typ) trm
@@ -1054,6 +1062,12 @@ checkIfEqLType env t u trm = do
    sTypes = [typeStr, typeTok, typeString]
    comp = computeLType env
 
+-- if prtType is misleading, print the full type
+prtTypeF :: LTEnv -> Type -> Type -> String
+prtTypeF env exp ty = 
+ let pty = prtType env ty 
+ in if pty == prtType env exp then prt ty else pty
+
 -- printing a type with a lock field lock_C as C
 prtType :: LTEnv -> Type -> String
 prtType env ty = case ty of