module GHC.Types.Unique.DFM (
UniqDFM,
emptyUDFM,
unitUDFM,
addToUDFM,
addToUDFM_C,
addToUDFM_C_Directly,
addToUDFM_Directly,
addListToUDFM,
delFromUDFM,
delListFromUDFM,
adjustUDFM,
adjustUDFM_Directly,
alterUDFM,
mapUDFM,
plusUDFM,
plusUDFM_C,
lookupUDFM, lookupUDFM_Directly,
elemUDFM,
foldUDFM,
eltsUDFM,
filterUDFM, filterUDFM_Directly,
isNullUDFM,
sizeUDFM,
intersectUDFM, udfmIntersectUFM,
disjointUDFM, disjointUdfmUfm,
equalKeysUDFM,
minusUDFM,
listToUDFM, listToUDFM_Directly,
udfmMinusUFM, ufmMinusUDFM,
partitionUDFM,
anyUDFM, allUDFM,
pprUniqDFM, pprUDFM,
udfmToList,
udfmToUfm,
nonDetStrictFoldUDFM,
unsafeCastUDFMKey,
alwaysUnsafeUfmToUdfm,
) where
import GHC.Prelude
import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
import GHC.Utils.Outputable
import qualified Data.IntMap as M
import Data.Data
import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
import qualified Data.Semigroup as Semi
import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
import Unsafe.Coerce
data TaggedVal val =
TaggedVal
val
!Int
deriving (Data, Functor)
taggedFst :: TaggedVal val -> val
taggedFst (TaggedVal v _) = v
taggedSnd :: TaggedVal val -> Int
taggedSnd (TaggedVal _ i) = i
instance Eq val => Eq (TaggedVal val) where
(TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2
data UniqDFM key ele =
UDFM
!(M.IntMap (TaggedVal ele))
!Int
deriving (Data, Functor)
instance Foldable (UniqDFM key) where
foldr = foldUDFM
instance Traversable (UniqDFM key) where
traverse f = fmap listToUDFM_Directly
. traverse (\(u,a) -> (u,) <$> f a)
. udfmToList
emptyUDFM :: UniqDFM key elt
emptyUDFM = UDFM M.empty 0
unitUDFM :: Uniquable key => key -> elt -> UniqDFM key elt
unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1
addToUDFM :: Uniquable key => UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM m k v = addToUDFM_Directly m (getUnique k) v
addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt
addToUDFM_Directly (UDFM m i) u v
= UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
where
tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i
addToUDFM_C_Directly
:: (elt -> elt -> elt)
-> UniqDFM key elt
-> Unique -> elt
-> UniqDFM key elt
addToUDFM_C_Directly f (UDFM m i) u v
= UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
where
tf (TaggedVal new_v _) (TaggedVal old_v old_i)
= TaggedVal (f old_v new_v) old_i
addToUDFM_C
:: Uniquable key => (elt -> elt -> elt)
-> UniqDFM key elt
-> key -> elt
-> UniqDFM key elt
addToUDFM_C f m k v = addToUDFM_C_Directly f m (getUnique k) v
addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt
addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)
addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)
addListToUDFM_Directly_C
:: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v)
delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt
delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i
plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)
| i > j = insertUDFMIntoLeft_C f udfml udfmr
| otherwise = insertUDFMIntoLeft_C f udfmr udfml
plusUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j)
| i > j = insertUDFMIntoLeft udfml udfmr
| otherwise = insertUDFMIntoLeft udfmr udfml
insertUDFMIntoLeft :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr
insertUDFMIntoLeft_C
:: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
insertUDFMIntoLeft_C f udfml udfmr =
addListToUDFM_Directly_C f udfml $ udfmToList udfmr
lookupUDFM :: Uniquable key => UniqDFM key elt -> key -> Maybe elt
lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
lookupUDFM_Directly :: UniqDFM key elt -> Unique -> Maybe elt
lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m
elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
foldUDFM k z m = foldr k z (eltsUDFM m)
nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m
where
k' acc (TaggedVal v _) = k v acc
eltsUDFM :: UniqDFM key elt -> [elt]
eltsUDFM (UDFM m _i) =
map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m
filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i
where
p' k (TaggedVal v _) = p (getUnique k) v
udfmToList :: UniqDFM key elt -> [(Unique, elt)]
udfmToList (UDFM m _i) =
[ (getUnique k, taggedFst v)
| (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool
equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2
isNullUDFM :: UniqDFM key elt -> Bool
isNullUDFM (UDFM m _) = M.null m
sizeUDFM :: UniqDFM key elt -> Int
sizeUDFM (UDFM m _i) = M.size m
intersectUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i
udfmIntersectUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1
udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i
disjointUDFM :: UniqDFM key elt -> UniqDFM key elt -> Bool
disjointUDFM (UDFM x _i) (UDFM y _j) = M.disjoint x y
disjointUdfmUfm :: UniqDFM key elt -> UniqFM key elt2 -> Bool
disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToIntMap y)
minusUDFM :: UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1
minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i
udfmMinusUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1
udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i
ufmMinusUDFM :: UniqFM key elt1 -> UniqDFM key elt2 -> UniqFM key elt1
ufmMinusUDFM x (UDFM y _i) = unsafeIntMapToUFM (M.difference (ufmToIntMap x) y)
partitionUDFM :: (elt -> Bool) -> UniqDFM key elt -> (UniqDFM key elt, UniqDFM key elt)
partitionUDFM p (UDFM m i) =
case M.partition (p . taggedFst) m of
(left, right) -> (UDFM left i, UDFM right i)
delListFromUDFM :: Uniquable key => UniqDFM key elt -> [key] -> UniqDFM key elt
delListFromUDFM = foldl' delFromUDFM
udfmToUfm :: UniqDFM key elt -> UniqFM key elt
udfmToUfm (UDFM m _i) = unsafeIntMapToUFM (M.map taggedFst m)
listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM key elt
listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM
listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM key elt
listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM
adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt
adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i
adjustUDFM_Directly :: (elt -> elt) -> UniqDFM key elt -> Unique -> UniqDFM key elt
adjustUDFM_Directly f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey k) m) i
alterUDFM
:: Uniquable key
=> (Maybe elt -> Maybe elt)
-> UniqDFM key elt
-> key
-> UniqDFM key elt
alterUDFM f (UDFM m i) k =
UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)
where
alterf Nothing = inject $ f Nothing
alterf (Just (TaggedVal v _)) = inject $ f (Just v)
inject Nothing = Nothing
inject (Just v) = Just $ TaggedVal v i
mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i
anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool
anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
allUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool
allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m
instance Semi.Semigroup (UniqDFM key a) where
(<>) = plusUDFM
instance Monoid (UniqDFM key a) where
mempty = emptyUDFM
mappend = (Semi.<>)
alwaysUnsafeUfmToUdfm :: UniqFM key elt -> UniqDFM key elt
alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList
unsafeCastUDFMKey :: UniqDFM key1 elt -> UniqDFM key2 elt
unsafeCastUDFMKey = unsafeCoerce
instance Outputable a => Outputable (UniqDFM key a) where
ppr ufm = pprUniqDFM ppr ufm
pprUniqDFM :: (a -> SDoc) -> UniqDFM key a -> SDoc
pprUniqDFM ppr_elt ufm
= brackets $ fsep $ punctuate comma $
[ ppr uq <+> text ":->" <+> ppr_elt elt
| (uq, elt) <- udfmToList ufm ]
pprUDFM :: UniqDFM key a
-> ([a] -> SDoc)
-> SDoc
pprUDFM ufm pp = pp (eltsUDFM ufm)