X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=0d0a9f8e083076f03a9d2abeabb58419b9144660;hb=c8c2f6bb7d79a2a6aeaa3233363fdf0bbbfad205;hp=6d5a52204f77055f9993fce98d7a45c247a123ec;hpb=2b6ba11cee81436aeed0ddab8ce5f53d51a349a9;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 6d5a522..0d0a9f8 100644
--- 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 )