{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}
module GHC.Core.RoughMap
(
RoughMatchTc(..)
, isRoughWildcard
, typeToRoughMatchTc
, RoughMatchLookupTc(..)
, typeToRoughMatchLookupTc
, roughMatchTcToLookup
, RoughMap
, emptyRM
, lookupRM
, lookupRM'
, insertRM
, filterRM
, filterMatchingRM
, elemsRM
, sizeRM
, foldRM
, unionRM
) where
import GHC.Prelude
import GHC.Data.Bag
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Env
import Control.Monad (join)
import Data.Data (Data)
import GHC.Utils.Misc
import Data.Bifunctor
import GHC.Utils.Panic
data RoughMatchTc
= RM_KnownTc Name
| RM_WildCard
deriving( Typeable RoughMatchTc
RoughMatchTc -> DataType
RoughMatchTc -> Constr
(forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
gmapT :: (forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
$cgmapT :: (forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
dataTypeOf :: RoughMatchTc -> DataType
$cdataTypeOf :: RoughMatchTc -> DataType
toConstr :: RoughMatchTc -> Constr
$ctoConstr :: RoughMatchTc -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
Data )
data RoughMatchLookupTc
= RML_KnownTc Name
| RML_NoKnownTc
| RML_WildCard
deriving ( Typeable RoughMatchLookupTc
RoughMatchLookupTc -> DataType
RoughMatchLookupTc -> Constr
(forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
gmapT :: (forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
$cgmapT :: (forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
dataTypeOf :: RoughMatchLookupTc -> DataType
$cdataTypeOf :: RoughMatchLookupTc -> DataType
toConstr :: RoughMatchLookupTc -> Constr
$ctoConstr :: RoughMatchLookupTc -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
Data )
instance Outputable RoughMatchLookupTc where
ppr :: RoughMatchLookupTc -> SDoc
ppr (RML_KnownTc Name
nm) = String -> SDoc
text String
"RML_KnownTc" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
nm
ppr RoughMatchLookupTc
RML_NoKnownTc = String -> SDoc
text String
"RML_NoKnownTC"
ppr RoughMatchLookupTc
RML_WildCard = String -> SDoc
text String
"_"
roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc
roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc
roughMatchTcToLookup (RM_KnownTc Name
n) = Name -> RoughMatchLookupTc
RML_KnownTc Name
n
roughMatchTcToLookup RoughMatchTc
RM_WildCard = RoughMatchLookupTc
RML_WildCard
instance Outputable RoughMatchTc where
ppr :: RoughMatchTc -> SDoc
ppr (RM_KnownTc Name
nm) = String -> SDoc
text String
"KnownTc" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
nm
ppr RoughMatchTc
RM_WildCard = String -> SDoc
text String
"OtherTc"
isRoughWildcard :: RoughMatchTc -> Bool
isRoughWildcard :: RoughMatchTc -> Bool
isRoughWildcard RoughMatchTc
RM_WildCard = Bool
True
isRoughWildcard (RM_KnownTc {}) = Bool
False
typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc Type
ty
| Just (Type
ty', Coercion
_) <- Type -> Maybe (Type, Coercion)
splitCastTy_maybe Type
ty = Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc Type
ty'
| Bool
otherwise =
case Type -> (Type, [Type])
splitAppTys Type
ty of
(TyVarTy {}, [Type]
_) -> RoughMatchLookupTc
RML_NoKnownTc
(TyConApp TyCon
tc [Type]
_, [Type]
_)
| Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc) -> Name -> RoughMatchLookupTc
RML_KnownTc forall a b. (a -> b) -> a -> b
$! TyCon -> Name
tyConName TyCon
tc
| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc -> RoughMatchLookupTc
RML_NoKnownTc
(Type, [Type])
_ -> RoughMatchLookupTc
RML_WildCard
typeToRoughMatchTc :: Type -> RoughMatchTc
typeToRoughMatchTc :: Type -> RoughMatchTc
typeToRoughMatchTc Type
ty
| Just (Type
ty', Coercion
_) <- Type -> Maybe (Type, Coercion)
splitCastTy_maybe Type
ty = Type -> RoughMatchTc
typeToRoughMatchTc Type
ty'
| Just (TyCon
tc,[Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc) = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal) (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
Name -> RoughMatchTc
RM_KnownTc forall a b. (a -> b) -> a -> b
$! TyCon -> Name
tyConName TyCon
tc
| Bool
otherwise = RoughMatchTc
RM_WildCard
data RoughMap a = RM { forall a. RoughMap a -> Bag a
rm_empty :: Bag a
, forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known :: DNameEnv (RoughMap a)
, forall a. RoughMap a -> RoughMap a
rm_unknown :: RoughMap a }
| RMEmpty
deriving (forall a b. a -> RoughMap b -> RoughMap a
forall a b. (a -> b) -> RoughMap a -> RoughMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RoughMap b -> RoughMap a
$c<$ :: forall a b. a -> RoughMap b -> RoughMap a
fmap :: forall a b. (a -> b) -> RoughMap a -> RoughMap b
$cfmap :: forall a b. (a -> b) -> RoughMap a -> RoughMap b
Functor)
instance Outputable a => Outputable (RoughMap a) where
ppr :: RoughMap a -> SDoc
ppr (RM Bag a
empty DNameEnv (RoughMap a)
known RoughMap a
unknown) =
[SDoc] -> SDoc
vcat [String -> SDoc
text String
"RM"
, Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Empty:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bag a
empty
, String -> SDoc
text String
"Known:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DNameEnv (RoughMap a)
known
, String -> SDoc
text String
"Unknown:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr RoughMap a
unknown])]
ppr RoughMap a
RMEmpty = String -> SDoc
text String
"{}"
emptyRM :: RoughMap a
emptyRM :: forall a. RoughMap a
emptyRM = forall a. RoughMap a
RMEmpty
lookupRM :: [RoughMatchLookupTc] -> RoughMap a -> [a]
lookupRM :: forall a. [RoughMatchLookupTc] -> RoughMap a -> [a]
lookupRM [RoughMatchLookupTc]
tcs RoughMap a
rm = forall a. Bag a -> [a]
bagToList (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs RoughMap a
rm)
lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a
, [a])
lookupRM' :: forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
_ RoughMap a
RMEmpty = (forall a. Bag a
emptyBag, [])
lookupRM' [] RoughMap a
rm = let m :: [a]
m = forall a. RoughMap a -> [a]
elemsRM RoughMap a
rm
in (forall a. [a] -> Bag a
listToBag [a]
m, [a]
m)
lookupRM' (RML_KnownTc Name
tc : [RoughMatchLookupTc]
tcs) RoughMap a
rm =
let (Bag a
common_m, [a]
common_u) = forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm)
(Bag a
m, [a]
u) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Bag a
emptyBag, []) (forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs) (forall a. DNameEnv a -> Name -> Maybe a
lookupDNameEnv (forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm) Name
tc)
in (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
common_m forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m
, forall a. Bag a -> [a]
bagToList (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm) forall a. [a] -> [a] -> [a]
++ [a]
common_u forall a. [a] -> [a] -> [a]
++ [a]
u)
lookupRM' (RoughMatchLookupTc
RML_NoKnownTc : [RoughMatchLookupTc]
tcs) RoughMap a
rm =
let (Bag a
u_m, [a]
_u_u) = forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm)
in (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
u_m
, forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' (RoughMatchLookupTc
RML_WildCard forall a. a -> [a] -> [a]
: [RoughMatchLookupTc]
tcs) RoughMap a
rm)
lookupRM' (RoughMatchLookupTc
RML_WildCard : [RoughMatchLookupTc]
tcs) RoughMap a
rm =
let (Bag a
m, [a]
u) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. [Bag a] -> Bag a
unionManyBags forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs) (forall a. DNameEnv a -> [a]
eltsDNameEnv forall a b. (a -> b) -> a -> b
$ forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm))
(Bag a
u_m, [a]
u_u) = forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm)
in (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
u_m forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m
, forall a. Bag a -> [a]
bagToList (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm) forall a. [a] -> [a] -> [a]
++ [a]
u_u forall a. [a] -> [a] -> [a]
++ [a]
u)
unionRM :: RoughMap a -> RoughMap a -> RoughMap a
unionRM :: forall a. RoughMap a -> RoughMap a -> RoughMap a
unionRM RoughMap a
RMEmpty RoughMap a
a = RoughMap a
a
unionRM RoughMap a
a RoughMap a
RMEmpty = RoughMap a
a
unionRM RoughMap a
a RoughMap a
b =
RM { rm_empty :: Bag a
rm_empty = forall a. RoughMap a -> Bag a
rm_empty RoughMap a
a forall a. Bag a -> Bag a -> Bag a
`unionBags` forall a. RoughMap a -> Bag a
rm_empty RoughMap a
b
, rm_known :: DNameEnv (RoughMap a)
rm_known = forall elt.
(elt -> elt -> elt) -> DNameEnv elt -> DNameEnv elt -> DNameEnv elt
plusDNameEnv_C forall a. RoughMap a -> RoughMap a -> RoughMap a
unionRM (forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
a) (forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
b)
, rm_unknown :: RoughMap a
rm_unknown = forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
a forall a. RoughMap a -> RoughMap a -> RoughMap a
`unionRM` forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
b
}
insertRM :: [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM :: forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
k a
v RoughMap a
RMEmpty =
forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
k a
v forall a b. (a -> b) -> a -> b
$ RM { rm_empty :: Bag a
rm_empty = forall a. Bag a
emptyBag
, rm_known :: DNameEnv (RoughMap a)
rm_known = forall a. DNameEnv a
emptyDNameEnv
, rm_unknown :: RoughMap a
rm_unknown = forall a. RoughMap a
emptyRM }
insertRM [] a
v rm :: RoughMap a
rm@(RM {}) =
RoughMap a
rm { rm_empty :: Bag a
rm_empty = a
v forall a. a -> Bag a -> Bag a
`consBag` forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm }
insertRM (RM_KnownTc Name
k : [RoughMatchTc]
ks) a
v rm :: RoughMap a
rm@(RM {}) =
RoughMap a
rm { rm_known :: DNameEnv (RoughMap a)
rm_known = forall a. (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a
alterDNameEnv Maybe (RoughMap a) -> Maybe (RoughMap a)
f (forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm) Name
k }
where
f :: Maybe (RoughMap a) -> Maybe (RoughMap a)
f Maybe (RoughMap a)
Nothing = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
ks a
v forall a. RoughMap a
emptyRM)
f (Just RoughMap a
m) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
ks a
v RoughMap a
m)
insertRM (RoughMatchTc
RM_WildCard : [RoughMatchTc]
ks) a
v rm :: RoughMap a
rm@(RM {}) =
RoughMap a
rm { rm_unknown :: RoughMap a
rm_unknown = forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
ks a
v (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm) }
filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a
filterRM :: forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
_ RoughMap a
RMEmpty = forall a. RoughMap a
RMEmpty
filterRM a -> Bool
pred RoughMap a
rm =
forall a. RoughMap a -> RoughMap a
normalise forall a b. (a -> b) -> a -> b
$ RM {
rm_empty :: Bag a
rm_empty = forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
rm_known :: DNameEnv (RoughMap a)
rm_known = forall a b. (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv (forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred) (forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm),
rm_unknown :: RoughMap a
rm_unknown = forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm)
}
normalise :: RoughMap a -> RoughMap a
normalise :: forall a. RoughMap a -> RoughMap a
normalise RoughMap a
RMEmpty = forall a. RoughMap a
RMEmpty
normalise (RM Bag a
empty DNameEnv (RoughMap a)
known RoughMap a
RMEmpty)
| forall a. Bag a -> Bool
isEmptyBag Bag a
empty
, forall a. DNameEnv a -> Bool
isEmptyDNameEnv DNameEnv (RoughMap a)
known = forall a. RoughMap a
RMEmpty
normalise RoughMap a
rm = RoughMap a
rm
filterMatchingRM :: (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM :: forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
_ [RoughMatchTc]
_ RoughMap a
RMEmpty = forall a. RoughMap a
RMEmpty
filterMatchingRM a -> Bool
pred [] RoughMap a
rm = forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred RoughMap a
rm
filterMatchingRM a -> Bool
pred (RM_KnownTc Name
tc : [RoughMatchTc]
tcs) RoughMap a
rm =
forall a. RoughMap a -> RoughMap a
normalise forall a b. (a -> b) -> a -> b
$ RM {
rm_empty :: Bag a
rm_empty = forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
rm_known :: DNameEnv (RoughMap a)
rm_known = forall a. (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a
alterDNameEnv (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. RoughMap a -> Maybe (RoughMap a)
dropEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs)) (forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm) Name
tc,
rm_unknown :: RoughMap a
rm_unknown = forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm)
}
filterMatchingRM a -> Bool
pred (RoughMatchTc
RM_WildCard : [RoughMatchTc]
tcs) RoughMap a
rm =
forall a. RoughMap a -> RoughMap a
normalise forall a b. (a -> b) -> a -> b
$ RM {
rm_empty :: Bag a
rm_empty = forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
rm_known :: DNameEnv (RoughMap a)
rm_known = forall a b. (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv (forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs) (forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm),
rm_unknown :: RoughMap a
rm_unknown = forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm)
}
dropEmpty :: RoughMap a -> Maybe (RoughMap a)
dropEmpty :: forall a. RoughMap a -> Maybe (RoughMap a)
dropEmpty RoughMap a
RMEmpty = forall a. Maybe a
Nothing
dropEmpty RoughMap a
rm = forall a. a -> Maybe a
Just RoughMap a
rm
elemsRM :: RoughMap a -> [a]
elemsRM :: forall a. RoughMap a -> [a]
elemsRM = forall a b. (a -> b -> b) -> b -> RoughMap a -> b
foldRM (:) []
foldRM :: (a -> b -> b) -> b -> RoughMap a -> b
foldRM :: forall a b. (a -> b -> b) -> b -> RoughMap a -> b
foldRM a -> b -> b
f = b -> RoughMap a -> b
go
where
go :: b -> RoughMap a -> b
go b
z RoughMap a
RMEmpty = b
z
go b
z (RM{ rm_unknown :: forall a. RoughMap a -> RoughMap a
rm_unknown = RoughMap a
unk, rm_known :: forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known = DNameEnv (RoughMap a)
known, rm_empty :: forall a. RoughMap a -> Bag a
rm_empty = Bag a
empty}) =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
a -> b -> b
f
(forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
foldDNameEnv
(forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> RoughMap a -> b
go)
(b -> RoughMap a -> b
go b
z RoughMap a
unk)
DNameEnv (RoughMap a)
known
)
Bag a
empty
nonDetStrictFoldRM :: (b -> a -> b) -> b -> RoughMap a -> b
nonDetStrictFoldRM :: forall b a. (b -> a -> b) -> b -> RoughMap a -> b
nonDetStrictFoldRM b -> a -> b
f = b -> RoughMap a -> b
go
where
go :: b -> RoughMap a -> b
go !b
z RoughMap a
RMEmpty = b
z
go b
z rm :: RoughMap a
rm@(RM{}) =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
b -> a -> b
f
(forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
nonDetStrictFoldDNameEnv
(forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> RoughMap a -> b
go)
(b -> RoughMap a -> b
go b
z (forall a. RoughMap a -> RoughMap a
rm_unknown RoughMap a
rm))
(forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm)
)
(forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm)
sizeRM :: RoughMap a -> Int
sizeRM :: forall a. RoughMap a -> Int
sizeRM = forall b a. (b -> a -> b) -> b -> RoughMap a -> b
nonDetStrictFoldRM (\Int
acc a
_ -> Int
acc forall a. Num a => a -> a -> a
+ Int
1) Int
0