Commit f67b457b authored by simonpj's avatar simonpj
Browse files

Slightly better tracing in the constraint solver

parent 3f9d24d5
......@@ -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 $
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
......@@ -1297,7 +1297,7 @@ inferInstanceContexts oflag infer_specs
, 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
......@@ -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
where
the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------
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))
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
......
......@@ -103,7 +103,9 @@ import HsBinds -- for TcEvBinds stuff
import Id
import TcRnTypes
#ifdef DEBUG
import Control.Monad( when )
#endif
import Data.IORef
\end{code}
......@@ -421,17 +423,16 @@ type TcsUntouchables = (Untouchables,TcTyVarSet)
\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
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 SimplCheck = ptext (sLit "SimplCheck")
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
simplEqsOnly SimplRuleLhs = True
simplEqsOnly _ = False
simplEqsOnly (SimplRuleLhs {}) = True
simplEqsOnly _ = False
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 }
......@@ -526,7 +527,8 @@ runTcS context untouch tcs
#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
......@@ -563,8 +565,9 @@ recoverTcS (TcS recovery_code) (TcS thing_inside)
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
......
......@@ -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
= simplifyCheck SimplCheck wanteds
= simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds
------------------
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
; _ignored_ev_binds <- simplifyCheck SimplCheck (mkFlatWC wanted)
; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults")))
(mkFlatWC wanted)
; return () }
\end{code}
......@@ -75,13 +76,14 @@ simplifyDefault theta
\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
simplifyDeriv orig tvs theta
simplifyDeriv orig pred tvs theta
= 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
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)
<- runTcS SimplInfer NoUntouchables $
<- runTcS (SimplInfer doc) NoUntouchables $
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)
<- 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
......@@ -547,7 +550,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
-- variables; hence *no untouchables*
; (lhs_results, lhs_binds)
<- runTcS SimplRuleLhs untch $
<- runTcS (SimplRuleLhs name) untch $
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
; 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 $
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment