Data.Map: monadic combining functions

[Graham Klyne]

While discussing Data.Map and Data.Set, I'd like to raise again a point I 
mentioned previously with respect to Data.FiniteMap:
   http://www.haskell.org/pipermail/libraries/2004-November/002670.html

I since created a private copy of Data.Map with the functionality I desire [1].

At the time, concern was expressed that consistency would require a lot of 
new monadic functions to be defined.  Is there any easy way the module 
interface could be revised to allow this kind of added functionality to be 
created externally to the module?

#g
--

[1] Monadic union for Data.Map:
[[
{--------------------------------------------------------------------
   Monadic union
--------------------------------------------------------------------}

-- | /O(n+m)/.  Monadic version of union with a combining function.
--   The implementation uses the efficient /hedge-union/ algorithm.
--
--   The combining function returns a monadic value, which is threaded though
--   the combined elements in key order, yielding a Map that is bound
--   to the same monadic type.  The intended use for this is with a Maybe
--   monad, allowing result returned to be Nothing if any of the attempted
--   combinations of key values return Nothing.  Could also be usefully used
--   with an error or state monad.
--
unionWithM :: (Ord k, Monad m) =>
     (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithM f m1 m2
   = unionWithKeyM (\k x y -> f x y) m1 m2

-- | /O(n+m)/.  Monadic version of @unionWithKey at .
--   The implementation uses the efficient /hedge-union/ algorithm.
--
--   See @unionWithM@ for further details.
--
unionWithKeyM :: (Ord k, Monad m) =>
     (k -> a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithKeyM f Tip t2  = return t2
unionWithKeyM f t1 Tip  = return t1
unionWithKeyM f t1 t2
   -- hedge-union is more efficient on (bigset `union` smallset)
   | size t1 >= size t2  = hedgeUnionWithKeyML f     (const LT) (const GT) 
t1 t2
   | otherwise           = hedgeUnionWithKeyML flipf (const LT) (const GT) 
t2 t1
   where
     flipf k x y   = f k y x

-- Left version of monadic hedgeUnionWithKey.
-- (Monad is threaded left-to-right in tree)
--
hedgeUnionWithKeyML :: (Ord k, Monad m) =>
     (k -> a -> a -> m a) -> (k -> Ordering) -> (k -> Ordering) -> Map k a 
-> Map k a
     -> m (Map k a)
hedgeUnionWithKeyML f cmplo cmphi t1 Tip
   = return t1
hedgeUnionWithKeyML f cmplo cmphi Tip (Bin _ kx x l r)
   = return $ join kx x (filterGt cmplo l) (filterLt cmphi r)
hedgeUnionWithKeyML f cmplo cmphi (Bin _ kx x l r) t2
   = do { newl <- hedgeUnionWithKeyML f cmplo cmpkx l lt
        ; newx <- case found of
                     Nothing -> return x
                     Just y  -> f kx x y
        ; newr <- hedgeUnionWithKeyML f cmpkx cmphi r gt
        ; return $ join kx newx newl newr
        }
   where
     cmpkx k     = compare kx k
     lt          = trim cmplo cmpkx t2
     (found,gt)  = trimLookupLo kx cmphi t2

{-
-- Right version of monadic hedgeUnionWithKey
-- (Monad is threaded right-to-left in tree)
hedgeUnionWithKeyMR :: (Ord k, Monad m) =>
     (k -> a -> a -> m a) -> (k -> Ordering) -> (k -> Ordering) -> Map k a 
-> Map k a
     -> m (Map k a)
hedgeUnionWithKeyMR f cmplo cmphi t1 Tip
   = return t1
hedgeUnionWithKeyMR f cmplo cmphi Tip (Bin _ kx x l r)
   = return $ join kx x (filterGt cmplo l) (filterLt cmphi r)
hedgeUnionWithKeyMR f cmplo cmphi (Bin _ kx x l r) t2
   = do { newr <- hedgeUnionWithKeyMR f cmpkx cmphi r gt
        ; newx <- case found of
                     Nothing -> return x
                     Just y  -> f kx y x
        ; newl <- hedgeUnionWithKeyMR f cmplo cmpkx l lt
        ; return $ join kx newx newl newr
        }
   where
     cmpkx k     = compare kx k
     lt          = trim cmplo cmpkx t2
     (found,gt)  = trimLookupLo kx cmphi t2
-}

-- And some test cases:
fm1 = fromList [(1,["a"]),(2,["b","c"]),(3,["d"])]
fm2 = fromList [(1,["b","c"]),(4,["e"])]
fm3 = fromList [(1,["d","e"]),(2,["c","d"]),(4,["f"])]
-- Test function returns Nothing if list values have a member in common:
comb ovs nvs | null (List.intersect ovs nvs) = Just (ovs++nvs)
              | otherwise                     = Nothing
fm12 = Just $ fromList [(1,["a","b","c"]),(2,["b","c"]),(3,["d"]),(4,["e"])]
fm13 = Nothing
fm23 = Just $ fromList [(1,["b","c","d","e"]),(2,["c","d"]),(4,["e","f"])]
fmt1 = unionWithM comb fm1 fm2 == fm12
fmt2 = unionWithM comb fm1 fm3 == fm13
fmt3 = unionWithM comb fm2 fm3 == fm23
-- Test function uses state to accumulate combined keys
combk :: k -> [a] -> [a] -> State.State [k] [a]
combk k ov nv = State.State (\s -> (ov++nv,s++[k]))
fmk12 = ( fromList [(1,["a","b","c"]),(2,["b","c"]),(3,["d"]),(4,["e"])]
         , [1] )
fmk13 = (fromList [(1,["a","d","e"]),(2,["b","c","c","d"]),(3,["d"]),(4,["f"])]
         ,[1,2] )
fmk23 = (fromList [(1,["b","c","d","e"]),(2,["c","d"]),(4,["e","f"])]
         ,[1,4])
fmt4  = State.runState (unionWithKeyM combk fm1 fm2) [] == fmk12
fmt5  = State.runState (unionWithKeyM combk fm1 fm3) [] == fmk13
fmt6  = State.runState (unionWithKeyM combk fm2 fm3) []  == fmk23
fmtall = and [fmt1,fmt2,fmt3,fmt4,fmt5,fmt6]
]]


------------
Graham Klyne
For email:
http://www.ninebynine.org/#Contact