Commit 0e022e56 authored by Joachim Breitner's avatar Joachim Breitner

Turn EvTerm (almost) into CoreExpr (#14691)

Ideally, I'd like to do

    type EvTerm = CoreExpr

and the type checker builds the evidence terms as it goes. This failed,
becuase the evidence for `Typeable` refers to local identifiers that are
added *after* the typechecker solves constraints. Therefore, `EvTerm`
stays a data type with two constructors: `EvExpr` for `CoreExpr`
evidence, and `EvTypeable` for the others.

Delted `Note [Memoising typeOf]`, its reference (and presumably
relevance) was removed in 8fa4bf9a.

Differential Revision: https://phabricator.haskell.org/D4341
parent 40c753f1
......@@ -30,7 +30,6 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreOpt ( simpleOptExpr )
import OccurAnal ( occurAnalyseExpr )
import MkCore
......@@ -49,7 +48,6 @@ import Coercion
import TysWiredIn ( typeNatKind, typeSymbolKind )
import Id
import MkId(proxyHashId)
import Class
import Name
import VarSet
import Rules
......@@ -1156,41 +1154,8 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
**********************************************************************-}
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCallStack cs) = dsEvCallStack cs
dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
dsEvTerm (EvLit (EvNum n)) = mkNaturalExpr n
dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; return $ mkCastDs tm' co }
dsEvTerm (EvDFunApp df tys tms)
= do { tms' <- mapM dsEvTerm tms
; return $ Var df `mkTyApps` tys `mkApps` tms' }
-- The use of mkApps here is OK vis-a-vis levity polymorphism because
-- the terms are always evidence variables with types of kind Constraint
dsEvTerm (EvCoercion co) = return (Coercion co)
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
dsEvTerm (EvSelector sel_id tys tms)
= do { tms' <- mapM dsEvTerm tms
; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }
dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
dsEvDelayedError :: Type -> FastString -> CoreExpr
dsEvDelayedError ty msg
= Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
dsEvTerm (EvExpr e) = return e
dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
{-**********************************************************************
* *
......@@ -1312,58 +1277,3 @@ tyConRep tc
; return (Var tc_rep_id) }
| otherwise
= pprPanic "tyConRep" (ppr tc)
{- Note [Memoising typeOf]
~~~~~~~~~~~~~~~~~~~~~~~~~~
See #3245, #9203
IMPORTANT: we don't want to recalculate the TypeRep once per call with
the proxy argument. This is what went wrong in #3245 and #9203. So we
help GHC by manually keeping the 'rep' *outside* the lambda.
-}
{-**********************************************************************
* *
Desugaring EvCallStack evidence
* *
**********************************************************************-}
dsEvCallStack :: EvCallStack -> DsM CoreExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
dsEvCallStack cs = do
df <- getDynFlags
m <- getModule
srcLocDataCon <- dsLookupDataCon srcLocDataConName
let mkSrcLoc l =
liftM (mkCoreConApps srcLocDataCon)
(sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt df (srcSpanStartLine l)
, return $ mkIntExprInt df (srcSpanStartCol l)
, return $ mkIntExprInt df (srcSpanEndLine l)
, return $ mkIntExprInt df (srcSpanEndCol l)
])
emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName
pushCSVar <- dsLookupGlobalId pushCallStackName
let pushCS name loc rest =
mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
let mkPush name loc tm = do
nameExpr <- mkStringExprFS name
locExpr <- mkSrcLoc loc
case tm of
EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
_ -> do tmExpr <- dsEvTerm tm
-- at this point tmExpr :: IP sym CallStack
-- but we need the actual CallStack to pass to pushCS,
-- so we use unwrapIP to strip the dictionary wrapper
-- See Note [Overview of implicit CallStacks]
let ip_co = unwrapIP (exprType tmExpr)
return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))
case cs of
EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
EvCsEmpty -> return emptyCS
......@@ -1053,8 +1053,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
---------
ev_term :: EvTerm -> EvTerm -> Bool
ev_term (EvId a) (EvId b) = a==b
ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b
ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b
ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
ev_term _ _ = False
---------
......
......@@ -471,6 +471,7 @@ Library
TcTypeable
TcType
TcEvidence
TcEvTerm
TcUnify
TcInteract
TcCanonical
......
......@@ -355,13 +355,13 @@ instCallConstraints orig preds
go pred
| Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
= do { co <- unifyType Nothing ty1 ty2
; return (EvCoercion co) }
; return (evCoercion co) }
-- Try short-cut #2
| Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
, tc `hasKey` heqTyConKey
= do { co <- unifyType Nothing ty1 ty2
; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) }
; return (evDFunApp (dataConWrapId heqDataCon) args [evCoercion co]) }
| otherwise
= emitWanted orig pred
......
......@@ -19,6 +19,7 @@ import Type
import TcFlatten
import TcSMonad
import TcEvidence
import TcEvTerm
import Class
import TyCon
import TyCoRep -- cleverly decomposes types, good for completeness checking
......@@ -152,7 +153,7 @@ canClassNC ev cls tys
-- Then we solve the wanted by pushing the call-site
-- onto the newly emitted CallStack
; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvTerm new_ev)
; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
; solveCallStack ev ev_cs
; canClass new_ev cls tys False }
......@@ -171,8 +172,9 @@ solveCallStack ev ev_cs = do
-- We're given ev_cs :: CallStack, but the evidence term should be a
-- dictionary, so we have to coerce ev_cs to a dictionary for
-- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
let ev_tm = mkEvCast (EvCallStack ev_cs) (wrapIP (ctEvPred ev))
setWantedEvBind (ctEvEvId ev) ev_tm
cs_tm <- evCallStack ev_cs
let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
setWantedEvBind (ctEvEvId ev) (EvExpr ev_tm)
canClass :: CtEvidence
-> Class -> [Type]
......@@ -443,7 +445,7 @@ mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]
mk_strict_superclasses rec_clss ev cls tys
| CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
= do { sc_evs <- newGivenEvVars (mk_given_loc loc)
(mkEvScSelectors (EvId evar) cls tys)
(mkEvScSelectors (evId evar) cls tys)
; concatMapM (mk_superclasses rec_clss) sc_evs }
| all noFreeVarsOfType tys
......@@ -992,9 +994,9 @@ can_eq_app ev NomEq s1 t1 s2 t2
co_s = mkTcLRCo CLeft co
co_t = mkTcLRCo CRight co
; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
, EvCoercion co_s )
, evCoercion co_s )
; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
, EvCoercion co_t )
, evCoercion co_t )
; emitWorkNC [evar_t]
; canEqNC evar_s NomEq s1 s2 }
| otherwise -- Can't happen
......@@ -1264,7 +1266,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
-> do { let ev_co = mkCoVarCo evar
; given_evs <- newGivenEvVars loc $
[ ( mkPrimEqPredRole r ty1 ty2
, EvCoercion (mkNthCo i ev_co) )
, evCoercion $ mkNthCo i ev_co )
| (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
, r /= Phantom
, not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
......@@ -1459,7 +1461,7 @@ canEqTyVar ev eq_rel swapped tv1 co1 ps_ty1 xi2 ps_xi2
-- unswapped: tm :: (lhs :: k1) ~ (rhs :: k2)
-- swapped : tm :: (rhs :: k2) ~ (lhs :: k1)
= do { kind_ev_id <- newBoundEvVarId kind_pty
(EvCoercion $
(evCoercion $
if isSwapped swapped
then mkTcSymCo $ mkTcKindCo $ mkTcCoVarCo evar
else mkTcKindCo $ mkTcCoVarCo evar)
......@@ -1476,10 +1478,10 @@ canEqTyVar ev eq_rel swapped tv1 co1 ps_ty1 xi2 ps_xi2
; type_ev <- newGivenEvVar loc $
if isSwapped swapped
then ( mkTcEqPredLikeEv ev rhs' lhs
, EvCoercion $
, evCoercion $
mkTcCoherenceLeftCo (mkTcCoVarCo evar) homo_co )
else ( mkTcEqPredLikeEv ev lhs rhs'
, EvCoercion $
, evCoercion $
mkTcCoherenceRightCo (mkTcCoVarCo evar) homo_co )
-- unswapped: type_ev :: (lhs :: k1) ~ ((rhs |> sym kind_ev_id) :: k1)
-- swapped : type_ev :: ((rhs |> sym kind_ev_id) :: k1) ~ (lhs :: k1)
......@@ -1589,7 +1591,7 @@ canEqReflexive :: CtEvidence -- ty ~ ty
-> TcType -- ty
-> TcS (StopOrContinue Ct) -- always Stop
canEqReflexive ev eq_rel ty
= do { setEvBindIfWanted ev (EvCoercion $
= do { setEvBindIfWanted ev (evCoercion $
mkTcReflCo (eqRelRole eq_rel) ty)
; stopWith ev "Solved by reflexivity" }
......@@ -1843,7 +1845,7 @@ rewriteEvidence old_ev@(CtDerived {}) new_pred _co
-- rewriteEvidence to put the isTcReflCo test first!
-- Why? Because for *Derived* constraints, c, the coercion, which
-- was produced by flattening, may contain suspended calls to
-- (ctEvTerm c), which fails for Derived constraints.
-- (ctEvExpr c), which fails for Derived constraints.
-- (Getting this wrong caused Trac #7384.)
continueWith (old_ev { ctev_pred = new_pred })
......@@ -1856,7 +1858,7 @@ rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred c
; continueWith new_ev }
where
-- mkEvCast optimises ReflCo
new_tm = mkEvCast (EvId old_evar) (tcDowngradeRole Representational
new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational
(ctEvRole ev)
(mkTcSymCo co))
......@@ -1865,8 +1867,8 @@ rewriteEvidence ev@(CtWanted { ctev_dest = dest
= do { mb_new_ev <- newWanted loc new_pred
; MASSERT( tcCoercionRole co == ctEvRole ev )
; setWantedEvTerm dest
(mkEvCast (getEvTerm mb_new_ev)
(tcDowngradeRole Representational (ctEvRole ev) co))
(EvExpr $ mkEvCast (getEvExpr mb_new_ev)
(tcDowngradeRole Representational (ctEvRole ev) co))
; case mb_new_ev of
Fresh new_ev -> continueWith new_ev
Cached _ -> stopWith ev "Cached wanted" }
......@@ -1905,7 +1907,7 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
= continueWith (old_ev { ctev_pred = new_pred })
| CtGiven { ctev_evar = old_evar } <- old_ev
= do { let new_tm = EvCoercion (lhs_co
= do { let new_tm = evCoercion (lhs_co
`mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
`mkTcTransCo` mkTcSymCo rhs_co)
; new_ev <- newGivenEvVar loc' (new_pred, new_tm)
......
......@@ -31,6 +31,7 @@ import TyCon
import Class
import DataCon
import TcEvidence
import TcEvTerm
import HsExpr ( UnboundVar(..) )
import HsBinds ( PatSynBind(..) )
import Name
......@@ -806,16 +807,16 @@ addDeferredBinding ctxt err ct
; let err_msg = pprLocErrMsg err
err_fs = mkFastString $ showSDoc dflags $
err_msg $$ text "(deferred type error)"
err_tm = EvDelayedError pred err_fs
err_tm = evDelayedError pred err_fs
ev_binds_var = cec_binds ctxt
; case dest of
EvVarDest evar
-> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
-> addTcEvBind ev_binds_var $ mkWantedEvBind evar (EvExpr err_tm)
HoleDest hole
-> do { -- See Note [Deferred errors for coercion holes]
let co_var = coHoleCoVar hole
; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
; addTcEvBind ev_binds_var $ mkWantedEvBind co_var (EvExpr err_tm)
; fillCoercionHole hole (mkTcCoVarCo co_var) }}
| otherwise -- Do not set any evidence for Given/Derived
......
-- (those who have too heavy dependencies for TcEvidence)
module TcEvTerm
( evDelayedError, evCallStack )
where
import GhcPrelude
import FastString
import Type
import CoreSyn
import MkCore
import Literal ( Literal(..) )
import TcEvidence
import HscTypes
import DynFlags
import Name
import Module
import CoreUtils
import PrelNames
import SrcLoc
-- Used with Opt_DeferTypeErrors
-- See Note [Deferring coercion errors to runtime]
-- in TcSimplify
evDelayedError :: Type -> FastString -> EvExpr
evDelayedError ty msg
= Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
-- Dictionary for CallStack implicit parameters
evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
EvCallStack -> m EvExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
evCallStack cs = do
df <- getDynFlags
m <- getModule
srcLocDataCon <- lookupDataCon srcLocDataConName
let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt df (srcSpanStartLine l)
, return $ mkIntExprInt df (srcSpanStartCol l)
, return $ mkIntExprInt df (srcSpanEndLine l)
, return $ mkIntExprInt df (srcSpanEndCol l)
]
emptyCS <- Var <$> lookupId emptyCallStackName
pushCSVar <- lookupId pushCallStackName
let pushCS name loc rest =
mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
let mkPush name loc tm = do
nameExpr <- mkStringExprFS name
locExpr <- mkSrcLoc loc
-- at this point tm :: IP sym CallStack
-- but we need the actual CallStack to pass to pushCS,
-- so we use unwrapIP to strip the dictionary wrapper
-- See Note [Overview of implicit CallStacks]
let ip_co = unwrapIP (exprType tm)
return (pushCS nameExpr locExpr (Cast tm ip_co))
case cs of
EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
EvCsEmpty -> return emptyCS
This diff is collapsed.
......@@ -1644,7 +1644,7 @@ tryFill ev tv rhs
setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()
setReflEvidence ev eq_rel rhs
= setEvBindIfWanted ev (EvCoercion refl_co)
= setEvBindIfWanted ev (evCoercion refl_co)
where
refl_co = mkTcReflCo (eqRelRole eq_rel) rhs
......
......@@ -71,6 +71,7 @@ import Bag
import Outputable
import Util
import UniqFM
import CoreSyn
import Control.Monad
import Data.List ( partition )
......@@ -333,12 +334,14 @@ zonkEvBndr env var
zonkTcTypeToType env var_ty
; return (setVarType var ty) }
{-
zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
zonkEvVarOcc env v
| isCoVar v
= EvCoercion <$> zonkCoVarOcc env v
| otherwise
= return (EvId $ zonkIdOcc env v)
-}
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX = mapAccumLM zonkTyBndrX
......@@ -1418,39 +1421,70 @@ zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
-}
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
zonkEvVarOcc env v
zonkEvTerm env (EvCoercion co) = do { co' <- zonkCoToCo env co
; return (EvCoercion co') }
zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm
; co' <- zonkCoToCo env co
; return (mkEvCast tm' co') }
zonkEvTerm _ (EvLit l) = return (EvLit l)
zonkEvTerm env (EvExpr e) =
EvExpr <$> zonkCoreExpr env e
zonkEvTerm env (EvTypeable ty ev) =
do { ev' <- zonkEvTypeable env ev
; ty' <- zonkTcTypeToType env ty
; return (EvTypeable ty' ev') }
zonkEvTerm env (EvCallStack cs)
= case cs of
EvCsEmpty -> return (EvCallStack cs)
EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
; return (EvCallStack (EvCsPushCall n l tm')) }
zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
; return (EvSuperClass d' n) }
zonkEvTerm env (EvDFunApp df tys tms)
= do { tys' <- zonkTcTypeToTypes env tys
; tms' <- mapM (zonkEvTerm env) tms
; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
zonkEvTerm env (EvDelayedError ty msg)
= do { ty' <- zonkTcTypeToType env ty
; return (EvDelayedError ty' msg) }
zonkEvTerm env (EvSelector sel_id tys tms)
= do { sel_id' <- zonkIdBndr env sel_id
; tys' <- zonkTcTypeToTypes env tys
; tms' <- mapM (zonkEvTerm env) tms
; return (EvSelector sel_id' tys' tms') }
EvTypeable <$> zonkTcTypeToType env ty <*> zonkEvTypeable env ev
zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
zonkCoreExpr env (Var v)
| isCoVar v
= Coercion <$> zonkCoVarOcc env v
| otherwise
= return (Var $ zonkIdOcc env v)
zonkCoreExpr _ (Lit l)
= return $ Lit l
zonkCoreExpr env (Coercion co)
= Coercion <$> zonkCoToCo env co
zonkCoreExpr env (Type ty)
= Type <$> zonkTcTypeToType env ty
zonkCoreExpr env (Cast e co)
= Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
zonkCoreExpr env (Tick t e)
= Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?
zonkCoreExpr env (App e1 e2)
= App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
zonkCoreExpr env (Lam v e)
= do v' <- zonkIdBndr env v
let env1 = extendIdZonkEnv1 env v'
Lam v' <$> zonkCoreExpr env1 e
zonkCoreExpr env (Let bind e)
= do (env1, bind') <- zonkCoreBind env bind
Let bind'<$> zonkCoreExpr env1 e
zonkCoreExpr env (Case scrut b ty alts)
= do scrut' <- zonkCoreExpr env scrut
ty' <- zonkTcTypeToType env ty
b' <- zonkIdBndr env b
let env1 = extendIdZonkEnv1 env b'
alts' <- mapM (zonkCoreAlt env1) alts
return $ Case scrut' b' ty' alts'
zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
zonkCoreAlt env (dc, pats, rhs)
= do pats' <- mapM (zonkIdBndr env) pats
let env1 = extendZonkEnv env pats'
rhs' <- zonkCoreExpr env1 rhs
return $ (dc, pats', rhs')
zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
zonkCoreBind env (NonRec v e)
= do v' <- zonkIdBndr env v
e' <- zonkCoreExpr env e
let env1 = extendIdZonkEnv1 env v'
return (env1, NonRec v' e')
zonkCoreBind env (Rec pairs)
= do (env1, pairs') <- fixM go
return (env1, Rec pairs')
where
go ~(_, new_pairs) = do
let env1 = extendIdZonkEnvRec env (map fst new_pairs)
pairs' <- mapM (zonkCorePair env1) pairs
return (env1, pairs')
zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
zonkEvTypeable env (EvTypeableTyCon tycon e)
......@@ -1507,7 +1541,7 @@ zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
; term' <- case getEqPredTys_maybe (idType var') of
Just (r, ty1, ty2) | ty1 `eqType` ty2
-> return (EvCoercion (mkTcReflCo r ty1))
-> return (EvExpr (evCoercion (mkTcReflCo r ty1)))
_other -> zonkEvTerm env term
; return (bind { eb_lhs = var', eb_rhs = term' }) }
......
......@@ -1034,7 +1034,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
; sc_ev_id <- newEvVar sc_pred
; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id (EvExpr sc_ev_tm)
; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
sc_top_id = mkLocalId sc_top_name sc_top_ty
export = ABE { abe_wrap = idHsWrapper
......
This diff is collapsed.
......@@ -203,11 +203,11 @@ cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
; return (implic { ic_wanted = inner_wanted' }) }
-- | Emits a new Wanted. Deals with both equalities and non-equalities.
emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
emitWanted :: CtOrigin -> TcPredType -> TcM EvExpr
emitWanted origin pty
= do { ev <- newWanted origin Nothing pty
; emitSimple $ mkNonCanonical ev
; return $ ctEvTerm ev }
; return $ ctEvExpr ev }
-- | Emits a new equality constraint
emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
......
......@@ -117,7 +117,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
(mkTyVarBinders Inferred univ_tvs
, req_theta, ev_binds, req_dicts)
(mkTyVarBinders Inferred ex_tvs
, mkTyVarTys ex_tvs, prov_theta, map EvId filtered_prov_dicts)
, mkTyVarTys ex_tvs, prov_theta, map evId filtered_prov_dicts)
(map nlHsVar args, map idType args)
pat_ty rec_fields }
......@@ -540,7 +540,7 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name
-> Bool -- ^ Whether infix
-> LPat GhcTc -- ^ Pattern of the PatSyn
-> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
-> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
-> ([TcTyVarBinder], [TcType], [PredType], [EvExpr])
-> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and
-- types
-> TcType -- ^ Pattern type
......@@ -626,7 +626,7 @@ tc_patsyn_finish lname dir is_infix lpat'
tcPatSynMatcher :: Located Name
-> LPat GhcTc
-> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
-> ([TcTyVar], [TcType], ThetaType, [EvTerm])
-> ([TcTyVar], [TcType], ThetaType, [EvExpr])
-> ([LHsExpr GhcTcId], [TcType])
-> TcType
-> TcM ((Id, Bool), LHsBinds GhcTc)
......
......@@ -70,7 +70,7 @@ import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
import TcMType ( TcTyVar, TcType )
import TcEnv ( TcTyThing )
import TcEvidence ( TcCoercion, CoercionHole
, EvTerm, EvBind, mkGivenEvBind )
, EvExpr, EvBind, mkGivenEvBind )
import TcRnTypes ( CtEvidence(..) )
import Var ( EvVar )
......@@ -170,7 +170,7 @@ newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
-- | Create a new given constraint, with the supplied evidence. This
-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
-- will panic.
newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence
newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
newGiven loc pty evtm = do
new_ev <- newEvVar pty
setEvBind $ mkGivenEvBind new_ev evtm
......
......@@ -78,7 +78,7 @@ module TcRnTypes(
mkNonCanonical, mkNonCanonicalCt, mkGivens,
mkIrredCt, mkInsolubleCt,
ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
ctEvTerm, ctEvCoercion, ctEvEvId,
ctEvExpr, ctEvCoercion, ctEvEvId,
tyCoVarsOfCt, tyCoVarsOfCts,
tyCoVarsOfCtList, tyCoVarsOfCtsList,
......@@ -2680,9 +2680,9 @@ ctEvEqRel = predTypeEqRel . ctEvPred
ctEvRole :: CtEvidence -> Role
ctEvRole = eqRelRole . ctEvEqRel
ctEvTerm :: CtEvidence -> EvTerm
ctEvTerm ev@(CtWanted { ctev_dest = HoleDest _ }) = EvCoercion $ ctEvCoercion ev
ctEvTerm ev = EvId (ctEvEvId ev)
ctEvExpr :: CtEvidence -> EvExpr
ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) = evCoercion $ ctEvCoercion ev
ctEvExpr ev = evId (ctEvEvId ev)
-- Always returns a coercion whose type is precisely ctev_pred of the CtEvidence.
-- See also Note [Given in ctEvCoercion]
......
......@@ -26,7 +26,7 @@ module TcSMonad (
wrapErrTcS, wrapWarnTcS,
-- Evidence creation and transformation
MaybeNew(..), freshGoals, isFresh, getEvTerm,
MaybeNew(..), freshGoals, isFresh, getEvExpr,
newTcEvBinds,
newWantedEq, emitNewWantedEq,
......@@ -143,6 +143,7 @@ import TyCon
import TcErrors ( solverDepthErrorTcS )
import Name
import Module ( HasModule, getModule )
import RdrName ( GlobalRdrEnv, GlobalRdrElt )
import qualified RnEnv as TcM
import Var
......@@ -2385,6 +2386,12 @@ instance MonadFail.MonadFail TcS where
instance MonadUnique TcS where
getUniqueSupplyM = wrapTcS getUniqueSupplyM
instance HasModule TcS where
getModule = wrapTcS getModule
instance MonadThings TcS where
lookupThing n = wrapTcS (lookupThing n)
-- Basic functionality
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
wrapTcS :: TcM a -> TcS a
......@@ -2869,7 +2876,7 @@ newFlattenSkolem flav loc tc xis
-- Construct the Refl evidence
; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)
co = mkNomReflCo fam_ty
; ev <- newGivenEvVar loc (pred, EvCoercion co)
; ev <- newGivenEvVar loc (pred, evCoercion co)
; return (ev, co, fsk) }
| otherwise -- Generate a [WD] for both Wanted and Derived
......@@ -2981,7 +2988,7 @@ tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs
-- Creating and setting evidence variables and CtFlavors
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
data MaybeNew = Fresh CtEvidence | Cached EvTerm
data MaybeNew = Fresh CtEvidence | Cached EvExpr
isFresh :: MaybeNew -> Bool
isFresh (Fresh {}) = True
......@@ -2990,9 +2997,9 @@ isFresh (Cached {}) = False
freshGoals :: [MaybeNew] -> [CtEvidence]
freshGoals mns = [ ctev | Fresh ctev <- mns ]
getEvTerm :: MaybeNew -> EvTerm
getEvTerm (Fresh ctev) = ctEvTerm ctev
getEvTerm (Cached evt) = evt
getEvExpr :: MaybeNew -> EvExpr
getEvExpr (Fresh ctev) = ctEvExpr ctev
getEvExpr (Cached evt) = evt
setEvBind :: EvBind -> TcS ()
setEvBind ev_bind
......@@ -3031,11 +3038,11 @@ setWantedEvTerm (EvVarDest ev) tm = setWantedEvBind ev tm
setWantedEvBind :: EvVar -> EvTerm -> TcS ()
setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm)
setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
setEvBindIfWanted :: CtEvidence -> EvExpr -> TcS ()
setEvBindIfWanted ev tm
= case ev of
CtWanted { ctev_dest = dest }
-> setWantedEvTerm dest tm
-> setWantedEvTerm dest (EvExpr tm)
_ -> return ()
newTcEvBinds :: TcS EvBindsVar
......@@ -3044,7 +3051,7 @@ newTcEvBinds = wrapTcS TcM.newTcEvBinds
newEvVar :: TcPredType -> TcS EvVar
newEvVar pred = wrapTcS (TcM.newEvVar pred)