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 m = isEmptyDTyConEnv m
emptyTcAppMap :: TcAppMap a
emptyTcAppMap = emptyDTyConEnv
findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a
findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc
; lookupTM tys tys_map }
delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a
delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc
insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc
where
alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a
alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc
where
alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))
filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a
filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m
where
one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
one_tycon tm
| isEmptyTM filtered_tm = Nothing
| otherwise = Just filtered_tm
where
filtered_tm = filterTM f tm
tcAppMapToBag :: TcAppMap a -> Bag a
tcAppMapToBag m = foldTcAppMap consBag m emptyBag
foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m
type DictMap a = TcAppMap a
emptyDictMap :: DictMap a
emptyDictMap = emptyTcAppMap
findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
findDict m loc cls tys
| hasIPSuperClasses cls tys
= Nothing
| Just {} <- isCallStackPred cls tys
, isPushCallStackOrigin (ctLocOrigin loc)
= Nothing
| otherwise
= findTcApp m (classTyCon cls) tys
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass m cls
| Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag
| otherwise = emptyBag
delDict :: DictMap a -> Class -> [Type] -> DictMap a
delDict m cls tys = delTcApp m (classTyCon cls) tys
addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
addDict m cls tys item = insertTcApp m (classTyCon cls) tys item
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass m cls items
= extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)
where
add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
add ct _ = pprPanic "addDictsByClass" (ppr ct)
filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
filterDicts f m = filterTcAppMap f m
partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap)
where
k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes)
| otherwise = (yeses, add ct noes)
add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m
= addDict m cls tys ct
add ct _ = pprPanic "partitionDicts" (ppr ct)
dictsToBag :: DictMap a -> Bag a
dictsToBag = tcAppMapToBag
foldDicts :: (a -> b -> b) -> DictMap a -> b -> b
foldDicts = foldTcAppMap
type FunEqMap a = TcAppMap a
emptyFunEqs :: TcAppMap a
emptyFunEqs = emptyTcAppMap
findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
findFunEq m tc tys = findTcApp m tc tys
findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
findFunEqsByTyCon m tc
| Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []
| otherwise = []
foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
foldFunEqs = foldTcAppMap
insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
insertFunEq m tc tys val = insertTcApp m tc tys val
type EqualCtList = [Ct]
addToEqualCtList :: Ct -> EqualCtList -> EqualCtList
addToEqualCtList ct old_eqs
| debugIsOn
= case ct of
CEqCan { cc_lhs = TyVarLHS tv } ->
assert (all (shares_lhs tv) old_eqs) $
assertPpr (null bad_prs)
(vcat [ text "bad_prs" <+> ppr bad_prs
, text "ct:old_eqs" <+> ppr (ct : old_eqs) ]) $
(ct : old_eqs)
_ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct)
| otherwise
= ct : old_eqs
where
shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
shares_lhs _ _ = False
bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs))
is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2
distinctPairs :: [a] -> [(a,a)]
distinctPairs [] = []
distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs
filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList
filterEqualCtList pred cts
| null new_list
= Nothing
| otherwise
= Just new_list
where
new_list = filter pred cts