X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FBag.lhs;h=bb0f10481a6c6c1bc083f8b15d4883966b3236f2;hb=a0f6d307b097bd788e181434a4d9b7fdd56a6c6b;hp=b2be2c30db697b411231bb63a28b39dfe1741c65;hpb=f278f0676579f67075033a4f9857715909c4b71e;p=ghc-hetmet.git

diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index b2be2c3..bb0f104 100644
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -12,10 +12,13 @@ module Bag (
         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
+        foldlBagM, mapBagM, mapBagM_, 
+        flatMapBagM, flatMapBagPairM,
+        mapAndUnzipBagM, mapAccumBagLM
     ) where
 
 #include "Typeable.h"
@@ -23,6 +26,7 @@ module Bag (
 import Outputable
 import Util
 
+import MonadUtils
 import Data.Data
 import Data.List ( partition )
 
@@ -115,6 +119,21 @@ partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)
   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
@@ -152,6 +171,11 @@ foldlBag k z (UnitBag x)     = k z x
 foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2
 foldlBag k z (ListBag xs)    = foldl 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
@@ -169,6 +193,33 @@ mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1
 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
@@ -180,6 +231,19 @@ mapAndUnzipBagM f (ListBag xs)    = do ts <- mapM f xs
                                        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