Slightly better tracing in the constraint solver

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 2988f08..1798be3 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1282,7 +1282,7 @@ inferInstanceContexts oflag infer_specs
     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars 
                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
       = setSrcSpan loc $
     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars 
                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
       = setSrcSpan loc $

-       addErrCtxt (derivInstCtxt clas inst_tys) $ 
+       addErrCtxt (derivInstCtxt the_pred) $ 

        do {      -- Check for a bizarre corner case, when the derived instance decl should
                  -- have form  instance C a b => D (T a) where ...
                  -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
        do {      -- Check for a bizarre corner case, when the derived instance decl should
                  -- have form  instance C a b => D (T a) where ...
                  -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts

@@ -1297,7 +1297,7 @@ inferInstanceContexts oflag infer_specs
                                      , not (tyVarsOfPred pred `subVarSet` tv_set)]  
           ; mapM_ (addErrTc . badDerivedPred) weird_preds      
 
                                      , not (tyVarsOfPred pred `subVarSet` tv_set)]  
           ; mapM_ (addErrTc . badDerivedPred) weird_preds      
 

-           ; theta <- simplifyDeriv orig tyvars deriv_rhs
+           ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs

                -- checkValidInstance tyvars theta clas inst_tys
                -- Not necessary; see Note [Exotic derived instance contexts]
                --                in TcSimplify
                -- checkValidInstance tyvars theta clas inst_tys
                -- Not necessary; see Note [Exotic derived instance contexts]
                --                in TcSimplify

@@ -1307,6 +1307,8 @@ inferInstanceContexts oflag infer_specs
                -- Hence no need to call:
                --   checkValidInstance tyvars theta clas inst_tys
           ; return (sortLe (<=) theta) }       -- Canonicalise before returning the solution
                -- Hence no need to call:
                --   checkValidInstance tyvars theta clas inst_tys
           ; return (sortLe (<=) theta) }       -- Canonicalise before returning the solution

+      where
+        the_pred = mkClassPred clas inst_tys

 
 ------------------------------------------------------------------
 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
 
 ------------------------------------------------------------------
 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance

@@ -1511,9 +1513,9 @@ standaloneCtxt :: LHsType Name -> SDoc
 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 
                       2 (quotes (ppr ty))
 
 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 
                       2 (quotes (ppr ty))
 

-derivInstCtxt :: Class -> [Type] -> Message
-derivInstCtxt clas inst_tys
-  = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
+derivInstCtxt :: PredType -> Message
+derivInstCtxt pred
+  = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)

 
 badDerivedPred :: PredType -> Message
 badDerivedPred pred
 
 badDerivedPred :: PredType -> Message
 badDerivedPred pred

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 87cd5eb..cbf9330 100644 (file)
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -103,7 +103,9 @@ import HsBinds               -- for TcEvBinds stuff
 import Id 
 
 import TcRnTypes
 import Id 
 
 import TcRnTypes

-
+#ifdef DEBUG
+import Control.Monad( when )
+#endif

 import Data.IORef
 \end{code}
 
 import Data.IORef
 \end{code}
 

@@ -421,17 +423,16 @@ type TcsUntouchables = (Untouchables,TcTyVarSet)
 
 \begin{code}
 data SimplContext
 
 \begin{code}
 data SimplContext

-  = SimplInfer         -- Inferring type of a let-bound thing
-  | SimplRuleLhs       -- Inferring type of a RULE lhs
-  | SimplInteractive   -- Inferring type at GHCi prompt
-  | SimplCheck         -- Checking a type signature or RULE rhs
-  deriving Eq
+  = SimplInfer SDoc       -- Inferring type of a let-bound thing
+  | SimplRuleLhs RuleName  -- Inferring type of a RULE lhs
+  | SimplInteractive      -- Inferring type at GHCi prompt
+  | SimplCheck SDoc       -- Checking a type signature or RULE rhs

 
 instance Outputable SimplContext where
 
 instance Outputable SimplContext where

-  ppr SimplInfer       = ptext (sLit "SimplInfer")
-  ppr SimplRuleLhs     = ptext (sLit "SimplRuleLhs")
+  ppr (SimplInfer d)   = ptext (sLit "SimplInfer") <+> d
+  ppr (SimplCheck d)   = ptext (sLit "SimplCheck") <+> d
+  ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n)

   ppr SimplInteractive = ptext (sLit "SimplInteractive")
   ppr SimplInteractive = ptext (sLit "SimplInteractive")

-  ppr SimplCheck       = ptext (sLit "SimplCheck")

 
 isInteractive :: SimplContext -> Bool
 isInteractive SimplInteractive = True
 
 isInteractive :: SimplContext -> Bool
 isInteractive SimplInteractive = True

@@ -441,14 +442,14 @@ simplEqsOnly :: SimplContext -> Bool
 -- Simplify equalities only, not dictionaries
 -- This is used for the LHS of rules; ee
 -- Note [Simplifying RULE lhs constraints] in TcSimplify
 -- Simplify equalities only, not dictionaries
 -- This is used for the LHS of rules; ee
 -- Note [Simplifying RULE lhs constraints] in TcSimplify

-simplEqsOnly SimplRuleLhs = True
-simplEqsOnly _            = False
+simplEqsOnly (SimplRuleLhs {}) = True
+simplEqsOnly _                 = False

 
 performDefaulting :: SimplContext -> Bool
 
 performDefaulting :: SimplContext -> Bool

-performDefaulting SimplInfer              = False
-performDefaulting SimplRuleLhs            = False
-performDefaulting SimplInteractive = True
-performDefaulting SimplCheck       = True
+performDefaulting (SimplInfer {})   = False
+performDefaulting (SimplRuleLhs {}) = False
+performDefaulting SimplInteractive  = True
+performDefaulting (SimplCheck {})   = True

 
 ---------------
 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 
 
 ---------------
 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 

@@ -526,7 +527,8 @@ runTcS context untouch tcs
 
 #ifdef DEBUG
        ; count <- TcM.readTcRef step_count
 
 #ifdef DEBUG
        ; count <- TcM.readTcRef step_count

-       ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count)
+       ; when (count > 0) $
+         TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count <+> ppr context)

 #endif
              -- And return
        ; ev_binds      <- TcM.readTcRef evb_ref
 #endif
              -- And return
        ; ev_binds      <- TcM.readTcRef evb_ref

@@ -563,8 +565,9 @@ recoverTcS (TcS recovery_code) (TcS thing_inside)
 
 ctxtUnderImplic :: SimplContext -> SimplContext
 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
 
 ctxtUnderImplic :: SimplContext -> SimplContext
 -- See Note [Simplifying RULE lhs constraints] in TcSimplify

-ctxtUnderImplic SimplRuleLhs = SimplCheck
-ctxtUnderImplic ctxt         = ctxt
+ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") 
+                                               <+> doubleQuotes (ftext n))
+ctxtUnderImplic ctxt              = ctxt

 
 tryTcS :: TcS a -> TcS a
 -- Like runTcS, but from within the TcS monad 
 
 tryTcS :: TcS a -> TcS a
 -- Like runTcS, but from within the TcS monad 

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index eecfb27..cf41372 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -49,7 +49,7 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
 -- but when there is nothing to quantify we don't wrap
 -- in a degenerate implication, so we do that here instead
 simplifyTop wanteds 
 -- but when there is nothing to quantify we don't wrap
 -- in a degenerate implication, so we do that here instead
 simplifyTop wanteds 

-  = simplifyCheck SimplCheck wanteds
+  = simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds

 
 ------------------
 simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
 
 ------------------
 simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)

@@ -61,7 +61,8 @@ simplifyDefault :: ThetaType  -- Wanted; has no type variables in it
                 -> TcM ()      -- Succeeds iff the constraint is soluble
 simplifyDefault theta
   = do { wanted <- newFlatWanteds DefaultOrigin theta
                 -> TcM ()      -- Succeeds iff the constraint is soluble
 simplifyDefault theta
   = do { wanted <- newFlatWanteds DefaultOrigin theta

-       ; _ignored_ev_binds <- simplifyCheck SimplCheck (mkFlatWC wanted)
+       ; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults"))) 
+                                            (mkFlatWC wanted)

        ; return () }
 \end{code}
 
        ; return () }
 \end{code}
 

@@ -75,13 +76,14 @@ simplifyDefault theta
 
 \begin{code}
 simplifyDeriv :: CtOrigin
 
 \begin{code}
 simplifyDeriv :: CtOrigin

-               -> [TyVar]      
-               -> ThetaType            -- Wanted
-               -> TcM ThetaType        -- Needed
+              -> PredType
+             -> [TyVar]        
+             -> ThetaType              -- Wanted
+             -> TcM ThetaType  -- Needed

 -- Given  instance (wanted) => C inst_ty 
 -- Simplify 'wanted' as much as possibles
 -- Fail if not possible
 -- Given  instance (wanted) => C inst_ty 
 -- Simplify 'wanted' as much as possibles
 -- Fail if not possible

-simplifyDeriv orig tvs theta 
+simplifyDeriv orig pred tvs theta 

   = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize
                -- The constraint solving machinery 
                -- expects *TcTyVars* not TyVars.  
   = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize
                -- The constraint solving machinery 
                -- expects *TcTyVars* not TyVars.  

@@ -90,12 +92,13 @@ simplifyDeriv orig tvs theta
 
        ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols
              subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
 
        ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols
              subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs

+            doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred)

 
        ; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
 
        ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted)
        ; (residual_wanted, _binds)
 
        ; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
 
        ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted)
        ; (residual_wanted, _binds)

-             <- runTcS SimplInfer NoUntouchables $
+             <- runTcS (SimplInfer doc) NoUntouchables $

                 solveWanteds emptyInert (mkFlatWC wanted)
 
        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
                 solveWanteds emptyInert (mkFlatWC wanted)
 
        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)

@@ -247,7 +250,7 @@ simplifyInfer top_lvl apply_mr name_taus wanteds
             -- Step 2 
                    -- Now simplify the possibly-bound constraints
        ; (simpl_results, tc_binds0)
             -- Step 2 
                    -- Now simplify the possibly-bound constraints
        ; (simpl_results, tc_binds0)

-           <- runTcS SimplInfer NoUntouchables $
+           <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables $

               simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound })
 
        ; when (insolubleWC simpl_results)  -- Fail fast if there is an insoluble constraint
               simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound })
 
        ; when (insolubleWC simpl_results)  -- Fail fast if there is an insoluble constraint

@@ -547,7 +550,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
                 -- variables; hence *no untouchables*
 
        ; (lhs_results, lhs_binds)
                 -- variables; hence *no untouchables*
 
        ; (lhs_results, lhs_binds)

-              <- runTcS SimplRuleLhs untch $
+              <- runTcS (SimplRuleLhs name) untch $

                  solveWanteds emptyInert zonked_lhs
 
        ; traceTc "simplifyRule" $
                  solveWanteds emptyInert zonked_lhs
 
        ; traceTc "simplifyRule" $

@@ -589,7 +592,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
 
             -- Hence the rather painful ad-hoc treatement here
        ; rhs_binds_var@(EvBindsVar evb_ref _)  <- newTcEvBinds
 
             -- Hence the rather painful ad-hoc treatement here
        ; rhs_binds_var@(EvBindsVar evb_ref _)  <- newTcEvBinds

-       ; rhs_binds1 <- simplifyCheck SimplCheck $
+       ; let doc = ptext (sLit "rhs of rule") <+> doubleQuotes (ftext name)
+       ; rhs_binds1 <- simplifyCheck (SimplCheck doc) $

             WC { wc_flat = emptyBag
                , wc_insol = emptyBag
                , wc_impl = unitBag $
             WC { wc_flat = emptyBag
                , wc_insol = emptyBag
                , wc_impl = unitBag $