Merge remote branch 'origin/master'

[ghc-hetmet.git] / compiler / typecheck / TcErrors.lhs

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 6d5a522..0d0a9f8 100644 (file)
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -16,14 +16,12 @@ import TcSMonad
 import TcType
 import TypeRep
 import Type( isTyVarTy )
-
 import Inst
 import InstEnv
-
 import TyCon
 import Name
 import NameEnv
-import Id      ( idType )
+import Id      ( idType, evVarPred )
 import Var
 import VarSet
 import VarEnv
@@ -223,7 +221,7 @@ pprWithArising ev_vars
   where
     first_loc = evVarX (head ev_vars)
     ppr_one (EvVarX v loc)
-       = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
+       = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
 
 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
@@ -300,8 +298,8 @@ getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp
                  ty1 ty2
   -- If the types in the error message are the same as the types we are unifying,
   -- don't add the extra expected/actual message
-  | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
-  | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
+  | act `eqType` ty1 && exp `eqType` ty2 = empty
+  | exp `eqType` ty1 && act `eqType` ty2 = empty
   | otherwise                                = mkExpectedActualMsg act exp
 
 getWantedEqExtra orig _ _ = pprArising orig
@@ -459,12 +457,22 @@ typeExtraInfoMsg :: [Implication] -> Type -> SDoc
 -- Shows a bit of extra info about skolem constants
 typeExtraInfoMsg implics ty
   | Just tv <- tcGetTyVar_maybe ty
-  , isTcTyVar tv
-  , isSkolemTyVar tv
- = pprSkolTvBinding implics tv
-  where
-typeExtraInfoMsg _ _ = empty            -- Normal case
-
+  , isTcTyVar tv, isSkolemTyVar tv
+  , let pp_tv = quotes (ppr tv)
+ = case tcTyVarDetails tv of
+    SkolemTv {}   -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
+    FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
+    RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
+    MetaTv {}     -> empty
+
+ | otherwise             -- Normal case
+ = empty
+
+ where
+   ppr_skol UnkSkol _   = ptext (sLit "is an unknown type variable")  -- Unhelpful
+   ppr_skol info    loc = sep [ptext (sLit "is a rigid type variable bound by"),
+                               sep [ppr info, ptext (sLit "at") <+> ppr loc]]
+ 
 --------------------
 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
@@ -564,7 +572,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
     mk_overlap_msg (matches, unifiers)
       = ASSERT( not (null matches) )
         vcat [ addArising orig (ptext (sLit "Overlapping instances for") 
-                               <+> pprPred pred)
+                               <+> pprPredTy pred)
             ,  sep [ptext (sLit "Matching instances") <> colon,
                     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
             ,  if not (isSingleton matches)
@@ -573,7 +581,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
                else    -- One match, plus some unifiers
                ASSERT( not (null unifiers) )
                parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
-                                quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
+                                 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
                              ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
                              ptext (sLit "when compiling the other instance declarations")])]
       where
@@ -660,7 +668,6 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 -- ASSUMPTION: the Insts are fully zonked
 mkMonomorphismMsg ctxt inst_tvs
   = do { dflags <- getDOpts
-        ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs))
         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
        ; return (tidy_env, mk_msg dflags docs) }
   where
@@ -686,28 +693,6 @@ monomorphism_fix dflags
            else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
                        -- if it is not already set!
 
-
-pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc
--- Print info about the binding of a skolem tyvar, 
--- or nothing if we don't have anything useful to say
-pprSkolTvBinding implics tv
-  | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
-  | otherwise    = quotes (ppr tv) <+> ppr_skol    (getSkolemInfo implics tv)
-  where
-    ppr_details (SkolemTv {})        = ppr_skol (getSkolemInfo implics tv)
-    ppr_details (FlatSkol {})        = ptext (sLit "is a flattening type variable")
-    ppr_details (RuntimeUnk {})      = ptext (sLit "is an interactive-debugger skolem")
-    ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
-                                       <+> quotes (ppr n)
-    ppr_details (MetaTv _ _)         = ptext (sLit "is a meta type variable")
-
-
-    ppr_skol UnkSkol        = ptext (sLit "is an unknown type variable")        -- Unhelpful
-    ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
-    ppr_skol info           = sep [ptext (sLit "is a rigid type variable bound by"),
-                                   sep [ppr info,
-                                        ptext (sLit "at") <+> ppr (getSrcLoc tv)]]
- 
 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
 getSkolemInfo [] tv
   = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )