Commit cc2d2e1d authored by dimitris's avatar dimitris

Midstream check-in on

   (i) Replaced a lot of clunky and fragile EvVar handling code with
       a more uniform ``flavor transformer'' API in the canonicalizer
       and the interaction solver. Now EvVars are just fields inside
       the CtFlavors.
   (ii) Significantly simplified our caching story
This patch does not validate yet and more refactoring is on the way.
parent 4bbe9f71
......@@ -14,7 +14,7 @@
{-# LANGUAGE TypeFamilies #-}
module TrieMap(
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
TypeMap, foldTypeMap,
TypeMap, foldTypeMap, lookupTypeMap_mod,
CoercionMap,
MaybeMap,
ListMap,
......@@ -521,6 +521,44 @@ lkT env ty m
go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys
go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
lkT_mod :: CmEnv
-> TyVarEnv a -- A substitution
-> (a -> Type)
-> Type
-> TypeMap b -> Maybe b
lkT_mod env s f ty m
| EmptyTM <- m = Nothing
| Just ty' <- coreView ty
= lkT_mod env s f ty' m
| isEmptyVarEnv candidates
= go env s ty m
| otherwise
= Just $ head (varEnvElts candidates) -- Yikes!
where
candidates = filterVarEnv_Directly find_matching (vm_fvar $ tm_var m)
find_matching tv _b = case lookupVarEnv_Directly s tv of
Nothing -> False
Just a -> f a `eqType` ty
go env _s (TyVarTy v) = tm_var >.> lkVar env v
go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s f t1 >=> lkT_mod env s f t2
go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s f t1 >=> lkT_mod env s f t2
go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s f) tys
go _env _s (ForAllTy _tv _ty) = const Nothing
{- TODO: bleah the following is wrong!
= let (s',inscope') = substTyVarBndr tv (s,inscope)
in
let s' = delVarEnv s tv -- I think it's enough to just restrict substution
-- without renaming anything
in tm_forall >.> lkT_mod (extendCME env tv) s' f ty >=> lkBndr env tv
-}
lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the /keys/ of type map
-> (a -> Type)
-> Type
-> TypeMap b -> Maybe b
lookupTypeMap_mod = lkT_mod emptyCME
-----------------
xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a
xtT env ty f m
......
......@@ -85,7 +85,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta
emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred = do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred
; emitFlat (mkNonCanonical ev (Wanted loc))
; emitFlat (mkNonCanonical (Wanted loc ev))
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -527,7 +527,7 @@ tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCt (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CNonCanonical { cc_id = ev }) = tyVarsOfEvVar ev
tyVarsOfCt (CNonCanonical { cc_flavor = fl }) = tyVarsOfType (ctFlavPred fl)
tyVarsOfCDict :: Ct -> TcTyVarSet
tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
......@@ -563,19 +563,29 @@ tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
tidyCt :: TidyEnv -> Ct -> Ct
-- Also converts it to non-canonical
tidyCt env ct
= CNonCanonical { cc_id = tidyEvVar env (cc_id ct)
, cc_flavor = tidyFlavor env (cc_flavor ct)
= CNonCanonical { cc_flavor = tidy_flavor env (cc_flavor ct)
, cc_depth = cc_depth ct }
where tidy_flavor :: TidyEnv -> CtFlavor -> CtFlavor
tidy_flavor env (Given { flav_gloc = gloc, flav_evar = evar })
= Given { flav_gloc = tidyGivenLoc env gloc
, flav_evar = tidyEvVar env evar }
tidy_flavor env (Solved { flav_gloc = gloc
, flav_evar = evar })
= Solved { flav_gloc = tidyGivenLoc env gloc
, flav_evar = tidyEvVar env evar }
tidy_flavor env (Wanted { flav_wloc = wloc
, flav_evar = evar })
= Wanted { flav_wloc = wloc -- Interesting: no tidying needed?
, flav_evar = tidyEvVar env evar }
tidy_flavor env (Derived { flav_wloc = wloc, flav_der_pty = pty })
= Derived { flav_wloc = wloc, flav_der_pty = tidyType env pty }
tidyEvVar :: TidyEnv -> EvVar -> EvVar
tidyEvVar env var = setVarType var (tidyType env (varType var))
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
tidyFlavor _ fl = fl
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span ctxt
tidyGivenLoc env (CtLoc skol span ctxt)
= CtLoc (tidySkolemInfo env skol) span ctxt
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
......@@ -595,13 +605,12 @@ substCt :: TvSubst -> Ct -> Ct
-- Conservatively converts it to non-canonical:
-- Postcondition: if the constraint does not get rewritten
substCt subst ct
| ev <- cc_id ct, pty <- evVarPred (cc_id ct)
| pty <- ctPred ct
, sty <- substTy subst pty
= if sty `eqType` pty then
ct { cc_flavor = substFlavor subst (cc_flavor ct) }
else
CNonCanonical { cc_id = setVarType ev sty
, cc_flavor = substFlavor subst (cc_flavor ct)
CNonCanonical { cc_flavor = substFlavor subst (cc_flavor ct)
, cc_depth = cc_depth ct }
substWC :: TvSubst -> WantedConstraints -> WantedConstraints
......@@ -626,11 +635,24 @@ substEvVar :: TvSubst -> EvVar -> EvVar
substEvVar subst var = setVarType var (substTy subst (varType var))
substFlavor :: TvSubst -> CtFlavor -> CtFlavor
substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
substFlavor _ fl = fl
substFlavor subst (Given { flav_gloc = gloc, flav_evar = evar })
= Given { flav_gloc = substGivenLoc subst gloc
, flav_evar = substEvVar subst evar }
substFlavor subst (Solved { flav_gloc = gloc, flav_evar = evar })
= Solved { flav_gloc = substGivenLoc subst gloc
, flav_evar = substEvVar subst evar }
substFlavor subst (Wanted { flav_wloc = wloc, flav_evar = evar })
= Wanted { flav_wloc = wloc
, flav_evar = substEvVar subst evar }
substFlavor subst (Derived { flav_wloc = wloc, flav_der_pty = pty })
= Derived { flav_wloc = wloc
, flav_der_pty = substTy subst pty }
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
substGivenLoc subst (CtLoc skol span ctxt)
= CtLoc (substSkolemInfo subst skol) span ctxt
substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
......
This diff is collapsed.
......@@ -159,10 +159,11 @@ reportTidyWanteds ctxt insols flats implics
deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg)
-> Ct -> TcM ()
deferToRuntime ev_binds_var ctxt mk_err_msg ct
| Wanted loc <- cc_flavor ct
| fl <- cc_flavor ct
, Wanted loc _ <- fl
= do { err <- setCtLoc loc $
mk_err_msg ctxt ct
; let ev_id = cc_id ct
; let ev_id = ctId "deferToRuntime" ct -- Prec satisfied: Wanted
err_msg = pprLocErrMsg err
err_fs = mkFastString $ showSDoc $
err_msg $$ text "(deferred type error)"
......@@ -323,8 +324,8 @@ groupErrs mk_err (ct1 : rest)
same_group :: CtFlavor -> CtFlavor -> Bool
same_group (Given l1 _) (Given l2 _) = same_loc l1 l2
same_group (Derived l1) (Derived l2) = same_loc l1 l2
same_group (Wanted l1) (Wanted l2) = same_loc l1 l2
same_group (Derived l1 _) (Derived l2 _) = same_loc l1 l2
same_group (Wanted l1 _) (Wanted l2 _) = same_loc l1 l2
same_group _ _ = False
same_loc :: CtLoc o -> CtLoc o -> Bool
......@@ -345,7 +346,7 @@ pprWithArising []
pprWithArising (ct:cts)
| null cts
= (loc, addArising (ctLocOrigin (ctWantedLoc ct))
(pprEvVarTheta [cc_id ct]))
(pprTheta [ctPred ct]))
| otherwise
= (loc, vcat (map ppr_one (ct:cts)))
where
......@@ -425,22 +426,23 @@ mkEqErr _ [] = panic "mkEqErr"
mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
-- Wanted constraints only!
mkEqErr1 ctxt ct
= case cc_flavor ct of
Given gl gk -> mkEqErr_help ctxt2 ct False ty1 ty2
where
ctxt2 = ctxt { cec_extra = cec_extra ctxt $$
inaccessible_msg gl gk }
flav -> do { let orig = ctLocOrigin (getWantedLoc flav)
; (ctxt1, orig') <- zonkTidyOrigin ctxt orig
; mk_err ctxt1 orig' }
= if isGivenOrSolved flav then
let ctx2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg flav }
in mkEqErr_help ctx2 ct False ty1 ty2
else
do { let orig = ctLocOrigin (getWantedLoc flav)
; (ctxt1, orig') <- zonkTidyOrigin ctxt orig
; mk_err ctxt1 orig' }
where
-- If a GivenSolved then we should not report inaccessible code
inaccessible_msg loc GivenOrig = hang (ptext (sLit "Inaccessible code in"))
flav = cc_flavor ct
inaccessible_msg (Given loc _) = hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ctLocOrigin loc))
inaccessible_msg _ _ = empty
-- If a Solved then we should not report inaccessible code
inaccessible_msg _ = empty
(ty1, ty2) = getEqPredTys (evVarPred (cc_id ct))
(ty1, ty2) = getEqPredTys (ctPred ct)
-- If the types in the error message are the same as the types
-- we are unifying, don't add the extra expected/actual message
......@@ -1070,6 +1072,19 @@ solverDepthErrorTcS depth stack
| null stack -- Shouldn't happen unless you say -fcontext-stack=0
= failWith msg
| otherwise
= setCtFlavorLoc (cc_flavor top_item) $
do { zstack <- mapM zonkCt stack
; env0 <- tcInitTidyEnv
; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack
tidy_env = tidyFreeTyVars env0 zstack_tvs
tidy_cts = map (tidyCt tidy_env) zstack
; failWithTcM (tidy_env, hang msg 2 (vcat (map (ppr . ctPred) tidy_cts))) }
where
top_item = head stack
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
, ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
{- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ...
= setCtFlavorLoc (cc_flavor top_item) $
do { ev_vars <- mapM (zonkEvVar . cc_id) stack
; env0 <- tcInitTidyEnv
......@@ -1080,6 +1095,8 @@ solverDepthErrorTcS depth stack
top_item = head stack
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
, ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
-}
flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a
flattenForAllErrorTcS fl ty
......@@ -1099,9 +1116,10 @@ flattenForAllErrorTcS fl ty
\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 _gk) 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
setCtFlavorLoc (Solved loc _) thing = setCtLoc loc thing
\end{code}
%************************************************************************
......
This diff is collapsed.
......@@ -686,18 +686,29 @@ zonkWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
zonkCt :: Ct -> TcM Ct
-- Zonking a Ct conservatively gives back a CNonCanonical
zonkCt ct
= do { v' <- zonkEvVar (cc_id ct)
; fl' <- zonkFlavor (cc_flavor ct)
= do { fl' <- zonkFlavor (cc_flavor ct)
; return $
CNonCanonical { cc_id = v'
, cc_flavor = fl'
CNonCanonical { cc_flavor = fl'
, cc_depth = cc_depth ct } }
zonkCts :: Cts -> TcM Cts
zonkCts = mapBagM zonkCt
zonkFlavor :: CtFlavor -> TcM CtFlavor
zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) }
zonkFlavor fl = return fl
zonkFlavor (Given loc evar)
= do { loc' <- zonkGivenLoc loc
; evar' <- zonkEvVar evar
; return (Given loc' evar') }
zonkFlavor (Solved loc evar)
= do { loc' <- zonkGivenLoc loc
; evar' <- zonkEvVar evar
; return (Solved loc' evar') }
zonkFlavor (Wanted loc evar)
= do { evar' <- zonkEvVar evar
; return (Wanted loc evar') }
zonkFlavor (Derived loc pty)
= do { pty' <- zonkTcType pty
; return (Derived loc pty') }
zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
......
......@@ -55,9 +55,9 @@ module TcRnTypes(
singleCt, extendCts, isEmptyCts, isCTyEqCan,
isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt_maybe, isGivenOrSolvedCt,
isGivenCt, isGivenOrSolvedCt,
ctWantedLoc,
SubGoalDepth, mkNonCanonical, ctPred,
SubGoalDepth, mkNonCanonical, ctPred, ctFlavPred, ctId, ctFlavId,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, addFlats, addImplics, mkFlatWC,
......@@ -65,16 +65,15 @@ module TcRnTypes(
Implication(..),
CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
WantedLoc, GivenLoc, pushErrCtxt,
pushErrCtxtSameOrigin,
SkolemInfo(..),
CtFlavor(..), pprFlavorArising,
mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor,
isWanted, isGivenOrSolved, isGiven_maybe, isSolved,
isDerived, getWantedLoc, canSolve, canRewrite,
combineCtLoc,
CtFlavor(..), pprFlavorArising,
mkSolvedLoc, mkGivenLoc,
isWanted, isGivenOrSolved, isGiven, isSolved,
isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite,
-- Pretty printing
pprEvVarTheta, pprWantedsWithLocs,
......@@ -90,7 +89,7 @@ module TcRnTypes(
import HsSyn
import HscTypes
import TcEvidence( EvBind, EvBindsVar, EvTerm )
import TcEvidence( EvBind, EvBindsVar )
import Type
import Class ( Class )
import TyCon ( TyCon )
......@@ -846,7 +845,6 @@ type SubGoalDepth = Int -- An ever increasing number used to restrict
data Ct
-- Atomic canonical constraints
= CDictCan { -- e.g. Num xi
cc_id :: EvVar,
cc_flavor :: CtFlavor,
cc_class :: Class,
cc_tyargs :: [Xi],
......@@ -857,7 +855,6 @@ data Ct
| CIPCan { -- ?x::tau
-- See note [Canonical implicit parameter constraints].
cc_id :: EvVar,
cc_flavor :: CtFlavor,
cc_ip_nm :: IPName Name,
cc_ip_ty :: TcTauType, -- Not a Xi! See same not as above
......@@ -865,7 +862,6 @@ data Ct
}
| CIrredEvCan { -- These stand for yet-unknown predicates
cc_id :: EvVar,
cc_flavor :: CtFlavor,
cc_ty :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin)
-- Since, if it were a type constructor application, that'd make the
......@@ -880,7 +876,6 @@ data Ct
-- * typeKind xi `compatKind` typeKind tv
-- See Note [Spontaneous solving and kind compatibility]
-- * We prefer unification variables on the left *JUST* for efficiency
cc_id :: EvVar,
cc_flavor :: CtFlavor,
cc_tyvar :: TcTyVar,
cc_rhs :: Xi,
......@@ -891,7 +886,6 @@ data Ct
| CFunEqCan { -- F xis ~ xi
-- Invariant: * isSynFamilyTyCon cc_fun
-- * typeKind (F xis) `compatKind` typeKind xi
cc_id :: EvVar,
cc_flavor :: CtFlavor,
cc_fun :: TyCon, -- A type function
cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated
......@@ -903,7 +897,6 @@ data Ct
}
| CNonCanonical { -- See Note [NonCanonical Semantics]
cc_id :: EvVar,
cc_flavor :: CtFlavor,
cc_depth :: SubGoalDepth
}
......@@ -911,11 +904,11 @@ data Ct
\end{code}
\begin{code}
mkNonCanonical :: EvVar -> CtFlavor -> Ct
mkNonCanonical ev flav = CNonCanonical { cc_id = ev, cc_flavor = flav, cc_depth = 0}
mkNonCanonical :: CtFlavor -> Ct
mkNonCanonical flav = CNonCanonical { cc_flavor = flav, cc_depth = 0}
ctPred :: Ct -> PredType
ctPred (CNonCanonical { cc_id = v }) = evVarPred v
ctPred (CNonCanonical { cc_flavor = fl }) = ctFlavPred fl
ctPred (CDictCan { cc_class = cls, cc_tyargs = xis })
= mkClassPred cls xis
ctPred (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })
......@@ -925,6 +918,12 @@ ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 })
ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi })
= mkIPPred nm xi
ctPred (CIrredEvCan { cc_ty = xi }) = xi
ctId :: String -> Ct -> EvVar
-- Precondition: not a derived!
ctId origin ct = ctFlavId origin (cc_flavor ct)
\end{code}
......@@ -942,16 +941,16 @@ ctWantedLoc ct = ASSERT2( not (isGivenOrSolved (cc_flavor ct)), ppr ct )
getWantedLoc (cc_flavor ct)
isWantedCt :: Ct -> Bool
isWantedCt ct = isWanted (cc_flavor ct)
isWantedCt = isWanted . cc_flavor
isDerivedCt :: Ct -> Bool
isDerivedCt ct = isDerived (cc_flavor ct)
isGivenCt :: Ct -> Bool
isGivenCt = isGiven . cc_flavor
isGivenCt_maybe :: Ct -> Maybe GivenKind
isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
isDerivedCt :: Ct -> Bool
isDerivedCt = isDerived . cc_flavor
isGivenOrSolvedCt :: Ct -> Bool
isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
isGivenOrSolvedCt = isGivenOrSolved . cc_flavor
isCTyEqCan :: Ct -> Bool
isCTyEqCan (CTyEqCan {}) = True
......@@ -981,11 +980,9 @@ isCNonCanonical _ = False
\begin{code}
instance Outputable Ct where
ppr ct = ppr (cc_flavor ct) <> braces (ppr (cc_depth ct))
<+> ppr ev_var <+> dcolon <+> ppr (ctPred ct)
<+> parens (text ct_sort)
where ev_var = cc_id ct
ct_sort = case ct of
ppr ct = ppr (cc_flavor ct) <+>
braces (ppr (cc_depth ct)) <+> parens (text ct_sort)
where ct_sort = case ct of
CTyEqCan {} -> "CTyEqCan"
CFunEqCan {} -> "CFunEqCan"
CNonCanonical {} -> "CNonCanonical"
......@@ -1225,55 +1222,85 @@ pprWantedsWithLocs wcs
\begin{code}
data CtFlavor
= Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
| Derived WantedLoc -- Derived's are just hints for unifications
| Wanted WantedLoc -- We have no evidence bindings for this constraint.
data GivenKind
= GivenOrig -- Originates in some given, such as signature or pattern match
| GivenSolved (Maybe EvTerm)
-- Is given as result of being solved, maybe provisionally on
-- some other wanted constraints. We cache the evidence term
-- sometimes here as well /as well as/ in the EvBinds,
-- see Note [Optimizing Spontaneously Solved Coercions]
= Given { flav_gloc :: GivenLoc, flav_evar :: EvVar }
-- Trully given, not depending on subgoals
-- NB: Spontaneous unifications belong here
-- DV TODOs: (i) Consider caching actual evidence _term_
-- (ii) Revisit Note [Optimizing Spontaneously Solved Coercions]
| Solved { flav_gloc :: GivenLoc, flav_evar :: EvVar }
-- Originally wanted, but now we've produced and
-- bound some partial evidence for this constraint.
-- NB: Evidence may rely on yet-wanted constraints or other solved or given
| Wanted { flav_wloc :: WantedLoc, flav_evar :: EvVar }
-- Wanted goal
| Derived { flav_wloc :: WantedLoc, flav_der_pty :: TcPredType }
-- A goal that we don't really have to solve and can't immediately
-- rewrite anything other than a derived (there's no evidence variable!)
-- but if we do manage to solve it may help in solving other goals.
ctFlavPred :: CtFlavor -> TcPredType
-- The predicate of a flavor
ctFlavPred (Given _ evar) = evVarPred evar
ctFlavPred (Solved _ evar) = evVarPred evar
ctFlavPred (Wanted _ evar) = evVarPred evar
ctFlavPred (Derived { flav_der_pty = pty }) = pty
ctFlavId :: String -> CtFlavor -> EvVar
-- Precondition: can't be derived
ctFlavId origin (Derived _ pty)
= pprPanic "ctFlavId: derived constraint cannot have id" $
vcat [ text "origin=" <+> text origin
, text "pty =" <+> ppr pty ]
ctFlavId _ fl = flav_evar fl
instance Outputable CtFlavor where
ppr (Given _ GivenOrig) = ptext (sLit "[G]")
ppr (Given _ (GivenSolved {})) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
ppr (Wanted {}) = ptext (sLit "[W]")
ppr (Derived {}) = ptext (sLit "[D]")
ppr fl = case fl of
(Given _ evar) -> ptext (sLit "[G]") <+> ppr evar <+> ppr_pty
(Solved _ evar) -> ptext (sLit "[S]") <+> ppr evar <+> ppr_pty
(Wanted _ evar) -> ptext (sLit "[W]") <+> ppr evar <+> ppr_pty
(Derived {}) -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty
where ppr_pty = dcolon <+> ppr (ctFlavPred fl)
getWantedLoc :: CtFlavor -> WantedLoc
getWantedLoc (Wanted wl) = wl
getWantedLoc (Derived wl) = wl
getWantedLoc flav@(Given {}) = pprPanic "getWantedLoc" (ppr flav)
-- Precondition: Wanted or Derived
getWantedLoc fl = flav_wloc fl
getGivenLoc :: CtFlavor -> GivenLoc
-- Precondition: Given or Solved
getGivenLoc fl = flav_gloc fl
pprFlavorArising :: CtFlavor -> SDoc
pprFlavorArising (Derived wl) = pprArisingAt wl
pprFlavorArising (Wanted wl) = pprArisingAt wl
pprFlavorArising (Given gl _) = pprArisingAt gl
pprFlavorArising (Solved gl _) = pprArisingAt gl
pprFlavorArising (Wanted wl _) = pprArisingAt wl
pprFlavorArising (Derived wl _) = pprArisingAt wl
isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
isWanted _ = False
isWanted _ = False
isGivenOrSolved :: CtFlavor -> Bool
isGivenOrSolved (Given {}) = True
isGivenOrSolved (Given {}) = True
isGivenOrSolved (Solved {}) = True
isGivenOrSolved _ = False
isSolved :: CtFlavor -> Bool
isSolved (Given _ (GivenSolved {})) = True
isSolved (Solved {}) = True
isSolved _ = False
isGiven_maybe :: CtFlavor -> Maybe GivenKind
isGiven_maybe (Given _ gk) = Just gk
isGiven_maybe _ = Nothing
isGiven :: CtFlavor -> Bool
isGiven (Given {}) = True
isGiven _ = False
isDerived :: CtFlavor -> Bool
isDerived :: CtFlavor -> Bool
isDerived (Derived {}) = True
isDerived _ = False
isDerived _ = False
canSolve :: CtFlavor -> CtFlavor -> Bool
canSolve :: CtFlavor -> CtFlavor -> Bool
-- canSolve ctid1 ctid2
-- The constraint ctid1 can be used to solve ctid2
-- "to solve" means a reaction where the active parts of the two constraints match.
......@@ -1287,14 +1314,15 @@ canSolve :: CtFlavor -> CtFlavor -> Bool
canSolve (Given {}) _ = True
canSolve (Wanted {}) (Derived {}) = True
canSolve (Wanted {}) (Wanted {}) = True
canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given
canSolve _ _ = False -- (There is no *evidence* for a derived.)
canSolve (Derived {}) (Derived {}) = True -- Derived can't solve wanted/given
canSolve _ _ = False -- No evidence for a derived, anyway
canRewrite :: CtFlavor -> CtFlavor -> Bool
-- canRewrite ctid1 ctid2
-- The *equality_constraint* ctid1 can be used to rewrite inside ctid2
-- canRewrite ct1 ct2
-- The equality constraint ct1 can be used to rewrite inside ct2
canRewrite = canSolve
{- DELETEME
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted
combineCtLoc (Wanted loc) _ = loc
......@@ -1303,12 +1331,28 @@ combineCtLoc (Derived loc ) _ = loc
combineCtLoc _ (Derived loc ) = loc
combineCtLoc _ _ = panic "combineCtLoc: both given"
mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor
-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl
-}
-- combineWantedLoc :: Maybe WantedLoc -> Maybe WantedLoc -> WantedLoc
-- -- Precondition: at least one is Just
-- combineWantedLoc (Just wl) _ = wl
-- combineWantedLoc _ (Just wl) = wl
-- combineWantedLoc _ _ = panic "combineCtLoc: both given!"
mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc
mkGivenLoc wl sk = setCtLocOrigin wl sk
mkSolvedLoc :: WantedLoc -> SkolemInfo -> GivenLoc
mkSolvedLoc wl sk = setCtLocOrigin wl sk
{- DELETEME
mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
......@@ -1318,6 +1362,8 @@ mkWantedFlavor :: CtFlavor -> CtFlavor
mkWantedFlavor (Wanted loc) = Wanted loc
mkWantedFlavor (Derived loc) = Wanted loc
mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
-}
\end{code}
%************************************************************************
......
This diff is collapsed.
......@@ -39,7 +39,7 @@ import BasicTypes ( RuleName )
import Control.Monad ( when )
import Outputable
import FastString
import TrieMap
import TrieMap () -- DV: for now
import DynFlags
\end{code}
......@@ -603,7 +603,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
; traceTc "simplifyRule" $
vcat [ text "zonked_lhs" <+> ppr zonked_lhs
, text "lhs_results" <+> ppr lhs_results
, text "lhs_results" <+> ppr lhs_results
, text "lhs_binds" <+> ppr lhs_binds
, text "rhs_wanted" <+> ppr rhs_wanted ]
......@@ -611,8 +611,11 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
-- Don't quantify over equalities (judgement call here)
; let (eqs, dicts) = partitionBag (isEqPred . ctPred)
(wc_flat lhs_results)
lhs_dicts = map cc_id (bagToList dicts)
lhs_dicts = map (ctId "tcSimplify") (bagToList dicts)
-- Dicts and implicit parameters
-- NB: dicts come from lhs_results which
-- are all Wanted, hence have ids, hence
-- it's fine to call ctId on them
-- Fail if we have not got down to unsolved flats
; ev_binds_var <- newTcEvBinds
......@@ -808,17 +811,21 @@ simpl_loop n implics
; inerts <- getTcSInerts
; let ((_,unsolved_flats),_) = extractUnsolved inerts
{- DELETEME
; ecache_pre <- getTcSEvVarCacheMap
; let pr = ppr ((\k z m -> foldTM k m z) (:) [] ecache_pre)
; traceTcS "ecache_pre" $ pr
-}
; improve_eqs <- if not (isEmptyBag implic_eqs)
then return implic_eqs
else applyDefaultingRules unsolved_flats
{- DELETEME
; ecache_post <- getTcSEvVarCacheMap