Commit 2b69233d authored by Simon Peyton Jones's avatar Simon Peyton Jones

A raft more changes,

 * simplifying and tidying up canonicalisation,
 * removing the flat cache altogether
 * making the FunEq worklist into a deque
parent f5216cd2
......@@ -85,7 +85,7 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred
= do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred
; emitFlat (mkNonCanonical (Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev }))
; emitFlat (mkNonCanonical (CtWanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev }))
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -557,12 +557,12 @@ tidyCt env ct
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@(Given { ctev_gloc = gloc, ctev_pred = pred })
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@(Wanted { ctev_pred = pred })
tidy_flavor env ctev@(CtWanted { ctev_pred = pred })
= ctev { ctev_pred = tidyType env pred }
tidy_flavor env ctev@(Derived { ctev_pred = pred })
tidy_flavor env ctev@(CtDerived { ctev_pred = pred })
= ctev { ctev_pred = tidyType env pred }
tidyEvVar :: TidyEnv -> EvVar -> EvVar
......@@ -624,14 +624,14 @@ substEvVar :: TvSubst -> EvVar -> EvVar
substEvVar subst var = setVarType var (substTy subst (varType var))
substFlavor :: TvSubst -> CtEvidence -> CtEvidence
substFlavor subst ctev@(Given { ctev_gloc = gloc, ctev_pred = pred })
substFlavor subst ctev@(CtGiven { ctev_gloc = gloc, ctev_pred = pred })
= ctev { ctev_gloc = substGivenLoc subst gloc
, ctev_pred = substTy subst pred }
substFlavor subst ctev@(Wanted { ctev_pred = pred })
substFlavor subst ctev@(CtWanted { ctev_pred = pred })
= ctev { ctev_pred = substTy subst pred }
substFlavor subst ctev@(Derived { ctev_pred = pty })
substFlavor subst ctev@(CtDerived { ctev_pred = pty })
= ctev { ctev_pred = substTy subst pty }
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
......
This diff is collapsed.
......@@ -166,7 +166,7 @@ reportTidyWanteds ctxt insols flats implics
deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg)
-> Ct -> TcM ()
deferToRuntime ev_binds_var ctxt mk_err_msg ct
| Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
| CtWanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
= do { err <- setCtLoc loc $
mk_err_msg ctxt ct
; dflags <- getDynFlags
......@@ -332,9 +332,9 @@ groupErrs mk_err (ct1 : rest)
is_friend friend = cc_ev friend `same_group` flavor
same_group :: CtEvidence -> CtEvidence -> Bool
same_group (Given {ctev_gloc = l1}) (Given {ctev_gloc = l2}) = same_loc l1 l2
same_group (Wanted {ctev_wloc = l1}) (Wanted {ctev_wloc = l2}) = same_loc l1 l2
same_group (Derived {ctev_wloc = l1}) (Derived {ctev_wloc = l2}) = same_loc l1 l2
same_group (CtGiven {ctev_gloc = l1}) (CtGiven {ctev_gloc = l2}) = same_loc l1 l2
same_group (CtWanted {ctev_wloc = l1}) (CtWanted {ctev_wloc = l2}) = same_loc l1 l2
same_group (CtDerived {ctev_wloc = l1}) (CtDerived {ctev_wloc = l2}) = same_loc l1 l2
same_group _ _ = False
same_loc :: CtLoc o -> CtLoc o -> Bool
......@@ -496,7 +496,7 @@ mkEqErr1 ctxt ct
flav = cc_ev ct
inaccessible_msg (Given { ctev_gloc = loc })
inaccessible_msg (CtGiven { ctev_gloc = loc })
= hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ctLocOrigin loc))
-- If a Solved then we should not report inaccessible code
......@@ -1151,9 +1151,9 @@ flattenForAllErrorTcS fl ty
\begin{code}
setCtFlavorLoc :: CtEvidence -> TcM a -> TcM a
setCtFlavorLoc (Wanted { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (Derived { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (Given { ctev_gloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (CtWanted { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (CtDerived { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (CtGiven { ctev_gloc = loc }) thing = setCtLoc loc thing
\end{code}
%************************************************************************
......
This diff is collapsed.
......@@ -652,14 +652,14 @@ zonkCts :: Cts -> TcM Cts
zonkCts = mapBagM zonkCt
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev@(Given { ctev_gloc = loc, ctev_pred = pred })
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@(Wanted { ctev_pred = pred })
zonkCtEvidence ctev@(CtWanted { ctev_pred = pred })
= do { pred' <- zonkTcType pred
; return (ctev { ctev_pred = pred' }) }
zonkCtEvidence ctev@(Derived { ctev_pred = pred })
zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
= do { pred' <- zonkTcType pred
; return (ctev { ctev_pred = pred' }) }
......
......@@ -73,6 +73,7 @@ module TcRnTypes(
mkGivenLoc,
isWanted, isGiven,
isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite,
CtFlavour(..), ctEvFlavour, ctFlavour,
-- Pretty printing
pprEvVarTheta, pprWantedsWithLocs,
......@@ -1205,42 +1206,57 @@ may be un-zonked.
\begin{code}
data CtEvidence
= Given { ctev_gloc :: GivenLoc
, ctev_pred :: TcPredType
, ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence]
= CtGiven { ctev_gloc :: GivenLoc
, ctev_pred :: TcPredType
, ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence]
-- Truly given, not depending on subgoals
-- NB: Spontaneous unifications belong here
| Wanted { ctev_wloc :: WantedLoc
, ctev_pred :: TcPredType
, ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence]
| CtWanted { ctev_wloc :: WantedLoc
, ctev_pred :: TcPredType
, ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence]
-- Wanted goal
| Derived { ctev_wloc :: WantedLoc
, ctev_pred :: TcPredType }
| CtDerived { ctev_wloc :: WantedLoc
, 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.
data CtFlavour = Given | Wanted | Derived
ctFlavour :: Ct -> CtFlavour
ctFlavour ct = ctEvFlavour (cc_ev ct)
ctEvFlavour :: CtEvidence -> CtFlavour
ctEvFlavour (CtGiven {}) = Given
ctEvFlavour (CtWanted {}) = Wanted
ctEvFlavour (CtDerived {}) = Derived
ctEvPred :: CtEvidence -> TcPredType
-- The predicate of a flavor
ctEvPred = ctev_pred
ctEvTerm :: CtEvidence -> EvTerm
ctEvTerm (Given { ctev_evtm = tm }) = tm
ctEvTerm (Wanted { ctev_evar = ev }) = EvId ev
ctEvTerm ctev@(Derived {}) = pprPanic "ctEvTerm: derived constraint cannot have id"
ctEvTerm (CtGiven { ctev_evtm = tm }) = tm
ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev
ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id"
(ppr ctev)
ctEvId :: CtEvidence -> TcId
ctEvId (Wanted { ctev_evar = ev }) = ev
ctEvId (CtWanted { ctev_evar = ev }) = ev
ctEvId ctev = pprPanic "ctEvId:" (ppr ctev)
instance Outputable CtFlavour where
ppr Given = ptext (sLit "[G]")
ppr Wanted = ptext (sLit "[W]")
ppr Derived = ptext (sLit "[D]")
instance Outputable CtEvidence where
ppr fl = case fl of
Given {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty
Wanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty
Derived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty
CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty
CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty
CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty
where ppr_pty = dcolon <+> ppr (ctEvPred fl)
getWantedLoc :: CtEvidence -> WantedLoc
......@@ -1252,23 +1268,23 @@ getGivenLoc :: CtEvidence -> GivenLoc
getGivenLoc fl = ctev_gloc fl
pprFlavorArising :: CtEvidence -> SDoc
pprFlavorArising (Given { ctev_gloc = gl }) = pprArisingAt gl
pprFlavorArising ctev = pprArisingAt (ctev_wloc ctev)
pprFlavorArising (CtGiven { ctev_gloc = gl }) = pprArisingAt gl
pprFlavorArising ctev = pprArisingAt (ctev_wloc ctev)
isWanted :: CtEvidence -> Bool
isWanted (Wanted {}) = True
isWanted (CtWanted {}) = True
isWanted _ = False
isGiven :: CtEvidence -> Bool
isGiven (Given {}) = True
isGiven (CtGiven {}) = True
isGiven _ = False
isDerived :: CtEvidence -> Bool
isDerived (Derived {}) = True
isDerived _ = False
isDerived (CtDerived {}) = True
isDerived _ = False
canSolve :: CtEvidence -> CtEvidence -> Bool
canSolve :: CtFlavour -> CtFlavour -> 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.
......@@ -1279,13 +1295,13 @@ canSolve :: CtEvidence -> CtEvidence -> Bool
--
-- NB: either (a `canSolve` b) or (b `canSolve` a) must hold
-----------------------------------------
canSolve (Given {}) _ = True
canSolve (Wanted {}) (Derived {}) = True
canSolve (Wanted {}) (Wanted {}) = True
canSolve (Derived {}) (Derived {}) = True -- Derived can't solve wanted/given
canSolve Given _ = True
canSolve Wanted Derived = True
canSolve Wanted Wanted = True
canSolve Derived Derived = True -- Derived can't solve wanted/given
canSolve _ _ = False -- No evidence for a derived, anyway
canRewrite :: CtEvidence -> CtEvidence -> Bool
canRewrite :: CtFlavour -> CtFlavour -> Bool
-- canRewrite ct1 ct2
-- The equality constraint ct1 can be used to rewrite inside ct2
canRewrite = canSolve
......
This diff is collapsed.
......@@ -1056,9 +1056,9 @@ unFlattenWC wc
; return (niFixTvSubst ni_subst, unsolved_can_cts) }
where
solve_one (Wanted { ctev_evar = cv }, tv, ty)
solve_one (CtWanted { ctev_evar = cv }, tv, ty)
= setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty))
solve_one (Derived {}, tv, ty)
solve_one (CtDerived {}, tv, ty)
= setWantedTyBind tv ty
solve_one arg
= pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg
......@@ -1201,8 +1201,8 @@ defaultTyVar the_tv
-- Why not directly derived_pred = mkTcEqPred k default_k?
-- See Note [DefaultTyVar]
derived_cts = mkNonCanonical $
Derived { ctev_wloc = loc
, ctev_pred = derived_pred }
CtDerived { ctev_wloc = loc
, ctev_pred = derived_pred }
; return (unitBag derived_cts) }
......@@ -1302,8 +1302,8 @@ disambigGroup (default_ty:default_tys) group
; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting]
do { let derived_pred = mkTcEqPred (mkTyVarTy the_tv) default_ty
derived_cts = unitBag $ mkNonCanonical $
Derived { ctev_wloc = the_loc
, ctev_pred = derived_pred }
CtDerived { ctev_wloc = the_loc
, ctev_pred = derived_pred }
; traceTcS "disambigGroup (solving) {" $
text "trying to solve constraints along with default equations ..."
......@@ -1366,9 +1366,8 @@ newFlatWanteds orig theta
where
inst_to_wanted loc pty
= do { v <- TcMType.newWantedEvVar pty
; return $
CNonCanonical { cc_ev = Wanted { ctev_evar = v
, ctev_wloc = loc
, ctev_pred = pty }
, cc_depth = 0 } }
; return $ mkNonCanonical $
CtWanted { ctev_evar = v
, ctev_wloc = loc
, ctev_pred = pty } }
\end{code}
......@@ -535,8 +535,8 @@ uType_defer items ty1 ty2
= ASSERT( not (null items) )
do { eqv <- newEq ty1 ty2
; loc <- getCtLoc (TypeEqOrigin (last items))
; let ctev = Wanted { ctev_wloc = loc, ctev_evar = eqv
, ctev_pred = mkTcEqPred ty1 ty2 }
; let ctev = CtWanted { ctev_wloc = loc, ctev_evar = eqv
, ctev_pred = mkTcEqPred ty1 ty2 }
; emitFlat $ mkNonCanonical ctev
-- Error trace only
......
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