diff options
Diffstat (limited to 'ghc/compiler/utils/Bag.lhs')
| -rw-r--r-- | ghc/compiler/utils/Bag.lhs | 65 |
1 files changed, 34 insertions, 31 deletions
diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs index ed9a5407fb..4ee8b0fafb 100644 --- a/ghc/compiler/utils/Bag.lhs +++ b/ghc/compiler/utils/Bag.lhs @@ -11,13 +11,15 @@ module Bag ( mapBag, elemBag, filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag, - isEmptyBag, consBag, snocBag, - listToBag, bagToList + isEmptyBag, isSingletonBag, consBag, snocBag, + listToBag, bagToList, + mapBagM, mapAndUnzipBagM ) where #include "HsVersions.h" import Outputable +import Util ( isSingleton ) import List ( partition ) \end{code} @@ -26,10 +28,8 @@ import List ( partition ) data Bag a = EmptyBag | UnitBag a - | TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least - -- one branch is non-empty - | ListBag [a] -- The list is non-empty - | ListOfBags [Bag a] -- The list is non-empty + | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty + | ListBag [a] -- INVARIANT: the list is non-empty emptyBag = EmptyBag unitBag = UnitBag @@ -40,13 +40,13 @@ elemBag x EmptyBag = False elemBag x (UnitBag y) = x==y elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 elemBag x (ListBag ys) = any (x ==) ys -elemBag x (ListOfBags bs) = any (x `elemBag`) bs -unionManyBags [] = EmptyBag -unionManyBags xs = ListOfBags xs +unionManyBags :: [Bag a] -> Bag a +unionManyBags xs = foldr unionBags EmptyBag xs -- This one is a bit stricter! The bag will get completely evaluated. +unionBags :: Bag a -> Bag a -> Bag a unionBags EmptyBag b = b unionBags b EmptyBag = b unionBags b1 b2 = TwoBags b1 b2 @@ -57,11 +57,14 @@ snocBag :: Bag a -> a -> Bag a consBag elt bag = (unitBag elt) `unionBags` bag snocBag bag elt = bag `unionBags` (unitBag elt) -isEmptyBag EmptyBag = True -isEmptyBag (UnitBag x) = False -isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe -isEmptyBag (ListBag xs) = null xs -- Paranoid, but safe -isEmptyBag (ListOfBags bs) = all isEmptyBag bs +isEmptyBag EmptyBag = True +isEmptyBag other = False -- NB invariants + +isSingletonBag :: Bag a -> Bool +isSingletonBag EmptyBag = False +isSingletonBag (UnitBag x) = True +isSingletonBag (TwoBags b1 b2) = False -- Neither is empty +isSingletonBag (ListBag xs) = isSingleton xs filterBag :: (a -> Bool) -> Bag a -> Bag a filterBag pred EmptyBag = EmptyBag @@ -71,17 +74,12 @@ filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 sat1 = filterBag pred b1 sat2 = filterBag pred b2 filterBag pred (ListBag vs) = listToBag (filter pred vs) -filterBag pred (ListOfBags bs) = ListOfBags sats - where - sats = [filterBag pred b | b <- bs] concatBag :: Bag (Bag a) -> Bag a - concatBag EmptyBag = EmptyBag concatBag (UnitBag b) = b -concatBag (TwoBags b1 b2) = concatBag b1 `TwoBags` concatBag b2 -concatBag (ListBag bs) = ListOfBags bs -concatBag (ListOfBags bbs) = ListOfBags (map concatBag bbs) +concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2 +concatBag (ListBag bs) = unionManyBags bs partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, Bag a {- Don't -}) @@ -94,9 +92,6 @@ partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fa partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) where (sats,fails) = partition pred vs -partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails) - where - (sats, fails) = unzip [partitionBag pred b | b <- bs] foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative @@ -110,7 +105,6 @@ foldBag t u e EmptyBag = e foldBag t u e (UnitBag x) = u x foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) foldBag t u e (ListBag xs) = foldr (t.u) e xs -foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs -} -- More tail-recursive definition, exploiting associativity of "t" @@ -118,7 +112,6 @@ foldBag t u e EmptyBag = e foldBag t u e (UnitBag x) = u x `t` e foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 foldBag t u e (ListBag xs) = foldr (t.u) e xs -foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs foldrBag :: (a -> r -> r) -> r -> Bag a @@ -128,7 +121,6 @@ foldrBag k z EmptyBag = z foldrBag k z (UnitBag x) = k x z foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 foldrBag k z (ListBag xs) = foldr k z xs -foldrBag k z (ListOfBags bs) = foldr (\b r -> foldrBag k r b) z bs foldlBag :: (r -> a -> r) -> r -> Bag a @@ -138,7 +130,6 @@ foldlBag k z EmptyBag = z 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 -foldlBag k z (ListOfBags bs) = foldl (\r b -> foldlBag k r b) z bs mapBag :: (a -> b) -> Bag a -> Bag b @@ -146,8 +137,22 @@ mapBag f EmptyBag = EmptyBag mapBag f (UnitBag x) = UnitBag (f x) mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) mapBag f (ListBag xs) = ListBag (map f xs) -mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs) +mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) +mapBagM f EmptyBag = return EmptyBag +mapBagM f (UnitBag x) = do { r <- f x; return (UnitBag r) } +mapBagM f (TwoBags b1 b2) = do { r1 <- mapBagM f b1; r2 <- mapBagM f b2; return (TwoBags r1 r2) } +mapBagM f (ListBag xs) = do { rs <- mapM f xs; return (ListBag rs) } + +mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) +mapAndUnzipBagM f EmptyBag = return (EmptyBag, EmptyBag) +mapAndUnzipBagM f (UnitBag x) = do { (r,s) <- f x; return (UnitBag r, UnitBag s) } +mapAndUnzipBagM f (TwoBags b1 b2) = do { (r1,s1) <- mapAndUnzipBagM f b1 + ; (r2,s2) <- mapAndUnzipBagM f b2 + ; return (TwoBags r1 r2, TwoBags s1 s2) } +mapAndUnzipBagM f (ListBag xs) = do { ts <- mapM f xs + ; let (rs,ss) = unzip ts + ; return (ListBag rs, ListBag ss) } listToBag :: [a] -> Bag a listToBag [] = EmptyBag @@ -163,6 +168,4 @@ instance (Outputable a) => Outputable (Bag a) where ppr (UnitBag a) = ppr a ppr (TwoBags b1 b2) = hsep [ppr b1 <> comma, ppr b2] ppr (ListBag as) = interpp'SP as - ppr (ListOfBags bs) = brackets (interpp'SP bs) - \end{code} |