2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Bag: an unordered collection with duplicates
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
19 emptyBag, unitBag, unionBags, unionManyBags,
22 filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag,
23 isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
25 mapBagM, mapAndUnzipBagM
28 #include "HsVersions.h"
31 import Util ( isSingleton )
33 import Data.List ( partition )
41 | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
42 | ListBag [a] -- INVARIANT: the list is non-empty
47 elemBag :: Eq a => a -> Bag a -> Bool
49 elemBag x EmptyBag = False
50 elemBag x (UnitBag y) = x==y
51 elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
52 elemBag x (ListBag ys) = any (x ==) ys
54 unionManyBags :: [Bag a] -> Bag a
55 unionManyBags xs = foldr unionBags EmptyBag xs
57 -- This one is a bit stricter! The bag will get completely evaluated.
59 unionBags :: Bag a -> Bag a -> Bag a
60 unionBags EmptyBag b = b
61 unionBags b EmptyBag = b
62 unionBags b1 b2 = TwoBags b1 b2
64 consBag :: a -> Bag a -> Bag a
65 snocBag :: Bag a -> a -> Bag a
67 consBag elt bag = (unitBag elt) `unionBags` bag
68 snocBag bag elt = bag `unionBags` (unitBag elt)
70 isEmptyBag EmptyBag = True
71 isEmptyBag other = False -- NB invariants
73 isSingletonBag :: Bag a -> Bool
74 isSingletonBag EmptyBag = False
75 isSingletonBag (UnitBag x) = True
76 isSingletonBag (TwoBags b1 b2) = False -- Neither is empty
77 isSingletonBag (ListBag xs) = isSingleton xs
79 filterBag :: (a -> Bool) -> Bag a -> Bag a
80 filterBag pred EmptyBag = EmptyBag
81 filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
82 filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
84 sat1 = filterBag pred b1
85 sat2 = filterBag pred b2
86 filterBag pred (ListBag vs) = listToBag (filter pred vs)
88 anyBag :: (a -> Bool) -> Bag a -> Bool
89 anyBag p EmptyBag = False
90 anyBag p (UnitBag v) = p v
91 anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2
92 anyBag p (ListBag xs) = any p xs
94 concatBag :: Bag (Bag a) -> Bag a
95 concatBag EmptyBag = EmptyBag
96 concatBag (UnitBag b) = b
97 concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2
98 concatBag (ListBag bs) = unionManyBags bs
100 partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
102 partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
103 partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
104 partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
106 (sat1,fail1) = partitionBag pred b1
107 (sat2,fail2) = partitionBag pred b2
108 partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)
110 (sats,fails) = partition pred vs
113 foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
114 -> (a -> r) -- Replace UnitBag with this
115 -> r -- Replace EmptyBag with this
119 {- Standard definition
120 foldBag t u e EmptyBag = e
121 foldBag t u e (UnitBag x) = u x
122 foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
123 foldBag t u e (ListBag xs) = foldr (t.u) e xs
126 -- More tail-recursive definition, exploiting associativity of "t"
127 foldBag t u e EmptyBag = e
128 foldBag t u e (UnitBag x) = u x `t` e
129 foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
130 foldBag t u e (ListBag xs) = foldr (t.u) e xs
132 foldrBag :: (a -> r -> r) -> r
136 foldrBag k z EmptyBag = z
137 foldrBag k z (UnitBag x) = k x z
138 foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1
139 foldrBag k z (ListBag xs) = foldr k z xs
141 foldlBag :: (r -> a -> r) -> r
145 foldlBag k z EmptyBag = z
146 foldlBag k z (UnitBag x) = k z x
147 foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2
148 foldlBag k z (ListBag xs) = foldl k z xs
151 mapBag :: (a -> b) -> Bag a -> Bag b
152 mapBag f EmptyBag = EmptyBag
153 mapBag f (UnitBag x) = UnitBag (f x)
154 mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
155 mapBag f (ListBag xs) = ListBag (map f xs)
157 mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b)
158 mapBagM f EmptyBag = return EmptyBag
159 mapBagM f (UnitBag x) = do { r <- f x; return (UnitBag r) }
160 mapBagM f (TwoBags b1 b2) = do { r1 <- mapBagM f b1; r2 <- mapBagM f b2; return (TwoBags r1 r2) }
161 mapBagM f (ListBag xs) = do { rs <- mapM f xs; return (ListBag rs) }
163 mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c)
164 mapAndUnzipBagM f EmptyBag = return (EmptyBag, EmptyBag)
165 mapAndUnzipBagM f (UnitBag x) = do { (r,s) <- f x; return (UnitBag r, UnitBag s) }
166 mapAndUnzipBagM f (TwoBags b1 b2) = do { (r1,s1) <- mapAndUnzipBagM f b1
167 ; (r2,s2) <- mapAndUnzipBagM f b2
168 ; return (TwoBags r1 r2, TwoBags s1 s2) }
169 mapAndUnzipBagM f (ListBag xs) = do { ts <- mapM f xs
170 ; let (rs,ss) = unzip ts
171 ; return (ListBag rs, ListBag ss) }
173 listToBag :: [a] -> Bag a
174 listToBag [] = EmptyBag
175 listToBag vs = ListBag vs
177 bagToList :: Bag a -> [a]
178 bagToList b = foldrBag (:) [] b
182 instance (Outputable a) => Outputable (Bag a) where
183 ppr bag = char '<' <> pprWithCommas ppr (bagToList bag) <> char '>'