module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds
) where
#include "HsVersions.h"
import DsExpr( dsLExpr )
import Match( matchWrapper )
import DsMonad
import DsGRHSs
import DsUtils
import HsSyn
import CoreSyn
import Literal ( Literal(MachStr) )
import CoreSubst
import OccurAnal ( occurAnalyseExpr )
import MkCore
import CoreUtils
import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
import UniqSupply
import Digraph
import Module
import PrelNames
import TysPrim ( mkProxyPrimTy )
import TyCon ( isTupleTyCon, tyConDataCons_maybe
, tyConName, isPromotedTyCon, isPromotedDataCon )
import TcEvidence
import TcType
import Type
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
import Id
import MkId(proxyHashId)
import Class
import DataCon ( dataConWorkId )
import Name
import MkId ( seqId )
import IdInfo ( IdDetails(..) )
import Var
import VarSet
import Rules
import VarEnv
import Outputable
import SrcLoc
import Maybes
import OrdList
import Bag
import BasicTypes hiding ( TopLevel )
import DynFlags
import FastString
import ErrUtils( MsgDoc )
import ListSetOps( getNth )
import Util
import Control.Monad( when )
import MonadUtils
import Control.Monad(liftM)
import Fingerprint(Fingerprint(..), fingerprintString)
dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds binds = ds_lhs_binds binds
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
; return (fromOL binds') }
ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
; return (foldBag appOL id nilOL ds_bs) }
dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
= do { dflags <- getDynFlags
; core_expr <- dsLExpr expr
; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
| otherwise = var
; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick
, fun_infix = inf })
= do { dflags <- getDynFlags
; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; let body' = mkOptTickBox tick body
; rhs <- dsHsWrapper co_fn (mkLams args body')
;
return (unitOL (makeCorePair dflags fun False 0 rhs)) }
dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
, pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
; let body' = mkOptTickBox rhs_tick body_expr
; sel_binds <- mkSelectorBinds var_ticks pat body'
; return (toOL sel_binds) }
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
= do { dflags <- getDynFlags
; bind_prs <- ds_lhs_binds binds
; let core_bind = Rec (fromOL bind_prs)
; ds_binds <- dsTcEvBinds ev_binds
; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
Var local
; (spec_binds, rules) <- dsSpecs rhs prags
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
; return (main_bind `consOL` spec_binds) }
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
, abs_binds = binds })
= do { dflags <- getDynFlags
; bind_prs <- ds_lhs_binds binds
; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
| (lcl_id, rhs) <- fromOL bind_prs ]
locals = map abe_mono exports
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
; ds_binds <- dsTcEvBinds ev_binds
; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
tup_expr
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
= do { tup_id <- newSysLocalDs tup_ty
; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
mkTupleSelector locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = (global `setInlinePragma` defaultInlinePragma)
`addIdSpecialisations` rules
; return ((global', rhs) `consOL` spec_binds) }
; export_binds_s <- mapM mk_bind exports
; return ((poly_tup_id, poly_tup_rhs) `consOL`
concatOL export_binds_s) }
where
inline_env :: IdEnv Id
inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
| ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
, let prag = idInlinePragma gbl_id ]
add_inline :: Id -> Id
add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair dflags gbl_id is_default_method dict_arity rhs
| is_default_method
= (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
| DFunId _ is_newtype <- idDetails gbl_id
= (mk_dfun_w_stuff is_newtype, rhs)
| otherwise
= case inlinePragmaSpec inline_prag of
EmptyInlineSpec -> (gbl_id, rhs)
NoInline -> (gbl_id, rhs)
Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
Inline -> inline_pair
where
inline_prag = idInlinePragma gbl_id
inlinable_unf = mkInlinableUnfolding dflags rhs
inline_pair
| Just arity <- inlinePragmaSat inline_prag
, let real_arity = dict_arity + arity
= ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
, etaExpand real_arity rhs)
| otherwise
= pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
(gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
mk_dfun_w_stuff is_newtype
| is_newtype
= gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs
`setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise
= gbl_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dfun_constr dfun_args
`setInlinePragma` dfunInlinePragma
(dfun_bndrs, dfun_body) = collectBinders (simpleOptExpr rhs)
(dfun_con, dfun_args) = collectArgs dfun_body
dfun_constr | Var id <- dfun_con
, DataConWorkId con <- idDetails id
= con
| otherwise = pprPanic "makeCorePair: dfun" (ppr rhs)
dictArity :: [Var] -> Arity
dictArity dicts = count isId dicts
dsSpecs :: CoreExpr
-> TcSpecPrags
-> DsM ( OrdList (Id,CoreExpr)
, [CoreRule] )
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
= do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
dsSpec :: Maybe CoreExpr
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| isJust (isClassOpId_maybe poly_id)
= putSrcSpanDs loc $
do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
<+> quotes (ppr poly_id))
; return Nothing }
| no_act_spec && isNeverActive rule_act
= putSrcSpanDs loc $
do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
<+> quotes (ppr poly_id))
; return Nothing }
| otherwise
= putSrcSpanDs loc $
do { uniq <- newUnique
; let poly_name = idName poly_id
spec_occ = mkSpecOcc (getOccName poly_name)
spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
; (bndrs, ds_lhs) <- liftM collectBinders
(dsHsWrapper spec_co (Var poly_id))
; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
;
case decomposeRuleLhs bndrs ds_lhs of {
Left msg -> do { warnDs msg; return Nothing } ;
Right (rule_bndrs, _fn, args) -> do
{ dflags <- getDynFlags
; let fn_unf = realIdUnfolding poly_id
unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkRule False is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
rule_bndrs args
(mkVarApps (Var spec_id) bndrs)
; spec_rhs <- dsHsWrapper spec_co poly_rhs
; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
(warnDs (specOnInline poly_name))
; return (Just (unitOL (spec_id, spec_rhs), rule))
} } }
where
is_local_id = isJust mb_poly_rhs
poly_rhs | Just rhs <- mb_poly_rhs
= rhs
| Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
= unfolding
| otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
id_inl = idInlinePragma poly_id
inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
| not is_local_id
, isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
| otherwise = id_inl
spec_prag_act = inlinePragmaActivation spec_inl
no_act_spec = case inlinePragmaSpec spec_inl of
NoInline -> isNeverActive spec_prag_act
_ -> isAlwaysActive spec_prag_act
rule_act | no_act_spec = inlinePragmaActivation id_inl
| otherwise = spec_prag_act
specOnInline :: Name -> MsgDoc
specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
<+> quotes (ppr f)
decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
decomposeRuleLhs orig_bndrs orig_lhs
| not (null unbound)
= Left (vcat (map dead_msg unbound))
| Var fn_var <- fun
, not (fn_var `elemVarSet` orig_bndr_set)
=
Right (bndrs1, fn_var, args)
| Case scrut bndr ty [(DEFAULT, _, body)] <- fun
, isDeadBinder bndr
, let args' = [Type (idType bndr), Type ty, scrut, body]
= Right (bndrs1, seqId, args' ++ args)
| otherwise
= Left bad_shape_msg
where
lhs1 = drop_dicts orig_lhs
lhs2 = simpleOptExpr lhs1
(fun,args) = collectArgs lhs2
lhs_fvs = exprFreeVars lhs2
unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
bndrs1 = orig_bndrs ++ extra_dict_bndrs
orig_bndr_set = mkVarSet orig_bndrs
extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
| d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs)
, isDictId d ]
bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
, text "Orig lhs:" <+> ppr orig_lhs])
dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
, ptext (sLit "is not bound in RULE lhs")])
2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
, text "Orig lhs:" <+> ppr orig_lhs
, text "optimised lhs:" <+> ppr lhs2 ])
pp_bndr bndr
| isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
| Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
| otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
drop_dicts :: CoreExpr -> CoreExpr
drop_dicts e
= wrap_lets needed bnds body
where
needed = orig_bndr_set `minusVarSet` exprFreeVars body
(bnds, body) = split_lets (occurAnalyseExpr e)
split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
split_lets e
| Let (NonRec d r) body <- e
, isDictId d
, (bs, body') <- split_lets body
= ((d,r):bs, body')
| otherwise
= ([], e)
wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets _ [] body = body
wrap_lets needed ((d, r) : bs) body
| rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body)
| otherwise = wrap_lets needed bs body
where
rhs_fvs = exprFreeVars r
needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
dsHsWrapper WpHole e = return e
dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
; dsHsWrapper c1 e1 }
dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
; e1 <- dsHsWrapper c1 (Var x)
; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
; return (Lam x e2) }
dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
dsTcCoercion co (mkCast e)
dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm)
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
where
ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
where
edges :: [(EvBind, EvVar, [EvVar])]
edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCast tm' }
dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
; return (Var df `mkTyApps` tys `mkApps` tms') }
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v)
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= do { tm' <- dsEvTerm v
; let scrut_ty = exprType tm'
(tc, tys) = splitTyConApp scrut_ty
Just [dc] = tyConDataCons_maybe tc
xs = mkTemplateLocals tys
the_x = getNth xs n
; ASSERT( isTupleTyCon tc )
return $
Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
dsEvTerm (EvTupleMk tms)
= do { tms' <- mapM dsEvTerm tms
; let tys = map exprType tms'
; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }
where
dc = tupleCon ConstraintTuple (length tms)
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
sc_sel_id = classSCSelId cls n
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
where
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where
errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
dsEvTerm (EvLit l) =
case l of
EvNum n -> mkIntegerExpr n
EvStr s -> mkStringExprFS s
dsEvTerm (EvTypeable ev) = dsEvTypeable ev
dsEvTypeable :: EvTypeable -> DsM CoreExpr
dsEvTypeable ev =
do tyCl <- dsLookupTyCon typeableClassName
typeRepTc <- dsLookupTyCon typeRepTyConName
let tyRepType = mkTyConApp typeRepTc []
(ty, rep) <-
case ev of
EvTypeableTyCon tc ks ts ->
do ctr <- dsLookupGlobalId mkPolyTyConAppName
mkTyCon <- dsLookupGlobalId mkTyConName
dflags <- getDynFlags
let mkRep cRep kReps tReps =
mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps
, mkListExpr tyRepType tReps ]
let kindRep k =
case splitTyConApp_maybe k of
Nothing -> panic "dsEvTypeable: not a kind constructor"
Just (kc,ks) ->
do kcRep <- tyConRep dflags mkTyCon kc
reps <- mapM kindRep ks
return (mkRep kcRep [] reps)
tcRep <- tyConRep dflags mkTyCon tc
kReps <- mapM kindRep ks
tReps <- mapM (getRep tyCl) ts
return ( mkTyConApp tc (ks ++ map snd ts)
, mkRep tcRep kReps tReps
)
EvTypeableTyApp t1 t2 ->
do e1 <- getRep tyCl t1
e2 <- getRep tyCl t2
ctr <- dsLookupGlobalId mkAppTyName
return ( mkAppTy (snd t1) (snd t2)
, mkApps (Var ctr) [ e1, e2 ]
)
EvTypeableTyLit ty ->
do str <- case (isNumLitTy ty, isStrLitTy ty) of
(Just n, _) -> return (show n)
(_, Just n) -> return (show n)
_ -> panic "dsEvTypeable: malformed TyLit evidence"
ctr <- dsLookupGlobalId typeLitTypeRepName
tag <- mkStringExpr str
return (ty, mkApps (Var ctr) [ tag ])
repName <- newSysLocalDs tyRepType
let proxyT = mkProxyPrimTy (typeKind ty) ty
method = bindNonRec repName rep
$ mkLams [mkWildValBinder proxyT] (Var repName)
return $ mkCast method $ mkSymCo $ getTypeableCo tyCl ty
where
getTypeableCo tc t =
case instNewTyCon_maybe tc [typeKind t, t] of
Just (_,co) -> co
_ -> panic "Class `Typeable` is not a `newtype`."
getRep tc (ev,t) =
do typeableExpr <- dsEvTerm ev
let co = getTypeableCo tc t
method = mkCast typeableExpr co
proxy = mkTyApps (Var proxyHashId) [typeKind t, t]
return (mkApps method [proxy])
tyConRep dflags mkTyCon tc =
do pkgStr <- mkStringExprFS pkg_fs
modStr <- mkStringExprFS modl_fs
nameStr <- mkStringExprFS name_fs
return (mkApps (Var mkTyCon) [ int64 high, int64 low
, pkgStr, modStr, nameStr
])
where
tycon_name = tyConName tc
modl = nameModule tycon_name
pkg = modulePackageKey modl
modl_fs = moduleNameFS (moduleName modl)
pkg_fs = packageKeyFS pkg
name_fs = occNameFS (nameOccName tycon_name)
hash_name_fs
| isPromotedTyCon tc = appendFS (mkFastString "$k") name_fs
| isPromotedDataCon tc = appendFS (mkFastString "$c") name_fs
| otherwise = name_fs
hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]
Fingerprint high low = fingerprintString hashThis
int64
| wORD_SIZE dflags == 4 = mkWord64LitWord64
| otherwise = mkWordLit dflags . fromIntegral
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
dsTcCoercion co thing_inside
= do { us <- newUniqueSupply
; let eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
(uniqsFromSupply us)
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
result_expr = thing_inside (ds_tc_coercion subst co)
result_ty = exprType result_expr
; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
where
mk_co_var :: Id -> Unique -> (Id, Id)
mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
where
eq_nm = idName eqv
occ = nameOccName eq_nm
loc = nameSrcSpan eq_nm
ty = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2
(ty1, ty2) = getEqPredTys (evVarPred eqv)
wrap_in_case result_ty (eqv, cov) body
= case getEqPredRole (evVarPred eqv) of
Nominal -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)]
Phantom -> panic "wrap_in_case/phantom"
ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
ds_tc_coercion subst tc_co
= go tc_co
where
go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)
go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)
go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
go (TcAxiomInstCo ax ind cos)
= AxiomInstCo ax ind (map go cos)
go (TcPhantomCo ty1 ty2) = UnivCo (fsLit "ds_tc_coercion") Phantom ty1 ty2
go (TcSymCo co) = mkSymCo (go co)
go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
go (TcNthCo n co) = mkNthCo n (go co)
go (TcLRCo lr co) = mkLRCo lr (go co)
go (TcSubCo co) = mkSubCo (go co)
go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
go (TcCoVarCo v) = ds_ev_id subst v
go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)
go (TcCoercion co) = co
ds_co_binds :: TcEvBinds -> CvSubst
ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
ds_scc :: CvSubst -> SCC EvBind -> CvSubst
ds_scc subst (AcyclicSCC (EvBind v ev_term))
= extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
ds_co_term :: CvSubst -> EvTerm -> Coercion
ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
ds_co_term subst (EvId v) = ds_ev_id subst v
ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
ds_ev_id :: CvSubst -> EqVar -> Coercion
ds_ev_id subst v
| Just co <- Coercion.lookupCoVar subst v = co
| otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)