Commit 1a6ab644 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Remove cc_ty from CIrredCan and cc_hole_ty from CHoleCan

A simple refactoring with no complicated fiddling.
parent d30b9cf4
......@@ -517,12 +517,13 @@ hasEqualities givens = any (has_eq . evVarPred) givens
---------------- Getting free tyvars -------------------------
tyVarsOfCt :: Ct -> TcTyVarSet
-- NB: the
tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CHoleCan { cc_hole_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl)
tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
tyVarsOfCts :: Cts -> TcTyVarSet
tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
......@@ -551,18 +552,19 @@ tidyCt :: TidyEnv -> Ct -> Ct
-- Also converts it to non-canonical
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)
CHoleCan { cc_ev = ev }
-> ct { cc_ev = tidy_ev env ev }
_ -> CNonCanonical { cc_ev = tidy_ev env (cc_ev ct)
, cc_loc = cc_loc ct }
where
tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence
tidy_ev :: 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_pred = pred })
tidy_ev env ctev@(CtGiven { ctev_pred = pred })
= ctev { ctev_pred = tidyType env pred }
tidy_flavor env ctev@(CtWanted { ctev_pred = pred })
tidy_ev env ctev@(CtWanted { ctev_pred = pred })
= ctev { ctev_pred = tidyType env pred }
tidy_flavor env ctev@(CtDerived { ctev_pred = pred })
tidy_ev env ctev@(CtDerived { ctev_pred = pred })
= ctev { ctev_pred = tidyType env pred }
tidyEvVar :: TidyEnv -> EvVar -> EvVar
......
......@@ -192,12 +192,10 @@ canonicalize (CFunEqCan { cc_loc = d
canEqLeafFunEq d ev (fn,xis1) xi2
canonicalize (CIrredEvCan { cc_ev = ev
, cc_loc = d
, cc_ty = xi })
= canIrred d ev xi
canonicalize ct@(CHoleCan {})
= do { emitInsoluble ct
; return Stop }
, cc_loc = d })
= canIrred d ev
canonicalize (CHoleCan { cc_ev = ev, cc_loc = d })
= canHole d ev
canEvNC :: CtLoc -> CtEvidence -> TcS StopOrContinue
-- Called only for non-canonical EvVars
......@@ -205,8 +203,8 @@ canEvNC d ev
= case classifyPredType (ctEvPred ev) of
ClassPred cls tys -> canClassNC d ev cls tys
EqPred ty1 ty2 -> canEqNC d ev ty1 ty2
IrredPred ev_ty -> canIrred d ev ev_ty
TuplePred tys -> canTuple d ev tys
IrredPred {} -> canIrred d ev
\end{code}
......@@ -388,24 +386,35 @@ is_improvement_pty ty = go (classifyPredType ty)
\begin{code}
canIrred :: CtLoc -> CtEvidence -> TcType -> TcS StopOrContinue
canIrred :: CtLoc -> CtEvidence -> TcS StopOrContinue
-- Precondition: ty not a tuple and no other evidence form
canIrred d ev ty
= do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty)
canIrred d ev
= do { let ty = ctEvPred ev
; traceTcS "can_pred" (text "IrredPred = " <+> ppr ty)
; (xi,co) <- flatten d FMFullFlatten ev ty -- co :: xi ~ ty
; let no_flattening = xi `eqType` ty
-- In this particular case it is not safe to
-- say 'isTcReflCo' because the new constraint may
-- be reducible!
-- We can't use isTcReflCo, because even if the coercion is
-- Refl, the output type might have had a substitution
-- applied to it. For example 'a' might now be 'C b'
; if no_flattening then
continueWith $
CIrredEvCan { cc_ev = ev, cc_loc = d }
else do
{ mb <- rewriteCtFlavor ev xi co
; case mb of
Just new_ev -> canEvNC d new_ev -- Re-classify and try again
Nothing -> return Stop } } -- Found a cached copy
canHole :: CtLoc -> CtEvidence -> TcS StopOrContinue
canHole d ev
= do { let ty = ctEvPred ev
; (xi,co) <- flatten d FMFullFlatten ev ty -- co :: xi ~ ty
; mb <- rewriteCtFlavor ev xi co
; case mb of
Just new_ev
| no_flattening
-> continueWith $
CIrredEvCan { cc_ev = new_ev, cc_ty = xi, cc_loc = d }
| otherwise
-> canEvNC d new_ev
Nothing -> return Stop }
Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d})
Nothing -> return () -- Found a cached copy; won't happen
; return Stop }
\end{code}
%************************************************************************
......
......@@ -493,7 +493,7 @@ mkHoleError ctxt ct@(CHoleCan {})
= do { let tyvars = varSetElems (tyVarsOfCt ct)
tyvars_msg = map loc_msg tyvars
msg = (text "Found hole" <+> quotes (text "_")
<+> text "with type") <+> pprType (cc_hole_ty ct)
<+> text "with type") <+> pprType (ctEvPred (cc_ev ct))
$$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
; (ctxt, binds_doc) <- relevantBindings ctxt ct
; mkErrorMsg ctxt ct (msg $$ binds_doc) }
......
......@@ -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 ty ev, cc_hole_ty = ty, cc_loc = loc }
; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc }
; traceTc "tcExpr.HsHole emitting" (ppr can)
; emitInsoluble can
; tcWrapResult (HsVar ev) ty res_ty }
......
......@@ -714,9 +714,9 @@ doInteractWithInert inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyarg
-- we can rewrite them. We can never improve using this:
-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
-- mean that (ty1 ~ ty2)
doInteractWithInert (CIrredEvCan { cc_ev = ifl, cc_ty = ty1 })
workItem@(CIrredEvCan { cc_ty = ty2 })
| ty1 `eqType` ty2
doInteractWithInert (CIrredEvCan { cc_ev = ifl })
workItem@(CIrredEvCan { cc_ev = wfl })
| ctEvPred ifl `eqType` ctEvPred wfl
= solveOneFromTheOther "Irred/Irred" ifl workItem
doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1
......
......@@ -727,13 +727,13 @@ variables.
\begin{code}
zonkCt :: Ct -> TcM Ct
zonkCt ct@(CHoleCan { cc_ev = ev })
= do { ev' <- zonkCtEvidence ev
; return $ ct { cc_ev = ev' } }
zonkCt ct
| isHoleCt ct = do { fl' <- zonkCtEvidence (cc_ev ct)
; return $ ct { cc_ev = fl' } }
| otherwise = do { fl' <- zonkCtEvidence (cc_ev ct)
; return $
CNonCanonical { cc_ev = fl'
, cc_loc = cc_loc ct } }
= do { fl' <- zonkCtEvidence (cc_ev ct)
; return (CNonCanonical { cc_ev = fl'
, cc_loc = cc_loc ct }) }
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
......
......@@ -530,7 +530,9 @@ a bit complicated:
let x = 3 in
proc y -> (proc z -> e1) -< e2
Here, x and z are in scope in e1, but y is not. We implement this by
Here, x and z are in scope in e1, but y is not.
We implement this by
recording the environment when passing a proc (using newArrowScope),
and returning to that (using escapeArrowScope) on the left of -< and the
head of (|..|).
......@@ -860,7 +862,8 @@ data Ct
| CIrredEvCan { -- These stand for yet-unknown predicates
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_ty :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin)
-- In CIrredEvCan, the ctev_pred of the evidence is flat
-- and hence it may only be of the form (tv xi1 xi2 ... xin)
-- 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.
......@@ -898,9 +901,8 @@ data Ct
}
| CHoleCan {
cc_ev :: CtEvidence,
cc_hole_ty :: TcTauType, -- Not a Xi! See same not as above
cc_loc :: CtLoc
cc_ev :: CtEvidence,
cc_loc :: CtLoc
}
\end{code}
......
......@@ -867,7 +867,7 @@ lookupInInertCans ics pty
IrredPred {} -> findEvidence (\ct -> ctEvPred ct `eqType` pty) (inert_irreds ics)
_other -> Nothing -- NB: No caching for IPs
_other -> Nothing -- NB: No caching for IPs or holes
\end{code}
......
......@@ -195,17 +195,6 @@ calcClassCycles cls
expandTheta _ _ [] = id
expandTheta seen path (pred:theta) = expandType seen path pred . expandTheta seen path theta
{-
expandTree seen path (ClassPred cls tys)
| cls `elemUniqSet` seen =
| otherwise = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path)
(substTysWith (classTyVars cls) tys (classSCTheta cls))
expandTree seen path (TuplePred ts) = flip (foldr (expandTree seen path)) ts
expandTree _ _ (EqPred _ _) = id
expandTree _ _ (IPPred _ _) = id
expandTree seen path (IrredPred pred) = expandType seen path pred
-}
expandType seen path (TyConApp tc tys)
-- Expand unsaturated classes to their superclass theta if they are yet unseen.
-- If they have already been seen then we have detected an error!
......
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