{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-}
module TcSMonad (
WorkList(..), isEmptyWorkList, emptyWorkList,
extendWorkListNonEq, extendWorkListCt,
extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
appendWorkList,
selectNextWorkItem,
workListSize, workListWantedCount,
getWorkList, updWorkListTcS, pushLevelNoWorkList,
TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
failTcS, warnTcS, addErrTcS,
runTcSEqualities,
nestTcS, nestImplicTcS, setEvBindsTcS,
emitImplicationTcS, emitTvImplicationTcS,
runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,
matchGlobalInst, TcM.ClsInstResult(..),
QCInst(..),
panicTcS, traceTcS,
traceFireTcS, bumpStepCountTcS, csTraceTcS,
wrapErrTcS, wrapWarnTcS,
MaybeNew(..), freshGoals, isFresh, getEvExpr,
newTcEvBinds, newNoTcEvBinds,
newWantedEq, newWantedEq_SI, emitNewWantedEq,
newWanted, newWanted_SI, newWantedEvVar,
newWantedNC, newWantedEvVarNC,
newDerivedNC,
newBoundEvVarId,
unifyTyVar, unflattenFmv, reportUnifications,
setEvBind, setWantedEq,
setWantedEvTerm, setEvBindIfWanted,
newEvVar, newGivenEvVar, newGivenEvVars,
emitNewDeriveds, emitNewDerivedEq,
checkReductionDepth,
getSolvedDicts, setSolvedDicts,
getInstEnvs, getFamInstEnvs,
getTopEnv, getGblEnv, getLclEnv,
getTcEvBindsVar, getTcLevel,
getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
tcLookupClass, tcLookupId,
InertSet(..), InertCans(..),
updInertTcS, updInertCans, updInertDicts, updInertIrreds,
getNoGivenEqs, setInertCans,
getInertEqs, getInertCans, getInertGivens,
getInertInsols,
getTcSInerts, setTcSInerts,
matchableGivens, prohibitedSuperClassSolve, mightMatchLater,
getUnsolvedInerts,
removeInertCts, getPendingGivenScs,
addInertCan, insertFunEq, addInertForAll,
emitWorkNC, emitWork,
isImprovable,
kickOutAfterUnification,
addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
getSafeOverlapFailures,
DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,
addDictsByClass, delDict, foldDicts, filterDicts, findDict,
EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,
lookupInertTyVar,
addSolvedDict, lookupSolvedDict,
foldIrreds,
lookupFlatCache, extendFlatCache, newFlattenSkolem,
dischargeFunEq, pprKicked,
updInertFunEqs, findFunEq,
findFunEqsByTyCon,
instDFunType,
newFlexiTcSTy, instFlexi, instFlexiX,
cloneMetaTyVar, demoteUnfilledFmv,
tcInstSkolTyVarsX,
TcLevel,
isFilledMetaTyVar_maybe, isFilledMetaTyVar,
zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
zonkTyCoVarsAndFVList,
zonkSimples, zonkWC,
zonkTyCoVarKind,
newTcRef, readTcRef, writeTcRef, updTcRef,
getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
matchFam, matchFamTcM,
checkWellStagedDFun,
pprEq
) where
#include "HsVersions.h"
import GhcPrelude
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 ClsInst as TcM( matchGlobalInst, ClsInstResult(..) )
import qualified TcEnv as TcM
( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )
import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )
import TcType
import DynFlags
import Type
import Coercion
import Unify
import TcEvidence
import Class
import TyCon
import TcErrors ( solverDepthErrorTcS )
import Name
import Module ( HasModule, getModule )
import RdrName ( GlobalRdrEnv, GlobalRdrElt )
import qualified RnEnv as TcM
import Var
import VarEnv
import VarSet
import Outputable
import Bag
import UniqSupply
import Util
import TcRnTypes
import TcOrigin
import Constraint
import Predicate
import Unique
import UniqFM
import UniqDFM
import Maybes
import CoreMap
import Control.Monad
import qualified Control.Monad.Fail as MonadFail
import MonadUtils
import Data.IORef
import Data.List ( partition, mapAccumL )
#if defined(DEBUG)
import Digraph
import UniqSet
#endif
data WorkList
= WL { WorkList -> [Ct]
wl_eqs :: [Ct]
, WorkList -> [Ct]
wl_funeqs :: [Ct]
, WorkList -> [Ct]
wl_rest :: [Ct]
, WorkList -> Bag Implication
wl_implics :: Bag Implication
}
appendWorkList :: WorkList -> WorkList -> WorkList
appendWorkList :: WorkList -> WorkList -> WorkList
appendWorkList
(WL { wl_eqs :: WorkList -> [Ct]
wl_eqs = [Ct]
eqs1, wl_funeqs :: WorkList -> [Ct]
wl_funeqs = [Ct]
funeqs1, wl_rest :: WorkList -> [Ct]
wl_rest = [Ct]
rest1
, wl_implics :: WorkList -> Bag Implication
wl_implics = Bag Implication
implics1 })
(WL { wl_eqs :: WorkList -> [Ct]
wl_eqs = [Ct]
eqs2, wl_funeqs :: WorkList -> [Ct]
wl_funeqs = [Ct]
funeqs2, wl_rest :: WorkList -> [Ct]
wl_rest = [Ct]
rest2
, wl_implics :: WorkList -> Bag Implication
wl_implics = Bag Implication
implics2 })
= WL :: [Ct] -> [Ct] -> [Ct] -> Bag Implication -> WorkList
WL { wl_eqs :: [Ct]
wl_eqs = [Ct]
eqs1 [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
eqs2
, wl_funeqs :: [Ct]
wl_funeqs = [Ct]
funeqs1 [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
funeqs2
, wl_rest :: [Ct]
wl_rest = [Ct]
rest1 [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
rest2
, wl_implics :: Bag Implication
wl_implics = Bag Implication
implics1 Bag Implication -> Bag Implication -> Bag Implication
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag Implication
implics2 }
workListSize :: WorkList -> Int
workListSize :: WorkList -> Int
workListSize (WL { wl_eqs :: WorkList -> [Ct]
wl_eqs = [Ct]
eqs, wl_funeqs :: WorkList -> [Ct]
wl_funeqs = [Ct]
funeqs, wl_rest :: WorkList -> [Ct]
wl_rest = [Ct]
rest })
= [Ct] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ct]
eqs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Ct] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ct]
funeqs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Ct] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ct]
rest
workListWantedCount :: WorkList -> Int
workListWantedCount :: WorkList -> Int
workListWantedCount (WL { wl_eqs :: WorkList -> [Ct]
wl_eqs = [Ct]
eqs, wl_rest :: WorkList -> [Ct]
wl_rest = [Ct]
rest })
= (Ct -> Bool) -> [Ct] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Ct -> Bool
isWantedCt [Ct]
eqs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Ct -> Bool) -> [Ct] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Ct -> Bool
is_wanted [Ct]
rest
where
is_wanted :: Ct -> Bool
is_wanted Ct
ct
| CIrredCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev, cc_insol :: Ct -> Bool
cc_insol = Bool
insol } <- Ct
ct
= Bool -> Bool
not Bool
insol Bool -> Bool -> Bool
&& CtEvidence -> Bool
isWanted CtEvidence
ev
| Bool
otherwise
= Ct -> Bool
isWantedCt Ct
ct
extendWorkListEq :: Ct -> WorkList -> WorkList
extendWorkListEq :: Ct -> WorkList -> WorkList
extendWorkListEq Ct
ct WorkList
wl = WorkList
wl { wl_eqs :: [Ct]
wl_eqs = Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: WorkList -> [Ct]
wl_eqs WorkList
wl }
extendWorkListFunEq :: Ct -> WorkList -> WorkList
extendWorkListFunEq :: Ct -> WorkList -> WorkList
extendWorkListFunEq Ct
ct WorkList
wl = WorkList
wl { wl_funeqs :: [Ct]
wl_funeqs = Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: WorkList -> [Ct]
wl_funeqs WorkList
wl }
extendWorkListNonEq :: Ct -> WorkList -> WorkList
extendWorkListNonEq :: Ct -> WorkList -> WorkList
extendWorkListNonEq Ct
ct WorkList
wl = WorkList
wl { wl_rest :: [Ct]
wl_rest = Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: WorkList -> [Ct]
wl_rest WorkList
wl }
extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList
extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList
extendWorkListDeriveds [CtEvidence]
evs WorkList
wl
= [Ct] -> WorkList -> WorkList
extendWorkListCts ((CtEvidence -> Ct) -> [CtEvidence] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map CtEvidence -> Ct
mkNonCanonical [CtEvidence]
evs) WorkList
wl
extendWorkListImplic :: Implication -> WorkList -> WorkList
extendWorkListImplic :: Implication -> WorkList -> WorkList
extendWorkListImplic Implication
implic WorkList
wl = WorkList
wl { wl_implics :: Bag Implication
wl_implics = Implication
implic Implication -> Bag Implication -> Bag Implication
forall a. a -> Bag a -> Bag a
`consBag` WorkList -> Bag Implication
wl_implics WorkList
wl }
extendWorkListCt :: Ct -> WorkList -> WorkList
extendWorkListCt :: Ct -> WorkList -> WorkList
extendWorkListCt Ct
ct WorkList
wl
= case PredType -> Pred
classifyPredType (Ct -> PredType
ctPred Ct
ct) of
EqPred EqRel
NomEq PredType
ty1 PredType
_
| Just TyCon
tc <- PredType -> Maybe TyCon
tcTyConAppTyCon_maybe PredType
ty1
, TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
-> Ct -> WorkList -> WorkList
extendWorkListFunEq Ct
ct WorkList
wl
EqPred {}
-> Ct -> WorkList -> WorkList
extendWorkListEq Ct
ct WorkList
wl
ClassPred Class
cls [PredType]
_
| Class -> Bool
isEqPredClass Class
cls
-> Ct -> WorkList -> WorkList
extendWorkListEq Ct
ct WorkList
wl
Pred
_ -> Ct -> WorkList -> WorkList
extendWorkListNonEq Ct
ct WorkList
wl
extendWorkListCts :: [Ct] -> WorkList -> WorkList
extendWorkListCts :: [Ct] -> WorkList -> WorkList
extendWorkListCts [Ct]
cts WorkList
wl = (Ct -> WorkList -> WorkList) -> WorkList -> [Ct] -> WorkList
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ct -> WorkList -> WorkList
extendWorkListCt WorkList
wl [Ct]
cts
isEmptyWorkList :: WorkList -> Bool
isEmptyWorkList :: WorkList -> Bool
isEmptyWorkList (WL { wl_eqs :: WorkList -> [Ct]
wl_eqs = [Ct]
eqs, wl_funeqs :: WorkList -> [Ct]
wl_funeqs = [Ct]
funeqs
, wl_rest :: WorkList -> [Ct]
wl_rest = [Ct]
rest, wl_implics :: WorkList -> Bag Implication
wl_implics = Bag Implication
implics })
= [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
eqs Bool -> Bool -> Bool
&& [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
rest Bool -> Bool -> Bool
&& [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
funeqs Bool -> Bool -> Bool
&& Bag Implication -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag Implication
implics
emptyWorkList :: WorkList
emptyWorkList :: WorkList
emptyWorkList = WL :: [Ct] -> [Ct] -> [Ct] -> Bag Implication -> WorkList
WL { wl_eqs :: [Ct]
wl_eqs = [], wl_rest :: [Ct]
wl_rest = []
, wl_funeqs :: [Ct]
wl_funeqs = [], wl_implics :: Bag Implication
wl_implics = Bag Implication
forall a. Bag a
emptyBag }
selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
selectWorkItem wl :: WorkList
wl@(WL { wl_eqs :: WorkList -> [Ct]
wl_eqs = [Ct]
eqs, wl_funeqs :: WorkList -> [Ct]
wl_funeqs = [Ct]
feqs
, wl_rest :: WorkList -> [Ct]
wl_rest = [Ct]
rest })
| Ct
ct:[Ct]
cts <- [Ct]
eqs = (Ct, WorkList) -> Maybe (Ct, WorkList)
forall a. a -> Maybe a
Just (Ct
ct, WorkList
wl { wl_eqs :: [Ct]
wl_eqs = [Ct]
cts })
| Ct
ct:[Ct]
fes <- [Ct]
feqs = (Ct, WorkList) -> Maybe (Ct, WorkList)
forall a. a -> Maybe a
Just (Ct
ct, WorkList
wl { wl_funeqs :: [Ct]
wl_funeqs = [Ct]
fes })
| Ct
ct:[Ct]
cts <- [Ct]
rest = (Ct, WorkList) -> Maybe (Ct, WorkList)
forall a. a -> Maybe a
Just (Ct
ct, WorkList
wl { wl_rest :: [Ct]
wl_rest = [Ct]
cts })
| Bool
otherwise = Maybe (Ct, WorkList)
forall a. Maybe a
Nothing
getWorkList :: TcS WorkList
getWorkList :: TcS WorkList
getWorkList = do { IORef WorkList
wl_var <- TcS (IORef WorkList)
getTcSWorkListRef
; TcM WorkList -> TcS WorkList
forall a. TcM a -> TcS a
wrapTcS (IORef WorkList -> TcM WorkList
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef WorkList
wl_var) }
selectNextWorkItem :: TcS (Maybe Ct)
selectNextWorkItem :: TcS (Maybe Ct)
selectNextWorkItem
= do { IORef WorkList
wl_var <- TcS (IORef WorkList)
getTcSWorkListRef
; WorkList
wl <- IORef WorkList -> TcS WorkList
forall a. TcRef a -> TcS a
readTcRef IORef WorkList
wl_var
; case WorkList -> Maybe (Ct, WorkList)
selectWorkItem WorkList
wl of {
Maybe (Ct, WorkList)
Nothing -> Maybe Ct -> TcS (Maybe Ct)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Ct
forall a. Maybe a
Nothing ;
Just (Ct
ct, WorkList
new_wl) ->
do {
; IORef WorkList -> WorkList -> TcS ()
forall a. TcRef a -> a -> TcS ()
writeTcRef IORef WorkList
wl_var WorkList
new_wl
; Maybe Ct -> TcS (Maybe Ct)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ct -> Maybe Ct
forall a. a -> Maybe a
Just Ct
ct) } } }
instance Outputable WorkList where
ppr :: WorkList -> SDoc
ppr (WL { wl_eqs :: WorkList -> [Ct]
wl_eqs = [Ct]
eqs, wl_funeqs :: WorkList -> [Ct]
wl_funeqs = [Ct]
feqs
, wl_rest :: WorkList -> [Ct]
wl_rest = [Ct]
rest, wl_implics :: WorkList -> Bag Implication
wl_implics = Bag Implication
implics })
= String -> SDoc
text String
"WL" SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppUnless ([Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
eqs) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Eqs =" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((Ct -> SDoc) -> [Ct] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
eqs)
, Bool -> SDoc -> SDoc
ppUnless ([Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
feqs) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Funeqs =" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((Ct -> SDoc) -> [Ct] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
feqs)
, Bool -> SDoc -> SDoc
ppUnless ([Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
rest) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Non-eqs =" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((Ct -> SDoc) -> [Ct] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
rest)
, Bool -> SDoc -> SDoc
ppUnless (Bag Implication -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag Implication
implics) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> SDoc -> SDoc
ifPprDebug (String -> SDoc
text String
"Implics =" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((Implication -> SDoc) -> [Implication] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Implication -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Bag Implication -> [Implication]
forall a. Bag a -> [a]
bagToList Bag Implication
implics)))
(String -> SDoc
text String
"(Implics omitted)")
])
data InertSet
= IS { InertSet -> InertCans
inert_cans :: InertCans
, InertSet -> [(TcTyVar, PredType)]
inert_fsks :: [(TcTyVar, TcType)]
, InertSet -> ExactFunEqMap (TcCoercion, PredType, CtFlavour)
inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
, InertSet -> DictMap CtEvidence
inert_solved_dicts :: DictMap CtEvidence
}
instance Outputable InertSet where
ppr :: InertSet -> SDoc
ppr (IS { inert_cans :: InertSet -> InertCans
inert_cans = InertCans
ics
, inert_fsks :: InertSet -> [(TcTyVar, PredType)]
inert_fsks = [(TcTyVar, PredType)]
ifsks
, inert_solved_dicts :: InertSet -> DictMap CtEvidence
inert_solved_dicts = DictMap CtEvidence
solved_dicts })
= [SDoc] -> SDoc
vcat [ InertCans -> SDoc
forall a. Outputable a => a -> SDoc
ppr InertCans
ics
, String -> SDoc
text String
"Inert fsks =" SDoc -> SDoc -> SDoc
<+> [(TcTyVar, PredType)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(TcTyVar, PredType)]
ifsks
, Bool -> SDoc -> SDoc
ppUnless ([CtEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CtEvidence]
dicts) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Solved dicts =" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((CtEvidence -> SDoc) -> [CtEvidence] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CtEvidence -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CtEvidence]
dicts) ]
where
dicts :: [CtEvidence]
dicts = Bag CtEvidence -> [CtEvidence]
forall a. Bag a -> [a]
bagToList (DictMap CtEvidence -> Bag CtEvidence
forall a. DictMap a -> Bag a
dictsToBag DictMap CtEvidence
solved_dicts)
emptyInertCans :: InertCans
emptyInertCans :: InertCans
emptyInertCans
= IC :: InertEqs
-> FunEqMap Ct
-> FunEqMap Ct
-> [QCInst]
-> FunEqMap Ct
-> Cts
-> Int
-> InertCans
IC { inert_count :: Int
inert_count = Int
0
, inert_eqs :: InertEqs
inert_eqs = InertEqs
forall a. DVarEnv a
emptyDVarEnv
, inert_dicts :: FunEqMap Ct
inert_dicts = FunEqMap Ct
forall a. DictMap a
emptyDicts
, inert_safehask :: FunEqMap Ct
inert_safehask = FunEqMap Ct
forall a. DictMap a
emptyDicts
, inert_funeqs :: FunEqMap Ct
inert_funeqs = FunEqMap Ct
forall a. DictMap a
emptyFunEqs
, inert_insts :: [QCInst]
inert_insts = []
, inert_irreds :: Cts
inert_irreds = Cts
emptyCts }
emptyInert :: InertSet
emptyInert :: InertSet
emptyInert
= IS :: InertCans
-> [(TcTyVar, PredType)]
-> ExactFunEqMap (TcCoercion, PredType, CtFlavour)
-> DictMap CtEvidence
-> InertSet
IS { inert_cans :: InertCans
inert_cans = InertCans
emptyInertCans
, inert_fsks :: [(TcTyVar, PredType)]
inert_fsks = []
, inert_flat_cache :: ExactFunEqMap (TcCoercion, PredType, CtFlavour)
inert_flat_cache = ExactFunEqMap (TcCoercion, PredType, CtFlavour)
forall a. ExactFunEqMap a
emptyExactFunEqs
, inert_solved_dicts :: DictMap CtEvidence
inert_solved_dicts = DictMap CtEvidence
forall a. DictMap a
emptyDictMap }
data InertCans
= IC { InertCans -> InertEqs
inert_eqs :: InertEqs
, InertCans -> FunEqMap Ct
inert_funeqs :: FunEqMap Ct
, InertCans -> FunEqMap Ct
inert_dicts :: DictMap Ct
, InertCans -> [QCInst]
inert_insts :: [QCInst]
, InertCans -> FunEqMap Ct
inert_safehask :: DictMap Ct
, InertCans -> Cts
inert_irreds :: Cts
, InertCans -> Int
inert_count :: Int
}
type InertEqs = DTyVarEnv EqualCtList
type EqualCtList = [Ct]
instance Outputable InertCans where
ppr :: InertCans -> SDoc
ppr (IC { inert_eqs :: InertCans -> InertEqs
inert_eqs = InertEqs
eqs
, inert_funeqs :: InertCans -> FunEqMap Ct
inert_funeqs = FunEqMap Ct
funeqs, inert_dicts :: InertCans -> FunEqMap Ct
inert_dicts = FunEqMap Ct
dicts
, inert_safehask :: InertCans -> FunEqMap Ct
inert_safehask = FunEqMap Ct
safehask, inert_irreds :: InertCans -> Cts
inert_irreds = Cts
irreds
, inert_insts :: InertCans -> [QCInst]
inert_insts = [QCInst]
insts
, inert_count :: InertCans -> Int
inert_count = Int
count })
= SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ Bool -> SDoc -> SDoc
ppUnless (InertEqs -> Bool
forall a. DVarEnv a -> Bool
isEmptyDVarEnv InertEqs
eqs) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Equalities:"
SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
pprCts (([Ct] -> Cts -> Cts) -> Cts -> InertEqs -> Cts
forall a b. (a -> b -> b) -> b -> DVarEnv a -> b
foldDVarEnv (\[Ct]
eqs Cts
rest -> [Ct] -> Cts
forall a. [a] -> Bag a
listToBag [Ct]
eqs Cts -> Cts -> Cts
`andCts` Cts
rest) Cts
emptyCts InertEqs
eqs)
, Bool -> SDoc -> SDoc
ppUnless (FunEqMap Ct -> Bool
forall a. TcAppMap a -> Bool
isEmptyTcAppMap FunEqMap Ct
funeqs) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Type-function equalities =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
pprCts (FunEqMap Ct -> Cts
forall a. DictMap a -> Bag a
funEqsToBag FunEqMap Ct
funeqs)
, Bool -> SDoc -> SDoc
ppUnless (FunEqMap Ct -> Bool
forall a. TcAppMap a -> Bool
isEmptyTcAppMap FunEqMap Ct
dicts) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Dictionaries =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
pprCts (FunEqMap Ct -> Cts
forall a. DictMap a -> Bag a
dictsToBag FunEqMap Ct
dicts)
, Bool -> SDoc -> SDoc
ppUnless (FunEqMap Ct -> Bool
forall a. TcAppMap a -> Bool
isEmptyTcAppMap FunEqMap Ct
safehask) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Safe Haskell unsafe overlap =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
pprCts (FunEqMap Ct -> Cts
forall a. DictMap a -> Bag a
dictsToBag FunEqMap Ct
safehask)
, Bool -> SDoc -> SDoc
ppUnless (Cts -> Bool
isEmptyCts Cts
irreds) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Irreds =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
pprCts Cts
irreds
, Bool -> SDoc -> SDoc
ppUnless ([QCInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QCInst]
insts) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Given instances =" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((QCInst -> SDoc) -> [QCInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map QCInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr [QCInst]
insts)
, String -> SDoc
text String
"Unsolved goals =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
count
]
maybeEmitShadow :: InertCans -> Ct -> TcS Ct
maybeEmitShadow :: InertCans -> Ct -> TcS Ct
maybeEmitShadow InertCans
ics Ct
ct
| let ev :: CtEvidence
ev = Ct -> CtEvidence
ctEvidence Ct
ct
, CtWanted { ctev_pred :: CtEvidence -> PredType
ctev_pred = PredType
pred, ctev_loc :: CtEvidence -> CtLoc
ctev_loc = CtLoc
loc
, ctev_nosh :: CtEvidence -> ShadowInfo
ctev_nosh = ShadowInfo
WDeriv } <- CtEvidence
ev
, InertEqs -> Ct -> Bool
shouldSplitWD (InertCans -> InertEqs
inert_eqs InertCans
ics) Ct
ct
= do { String -> SDoc -> TcS ()
traceTcS String
"Emit derived shadow" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
; let derived_ev :: CtEvidence
derived_ev = CtDerived :: PredType -> CtLoc -> CtEvidence
CtDerived { ctev_pred :: PredType
ctev_pred = PredType
pred
, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }
shadow_ct :: Ct
shadow_ct = Ct
ct { cc_ev :: CtEvidence
cc_ev = CtEvidence
derived_ev }
; [Ct] -> TcS ()
emitWork [Ct
shadow_ct]
; let ev' :: CtEvidence
ev' = CtEvidence
ev { ctev_nosh :: ShadowInfo
ctev_nosh = ShadowInfo
WOnly }
ct' :: Ct
ct' = Ct
ct { cc_ev :: CtEvidence
cc_ev = CtEvidence
ev' }
; Ct -> TcS Ct
forall (m :: * -> *) a. Monad m => a -> m a
return Ct
ct' }
| Bool
otherwise
= Ct -> TcS Ct
forall (m :: * -> *) a. Monad m => a -> m a
return Ct
ct
shouldSplitWD :: InertEqs -> Ct -> Bool
shouldSplitWD :: InertEqs -> Ct -> Bool
shouldSplitWD InertEqs
inert_eqs (CFunEqCan { cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys })
= InertEqs -> [PredType] -> Bool
should_split_match_args InertEqs
inert_eqs [PredType]
tys
shouldSplitWD InertEqs
inert_eqs (CDictCan { cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys })
= InertEqs -> [PredType] -> Bool
should_split_match_args InertEqs
inert_eqs [PredType]
tys
shouldSplitWD InertEqs
inert_eqs (CTyEqCan { cc_tyvar :: Ct -> TcTyVar
cc_tyvar = TcTyVar
tv, cc_rhs :: Ct -> PredType
cc_rhs = PredType
ty
, cc_eq_rel :: Ct -> EqRel
cc_eq_rel = EqRel
eq_rel })
= TcTyVar
tv TcTyVar -> InertEqs -> Bool
forall a. TcTyVar -> DVarEnv a -> Bool
`elemDVarEnv` InertEqs
inert_eqs
Bool -> Bool -> Bool
|| Bool -> EqRel -> (EqRel -> TcTyVar -> Bool) -> PredType -> Bool
anyRewritableTyVar Bool
False EqRel
eq_rel (InertEqs -> EqRel -> TcTyVar -> Bool
canRewriteTv InertEqs
inert_eqs) PredType
ty
shouldSplitWD InertEqs
inert_eqs (CIrredCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev })
= Bool -> EqRel -> (EqRel -> TcTyVar -> Bool) -> PredType -> Bool
anyRewritableTyVar Bool
False (CtEvidence -> EqRel
ctEvEqRel CtEvidence
ev) (InertEqs -> EqRel -> TcTyVar -> Bool
canRewriteTv InertEqs
inert_eqs) (CtEvidence -> PredType
ctEvPred CtEvidence
ev)
shouldSplitWD InertEqs
_ Ct
_ = Bool
False
should_split_match_args :: InertEqs -> [TcType] -> Bool
should_split_match_args :: InertEqs -> [PredType] -> Bool
should_split_match_args InertEqs
inert_eqs [PredType]
tys
= (PredType -> Bool) -> [PredType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> EqRel -> (EqRel -> TcTyVar -> Bool) -> PredType -> Bool
anyRewritableTyVar Bool
True EqRel
NomEq (InertEqs -> EqRel -> TcTyVar -> Bool
canRewriteTv InertEqs
inert_eqs)) [PredType]
tys
canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool
canRewriteTv :: InertEqs -> EqRel -> TcTyVar -> Bool
canRewriteTv InertEqs
inert_eqs EqRel
eq_rel TcTyVar
tv
| Just (Ct
ct : [Ct]
_) <- InertEqs -> TcTyVar -> Maybe [Ct]
forall a. DVarEnv a -> TcTyVar -> Maybe a
lookupDVarEnv InertEqs
inert_eqs TcTyVar
tv
, CTyEqCan { cc_eq_rel :: Ct -> EqRel
cc_eq_rel = EqRel
eq_rel1 } <- Ct
ct
= EqRel
eq_rel1 EqRel -> EqRel -> Bool
`eqCanRewrite` EqRel
eq_rel
| Bool
otherwise
= Bool
False
isImprovable :: CtEvidence -> Bool
isImprovable :: CtEvidence -> Bool
isImprovable (CtWanted { ctev_nosh :: CtEvidence -> ShadowInfo
ctev_nosh = ShadowInfo
WOnly }) = Bool
False
isImprovable CtEvidence
_ = Bool
True
addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs
addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs
addTyEq InertEqs
old_eqs TcTyVar
tv Ct
ct
= ([Ct] -> [Ct] -> [Ct]) -> InertEqs -> TcTyVar -> [Ct] -> InertEqs
forall a. (a -> a -> a) -> DVarEnv a -> TcTyVar -> a -> DVarEnv a
extendDVarEnv_C [Ct] -> [Ct] -> [Ct]
add_eq InertEqs
old_eqs TcTyVar
tv [Ct
ct]
where
add_eq :: [Ct] -> [Ct] -> [Ct]
add_eq [Ct]
old_eqs [Ct]
_
| Ct -> Bool
isWantedCt Ct
ct
, (Ct
eq1 : [Ct]
eqs) <- [Ct]
old_eqs
= Ct
eq1 Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
eqs
| Bool
otherwise
= Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
old_eqs
foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b
foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b
foldTyEqs Ct -> b -> b
k InertEqs
eqs b
z
= ([Ct] -> b -> b) -> b -> InertEqs -> b
forall a b. (a -> b -> b) -> b -> DVarEnv a -> b
foldDVarEnv (\[Ct]
cts b
z -> (Ct -> b -> b) -> b -> [Ct] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ct -> b -> b
k b
z [Ct]
cts) b
z InertEqs
eqs
findTyEqs :: InertCans -> TyVar -> EqualCtList
findTyEqs :: InertCans -> TcTyVar -> [Ct]
findTyEqs InertCans
icans TcTyVar
tv = InertEqs -> TcTyVar -> Maybe [Ct]
forall a. DVarEnv a -> TcTyVar -> Maybe a
lookupDVarEnv (InertCans -> InertEqs
inert_eqs InertCans
icans) TcTyVar
tv Maybe [Ct] -> [Ct] -> [Ct]
forall a. Maybe a -> a -> a
`orElse` []
delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs
delTyEq :: InertEqs -> TcTyVar -> PredType -> InertEqs
delTyEq InertEqs
m TcTyVar
tv PredType
t = ([Ct] -> [Ct]) -> InertEqs -> TcTyVar -> InertEqs
forall a. (a -> a) -> DVarEnv a -> TcTyVar -> DVarEnv a
modifyDVarEnv ((Ct -> Bool) -> [Ct] -> [Ct]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Ct -> Bool) -> Ct -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> Bool
isThisOne)) InertEqs
m TcTyVar
tv
where isThisOne :: Ct -> Bool
isThisOne (CTyEqCan { cc_rhs :: Ct -> PredType
cc_rhs = PredType
t1 }) = PredType -> PredType -> Bool
eqType PredType
t PredType
t1
isThisOne Ct
_ = Bool
False
lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType
lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe PredType
lookupInertTyVar InertEqs
ieqs TcTyVar
tv
= case InertEqs -> TcTyVar -> Maybe [Ct]
forall a. DVarEnv a -> TcTyVar -> Maybe a
lookupDVarEnv InertEqs
ieqs TcTyVar
tv of
Just (CTyEqCan { cc_rhs :: Ct -> PredType
cc_rhs = PredType
rhs, cc_eq_rel :: Ct -> EqRel
cc_eq_rel = EqRel
NomEq } : [Ct]
_ ) -> PredType -> Maybe PredType
forall a. a -> Maybe a
Just PredType
rhs
Maybe [Ct]
_ -> Maybe PredType
forall a. Maybe a
Nothing
addInertForAll :: QCInst -> TcS ()
addInertForAll :: QCInst -> TcS ()
addInertForAll QCInst
new_qci
= (InertCans -> InertCans) -> TcS ()
updInertCans ((InertCans -> InertCans) -> TcS ())
-> (InertCans -> InertCans) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \InertCans
ics ->
InertCans
ics { inert_insts :: [QCInst]
inert_insts = [QCInst] -> [QCInst]
add_qci (InertCans -> [QCInst]
inert_insts InertCans
ics) }
where
add_qci :: [QCInst] -> [QCInst]
add_qci :: [QCInst] -> [QCInst]
add_qci [QCInst]
qcis | (QCInst -> Bool) -> [QCInst] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any QCInst -> Bool
same_qci [QCInst]
qcis = [QCInst]
qcis
| Bool
otherwise = QCInst
new_qci QCInst -> [QCInst] -> [QCInst]
forall a. a -> [a] -> [a]
: [QCInst]
qcis
same_qci :: QCInst -> Bool
same_qci QCInst
old_qci = HasDebugCallStack => PredType -> PredType -> Bool
PredType -> PredType -> Bool
tcEqType (CtEvidence -> PredType
ctEvPred (QCInst -> CtEvidence
qci_ev QCInst
old_qci))
(CtEvidence -> PredType
ctEvPred (QCInst -> CtEvidence
qci_ev QCInst
new_qci))
addInertCan :: Ct -> TcS ()
addInertCan :: Ct -> TcS ()
addInertCan Ct
ct
= do { String -> SDoc -> TcS ()
traceTcS String
"insertInertCan {" (SDoc -> TcS ()) -> SDoc -> TcS ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Trying to insert new inert item:" SDoc -> SDoc -> SDoc
<+> Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct
; InertCans
ics <- TcS InertCans
getInertCans
; Ct
ct <- InertCans -> Ct -> TcS Ct
maybeEmitShadow InertCans
ics Ct
ct
; InertCans
ics <- InertCans -> Ct -> TcS InertCans
maybeKickOut InertCans
ics Ct
ct
; InertCans -> TcS ()
setInertCans (InertCans -> Ct -> InertCans
add_item InertCans
ics Ct
ct)
; String -> SDoc -> TcS ()
traceTcS String
"addInertCan }" (SDoc -> TcS ()) -> SDoc -> TcS ()
forall a b. (a -> b) -> a -> b
$ SDoc
empty }
maybeKickOut :: InertCans -> Ct -> TcS InertCans
maybeKickOut :: InertCans -> Ct -> TcS InertCans
maybeKickOut InertCans
ics Ct
ct
| CTyEqCan { cc_tyvar :: Ct -> TcTyVar
cc_tyvar = TcTyVar
tv, cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev, cc_eq_rel :: Ct -> EqRel
cc_eq_rel = EqRel
eq_rel } <- Ct
ct
= do { (Int
_, InertCans
ics') <- CtFlavourRole -> TcTyVar -> InertCans -> TcS (Int, InertCans)
kickOutRewritable (CtEvidence -> CtFlavour
ctEvFlavour CtEvidence
ev, EqRel
eq_rel) TcTyVar
tv InertCans
ics
; InertCans -> TcS InertCans
forall (m :: * -> *) a. Monad m => a -> m a
return InertCans
ics' }
| Bool
otherwise
= InertCans -> TcS InertCans
forall (m :: * -> *) a. Monad m => a -> m a
return InertCans
ics
add_item :: InertCans -> Ct -> InertCans
add_item :: InertCans -> Ct -> InertCans
add_item InertCans
ics item :: Ct
item@(CFunEqCan { cc_fun :: Ct -> TyCon
cc_fun = TyCon
tc, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys })
= InertCans
ics { inert_funeqs :: FunEqMap Ct
inert_funeqs = FunEqMap Ct -> TyCon -> [PredType] -> Ct -> FunEqMap Ct
forall a. FunEqMap a -> TyCon -> [PredType] -> a -> FunEqMap a
insertFunEq (InertCans -> FunEqMap Ct
inert_funeqs InertCans
ics) TyCon
tc [PredType]
tys Ct
item }
add_item InertCans
ics item :: Ct
item@(CTyEqCan { cc_tyvar :: Ct -> TcTyVar
cc_tyvar = TcTyVar
tv, cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev })
= InertCans
ics { inert_eqs :: InertEqs
inert_eqs = InertEqs -> TcTyVar -> Ct -> InertEqs
addTyEq (InertCans -> InertEqs
inert_eqs InertCans
ics) TcTyVar
tv Ct
item
, inert_count :: Int
inert_count = CtEvidence -> Int -> Int
bumpUnsolvedCount CtEvidence
ev (InertCans -> Int
inert_count InertCans
ics) }
add_item ics :: InertCans
ics@(IC { inert_irreds :: InertCans -> Cts
inert_irreds = Cts
irreds, inert_count :: InertCans -> Int
inert_count = Int
count })
item :: Ct
item@(CIrredCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev, cc_insol :: Ct -> Bool
cc_insol = Bool
insoluble })
= InertCans
ics { inert_irreds :: Cts
inert_irreds = Cts
irreds Cts -> Ct -> Cts
forall a. Bag a -> a -> Bag a
`Bag.snocBag` Ct
item
, inert_count :: Int
inert_count = if Bool
insoluble
then Int
count
else CtEvidence -> Int -> Int
bumpUnsolvedCount CtEvidence
ev Int
count }
add_item InertCans
ics item :: Ct
item@(CDictCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev, cc_class :: Ct -> Class
cc_class = Class
cls, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys })
= InertCans
ics { inert_dicts :: FunEqMap Ct
inert_dicts = FunEqMap Ct -> Class -> [PredType] -> Ct -> FunEqMap Ct
forall a. DictMap a -> Class -> [PredType] -> a -> DictMap a
addDict (InertCans -> FunEqMap Ct
inert_dicts InertCans
ics) Class
cls [PredType]
tys Ct
item
, inert_count :: Int
inert_count = CtEvidence -> Int -> Int
bumpUnsolvedCount CtEvidence
ev (InertCans -> Int
inert_count InertCans
ics) }
add_item InertCans
_ Ct
item
= String -> SDoc -> InertCans
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"upd_inert set: can't happen! Inserting " (SDoc -> InertCans) -> SDoc -> InertCans
forall a b. (a -> b) -> a -> b
$
Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
item
bumpUnsolvedCount :: CtEvidence -> Int -> Int
bumpUnsolvedCount :: CtEvidence -> Int -> Int
bumpUnsolvedCount CtEvidence
ev Int
n | CtEvidence -> Bool
isWanted CtEvidence
ev = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
| Bool
otherwise = Int
n
kickOutRewritable :: CtFlavourRole
-> TcTyVar
-> InertCans
-> TcS (Int, InertCans)
kickOutRewritable :: CtFlavourRole -> TcTyVar -> InertCans -> TcS (Int, InertCans)
kickOutRewritable CtFlavourRole
new_fr TcTyVar
new_tv InertCans
ics
= do { let (WorkList
kicked_out, InertCans
ics') = CtFlavourRole -> TcTyVar -> InertCans -> (WorkList, InertCans)
kick_out_rewritable CtFlavourRole
new_fr TcTyVar
new_tv InertCans
ics
n_kicked :: Int
n_kicked = WorkList -> Int
workListSize WorkList
kicked_out
; Bool -> TcS () -> TcS ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_kicked Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (TcS () -> TcS ()) -> TcS () -> TcS ()
forall a b. (a -> b) -> a -> b
$
do { (WorkList -> WorkList) -> TcS ()
updWorkListTcS (WorkList -> WorkList -> WorkList
appendWorkList WorkList
kicked_out)
; SDoc -> TcS ()
csTraceTcS (SDoc -> TcS ()) -> SDoc -> TcS ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Kick out, tv =" SDoc -> SDoc -> SDoc
<+> TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
new_tv)
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"n-kicked =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n_kicked
, String -> SDoc
text String
"kicked_out =" SDoc -> SDoc -> SDoc
<+> WorkList -> SDoc
forall a. Outputable a => a -> SDoc
ppr WorkList
kicked_out
, String -> SDoc
text String
"Residual inerts =" SDoc -> SDoc -> SDoc
<+> InertCans -> SDoc
forall a. Outputable a => a -> SDoc
ppr InertCans
ics' ]) }
; (Int, InertCans) -> TcS (Int, InertCans)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n_kicked, InertCans
ics') }
kick_out_rewritable :: CtFlavourRole
-> TcTyVar
-> InertCans
-> (WorkList, InertCans)
kick_out_rewritable :: CtFlavourRole -> TcTyVar -> InertCans -> (WorkList, InertCans)
kick_out_rewritable CtFlavourRole
new_fr TcTyVar
new_tv
ics :: InertCans
ics@(IC { inert_eqs :: InertCans -> InertEqs
inert_eqs = InertEqs
tv_eqs
, inert_dicts :: InertCans -> FunEqMap Ct
inert_dicts = FunEqMap Ct
dictmap
, inert_safehask :: InertCans -> FunEqMap Ct
inert_safehask = FunEqMap Ct
safehask
, inert_funeqs :: InertCans -> FunEqMap Ct
inert_funeqs = FunEqMap Ct
funeqmap
, inert_irreds :: InertCans -> Cts
inert_irreds = Cts
irreds
, inert_insts :: InertCans -> [QCInst]
inert_insts = [QCInst]
old_insts
, inert_count :: InertCans -> Int
inert_count = Int
n })
| Bool -> Bool
not (CtFlavourRole
new_fr CtFlavourRole -> CtFlavourRole -> Bool
`eqMayRewriteFR` CtFlavourRole
new_fr)
= (WorkList
emptyWorkList, InertCans
ics)
| Bool
otherwise
= (WorkList
kicked_out, InertCans
inert_cans_in)
where
inert_cans_in :: InertCans
inert_cans_in = IC :: InertEqs
-> FunEqMap Ct
-> FunEqMap Ct
-> [QCInst]
-> FunEqMap Ct
-> Cts
-> Int
-> InertCans
IC { inert_eqs :: InertEqs
inert_eqs = InertEqs
tv_eqs_in
, inert_dicts :: FunEqMap Ct
inert_dicts = FunEqMap Ct
dicts_in
, inert_safehask :: FunEqMap Ct
inert_safehask = FunEqMap Ct
safehask
, inert_funeqs :: FunEqMap Ct
inert_funeqs = FunEqMap Ct
feqs_in
, inert_irreds :: Cts
inert_irreds = Cts
irs_in
, inert_insts :: [QCInst]
inert_insts = [QCInst]
insts_in
, inert_count :: Int
inert_count = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- WorkList -> Int
workListWantedCount WorkList
kicked_out }
kicked_out :: WorkList
kicked_out :: WorkList
kicked_out = (Ct -> WorkList -> WorkList) -> WorkList -> Cts -> WorkList
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ct -> WorkList -> WorkList
extendWorkListCt
(WorkList
emptyWorkList { wl_eqs :: [Ct]
wl_eqs = [Ct]
tv_eqs_out
, wl_funeqs :: [Ct]
wl_funeqs = [Ct]
feqs_out })
((Cts
dicts_out Cts -> Cts -> Cts
`andCts` Cts
irs_out)
Cts -> [Ct] -> Cts
`extendCtsList` [Ct]
insts_out)
([Ct]
tv_eqs_out, InertEqs
tv_eqs_in) = ([Ct] -> ([Ct], InertEqs) -> ([Ct], InertEqs))
-> ([Ct], InertEqs) -> InertEqs -> ([Ct], InertEqs)
forall a b. (a -> b -> b) -> b -> DVarEnv a -> b
foldDVarEnv [Ct] -> ([Ct], InertEqs) -> ([Ct], InertEqs)
kick_out_eqs ([], InertEqs
forall a. DVarEnv a
emptyDVarEnv) InertEqs
tv_eqs
([Ct]
feqs_out, FunEqMap Ct
feqs_in) = (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
partitionFunEqs Ct -> Bool
kick_out_ct FunEqMap Ct
funeqmap
(Cts
dicts_out, FunEqMap Ct
dicts_in) = (Ct -> Bool) -> FunEqMap Ct -> (Cts, FunEqMap Ct)
partitionDicts Ct -> Bool
kick_out_ct FunEqMap Ct
dictmap
(Cts
irs_out, Cts
irs_in) = (Ct -> Bool) -> Cts -> (Cts, Cts)
forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag Ct -> Bool
kick_out_ct Cts
irreds
insts_out :: [Ct]
insts_in :: [QCInst]
([Ct]
insts_out, [QCInst]
insts_in)
| CtFlavourRole -> Bool
fr_may_rewrite (CtFlavour
Given, EqRel
NomEq)
= (QCInst -> Either Ct QCInst) -> [QCInst] -> ([Ct], [QCInst])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith QCInst -> Either Ct QCInst
kick_out_qci [QCInst]
old_insts
| Bool
otherwise
= ([], [QCInst]
old_insts)
kick_out_qci :: QCInst -> Either Ct QCInst
kick_out_qci QCInst
qci
| let ev :: CtEvidence
ev = QCInst -> CtEvidence
qci_ev QCInst
qci
, EqRel -> PredType -> Bool
fr_can_rewrite_ty EqRel
NomEq (CtEvidence -> PredType
ctEvPred (QCInst -> CtEvidence
qci_ev QCInst
qci))
= Ct -> Either Ct QCInst
forall a b. a -> Either a b
Left (CtEvidence -> Ct
mkNonCanonical CtEvidence
ev)
| Bool
otherwise
= QCInst -> Either Ct QCInst
forall a b. b -> Either a b
Right QCInst
qci
(CtFlavour
_, EqRel
new_role) = CtFlavourRole
new_fr
fr_can_rewrite_ty :: EqRel -> Type -> Bool
fr_can_rewrite_ty :: EqRel -> PredType -> Bool
fr_can_rewrite_ty EqRel
role PredType
ty = Bool -> EqRel -> (EqRel -> TcTyVar -> Bool) -> PredType -> Bool
anyRewritableTyVar Bool
False EqRel
role
EqRel -> TcTyVar -> Bool
fr_can_rewrite_tv PredType
ty
fr_can_rewrite_tv :: EqRel -> TyVar -> Bool
fr_can_rewrite_tv :: EqRel -> TcTyVar -> Bool
fr_can_rewrite_tv EqRel
role TcTyVar
tv = EqRel
new_role EqRel -> EqRel -> Bool
`eqCanRewrite` EqRel
role
Bool -> Bool -> Bool
&& TcTyVar
tv TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
new_tv
fr_may_rewrite :: CtFlavourRole -> Bool
fr_may_rewrite :: CtFlavourRole -> Bool
fr_may_rewrite CtFlavourRole
fs = CtFlavourRole
new_fr CtFlavourRole -> CtFlavourRole -> Bool
`eqMayRewriteFR` CtFlavourRole
fs
kick_out_ct :: Ct -> Bool
kick_out_ct :: Ct -> Bool
kick_out_ct Ct
ct | let fs :: CtFlavourRole
fs@(CtFlavour
_,EqRel
role) = Ct -> CtFlavourRole
ctFlavourRole Ct
ct
= CtFlavourRole -> Bool
fr_may_rewrite CtFlavourRole
fs
Bool -> Bool -> Bool
&& EqRel -> PredType -> Bool
fr_can_rewrite_ty EqRel
role (Ct -> PredType
ctPred Ct
ct)
kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)
-> ([Ct], DTyVarEnv EqualCtList)
kick_out_eqs :: [Ct] -> ([Ct], InertEqs) -> ([Ct], InertEqs)
kick_out_eqs [Ct]
eqs ([Ct]
acc_out, InertEqs
acc_in)
= ([Ct]
eqs_out [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
acc_out, case [Ct]
eqs_in of
[] -> InertEqs
acc_in
(Ct
eq1:[Ct]
_) -> InertEqs -> TcTyVar -> [Ct] -> InertEqs
forall a. DVarEnv a -> TcTyVar -> a -> DVarEnv a
extendDVarEnv InertEqs
acc_in (Ct -> TcTyVar
cc_tyvar Ct
eq1) [Ct]
eqs_in)
where
([Ct]
eqs_out, [Ct]
eqs_in) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Ct -> Bool
kick_out_eq [Ct]
eqs
kick_out_eq :: Ct -> Bool
kick_out_eq (CTyEqCan { cc_tyvar :: Ct -> TcTyVar
cc_tyvar = TcTyVar
tv, cc_rhs :: Ct -> PredType
cc_rhs = PredType
rhs_ty
, cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev, cc_eq_rel :: Ct -> EqRel
cc_eq_rel = EqRel
eq_rel })
| Bool -> Bool
not (CtFlavourRole -> Bool
fr_may_rewrite CtFlavourRole
fs)
= Bool
False
| TcTyVar
tv TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
new_tv = Bool
True
| Bool
kick_out_for_inertness = Bool
True
| Bool
kick_out_for_completeness = Bool
True
| Bool
otherwise = Bool
False
where
fs :: CtFlavourRole
fs = (CtEvidence -> CtFlavour
ctEvFlavour CtEvidence
ev, EqRel
eq_rel)
kick_out_for_inertness :: Bool
kick_out_for_inertness
= (CtFlavourRole
fs CtFlavourRole -> CtFlavourRole -> Bool
`eqMayRewriteFR` CtFlavourRole
fs)
Bool -> Bool -> Bool
&& Bool -> Bool
not (CtFlavourRole
fs CtFlavourRole -> CtFlavourRole -> Bool
`eqMayRewriteFR` CtFlavourRole
new_fr)
Bool -> Bool -> Bool
&& EqRel -> PredType -> Bool
fr_can_rewrite_ty EqRel
eq_rel PredType
rhs_ty
kick_out_for_completeness :: Bool
kick_out_for_completeness
= case EqRel
eq_rel of
EqRel
NomEq -> PredType
rhs_ty PredType -> PredType -> Bool
`eqType` TcTyVar -> PredType
mkTyVarTy TcTyVar
new_tv
EqRel
ReprEq -> TcTyVar -> PredType -> Bool
isTyVarHead TcTyVar
new_tv PredType
rhs_ty
kick_out_eq Ct
ct = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"keep_eq" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
kickOutAfterUnification :: TcTyVar -> TcS Int
kickOutAfterUnification :: TcTyVar -> TcS Int
kickOutAfterUnification TcTyVar
new_tv
= do { InertCans
ics <- TcS InertCans
getInertCans
; (Int
n_kicked, InertCans
ics2) <- CtFlavourRole -> TcTyVar -> InertCans -> TcS (Int, InertCans)
kickOutRewritable (CtFlavour
Given,EqRel
NomEq)
TcTyVar
new_tv InertCans
ics
; InertCans -> TcS ()
setInertCans InertCans
ics2
; Int -> TcS Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n_kicked }
addInertSafehask :: InertCans -> Ct -> InertCans
addInertSafehask :: InertCans -> Ct -> InertCans
addInertSafehask InertCans
ics item :: Ct
item@(CDictCan { cc_class :: Ct -> Class
cc_class = Class
cls, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys })
= InertCans
ics { inert_safehask :: FunEqMap Ct
inert_safehask = FunEqMap Ct -> Class -> [PredType] -> Ct -> FunEqMap Ct
forall a. DictMap a -> Class -> [PredType] -> a -> DictMap a
addDict (InertCans -> FunEqMap Ct
inert_dicts InertCans
ics) Class
cls [PredType]
tys Ct
item }
addInertSafehask InertCans
_ Ct
item
= String -> SDoc -> InertCans
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addInertSafehask: can't happen! Inserting " (SDoc -> InertCans) -> SDoc -> InertCans
forall a b. (a -> b) -> a -> b
$ Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
item
insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()
insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()
insertSafeOverlapFailureTcS InstanceWhat
what Ct
item
| InstanceWhat -> Bool
safeOverlap InstanceWhat
what = () -> TcS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = (InertCans -> InertCans) -> TcS ()
updInertCans (\InertCans
ics -> InertCans -> Ct -> InertCans
addInertSafehask InertCans
ics Ct
item)
getSafeOverlapFailures :: TcS Cts
getSafeOverlapFailures :: TcS Cts
getSafeOverlapFailures
= do { IC { inert_safehask :: InertCans -> FunEqMap Ct
inert_safehask = FunEqMap Ct
safehask } <- TcS InertCans
getInertCans
; Cts -> TcS Cts
forall (m :: * -> *) a. Monad m => a -> m a
return (Cts -> TcS Cts) -> Cts -> TcS Cts
forall a b. (a -> b) -> a -> b
$ (Ct -> Cts -> Cts) -> FunEqMap Ct -> Cts -> Cts
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldDicts Ct -> Cts -> Cts
consCts FunEqMap Ct
safehask Cts
emptyCts }
addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()
addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [PredType] -> TcS ()
addSolvedDict InstanceWhat
what CtEvidence
item Class
cls [PredType]
tys
| CtEvidence -> Bool
isWanted CtEvidence
item
, InstanceWhat -> Bool
instanceReturnsDictCon InstanceWhat
what
= do { String -> SDoc -> TcS ()
traceTcS String
"updSolvedSetTcs:" (SDoc -> TcS ()) -> SDoc -> TcS ()
forall a b. (a -> b) -> a -> b
$ CtEvidence -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtEvidence
item
; (InertSet -> InertSet) -> TcS ()
updInertTcS ((InertSet -> InertSet) -> TcS ())
-> (InertSet -> InertSet) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertSet
ics ->
InertSet
ics { inert_solved_dicts :: DictMap CtEvidence
inert_solved_dicts = DictMap CtEvidence
-> Class -> [PredType] -> CtEvidence -> DictMap CtEvidence
forall a. DictMap a -> Class -> [PredType] -> a -> DictMap a
addDict (InertSet -> DictMap CtEvidence
inert_solved_dicts InertSet
ics) Class
cls [PredType]
tys CtEvidence
item } }
| Bool
otherwise
= () -> TcS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getSolvedDicts :: TcS (DictMap CtEvidence)
getSolvedDicts :: TcS (DictMap CtEvidence)
getSolvedDicts = do { InertSet
ics <- TcS InertSet
getTcSInerts; DictMap CtEvidence -> TcS (DictMap CtEvidence)
forall (m :: * -> *) a. Monad m => a -> m a
return (InertSet -> DictMap CtEvidence
inert_solved_dicts InertSet
ics) }
setSolvedDicts :: DictMap CtEvidence -> TcS ()
setSolvedDicts :: DictMap CtEvidence -> TcS ()
setSolvedDicts DictMap CtEvidence
solved_dicts
= (InertSet -> InertSet) -> TcS ()
updInertTcS ((InertSet -> InertSet) -> TcS ())
-> (InertSet -> InertSet) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertSet
ics ->
InertSet
ics { inert_solved_dicts :: DictMap CtEvidence
inert_solved_dicts = DictMap CtEvidence
solved_dicts }
updInertTcS :: (InertSet -> InertSet) -> TcS ()
updInertTcS :: (InertSet -> InertSet) -> TcS ()
updInertTcS InertSet -> InertSet
upd_fn
= do { IORef InertSet
is_var <- TcS (IORef InertSet)
getTcSInertsRef
; TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (do { InertSet
curr_inert <- IORef InertSet -> TcRnIf TcGblEnv TcLclEnv InertSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef InertSet
is_var
; IORef InertSet -> InertSet -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
TcM.writeTcRef IORef InertSet
is_var (InertSet -> InertSet
upd_fn InertSet
curr_inert) }) }
getInertCans :: TcS InertCans
getInertCans :: TcS InertCans
getInertCans = do { InertSet
inerts <- TcS InertSet
getTcSInerts; InertCans -> TcS InertCans
forall (m :: * -> *) a. Monad m => a -> m a
return (InertSet -> InertCans
inert_cans InertSet
inerts) }
setInertCans :: InertCans -> TcS ()
setInertCans :: InertCans -> TcS ()
setInertCans InertCans
ics = (InertSet -> InertSet) -> TcS ()
updInertTcS ((InertSet -> InertSet) -> TcS ())
-> (InertSet -> InertSet) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertSet
inerts -> InertSet
inerts { inert_cans :: InertCans
inert_cans = InertCans
ics }
updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a
updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a
updRetInertCans InertCans -> (a, InertCans)
upd_fn
= do { IORef InertSet
is_var <- TcS (IORef InertSet)
getTcSInertsRef
; TcM a -> TcS a
forall a. TcM a -> TcS a
wrapTcS (do { InertSet
inerts <- IORef InertSet -> TcRnIf TcGblEnv TcLclEnv InertSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef InertSet
is_var
; let (a
res, InertCans
cans') = InertCans -> (a, InertCans)
upd_fn (InertSet -> InertCans
inert_cans InertSet
inerts)
; IORef InertSet -> InertSet -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
TcM.writeTcRef IORef InertSet
is_var (InertSet
inerts { inert_cans :: InertCans
inert_cans = InertCans
cans' })
; a -> TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res }) }
updInertCans :: (InertCans -> InertCans) -> TcS ()
updInertCans :: (InertCans -> InertCans) -> TcS ()
updInertCans InertCans -> InertCans
upd_fn
= (InertSet -> InertSet) -> TcS ()
updInertTcS ((InertSet -> InertSet) -> TcS ())
-> (InertSet -> InertSet) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertSet
inerts -> InertSet
inerts { inert_cans :: InertCans
inert_cans = InertCans -> InertCans
upd_fn (InertSet -> InertCans
inert_cans InertSet
inerts) }
updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()
updInertDicts :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
updInertDicts FunEqMap Ct -> FunEqMap Ct
upd_fn
= (InertCans -> InertCans) -> TcS ()
updInertCans ((InertCans -> InertCans) -> TcS ())
-> (InertCans -> InertCans) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertCans
ics -> InertCans
ics { inert_dicts :: FunEqMap Ct
inert_dicts = FunEqMap Ct -> FunEqMap Ct
upd_fn (InertCans -> FunEqMap Ct
inert_dicts InertCans
ics) }
updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()
updInertSafehask :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
updInertSafehask FunEqMap Ct -> FunEqMap Ct
upd_fn
= (InertCans -> InertCans) -> TcS ()
updInertCans ((InertCans -> InertCans) -> TcS ())
-> (InertCans -> InertCans) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertCans
ics -> InertCans
ics { inert_safehask :: FunEqMap Ct
inert_safehask = FunEqMap Ct -> FunEqMap Ct
upd_fn (InertCans -> FunEqMap Ct
inert_safehask InertCans
ics) }
updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
updInertFunEqs FunEqMap Ct -> FunEqMap Ct
upd_fn
= (InertCans -> InertCans) -> TcS ()
updInertCans ((InertCans -> InertCans) -> TcS ())
-> (InertCans -> InertCans) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertCans
ics -> InertCans
ics { inert_funeqs :: FunEqMap Ct
inert_funeqs = FunEqMap Ct -> FunEqMap Ct
upd_fn (InertCans -> FunEqMap Ct
inert_funeqs InertCans
ics) }
updInertIrreds :: (Cts -> Cts) -> TcS ()
updInertIrreds :: (Cts -> Cts) -> TcS ()
updInertIrreds Cts -> Cts
upd_fn
= (InertCans -> InertCans) -> TcS ()
updInertCans ((InertCans -> InertCans) -> TcS ())
-> (InertCans -> InertCans) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ InertCans
ics -> InertCans
ics { inert_irreds :: Cts
inert_irreds = Cts -> Cts
upd_fn (InertCans -> Cts
inert_irreds InertCans
ics) }
getInertEqs :: TcS (DTyVarEnv EqualCtList)
getInertEqs :: TcS InertEqs
getInertEqs = do { InertCans
inert <- TcS InertCans
getInertCans; InertEqs -> TcS InertEqs
forall (m :: * -> *) a. Monad m => a -> m a
return (InertCans -> InertEqs
inert_eqs InertCans
inert) }
getInertInsols :: TcS Cts
getInertInsols :: TcS Cts
getInertInsols = do { InertCans
inert <- TcS InertCans
getInertCans
; Cts -> TcS Cts
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ct -> Bool) -> Cts -> Cts
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag Ct -> Bool
insolubleEqCt (InertCans -> Cts
inert_irreds InertCans
inert)) }
getInertGivens :: TcS [Ct]
getInertGivens :: TcS [Ct]
getInertGivens
= do { InertCans
inerts <- TcS InertCans
getInertCans
; let all_cts :: [Ct]
all_cts = (Ct -> [Ct] -> [Ct]) -> FunEqMap Ct -> [Ct] -> [Ct]
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldDicts (:) (InertCans -> FunEqMap Ct
inert_dicts InertCans
inerts)
([Ct] -> [Ct]) -> [Ct] -> [Ct]
forall a b. (a -> b) -> a -> b
$ (Ct -> [Ct] -> [Ct]) -> FunEqMap Ct -> [Ct] -> [Ct]
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldFunEqs (:) (InertCans -> FunEqMap Ct
inert_funeqs InertCans
inerts)
([Ct] -> [Ct]) -> [Ct] -> [Ct]
forall a b. (a -> b) -> a -> b
$ [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (InertEqs -> [[Ct]]
forall a. DVarEnv a -> [a]
dVarEnvElts (InertCans -> InertEqs
inert_eqs InertCans
inerts))
; [Ct] -> TcS [Ct]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ct -> Bool) -> [Ct] -> [Ct]
forall a. (a -> Bool) -> [a] -> [a]
filter Ct -> Bool
isGivenCt [Ct]
all_cts) }
getPendingGivenScs :: TcS [Ct]
getPendingGivenScs :: TcS [Ct]
getPendingGivenScs = do { TcLevel
lvl <- TcS TcLevel
getTcLevel
; (InertCans -> ([Ct], InertCans)) -> TcS [Ct]
forall a. (InertCans -> (a, InertCans)) -> TcS a
updRetInertCans (TcLevel -> InertCans -> ([Ct], InertCans)
get_sc_pending TcLevel
lvl) }
get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)
get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)
get_sc_pending TcLevel
this_lvl ic :: InertCans
ic@(IC { inert_dicts :: InertCans -> FunEqMap Ct
inert_dicts = FunEqMap Ct
dicts, inert_insts :: InertCans -> [QCInst]
inert_insts = [QCInst]
insts })
= ASSERT2( all isGivenCt sc_pending, ppr sc_pending )
([Ct]
sc_pending, InertCans
ic { inert_dicts :: FunEqMap Ct
inert_dicts = FunEqMap Ct
dicts', inert_insts :: [QCInst]
inert_insts = [QCInst]
insts' })
where
sc_pending :: [Ct]
sc_pending = [Ct]
sc_pend_insts [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
sc_pend_dicts
sc_pend_dicts :: [Ct]
sc_pend_dicts = (Ct -> [Ct] -> [Ct]) -> FunEqMap Ct -> [Ct] -> [Ct]
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldDicts Ct -> [Ct] -> [Ct]
get_pending FunEqMap Ct
dicts []
dicts' :: FunEqMap Ct
dicts' = (Ct -> FunEqMap Ct -> FunEqMap Ct)
-> FunEqMap Ct -> [Ct] -> FunEqMap Ct
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ct -> FunEqMap Ct -> FunEqMap Ct
add FunEqMap Ct
dicts [Ct]
sc_pend_dicts
([Ct]
sc_pend_insts, [QCInst]
insts') = ([Ct] -> QCInst -> ([Ct], QCInst))
-> [Ct] -> [QCInst] -> ([Ct], [QCInst])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL [Ct] -> QCInst -> ([Ct], QCInst)
get_pending_inst [] [QCInst]
insts
get_pending :: Ct -> [Ct] -> [Ct]
get_pending :: Ct -> [Ct] -> [Ct]
get_pending Ct
dict [Ct]
dicts
| Just Ct
dict' <- Ct -> Maybe Ct
isPendingScDict Ct
dict
, CtEvidence -> Bool
belongs_to_this_level (Ct -> CtEvidence
ctEvidence Ct
dict)
= Ct
dict' Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
dicts
| Bool
otherwise
= [Ct]
dicts
add :: Ct -> DictMap Ct -> DictMap Ct
add :: Ct -> FunEqMap Ct -> FunEqMap Ct
add ct :: Ct
ct@(CDictCan { cc_class :: Ct -> Class
cc_class = Class
cls, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys }) FunEqMap Ct
dicts
= FunEqMap Ct -> Class -> [PredType] -> Ct -> FunEqMap Ct
forall a. DictMap a -> Class -> [PredType] -> a -> DictMap a
addDict FunEqMap Ct
dicts Class
cls [PredType]
tys Ct
ct
add Ct
ct FunEqMap Ct
_ = String -> SDoc -> FunEqMap Ct
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getPendingScDicts" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
get_pending_inst [Ct]
cts qci :: QCInst
qci@(QCI { qci_ev :: QCInst -> CtEvidence
qci_ev = CtEvidence
ev })
| Just QCInst
qci' <- QCInst -> Maybe QCInst
isPendingScInst QCInst
qci
, CtEvidence -> Bool
belongs_to_this_level CtEvidence
ev
= (QCInst -> Ct
CQuantCan QCInst
qci' Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
cts, QCInst
qci')
| Bool
otherwise
= ([Ct]
cts, QCInst
qci)
belongs_to_this_level :: CtEvidence -> Bool
belongs_to_this_level CtEvidence
ev = CtLoc -> TcLevel
ctLocLevel (CtEvidence -> CtLoc
ctEvLoc CtEvidence
ev) TcLevel -> TcLevel -> Bool
forall a. Eq a => a -> a -> Bool
== TcLevel
this_lvl
getUnsolvedInerts :: TcS ( Bag Implication
, Cts
, Cts
, Cts )
getUnsolvedInerts :: TcS (Bag Implication, Cts, Cts, Cts)
getUnsolvedInerts
= do { IC { inert_eqs :: InertCans -> InertEqs
inert_eqs = InertEqs
tv_eqs
, inert_funeqs :: InertCans -> FunEqMap Ct
inert_funeqs = FunEqMap Ct
fun_eqs
, inert_irreds :: InertCans -> Cts
inert_irreds = Cts
irreds
, inert_dicts :: InertCans -> FunEqMap Ct
inert_dicts = FunEqMap Ct
idicts
} <- TcS InertCans
getInertCans
; let unsolved_tv_eqs :: Cts
unsolved_tv_eqs = (Ct -> Cts -> Cts) -> InertEqs -> Cts -> Cts
forall b. (Ct -> b -> b) -> InertEqs -> b -> b
foldTyEqs Ct -> Cts -> Cts
add_if_unsolved InertEqs
tv_eqs Cts
emptyCts
unsolved_fun_eqs :: Cts
unsolved_fun_eqs = (Ct -> Cts -> Cts) -> FunEqMap Ct -> Cts -> Cts
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldFunEqs Ct -> Cts -> Cts
add_if_wanted FunEqMap Ct
fun_eqs Cts
emptyCts
unsolved_irreds :: Cts
unsolved_irreds = (Ct -> Bool) -> Cts -> Cts
forall a. (a -> Bool) -> Bag a -> Bag a
Bag.filterBag Ct -> Bool
is_unsolved Cts
irreds
unsolved_dicts :: Cts
unsolved_dicts = (Ct -> Cts -> Cts) -> FunEqMap Ct -> Cts -> Cts
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldDicts Ct -> Cts -> Cts
add_if_unsolved FunEqMap Ct
idicts Cts
emptyCts
unsolved_others :: Cts
unsolved_others = Cts
unsolved_irreds Cts -> Cts -> Cts
forall a. Bag a -> Bag a -> Bag a
`unionBags` Cts
unsolved_dicts
; Bag Implication
implics <- TcS (Bag Implication)
getWorkListImplics
; String -> SDoc -> TcS ()
traceTcS String
"getUnsolvedInerts" (SDoc -> TcS ()) -> SDoc -> TcS ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
" tv eqs =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
unsolved_tv_eqs
, String -> SDoc
text String
"fun eqs =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
unsolved_fun_eqs
, String -> SDoc
text String
"others =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
unsolved_others
, String -> SDoc
text String
"implics =" SDoc -> SDoc -> SDoc
<+> Bag Implication -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag Implication
implics ]
; (Bag Implication, Cts, Cts, Cts)
-> TcS (Bag Implication, Cts, Cts, Cts)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bag Implication
implics, Cts
unsolved_tv_eqs, Cts
unsolved_fun_eqs, Cts
unsolved_others) }
where
add_if_unsolved :: Ct -> Cts -> Cts
add_if_unsolved :: Ct -> Cts -> Cts
add_if_unsolved Ct
ct Cts
cts | Ct -> Bool
is_unsolved Ct
ct = Ct
ct Ct -> Cts -> Cts
`consCts` Cts
cts
| Bool
otherwise = Cts
cts
is_unsolved :: Ct -> Bool
is_unsolved Ct
ct = Bool -> Bool
not (Ct -> Bool
isGivenCt Ct
ct)
add_if_wanted :: Ct -> Cts -> Cts
add_if_wanted Ct
ct Cts
cts | Ct -> Bool
isWantedCt Ct
ct = Ct
ct Ct -> Cts -> Cts
`consCts` Cts
cts
| Bool
otherwise = Cts
cts
isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool
isInInertEqs :: InertEqs -> TcTyVar -> PredType -> Bool
isInInertEqs InertEqs
eqs TcTyVar
tv PredType
rhs
= case InertEqs -> TcTyVar -> Maybe [Ct]
forall a. DVarEnv a -> TcTyVar -> Maybe a
lookupDVarEnv InertEqs
eqs TcTyVar
tv of
Maybe [Ct]
Nothing -> Bool
False
Just [Ct]
cts -> (Ct -> Bool) -> [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (PredType -> Ct -> Bool
same_pred PredType
rhs) [Ct]
cts
where
same_pred :: PredType -> Ct -> Bool
same_pred PredType
rhs Ct
ct
| CTyEqCan { cc_rhs :: Ct -> PredType
cc_rhs = PredType
rhs2, cc_eq_rel :: Ct -> EqRel
cc_eq_rel = EqRel
eq_rel } <- Ct
ct
, EqRel
NomEq <- EqRel
eq_rel
, PredType
rhs PredType -> PredType -> Bool
`eqType` PredType
rhs2 = Bool
True
| Bool
otherwise = Bool
False
getNoGivenEqs :: TcLevel
-> [TcTyVar]
-> TcS ( Bool
, Cts )
getNoGivenEqs :: TcLevel -> [TcTyVar] -> TcS (Bool, Cts)
getNoGivenEqs TcLevel
tclvl [TcTyVar]
skol_tvs
= do { inerts :: InertCans
inerts@(IC { inert_eqs :: InertCans -> InertEqs
inert_eqs = InertEqs
ieqs, inert_irreds :: InertCans -> Cts
inert_irreds = Cts
irreds })
<- TcS InertCans
getInertCans
; let has_given_eqs :: Bool
has_given_eqs = (Ct -> Bool -> Bool) -> Bool -> Cts -> Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Ct -> Bool) -> Ct -> Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> Bool
ct_given_here) Bool
False Cts
irreds
Bool -> Bool -> Bool
|| ([Ct] -> Bool) -> InertEqs -> Bool
forall a. (a -> Bool) -> DVarEnv a -> Bool
anyDVarEnv [Ct] -> Bool
eqs_given_here InertEqs
ieqs
insols :: Cts
insols = (Ct -> Bool) -> Cts -> Cts
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag Ct -> Bool
insolubleEqCt Cts
irreds
; String -> SDoc -> TcS ()
traceTcS String
"getNoGivenEqs" (SDoc -> TcS ()) -> SDoc -> TcS ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ if Bool
has_given_eqs then String -> SDoc
text String
"May have given equalities"
else String -> SDoc
text String
"No given equalities"
, String -> SDoc
text String
"Skols:" SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcTyVar]
skol_tvs
, String -> SDoc
text String
"Inerts:" SDoc -> SDoc -> SDoc
<+> InertCans -> SDoc
forall a. Outputable a => a -> SDoc
ppr InertCans
inerts
, String -> SDoc
text String
"Insols:" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
insols]
; (Bool, Cts) -> TcS (Bool, Cts)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
has_given_eqs, Cts
insols) }
where
eqs_given_here :: EqualCtList -> Bool
eqs_given_here :: [Ct] -> Bool
eqs_given_here [ct :: Ct
ct@(CTyEqCan { cc_tyvar :: Ct -> TcTyVar
cc_tyvar = TcTyVar
tv })]
= Bool -> Bool
not (TcTyVar -> Bool
skolem_bound_here TcTyVar
tv) Bool -> Bool -> Bool
&& Ct -> Bool
ct_given_here Ct
ct
eqs_given_here [Ct]
_ = Bool
False
ct_given_here :: Ct -> Bool
ct_given_here :: Ct -> Bool
ct_given_here Ct
ct = CtEvidence -> Bool
isGiven CtEvidence
ev
Bool -> Bool -> Bool
&& TcLevel
tclvl TcLevel -> TcLevel -> Bool
forall a. Eq a => a -> a -> Bool
== CtLoc -> TcLevel
ctLocLevel (CtEvidence -> CtLoc
ctEvLoc CtEvidence
ev)
where
ev :: CtEvidence
ev = Ct -> CtEvidence
ctEvidence Ct
ct
skol_tv_set :: VarSet
skol_tv_set = [TcTyVar] -> VarSet
mkVarSet [TcTyVar]
skol_tvs
skolem_bound_here :: TcTyVar -> Bool
skolem_bound_here TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
SkolemTv {} -> TcTyVar
tv TcTyVar -> VarSet -> Bool
`elemVarSet` VarSet
skol_tv_set
TcTyVarDetails
_ -> Bool
False
matchableGivens :: CtLoc -> PredType -> InertSet -> Cts
matchableGivens :: CtLoc -> PredType -> InertSet -> Cts
matchableGivens CtLoc
loc_w PredType
pred_w (IS { inert_cans :: InertSet -> InertCans
inert_cans = InertCans
inert_cans })
= (Ct -> Bool) -> Cts -> Cts
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag Ct -> Bool
matchable_given Cts
all_relevant_givens
where
all_relevant_givens :: Cts
all_relevant_givens :: Cts
all_relevant_givens
| Just (Class
clas, [PredType]
_) <- PredType -> Maybe (Class, [PredType])
getClassPredTys_maybe PredType
pred_w
= FunEqMap Ct -> Class -> Cts
forall a. DictMap a -> Class -> Bag a
findDictsByClass (InertCans -> FunEqMap Ct
inert_dicts InertCans
inert_cans) Class
clas
Cts -> Cts -> Cts
forall a. Bag a -> Bag a -> Bag a
`unionBags` InertCans -> Cts
inert_irreds InertCans
inert_cans
| Bool
otherwise
= InertCans -> Cts
inert_irreds InertCans
inert_cans
matchable_given :: Ct -> Bool
matchable_given :: Ct -> Bool
matchable_given Ct
ct
| CtGiven { ctev_loc :: CtEvidence -> CtLoc
ctev_loc = CtLoc
loc_g, ctev_pred :: CtEvidence -> PredType
ctev_pred = PredType
pred_g } <- Ct -> CtEvidence
ctEvidence Ct
ct
= PredType -> CtLoc -> PredType -> CtLoc -> Bool
mightMatchLater PredType
pred_g CtLoc
loc_g PredType
pred_w CtLoc
loc_w
| Bool
otherwise
= Bool
False
mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool
mightMatchLater :: PredType -> CtLoc -> PredType -> CtLoc -> Bool
mightMatchLater PredType
given_pred CtLoc
given_loc PredType
wanted_pred CtLoc
wanted_loc
= Bool -> Bool
not (CtLoc -> CtLoc -> Bool
prohibitedSuperClassSolve CtLoc
given_loc CtLoc
wanted_loc)
Bool -> Bool -> Bool
&& Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust ((TcTyVar -> BindFlag) -> [PredType] -> [PredType] -> Maybe TCvSubst
tcUnifyTys TcTyVar -> BindFlag
bind_meta_tv [PredType
given_pred] [PredType
wanted_pred])
where
bind_meta_tv :: TcTyVar -> BindFlag
bind_meta_tv :: TcTyVar -> BindFlag
bind_meta_tv TcTyVar
tv | TcTyVar -> Bool
isMetaTyVar TcTyVar
tv
, Bool -> Bool
not (TcTyVar -> Bool
isFskTyVar TcTyVar
tv) = BindFlag
BindMe
| Bool
otherwise = BindFlag
Skolem
prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
prohibitedSuperClassSolve CtLoc
from_loc CtLoc
solve_loc
| GivenOrigin (InstSC TypeSize
given_size) <- CtLoc -> CtOrigin
ctLocOrigin CtLoc
from_loc
, ScOrigin TypeSize
wanted_size <- CtLoc -> CtOrigin
ctLocOrigin CtLoc
solve_loc
= TypeSize
given_size TypeSize -> TypeSize -> Bool
forall a. Ord a => a -> a -> Bool
>= TypeSize
wanted_size
| Bool
otherwise
= Bool
False
removeInertCts :: [Ct] -> InertCans -> InertCans
removeInertCts :: [Ct] -> InertCans -> InertCans
removeInertCts [Ct]
cts InertCans
icans = (InertCans -> Ct -> InertCans) -> InertCans -> [Ct] -> InertCans
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InertCans -> Ct -> InertCans
removeInertCt InertCans
icans [Ct]
cts
removeInertCt :: InertCans -> Ct -> InertCans
removeInertCt :: InertCans -> Ct -> InertCans
removeInertCt InertCans
is Ct
ct =
case Ct
ct of
CDictCan { cc_class :: Ct -> Class
cc_class = Class
cl, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys } ->
InertCans
is { inert_dicts :: FunEqMap Ct
inert_dicts = FunEqMap Ct -> Class -> [PredType] -> FunEqMap Ct
forall a. DictMap a -> Class -> [PredType] -> DictMap a
delDict (InertCans -> FunEqMap Ct
inert_dicts InertCans
is) Class
cl [PredType]
tys }
CFunEqCan { cc_fun :: Ct -> TyCon
cc_fun = TyCon
tf, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys } ->
InertCans
is { inert_funeqs :: FunEqMap Ct
inert_funeqs = FunEqMap Ct -> TyCon -> [PredType] -> FunEqMap Ct
forall a. FunEqMap a -> TyCon -> [PredType] -> FunEqMap a
delFunEq (InertCans -> FunEqMap Ct
inert_funeqs InertCans
is) TyCon
tf [PredType]
tys }
CTyEqCan { cc_tyvar :: Ct -> TcTyVar
cc_tyvar = TcTyVar
x, cc_rhs :: Ct -> PredType
cc_rhs = PredType
ty } ->
InertCans
is { inert_eqs :: InertEqs
inert_eqs = InertEqs -> TcTyVar -> PredType -> InertEqs
delTyEq (InertCans -> InertEqs
inert_eqs InertCans
is) TcTyVar
x PredType
ty }
CQuantCan {} -> String -> InertCans
forall a. String -> a
panic String
"removeInertCt: CQuantCan"
CIrredCan {} -> String -> InertCans
forall a. String -> a
panic String
"removeInertCt: CIrredEvCan"
CNonCanonical {} -> String -> InertCans
forall a. String -> a
panic String
"removeInertCt: CNonCanonical"
CHoleCan {} -> String -> InertCans
forall a. String -> a
panic String
"removeInertCt: CHoleCan"
lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))
lookupFlatCache :: TyCon
-> [PredType] -> TcS (Maybe (TcCoercion, PredType, CtFlavour))
lookupFlatCache TyCon
fam_tc [PredType]
tys
= do { IS { inert_flat_cache :: InertSet -> ExactFunEqMap (TcCoercion, PredType, CtFlavour)
inert_flat_cache = ExactFunEqMap (TcCoercion, PredType, CtFlavour)
flat_cache
, inert_cans :: InertSet -> InertCans
inert_cans = IC { inert_funeqs :: InertCans -> FunEqMap Ct
inert_funeqs = FunEqMap Ct
inert_funeqs } } <- TcS InertSet
getTcSInerts
; Maybe (TcCoercion, PredType, CtFlavour)
-> TcS (Maybe (TcCoercion, PredType, CtFlavour))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (TcCoercion, PredType, CtFlavour)]
-> Maybe (TcCoercion, PredType, CtFlavour)
forall a. [Maybe a] -> Maybe a
firstJusts [FunEqMap Ct -> Maybe (TcCoercion, PredType, CtFlavour)
lookup_inerts FunEqMap Ct
inert_funeqs,
ExactFunEqMap (TcCoercion, PredType, CtFlavour)
-> Maybe (TcCoercion, PredType, CtFlavour)
lookup_flats ExactFunEqMap (TcCoercion, PredType, CtFlavour)
flat_cache]) }
where
lookup_inerts :: FunEqMap Ct -> Maybe (TcCoercion, PredType, CtFlavour)
lookup_inerts FunEqMap Ct
inert_funeqs
| Just (CFunEqCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ctev, cc_fsk :: Ct -> TcTyVar
cc_fsk = TcTyVar
fsk, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
xis })
<- FunEqMap Ct -> TyCon -> [PredType] -> Maybe Ct
forall a. FunEqMap a -> TyCon -> [PredType] -> Maybe a
findFunEq FunEqMap Ct
inert_funeqs TyCon
fam_tc [PredType]
tys
, [PredType]
tys [PredType] -> [PredType] -> Bool
`eqTypes` [PredType]
xis
= (TcCoercion, PredType, CtFlavour)
-> Maybe (TcCoercion, PredType, CtFlavour)
forall a. a -> Maybe a
Just (HasDebugCallStack => CtEvidence -> TcCoercion
CtEvidence -> TcCoercion
ctEvCoercion CtEvidence
ctev, TcTyVar -> PredType
mkTyVarTy TcTyVar
fsk, CtEvidence -> CtFlavour
ctEvFlavour CtEvidence
ctev)
| Bool
otherwise = Maybe (TcCoercion, PredType, CtFlavour)
forall a. Maybe a
Nothing
lookup_flats :: ExactFunEqMap (TcCoercion, PredType, CtFlavour)
-> Maybe (TcCoercion, PredType, CtFlavour)
lookup_flats ExactFunEqMap (TcCoercion, PredType, CtFlavour)
flat_cache = ExactFunEqMap (TcCoercion, PredType, CtFlavour)
-> TyCon -> [PredType] -> Maybe (TcCoercion, PredType, CtFlavour)
forall a. ExactFunEqMap a -> TyCon -> [PredType] -> Maybe a
findExactFunEq ExactFunEqMap (TcCoercion, PredType, CtFlavour)
flat_cache TyCon
fam_tc [PredType]
tys
lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
lookupInInerts :: CtLoc -> PredType -> TcS (Maybe CtEvidence)
lookupInInerts CtLoc
loc PredType
pty
| ClassPred Class
cls [PredType]
tys <- PredType -> Pred
classifyPredType PredType
pty
= do { InertSet
inerts <- TcS InertSet
getTcSInerts
; Maybe CtEvidence -> TcS (Maybe CtEvidence)
forall (m :: * -> *) a. Monad m => a -> m a
return (InertSet -> CtLoc -> Class -> [PredType] -> Maybe CtEvidence
lookupSolvedDict InertSet
inerts CtLoc
loc Class
cls [PredType]
tys Maybe CtEvidence -> Maybe CtEvidence -> Maybe CtEvidence
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
InertCans -> CtLoc -> Class -> [PredType] -> Maybe CtEvidence
lookupInertDict (InertSet -> InertCans
inert_cans InertSet
inerts) CtLoc
loc Class
cls [PredType]
tys) }
| Bool
otherwise
= Maybe CtEvidence -> TcS (Maybe CtEvidence)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CtEvidence
forall a. Maybe a
Nothing
lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
lookupInertDict :: InertCans -> CtLoc -> Class -> [PredType] -> Maybe CtEvidence
lookupInertDict (IC { inert_dicts :: InertCans -> FunEqMap Ct
inert_dicts = FunEqMap Ct
dicts }) CtLoc
loc Class
cls [PredType]
tys
= case FunEqMap Ct -> CtLoc -> Class -> [PredType] -> Maybe Ct
forall a. DictMap a -> CtLoc -> Class -> [PredType] -> Maybe a
findDict FunEqMap Ct
dicts CtLoc
loc Class
cls [PredType]
tys of
Just Ct
ct -> CtEvidence -> Maybe CtEvidence
forall a. a -> Maybe a
Just (Ct -> CtEvidence
ctEvidence Ct
ct)
Maybe Ct
_ -> Maybe CtEvidence
forall a. Maybe a
Nothing
lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
lookupSolvedDict :: InertSet -> CtLoc -> Class -> [PredType] -> Maybe CtEvidence
lookupSolvedDict (IS { inert_solved_dicts :: InertSet -> DictMap CtEvidence
inert_solved_dicts = DictMap CtEvidence
solved }) CtLoc
loc Class
cls [PredType]
tys
= case DictMap CtEvidence
-> CtLoc -> Class -> [PredType] -> Maybe CtEvidence
forall a. DictMap a -> CtLoc -> Class -> [PredType] -> Maybe a
findDict DictMap CtEvidence
solved CtLoc
loc Class
cls [PredType]
tys of
Just CtEvidence
ev -> CtEvidence -> Maybe CtEvidence
forall a. a -> Maybe a
Just CtEvidence
ev
Maybe CtEvidence
_ -> Maybe CtEvidence
forall a. Maybe a
Nothing
foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
foldIrreds Ct -> b -> b
k Cts
irreds b
z = (Ct -> b -> b) -> b -> Cts -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ct -> b -> b
k b
z Cts
irreds
type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)
isEmptyTcAppMap :: TcAppMap a -> Bool
isEmptyTcAppMap :: TcAppMap a -> Bool
isEmptyTcAppMap TcAppMap a
m = TcAppMap a -> Bool
forall a. DVarEnv a -> Bool
isNullUDFM TcAppMap a
m
emptyTcAppMap :: TcAppMap a
emptyTcAppMap :: TcAppMap a
emptyTcAppMap = TcAppMap a
forall a. DVarEnv a
emptyUDFM
findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a
findTcApp :: TcAppMap a -> Unique -> [PredType] -> Maybe a
findTcApp TcAppMap a
m Unique
u [PredType]
tys = do { ListMap LooseTypeMap a
tys_map <- TcAppMap a -> Unique -> Maybe (ListMap LooseTypeMap a)
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM TcAppMap a
m Unique
u
; Key (ListMap LooseTypeMap) -> ListMap LooseTypeMap a -> Maybe a
forall (m :: * -> *) b. TrieMap m => Key m -> m b -> Maybe b
lookupTM [PredType]
Key (ListMap LooseTypeMap)
tys ListMap LooseTypeMap a
tys_map }
delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a
delTcApp :: TcAppMap a -> Unique -> [PredType] -> TcAppMap a
delTcApp TcAppMap a
m Unique
cls [PredType]
tys = (ListMap LooseTypeMap a -> ListMap LooseTypeMap a)
-> TcAppMap a -> Unique -> TcAppMap a
forall key elt.
Uniquable key =>
(elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt
adjustUDFM (Key (ListMap LooseTypeMap)
-> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
forall (m :: * -> *) a. TrieMap m => Key m -> m a -> m a
deleteTM [PredType]
Key (ListMap LooseTypeMap)
tys) TcAppMap a
m Unique
cls
insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a
insertTcApp :: TcAppMap a -> Unique -> [PredType] -> a -> TcAppMap a
insertTcApp TcAppMap a
m Unique
cls [PredType]
tys a
ct = (Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a))
-> TcAppMap a -> Unique -> TcAppMap a
forall key elt.
Uniquable key =>
(Maybe elt -> Maybe elt) -> UniqDFM elt -> key -> UniqDFM elt
alterUDFM Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm TcAppMap a
m Unique
cls
where
alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm Maybe (ListMap LooseTypeMap a)
mb_tm = ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
forall a. a -> Maybe a
Just (Key (ListMap LooseTypeMap)
-> a -> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
forall (m :: * -> *) a. TrieMap m => Key m -> a -> m a -> m a
insertTM [PredType]
Key (ListMap LooseTypeMap)
tys a
ct (Maybe (ListMap LooseTypeMap a)
mb_tm Maybe (ListMap LooseTypeMap a)
-> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
forall a. Maybe a -> a -> a
`orElse` ListMap LooseTypeMap a
forall (m :: * -> *) a. TrieMap m => m a
emptyTM))
filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
filterTcAppMap :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
filterTcAppMap Ct -> Bool
f FunEqMap Ct
m
= (ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct)
-> FunEqMap Ct -> FunEqMap Ct
forall elt1 elt2. (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2
mapUDFM ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct
do_tm FunEqMap Ct
m
where
do_tm :: ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct
do_tm ListMap LooseTypeMap Ct
tm = (Ct -> ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct)
-> ListMap LooseTypeMap Ct
-> ListMap LooseTypeMap Ct
-> ListMap LooseTypeMap Ct
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM Ct -> ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct
insert_mb ListMap LooseTypeMap Ct
tm ListMap LooseTypeMap Ct
forall (m :: * -> *) a. TrieMap m => m a
emptyTM
insert_mb :: Ct -> ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct
insert_mb Ct
ct ListMap LooseTypeMap Ct
tm
| Ct -> Bool
f Ct
ct = Key (ListMap LooseTypeMap)
-> Ct -> ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct
forall (m :: * -> *) a. TrieMap m => Key m -> a -> m a -> m a
insertTM [PredType]
Key (ListMap LooseTypeMap)
tys Ct
ct ListMap LooseTypeMap Ct
tm
| Bool
otherwise = ListMap LooseTypeMap Ct
tm
where
tys :: [PredType]
tys = case Ct
ct of
CFunEqCan { cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys } -> [PredType]
tys
CDictCan { cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys } -> [PredType]
tys
Ct
_ -> String -> SDoc -> [PredType]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"filterTcAppMap" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
tcAppMapToBag :: TcAppMap a -> Bag a
tcAppMapToBag :: TcAppMap a -> Bag a
tcAppMapToBag TcAppMap a
m = (a -> Bag a -> Bag a) -> TcAppMap a -> Bag a -> Bag a
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldTcAppMap a -> Bag a -> Bag a
forall a. a -> Bag a -> Bag a
consBag TcAppMap a
m Bag a
forall a. Bag a
emptyBag
foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap a -> b -> b
k TcAppMap a
m b
z = (ListMap LooseTypeMap a -> b -> b) -> b -> TcAppMap a -> b
forall a b. (a -> b -> b) -> b -> DVarEnv a -> b
foldUDFM ((a -> b -> b) -> ListMap LooseTypeMap a -> b -> b
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM a -> b -> b
k) b
z TcAppMap a
m
type DictMap a = TcAppMap a
emptyDictMap :: DictMap a
emptyDictMap :: DictMap a
emptyDictMap = DictMap a
forall a. DictMap a
emptyTcAppMap
findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
findDict :: DictMap a -> CtLoc -> Class -> [PredType] -> Maybe a
findDict DictMap a
m CtLoc
loc Class
cls [PredType]
tys
| Class -> Bool
isCTupleClass Class
cls
, (PredType -> Bool) -> [PredType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PredType -> Bool
hasIPPred [PredType]
tys
= Maybe a
forall a. Maybe a
Nothing
| Just {} <- Class -> [PredType] -> Maybe FastString
isCallStackPred Class
cls [PredType]
tys
, OccurrenceOf {} <- CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc
= Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise
= DictMap a -> Unique -> [PredType] -> Maybe a
forall a. TcAppMap a -> Unique -> [PredType] -> Maybe a
findTcApp DictMap a
m (Class -> Unique
forall a. Uniquable a => a -> Unique
getUnique Class
cls) [PredType]
tys
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass DictMap a
m Class
cls
| Just ListMap LooseTypeMap a
tm <- DictMap a -> Class -> Maybe (ListMap LooseTypeMap a)
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM DictMap a
m Class
cls = (a -> Bag a -> Bag a) -> ListMap LooseTypeMap a -> Bag a -> Bag a
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM a -> Bag a -> Bag a
forall a. a -> Bag a -> Bag a
consBag ListMap LooseTypeMap a
tm Bag a
forall a. Bag a
emptyBag
| Bool
otherwise = Bag a
forall a. Bag a
emptyBag
delDict :: DictMap a -> Class -> [Type] -> DictMap a
delDict :: DictMap a -> Class -> [PredType] -> DictMap a
delDict DictMap a
m Class
cls [PredType]
tys = DictMap a -> Unique -> [PredType] -> DictMap a
forall a. TcAppMap a -> Unique -> [PredType] -> TcAppMap a
delTcApp DictMap a
m (Class -> Unique
forall a. Uniquable a => a -> Unique
getUnique Class
cls) [PredType]
tys
addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
addDict :: DictMap a -> Class -> [PredType] -> a -> DictMap a
addDict DictMap a
m Class
cls [PredType]
tys a
item = DictMap a -> Unique -> [PredType] -> a -> DictMap a
forall a. TcAppMap a -> Unique -> [PredType] -> a -> TcAppMap a
insertTcApp DictMap a
m (Class -> Unique
forall a. Uniquable a => a -> Unique
getUnique Class
cls) [PredType]
tys a
item
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass :: FunEqMap Ct -> Class -> Cts -> FunEqMap Ct
addDictsByClass FunEqMap Ct
m Class
cls Cts
items
= FunEqMap Ct -> Class -> ListMap LooseTypeMap Ct -> FunEqMap Ct
forall key elt.
Uniquable key =>
UniqDFM elt -> key -> elt -> UniqDFM elt
addToUDFM FunEqMap Ct
m Class
cls ((Ct -> ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct)
-> ListMap LooseTypeMap Ct -> Cts -> ListMap LooseTypeMap Ct
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ct -> ListMap LooseTypeMap Ct -> ListMap LooseTypeMap Ct
forall (m :: * -> *).
(TrieMap m, Key m ~ [PredType]) =>
Ct -> m Ct -> m Ct
add ListMap LooseTypeMap Ct
forall (m :: * -> *) a. TrieMap m => m a
emptyTM Cts
items)
where
add :: Ct -> m Ct -> m Ct
add ct :: Ct
ct@(CDictCan { cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys }) m Ct
tm = Key m -> Ct -> m Ct -> m Ct
forall (m :: * -> *) a. TrieMap m => Key m -> a -> m a -> m a
insertTM [PredType]
Key m
tys Ct
ct m Ct
tm
add Ct
ct m Ct
_ = String -> SDoc -> m Ct
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addDictsByClass" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
filterDicts :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
filterDicts Ct -> Bool
f FunEqMap Ct
m = (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
filterTcAppMap Ct -> Bool
f FunEqMap Ct
m
partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
partitionDicts :: (Ct -> Bool) -> FunEqMap Ct -> (Cts, FunEqMap Ct)
partitionDicts Ct -> Bool
f FunEqMap Ct
m = (Ct -> (Cts, FunEqMap Ct) -> (Cts, FunEqMap Ct))
-> FunEqMap Ct -> (Cts, FunEqMap Ct) -> (Cts, FunEqMap Ct)
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldTcAppMap Ct -> (Cts, FunEqMap Ct) -> (Cts, FunEqMap Ct)
k FunEqMap Ct
m (Cts
forall a. Bag a
emptyBag, FunEqMap Ct
forall a. DictMap a
emptyDicts)
where
k :: Ct -> (Cts, FunEqMap Ct) -> (Cts, FunEqMap Ct)
k Ct
ct (Cts
yeses, FunEqMap Ct
noes) | Ct -> Bool
f Ct
ct = (Ct
ct Ct -> Cts -> Cts
forall a. a -> Bag a -> Bag a
`consBag` Cts
yeses, FunEqMap Ct
noes)
| Bool
otherwise = (Cts
yeses, Ct -> FunEqMap Ct -> FunEqMap Ct
add Ct
ct FunEqMap Ct
noes)
add :: Ct -> FunEqMap Ct -> FunEqMap Ct
add ct :: Ct
ct@(CDictCan { cc_class :: Ct -> Class
cc_class = Class
cls, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys }) FunEqMap Ct
m
= FunEqMap Ct -> Class -> [PredType] -> Ct -> FunEqMap Ct
forall a. DictMap a -> Class -> [PredType] -> a -> DictMap a
addDict FunEqMap Ct
m Class
cls [PredType]
tys Ct
ct
add Ct
ct FunEqMap Ct
_ = String -> SDoc -> FunEqMap Ct
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"partitionDicts" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
dictsToBag :: DictMap a -> Bag a
dictsToBag :: DictMap a -> Bag a
dictsToBag = DictMap a -> Bag a
forall a. DictMap a -> Bag a
tcAppMapToBag
foldDicts :: (a -> b -> b) -> DictMap a -> b -> b
foldDicts :: (a -> b -> b) -> DictMap a -> b -> b
foldDicts = (a -> b -> b) -> DictMap a -> b -> b
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldTcAppMap
emptyDicts :: DictMap a
emptyDicts :: DictMap a
emptyDicts = DictMap a
forall a. DictMap a
emptyTcAppMap
type FunEqMap a = TcAppMap a
emptyFunEqs :: TcAppMap a
emptyFunEqs :: TcAppMap a
emptyFunEqs = TcAppMap a
forall a. DictMap a
emptyTcAppMap
findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
findFunEq :: FunEqMap a -> TyCon -> [PredType] -> Maybe a
findFunEq FunEqMap a
m TyCon
tc [PredType]
tys = FunEqMap a -> Unique -> [PredType] -> Maybe a
forall a. TcAppMap a -> Unique -> [PredType] -> Maybe a
findTcApp FunEqMap a
m (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc) [PredType]
tys
funEqsToBag :: FunEqMap a -> Bag a
funEqsToBag :: FunEqMap a -> Bag a
funEqsToBag FunEqMap a
m = (a -> Bag a -> Bag a) -> FunEqMap a -> Bag a -> Bag a
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldTcAppMap a -> Bag a -> Bag a
forall a. a -> Bag a -> Bag a
consBag FunEqMap a
m Bag a
forall a. Bag a
emptyBag
findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon FunEqMap a
m TyCon
tc
| Just ListMap LooseTypeMap a
tm <- FunEqMap a -> TyCon -> Maybe (ListMap LooseTypeMap a)
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM FunEqMap a
m TyCon
tc = (a -> [a] -> [a]) -> ListMap LooseTypeMap a -> [a] -> [a]
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM (:) ListMap LooseTypeMap a
tm []
| Bool
otherwise = []
foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
foldFunEqs = (a -> b -> b) -> FunEqMap a -> b -> b
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldTcAppMap
insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
insertFunEq :: FunEqMap a -> TyCon -> [PredType] -> a -> FunEqMap a
insertFunEq FunEqMap a
m TyCon
tc [PredType]
tys a
val = FunEqMap a -> Unique -> [PredType] -> a -> FunEqMap a
forall a. TcAppMap a -> Unique -> [PredType] -> a -> TcAppMap a
insertTcApp FunEqMap a
m (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc) [PredType]
tys a
val
partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
partitionFunEqs Ct -> Bool
f FunEqMap Ct
m = ([Ct]
yeses, (Ct -> FunEqMap Ct -> FunEqMap Ct)
-> FunEqMap Ct -> [Ct] -> FunEqMap Ct
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ct -> FunEqMap Ct -> FunEqMap Ct
forall a. Ct -> FunEqMap a -> FunEqMap a
del FunEqMap Ct
m [Ct]
yeses)
where
yeses :: [Ct]
yeses = (Ct -> [Ct] -> [Ct]) -> FunEqMap Ct -> [Ct] -> [Ct]
forall a b. (a -> b -> b) -> DictMap a -> b -> b
foldTcAppMap Ct -> [Ct] -> [Ct]
k FunEqMap Ct
m []
k :: Ct -> [Ct] -> [Ct]
k Ct
ct [Ct]
yeses | Ct -> Bool
f Ct
ct = Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
yeses
| Bool
otherwise = [Ct]
yeses
del :: Ct -> FunEqMap a -> FunEqMap a
del (CFunEqCan { cc_fun :: Ct -> TyCon
cc_fun = TyCon
tc, cc_tyargs :: Ct -> [PredType]
cc_tyargs = [PredType]
tys }) FunEqMap a
m
= FunEqMap a -> TyCon -> [PredType] -> FunEqMap a
forall a. FunEqMap a -> TyCon -> [PredType] -> FunEqMap a
delFunEq FunEqMap a
m TyCon
tc [PredType]
tys
del Ct
ct FunEqMap a
_ = String -> SDoc -> FunEqMap a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"partitionFunEqs" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
delFunEq :: FunEqMap a -> TyCon -> [PredType] -> FunEqMap a
delFunEq FunEqMap a
m TyCon
tc [PredType]
tys = FunEqMap a -> Unique -> [PredType] -> FunEqMap a
forall a. TcAppMap a -> Unique -> [PredType] -> TcAppMap a
delTcApp FunEqMap a
m (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc) [PredType]
tys
type ExactFunEqMap a = UniqFM (ListMap TypeMap a)
emptyExactFunEqs :: ExactFunEqMap a
emptyExactFunEqs :: ExactFunEqMap a
emptyExactFunEqs = ExactFunEqMap a
forall elt. UniqFM elt
emptyUFM
findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a
findExactFunEq :: ExactFunEqMap a -> TyCon -> [PredType] -> Maybe a
findExactFunEq ExactFunEqMap a
m TyCon
tc [PredType]
tys = do { ListMap TypeMap a
tys_map <- ExactFunEqMap a -> Unique -> Maybe (ListMap TypeMap a)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM ExactFunEqMap a
m (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc)
; Key (ListMap TypeMap) -> ListMap TypeMap a -> Maybe a
forall (m :: * -> *) b. TrieMap m => Key m -> m b -> Maybe b
lookupTM [PredType]
Key (ListMap TypeMap)
tys ListMap TypeMap a
tys_map }
insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a
insertExactFunEq :: ExactFunEqMap a -> TyCon -> [PredType] -> a -> ExactFunEqMap a
insertExactFunEq ExactFunEqMap a
m TyCon
tc [PredType]
tys a
val = (Maybe (ListMap TypeMap a) -> Maybe (ListMap TypeMap a))
-> ExactFunEqMap a -> Unique -> ExactFunEqMap a
forall key elt.
Uniquable key =>
(Maybe elt -> Maybe elt) -> UniqFM elt -> key -> UniqFM elt
alterUFM Maybe (ListMap TypeMap a) -> Maybe (ListMap TypeMap a)
alter_tm ExactFunEqMap a
m (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc)
where alter_tm :: Maybe (ListMap TypeMap a) -> Maybe (ListMap TypeMap a)
alter_tm Maybe (ListMap TypeMap a)
mb_tm = ListMap TypeMap a -> Maybe (ListMap TypeMap a)
forall a. a -> Maybe a
Just (Key (ListMap TypeMap)
-> a -> ListMap TypeMap a -> ListMap TypeMap a
forall (m :: * -> *) a. TrieMap m => Key m -> a -> m a -> m a
insertTM [PredType]
Key (ListMap TypeMap)
tys a
val (Maybe (ListMap TypeMap a)
mb_tm Maybe (ListMap TypeMap a) -> ListMap TypeMap a -> ListMap TypeMap a
forall a. Maybe a -> a -> a
`orElse` ListMap TypeMap a
forall (m :: * -> *) a. TrieMap m => m a
emptyTM))
data TcSEnv
= TcSEnv {
TcSEnv -> EvBindsVar
tcs_ev_binds :: EvBindsVar,
TcSEnv -> IORef Int
tcs_unified :: IORef Int,
TcSEnv -> IORef Int
tcs_count :: IORef Int,
TcSEnv -> IORef InertSet
tcs_inerts :: IORef InertSet,
TcSEnv -> IORef WorkList
tcs_worklist :: IORef WorkList
}
newtype TcS a = TcS { TcS a -> TcSEnv -> TcM a
unTcS :: TcSEnv -> TcM a } deriving (a -> TcS b -> TcS a
(a -> b) -> TcS a -> TcS b
(forall a b. (a -> b) -> TcS a -> TcS b)
-> (forall a b. a -> TcS b -> TcS a) -> Functor TcS
forall a b. a -> TcS b -> TcS a
forall a b. (a -> b) -> TcS a -> TcS b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TcS b -> TcS a
$c<$ :: forall a b. a -> TcS b -> TcS a
fmap :: (a -> b) -> TcS a -> TcS b
$cfmap :: forall a b. (a -> b) -> TcS a -> TcS b
Functor)
instance Applicative TcS where
pure :: a -> TcS a
pure a
x = (TcSEnv -> TcM a) -> TcS a
forall a. (TcSEnv -> TcM a) -> TcS a
TcS (\TcSEnv
_ -> a -> TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
<*> :: TcS (a -> b) -> TcS a -> TcS b
(<*>) = TcS (a -> b) -> TcS a -> TcS b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad TcS where
#if !MIN_VERSION_base(4,13,0)
fail = MonadFail.fail
#endif
TcS a
m >>= :: TcS a -> (a -> TcS b) -> TcS b
>>= a -> TcS b
k = (TcSEnv -> TcM b) -> TcS b
forall a. (TcSEnv -> TcM a) -> TcS a
TcS (\TcSEnv
ebs -> TcS a -> TcSEnv -> TcM a
forall a. TcS a -> TcSEnv -> TcM a
unTcS TcS a
m TcSEnv
ebs TcM a -> (a -> TcM b) -> TcM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> TcS b -> TcSEnv -> TcM b
forall a. TcS a -> TcSEnv -> TcM a
unTcS (a -> TcS b
k a
r) TcSEnv
ebs)
instance MonadFail.MonadFail TcS where
fail :: String -> TcS a
fail String
err = (TcSEnv -> TcM a) -> TcS a
forall a. (TcSEnv -> TcM a) -> TcS a
TcS (\TcSEnv
_ -> String -> TcM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err)
instance MonadUnique TcS where
getUniqueSupplyM :: TcS UniqSupply
getUniqueSupplyM = TcM UniqSupply -> TcS UniqSupply
forall a. TcM a -> TcS a
wrapTcS TcM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
instance HasModule TcS where
getModule :: TcS Module
getModule = TcM Module -> TcS Module
forall a. TcM a -> TcS a
wrapTcS TcM Module
forall (m :: * -> *). HasModule m => m Module
getModule
instance MonadThings TcS where
lookupThing :: Name -> TcS TyThing
lookupThing Name
n = TcM TyThing -> TcS TyThing
forall a. TcM a -> TcS a
wrapTcS (Name -> TcM TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing Name
n)
wrapTcS :: TcM a -> TcS a
wrapTcS :: TcM a -> TcS a
wrapTcS = (TcSEnv -> TcM a) -> TcS a
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM a) -> TcS a)
-> (TcM a -> TcSEnv -> TcM a) -> TcM a -> TcS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcM a -> TcSEnv -> TcM a
forall a b. a -> b -> a
const
wrapErrTcS :: TcM a -> TcS a
wrapErrTcS :: TcM a -> TcS a
wrapErrTcS = TcM a -> TcS a
forall a. TcM a -> TcS a
wrapTcS
wrapWarnTcS :: TcM a -> TcS a
wrapWarnTcS :: TcM a -> TcS a
wrapWarnTcS = TcM a -> TcS a
forall a. TcM a -> TcS a
wrapTcS
failTcS, panicTcS :: SDoc -> TcS a
warnTcS :: WarningFlag -> SDoc -> TcS ()
addErrTcS :: SDoc -> TcS ()
failTcS :: SDoc -> TcS a
failTcS = TcM a -> TcS a
forall a. TcM a -> TcS a
wrapTcS (TcM a -> TcS a) -> (SDoc -> TcM a) -> SDoc -> TcS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> TcM a
forall a. SDoc -> TcRn a
TcM.failWith
warnTcS :: WarningFlag -> SDoc -> TcS ()
warnTcS WarningFlag
flag = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> (SDoc -> TcM ()) -> SDoc -> TcS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarnReason -> SDoc -> TcM ()
TcM.addWarn (WarningFlag -> WarnReason
Reason WarningFlag
flag)
addErrTcS :: SDoc -> TcS ()
addErrTcS = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> (SDoc -> TcM ()) -> SDoc -> TcS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> TcM ()
TcM.addErr
panicTcS :: SDoc -> TcS a
panicTcS SDoc
doc = String -> SDoc -> TcS a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"TcCanonical" SDoc
doc
traceTcS :: String -> SDoc -> TcS ()
traceTcS :: String -> SDoc -> TcS ()
traceTcS String
herald SDoc
doc = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (String -> SDoc -> TcM ()
TcM.traceTc String
herald SDoc
doc)
runTcPluginTcS :: TcPluginM a -> TcS a
runTcPluginTcS :: TcPluginM a -> TcS a
runTcPluginTcS TcPluginM a
m = TcM a -> TcS a
forall a. TcM a -> TcS a
wrapTcS (TcM a -> TcS a) -> (EvBindsVar -> TcM a) -> EvBindsVar -> TcS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcPluginM a -> EvBindsVar -> TcM a
forall a. TcPluginM a -> EvBindsVar -> TcM a
runTcPluginM TcPluginM a
m (EvBindsVar -> TcS a) -> TcS EvBindsVar -> TcS a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TcS EvBindsVar
getTcEvBindsVar
instance HasDynFlags TcS where
getDynFlags :: TcS DynFlags
getDynFlags = TcM DynFlags -> TcS DynFlags
forall a. TcM a -> TcS a
wrapTcS TcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
getGlobalRdrEnvTcS :: TcS GlobalRdrEnv
getGlobalRdrEnvTcS :: TcS GlobalRdrEnv
getGlobalRdrEnvTcS = TcM GlobalRdrEnv -> TcS GlobalRdrEnv
forall a. TcM a -> TcS a
wrapTcS TcM GlobalRdrEnv
TcM.getGlobalRdrEnv
bumpStepCountTcS :: TcS ()
bumpStepCountTcS :: TcS ()
bumpStepCountTcS = (TcSEnv -> TcM ()) -> TcS ()
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM ()) -> TcS ()) -> (TcSEnv -> TcM ()) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \TcSEnv
env -> do { let ref :: IORef Int
ref = TcSEnv -> IORef Int
tcs_count TcSEnv
env
; Int
n <- IORef Int -> TcRnIf TcGblEnv TcLclEnv Int
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef Int
ref
; IORef Int -> Int -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
TcM.writeTcRef IORef Int
ref (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) }
csTraceTcS :: SDoc -> TcS ()
csTraceTcS :: SDoc -> TcS ()
csTraceTcS SDoc
doc
= TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> TcM () -> TcS ()
forall a b. (a -> b) -> a -> b
$ TcM SDoc -> TcM ()
csTraceTcM (SDoc -> TcM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc)
traceFireTcS :: CtEvidence -> SDoc -> TcS ()
traceFireTcS :: CtEvidence -> SDoc -> TcS ()
traceFireTcS CtEvidence
ev SDoc
doc
= (TcSEnv -> TcM ()) -> TcS ()
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM ()) -> TcS ()) -> (TcSEnv -> TcM ()) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \TcSEnv
env -> TcM SDoc -> TcM ()
csTraceTcM (TcM SDoc -> TcM ()) -> TcM SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
do { Int
n <- IORef Int -> TcRnIf TcGblEnv TcLclEnv Int
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef (TcSEnv -> IORef Int
tcs_count TcSEnv
env)
; TcLevel
tclvl <- TcM TcLevel
TcM.getTcLevel
; SDoc -> TcM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Step" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n
SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (String -> SDoc
text String
"l:" SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"d:" SDoc -> SDoc -> SDoc
<> SubGoalDepth -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CtLoc -> SubGoalDepth
ctLocDepth (CtEvidence -> CtLoc
ctEvLoc CtEvidence
ev)))
SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
4 (CtEvidence -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtEvidence
ev)) }
csTraceTcM :: TcM SDoc -> TcM ()
csTraceTcM :: TcM SDoc -> TcM ()
csTraceTcM TcM SDoc
mk_doc
= do { DynFlags
dflags <- TcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_cs_trace DynFlags
dflags
Bool -> Bool -> Bool
|| DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_tc_trace DynFlags
dflags )
( do { SDoc
msg <- TcM SDoc
mk_doc
; DumpFlag -> SDoc -> TcM ()
TcM.traceTcRn DumpFlag
Opt_D_dump_cs_trace SDoc
msg }) }
runTcS :: TcS a
-> TcM (a, EvBindMap)
runTcS :: TcS a -> TcM (a, EvBindMap)
runTcS TcS a
tcs
= do { EvBindsVar
ev_binds_var <- TcM EvBindsVar
TcM.newTcEvBinds
; a
res <- EvBindsVar -> TcS a -> TcM a
forall a. EvBindsVar -> TcS a -> TcM a
runTcSWithEvBinds EvBindsVar
ev_binds_var TcS a
tcs
; EvBindMap
ev_binds <- EvBindsVar -> TcM EvBindMap
TcM.getTcEvBindsMap EvBindsVar
ev_binds_var
; (a, EvBindMap) -> TcM (a, EvBindMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, EvBindMap
ev_binds) }
runTcSDeriveds :: TcS a -> TcM a
runTcSDeriveds :: TcS a -> TcM a
runTcSDeriveds TcS a
tcs
= do { EvBindsVar
ev_binds_var <- TcM EvBindsVar
TcM.newTcEvBinds
; EvBindsVar -> TcS a -> TcM a
forall a. EvBindsVar -> TcS a -> TcM a
runTcSWithEvBinds EvBindsVar
ev_binds_var TcS a
tcs }
runTcSEqualities :: TcS a -> TcM a
runTcSEqualities :: TcS a -> TcM a
runTcSEqualities TcS a
thing_inside
= do { EvBindsVar
ev_binds_var <- TcM EvBindsVar
TcM.newNoTcEvBinds
; EvBindsVar -> TcS a -> TcM a
forall a. EvBindsVar -> TcS a -> TcM a
runTcSWithEvBinds EvBindsVar
ev_binds_var TcS a
thing_inside }
runTcSWithEvBinds :: EvBindsVar
-> TcS a
-> TcM a
runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a
runTcSWithEvBinds EvBindsVar
ev_binds_var TcS a
tcs
= do { IORef Int
unified_var <- Int -> TcRnIf TcGblEnv TcLclEnv (IORef Int)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef Int
0
; IORef Int
step_count <- Int -> TcRnIf TcGblEnv TcLclEnv (IORef Int)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef Int
0
; IORef InertSet
inert_var <- InertSet -> TcRnIf TcGblEnv TcLclEnv (IORef InertSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef InertSet
emptyInert
; IORef WorkList
wl_var <- WorkList -> TcRnIf TcGblEnv TcLclEnv (IORef WorkList)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef WorkList
emptyWorkList
; let env :: TcSEnv
env = TcSEnv :: EvBindsVar
-> IORef Int
-> IORef Int
-> IORef InertSet
-> IORef WorkList
-> TcSEnv
TcSEnv { tcs_ev_binds :: EvBindsVar
tcs_ev_binds = EvBindsVar
ev_binds_var
, tcs_unified :: IORef Int
tcs_unified = IORef Int
unified_var
, tcs_count :: IORef Int
tcs_count = IORef Int
step_count
, tcs_inerts :: IORef InertSet
tcs_inerts = IORef InertSet
inert_var
, tcs_worklist :: IORef WorkList
tcs_worklist = IORef WorkList
wl_var }
; a
res <- TcS a -> TcSEnv -> TcM a
forall a. TcS a -> TcSEnv -> TcM a
unTcS TcS a
tcs TcSEnv
env
; Int
count <- IORef Int -> TcRnIf TcGblEnv TcLclEnv Int
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef Int
step_count
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
TcM SDoc -> TcM ()
csTraceTcM (TcM SDoc -> TcM ()) -> TcM SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SDoc
text String
"Constraint solver steps =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
count)
; IORef InertSet -> TcM ()
unflattenGivens IORef InertSet
inert_var
#if defined(DEBUG)
; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
; checkForCyclicBinds ev_binds
#endif
; a -> TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res }
#if defined(DEBUG)
checkForCyclicBinds :: EvBindMap -> TcM ()
checkForCyclicBinds ev_binds_map
| null cycles
= return ()
| null coercion_cycles
= TcM.traceTc "Cycle in evidence binds" $ ppr cycles
| otherwise
= pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
where
ev_binds = evBindMapBinds ev_binds_map
cycles :: [[EvBind]]
cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]
coercion_cycles = [c | c <- cycles, any is_co_bind c]
is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)
edges :: [ Node EvVar EvBind ]
edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))
| bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
#endif
setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a
setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a
setEvBindsTcS EvBindsVar
ref (TcS TcSEnv -> TcM a
thing_inside)
= (TcSEnv -> TcM a) -> TcS a
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM a) -> TcS a) -> (TcSEnv -> TcM a) -> TcS a
forall a b. (a -> b) -> a -> b
$ \ TcSEnv
env -> TcSEnv -> TcM a
thing_inside (TcSEnv
env { tcs_ev_binds :: EvBindsVar
tcs_ev_binds = EvBindsVar
ref })
nestImplicTcS :: EvBindsVar
-> TcLevel -> TcS a
-> TcS a
nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a
nestImplicTcS EvBindsVar
ref TcLevel
inner_tclvl (TcS TcSEnv -> TcM a
thing_inside)
= (TcSEnv -> TcM a) -> TcS a
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM a) -> TcS a) -> (TcSEnv -> TcM a) -> TcS a
forall a b. (a -> b) -> a -> b
$ \ TcSEnv { tcs_unified :: TcSEnv -> IORef Int
tcs_unified = IORef Int
unified_var
, tcs_inerts :: TcSEnv -> IORef InertSet
tcs_inerts = IORef InertSet
old_inert_var
, tcs_count :: TcSEnv -> IORef Int
tcs_count = IORef Int
count
} ->
do { InertSet
inerts <- IORef InertSet -> TcRnIf TcGblEnv TcLclEnv InertSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef InertSet
old_inert_var
; let nest_inert :: InertSet
nest_inert = InertSet
emptyInert
{ inert_cans :: InertCans
inert_cans = InertSet -> InertCans
inert_cans InertSet
inerts
, inert_solved_dicts :: DictMap CtEvidence
inert_solved_dicts = InertSet -> DictMap CtEvidence
inert_solved_dicts InertSet
inerts }
; IORef InertSet
new_inert_var <- InertSet -> TcRnIf TcGblEnv TcLclEnv (IORef InertSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef InertSet
nest_inert
; IORef WorkList
new_wl_var <- WorkList -> TcRnIf TcGblEnv TcLclEnv (IORef WorkList)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef WorkList
emptyWorkList
; let nest_env :: TcSEnv
nest_env = TcSEnv :: EvBindsVar
-> IORef Int
-> IORef Int
-> IORef InertSet
-> IORef WorkList
-> TcSEnv
TcSEnv { tcs_ev_binds :: EvBindsVar
tcs_ev_binds = EvBindsVar
ref
, tcs_unified :: IORef Int
tcs_unified = IORef Int
unified_var
, tcs_count :: IORef Int
tcs_count = IORef Int
count
, tcs_inerts :: IORef InertSet
tcs_inerts = IORef InertSet
new_inert_var
, tcs_worklist :: IORef WorkList
tcs_worklist = IORef WorkList
new_wl_var }
; a
res <- TcLevel -> TcM a -> TcM a
forall a. TcLevel -> TcM a -> TcM a
TcM.setTcLevel TcLevel
inner_tclvl (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcSEnv -> TcM a
thing_inside TcSEnv
nest_env
; IORef InertSet -> TcM ()
unflattenGivens IORef InertSet
new_inert_var
#if defined(DEBUG)
; ev_binds <- TcM.getTcEvBindsMap ref
; checkForCyclicBinds ev_binds
#endif
; a -> TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res }
nestTcS :: TcS a -> TcS a
nestTcS :: TcS a -> TcS a
nestTcS (TcS TcSEnv -> TcM a
thing_inside)
= (TcSEnv -> TcM a) -> TcS a
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM a) -> TcS a) -> (TcSEnv -> TcM a) -> TcS a
forall a b. (a -> b) -> a -> b
$ \ env :: TcSEnv
env@(TcSEnv { tcs_inerts :: TcSEnv -> IORef InertSet
tcs_inerts = IORef InertSet
inerts_var }) ->
do { InertSet
inerts <- IORef InertSet -> TcRnIf TcGblEnv TcLclEnv InertSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef InertSet
inerts_var
; IORef InertSet
new_inert_var <- InertSet -> TcRnIf TcGblEnv TcLclEnv (IORef InertSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef InertSet
inerts
; IORef WorkList
new_wl_var <- WorkList -> TcRnIf TcGblEnv TcLclEnv (IORef WorkList)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef WorkList
emptyWorkList
; let nest_env :: TcSEnv
nest_env = TcSEnv
env { tcs_inerts :: IORef InertSet
tcs_inerts = IORef InertSet
new_inert_var
, tcs_worklist :: IORef WorkList
tcs_worklist = IORef WorkList
new_wl_var }
; a
res <- TcSEnv -> TcM a
thing_inside TcSEnv
nest_env
; InertSet
new_inerts <- IORef InertSet -> TcRnIf TcGblEnv TcLclEnv InertSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef InertSet
new_inert_var
; let old_ic :: InertCans
old_ic = InertSet -> InertCans
inert_cans InertSet
inerts
new_ic :: InertCans
new_ic = InertSet -> InertCans
inert_cans InertSet
new_inerts
nxt_ic :: InertCans
nxt_ic = InertCans
old_ic { inert_safehask :: FunEqMap Ct
inert_safehask = InertCans -> FunEqMap Ct
inert_safehask InertCans
new_ic }
; IORef InertSet -> InertSet -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
TcM.writeTcRef IORef InertSet
inerts_var
(InertSet
inerts { inert_solved_dicts :: DictMap CtEvidence
inert_solved_dicts = InertSet -> DictMap CtEvidence
inert_solved_dicts InertSet
new_inerts
, inert_cans :: InertCans
inert_cans = InertCans
nxt_ic })
; a -> TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res }
emitImplicationTcS :: TcLevel -> SkolemInfo
-> [TcTyVar]
-> [EvVar]
-> Cts
-> TcS TcEvBinds
emitImplicationTcS :: TcLevel
-> SkolemInfo -> [TcTyVar] -> [TcTyVar] -> Cts -> TcS TcEvBinds
emitImplicationTcS TcLevel
new_tclvl SkolemInfo
skol_info [TcTyVar]
skol_tvs [TcTyVar]
givens Cts
wanteds
= do { let wc :: WantedConstraints
wc = WantedConstraints
emptyWC { wc_simple :: Cts
wc_simple = Cts
wanteds }
; Implication
imp <- TcM Implication -> TcS Implication
forall a. TcM a -> TcS a
wrapTcS (TcM Implication -> TcS Implication)
-> TcM Implication -> TcS Implication
forall a b. (a -> b) -> a -> b
$
do { EvBindsVar
ev_binds_var <- TcM EvBindsVar
TcM.newTcEvBinds
; Implication
imp <- TcM Implication
TcM.newImplication
; Implication -> TcM Implication
forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
imp { ic_tclvl :: TcLevel
ic_tclvl = TcLevel
new_tclvl
, ic_skols :: [TcTyVar]
ic_skols = [TcTyVar]
skol_tvs
, ic_given :: [TcTyVar]
ic_given = [TcTyVar]
givens
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
wc
, ic_binds :: EvBindsVar
ic_binds = EvBindsVar
ev_binds_var
, ic_info :: SkolemInfo
ic_info = SkolemInfo
skol_info }) }
; Implication -> TcS ()
emitImplication Implication
imp
; TcEvBinds -> TcS TcEvBinds
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar -> TcEvBinds
TcEvBinds (Implication -> EvBindsVar
ic_binds Implication
imp)) }
emitTvImplicationTcS :: TcLevel -> SkolemInfo
-> [TcTyVar]
-> Cts
-> TcS ()
emitTvImplicationTcS :: TcLevel -> SkolemInfo -> [TcTyVar] -> Cts -> TcS ()
emitTvImplicationTcS TcLevel
new_tclvl SkolemInfo
skol_info [TcTyVar]
skol_tvs Cts
wanteds
= do { let wc :: WantedConstraints
wc = WantedConstraints
emptyWC { wc_simple :: Cts
wc_simple = Cts
wanteds }
; Implication
imp <- TcM Implication -> TcS Implication
forall a. TcM a -> TcS a
wrapTcS (TcM Implication -> TcS Implication)
-> TcM Implication -> TcS Implication
forall a b. (a -> b) -> a -> b
$
do { EvBindsVar
ev_binds_var <- TcM EvBindsVar
TcM.newNoTcEvBinds
; Implication
imp <- TcM Implication
TcM.newImplication
; Implication -> TcM Implication
forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
imp { ic_tclvl :: TcLevel
ic_tclvl = TcLevel
new_tclvl
, ic_skols :: [TcTyVar]
ic_skols = [TcTyVar]
skol_tvs
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
wc
, ic_binds :: EvBindsVar
ic_binds = EvBindsVar
ev_binds_var
, ic_info :: SkolemInfo
ic_info = SkolemInfo
skol_info }) }
; Implication -> TcS ()
emitImplication Implication
imp }
getTcSInertsRef :: TcS (IORef InertSet)
getTcSInertsRef :: TcS (IORef InertSet)
getTcSInertsRef = (TcSEnv -> TcRnIf TcGblEnv TcLclEnv (IORef InertSet))
-> TcS (IORef InertSet)
forall a. (TcSEnv -> TcM a) -> TcS a
TcS (IORef InertSet -> TcRnIf TcGblEnv TcLclEnv (IORef InertSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef InertSet -> TcRnIf TcGblEnv TcLclEnv (IORef InertSet))
-> (TcSEnv -> IORef InertSet)
-> TcSEnv
-> TcRnIf TcGblEnv TcLclEnv (IORef InertSet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSEnv -> IORef InertSet
tcs_inerts)
getTcSWorkListRef :: TcS (IORef WorkList)
getTcSWorkListRef :: TcS (IORef WorkList)
getTcSWorkListRef = (TcSEnv -> TcRnIf TcGblEnv TcLclEnv (IORef WorkList))
-> TcS (IORef WorkList)
forall a. (TcSEnv -> TcM a) -> TcS a
TcS (IORef WorkList -> TcRnIf TcGblEnv TcLclEnv (IORef WorkList)
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef WorkList -> TcRnIf TcGblEnv TcLclEnv (IORef WorkList))
-> (TcSEnv -> IORef WorkList)
-> TcSEnv
-> TcRnIf TcGblEnv TcLclEnv (IORef WorkList)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSEnv -> IORef WorkList
tcs_worklist)
getTcSInerts :: TcS InertSet
getTcSInerts :: TcS InertSet
getTcSInerts = TcS (IORef InertSet)
getTcSInertsRef TcS (IORef InertSet)
-> (IORef InertSet -> TcS InertSet) -> TcS InertSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef InertSet -> TcS InertSet
forall a. TcRef a -> TcS a
readTcRef
setTcSInerts :: InertSet -> TcS ()
setTcSInerts :: InertSet -> TcS ()
setTcSInerts InertSet
ics = do { IORef InertSet
r <- TcS (IORef InertSet)
getTcSInertsRef; IORef InertSet -> InertSet -> TcS ()
forall a. TcRef a -> a -> TcS ()
writeTcRef IORef InertSet
r InertSet
ics }
getWorkListImplics :: TcS (Bag Implication)
getWorkListImplics :: TcS (Bag Implication)
getWorkListImplics
= do { IORef WorkList
wl_var <- TcS (IORef WorkList)
getTcSWorkListRef
; WorkList
wl_curr <- IORef WorkList -> TcS WorkList
forall a. TcRef a -> TcS a
readTcRef IORef WorkList
wl_var
; Bag Implication -> TcS (Bag Implication)
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkList -> Bag Implication
wl_implics WorkList
wl_curr) }
pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)
#if defined(DEBUG)
pushLevelNoWorkList err_doc (TcS thing_inside)
= TcS (\env -> TcM.pushTcLevelM $
thing_inside (env { tcs_worklist = wl_panic })
)
where
wl_panic = pprPanic "TcSMonad.buildImplication" err_doc
#else
pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)
pushLevelNoWorkList SDoc
_ (TcS TcSEnv -> TcM a
thing_inside)
= (TcSEnv -> TcM (TcLevel, a)) -> TcS (TcLevel, a)
forall a. (TcSEnv -> TcM a) -> TcS a
TcS (\TcSEnv
env -> TcM a -> TcM (TcLevel, a)
forall a. TcM a -> TcM (TcLevel, a)
TcM.pushTcLevelM (TcSEnv -> TcM a
thing_inside TcSEnv
env))
#endif
updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
updWorkListTcS WorkList -> WorkList
f
= do { IORef WorkList
wl_var <- TcS (IORef WorkList)
getTcSWorkListRef
; IORef WorkList -> (WorkList -> WorkList) -> TcS ()
forall a. TcRef a -> (a -> a) -> TcS ()
updTcRef IORef WorkList
wl_var WorkList -> WorkList
f }
emitWorkNC :: [CtEvidence] -> TcS ()
emitWorkNC :: [CtEvidence] -> TcS ()
emitWorkNC [CtEvidence]
evs
| [CtEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CtEvidence]
evs
= () -> TcS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= [Ct] -> TcS ()
emitWork ((CtEvidence -> Ct) -> [CtEvidence] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map CtEvidence -> Ct
mkNonCanonical [CtEvidence]
evs)
emitWork :: [Ct] -> TcS ()
emitWork :: [Ct] -> TcS ()
emitWork [Ct]
cts
= do { String -> SDoc -> TcS ()
traceTcS String
"Emitting fresh work" ([SDoc] -> SDoc
vcat ((Ct -> SDoc) -> [Ct] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts))
; (WorkList -> WorkList) -> TcS ()
updWorkListTcS ([Ct] -> WorkList -> WorkList
extendWorkListCts [Ct]
cts) }
emitImplication :: Implication -> TcS ()
emitImplication :: Implication -> TcS ()
emitImplication Implication
implic
= (WorkList -> WorkList) -> TcS ()
updWorkListTcS (Implication -> WorkList -> WorkList
extendWorkListImplic Implication
implic)
newTcRef :: a -> TcS (TcRef a)
newTcRef :: a -> TcS (TcRef a)
newTcRef a
x = TcM (TcRef a) -> TcS (TcRef a)
forall a. TcM a -> TcS a
wrapTcS (a -> TcM (TcRef a)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef a
x)
readTcRef :: TcRef a -> TcS a
readTcRef :: TcRef a -> TcS a
readTcRef TcRef a
ref = TcM a -> TcS a
forall a. TcM a -> TcS a
wrapTcS (TcRef a -> TcM a
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef TcRef a
ref)
writeTcRef :: TcRef a -> a -> TcS ()
writeTcRef :: TcRef a -> a -> TcS ()
writeTcRef TcRef a
ref a
val = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcRef a -> a -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
TcM.writeTcRef TcRef a
ref a
val)
updTcRef :: TcRef a -> (a->a) -> TcS ()
updTcRef :: TcRef a -> (a -> a) -> TcS ()
updTcRef TcRef a
ref a -> a
upd_fn = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcRef a -> (a -> a) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
TcM.updTcRef TcRef a
ref a -> a
upd_fn)
getTcEvBindsVar :: TcS EvBindsVar
getTcEvBindsVar :: TcS EvBindsVar
getTcEvBindsVar = (TcSEnv -> TcM EvBindsVar) -> TcS EvBindsVar
forall a. (TcSEnv -> TcM a) -> TcS a
TcS (EvBindsVar -> TcM EvBindsVar
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar -> TcM EvBindsVar)
-> (TcSEnv -> EvBindsVar) -> TcSEnv -> TcM EvBindsVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSEnv -> EvBindsVar
tcs_ev_binds)
getTcLevel :: TcS TcLevel
getTcLevel :: TcS TcLevel
getTcLevel = TcM TcLevel -> TcS TcLevel
forall a. TcM a -> TcS a
wrapTcS TcM TcLevel
TcM.getTcLevel
getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet
getTcEvTyCoVars :: EvBindsVar -> TcS VarSet
getTcEvTyCoVars EvBindsVar
ev_binds_var
= TcM VarSet -> TcS VarSet
forall a. TcM a -> TcS a
wrapTcS (TcM VarSet -> TcS VarSet) -> TcM VarSet -> TcS VarSet
forall a b. (a -> b) -> a -> b
$ EvBindsVar -> TcM VarSet
TcM.getTcEvTyCoVars EvBindsVar
ev_binds_var
getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap
getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap
getTcEvBindsMap EvBindsVar
ev_binds_var
= TcM EvBindMap -> TcS EvBindMap
forall a. TcM a -> TcS a
wrapTcS (TcM EvBindMap -> TcS EvBindMap) -> TcM EvBindMap -> TcS EvBindMap
forall a b. (a -> b) -> a -> b
$ EvBindsVar -> TcM EvBindMap
TcM.getTcEvBindsMap EvBindsVar
ev_binds_var
setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()
setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()
setTcEvBindsMap EvBindsVar
ev_binds_var EvBindMap
binds
= TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> TcM () -> TcS ()
forall a b. (a -> b) -> a -> b
$ EvBindsVar -> EvBindMap -> TcM ()
TcM.setTcEvBindsMap EvBindsVar
ev_binds_var EvBindMap
binds
unifyTyVar :: TcTyVar -> TcType -> TcS ()
unifyTyVar :: TcTyVar -> PredType -> TcS ()
unifyTyVar TcTyVar
tv PredType
ty
= ASSERT2( isMetaTyVar tv, ppr tv )
(TcSEnv -> TcM ()) -> TcS ()
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM ()) -> TcS ()) -> (TcSEnv -> TcM ()) -> TcS ()
forall a b. (a -> b) -> a -> b
$ \ TcSEnv
env ->
do { String -> SDoc -> TcM ()
TcM.traceTc String
"unifyTyVar" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
ty)
; TcTyVar -> PredType -> TcM ()
TcM.writeMetaTyVar TcTyVar
tv PredType
ty
; IORef Int -> (Int -> Int) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
TcM.updTcRef (TcSEnv -> IORef Int
tcs_unified TcSEnv
env) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) }
reportUnifications :: TcS a -> TcS (Int, a)
reportUnifications :: TcS a -> TcS (Int, a)
reportUnifications (TcS TcSEnv -> TcM a
thing_inside)
= (TcSEnv -> TcM (Int, a)) -> TcS (Int, a)
forall a. (TcSEnv -> TcM a) -> TcS a
TcS ((TcSEnv -> TcM (Int, a)) -> TcS (Int, a))
-> (TcSEnv -> TcM (Int, a)) -> TcS (Int, a)
forall a b. (a -> b) -> a -> b
$ \ TcSEnv
env ->
do { IORef Int
inner_unified <- Int -> TcRnIf TcGblEnv TcLclEnv (IORef Int)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef Int
0
; a
res <- TcSEnv -> TcM a
thing_inside (TcSEnv
env { tcs_unified :: IORef Int
tcs_unified = IORef Int
inner_unified })
; Int
n_unifs <- IORef Int -> TcRnIf TcGblEnv TcLclEnv Int
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef IORef Int
inner_unified
; IORef Int -> (Int -> Int) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
TcM.updTcRef (TcSEnv -> IORef Int
tcs_unified TcSEnv
env) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_unifs)
; (Int, a) -> TcM (Int, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n_unifs, a
res) }
getDefaultInfo :: TcS ([Type], (Bool, Bool))
getDefaultInfo :: TcS ([PredType], (Bool, Bool))
getDefaultInfo = TcM ([PredType], (Bool, Bool)) -> TcS ([PredType], (Bool, Bool))
forall a. TcM a -> TcS a
wrapTcS TcM ([PredType], (Bool, Bool))
TcM.tcGetDefaultTys
getInstEnvs :: TcS InstEnvs
getInstEnvs :: TcS InstEnvs
getInstEnvs = TcM InstEnvs -> TcS InstEnvs
forall a. TcM a -> TcS a
wrapTcS (TcM InstEnvs -> TcS InstEnvs) -> TcM InstEnvs -> TcS InstEnvs
forall a b. (a -> b) -> a -> b
$ TcM InstEnvs
TcM.tcGetInstEnvs
getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
getFamInstEnvs = TcM (FamInstEnv, FamInstEnv) -> TcS (FamInstEnv, FamInstEnv)
forall a. TcM a -> TcS a
wrapTcS (TcM (FamInstEnv, FamInstEnv) -> TcS (FamInstEnv, FamInstEnv))
-> TcM (FamInstEnv, FamInstEnv) -> TcS (FamInstEnv, FamInstEnv)
forall a b. (a -> b) -> a -> b
$ TcM (FamInstEnv, FamInstEnv)
FamInst.tcGetFamInstEnvs
getTopEnv :: TcS HscEnv
getTopEnv :: TcS HscEnv
getTopEnv = TcM HscEnv -> TcS HscEnv
forall a. TcM a -> TcS a
wrapTcS (TcM HscEnv -> TcS HscEnv) -> TcM HscEnv -> TcS HscEnv
forall a b. (a -> b) -> a -> b
$ TcM HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
TcM.getTopEnv
getGblEnv :: TcS TcGblEnv
getGblEnv :: TcS TcGblEnv
getGblEnv = TcM TcGblEnv -> TcS TcGblEnv
forall a. TcM a -> TcS a
wrapTcS (TcM TcGblEnv -> TcS TcGblEnv) -> TcM TcGblEnv -> TcS TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
TcM.getGblEnv
getLclEnv :: TcS TcLclEnv
getLclEnv :: TcS TcLclEnv
getLclEnv = TcM TcLclEnv -> TcS TcLclEnv
forall a. TcM a -> TcS a
wrapTcS (TcM TcLclEnv -> TcS TcLclEnv) -> TcM TcLclEnv -> TcS TcLclEnv
forall a b. (a -> b) -> a -> b
$ TcM TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
TcM.getLclEnv
tcLookupClass :: Name -> TcS Class
tcLookupClass :: Name -> TcS Class
tcLookupClass Name
c = TcM Class -> TcS Class
forall a. TcM a -> TcS a
wrapTcS (TcM Class -> TcS Class) -> TcM Class -> TcS Class
forall a b. (a -> b) -> a -> b
$ Name -> TcM Class
TcM.tcLookupClass Name
c
tcLookupId :: Name -> TcS Id
tcLookupId :: Name -> TcS TcTyVar
tcLookupId Name
n = TcM TcTyVar -> TcS TcTyVar
forall a. TcM a -> TcS a
wrapTcS (TcM TcTyVar -> TcS TcTyVar) -> TcM TcTyVar -> TcS TcTyVar
forall a b. (a -> b) -> a -> b
$ Name -> TcM TcTyVar
TcM.tcLookupId Name
n
addUsedGREs :: [GlobalRdrElt] -> TcS ()
addUsedGREs :: [GlobalRdrElt] -> TcS ()
addUsedGREs [GlobalRdrElt]
gres = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> TcM () -> TcS ()
forall a b. (a -> b) -> a -> b
$ [GlobalRdrElt] -> TcM ()
TcM.addUsedGREs [GlobalRdrElt]
gres
addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
addUsedGRE Bool
warn_if_deprec GlobalRdrElt
gre = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> TcM () -> TcS ()
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcM ()
TcM.addUsedGRE Bool
warn_if_deprec GlobalRdrElt
gre
keepAlive :: Name -> TcS ()
keepAlive :: Name -> TcS ()
keepAlive = TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> (Name -> TcM ()) -> Name -> TcS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM ()
TcM.keepAlive
checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
checkWellStagedDFun CtLoc
loc InstanceWhat
what PredType
pred
| TopLevInstance { iw_dfun_id :: InstanceWhat -> TcTyVar
iw_dfun_id = TcTyVar
dfun_id } <- InstanceWhat
what
, let bind_lvl :: Int
bind_lvl = TcTyVar -> Int
TcM.topIdLvl TcTyVar
dfun_id
, Int
bind_lvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
impLevel
= TcM () -> TcS ()
forall a. TcM a -> TcS a
wrapTcS (TcM () -> TcS ()) -> TcM () -> TcS ()
forall a b. (a -> b) -> a -> b
$ CtLoc -> TcM () -> TcM ()
forall a. CtLoc -> TcM a -> TcM a
TcM.setCtLocM CtLoc
loc (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
do { ThStage
use_stage <- TcM ThStage
TcM.getStage
; SDoc -> Int -> Int -> TcM ()
TcM.checkWellStaged SDoc
pp_thing Int
bind_lvl (ThStage -> Int
thLevel ThStage
use_stage) }
| Bool
otherwise
= () -> TcS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
pp_thing :: SDoc
pp_thing = String -> SDoc
text String
"instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
pred)
pprEq :: TcType -> TcType -> SDoc
pprEq :: PredType -> PredType -> SDoc
pprEq PredType
ty1 PredType
ty2 = PredType -> SDoc
pprParendType PredType
ty1 SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'~' SDoc -> SDoc -> SDoc
<+> PredType -> SDoc
pprParendType PredType
ty2
isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe PredType)
isFilledMetaTyVar_maybe TcTyVar
tv = TcM (Maybe PredType) -> TcS (Maybe PredType)
forall a. TcM a -> TcS a
wrapTcS (TcTyVar -> TcM (Maybe PredType)
TcM.isFilledMetaTyVar_maybe TcTyVar
tv