module TcSMonad (
WorkList(..), isEmptyWorkList, emptyWorkList,
extendWorkListNonEq, extendWorkListCt, extendWorkListDerived,
extendWorkListCts, extendWorkListEq, appendWorkList,
selectNextWorkItem,
workListSize, workListWantedCount,
updWorkListTcS,
TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, failTcS,
runTcSEqualities,
nestTcS, nestImplicTcS,
runTcPluginTcS, addUsedDataCons, deferTcSForAllEq,
panicTcS, traceTcS,
traceFireTcS, bumpStepCountTcS, csTraceTcS,
wrapErrTcS, wrapWarnTcS,
MaybeNew(..), freshGoals, isFresh, getEvTerm,
newTcEvBinds,
newWantedEq,
newWanted, newWantedEvVar, newWantedEvVarNC, newDerivedNC,
newBoundEvVarId,
unifyTyVar, unflattenFmv, reportUnifications,
setEvBind, setWantedEq, setEqIfWanted,
setWantedEvTerm, setWantedEvBind, setEvBindIfWanted,
newEvVar, newGivenEvVar, newGivenEvVars,
emitNewDerived, emitNewDeriveds, emitNewDerivedEq,
checkReductionDepth,
getInstEnvs, getFamInstEnvs,
getTopEnv, getGblEnv, getLclEnv,
getTcEvBinds, getTcEvBindsFromVar, getTcLevel,
getTcEvBindsMap,
tcLookupClass,
InertSet(..), InertCans(..),
updInertTcS, updInertCans, updInertDicts, updInertIrreds,
getNoGivenEqs, setInertCans,
getInertEqs, getInertCans, getInertModel, getInertGivens,
emptyInert, getTcSInerts, setTcSInerts, takeGivenInsolubles,
matchableGivens, prohibitedSuperClassSolve,
getUnsolvedInerts,
removeInertCts, getPendingScDicts, isPendingScDict,
addInertCan, addInertEq, insertFunEq,
emitInsoluble, emitWorkNC, emitWorkCt,
InertModel, kickOutAfterUnification,
addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
getSafeOverlapFailures,
lookupInertDict, findDictsByClass, addDict, addDictsByClass,
delDict, partitionDicts, foldDicts, filterDicts,
EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,
addSolvedDict, lookupSolvedDict,
foldIrreds,
lookupFlatCache, extendFlatCache, newFlattenSkolem,
updInertFunEqs, findFunEq, sizeFunEqMap, filterFunEqs,
findFunEqsByTyCon, partitionFunEqs, foldFunEqs,
instDFunType,
newFlexiTcSTy, instFlexiTcS,
cloneMetaTyVar, demoteUnfilledFmv,
TcLevel, isTouchableMetaTyVarTcS,
isFilledMetaTyVar_maybe, isFilledMetaTyVar,
zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
zonkSimples, zonkWC,
newTcRef, readTcRef, updTcRef,
getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
matchFam, matchFamTcM,
checkWellStagedDFun,
pprEq
) where
#include "HsVersions.h"
import HscTypes
import qualified Inst as TcM
import InstEnv
import FamInst
import FamInstEnv
import qualified TcRnMonad as TcM
import qualified TcMType as TcM
import qualified TcEnv as TcM
( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass )
import Kind
import TcType
import DynFlags
import Type
import Coercion
import Unify
import TcEvidence
import Class
import TyCon
import TcErrors ( solverDepthErrorTcS )
import Name
import RdrName ( GlobalRdrEnv)
import qualified RnEnv as TcM
import Var
import VarEnv
import VarSet
import Outputable
import Bag
import UniqSupply
import FastString
import Util
import TcRnTypes
import Unique
import UniqFM
import Maybes
import TrieMap
import Control.Monad
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif
import MonadUtils
import Data.IORef
import Data.List ( foldl', partition )
#ifdef DEBUG
import Digraph
#endif
data WorkList
= WL { wl_eqs :: [Ct]
, wl_funeqs :: [Ct]
, wl_rest :: [Ct]
, wl_deriv :: [CtEvidence]
, wl_implics :: Bag Implication
}
appendWorkList :: WorkList -> WorkList -> WorkList
appendWorkList
(WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1
, wl_deriv = ders1, wl_implics = implics1 })
(WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2
, wl_deriv = ders2, wl_implics = implics2 })
= WL { wl_eqs = eqs1 ++ eqs2
, wl_funeqs = funeqs1 ++ funeqs2
, wl_rest = rest1 ++ rest2
, wl_deriv = ders1 ++ ders2
, wl_implics = implics1 `unionBags` implics2 }
workListSize :: WorkList -> Int
workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_deriv = ders, wl_rest = rest })
= length eqs + length funeqs + length rest + length ders
workListWantedCount :: WorkList -> Int
workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })
= count isWantedCt eqs + count isWantedCt rest
extendWorkListEq :: Ct -> WorkList -> WorkList
extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
extendWorkListEqs :: [Ct] -> WorkList -> WorkList
extendWorkListEqs cts wl = wl { wl_eqs = cts ++ wl_eqs wl }
extendWorkListFunEq :: Ct -> WorkList -> WorkList
extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }
extendWorkListNonEq :: Ct -> WorkList -> WorkList
extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
extendWorkListDerived :: CtLoc -> CtEvidence -> WorkList -> WorkList
extendWorkListDerived loc ev wl
| isDroppableDerivedLoc loc = wl { wl_deriv = ev : wl_deriv wl }
| otherwise = extendWorkListEq (mkNonCanonical ev) wl
extendWorkListDeriveds :: CtLoc -> [CtEvidence] -> WorkList -> WorkList
extendWorkListDeriveds loc evs wl
| isDroppableDerivedLoc loc = wl { wl_deriv = evs ++ wl_deriv wl }
| otherwise = extendWorkListEqs (map mkNonCanonical evs) wl
extendWorkListImplic :: Implication -> WorkList -> WorkList
extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }
extendWorkListCt :: Ct -> WorkList -> WorkList
extendWorkListCt ct wl
= case classifyPredType (ctPred ct) of
EqPred NomEq ty1 _
| Just (tc,_) <- tcSplitTyConApp_maybe ty1
, isTypeFamilyTyCon tc
-> extendWorkListFunEq ct wl
EqPred {}
-> extendWorkListEq ct wl
_ -> extendWorkListNonEq ct wl
extendWorkListCts :: [Ct] -> WorkList -> WorkList
extendWorkListCts cts wl = foldr extendWorkListCt wl cts
isEmptyWorkList :: WorkList -> Bool
isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
, wl_rest = rest, wl_deriv = ders, wl_implics = implics })
= null eqs && null rest && null funeqs && isEmptyBag implics && null ders
emptyWorkList :: WorkList
emptyWorkList = WL { wl_eqs = [], wl_rest = []
, wl_funeqs = [], wl_deriv = [], wl_implics = emptyBag }
selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
, wl_rest = rest })
| ct:cts <- eqs = Just (ct, wl { wl_eqs = cts })
| ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })
| ct:cts <- rest = Just (ct, wl { wl_rest = cts })
| otherwise = Nothing
selectDerivedWorkItem :: WorkList -> Maybe (Ct, WorkList)
selectDerivedWorkItem wl@(WL { wl_deriv = ders })
| ev:evs <- ders = Just (mkNonCanonical ev, wl { wl_deriv = evs })
| otherwise = Nothing
selectNextWorkItem :: TcS (Maybe Ct)
selectNextWorkItem
= do { wl_var <- getTcSWorkListRef
; wl <- wrapTcS (TcM.readTcRef wl_var)
; let try :: Maybe (Ct,WorkList) -> TcS (Maybe Ct) -> TcS (Maybe Ct)
try mb_work do_this_if_fail
| Just (ct, new_wl) <- mb_work
= do { checkReductionDepth (ctLoc ct) (ctPred ct)
; wrapTcS (TcM.writeTcRef wl_var new_wl)
; return (Just ct) }
| otherwise
= do_this_if_fail
; try (selectWorkItem wl) $
do { ics <- getInertCans
; solve_deriveds <- keepSolvingDeriveds
; if inert_count ics == 0 && not solve_deriveds
then return Nothing
else try (selectDerivedWorkItem wl) (return Nothing) } }
instance Outputable WorkList where
ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
, wl_rest = rest, wl_implics = implics, wl_deriv = ders })
= text "WL" <+> (braces $
vcat [ ppUnless (null eqs) $
ptext (sLit "Eqs =") <+> vcat (map ppr eqs)
, ppUnless (null feqs) $
ptext (sLit "Funeqs =") <+> vcat (map ppr feqs)
, ppUnless (null rest) $
ptext (sLit "Non-eqs =") <+> vcat (map ppr rest)
, ppUnless (null ders) $
ptext (sLit "Derived =") <+> vcat (map ppr ders)
, ppUnless (isEmptyBag implics) $
ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics))
])
data InertSet
= IS { inert_cans :: InertCans
, inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
, inert_solved_dicts :: DictMap CtEvidence
}
instance Outputable InertSet where
ppr is = vcat [ ppr $ inert_cans is
, text "Solved dicts" <+> vcat (map ppr (bagToList (dictsToBag (inert_solved_dicts is)))) ]
emptyInert :: InertSet
emptyInert
= IS { inert_cans = IC { inert_count = 0
, inert_eqs = emptyVarEnv
, inert_dicts = emptyDicts
, inert_safehask = emptyDicts
, inert_funeqs = emptyFunEqs
, inert_irreds = emptyCts
, inert_insols = emptyCts
, inert_model = emptyVarEnv }
, inert_flat_cache = emptyExactFunEqs
, inert_solved_dicts = emptyDictMap }
data InertCans
= IC { inert_model :: InertModel
, inert_eqs :: TyVarEnv EqualCtList
, inert_funeqs :: FunEqMap Ct
, inert_dicts :: DictMap Ct
, inert_safehask :: DictMap Ct
, inert_irreds :: Cts
, inert_insols :: Cts
, inert_count :: Int
}
type InertModel = TyVarEnv Ct
instance Outputable InertCans where
ppr (IC { inert_model = model, inert_eqs = eqs
, inert_funeqs = funeqs, inert_dicts = dicts
, inert_safehask = safehask, inert_irreds = irreds
, inert_insols = insols, inert_count = count })
= braces $ vcat
[ ppUnless (isEmptyVarEnv eqs) $
ptext (sLit "Equalities:")
<+> pprCts (foldVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)
, ppUnless (isEmptyTcAppMap funeqs) $
ptext (sLit "Type-function equalities =") <+> pprCts (funEqsToBag funeqs)
, ppUnless (isEmptyTcAppMap dicts) $
ptext (sLit "Dictionaries =") <+> pprCts (dictsToBag dicts)
, ppUnless (isEmptyTcAppMap safehask) $
ptext (sLit "Safe Haskell unsafe overlap =") <+> pprCts (dictsToBag safehask)
, ppUnless (isEmptyCts irreds) $
ptext (sLit "Irreds =") <+> pprCts irreds
, ppUnless (isEmptyCts insols) $
text "Insolubles =" <+> pprCts insols
, ppUnless (isEmptyVarEnv model) $
text "Model =" <+> pprCts (foldVarEnv consCts emptyCts model)
, text "Unsolved goals =" <+> int count
]
addInertEq :: Ct -> TcS ()
addInertEq ct@(CTyEqCan { cc_tyvar = tv })
= do { traceTcS "addInertEq {" $
text "Adding new inert equality:" <+> ppr ct
; ics <- getInertCans
; let (kicked_out, ics1) = kickOutRewritable (ctFlavourRole ct) tv ics
; ics2 <- add_inert_eq ics1 ct
; setInertCans ics2
; unless (isEmptyWorkList kicked_out) $
do { updWorkListTcS (appendWorkList kicked_out)
; csTraceTcS $
hang (ptext (sLit "Kick out, tv =") <+> ppr tv)
2 (vcat [ text "n-kicked =" <+> int (workListSize kicked_out)
, ppr kicked_out ]) }
; traceTcS "addInertEq }" $ empty }
addInertEq ct = pprPanic "addInertEq" (ppr ct)
add_inert_eq :: InertCans -> Ct -> TcS InertCans
add_inert_eq ics@(IC { inert_count = n
, inert_eqs = old_eqs
, inert_model = old_model })
ct@(CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel, cc_tyvar = tv
, cc_rhs = rhs })
| isDerived ev
= do { emitDerivedShadows ics tv
; return (ics { inert_model = extendVarEnv old_model tv ct }) }
| ReprEq <- eq_rel
= return new_ics
| modelCanRewrite old_model rw_tvs
= do { emitNewDerivedEq loc (eqRelRole eq_rel) (mkTyVarTy tv) rhs
; return new_ics }
| otherwise
= do { emitDerivedShadows ics tv
; return (new_ics { inert_model = new_model }) }
where
loc = ctEvLoc ev
pred = ctEvPred ev
rw_tvs = tyCoVarsOfType pred
new_ics = ics { inert_eqs = addTyEq old_eqs tv ct
, inert_count = bumpUnsolvedCount ev n }
new_model = extendVarEnv old_model tv derived_ct
derived_ct = ct { cc_ev = CtDerived { ctev_loc = loc, ctev_pred = pred } }
add_inert_eq _ ct = pprPanic "addInertEq" (ppr ct)
emitDerivedShadows :: InertCans -> TcTyVar -> TcS ()
emitDerivedShadows IC { inert_eqs = tv_eqs
, inert_dicts = dicts
, inert_safehask = safehask
, inert_funeqs = funeqs
, inert_irreds = irreds
, inert_model = model } new_tv
= mapM_ emit_shadow shadows
where
emit_shadow ct = emitNewDerived loc pred
where
ev = ctEvidence ct
pred = ctEvPred ev
loc = ctEvLoc ev
shadows = foldDicts get_ct dicts $
foldDicts get_ct safehask $
foldFunEqs get_ct funeqs $
foldIrreds get_ct irreds $
foldTyEqs get_ct tv_eqs []
get_ct ct cts | want_shadow ct = ct:cts
| otherwise = cts
want_shadow ct
= not (isDerivedCt ct)
&& (new_tv `elemVarSet` rw_tvs)
&& not (modelCanRewrite model rw_tvs)
where
rw_tvs = rewritableTyCoVars ct
modelCanRewrite :: InertModel -> TcTyCoVarSet -> Bool
modelCanRewrite model tvs = not (disjointUFM model tvs)
rewritableTyCoVars :: Ct -> TcTyVarSet
rewritableTyCoVars (CFunEqCan { cc_tyargs = tys }) = tyCoVarsOfTypes tys
rewritableTyCoVars ct = tyCoVarsOfType (ctPred ct)
addInertCan :: Ct -> TcS ()
addInertCan ct
= do { traceTcS "insertInertCan {" $
text "Trying to insert new inert item:" <+> ppr ct
; ics <- getInertCans
; setInertCans (add_item ics ct)
; let ev = ctEvidence ct
pred = ctEvPred ev
rw_tvs = rewritableTyCoVars ct
; when (not (isDerived ev) && modelCanRewrite (inert_model ics) rw_tvs)
(emitNewDerived (ctEvLoc ev) pred)
; traceTcS "addInertCan }" $ empty }
add_item :: InertCans -> Ct -> InertCans
add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
= ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
add_item ics item@(CIrredEvCan { cc_ev = ev })
= ics { inert_irreds = inert_irreds ics `Bag.snocBag` item
, inert_count = bumpUnsolvedCount ev (inert_count ics) }
add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
= ics { inert_dicts = addDict (inert_dicts ics) cls tys item
, inert_count = bumpUnsolvedCount ev (inert_count ics) }
add_item _ item
= pprPanic "upd_inert set: can't happen! Inserting " $
ppr item
bumpUnsolvedCount :: CtEvidence -> Int -> Int
bumpUnsolvedCount ev n | isWanted ev = n+1
| otherwise = n
kickOutRewritable :: CtFlavourRole
-> TcTyVar
-> InertCans
-> (WorkList, InertCans)
kickOutRewritable new_fr new_tv ics@(IC { inert_funeqs = funeqmap })
| not (new_fr `eqCanRewriteFR` new_fr)
= if isFlattenTyVar new_tv
then (emptyWorkList { wl_funeqs = feqs_out }, ics { inert_funeqs = feqs_in })
else (emptyWorkList, ics)
where
(feqs_out, feqs_in) = partitionFunEqs kick_out_fe funeqmap
kick_out_fe :: Ct -> Bool
kick_out_fe (CFunEqCan { cc_fsk = fsk }) = fsk == new_tv
kick_out_fe _ = False
kickOutRewritable new_fr new_tv (IC { inert_eqs = tv_eqs
, inert_dicts = dictmap
, inert_safehask = safehask
, inert_funeqs = funeqmap
, inert_irreds = irreds
, inert_insols = insols
, inert_count = n
, inert_model = model })
= (kicked_out, inert_cans_in)
where
inert_cans_in = IC { inert_eqs = tv_eqs_in
, inert_dicts = dicts_in
, inert_safehask = safehask
, inert_funeqs = feqs_in
, inert_irreds = irs_in
, inert_insols = insols_in
, inert_count = n workListWantedCount kicked_out
, inert_model = model }
kicked_out = WL { wl_eqs = tv_eqs_out
, wl_funeqs = feqs_out
, wl_deriv = []
, wl_rest = bagToList (dicts_out `andCts` irs_out
`andCts` insols_out)
, wl_implics = emptyBag }
(tv_eqs_out, tv_eqs_in) = foldVarEnv kick_out_eqs ([], emptyVarEnv) tv_eqs
(feqs_out, feqs_in) = partitionFunEqs kick_out_fe funeqmap
(dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap
(irs_out, irs_in) = partitionBag kick_out_ct irreds
(insols_out, insols_in) = partitionBag kick_out_ct insols
fr_can_rewrite :: CtEvidence -> Bool
fr_can_rewrite = (new_fr `eqCanRewriteFR`) . ctEvFlavourRole
kick_out_ct :: Ct -> Bool
kick_out_ct ct = kick_out_ctev (ctEvidence ct)
kick_out_fe :: Ct -> Bool
kick_out_fe (CFunEqCan { cc_ev = ev, cc_fsk = fsk })
= kick_out_ctev ev || fsk == new_tv
kick_out_fe _ = False
kick_out_ctev :: CtEvidence -> Bool
kick_out_ctev ev = fr_can_rewrite ev
&& new_tv `elemVarSet` tyCoVarsOfType (ctEvPred ev)
kick_out_eqs :: EqualCtList -> ([Ct], TyVarEnv EqualCtList)
-> ([Ct], TyVarEnv EqualCtList)
kick_out_eqs eqs (acc_out, acc_in)
= (eqs_out ++ acc_out, case eqs_in of
[] -> acc_in
(eq1:_) -> extendVarEnv acc_in (cc_tyvar eq1) eqs_in)
where
(eqs_in, eqs_out) = partition keep_eq eqs
keep_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty, cc_ev = ev
, cc_eq_rel = eq_rel })
| tv == new_tv
= not (fr_can_rewrite ev)
| otherwise
= check_k2 && check_k3
where
fs = ctEvFlavourRole ev
check_k2 = not (fs `eqCanRewriteFR` fs)
|| (fs `eqCanRewriteFR` new_fr)
|| not (new_fr `eqCanRewriteFR` fs)
|| not (new_tv `elemVarSet` tyCoVarsOfType rhs_ty)
check_k3
| new_fr `eqCanRewriteFR` fs
= case eq_rel of
NomEq -> not (rhs_ty `eqType` mkTyVarTy new_tv)
ReprEq -> not (isTyVarExposed new_tv rhs_ty)
| otherwise
= True
keep_eq ct = pprPanic "keep_eq" (ppr ct)
kickOutAfterUnification :: TcTyVar -> TcS Int
kickOutAfterUnification new_tv
= do { ics <- getInertCans
; let (kicked_out1, ics1) = kickOutModel new_tv ics
(kicked_out2, ics2) = kickOutRewritable (Given,NomEq)
new_tv ics1
kicked_out = appendWorkList kicked_out1 kicked_out2
; setInertCans ics2
; updWorkListTcS (appendWorkList kicked_out)
; unless (isEmptyWorkList kicked_out) $
csTraceTcS $
hang (ptext (sLit "Kick out (unify), tv =") <+> ppr new_tv)
2 (vcat [ text "n-kicked =" <+> int (workListSize kicked_out)
, text "kicked_out =" <+> ppr kicked_out
, text "Residual inerts =" <+> ppr ics2 ])
; return (workListSize kicked_out) }
kickOutModel :: TcTyVar -> InertCans -> (WorkList, InertCans)
kickOutModel new_tv ics@(IC { inert_model = model, inert_eqs = eqs })
= (foldVarEnv add emptyWorkList der_out, ics { inert_model = new_model })
where
(der_out, new_model) = partitionVarEnv kick_out_der model
kick_out_der :: Ct -> Bool
kick_out_der (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs })
= new_tv == tv || new_tv `elemVarSet` tyCoVarsOfType rhs
kick_out_der _ = False
add :: Ct -> WorkList -> WorkList
add (CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) wl
| not (isInInertEqs eqs tv rhs) = extendWorkListDerived (ctEvLoc ev) ev wl
add _ wl = wl
addInertSafehask :: InertCans -> Ct -> InertCans
addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
= ics { inert_safehask = addDict (inert_dicts ics) cls tys item }
addInertSafehask _ item
= pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item
insertSafeOverlapFailureTcS :: Ct -> TcS ()
insertSafeOverlapFailureTcS item
= updInertCans (\ics -> addInertSafehask ics item)
getSafeOverlapFailures :: TcS Cts
getSafeOverlapFailures
= do { IC { inert_safehask = safehask } <- getInertCans
; return $ foldDicts consCts safehask emptyCts }
addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS ()
addSolvedDict item cls tys
| isIPPred (ctEvPred item)
= return ()
| otherwise
= do { traceTcS "updSolvedSetTcs:" $ ppr item
; updInertTcS $ \ ics ->
ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
updInertTcS :: (InertSet -> InertSet) -> TcS ()
updInertTcS upd_fn
= do { is_var <- getTcSInertsRef
; wrapTcS (do { curr_inert <- TcM.readTcRef is_var
; TcM.writeTcRef is_var (upd_fn curr_inert) }) }
getInertCans :: TcS InertCans
getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }
setInertCans :: InertCans -> TcS ()
setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }
takeGivenInsolubles :: TcS Cts
takeGivenInsolubles
= updRetInertCans $ \ cans ->
( inert_insols cans
, cans { inert_insols = emptyBag
, inert_funeqs = filterFunEqs isGivenCt (inert_funeqs cans) } )
updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a
updRetInertCans upd_fn
= do { is_var <- getTcSInertsRef
; wrapTcS (do { inerts <- TcM.readTcRef is_var
; let (res, cans') = upd_fn (inert_cans inerts)
; TcM.writeTcRef is_var (inerts { inert_cans = cans' })
; return res }) }
updInertCans :: (InertCans -> InertCans) -> TcS ()
updInertCans upd_fn
= updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }
updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()
updInertDicts upd_fn
= updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }
updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()
updInertSafehask upd_fn
= updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }
updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
updInertFunEqs upd_fn
= updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }
updInertIrreds :: (Cts -> Cts) -> TcS ()
updInertIrreds upd_fn
= updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }
getInertEqs :: TcS (TyVarEnv EqualCtList)
getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }
getInertModel :: TcS InertModel
getInertModel = do { inert <- getInertCans; return (inert_model inert) }
getInertGivens :: TcS [Ct]
getInertGivens
= do { inerts <- getInertCans
; let all_cts = foldDicts (:) (inert_dicts inerts)
$ foldFunEqs (:) (inert_funeqs inerts)
$ concat (varEnvElts (inert_eqs inerts))
; return (filter isGivenCt all_cts) }
getPendingScDicts :: TcS [Ct]
getPendingScDicts = updRetInertCans get_sc_dicts
where
get_sc_dicts ic@(IC { inert_dicts = dicts })
= (sc_pend_dicts, ic')
where
ic' = ic { inert_dicts = foldr add dicts sc_pend_dicts }
sc_pend_dicts :: [Ct]
sc_pend_dicts = foldDicts get_pending dicts []
get_pending :: Ct -> [Ct] -> [Ct]
get_pending dict dicts
| Just dict' <- isPendingScDict dict = dict' : dicts
| otherwise = dicts
add :: Ct -> DictMap Ct -> DictMap Ct
add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
= addDict dicts cls tys ct
add ct _ = pprPanic "getPendingScDicts" (ppr ct)
isPendingScDict :: Ct -> Maybe Ct
isPendingScDict ct@(CDictCan { cc_pend_sc = True })
= Just (ct { cc_pend_sc = False })
isPendingScDict _ = Nothing
getUnsolvedInerts :: TcS ( Bag Implication
, Cts
, Cts
, Cts
, Cts )
getUnsolvedInerts
= do { IC { inert_eqs = tv_eqs
, inert_funeqs = fun_eqs
, inert_irreds = irreds
, inert_dicts = idicts
, inert_insols = insols
, inert_model = model } <- getInertCans
; let der_tv_eqs = foldVarEnv (add_der tv_eqs) emptyCts model
unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs der_tv_eqs
unsolved_fun_eqs = foldFunEqs add_if_unsolved fun_eqs emptyCts
unsolved_irreds = Bag.filterBag is_unsolved irreds
unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts
others = unsolved_irreds `unionBags` unsolved_dicts
; implics <- getWorkListImplics
; traceTcS "getUnsolvedInerts" $
vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs
, text "fun eqs =" <+> ppr unsolved_fun_eqs
, text "insols =" <+> ppr insols
, text "others =" <+> ppr others
, text "implics =" <+> ppr implics ]
; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, insols, others) }
where
add_der tv_eqs ct cts
| CTyEqCan { cc_tyvar = tv, cc_rhs = rhs } <- ct
, not (isInInertEqs tv_eqs tv rhs) = ct `consBag` cts
| otherwise = cts
add_if_unsolved :: Ct -> Cts -> Cts
add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts
| otherwise = cts
is_unsolved ct = not (isGivenCt ct)
isInInertEqs :: TyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool
isInInertEqs eqs tv rhs
= case lookupVarEnv eqs tv of
Nothing -> False
Just cts -> any (same_pred rhs) cts
where
same_pred rhs ct
| CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct
, NomEq <- eq_rel
, rhs `eqType` rhs2 = True
| otherwise = False
getNoGivenEqs :: TcLevel
-> [TcTyVar]
-> TcS Bool
getNoGivenEqs tclvl skol_tvs
= do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds, inert_funeqs = funeqs })
<- getInertCans
; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet
has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False iirreds
|| foldVarEnv ((||) . eqs_given_here local_fsks) False ieqs
; traceTcS "getNoGivenEqs" (vcat [ppr has_given_eqs, ppr inerts])
; return (not has_given_eqs) }
where
eqs_given_here :: VarSet -> EqualCtList -> Bool
eqs_given_here local_fsks [CTyEqCan { cc_tyvar = tv, cc_ev = ev }]
= not (skolem_bound_here local_fsks tv) && ev_given_here ev
eqs_given_here _ _ = False
ev_given_here :: CtEvidence -> Bool
ev_given_here ev
= isGiven ev
&& tclvl == ctLocLevel (ctEvLoc ev)
add_fsk :: Ct -> VarSet -> VarSet
add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct
, isGiven ev = extendVarSet fsks tv
| otherwise = fsks
skol_tv_set = mkVarSet skol_tvs
skolem_bound_here local_fsks tv
= case tcTyVarDetails tv of
SkolemTv {} -> tv `elemVarSet` skol_tv_set
FlatSkol {} -> not (tv `elemVarSet` local_fsks)
_ -> False
matchableGivens :: CtLoc -> PredType -> InertSet -> Cts
matchableGivens loc_w pred (IS { inert_cans = inert_cans })
= filterBag matchable_given all_relevant_givens
where
all_relevant_givens :: Cts
all_relevant_givens
| Just (clas, _) <- getClassPredTys_maybe pred
= findDictsByClass (inert_dicts inert_cans) clas
`unionBags` inert_irreds inert_cans
| otherwise
= inert_irreds inert_cans
matchable_given :: Ct -> Bool
matchable_given ct
| CtGiven { ctev_loc = loc_g } <- ctev
, Just _ <- tcUnifyTys bind_meta_tv [ctEvPred ctev] [pred]
, not (prohibitedSuperClassSolve loc_g loc_w)
= True
| otherwise
= False
where
ctev = cc_ev ct
bind_meta_tv :: TcTyVar -> BindFlag
bind_meta_tv tv | isMetaTyVar tv = BindMe
| otherwise = Skolem
prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
prohibitedSuperClassSolve from_loc solve_loc
| GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc
, ScOrigin wanted_size <- ctLocOrigin solve_loc
= given_size >= wanted_size
| otherwise
= False
removeInertCts :: [Ct] -> InertCans -> InertCans
removeInertCts cts icans = foldl' removeInertCt icans cts
removeInertCt :: InertCans -> Ct -> InertCans
removeInertCt is ct =
case ct of
CDictCan { cc_class = cl, cc_tyargs = tys } ->
is { inert_dicts = delDict (inert_dicts is) cl tys }
CFunEqCan { cc_fun = tf, cc_tyargs = tys } ->
is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
CTyEqCan { cc_tyvar = x, cc_rhs = ty } ->
is { inert_eqs = delTyEq (inert_eqs is) x ty }
CIrredEvCan {} -> panic "removeInertCt: CIrredEvCan"
CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
CHoleCan {} -> panic "removeInertCt: CHoleCan"
lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))
lookupFlatCache fam_tc tys
= do { IS { inert_flat_cache = flat_cache
, inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
; return (firstJusts [lookup_inerts inert_funeqs,
lookup_flats flat_cache]) }
where
lookup_inerts inert_funeqs
| Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })
<- findFunEq inert_funeqs fam_tc tys
, tys `eqTypes` xis
= Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)
| otherwise = Nothing
lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys
lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence)
lookupInInerts pty
| ClassPred cls tys <- classifyPredType pty
= do { inerts <- getTcSInerts
; return (lookupSolvedDict inerts cls tys `mplus`
lookupInertDict (inert_cans inerts) cls tys) }
| otherwise
= return Nothing
lookupInertDict :: InertCans -> Class -> [Type] -> Maybe CtEvidence
lookupInertDict (IC { inert_dicts = dicts }) cls tys
= case findDict dicts cls tys of
Just ct -> Just (ctEvidence ct)
_ -> Nothing
lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence
lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys
= case findDict solved cls tys of
Just ev -> Just ev
_ -> Nothing
foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
foldIrreds k irreds z = foldrBag k z irreds
type EqualCtList = [Ct]
addTyEq :: TyVarEnv EqualCtList -> TcTyVar -> Ct -> TyVarEnv EqualCtList
addTyEq old_list tv it = extendVarEnv_C (\old_eqs _new_eqs -> it : old_eqs)
old_list tv [it]
foldTyEqs :: (Ct -> b -> b) -> TyVarEnv EqualCtList -> b -> b
foldTyEqs k eqs z
= foldVarEnv (\cts z -> foldr k z cts) z eqs
findTyEqs :: InertCans -> TyVar -> EqualCtList
findTyEqs icans tv = lookupVarEnv (inert_eqs icans) tv `orElse` []
delTyEq :: TyVarEnv EqualCtList -> TcTyVar -> TcType -> TyVarEnv EqualCtList
delTyEq m tv t = modifyVarEnv (filter (not . isThisOne)) m tv
where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
isThisOne _ = False
type TcAppMap a = UniqFM (ListMap LooseTypeMap a)
isEmptyTcAppMap :: TcAppMap a -> Bool
isEmptyTcAppMap m = isNullUFM m
emptyTcAppMap :: TcAppMap a
emptyTcAppMap = emptyUFM
findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a
findTcApp m u tys = do { tys_map <- lookupUFM m u
; lookupTM tys tys_map }
delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a
delTcApp m cls tys = adjustUFM (deleteTM tys) m cls
insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a
insertTcApp m cls tys ct = alterUFM alter_tm m cls
where
alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
filterTcAppMap f m
= mapUFM do_tm m
where
do_tm tm = foldTM insert_mb tm emptyTM
insert_mb ct tm
| f ct = insertTM tys ct tm
| otherwise = tm
where
tys = case ct of
CFunEqCan { cc_tyargs = tys } -> tys
CDictCan { cc_tyargs = tys } -> tys
_ -> pprPanic "filterTcAppMap" (ppr ct)
tcAppMapToBag :: TcAppMap a -> Bag a
tcAppMapToBag m = foldTcAppMap consBag m emptyBag
foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap k m z = foldUFM (foldTM k) z m
type DictMap a = TcAppMap a
emptyDictMap :: DictMap a
emptyDictMap = emptyTcAppMap
findDict :: DictMap a -> Class -> [Type] -> Maybe a
findDict m cls tys = findTcApp m (getUnique cls) tys
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass m cls
| Just tm <- lookupUFM m cls = foldTM consBag tm emptyBag
| otherwise = emptyBag
delDict :: DictMap a -> Class -> [Type] -> DictMap a
delDict m cls tys = delTcApp m (getUnique cls) tys
addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
addDict m cls tys item = insertTcApp m (getUnique cls) tys item
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass m cls items
= addToUFM m cls (foldrBag add emptyTM items)
where
add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
add ct _ = pprPanic "addDictsByClass" (ppr ct)
filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
filterDicts f m = filterTcAppMap f m
partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)
where
k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes)
| otherwise = (yeses, add ct noes)
add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m
= addDict m cls tys ct
add ct _ = pprPanic "partitionDicts" (ppr ct)
dictsToBag :: DictMap a -> Bag a
dictsToBag = tcAppMapToBag
foldDicts :: (a -> b -> b) -> DictMap a -> b -> b
foldDicts = foldTcAppMap
emptyDicts :: DictMap a
emptyDicts = emptyTcAppMap
type FunEqMap a = TcAppMap a
emptyFunEqs :: TcAppMap a
emptyFunEqs = emptyTcAppMap
sizeFunEqMap :: FunEqMap a -> Int
sizeFunEqMap m = foldFunEqs (\ _ x -> x+1) m 0
findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
findFunEq m tc tys = findTcApp m (getUnique tc) tys
funEqsToBag :: FunEqMap a -> Bag a
funEqsToBag m = foldTcAppMap consBag m emptyBag
findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon m tc
| Just tm <- lookupUFM m tc = foldTM (:) tm []
| otherwise = []
foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
foldFunEqs = foldTcAppMap
filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
filterFunEqs = filterTcAppMap
insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
partitionFunEqs f m = (yeses, foldr del m yeses)
where
yeses = foldTcAppMap k m []
k ct yeses | f ct = ct : yeses
| otherwise = yeses
del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
= delFunEq m tc tys
del ct _ = pprPanic "partitionFunEqs" (ppr ct)
delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
delFunEq m tc tys = delTcApp m (getUnique tc) tys
type ExactFunEqMap a = UniqFM (ListMap TypeMap a)
emptyExactFunEqs :: ExactFunEqMap a
emptyExactFunEqs = emptyUFM
findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a
findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc)
; lookupTM tys tys_map }
insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a
insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)
where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))
data TcSEnv
= TcSEnv {
tcs_ev_binds :: Maybe EvBindsVar,
tcs_unified :: IORef Int,
tcs_count :: IORef Int,
tcs_inerts :: IORef InertSet,
tcs_worklist :: IORef WorkList,
tcs_used_tcvs :: IORef TyCoVarSet,
tcs_need_deriveds :: Bool
}
newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
instance Functor TcS where
fmap f m = TcS $ fmap f . unTcS m
instance Applicative TcS where
pure x = TcS (\_ -> return x)
(<*>) = ap
instance Monad TcS where
return = pure
fail err = TcS (\_ -> fail err)
m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
#if __GLASGOW_HASKELL__ > 710
instance MonadFail.MonadFail TcS where
fail err = TcS (\_ -> fail err)
#endif
instance MonadUnique TcS where
getUniqueSupplyM = wrapTcS getUniqueSupplyM
wrapTcS :: TcM a -> TcS a
wrapTcS = TcS . const
wrapErrTcS :: TcM a -> TcS a
wrapErrTcS = wrapTcS
wrapWarnTcS :: TcM a -> TcS a
wrapWarnTcS = wrapTcS
failTcS, panicTcS :: SDoc -> TcS a
failTcS = wrapTcS . TcM.failWith
panicTcS doc = pprPanic "TcCanonical" doc
traceTcS :: String -> SDoc -> TcS ()
traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
runTcPluginTcS :: TcPluginM a -> TcS a
runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBinds
instance HasDynFlags TcS where
getDynFlags = wrapTcS getDynFlags
getGlobalRdrEnvTcS :: TcS GlobalRdrEnv
getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv
bumpStepCountTcS :: TcS ()
bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
; n <- TcM.readTcRef ref
; TcM.writeTcRef ref (n+1) }
useVars :: TyCoVarSet -> TcS ()
useVars vars = TcS $ \env -> do { let ref = tcs_used_tcvs env
; TcM.updTcRef ref (`unionVarSet` vars) }
csTraceTcS :: SDoc -> TcS ()
csTraceTcS doc
= wrapTcS $ csTraceTcM 1 (return doc)
traceFireTcS :: CtEvidence -> SDoc -> TcS ()
traceFireTcS ev doc
= TcS $ \env -> csTraceTcM 1 $
do { n <- TcM.readTcRef (tcs_count env)
; tclvl <- TcM.getTcLevel
; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr tclvl
<> ppr (ctLocDepth (ctEvLoc ev)))
<+> doc <> colon)
4 (ppr ev)) }
csTraceTcM :: Int -> TcM SDoc -> TcM ()
csTraceTcM trace_level mk_doc
= do { dflags <- getDynFlags
; when ( (dopt Opt_D_dump_cs_trace dflags || dopt Opt_D_dump_tc_trace dflags)
&& trace_level <= traceLevel dflags ) $
do { msg <- mk_doc
; TcM.traceTcRn Opt_D_dump_cs_trace msg } }
runTcS :: TcS a
-> TcM (a, EvBindMap)
runTcS tcs
= do { ev_binds_var <- TcM.newTcEvBinds
; res <- runTcSWithEvBinds False (Just ev_binds_var) tcs
; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
; return (res, ev_binds) }
runTcSDeriveds :: TcS a -> TcM a
runTcSDeriveds tcs
= do { ev_binds_var <- TcM.newTcEvBinds
; runTcSWithEvBinds True (Just ev_binds_var) tcs }
runTcSEqualities :: TcS a -> TcM a
runTcSEqualities = runTcSWithEvBinds False Nothing
runTcSWithEvBinds :: Bool
-> Maybe EvBindsVar
-> TcS a
-> TcM a
runTcSWithEvBinds solve_deriveds ev_binds_var tcs
= do { unified_var <- TcM.newTcRef 0
; step_count <- TcM.newTcRef 0
; inert_var <- TcM.newTcRef emptyInert
; wl_var <- TcM.newTcRef emptyWorkList
; used_var <- TcM.newTcRef emptyVarSet
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_unified = unified_var
, tcs_count = step_count
, tcs_inerts = inert_var
, tcs_worklist = wl_var
, tcs_used_tcvs = used_var
, tcs_need_deriveds = solve_deriveds }
; res <- unTcS tcs env
; count <- TcM.readTcRef step_count
; when (count > 0) $
csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count)
#ifdef DEBUG
; whenIsJust ev_binds_var $ \ebv ->
do { ev_binds <- TcM.getTcEvBinds ebv
; checkForCyclicBinds ev_binds }
#endif
; return res }
#ifdef DEBUG
checkForCyclicBinds :: Bag EvBind -> TcM ()
checkForCyclicBinds ev_binds
| null cycles
= return ()
| null coercion_cycles
= TcM.traceTc "Cycle in evidence binds" $ ppr cycles
| otherwise
= pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
where
cycles :: [[EvBind]]
cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges]
coercion_cycles = [c | c <- cycles, any is_co_bind c]
is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)
edges :: [(EvBind, EvVar, [EvVar])]
edges = [ (bind, bndr, varSetElems (evVarsOfTerm rhs))
| bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
#endif
nestImplicTcS :: Maybe EvBindsVar -> TyCoVarSet
-> TcLevel -> TcS a
-> TcS (a, TyCoVarSet)
nestImplicTcS m_ref bound_tcvs inner_tclvl (TcS thing_inside)
= do { (res, used_tcvs) <-
TcS $ \ TcSEnv { tcs_unified = unified_var
, tcs_inerts = old_inert_var
, tcs_count = count
, tcs_need_deriveds = solve_deriveds
} ->
do { inerts <- TcM.readTcRef old_inert_var
; let nest_inert = inerts { inert_flat_cache = emptyExactFunEqs }
; new_inert_var <- TcM.newTcRef nest_inert
; new_wl_var <- TcM.newTcRef emptyWorkList
; new_used_var <- TcM.newTcRef emptyVarSet
; let nest_env = TcSEnv { tcs_ev_binds = m_ref
, tcs_unified = unified_var
, tcs_count = count
, tcs_inerts = new_inert_var
, tcs_worklist = new_wl_var
, tcs_used_tcvs = new_used_var
, tcs_need_deriveds = solve_deriveds }
; res <- TcM.setTcLevel inner_tclvl $
thing_inside nest_env
#ifdef DEBUG
; whenIsJust m_ref $ \ ref ->
do { ev_binds <- TcM.getTcEvBinds ref
; checkForCyclicBinds ev_binds }
#endif
; used_tcvs <- TcM.readTcRef new_used_var
; return (res, used_tcvs) }
; local_ev_vars <- case m_ref of
Nothing -> return emptyVarSet
Just ref -> do { binds <- wrapTcS $ TcM.getTcEvBinds ref
; return $ mkVarSet $ map evBindVar $ bagToList binds }
; let all_locals = bound_tcvs `unionVarSet` local_ev_vars
(inner_used_tcvs, outer_used_tcvs)
= partitionVarSet (`elemVarSet` all_locals) used_tcvs
; useVars outer_used_tcvs
; return (res, inner_used_tcvs) }
nestTcS :: TcS a -> TcS a
nestTcS (TcS thing_inside)
= TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
do { inerts <- TcM.readTcRef inerts_var
; new_inert_var <- TcM.newTcRef inerts
; new_wl_var <- TcM.newTcRef emptyWorkList
; let nest_env = env { tcs_inerts = new_inert_var
, tcs_worklist = new_wl_var }
; res <- thing_inside nest_env
; new_inerts <- TcM.readTcRef new_inert_var
; let old_ic = inert_cans inerts
new_ic = inert_cans new_inerts
nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }
; TcM.writeTcRef inerts_var
(inerts { inert_solved_dicts = inert_solved_dicts new_inerts
, inert_cans = nxt_ic })
; return res }
getTcSInertsRef :: TcS (IORef InertSet)
getTcSInertsRef = TcS (return . tcs_inerts)
getTcSWorkListRef :: TcS (IORef WorkList)
getTcSWorkListRef = TcS (return . tcs_worklist)
getTcSInerts :: TcS InertSet
getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)
setTcSInerts :: InertSet -> TcS ()
setTcSInerts ics = do { r <- getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) }
getWorkListImplics :: TcS (Bag Implication)
getWorkListImplics
= do { wl_var <- getTcSWorkListRef
; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
; return (wl_implics wl_curr) }
updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
updWorkListTcS f
= do { wl_var <- getTcSWorkListRef
; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
; let new_work = f wl_curr
; wrapTcS (TcM.writeTcRef wl_var new_work) }
keepSolvingDeriveds :: TcS Bool
keepSolvingDeriveds = TcS (return . tcs_need_deriveds)
emitWorkNC :: [CtEvidence] -> TcS ()
emitWorkNC evs
| null evs
= return ()
| otherwise
= emitWork (map mkNonCanonical evs)
emitWork :: [Ct] -> TcS ()
emitWork cts
= do { traceTcS "Emitting fresh work" (vcat (map ppr cts))
; updWorkListTcS (extendWorkListCts cts) }
emitWorkCt :: Ct -> TcS ()
emitWorkCt ct
= do { traceTcS "Emitting fresh (canonical) work" (ppr ct)
; updWorkListTcS (extendWorkListCt ct) }
emitInsoluble :: Ct -> TcS ()
emitInsoluble ct
= do { traceTcS "Emit insoluble" (ppr ct $$ pprCtLoc (ctLoc ct))
; updInertTcS add_insol }
where
this_pred = ctPred ct
add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) })
| already_there = is
| otherwise = is { inert_cans = ics { inert_insols = old_insols `snocCts` ct } }
where
already_there = not (isWantedCt ct) && anyBag (tcEqType this_pred . ctPred) old_insols
newTcRef :: a -> TcS (TcRef a)
newTcRef x = wrapTcS (TcM.newTcRef x)
readTcRef :: TcRef a -> TcS a
readTcRef ref = wrapTcS (TcM.readTcRef ref)
updTcRef :: TcRef a -> (a->a) -> TcS ()
updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)
getTcEvBinds :: TcS (Maybe EvBindsVar)
getTcEvBinds = TcS (return . tcs_ev_binds)
getTcEvBindsFromVar :: EvBindsVar -> TcS (Bag EvBind)
getTcEvBindsFromVar = wrapTcS . TcM.getTcEvBinds
getTcLevel :: TcS TcLevel
getTcLevel = wrapTcS TcM.getTcLevel
getTcEvBindsMap :: TcS EvBindMap
getTcEvBindsMap
= do { ev_binds <- getTcEvBinds
; case ev_binds of
Just (EvBindsVar ev_ref _) -> wrapTcS $ TcM.readTcRef ev_ref
Nothing -> return emptyEvBindMap }
unifyTyVar :: TcTyVar -> TcType -> TcS ()
unifyTyVar tv ty
= ASSERT2( isMetaTyVar tv, ppr tv )
TcS $ \ env ->
do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)
; TcM.writeMetaTyVar tv ty
; TcM.updTcRef (tcs_unified env) (+1) }
unflattenFmv :: TcTyVar -> TcType -> TcS ()
unflattenFmv tv ty
= ASSERT2( isMetaTyVar tv, ppr tv )
TcS $ \ _ ->
do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)
; TcM.writeMetaTyVar tv ty }
reportUnifications :: TcS a -> TcS (Int, a)
reportUnifications (TcS thing_inside)
= TcS $ \ env ->
do { inner_unified <- TcM.newTcRef 0
; res <- thing_inside (env { tcs_unified = inner_unified })
; n_unifs <- TcM.readTcRef inner_unified
; TcM.updTcRef (tcs_unified env) (+ n_unifs)
; return (n_unifs, res) }
getDefaultInfo :: TcS ([Type], (Bool, Bool))
getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
getInstEnvs :: TcS InstEnvs
getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs
getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
getTopEnv :: TcS HscEnv
getTopEnv = wrapTcS $ TcM.getTopEnv
getGblEnv :: TcS TcGblEnv
getGblEnv = wrapTcS $ TcM.getGblEnv
getLclEnv :: TcS TcLclEnv
getLclEnv = wrapTcS $ TcM.getLclEnv
tcLookupClass :: Name -> TcS Class
tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
addUsedDataCons :: GlobalRdrEnv -> TyCon -> TcS ()
addUsedDataCons rdr_env tycon = wrapTcS $ TcM.addUsedDataCons rdr_env tycon
checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS ()
checkWellStagedDFun pred dfun_id loc
= wrapTcS $ TcM.setCtLocM loc $
do { use_stage <- TcM.getStage
; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
where
pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
bind_lvl = TcM.topIdLvl dfun_id
pprEq :: TcType -> TcType -> SDoc
pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool
isTouchableMetaTyVarTcS tv
= do { tclvl <- getTcLevel
; return $ isTouchableMetaTyVar tclvl tv }
isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
isFilledMetaTyVar_maybe tv
= case tcTyVarDetails tv of
MetaTv { mtv_ref = ref }
-> do { cts <- wrapTcS (TcM.readTcRef ref)
; case cts of
Indirect ty -> return (Just ty)
Flexi -> return Nothing }
_ -> return Nothing
isFilledMetaTyVar :: TcTyVar -> TcS Bool
isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet
zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)
zonkCo :: Coercion -> TcS Coercion
zonkCo = wrapTcS . TcM.zonkCo
zonkTcType :: TcType -> TcS TcType
zonkTcType ty = wrapTcS (TcM.zonkTcType ty)
zonkTcTypes :: [TcType] -> TcS [TcType]
zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)
zonkTcTyVar :: TcTyVar -> TcS TcType
zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)
zonkSimples :: Cts -> TcS Cts
zonkSimples cts = wrapTcS (TcM.zonkSimples cts)
zonkWC :: WantedConstraints -> TcS WantedConstraints
zonkWC wc = wrapTcS (TcM.zonkWC wc)
newFlattenSkolem :: CtFlavour -> CtLoc
-> TcType
-> TcS (CtEvidence, Coercion, TcTyVar)
newFlattenSkolem Given loc fam_ty
= do { fsk <- newFsk fam_ty
; let co = mkNomReflCo fam_ty
; ev <- newGivenEvVar loc (mkPrimEqPred fam_ty (mkTyVarTy fsk),
EvCoercion co)
; return (ev, co, fsk) }
newFlattenSkolem Wanted loc fam_ty
= do { fmv <- newFmv fam_ty
; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv)
; return (ev, hole_co, fmv) }
newFlattenSkolem Derived loc fam_ty
= do { fmv <- newFmv fam_ty
; ev <- newDerivedNC loc (mkPrimEqPred fam_ty (mkTyVarTy fmv))
; return (ev, pprPanic "newFlattenSkolem [D]" (ppr fam_ty), fmv) }
newFsk, newFmv :: TcType -> TcS TcTyVar
newFsk fam_ty = wrapTcS (TcM.newFskTyVar fam_ty)
newFmv fam_ty = wrapTcS (TcM.newFmvTyVar fam_ty)
extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()
extendFlatCache tc xi_args stuff
= do { dflags <- getDynFlags
; when (gopt Opt_FlatCache dflags) $
updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->
is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } }
instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)
instDFunType dfun_id inst_tys
= wrapTcS $ TcM.instDFunType dfun_id inst_tys
newFlexiTcSTy :: Kind -> TcS TcType
newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
cloneMetaTyVar :: TcTyVar -> TcS TcTyVar
cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)
demoteUnfilledFmv :: TcTyVar -> TcS ()
demoteUnfilledFmv fmv
= wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv
; unless is_filled $
do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)
; TcM.writeMetaTyVar fmv tv_ty } }
instFlexiTcS :: [TKVar] -> TcS (TCvSubst, [TcType])
instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTCvSubst tvs)
where
inst_one subst tv
= do { ty' <- instFlexiTcSHelper (tyVarName tv)
(substTy subst (tyVarKind tv))
; return (extendTCvSubst subst tv ty', ty') }
instFlexiTcSHelper :: Name -> Kind -> TcM TcType
instFlexiTcSHelper tvname kind
= do { uniq <- TcM.newUnique
; details <- TcM.newMetaDetails TauTv
; let name = setNameUnique tvname uniq
; return (mkTyVarTy (mkTcTyVar name kind details)) }
data MaybeNew = Fresh CtEvidence | Cached EvTerm
isFresh :: MaybeNew -> Bool
isFresh (Fresh {}) = True
isFresh (Cached {}) = False
freshGoals :: [MaybeNew] -> [CtEvidence]
freshGoals mns = [ ctev | Fresh ctev <- mns ]
getEvTerm :: MaybeNew -> EvTerm
getEvTerm (Fresh ctev) = ctEvTerm ctev
getEvTerm (Cached evt) = evt
setEvBind :: EvBind -> TcS ()
setEvBind ev_bind
= do { tc_evbinds <- getTcEvBinds
; case tc_evbinds of
Just evb -> wrapTcS $ TcM.addTcEvBind evb ev_bind
Nothing -> pprPanic "setEvBind" (ppr ev_bind) }
setWantedEq :: TcEvDest -> Coercion -> TcS ()
setWantedEq (HoleDest hole) co
= do { useVars (tyCoVarsOfCo co)
; wrapTcS $ TcM.fillCoercionHole hole co }
setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)
setEqIfWanted :: CtEvidence -> Coercion -> TcS ()
setEqIfWanted (CtWanted { ctev_dest = dest }) co = setWantedEq dest co
setEqIfWanted _ _ = return ()
setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()
setWantedEvTerm (HoleDest hole) tm
= do { let co = evTermCoercion tm
; useVars (tyCoVarsOfCo co)
; wrapTcS $ TcM.fillCoercionHole hole co }
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 ev tm
= case ev of
CtWanted { ctev_dest = dest }
-> setWantedEvTerm dest tm
_ -> return ()
newTcEvBinds :: TcS EvBindsVar
newTcEvBinds = wrapTcS TcM.newTcEvBinds
newEvVar :: TcPredType -> TcS EvVar
newEvVar pred = wrapTcS (TcM.newEvVar pred)
newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence
newGivenEvVar loc (pred, rhs)
= do { new_ev <- newBoundEvVarId pred rhs
; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }
newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar
newBoundEvVarId pred rhs
= do { new_ev <- newEvVar pred
; setEvBind (mkGivenEvBind new_ev rhs)
; return new_ev }
newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]
newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)
newWantedEq loc role ty1 ty2
= do { hole <- wrapTcS $ TcM.newCoercionHole
; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
, ctev_loc = loc}
, mkHoleCo hole role ty1 ty2 ) }
where
pty = mkPrimEqPredRole role ty1 ty2
newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence
newWantedEvVarNC loc pty
= do {
; new_ev <- newEvVar pty
; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$
pprCtLoc loc)
; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev
, ctev_loc = loc })}
newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew
newWantedEvVar loc pty
= do { mb_ct <- lookupInInerts pty
; case mb_ct of
Just ctev
| not (isDerived ctev)
-> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
; return $ Cached (ctEvTerm ctev) }
_ -> do { ctev <- newWantedEvVarNC loc pty
; return (Fresh ctev) } }
newWanted :: CtLoc -> PredType -> TcS MaybeNew
newWanted loc pty
| Just (role, ty1, ty2) <- getEqPredTys_maybe pty
= Fresh . fst <$> newWantedEq loc role ty1 ty2
| otherwise
= newWantedEvVar loc pty
emitNewDerived :: CtLoc -> TcPredType -> TcS ()
emitNewDerived loc pred
= do { ev <- newDerivedNC loc pred
; traceTcS "Emitting new derived" (ppr ev)
; updWorkListTcS (extendWorkListDerived loc ev) }
emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()
emitNewDeriveds loc preds
| null preds
= return ()
| otherwise
= do { evs <- mapM (newDerivedNC loc) preds
; traceTcS "Emitting new deriveds" (ppr evs)
; updWorkListTcS (extendWorkListDeriveds loc evs) }
emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()
emitNewDerivedEq loc role ty1 ty2
= do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)
; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)
; updWorkListTcS (extendWorkListDerived loc ev) }
newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence
newDerivedNC loc pred
= do {
; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }
checkReductionDepth :: CtLoc -> TcType
-> TcS ()
checkReductionDepth loc ty
= do { dflags <- getDynFlags
; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $
wrapErrTcS $
solverDepthErrorTcS loc ty }
matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType))
matchFam tycon args = wrapTcS $ matchFamTcM tycon args
matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType))
matchFamTcM tycon args
= do { fam_envs <- FamInst.tcGetFamInstEnvs
; return $ reduceTyFamApp_maybe fam_envs Nominal tycon args }
deferTcSForAllEq :: Role
-> CtLoc
-> [Coercion]
-> ([TyBinder],TcType)
-> ([TyBinder],TcType)
-> TcS Coercion
deferTcSForAllEq role loc kind_cos (bndrs1,body1) (bndrs2,body2)
= do { let tvs1' = zipWithEqual "deferTcSForAllEq"
mkCastTy (mkTyVarTys tvs1) kind_cos
body2' = substTyWith tvs2 tvs1' body2
; (subst, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1
; let phi1 = Type.substTy subst body1
phi2 = Type.substTy subst body2'
skol_info = UnifyForAllSkol skol_tvs phi1
; (ctev, hole_co) <- newWantedEq loc role phi1 phi2
; env <- getLclEnv
; let new_tclvl = pushTcLevel (tcl_tclvl env)
wc = WC { wc_simple = singleCt (mkNonCanonical ctev)
, wc_impl = emptyBag
, wc_insol = emptyCts }
imp = Implic { ic_tclvl = new_tclvl
, ic_skols = skol_tvs
, ic_no_eqs = True
, ic_given = []
, ic_wanted = wc
, ic_status = IC_Unsolved
, ic_binds = Nothing
, ic_env = env
, ic_info = skol_info }
; updWorkListTcS (extendWorkListImplic imp)
; let cobndrs = zip skol_tvs kind_cos
; return $ mkForAllCos cobndrs hole_co }
where
tvs1 = map (binderVar "deferTcSForAllEq") bndrs1
tvs2 = map (binderVar "deferTcSForAllEq") bndrs2