Tidy up RuntimeUnkSkols a bit more

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

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 293b3a7..28fc91b 100644 (file)
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -33,7 +33,7 @@ import Outputable
 import DynFlags
 import StaticFlags( opt_PprStyle_Debug )
 import Data.List( partition )
-import Control.Monad( unless )
+import Control.Monad( when, unless )
 \end{code}
 
 %************************************************************************
@@ -117,17 +117,27 @@ reportTidyImplic ctxt implic
   
 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 reportTidyWanteds ctxt unsolved
-  = do { let (flats, implics) = splitWanteds unsolved
-             (ambigs, others) = partition is_ambiguous (bagToList flats)
-       ; groupErrs (reportFlat ctxt) others
-       ; mapBagM_ (reportTidyImplic ctxt) implics
-       ; ifErrsM (return ()) $
-                  -- Only report ambiguity if no other errors happened
-          -- See Note [Avoiding spurious errors]
-         reportAmbigErrs ctxt skols ambigs }
+  = do { let (flats,  implics)    = splitWanteds unsolved
+             (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
+                    (tv_eqs, others)     = partition is_tv_eq non_ambigs
+
+       ; groupErrs (reportEqErrs ctxt) tv_eqs
+       ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
+       ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
+
+                  -- Only report ambiguity if no other errors (at all) happened
+          -- See Note [Avoiding spurious errors] in TcSimplify
+       ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
   where
     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
  
+       -- Report equalities of form (a~ty) first.  They are usually
+       -- skolem-equalities, and they cause confusing knock-on 
+       -- effects in other errors; see test T4093b.
+    is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
+               = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
+               | otherwise = False
+
        -- Treat it as "ambiguous" if 
        --   (a) it is a class constraint
         --   (b) it constrains only type variables
@@ -386,7 +396,7 @@ typeExtraInfoMsg env ty
   | Just tv <- tcGetTyVar_maybe ty
   , isTcTyVar tv
   , isSkolemTyVar tv || isSigTyVar tv
-  , not (isUnk tv)
+  , not (isUnkSkol tv)
   , let (env1, tv1) = tidySkolemTyVar env tv
   = (env1, pprSkolTvBinding tv1)
   where
@@ -523,10 +533,11 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 -- ASSUMPTION: the Insts are fully zonked
 mkMonomorphismMsg ctxt inst_tvs
   = do { dflags <- getDOpts
-       ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
+       ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
+        ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
        ; return (tidy_env, mk_msg dflags docs) }
   where
-    mk_msg _ _ | any isRuntimeUnk inst_tvs
+    mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
                    (pprWithCommas ppr inst_tvs),
                 ptext (sLit "Use :print or :force to determine these types")]
@@ -626,6 +637,13 @@ warnDefaulting wanteds default_ty
     (loc, ppr_wanteds) = pprWithArising wanteds
 \end{code}
 
+Note [Runtime skolems]
+~~~~~~~~~~~~~~~~~~~~~~
+We want to give a reasonably helpful error message for ambiguity
+arising from *runtime* skolems in the debugger.  These
+are created by in RtClosureInspect.zonkRTTIType.  
+
+
 %************************************************************************
 %*                                                                     *
                  Error from the canonicaliser
@@ -634,7 +652,7 @@ warnDefaulting wanteds default_ty
 %************************************************************************
 
 \begin{code}
-kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
+kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 -- If there's a kind error, we don't want to blindly say "kind error"
 -- We might, say, be unifying a skolem 'a' with a type 'Int', 
 -- in which case that's the error to report.  So we set things
@@ -644,7 +662,9 @@ kindErrorTcS fl ty1 ty2
     do { let ctxt = CEC { cec_encl = []
                         , cec_extra = extra
                         , cec_tidy = env0 }
-       ; reportEqErr ctxt ty1 ty2 }
+       ; reportEqErr ctxt ty1 ty2 
+       ; failM
+       }
 
 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 misMatchErrorTcS fl ty1 ty2
@@ -709,9 +729,9 @@ flattenForAllErrorTcS fl ty _bad_eqs
 
 \begin{code}
 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
+setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
 
 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
              -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
@@ -730,10 +750,10 @@ wrapEqErrTcS fl ty1 ty2 thing_inside
                                                      (ctLocOrigin loc) ty1 ty2
                                 ; thing_inside env3 ty1 ty2 extra } 
        ; case fl of
-           Wanted  loc -> do_wanted loc
-           Derived loc -> do_wanted loc
-           Given {}    -> thing_inside env2 ty1 ty2 empty 
-                                -- We could print more info, but it
+           Wanted  loc   -> do_wanted loc
+           Derived loc _ -> do_wanted loc
+           Given {}      -> thing_inside env2 ty1 ty2 empty 
+                                -- We could print more info, but it
                                  -- seems to be coming out already
        } }  
   where