Commit d30b9cf4 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Another refactoring of constraints

1. Rejig CtLoc
   * CtLoc is now *not* parameterised (much simpler)
   * CtLoc includes the "depth" of the constraint
   * CtLoc includes the TcLclEnv at the birthplace
     That gives (a) the SrcSpan, (b) the [ErrCtxt]
     (c) the [TcIdBinder]
   * The CtLoc of a constraint is no longer in its CtEvidence
   * Where we passed 'depth' before, now we pass CtLoc

2. Some significant refactoring in TcErrors
   * Get rid of cec_extra
   * Traverse every constraint, so that we can be
     sure to generate bindings where necessary.
     (This was really a lurking bug before.)

3. Merge zonking into TcCanonical.  This turned out to be
   almost trivial; just a small change to TcCanonical.flattenTyVar.

   The nice consequence is that we don't need to zonk a constraint
   before solving it; instead it gets zonked "on the fly" as it were.
parent 06832583
......@@ -30,9 +30,7 @@ module Inst (
tyVarsOfWC, tyVarsOfBag,
tyVarsOfCt, tyVarsOfCts,
tidyEvVar, tidyCt, tidyGivenLoc,
substEvVar, substImplication, substCt
tidyEvVar, tidyCt, tidySkolemInfo
) where
#include "HsVersions.h"
......@@ -85,7 +83,7 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred
= do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred
; emitFlat (mkNonCanonical (CtWanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev }))
; emitFlat (mkNonCanonical loc (CtWanted { ctev_pred = pred, ctev_evar = ev }))
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -555,14 +553,13 @@ tidyCt env ct
= case ct of
CHoleCan {} -> ct { cc_ev = tidy_flavor env (cc_ev ct) }
_ -> CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct)
, cc_depth = cc_depth ct }
, cc_loc = cc_loc ct }
where
tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evtm/var field because we don't
-- show it in error messages
tidy_flavor env ctev@(CtGiven { ctev_gloc = gloc, ctev_pred = pred })
= ctev { ctev_gloc = tidyGivenLoc env gloc
, ctev_pred = tidyType env pred }
tidy_flavor env ctev@(CtGiven { ctev_pred = pred })
= ctev { ctev_pred = tidyType env pred }
tidy_flavor env ctev@(CtWanted { ctev_pred = pred })
= ctev { ctev_pred = tidyType env pred }
tidy_flavor env ctev@(CtDerived { ctev_pred = pred })
......@@ -571,78 +568,26 @@ tidyCt env ct
tidyEvVar :: TidyEnv -> EvVar -> EvVar
tidyEvVar env var = setVarType var (tidyType env (varType var))
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
tidyGivenLoc env (CtLoc skol lcl)
= CtLoc (tidySkolemInfo env skol) lcl
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
tidySkolemInfo env (UnifyForAllSkol skol_tvs ty)
= UnifyForAllSkol (map tidy_tv skol_tvs) (tidyType env ty)
where
tidy_tv tv = case getTyVar_maybe ty' of
Just tv' -> tv'
Nothing -> pprPanic "ticySkolemInfo" (ppr tv <+> ppr ty')
where
ty' = tidyTyVarOcc env tv
tidySkolemInfo _ info = info
---------------- Substitution -------------------------
-- This is used only in TcSimpify, for substituations that are *also*
-- reflected in the unification variables. So we don't substitute
-- in the evidence.
substCt :: TvSubst -> Ct -> Ct
-- Conservatively converts it to non-canonical:
-- Postcondition: if the constraint does not get rewritten
substCt subst ct
| pty <- ctPred ct
, sty <- substTy subst pty
= if sty `eqType` pty then
ct { cc_ev = substFlavor subst (cc_ev ct) }
else
CNonCanonical { cc_ev = substFlavor subst (cc_ev ct)
, cc_depth = cc_depth ct }
substWC :: TvSubst -> WantedConstraints -> WantedConstraints
substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= WC { wc_flat = mapBag (substCt subst) flat
, wc_impl = mapBag (substImplication subst) implic
, wc_insol = mapBag (substCt subst) insol }
substImplication :: TvSubst -> Implication -> Implication
substImplication subst implic@(Implic { ic_skols = tvs
, ic_given = given
, ic_wanted = wanted
, ic_loc = loc })
= implic { ic_skols = tvs'
, ic_given = map (substEvVar subst1) given
, ic_wanted = substWC subst1 wanted
, ic_loc = substGivenLoc subst1 loc }
tidySkolemInfo :: TidyEnv -> SkolemInfo -> (TidyEnv, SkolemInfo)
tidySkolemInfo env (SigSkol cx ty)
= (env', SigSkol cx ty')
where
(subst1, tvs') = mapAccumL substTyVarBndr subst tvs
substEvVar :: TvSubst -> EvVar -> EvVar
substEvVar subst var = setVarType var (substTy subst (varType var))
(env', ty') = tidyOpenType env ty
substFlavor :: TvSubst -> CtEvidence -> CtEvidence
substFlavor subst ctev@(CtGiven { ctev_gloc = gloc, ctev_pred = pred })
= ctev { ctev_gloc = substGivenLoc subst gloc
, ctev_pred = substTy subst pred }
substFlavor subst ctev@(CtWanted { ctev_pred = pred })
= ctev { ctev_pred = substTy subst pred }
substFlavor subst ctev@(CtDerived { ctev_pred = pty })
= ctev { ctev_pred = substTy subst pty }
tidySkolemInfo env (InferSkol ids)
= (env', InferSkol ids')
where
(env', ids') = mapAccumL do_one env ids
do_one env (name, ty) = (env', (name, ty'))
where
(env', ty') = tidyOpenType env ty
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol lcl)
= CtLoc (substSkolemInfo subst skol) lcl
tidySkolemInfo env (UnifyForAllSkol skol_tvs ty)
= (env1, UnifyForAllSkol skol_tvs' ty')
where
env1 = tidyFreeTyVars env (tyVarsOfType ty `delVarSetList` skol_tvs)
(env2, skol_tvs') = tidyTyVarBndrs env1 skol_tvs
ty' = tidyType env2 ty
substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids)
substSkolemInfo _ info = info
tidySkolemInfo env info = (env, info)
\end{code}
This diff is collapsed.
This diff is collapsed.
......@@ -236,7 +236,7 @@ tcExpr HsHole res_ty
; traceTc "tcExpr.HsHole" (ppr ty)
; ev <- mkSysLocalM (mkFastString "_") ty
; loc <- getCtLoc HoleOrigin
; let can = CHoleCan { cc_ev = CtWanted loc ty ev, cc_hole_ty = ty, cc_depth = 0 }
; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_hole_ty = ty, cc_loc = loc }
; traceTc "tcExpr.HsHole emitting" (ppr can)
; emitInsoluble can
; tcWrapResult (HsVar ev) ty res_ty }
......
This diff is collapsed.
......@@ -66,7 +66,7 @@ module TcMType (
zonkTcType, zonkTcTypes, zonkTcThetaType,
zonkTcKind, defaultKindVarToStar,
zonkEvVar, zonkWC, zonkId, zonkCt,
zonkEvVar, zonkWC, zonkId, zonkCt, zonkSkolemInfo,
tcGetGlobalTyVars,
) where
......@@ -623,17 +623,17 @@ zonkImplication implic@(Implic { ic_untch = untch
, ic_skols = skols
, ic_given = given
, ic_wanted = wanted
, ic_loc = loc })
, ic_info = info })
= do { skols' <- mapM zonkTcTyVarBndr skols -- Need to zonk their kinds!
-- as Trac #7230 showed
; given' <- mapM zonkEvVar given
; loc' <- zonkGivenLoc loc
; info' <- zonkSkolemInfo info
; wanted' <- zonkWCRec binds_var untch wanted
; return (implic { ic_skols = skols'
, ic_given = given'
, ic_fsks = [] -- Zonking removes all FlatSkol tyvars
, ic_wanted = wanted'
, ic_loc = loc' }) }
, ic_info = info' }) }
zonkEvVar :: EvVar -> TcM EvVar
zonkEvVar var = do { ty' <- zonkTcType (varType var)
......@@ -643,7 +643,8 @@ zonkEvVar var = do { ty' <- zonkTcType (varType var)
zonkWC :: EvBindsVar -- May add new bindings for wanted family equalities in here
-> WantedConstraints -> TcM WantedConstraints
zonkWC binds_var wc
= zonkWCRec binds_var noUntouchables wc
= do { untch <- getUntouchables
; zonkWCRec binds_var untch wc }
zonkWCRec :: EvBindsVar
-> Untouchables
......@@ -732,13 +733,12 @@ zonkCt ct
| otherwise = do { fl' <- zonkCtEvidence (cc_ev ct)
; return $
CNonCanonical { cc_ev = fl'
, cc_depth = cc_depth ct } }
, cc_loc = cc_loc ct } }
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev@(CtGiven { ctev_gloc = loc, ctev_pred = pred })
= do { loc' <- zonkGivenLoc loc
; pred' <- zonkTcType pred
; return (ctev { ctev_gloc = loc', ctev_pred = pred'}) }
zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
= do { pred' <- zonkTcType pred
; return (ctev { ctev_pred = pred'}) }
zonkCtEvidence ctev@(CtWanted { ctev_pred = pred })
= do { pred' <- zonkTcType pred
; return (ctev { ctev_pred = pred' }) }
......@@ -746,12 +746,6 @@ zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
= do { pred' <- zonkTcType pred
; return (ctev { ctev_pred = pred' }) }
zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
zonkGivenLoc (CtLoc skol_info lcl)
= do { skol_info' <- zonkSkolemInfo skol_info
; return (CtLoc skol_info' lcl) }
zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty
; return (SigSkol cx ty') }
......
......@@ -815,13 +815,14 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
popErrCtxt :: TcM a -> TcM a
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
getCtLoc :: orig -> TcM (CtLoc orig)
getCtLoc :: CtOrigin -> TcM CtLoc
getCtLoc origin
= do { env <- getLclEnv ; return (CtLoc origin env) }
= do { env <- getLclEnv
; return (CtLoc { ctl_origin = origin, ctl_env = env, ctl_depth = 0 }) }
setCtLoc :: CtLoc orig -> TcM a -> TcM a
setCtLoc :: CtLoc -> TcM a -> TcM a
-- Set the SrcSpan and error context from the CtLoc
setCtLoc (CtLoc _ lcl) thing_inside
setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
= updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
, tcl_bndrs = tcl_bndrs lcl
, tcl_ctxt = tcl_ctxt lcl })
......
......@@ -54,25 +54,26 @@ module TcRnTypes(
isCDictCan_Maybe, isCFunEqCan_Maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt,
ctWantedLoc, ctEvidence,
ctEvidence,
SubGoalDepth, mkNonCanonical, mkNonCanonicalCt,
ctPred, ctEvPred, ctEvTerm, ctEvId, ctEvEnv,
ctPred, ctEvPred, ctEvTerm, ctEvId,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
Implication(..),
CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, setCtLocOrigin,
CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
ctLocDepth, bumpCtLocDepth,
setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
WantedLoc, GivenLoc, pushErrCtxt,
pushErrCtxtSameOrigin,
pushErrCtxt, pushErrCtxtSameOrigin,
SkolemInfo(..),
CtEvidence(..), pprFlavorArising,
CtEvidence(..),
mkGivenLoc,
isWanted, isGiven,
isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite,
isDerived, canSolve, canRewrite,
CtFlavour(..), ctEvFlavour, ctFlavour,
-- Pretty printing
......@@ -118,7 +119,6 @@ import DynFlags
import Outputable
import ListSetOps
import FastString
import Util
import Data.Set (Set)
\end{code}
......@@ -848,9 +848,6 @@ type Xi = Type -- In many comments, "xi" ranges over Xi
type Cts = Bag Ct
type SubGoalDepth = Int -- An ever increasing number used to restrict
-- simplifier iterations. Bounded by -fcontext-stack.
data Ct
-- Atomic canonical constraints
= CDictCan { -- e.g. Num xi
......@@ -858,8 +855,7 @@ data Ct
cc_class :: Class,
cc_tyargs :: [Xi],
cc_depth :: SubGoalDepth -- Simplification depth of this constraint
-- See Note [WorkList]
cc_loc :: CtLoc
}
| CIrredEvCan { -- These stand for yet-unknown predicates
......@@ -868,7 +864,7 @@ data Ct
-- Since, if it were a type constructor application, that'd make the
-- whole constraint a CDictCan, or CTyEqCan. And it can't be
-- a type family application either because it's a Xi type.
cc_depth :: SubGoalDepth -- See Note [WorkList]
cc_loc :: CtLoc
}
| CTyEqCan { -- tv ~ xi (recall xi means function free)
......@@ -880,8 +876,7 @@ data Ct
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_tyvar :: TcTyVar,
cc_rhs :: Xi,
cc_depth :: SubGoalDepth -- See Note [WorkList]
cc_loc :: CtLoc
}
| CFunEqCan { -- F xis ~ xi
......@@ -893,21 +888,20 @@ data Ct
cc_rhs :: Xi, -- *never* over-saturated (because if so
-- we should have decomposed)
cc_depth :: SubGoalDepth -- See Note [WorkList]
cc_loc :: CtLoc
}
| CNonCanonical { -- See Note [NonCanonical Semantics]
cc_ev :: CtEvidence,
cc_depth :: SubGoalDepth
cc_ev :: CtEvidence,
cc_loc :: CtLoc
}
| CHoleCan {
cc_ev :: CtEvidence,
cc_hole_ty :: TcTauType, -- Not a Xi! See same not as above
cc_depth :: SubGoalDepth -- See Note [WorkList]
cc_loc :: CtLoc
}
\end{code}
Note [Ct/evidence invariant]
......@@ -919,11 +913,11 @@ This holds by construction; look at the unique place where CDictCan is
built (in TcCanonical)
\begin{code}
mkNonCanonical :: CtEvidence -> Ct
mkNonCanonical flav = CNonCanonical { cc_ev = flav, cc_depth = 0}
mkNonCanonical :: CtLoc -> CtEvidence -> Ct
mkNonCanonical loc ev = CNonCanonical { cc_ev = ev, cc_loc = loc }
mkNonCanonicalCt :: Ct -> Ct
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_depth = 0}
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_loc = cc_loc ct }
ctEvidence :: Ct -> CtEvidence
ctEvidence = cc_ev
......@@ -949,11 +943,6 @@ dropDerivedWC wc@(WC { wc_flat = flats })
%************************************************************************
\begin{code}
ctWantedLoc :: Ct -> WantedLoc
-- Only works for Wanted/Derived
ctWantedLoc ct = ASSERT2( not (isGiven (cc_ev ct)), ppr ct )
getWantedLoc (cc_ev ct)
isWantedCt :: Ct -> Bool
isWantedCt = isWanted . cc_ev
......@@ -996,8 +985,7 @@ isHoleCt _ = False
\begin{code}
instance Outputable Ct where
ppr ct = ppr (cc_ev ct) <+>
braces (ppr (cc_depth ct)) <+> parens (text ct_sort)
ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort)
where ct_sort = case ct of
CTyEqCan {} -> "CTyEqCan"
CFunEqCan {} -> "CFunEqCan"
......@@ -1113,7 +1101,7 @@ data Implication
-- free in the environment
ic_skols :: [TcTyVar], -- Introduced skolems
-- See Note [Skolems in an implication]
ic_info :: SkolemInfo, -- See Note [Skolems in an implication]
-- See Note [Shadowing in a constraint]
ic_fsks :: [TcTyVar], -- Extra flatten-skolems introduced by the flattening
......@@ -1122,9 +1110,9 @@ data Implication
ic_given :: [EvVar], -- Given evidence variables
-- (order does not matter)
ic_loc :: GivenLoc, -- Binding location of the implication,
-- which is also the location of all the
-- given evidence variables
ic_env :: TcLclEnv, -- Gives the source location and error context
-- for the implicatdion, and hence for all the
-- given evidence variables
ic_wanted :: WantedConstraints, -- The wanted
ic_insol :: Bool, -- True iff insolubleWC ic_wanted is true
......@@ -1137,7 +1125,7 @@ instance Outputable Implication where
ppr (Implic { ic_untch = untch, ic_skols = skols, ic_fsks = fsks
, ic_given = given
, ic_wanted = wanted
, ic_binds = binds, ic_loc = loc })
, ic_binds = binds, ic_info = info })
= ptext (sLit "Implic") <+> braces
(sep [ ptext (sLit "Untouchables = ") <+> ppr untch
, ptext (sLit "Skolems = ") <+> ppr skols
......@@ -1145,8 +1133,7 @@ instance Outputable Implication where
, ptext (sLit "Given = ") <+> pprEvVars given
, ptext (sLit "Wanted = ") <+> ppr wanted
, ptext (sLit "Binds = ") <+> ppr binds
, pprSkolInfo (ctLocOrigin loc)
, ppr (ctLocSpan loc) ])
, pprSkolInfo info ])
\end{code}
Note [Shadowing in a constraint]
......@@ -1227,7 +1214,7 @@ pprWantedsWithLocs wcs
%************************************************************************
%* *
CtLoc
CtEvidence
%* *
%************************************************************************
......@@ -1239,19 +1226,16 @@ may be un-zonked.
\begin{code}
data CtEvidence
= CtGiven { ctev_gloc :: GivenLoc
, ctev_pred :: TcPredType
= CtGiven { ctev_pred :: TcPredType
, ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence]
-- Truly given, not depending on subgoals
-- NB: Spontaneous unifications belong here
| CtWanted { ctev_wloc :: WantedLoc
, ctev_pred :: TcPredType
| CtWanted { ctev_pred :: TcPredType
, ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence]
-- Wanted goal
| CtDerived { ctev_wloc :: WantedLoc
, ctev_pred :: TcPredType }
| CtDerived { ctev_pred :: 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!)
-- but if we do manage to solve it may help in solving other goals.
......@@ -1276,11 +1260,6 @@ ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev
ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id"
(ppr ctev)
ctEvEnv :: CtEvidence -> TcLclEnv
ctEvEnv (CtWanted { ctev_wloc = loc }) = ctLocEnv loc
ctEvEnv (CtDerived { ctev_wloc = loc }) = ctLocEnv loc
ctEvEnv (CtGiven { ctev_gloc = loc }) = ctLocEnv loc
ctEvId :: CtEvidence -> TcId
ctEvId (CtWanted { ctev_evar = ev }) = ev
ctEvId ctev = pprPanic "ctEvId:" (ppr ctev)
......@@ -1297,19 +1276,6 @@ instance Outputable CtEvidence where
CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty
where ppr_pty = dcolon <+> ppr (ctEvPred fl)
getWantedLoc :: CtEvidence -> WantedLoc
-- Precondition: Wanted or Derived
getWantedLoc fl = ctev_wloc fl
getGivenLoc :: CtEvidence -> GivenLoc
-- Precondition: Given
getGivenLoc fl = ctev_gloc fl
pprFlavorArising :: CtEvidence -> SDoc
pprFlavorArising (CtGiven { ctev_gloc = gl }) = pprArisingAt gl
pprFlavorArising ctev = pprArisingAt (ctev_wloc ctev)
isWanted :: CtEvidence -> Bool
isWanted (CtWanted {}) = True
isWanted _ = False
......@@ -1343,9 +1309,6 @@ canRewrite :: CtFlavour -> CtFlavour -> Bool
-- canRewrite ct1 ct2
-- The equality constraint ct1 can be used to rewrite inside ct2
canRewrite = canSolve
mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc
mkGivenLoc wl sk = setCtLocOrigin wl sk
\end{code}
%************************************************************************
......@@ -1360,35 +1323,49 @@ dictionaries don't appear in the original source code.
type will evolve...
\begin{code}
data CtLoc orig = CtLoc orig TcLclEnv
data CtLoc = CtLoc { ctl_origin :: CtOrigin
, ctl_env :: TcLclEnv
, ctl_depth :: SubGoalDepth }
-- The TcLclEnv includes particularly
-- source location: tcl_loc :: SrcSpan
-- context: tcl_ctxt :: [ErrCtxt]
-- binder stack: tcl_bndrs :: [TcIdBinders]
type WantedLoc = CtLoc CtOrigin -- Instantiation for wanted constraints
type GivenLoc = CtLoc SkolemInfo -- Instantiation for given constraints
type SubGoalDepth = Int -- An ever increasing number used to restrict
-- simplifier iterations. Bounded by -fcontext-stack.
-- See Note [WorkList]
ctLocEnv :: CtLoc o -> TcLclEnv
ctLocEnv (CtLoc _ lcl) = lcl
mkGivenLoc :: SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info
, ctl_env = env
, ctl_depth = 0 }
ctLocSpan :: CtLoc o -> SrcSpan
ctLocSpan (CtLoc _ lcl) = tcl_loc lcl
ctLocEnv :: CtLoc -> TcLclEnv
ctLocEnv = ctl_env
ctLocOrigin :: CtLoc o -> o
ctLocOrigin (CtLoc o _) = o
ctLocDepth :: CtLoc -> SubGoalDepth
ctLocDepth = ctl_depth
setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
setCtLocOrigin (CtLoc _ lcl) o = CtLoc o lcl
ctLocOrigin :: CtLoc -> CtOrigin
ctLocOrigin = ctl_origin
pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig
pushErrCtxt o err (CtLoc _ lcl)
= CtLoc o (lcl { tcl_ctxt = err : tcl_ctxt lcl })
ctLocSpan :: CtLoc -> SrcSpan
ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl
pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc orig -> CtLoc orig
bumpCtLocDepth :: CtLoc -> CtLoc
bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = d+1 }
setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
setCtLocOrigin ctl orig = ctl { ctl_origin = orig }
pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc
pushErrCtxt o err loc@(CtLoc { ctl_env = lcl })
= loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }
pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc
-- Just add information w/o updating the origin!
pushErrCtxtSameOrigin err (CtLoc o lcl)
= CtLoc o (lcl { tcl_ctxt = err : tcl_ctxt lcl })
pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl })
= loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }
pprArising :: CtOrigin -> SDoc
-- Used for the main, top-level error message
......@@ -1397,9 +1374,10 @@ pprArising (TypeEqOrigin {}) = empty
pprArising FunDepOrigin = empty
pprArising orig = text "arising from" <+> ppr orig
pprArisingAt :: Outputable o => CtLoc o -> SDoc
pprArisingAt (CtLoc o lcl) = sep [ text "arising from" <+> ppr o
, text "at" <+> ppr (tcl_loc lcl)]
pprArisingAt :: CtLoc -> SDoc
pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl})
= sep [ text "arising from" <+> ppr o
, text "at" <+> ppr (tcl_loc lcl)]
\end{code}
%************************************************************************
......@@ -1491,9 +1469,11 @@ pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "Unk
%************************************************************************
\begin{code}
-- CtOrigin gives the origin of *wanted* constraints
data CtOrigin
= OccurrenceOf Name -- Occurrence of an overloaded identifier
= GivenOrigin SkolemInfo
-- All the others are for *wanted* constraints
| OccurrenceOf Name -- Occurrence of an overloaded identifier
| AppOrigin -- An application of some kind
| SpecPragOrigin Name -- Specialisation pragma for identifier
......@@ -1537,6 +1517,7 @@ instance Outputable CtOrigin where
ppr orig = pprO orig
pprO :: CtOrigin -> SDoc
pprO (GivenOrigin sk) = ppr sk
pprO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
pprO AppOrigin = ptext (sLit "an application")
pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
......
......@@ -177,7 +177,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
])
-- Simplify the RHS constraints
; loc <- getCtLoc (RuleSkol name)
; lcl_env <- getLclEnv
; rhs_binds_var <- newTcEvBinds
; emitImplication $ Implic { ic_untch = noUntouchables
, ic_skols = qtkvs
......@@ -186,7 +186,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
, ic_wanted = rhs_wanted
, ic_insol = insolubleWC rhs_wanted
, ic_binds = rhs_binds_var
, ic_loc = loc }
, ic_info = RuleSkol name
, ic_env = lcl_env }
-- For the LHS constraints we must solve the remaining constraints
-- (a) so that we report insoluble ones
......@@ -199,7 +200,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
, ic_wanted = other_lhs_wanted
, ic_insol = insolubleWC other_lhs_wanted
, ic_binds = lhs_binds_var
, ic_loc = loc }
, ic_info = RuleSkol name
, ic_env = lcl_env }
; return (HsRule name act
(map (RuleBndr . noLoc) (qtkvs ++ tpl_ids))
......
......@@ -25,10 +25,10 @@ module TcSMonad (
emitInsoluble,
isWanted, isDerived,
isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
isGivenCt, isWantedCt, isDerivedCt,
canRewrite, canSolve,
mkGivenLoc, ctWantedLoc,
mkGivenLoc,
TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality
traceFireTcS, bumpStepCountTcS,
......@@ -82,7 +82,7 @@ module TcSMonad (
compatKind, mkKindErrorCtxtTcS,
Untouchables, isTouchableMetaTyVarTcS,
Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe,
getDefaultInfo, getDynFlags,
......@@ -701,8 +701,7 @@ prepareInertsForImplications is
| otherwise = funeq { cc_ev = given_ev }
where
ev = ctEvidence funeq
given_ev = CtGiven { ctev_gloc = setCtLocOrigin (ctev_wloc ev) UnkSkol
, ctev_evtm = EvId (ctev_evar ev)
given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev)
, ctev_pred = ctev_pred ev }
\end{code}
......@@ -960,13 +959,13 @@ bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
; n <- TcM.readTcRef ref
; TcM.writeTcRef ref (n+1) }
traceFireTcS :: SubGoalDepth -> SDoc -> TcS ()
traceFireTcS :: Ct -> SDoc -> TcS ()
-- Dump a rule-firing trace
traceFireTcS depth doc
traceFireTcS ct doc
= TcS $ \env ->
TcM.ifDOptM Opt_D_dump_cs_trace $
do { n <- TcM.readTcRef (tcs_count env)
; let msg = int n <> brackets (int depth) <+> doc
; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct))) <+> doc
; TcM.dumpTcRn msg }
runTcS :: TcS a -- What to run
......@@ -1221,7 +1220,7 @@ getGblEnv = wrapTcS $ TcM.getGblEnv
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS ()
checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS ()
checkWellStagedDFun pred dfun_id loc
= wrapTcS $ TcM.setCtLoc loc $
do { use_stage <- TcM.getStage
......@@ -1237,6 +1236,17 @@ isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool