{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
module GHC.Tc.Solver.Types (
DictMap, emptyDictMap, findDictsByClass, addDict,
addDictsByClass, delDict, foldDicts, filterDicts, findDict,
dictsToBag, partitionDicts,
FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq,
findFunEqsByTyCon,
TcAppMap, emptyTcAppMap, isEmptyTcAppMap,
insertTcApp, alterTcApp, filterTcAppMap,
tcAppMapToBag, foldTcAppMap,
EqualCtList, filterEqualCtList, addToEqualCtList
) where
import GHC.Prelude
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Core.Class
import GHC.Core.Map.Type
import GHC.Core.Predicate
import GHC.Core.TyCon
import GHC.Core.TyCon.Env
import GHC.Data.Bag
import GHC.Data.Maybe
import GHC.Data.TrieMap
import GHC.Utils.Constants
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)
isEmptyTcAppMap :: TcAppMap a -> Bool
isEmptyTcAppMap :: forall a. TcAppMap a -> Bool
isEmptyTcAppMap TcAppMap a
m = forall a. DTyConEnv a -> Bool
isEmptyDTyConEnv TcAppMap a
m
emptyTcAppMap :: TcAppMap a
emptyTcAppMap :: forall a. TcAppMap a
emptyTcAppMap = forall a. DTyConEnv a
emptyDTyConEnv
findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a
findTcApp :: forall a. TcAppMap a -> TyCon -> [Xi] -> Maybe a
findTcApp TcAppMap a
m TyCon
tc [Xi]
tys = do { ListMap LooseTypeMap a
tys_map <- forall a. DTyConEnv a -> TyCon -> Maybe a
lookupDTyConEnv TcAppMap a
m TyCon
tc
; forall (m :: * -> *) b. TrieMap m => Key m -> m b -> Maybe b
lookupTM [Xi]
tys ListMap LooseTypeMap a
tys_map }
delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a
delTcApp :: forall a. TcAppMap a -> TyCon -> [Xi] -> TcAppMap a
delTcApp TcAppMap a
m TyCon
tc [Xi]
tys = forall a. (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a
adjustDTyConEnv (forall (m :: * -> *) a. TrieMap m => Key m -> m a -> m a
deleteTM [Xi]
tys) TcAppMap a
m TyCon
tc
insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
insertTcApp :: forall a. TcAppMap a -> TyCon -> [Xi] -> a -> TcAppMap a
insertTcApp TcAppMap a
m TyCon
tc [Xi]
tys a
ct = forall a.
(Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a
alterDTyConEnv Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm TcAppMap a
m TyCon
tc
where
alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm Maybe (ListMap LooseTypeMap a)
mb_tm = forall a. a -> Maybe a
Just (forall (m :: * -> *) a. TrieMap m => Key m -> a -> m a -> m a
insertTM [Xi]
tys a
ct (Maybe (ListMap LooseTypeMap a)
mb_tm forall a. Maybe a -> a -> a
`orElse` forall (m :: * -> *) a. TrieMap m => m a
emptyTM))
alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a
alterTcApp :: forall a. TcAppMap a -> TyCon -> [Xi] -> XT a -> TcAppMap a
alterTcApp TcAppMap a
m TyCon
tc [Xi]
tys XT a
upd = forall a.
(Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a
alterDTyConEnv Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm TcAppMap a
m TyCon
tc
where
alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm Maybe (ListMap LooseTypeMap a)
m_elt = forall a. a -> Maybe a
Just (forall (m :: * -> *) b. TrieMap m => Key m -> XT b -> m b -> m b
alterTM [Xi]
tys XT a
upd (Maybe (ListMap LooseTypeMap a)
m_elt forall a. Maybe a -> a -> a
`orElse` forall (m :: * -> *) a. TrieMap m => m a
emptyTM))
filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a
filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a
filterTcAppMap a -> Bool
f TcAppMap a
m = forall a b. (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b
mapMaybeDTyConEnv ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
one_tycon TcAppMap a
m
where
one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
one_tycon ListMap LooseTypeMap a
tm
| forall (m :: * -> *) a. TrieMap m => m a -> Bool
isEmptyTM ListMap LooseTypeMap a
filtered_tm = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just ListMap LooseTypeMap a
filtered_tm
where
filtered_tm :: ListMap LooseTypeMap a
filtered_tm = forall (m :: * -> *) a. TrieMap m => (a -> Bool) -> m a -> m a
filterTM a -> Bool
f ListMap LooseTypeMap a
tm
tcAppMapToBag :: TcAppMap a -> Bag a
tcAppMapToBag :: forall a. TcAppMap a -> Bag a
tcAppMapToBag TcAppMap a
m = forall a b. (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap forall a. a -> Bag a -> Bag a
consBag TcAppMap a
m forall a. Bag a
emptyBag
foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap :: forall a b. (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap a -> b -> b
k TcAppMap a
m b
z = forall elt a. (elt -> a -> a) -> a -> DTyConEnv elt -> a
foldDTyConEnv (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 :: forall a. TcAppMap a
emptyDictMap = forall a. TcAppMap a
emptyTcAppMap
findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
findDict :: forall a. DictMap a -> CtLoc -> Class -> [Xi] -> Maybe a
findDict DictMap a
m CtLoc
loc Class
cls [Xi]
tys
| Class -> [Xi] -> Bool
hasIPSuperClasses Class
cls [Xi]
tys
= forall a. Maybe a
Nothing
| Just {} <- Class -> [Xi] -> Maybe FastString
isCallStackPred Class
cls [Xi]
tys
, CtOrigin -> Bool
isPushCallStackOrigin (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc)
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. TcAppMap a -> TyCon -> [Xi] -> Maybe a
findTcApp DictMap a
m (Class -> TyCon
classTyCon Class
cls) [Xi]
tys
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass :: forall a. DictMap a -> Class -> Bag a
findDictsByClass DictMap a
m Class
cls
| Just ListMap LooseTypeMap a
tm <- forall a. DTyConEnv a -> TyCon -> Maybe a
lookupDTyConEnv DictMap a
m (Class -> TyCon
classTyCon Class
cls) = forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM forall a. a -> Bag a -> Bag a
consBag ListMap LooseTypeMap a
tm forall a. Bag a
emptyBag
| Bool
otherwise = forall a. Bag a
emptyBag
delDict :: DictMap a -> Class -> [Type] -> DictMap a
delDict :: forall a. DictMap a -> Class -> [Xi] -> DictMap a
delDict DictMap a
m Class
cls [Xi]
tys = forall a. TcAppMap a -> TyCon -> [Xi] -> TcAppMap a
delTcApp DictMap a
m (Class -> TyCon
classTyCon Class
cls) [Xi]
tys
addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
addDict :: forall a. DictMap a -> Class -> [Xi] -> a -> DictMap a
addDict DictMap a
m Class
cls [Xi]
tys a
item = forall a. TcAppMap a -> TyCon -> [Xi] -> a -> TcAppMap a
insertTcApp DictMap a
m (Class -> TyCon
classTyCon Class
cls) [Xi]
tys a
item
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass DictMap Ct
m Class
cls Bag Ct
items
= forall a. DTyConEnv a -> TyCon -> a -> DTyConEnv a
extendDTyConEnv DictMap Ct
m (Class -> TyCon
classTyCon Class
cls) (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {m :: * -> *}.
(Key m ~ [Xi], TrieMap m) =>
Ct -> m Ct -> m Ct
add forall (m :: * -> *) a. TrieMap m => m a
emptyTM Bag Ct
items)
where
add :: Ct -> m Ct -> m Ct
add ct :: Ct
ct@(CDictCan { cc_tyargs :: Ct -> [Xi]
cc_tyargs = [Xi]
tys }) m Ct
tm = forall (m :: * -> *) a. TrieMap m => Key m -> a -> m a -> m a
insertTM [Xi]
tys Ct
ct m Ct
tm
add Ct
ct m Ct
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addDictsByClass" (forall a. Outputable a => a -> SDoc
ppr Ct
ct)
filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
filterDicts Ct -> Bool
f DictMap Ct
m = forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a
filterTcAppMap Ct -> Bool
f DictMap Ct
m
partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
partitionDicts Ct -> Bool
f DictMap Ct
m = forall a b. (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap Ct -> (Bag Ct, DictMap Ct) -> (Bag Ct, DictMap Ct)
k DictMap Ct
m (forall a. Bag a
emptyBag, forall a. TcAppMap a
emptyDictMap)
where
k :: Ct -> (Bag Ct, DictMap Ct) -> (Bag Ct, DictMap Ct)
k Ct
ct (Bag Ct
yeses, DictMap Ct
noes) | Ct -> Bool
f Ct
ct = (Ct
ct forall a. a -> Bag a -> Bag a
`consBag` Bag Ct
yeses, DictMap Ct
noes)
| Bool
otherwise = (Bag Ct
yeses, Ct -> DictMap Ct -> DictMap Ct
add Ct
ct DictMap Ct
noes)
add :: Ct -> DictMap Ct -> DictMap Ct
add ct :: Ct
ct@(CDictCan { cc_class :: Ct -> Class
cc_class = Class
cls, cc_tyargs :: Ct -> [Xi]
cc_tyargs = [Xi]
tys }) DictMap Ct
m
= forall a. DictMap a -> Class -> [Xi] -> a -> DictMap a
addDict DictMap Ct
m Class
cls [Xi]
tys Ct
ct
add Ct
ct DictMap Ct
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"partitionDicts" (forall a. Outputable a => a -> SDoc
ppr Ct
ct)
dictsToBag :: DictMap a -> Bag a
dictsToBag :: forall a. TcAppMap a -> Bag a
dictsToBag = forall a. TcAppMap a -> Bag a
tcAppMapToBag
foldDicts :: (a -> b -> b) -> DictMap a -> b -> b
foldDicts :: forall a b. (a -> b -> b) -> TcAppMap a -> b -> b
foldDicts = forall a b. (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap
type FunEqMap a = TcAppMap a
emptyFunEqs :: TcAppMap a
emptyFunEqs :: forall a. TcAppMap a
emptyFunEqs = forall a. TcAppMap a
emptyTcAppMap
findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
findFunEq :: forall a. TcAppMap a -> TyCon -> [Xi] -> Maybe a
findFunEq FunEqMap a
m TyCon
tc [Xi]
tys = forall a. TcAppMap a -> TyCon -> [Xi] -> Maybe a
findTcApp FunEqMap a
m TyCon
tc [Xi]
tys
findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon :: forall a. FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon FunEqMap a
m TyCon
tc
| Just ListMap LooseTypeMap a
tm <- forall a. DTyConEnv a -> TyCon -> Maybe a
lookupDTyConEnv FunEqMap a
m TyCon
tc = 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 :: forall a b. (a -> b -> b) -> TcAppMap a -> b -> b
foldFunEqs = forall a b. (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap
insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
insertFunEq :: forall a. TcAppMap a -> TyCon -> [Xi] -> a -> TcAppMap a
insertFunEq FunEqMap a
m TyCon
tc [Xi]
tys a
val = forall a. TcAppMap a -> TyCon -> [Xi] -> a -> TcAppMap a
insertTcApp FunEqMap a
m TyCon
tc [Xi]
tys a
val
type EqualCtList = [Ct]
addToEqualCtList :: Ct -> EqualCtList -> EqualCtList
addToEqualCtList :: Ct -> [Ct] -> [Ct]
addToEqualCtList Ct
ct [Ct]
old_eqs
| Bool
debugIsOn
= case Ct
ct of
CEqCan { cc_lhs :: Ct -> CanEqLHS
cc_lhs = TyVarLHS TcTyVar
tv } ->
forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TcTyVar -> Ct -> Bool
shares_lhs TcTyVar
tv) [Ct]
old_eqs) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ct, Ct)]
bad_prs)
(forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"bad_prs" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [(Ct, Ct)]
bad_prs
, forall doc. IsLine doc => String -> doc
text String
"ct:old_eqs" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (Ct
ct forall a. a -> [a] -> [a]
: [Ct]
old_eqs) ]) forall a b. (a -> b) -> a -> b
$
(Ct
ct forall a. a -> [a] -> [a]
: [Ct]
old_eqs)
Ct
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addToEqualCtList not CEqCan" (forall a. Outputable a => a -> SDoc
ppr Ct
ct)
| Bool
otherwise
= Ct
ct forall a. a -> [a] -> [a]
: [Ct]
old_eqs
where
shares_lhs :: TcTyVar -> Ct -> Bool
shares_lhs TcTyVar
tv (CEqCan { cc_lhs :: Ct -> CanEqLHS
cc_lhs = TyVarLHS TcTyVar
old_tv }) = TcTyVar
tv forall a. Eq a => a -> a -> Bool
== TcTyVar
old_tv
shares_lhs TcTyVar
_ Ct
_ = Bool
False
bad_prs :: [(Ct, Ct)]
bad_prs = forall a. (a -> Bool) -> [a] -> [a]
filter (Ct, Ct) -> Bool
is_bad_pair (forall a. [a] -> [(a, a)]
distinctPairs (Ct
ct forall a. a -> [a] -> [a]
: [Ct]
old_eqs))
is_bad_pair :: (Ct, Ct) -> Bool
is_bad_pair (Ct
ct1,Ct
ct2) = Ct -> CtFlavourRole
ctFlavourRole Ct
ct1 CtFlavourRole -> CtFlavourRole -> Bool
`eqCanRewriteFR` Ct -> CtFlavourRole
ctFlavourRole Ct
ct2
distinctPairs :: [a] -> [(a,a)]
distinctPairs :: forall a. [a] -> [(a, a)]
distinctPairs [] = []
distinctPairs (a
x:[a]
xs) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
y -> [(a
x,a
y),(a
y,a
x)]) [a]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [(a, a)]
distinctPairs [a]
xs
filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList
filterEqualCtList :: (Ct -> Bool) -> [Ct] -> Maybe [Ct]
filterEqualCtList Ct -> Bool
pred [Ct]
cts
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
new_list
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just [Ct]
new_list
where
new_list :: [Ct]
new_list = forall a. (a -> Bool) -> [a] -> [a]
filter Ct -> Bool
pred [Ct]
cts