Rejig the error messages a bit; fixes a minor bug

The type checker was only reporting the first message if an equality
failed to match.  This patch does a bit of refactoring and fixes the
bug, which was in the bogus use of eqInstMisMatch
in tcSimplify.report_no_instances.b

This is really a bug in 6.8 too, so this would be good to merge across
to the 6.8 branch.

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index fac10ab..d75a7cd 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -52,8 +52,7 @@ module Inst (
        eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
        finalizeEqInst, writeWantedCoercion,
        eqInstType, updateEqInstCoercion,
-       eqInstCoercion,
-       eqInstLeftTy, eqInstRightTy
+       eqInstCoercion, eqInstTys
     ) where
 
 #include "HsVersions.h"
@@ -1052,9 +1051,8 @@ eqInstType inst = eitherEqInst inst mkTyVarTy id
 eqInstCoercion :: Inst -> Either TcTyVar Coercion
 eqInstCoercion = tci_co
 
-eqInstLeftTy, eqInstRightTy :: Inst -> TcType
-eqInstLeftTy  = tci_left
-eqInstRightTy = tci_right
+eqInstTys :: Inst -> (TcType, TcType)
+eqInstTys inst = (tci_left inst, tci_right inst)
 
 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index af58138..5b654fc 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -2934,11 +2934,10 @@ groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
 -- We want to report them together in error messages
 
 groupErrs report_err [] 
-  = returnM ()
+  = return ()
 groupErrs report_err (inst:insts) 
-  = do_one (inst:friends)              `thenM_`
-    groupErrs report_err others
-
+  = do { do_one (inst:friends)
+       ; groupErrs report_err others }
   where
        -- (It may seem a bit crude to compare the error messages,
        --  but it makes sure that we combine just what the user sees,
@@ -3003,11 +3002,11 @@ report_no_instances tidy_env mb_what insts
             (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
              (eqInsts, insts3)  = partition isEqInst insts2
        ; traceTc (text "reportNoInstances" <+> vcat 
-                       [ppr implics, ppr insts1, ppr insts2])
+                       [ppr insts, ppr implics, ppr insts1, ppr insts2])
        ; mapM_ complain_implic implics
        ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
        ; groupErrs complain_no_inst insts3 
-       ; mapM_ eqInstMisMatch eqInsts
+       ; mapM_ (addErrTcM . mk_eq_err) eqInsts
        }
   where
     complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
@@ -3053,6 +3052,9 @@ report_no_instances tidy_env mb_what insts
       where
        ispecs = [ispec | (ispec, _) <- matches]
 
+    mk_eq_err :: Inst -> (TidyEnv, SDoc)
+    mk_eq_err inst = misMatchMsg tidy_env (eqInstTys inst)
+
     mk_no_inst_err insts
       | null insts = empty
 

diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index 19fe506..d7da2f7 100644 (file)
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs
@@ -11,7 +11,7 @@ module TcTyFuns (
        substEqInDictInsts,
        
         -- errors
-        eqInstMisMatch, misMatchMsg,
+        misMatchMsg, failWithMisMatch
   ) where
 
 
@@ -121,8 +121,10 @@ eqInstToRewrite :: Inst -> Maybe (Rewrite, Bool)
                                            -- True iff rewrite swapped equality
 eqInstToRewrite inst
   = ASSERT( isEqInst inst )
-    go (eqInstLeftTy inst) (eqInstRightTy inst) (eqInstType inst)
+    go ty1 ty2 (eqInstType inst)
   where
+    (ty1,ty2) = eqInstTys inst
+
     -- look through synonyms
     go ty1 ty2 co | Just ty1' <- tcView ty1 = go ty1' ty2 co
     go ty1 ty2 co | Just ty2' <- tcView ty2 = go ty1 ty2' co
@@ -670,8 +672,7 @@ trivialRule insts
       | otherwise
       = return $ Just inst
       where
-        ty1 = eqInstLeftTy  inst
-        ty2 = eqInstRightTy inst
+        (ty1,ty2) = eqInstTys inst
 \end{code}
 
 
@@ -702,8 +703,9 @@ decompRule insts
   where
     decomp inst
       = ASSERT( isEqInst inst )
-        go (eqInstLeftTy inst) (eqInstRightTy inst)
+        go ty1 ty2
       where
+       (ty1,ty2) = eqInstTys inst
         go ty1 ty2             
           | Just ty1' <- tcView ty1 = go ty1' ty2 
           | Just ty2' <- tcView ty2 = go ty1 ty2' 
@@ -822,8 +824,7 @@ topRule insts
                    }
             }
       where
-        ty1 = eqInstLeftTy  inst
-       ty2 = eqInstRightTy inst
+        (ty1,ty2) = eqInstTys inst
 \end{code}
 
 
@@ -921,8 +922,7 @@ substInst inst insts
                     }
               }
          where 
-            ty1 = eqInstLeftTy  inst
-            ty2 = eqInstRightTy inst
+            (ty1,ty2) = eqInstTys inst
 \end{code}
 
 
@@ -959,9 +959,10 @@ unifyMetaRule insts
   where
     unifyMeta inst
       = ASSERT( isEqInst inst )
-        go (eqInstLeftTy inst) (eqInstRightTy inst)
+        go ty1 ty2
            (fromWantedCo "unifyMetaRule" $ eqInstCoercion inst)
       where
+       (ty1,ty2) = eqInstTys inst
         go ty1 ty2 cotv
           | Just ty1' <- tcView ty1 = go ty1' ty2 cotv
           | Just ty2' <- tcView ty2 = go ty1 ty2' cotv
@@ -1201,45 +1202,49 @@ somethingdifferent message.
 eqInstMisMatch :: Inst -> TcM a
 eqInstMisMatch inst
   = ASSERT( isEqInst inst )
-    do { (env, msg) <- misMatchMsg ty_act ty_exp
-       ; setErrCtxt ctxt $
-           failWithTcM (env, msg)
-       }
+    setErrCtxt ctxt $ failWithMisMatch ty_act ty_exp
   where
-    ty_act           = eqInstLeftTy  inst
-    ty_exp           = eqInstRightTy inst
-    InstLoc _ _ ctxt = instLoc       inst
+    (ty_act, ty_exp) = eqInstTys inst
+    InstLoc _ _ ctxt = instLoc   inst
 
 -----------------------
-misMatchMsg :: TcType -> TcType -> TcM (TidyEnv, SDoc)
+failWithMisMatch :: TcType -> TcType -> TcM a
 -- Generate the message when two types fail to match,
 -- going to some trouble to make it helpful.
 -- The argument order is: actual type, expected type
-misMatchMsg ty_act ty_exp
+failWithMisMatch ty_act ty_exp
   = do { env0 <- tcInitTidyEnv
         ; ty_exp <- zonkTcType ty_exp
         ; ty_act <- zonkTcType ty_act
-       ; (env1, pp_exp, extra_exp) <- ppr_ty env0 ty_exp
-       ; (env2, pp_act, extra_act) <- ppr_ty env1 ty_act
-       ; return (env2, 
-                  sep [sep [ptext SLIT("Couldn't match expected type") <+> pp_exp, 
-                           nest 7 $
+        ; failWithTcM (misMatchMsg env0 (ty_act, ty_exp))
+       }
+
+misMatchMsg :: TidyEnv -> (TcType, TcType) -> (TidyEnv, SDoc)
+misMatchMsg env0 (ty_act, ty_exp)
+  = let (env1, pp_exp, extra_exp) = ppr_ty env0 ty_exp
+       (env2, pp_act, extra_act) = ppr_ty env1 ty_act
+        msg = sep [sep [ptext SLIT("Couldn't match expected type") <+> pp_exp, 
+                       nest 7 $
                               ptext SLIT("against inferred type") <+> pp_act],
-                      nest 2 (extra_exp $$ extra_act)]) }
-
-ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc)
-ppr_ty env ty
-  = do { let (env1, tidy_ty) = tidyOpenType env ty
-       ; (env2, extra) <- ppr_extra env1 tidy_ty
-       ; return (env2, quotes (ppr tidy_ty), extra) }
-
--- (ppr_extra env ty) shows extra info about 'ty'
-ppr_extra :: TidyEnv -> Type -> TcM (TidyEnv, SDoc)
-ppr_extra env (TyVarTy tv)
-  | isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv) && not (isUnk tv)
-  = return (env1, pprSkolTvBinding tv1)
+                  nest 2 (extra_exp $$ extra_act)]
+    in
+    (env2, msg)
+
   where
-    (env1, tv1) = tidySkolemTyVar env tv
+    ppr_ty :: TidyEnv -> TcType -> (TidyEnv, SDoc, SDoc)
+    ppr_ty env ty
+      = let (env1, tidy_ty) = tidyOpenType env ty
+           (env2, extra)  = ppr_extra env1 tidy_ty
+       in
+       (env2, quotes (ppr tidy_ty), extra)
+
+    -- (ppr_extra env ty) shows extra info about 'ty'
+    ppr_extra :: TidyEnv -> Type -> (TidyEnv, SDoc)
+    ppr_extra env (TyVarTy tv)
+      | isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv) && not (isUnk tv)
+      = (env1, pprSkolTvBinding tv1)
+      where
+        (env1, tv1) = tidySkolemTyVar env tv
 
-ppr_extra env _ty = return (env, empty)                -- Normal case
+    ppr_extra env _ty = (env, empty)           -- Normal case
 \end{code}

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 7256940..04e9379 100644 (file)
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -1753,13 +1753,9 @@ unifyForAllCtxt tvs phi1 phi2 env
 
 -----------------------
 unifyMisMatch outer swapped ty1 ty2
-  = do { (env, msg) <- if swapped then misMatchMsg ty2 ty1
-                                  else misMatchMsg ty1 ty2
-
-       -- This is the whole point of the 'outer' stuff
-       ; if outer then popErrCtxt (failWithTcM (env, msg))
-                  else failWithTcM (env, msg)
-       } 
+  | swapped   = unifyMisMatch outer False ty2 ty1
+  | outer     = popErrCtxt $ unifyMisMatch False swapped ty1 ty2  -- This is the whole point of the 'outer' stuff
+  | otherwise = failWithMisMatch ty1 ty2
 \end{code}