{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}
module GHC.Core.RoughMap
(
RoughMatchTc(..)
, isRoughWildcard
, typeToRoughMatchTc
, RoughMatchLookupTc(..)
, typeToRoughMatchLookupTc
, roughMatchTcToLookup
, roughMatchTcs
, roughMatchTcsLookup
, instanceCantMatch
, 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 GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName )
import Control.Monad (join)
import Data.Data (Data)
import GHC.Utils.Panic
data RoughMatchTc
= RM_KnownTc Name
| RM_WildCard
deriving( Typeable RoughMatchTc
Typeable RoughMatchTc =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc)
-> (RoughMatchTc -> Constr)
-> (RoughMatchTc -> DataType)
-> (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))
-> ((forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc)
-> (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 u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u)
-> (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 (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc)
-> Data RoughMatchTc
RoughMatchTc -> Constr
RoughMatchTc -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RoughMatchTc -> c RoughMatchTc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchTc
$ctoConstr :: RoughMatchTc -> Constr
toConstr :: RoughMatchTc -> Constr
$cdataTypeOf :: RoughMatchTc -> DataType
dataTypeOf :: RoughMatchTc -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchTc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchTc)
$cgmapT :: (forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
gmapT :: (forall b. Data b => b -> b) -> RoughMatchTc -> RoughMatchTc
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchTc -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchTc -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RoughMatchTc -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RoughMatchTc -> m RoughMatchTc
Data )
data RoughMatchLookupTc
= RML_KnownTc Name
| RML_NoKnownTc
| RML_WildCard
deriving ( Typeable RoughMatchLookupTc
Typeable RoughMatchLookupTc =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc)
-> (RoughMatchLookupTc -> Constr)
-> (RoughMatchLookupTc -> DataType)
-> (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))
-> ((forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc)
-> (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 u.
(forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u)
-> (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 (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc)
-> Data RoughMatchLookupTc
RoughMatchLookupTc -> Constr
RoughMatchLookupTc -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> RoughMatchLookupTc
-> c RoughMatchLookupTc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RoughMatchLookupTc
$ctoConstr :: RoughMatchLookupTc -> Constr
toConstr :: RoughMatchLookupTc -> Constr
$cdataTypeOf :: RoughMatchLookupTc -> DataType
dataTypeOf :: RoughMatchLookupTc -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RoughMatchLookupTc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RoughMatchLookupTc)
$cgmapT :: (forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
gmapT :: (forall b. Data b => b -> b)
-> RoughMatchLookupTc -> RoughMatchLookupTc
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RoughMatchLookupTc -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> RoughMatchLookupTc -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> RoughMatchLookupTc -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> RoughMatchLookupTc -> m RoughMatchLookupTc
Data )
instance Outputable RoughMatchLookupTc where
ppr :: RoughMatchLookupTc -> SDoc
ppr (RML_KnownTc Name
nm) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RML_KnownTc" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm
ppr RoughMatchLookupTc
RML_NoKnownTc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RML_NoKnownTC"
ppr RoughMatchLookupTc
RML_WildCard = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_"
instance Outputable RoughMatchTc where
ppr :: RoughMatchTc -> SDoc
ppr (RM_KnownTc Name
nm) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"KnownTc" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm
ppr RoughMatchTc
RM_WildCard = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OtherTc"
instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool
instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool
instanceCantMatch (RoughMatchTc
mt : [RoughMatchTc]
ts) (RoughMatchTc
ma : [RoughMatchTc]
as) = RoughMatchTc -> RoughMatchTc -> Bool
itemCantMatch RoughMatchTc
mt RoughMatchTc
ma Bool -> Bool -> Bool
|| [RoughMatchTc] -> [RoughMatchTc] -> Bool
instanceCantMatch [RoughMatchTc]
ts [RoughMatchTc]
as
instanceCantMatch [RoughMatchTc]
_ [RoughMatchTc]
_ = Bool
False
itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool
itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool
itemCantMatch (RM_KnownTc Name
t) (RM_KnownTc Name
a) = Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
a
itemCantMatch RoughMatchTc
_ RoughMatchTc
_ = Bool
False
roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc
roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc
roughMatchTcToLookup (RM_KnownTc Name
n) = Name -> RoughMatchLookupTc
RML_KnownTc Name
n
roughMatchTcToLookup RoughMatchTc
RM_WildCard = RoughMatchLookupTc
RML_WildCard
isRoughWildcard :: RoughMatchTc -> Bool
isRoughWildcard :: RoughMatchTc -> Bool
isRoughWildcard RoughMatchTc
RM_WildCard = Bool
True
isRoughWildcard (RM_KnownTc {}) = Bool
False
roughMatchTcs :: [Type] -> [RoughMatchTc]
roughMatchTcs :: [Type] -> [RoughMatchTc]
roughMatchTcs [Type]
tys = (Type -> RoughMatchTc) -> [Type] -> [RoughMatchTc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> RoughMatchTc
typeToRoughMatchTc [Type]
tys
roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]
roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]
roughMatchTcsLookup [Type]
tys = (Type -> RoughMatchLookupTc) -> [Type] -> [RoughMatchLookupTc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc [Type]
tys
typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc Type
ty'
| CastTy Type
ty' KindCoercion
_ <- 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 (Name -> RoughMatchLookupTc) -> Name -> RoughMatchLookupTc
forall a b. (a -> b) -> a -> b
$! TyCon -> Name
roughMatchTyConName 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', KindCoercion
_) <- Type -> Maybe (Type, KindCoercion)
splitCastTy_maybe Type
ty = Type -> RoughMatchTc
typeToRoughMatchTc Type
ty'
| Just (TyCon
tc,[Type]
_) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc) = Name -> RoughMatchTc
RM_KnownTc (Name -> RoughMatchTc) -> Name -> RoughMatchTc
forall a b. (a -> b) -> a -> b
$! TyCon -> Name
roughMatchTyConName TyCon
tc
| Bool
otherwise = RoughMatchTc
RM_WildCard
roughMatchTyConName :: TyCon -> Name
roughMatchTyConName :: TyCon -> Name
roughMatchTyConName TyCon
tc
| Name
tc_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
cONSTRAINTTyConName
= Name
tYPETyConName
| Bool
otherwise
= Bool -> SDoc -> Name -> Name
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) Name
tc_name
where
tc_name :: Name
tc_name = TyCon -> Name
tyConName TyCon
tc
data RoughMap a
= RMEmpty
| 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_wild :: RoughMap a }
deriving ((forall a b. (a -> b) -> RoughMap a -> RoughMap b)
-> (forall a b. a -> RoughMap b -> RoughMap a) -> Functor RoughMap
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
$cfmap :: forall a b. (a -> b) -> RoughMap a -> RoughMap b
fmap :: forall a b. (a -> b) -> RoughMap a -> RoughMap b
$c<$ :: forall a b. a -> RoughMap b -> RoughMap a
<$ :: forall a b. a -> RoughMap b -> RoughMap a
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
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RM"
, Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Empty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bag a -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag a
empty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Known:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DNameEnv (RoughMap a) -> SDoc
forall a. Outputable a => a -> SDoc
ppr DNameEnv (RoughMap a)
known
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unknown:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RoughMap a -> SDoc
forall a. Outputable a => a -> SDoc
ppr RoughMap a
unknown])]
ppr RoughMap a
RMEmpty = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{}"
emptyRM :: RoughMap a
emptyRM :: forall a. RoughMap a
emptyRM = RoughMap a
forall a. RoughMap a
RMEmpty
lookupRM :: [RoughMatchLookupTc] -> RoughMap a -> [a]
lookupRM :: forall a. [RoughMatchLookupTc] -> RoughMap a -> [a]
lookupRM [RoughMatchLookupTc]
tcs RoughMap a
rm = Bag a -> [a]
forall a. Bag a -> [a]
bagToList ((Bag a, [a]) -> Bag a
forall a b. (a, b) -> a
fst ((Bag a, [a]) -> Bag a) -> (Bag a, [a]) -> Bag a
forall a b. (a -> b) -> a -> b
$ [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
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
= (Bag a
forall a. Bag a
emptyBag, [])
lookupRM' [] RoughMap a
rm
= ([a] -> Bag a
forall a. [a] -> Bag a
listToBag [a]
m, [a]
m)
where
m :: [a]
m = RoughMap a -> [a]
forall a. RoughMap a -> [a]
elemsRM RoughMap a
rm
lookupRM' (RML_KnownTc Name
tc : [RoughMatchLookupTc]
tcs) RoughMap a
rm =
let (Bag a
common_m, [a]
common_u) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
(Bag a
m, [a]
u) = (Bag a, [a])
-> (RoughMap a -> (Bag a, [a]))
-> Maybe (RoughMap a)
-> (Bag a, [a])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bag a
forall a. Bag a
emptyBag, []) ([RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs) (DNameEnv (RoughMap a) -> Name -> Maybe (RoughMap a)
forall a. DNameEnv a -> Name -> Maybe a
lookupDNameEnv (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm) Name
tc)
in ( RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
common_m Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m
, Bag a -> [a]
forall a. Bag a -> [a]
bagToList (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
common_u [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u)
lookupRM' (RoughMatchLookupTc
RML_NoKnownTc : [RoughMatchLookupTc]
tcs) RoughMap a
rm =
let (Bag a
u_m, [a]
_u_u) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
in ( RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
u_m
, (Bag a, [a]) -> [a]
forall a b. (a, b) -> b
snd ((Bag a, [a]) -> [a]) -> (Bag a, [a]) -> [a]
forall a b. (a -> b) -> a -> b
$ [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' (RoughMatchLookupTc
RML_WildCard RoughMatchLookupTc -> [RoughMatchLookupTc] -> [RoughMatchLookupTc]
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) = (RoughMap a -> (Bag a, [a]) -> (Bag a, [a]))
-> (Bag a, [a]) -> DNameEnv (RoughMap a) -> (Bag a, [a])
forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
foldDNameEnv RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
forall a. RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
add_one (Bag a
forall a. Bag a
emptyBag, []) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm)
(Bag a
u_m, [a]
u_u) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
in ( RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
u_m Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m
, Bag a -> [a]
forall a. Bag a -> [a]
bagToList (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u_u [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u )
where
add_one :: RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
add_one :: forall a. RoughMap a -> (Bag a, [a]) -> (Bag a, [a])
add_one RoughMap a
rm ~(Bag a
m2, [a]
u2) = (Bag a
m1 Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag a
m2, [a]
u1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
u2)
where
(Bag a
m1,[a]
u1) = [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
tcs RoughMap a
rm
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 = RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
a Bag a -> Bag a -> Bag a
forall a. Bag a -> Bag a -> Bag a
`unionBags` RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
b
, rm_known :: DNameEnv (RoughMap a)
rm_known = (RoughMap a -> RoughMap a -> RoughMap a)
-> DNameEnv (RoughMap a)
-> DNameEnv (RoughMap a)
-> DNameEnv (RoughMap a)
forall elt.
(elt -> elt -> elt) -> DNameEnv elt -> DNameEnv elt -> DNameEnv elt
plusDNameEnv_C RoughMap a -> RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a -> RoughMap a
unionRM (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
a) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
b)
, rm_wild :: RoughMap a
rm_wild = RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
a RoughMap a -> RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a -> RoughMap a
`unionRM` RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild 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 =
[RoughMatchTc] -> a -> RoughMap a -> RoughMap a
forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
k a
v (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM { rm_empty :: Bag a
rm_empty = Bag a
forall a. Bag a
emptyBag
, rm_known :: DNameEnv (RoughMap a)
rm_known = DNameEnv (RoughMap a)
forall a. DNameEnv a
emptyDNameEnv
, rm_wild :: RoughMap a
rm_wild = RoughMap a
forall a. RoughMap a
emptyRM }
insertRM [] a
v rm :: RoughMap a
rm@(RM {}) =
RoughMap a
rm { rm_empty = v `consBag` rm_empty rm }
insertRM (RM_KnownTc Name
k : [RoughMatchTc]
ks) a
v rm :: RoughMap a
rm@(RM {}) =
RoughMap a
rm { rm_known = alterDNameEnv f (rm_known rm) k }
where
f :: Maybe (RoughMap a) -> Maybe (RoughMap a)
f Maybe (RoughMap a)
Nothing = RoughMap a -> Maybe (RoughMap a)
forall a. a -> Maybe a
Just (RoughMap a -> Maybe (RoughMap a))
-> RoughMap a -> Maybe (RoughMap a)
forall a b. (a -> b) -> a -> b
$ ([RoughMatchTc] -> a -> RoughMap a -> RoughMap a
forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
ks a
v RoughMap a
forall a. RoughMap a
emptyRM)
f (Just RoughMap a
m) = RoughMap a -> Maybe (RoughMap a)
forall a. a -> Maybe a
Just (RoughMap a -> Maybe (RoughMap a))
-> RoughMap a -> Maybe (RoughMap a)
forall a b. (a -> b) -> a -> b
$ ([RoughMatchTc] -> a -> RoughMap a -> RoughMap a
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_wild = insertRM ks v (rm_wild rm) }
filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a
filterRM :: forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
_ RoughMap a
RMEmpty = RoughMap a
forall a. RoughMap a
RMEmpty
filterRM a -> Bool
pred RoughMap a
rm =
RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
normalise (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM {
rm_empty :: Bag a
rm_empty = (a -> Bool) -> Bag a -> Bag a
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
rm_known :: DNameEnv (RoughMap a)
rm_known = (RoughMap a -> RoughMap a)
-> DNameEnv (RoughMap a) -> DNameEnv (RoughMap a)
forall a b. (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv ((a -> Bool) -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm),
rm_wild :: RoughMap a
rm_wild = (a -> Bool) -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM a -> Bool
pred (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
}
normalise :: RoughMap a -> RoughMap a
normalise :: forall a. RoughMap a -> RoughMap a
normalise RoughMap a
RMEmpty = RoughMap a
forall a. RoughMap a
RMEmpty
normalise (RM Bag a
empty DNameEnv (RoughMap a)
known RoughMap a
RMEmpty)
| Bag a -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag a
empty
, DNameEnv (RoughMap a) -> Bool
forall a. DNameEnv a -> Bool
isEmptyDNameEnv DNameEnv (RoughMap a)
known = RoughMap a
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 = RoughMap a
forall a. RoughMap a
RMEmpty
filterMatchingRM a -> Bool
pred [] RoughMap a
rm = (a -> Bool) -> RoughMap a -> RoughMap a
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 =
RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
normalise (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM {
rm_empty :: Bag a
rm_empty = (a -> Bool) -> Bag a -> Bag a
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
rm_known :: DNameEnv (RoughMap a)
rm_known = (Maybe (RoughMap a) -> Maybe (RoughMap a))
-> DNameEnv (RoughMap a) -> Name -> DNameEnv (RoughMap a)
forall a. (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a
alterDNameEnv (Maybe (Maybe (RoughMap a)) -> Maybe (RoughMap a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (RoughMap a)) -> Maybe (RoughMap a))
-> (Maybe (RoughMap a) -> Maybe (Maybe (RoughMap a)))
-> Maybe (RoughMap a)
-> Maybe (RoughMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RoughMap a -> Maybe (RoughMap a))
-> Maybe (RoughMap a) -> Maybe (Maybe (RoughMap a))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RoughMap a -> Maybe (RoughMap a)
forall a. RoughMap a -> Maybe (RoughMap a)
dropEmpty (RoughMap a -> Maybe (RoughMap a))
-> (RoughMap a -> RoughMap a) -> RoughMap a -> Maybe (RoughMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs)) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm) Name
tc,
rm_wild :: RoughMap a
rm_wild = (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
}
filterMatchingRM a -> Bool
pred (RoughMatchTc
RM_WildCard : [RoughMatchTc]
tcs) RoughMap a
rm =
RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
normalise (RoughMap a -> RoughMap a) -> RoughMap a -> RoughMap a
forall a b. (a -> b) -> a -> b
$ RM {
rm_empty :: Bag a
rm_empty = (a -> Bool) -> Bag a -> Bag a
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag a -> Bool
pred (RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm),
rm_known :: DNameEnv (RoughMap a)
rm_known = (RoughMap a -> RoughMap a)
-> DNameEnv (RoughMap a) -> DNameEnv (RoughMap a)
forall a b. (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv ((a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs) (RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm),
rm_wild :: RoughMap a
rm_wild = (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM a -> Bool
pred [RoughMatchTc]
tcs (RoughMap a -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm)
}
dropEmpty :: RoughMap a -> Maybe (RoughMap a)
dropEmpty :: forall a. RoughMap a -> Maybe (RoughMap a)
dropEmpty RoughMap a
RMEmpty = Maybe (RoughMap a)
forall a. Maybe a
Nothing
dropEmpty RoughMap a
rm = RoughMap a -> Maybe (RoughMap a)
forall a. a -> Maybe a
Just RoughMap a
rm
elemsRM :: RoughMap a -> [a]
elemsRM :: forall a. RoughMap a -> [a]
elemsRM = (a -> [a] -> [a]) -> [a] -> RoughMap a -> [a]
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_wild :: forall a. RoughMap a -> RoughMap a
rm_wild = 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}) =
(a -> b -> b) -> b -> Bag a -> b
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
a -> b -> b
f
((RoughMap a -> b -> b) -> b -> DNameEnv (RoughMap a) -> b
forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
foldDNameEnv
((b -> RoughMap a -> b) -> RoughMap a -> b -> b
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{}) =
(b -> a -> b) -> b -> Bag a -> b
forall b a. (b -> a -> b) -> b -> Bag a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
b -> a -> b
f
((RoughMap a -> b -> b) -> b -> DNameEnv (RoughMap a) -> b
forall a b. (a -> b -> b) -> b -> DNameEnv a -> b
nonDetStrictFoldDNameEnv
((b -> RoughMap a -> b) -> RoughMap a -> b -> b
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 -> RoughMap a
forall a. RoughMap a -> RoughMap a
rm_wild RoughMap a
rm))
(RoughMap a -> DNameEnv (RoughMap a)
forall a. RoughMap a -> DNameEnv (RoughMap a)
rm_known RoughMap a
rm)
)
(RoughMap a -> Bag a
forall a. RoughMap a -> Bag a
rm_empty RoughMap a
rm)
sizeRM :: RoughMap a -> Int
sizeRM :: forall a. RoughMap a -> Int
sizeRM = (Int -> a -> Int) -> Int -> RoughMap a -> Int
forall b a. (b -> a -> b) -> b -> RoughMap a -> b
nonDetStrictFoldRM (\Int
acc a
_ -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0