{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
module GHC.Tc.Solver.Types (
DictMap, emptyDictMap,
findDictsByTyConKey, findDictsByClass,
foldDicts, findDict,
dictsToBag,
FunEqMap, emptyFunEqs, findFunEq, insertFunEq,
findFunEqsByTyCon,
TcAppMap, emptyTcAppMap, isEmptyTcAppMap,
insertTcApp, alterTcApp, filterTcAppMap,
tcAppMapToBag, foldTcAppMap, delTcApp,
EqualCtList, filterEqualCtList, addToEqualCtList
) where
import GHC.Prelude
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin )
import GHC.Tc.Utils.TcType
import GHC.Types.Unique
import GHC.Types.Unique.DFM
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
type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)
isEmptyTcAppMap :: TcAppMap a -> Bool
isEmptyTcAppMap :: forall a. TcAppMap a -> Bool
isEmptyTcAppMap TcAppMap a
m = TcAppMap a -> Bool
forall a. DTyConEnv a -> Bool
isEmptyDTyConEnv TcAppMap a
m
emptyTcAppMap :: TcAppMap a
emptyTcAppMap :: forall a. TcAppMap a
emptyTcAppMap = DTyConEnv (ListMap LooseTypeMap a)
forall a. DTyConEnv a
emptyDTyConEnv
findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a
findTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> Maybe a
findTcApp TcAppMap a
m TyCon
tc [Type]
tys = do { tys_map <- TcAppMap a -> TyCon -> Maybe (ListMap LooseTypeMap a)
forall a. DTyConEnv a -> TyCon -> Maybe a
lookupDTyConEnv TcAppMap a
m TyCon
tc
; lookupTM tys tys_map }
delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a
delTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> TcAppMap a
delTcApp TcAppMap a
m TyCon
tc [Type]
tys = (ListMap LooseTypeMap a -> ListMap LooseTypeMap a)
-> TcAppMap a -> TyCon -> TcAppMap a
forall a. (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a
adjustDTyConEnv (Key (ListMap LooseTypeMap)
-> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
forall (m :: * -> *) a. TrieMap m => Key m -> m a -> m a
deleteTM [Type]
Key (ListMap LooseTypeMap)
tys) TcAppMap a
m TyCon
tc
insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
insertTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
insertTcApp TcAppMap a
m TyCon
tc [Type]
tys a
ct = (Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a))
-> TcAppMap a -> TyCon -> TcAppMap a
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 = 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 [Type]
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 a. ListMap LooseTypeMap a
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 -> [Type] -> XT a -> TcAppMap a
alterTcApp TcAppMap a
m TyCon
tc [Type]
tys XT a
upd = (Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a))
-> TcAppMap a -> TyCon -> TcAppMap a
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 = ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
forall a. a -> Maybe a
Just (Key (ListMap LooseTypeMap)
-> XT a -> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
forall b.
Key (ListMap LooseTypeMap)
-> XT b -> ListMap LooseTypeMap b -> ListMap LooseTypeMap b
forall (m :: * -> *) b. TrieMap m => Key m -> XT b -> m b -> m b
alterTM [Type]
Key (ListMap LooseTypeMap)
tys XT a
upd (Maybe (ListMap LooseTypeMap a)
m_elt Maybe (ListMap LooseTypeMap a)
-> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
forall a. Maybe a -> a -> a
`orElse` ListMap LooseTypeMap a
forall a. ListMap LooseTypeMap a
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 = (ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a))
-> TcAppMap a -> TcAppMap a
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
| ListMap LooseTypeMap a -> Bool
forall (m :: * -> *) a. TrieMap m => m a -> Bool
isEmptyTM ListMap LooseTypeMap a
filtered_tm = Maybe (ListMap LooseTypeMap a)
forall a. Maybe a
Nothing
| Bool
otherwise = ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
forall a. a -> Maybe a
Just ListMap LooseTypeMap a
filtered_tm
where
filtered_tm :: ListMap LooseTypeMap a
filtered_tm = (a -> Bool) -> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
forall a.
(a -> Bool) -> ListMap LooseTypeMap a -> ListMap LooseTypeMap a
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 = (a -> Bag a -> Bag a) -> TcAppMap a -> Bag a -> Bag a
forall a b. (a -> b -> b) -> TcAppMap 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 :: forall a b. (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 elt a. (elt -> a -> a) -> a -> DTyConEnv elt -> a
foldDTyConEnv ((a -> b -> b) -> ListMap LooseTypeMap a -> b -> b
forall a b. (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 :: forall a. TcAppMap a
emptyDictMap = TcAppMap a
forall a. TcAppMap a
emptyTcAppMap
findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
findDict :: forall a. DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
findDict DictMap a
m CtLoc
loc Class
cls [Type]
tys
| Just {} <- Class -> [Type] -> Maybe FastString
isCallStackPred Class
cls [Type]
tys
, CtOrigin -> Bool
isPushCallStackOrigin (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc)
= Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise
= DictMap a -> TyCon -> [Type] -> Maybe a
forall a. TcAppMap a -> TyCon -> [Type] -> Maybe a
findTcApp DictMap a
m (Class -> TyCon
classTyCon Class
cls) [Type]
tys
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass :: forall a. DictMap a -> Class -> Bag a
findDictsByClass DictMap a
m Class
cls = DictMap a -> Unique -> Bag a
forall a. DictMap a -> Unique -> Bag a
findDictsByTyConKey DictMap a
m (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Unique) -> TyCon -> Unique
forall a b. (a -> b) -> a -> b
$ Class -> TyCon
classTyCon Class
cls)
findDictsByTyConKey :: DictMap a -> Unique -> Bag a
findDictsByTyConKey :: forall a. DictMap a -> Unique -> Bag a
findDictsByTyConKey DictMap a
m Unique
tc
| Just ListMap LooseTypeMap a
tm <- DictMap a -> Unique -> Maybe (ListMap LooseTypeMap a)
forall {k} (key :: k) elt. UniqDFM key elt -> Unique -> Maybe elt
lookupUDFM_Directly DictMap a
m Unique
tc = (a -> Bag a -> Bag a) -> ListMap LooseTypeMap a -> Bag a -> Bag a
forall a b. (a -> b -> b) -> ListMap LooseTypeMap a -> b -> b
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
dictsToBag :: DictMap a -> Bag a
dictsToBag :: forall a. TcAppMap a -> Bag a
dictsToBag = TcAppMap a -> Bag a
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 = (a -> b -> b) -> TcAppMap a -> b -> b
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 = TcAppMap a
forall a. TcAppMap a
emptyTcAppMap
findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
findFunEq :: forall a. TcAppMap a -> TyCon -> [Type] -> Maybe a
findFunEq FunEqMap a
m TyCon
tc [Type]
tys = FunEqMap a -> TyCon -> [Type] -> Maybe a
forall a. TcAppMap a -> TyCon -> [Type] -> Maybe a
findTcApp FunEqMap a
m TyCon
tc [Type]
tys
findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon :: forall a. FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon FunEqMap a
m TyCon
tc
| Just ListMap LooseTypeMap a
tm <- FunEqMap a -> TyCon -> Maybe (ListMap LooseTypeMap a)
forall a. DTyConEnv a -> TyCon -> Maybe a
lookupDTyConEnv FunEqMap a
m TyCon
tc = (a -> [a] -> [a]) -> ListMap LooseTypeMap a -> [a] -> [a]
forall a b. (a -> b -> b) -> ListMap LooseTypeMap a -> b -> b
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM (:) ListMap LooseTypeMap a
tm []
| Bool
otherwise = []
insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
insertFunEq :: forall a. TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
insertFunEq FunEqMap a
m TyCon
tc [Type]
tys a
val = FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
forall a. TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
insertTcApp FunEqMap a
m TyCon
tc [Type]
tys a
val
type EqualCtList = [EqCt]
addToEqualCtList :: EqCt -> EqualCtList -> EqualCtList
addToEqualCtList :: EqCt -> [EqCt] -> [EqCt]
addToEqualCtList EqCt
ct [EqCt]
old_eqs
| Bool
debugIsOn
= case EqCt
ct of
EqCt { eq_lhs :: EqCt -> CanEqLHS
eq_lhs = TyVarLHS TcTyVar
tv } ->
Bool -> [EqCt] -> [EqCt]
forall a. HasCallStack => Bool -> a -> a
assert ((EqCt -> Bool) -> [EqCt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TcTyVar -> EqCt -> Bool
shares_lhs TcTyVar
tv) [EqCt]
old_eqs) ([EqCt] -> [EqCt]) -> [EqCt] -> [EqCt]
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> [EqCt] -> [EqCt]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([(EqCt, EqCt)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(EqCt, EqCt)]
bad_prs)
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bad_prs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(EqCt, EqCt)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(EqCt, EqCt)]
bad_prs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ct:old_eqs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [EqCt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (EqCt
ct EqCt -> [EqCt] -> [EqCt]
forall a. a -> [a] -> [a]
: [EqCt]
old_eqs) ]) ([EqCt] -> [EqCt]) -> [EqCt] -> [EqCt]
forall a b. (a -> b) -> a -> b
$
(EqCt
ct EqCt -> [EqCt] -> [EqCt]
forall a. a -> [a] -> [a]
: [EqCt]
old_eqs)
EqCt
_ -> String -> SDoc -> [EqCt]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addToEqualCtList not CEqCan" (EqCt -> SDoc
forall a. Outputable a => a -> SDoc
ppr EqCt
ct)
| Bool
otherwise
= EqCt
ct EqCt -> [EqCt] -> [EqCt]
forall a. a -> [a] -> [a]
: [EqCt]
old_eqs
where
shares_lhs :: TcTyVar -> EqCt -> Bool
shares_lhs TcTyVar
tv (EqCt { eq_lhs :: EqCt -> CanEqLHS
eq_lhs = TyVarLHS TcTyVar
old_tv }) = TcTyVar
tv TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
old_tv
shares_lhs TcTyVar
_ EqCt
_ = Bool
False
bad_prs :: [(EqCt, EqCt)]
bad_prs = ((EqCt, EqCt) -> Bool) -> [(EqCt, EqCt)] -> [(EqCt, EqCt)]
forall a. (a -> Bool) -> [a] -> [a]
filter (EqCt, EqCt) -> Bool
is_bad_pair ([EqCt] -> [(EqCt, EqCt)]
forall a. [a] -> [(a, a)]
distinctPairs (EqCt
ct EqCt -> [EqCt] -> [EqCt]
forall a. a -> [a] -> [a]
: [EqCt]
old_eqs))
is_bad_pair :: (EqCt, EqCt) -> Bool
is_bad_pair :: (EqCt, EqCt) -> Bool
is_bad_pair (EqCt
ct1,EqCt
ct2) = EqCt -> CtFlavourRole
eqCtFlavourRole EqCt
ct1 CtFlavourRole -> CtFlavourRole -> Bool
`eqCanRewriteFR` EqCt -> CtFlavourRole
eqCtFlavourRole EqCt
ct2
distinctPairs :: [a] -> [(a,a)]
distinctPairs :: forall a. [a] -> [(a, a)]
distinctPairs [] = []
distinctPairs (a
x:[a]
xs) = (a -> [(a, a)]) -> [a] -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
y -> [(a
x,a
y),(a
y,a
x)]) [a]
xs [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
distinctPairs [a]
xs
filterEqualCtList :: (EqCt -> Bool) -> EqualCtList -> Maybe EqualCtList
filterEqualCtList :: (EqCt -> Bool) -> [EqCt] -> Maybe [EqCt]
filterEqualCtList EqCt -> Bool
pred [EqCt]
cts
| [EqCt] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqCt]
new_list
= Maybe [EqCt]
forall a. Maybe a
Nothing
| Bool
otherwise
= [EqCt] -> Maybe [EqCt]
forall a. a -> Maybe a
Just [EqCt]
new_list
where
new_list :: [EqCt]
new_list = (EqCt -> Bool) -> [EqCt] -> [EqCt]
forall a. (a -> Bool) -> [a] -> [a]
filter EqCt -> Bool
pred [EqCt]
cts