MapExtras.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

-- | Sometimes we need to write our own version of functions over `Map.Map` that
-- do not appear in the "containers" library. This module is for such functions.
--
-- For example:
--
-- 1. Version of `Map.withoutKeys` where both arguments are `Map.Map`
-- 2. Comparing that two maps have exactly the same set of keys
-- 3. The intersection of two maps guarded by a predicate.
--
--    > ((dom stkcred) ◁ deleg) ▷ (dom stpool)) ==>
--    > intersectDomP (\ k v -> Map.member v stpool) stkcred deleg
module Data.MapExtras (
  StrictTriple (..),
  extract,
  noKeys,
  keysEqual,
  splitMemberMap,
  splitMemberSet,
  intersectDomP,
  intersectDomPLeft,
  intersectMapSetFold,
  disjointMapSetFold,
  extractKeys,
  extractKeysSmallSet,
  fromKeys,
  fromElems,
)
where

import Data.Foldable (toList)
import Data.Map.Internal (Map (..), balanceL, balanceR, glue, link, link2)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Set.Internal as Set
import GHC.Exts (isTrue#, reallyUnsafePtrEquality#, (==#))

data StrictTriple a b c = StrictTriple !a !b !c
  deriving (Show, Eq)

noKeys :: Ord k => Map k a -> Map k b -> Map k a
noKeys Tip _ = Tip
noKeys m Tip = m
noKeys m (Bin _ k _ ls rs) = case Map.split k m of
  (lm, rm) -> link2 lm' rm' -- We know `k` is not in either `lm` or `rm`
    where
      !lm' = noKeys lm ls
      !rm' = noKeys rm rs
{-# INLINEABLE noKeys #-}

-- | Checks if two pointers are equal. Yes means yes;
-- no means maybe. The values should be forced to at least
-- WHNF before comparison to get moderately reliable results.
ptrEq :: a -> a -> Bool
ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y ==# 1#)
{-# INLINE ptrEq #-}

keysEqual :: Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual Tip Tip = True
keysEqual Tip (Bin _ _ _ _ _) = False
keysEqual (Bin _ _ _ _ _) Tip = False
keysEqual m (Bin _ k _ ls rs) =
  case splitMemberMap k m of
    StrictTriple lm True rm -> keysEqual ls lm && keysEqual rs rm
    _ -> False
{-# INLINEABLE keysEqual #-}

-- | A variant of 'splitLookup' that indicates only whether the
-- key was present, rather than producing its value. This is used to
-- implement 'keysEqual' to avoid allocating unnecessary 'Just'
-- constructors.
--
-- /Note/ - this is a copy pasted internal function from "containers" package
-- adjusted to return `StrictTriple`
splitMemberMap :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
splitMemberMap = go
  where
    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
    go !k t =
      case t of
        Tip -> StrictTriple Tip False Tip
        Bin _ kx x l r -> case compare k kx of
          LT ->
            let !(StrictTriple lt z gt) = go k l
                !gt' = link kx x gt r
             in StrictTriple lt z gt'
          GT ->
            let !(StrictTriple lt z gt) = go k r
                !lt' = link kx x l lt
             in StrictTriple lt' z gt
          EQ -> StrictTriple l True r
{-# INLINEABLE splitMemberMap #-}

-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
-- element was found in the original set.
--
-- This is a modified version of `Set.splitMember`, where `StrictTriple` is used
-- instead of a lazy one for minor performance gain.
splitMemberSet :: Ord a => a -> Set a -> StrictTriple (Set a) Bool (Set a)
splitMemberSet _ Set.Tip = StrictTriple Set.Tip False Set.Tip
splitMemberSet x (Set.Bin _ y l r) =
  case compare x y of
    LT ->
      let !(StrictTriple lt found gt) = splitMemberSet x l
          !gt' = Set.link y gt r
       in StrictTriple lt found gt'
    GT ->
      let !(StrictTriple lt found gt) = splitMemberSet x r
          !lt' = Set.link y l lt
       in StrictTriple lt' found gt
    EQ -> StrictTriple l True r
{-# INLINEABLE splitMemberSet #-}

-- | intersetDomP p m1 m2 == Keep the key and value from m2, iff (the key is in the dom of m1) && ((p key value) is true)
intersectDomP :: Ord k => (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
intersectDomP _ Tip _ = Tip
intersectDomP _ _ Tip = Tip
intersectDomP p t1 (Bin _ k v l2 r2) =
  if mb && p k v
    then link k v l1l2 r1r2
    else link2 l1l2 r1r2
  where
    !(StrictTriple l1 mb r1) = splitMemberMap k t1
    !l1l2 = intersectDomP p l1 l2
    !r1r2 = intersectDomP p r1 r2
{-# INLINEABLE intersectDomP #-}

-- | - Similar to intersectDomP, except the Map returned has the same key as the first input map, rather than the second input map.
intersectDomPLeft :: Ord k => (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
intersectDomPLeft _ Tip _ = Tip
intersectDomPLeft _ _ Tip = Tip
intersectDomPLeft p (Bin _ k v1 l1 r1) t2 =
  case mb of
    Just v2 | p k v2 -> link k v1 l1l2 r1r2
    _other -> link2 l1l2 r1r2
  where
    !(l2, mb, r2) = Map.splitLookup k t2
    !l1l2 = intersectDomPLeft p l1 l2
    !r1r2 = intersectDomPLeft p r1 r2
{-# INLINEABLE intersectDomPLeft #-}

-- | - fold over the intersection of a Map and a Set
intersectMapSetFold :: Ord k => (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
intersectMapSetFold _accum Tip _ !ans = ans
intersectMapSetFold _accum _ set !ans | Set.null set = ans
intersectMapSetFold accum (Bin _ k v l1 l2) set !ans =
  intersectMapSetFold accum l1 s1 (addKV k v (intersectMapSetFold accum l2 s2 ans))
  where
    (s1, found, s2) = Set.splitMember k set
    addKV k1 v1 !ans1 = if found then accum k1 v1 ans1 else ans1
{-# INLINEABLE intersectMapSetFold #-}

-- | Fold with 'accum' all those pairs in the map, not appearing in the set.
disjointMapSetFold :: Ord k => (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
disjointMapSetFold _accum Tip _ !ans = ans
disjointMapSetFold accum m set !ans | Set.null set = Map.foldrWithKey' accum ans m
disjointMapSetFold accum (Bin _ k v l1 l2) set !ans =
  disjointMapSetFold accum l1 s1 (addKV k v (disjointMapSetFold accum l2 s2 ans))
  where
    (s1, found, s2) = Set.splitMember k set
    addKV k1 v1 !ans1 = if not found then accum k1 v1 ans1 else ans1
{-# INLINEABLE disjointMapSetFold #-}

-- =================================

-- This is a slightly adjusted version of `delete` from "containers"
extract# :: Ord k => k -> Map k a -> (# Maybe a, Map k a #)
extract# !k = go
  where
    go Tip = (# Nothing, Tip #)
    go t@(Bin _ kx x l r) =
      case compare k kx of
        LT
          | l' `ptrEq` l -> (# mVal, t #)
          | otherwise -> let !m = balanceR kx x l' r in (# mVal, m #)
          where
            !(# mVal, l' #) = go l
        GT
          | r' `ptrEq` r -> (# mVal, t #)
          | otherwise -> let !m = balanceL kx x l r' in (# mVal, m #)
          where
            !(# mVal, r' #) = go r
        EQ -> let !m = glue l r in (# Just x, m #)
{-# INLINE extract# #-}

-- | Just like `Map.delete`, but also returns the value if it was indeed deleted
-- from the map.
extract :: Ord k => k -> Map k b -> (Maybe b, Map k b)
extract k m =
  case extract# k m of
    (# Just v, m' #) -> (Just v, m')
    _ -> (Nothing, m)
{-# INLINE extract #-}

-- | Partition the `Map` according to keys in the `Set`. This is equivalent to:
--
-- > extractKeys m s === (withoutKeys m s, restrictKeys m s)
extractKeys :: Ord k => Map k a -> Set k -> (Map k a, Map k a)
extractKeys m s
  | Set.size s < 6 = extractKeysSmallSet m s -- See haddock for value 6
  | otherwise =
      case extractKeys# m s of
        (# w, r #) -> (w, r)
{-# INLINE extractKeys #-}

-- | It has been discovered expirementally through benchmarks that for small Set
-- size of under around 6 elements this function performs faster than
-- `extractKeys#`
extractKeysSmallSet :: Ord k => Map k a -> Set.Set k -> (Map k a, Map k a)
extractKeysSmallSet sm = Set.foldl' f (sm, Map.empty)
  where
    f acc@(without, restrict) k =
      case extract# k without of
        (# Just v, without' #) ->
          let !restrict' = Map.insert k v restrict
           in (without', restrict')
        _ -> acc
{-# INLINE extractKeysSmallSet #-}

-- | This function will produce exactly the same results as
-- `extractKeysSmallSet` for all inputs, but it performs better whenever the set
-- is big.
extractKeys# :: Ord k => Map k a -> Set k -> (# Map k a, Map k a #)
extractKeys# Tip _ = (# Tip, Tip #)
extractKeys# m Set.Tip = (# m, Tip #)
extractKeys# m@(Bin _ k x lm rm) s = (# w, r #)
  where
    !(StrictTriple ls b rs) = splitMemberSet k s
    !w
      | not b =
          if lmw `ptrEq` lm && rmw `ptrEq` rm
            then m
            else link k x lmw rmw
      | otherwise = link2 lmw rmw
    !r
      | b =
          if lmr `ptrEq` lm && rmr `ptrEq` rm
            then m
            else link k x lmr rmr
      | otherwise = link2 lmr rmr
    !(# lmw, lmr #) = extractKeys# lm ls
    !(# rmw, rmr #) = extractKeys# rm rs
{-# INLINEABLE extractKeys# #-}

-- | Convert any foldable data structure with keys to a Map. Implemented in terms of
-- `Map.fromList`, therefore last duplicate key wins.
fromKeys :: (Foldable f, Ord k) => (k -> v) -> f k -> Map k v
fromKeys f ks =
  -- Conversion implemented in terms of list instead of an Map.insert because fromList has
  -- a nice optimization for already sorted keys and with list fusion there should be no overhead
  Map.fromList [(k, f k) | k <- toList ks]
{-# INLINE [2] fromKeys #-}

{-# RULES "fromKeys/fromSet" [~2] fromKeys = Map.fromSet #-}

-- | Convert any foldable data structure with values to a Map. Implemented in terms of
-- `Map.fromList`, therefore last duplicate key wins.
fromElems ::
  (Foldable f, Ord k) =>
  -- | Function that will create a key from a value. Most common case is a hashing
  -- function.
  (v -> k) ->
  f v ->
  Map k v
fromElems f vs =
  -- Conversion implemented in terms of list instead of an Map.insert because fromList has
  -- a nice optimization for already sorted keys and with list fusion there should be no overhead
  Map.fromList [(f v, v) | v <- toList vs]
{-# INLINE fromElems #-}