emptyBag, unitBag, unionBags, unionManyBags,
mapBag,
elemBag, lengthBag,
- filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag,
+ filterBag, partitionBag, partitionBagWith,
+ concatBag, foldBag, foldrBag, foldlBag,
isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
listToBag, bagToList,
- mapBagM, mapAndUnzipBagM
+ foldrBagM, foldlBagM, mapBagM, mapBagM_,
+ flatMapBagM, flatMapBagPairM,
+ mapAndUnzipBagM, mapAccumBagLM
) where
#include "Typeable.h"
import Outputable
import Util
+import MonadUtils
import Data.Data
import Data.List ( partition )
where (sats, fails) = partition pred vs
+partitionBagWith :: (a -> Either b c) -> Bag a
+ -> (Bag b {- Left -},
+ Bag c {- Right -})
+partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag)
+partitionBagWith pred (UnitBag val)
+ = case pred val of
+ Left a -> (UnitBag a, EmptyBag)
+ Right b -> (EmptyBag, UnitBag b)
+partitionBagWith pred (TwoBags b1 b2)
+ = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
+ where (sat1, fail1) = partitionBagWith pred b1
+ (sat2, fail2) = partitionBagWith pred b2
+partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails)
+ where (sats, fails) = partitionWith pred vs
+
foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
-> (a -> r) -- Replace UnitBag with this
-> r -- Replace EmptyBag with this
foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2
foldlBag k z (ListBag xs) = foldl k z xs
+foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b
+foldrBagM _ z EmptyBag = return z
+foldrBagM k z (UnitBag x) = k x z
+foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 }
+foldrBagM k z (ListBag xs) = foldrM k z xs
+
+foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b
+foldlBagM _ z EmptyBag = return z
+foldlBagM k z (UnitBag x) = k z x
+foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 }
+foldlBagM k z (ListBag xs) = foldlM k z xs
mapBag :: (a -> b) -> Bag a -> Bag b
mapBag _ EmptyBag = EmptyBag
mapBagM f (ListBag xs) = do rs <- mapM f xs
return (ListBag rs)
+mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m ()
+mapBagM_ _ EmptyBag = return ()
+mapBagM_ f (UnitBag x) = f x >> return ()
+mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2
+mapBagM_ f (ListBag xs) = mapM_ f xs
+
+flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b)
+flatMapBagM _ EmptyBag = return EmptyBag
+flatMapBagM f (UnitBag x) = f x
+flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1
+ r2 <- flatMapBagM f b2
+ return (r1 `unionBags` r2)
+flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs
+ where
+ k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) }
+
+flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c)
+flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag)
+flatMapBagPairM f (UnitBag x) = f x
+flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1
+ (r2,s2) <- flatMapBagPairM f b2
+ return (r1 `unionBags` r2, s1 `unionBags` s2)
+flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs
+ where
+ k x (r2,s2) = do { (r1,s1) <- f x
+ ; return (r1 `unionBags` r2, s1 `unionBags` s2) }
+
mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c)
mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag)
mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x
let (rs,ss) = unzip ts
return (ListBag rs, ListBag ss)
+mapAccumBagLM :: Monad m
+ => (acc -> x -> m (acc, y)) -- ^ combining funcction
+ -> acc -- ^ initial state
+ -> Bag x -- ^ inputs
+ -> m (acc, Bag y) -- ^ final state, outputs
+mapAccumBagLM _ s EmptyBag = return (s, EmptyBag)
+mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) }
+mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1
+ ; (s2, b2') <- mapAccumBagLM f s1 b2
+ ; return (s2, TwoBags b1' b2') }
+mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs
+ ; return (s', ListBag xs') }
+
listToBag :: [a] -> Bag a
listToBag [] = EmptyBag
listToBag vs = ListBag vs