%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Bags]{@Bag@: an unordered collection with duplicates}
\begin{code}
+#ifdef COMPILING_GHC
+#include "HsVersions.h"
+#endif
+
module Bag (
Bag, -- abstract type
emptyBag, unitBag, unionBags, unionManyBags,
-#if ! defined(COMPILING_GHC)
+ mapBag,
+#ifndef COMPILING_GHC
elemBag,
#endif
- filterBag, partitionBag,
- isEmptyBag, snocBag, listToBag, bagToList
+ filterBag, partitionBag, concatBag, foldBag,
+ isEmptyBag, consBag, snocBag,
+ listToBag, bagToList
) where
-#if defined(COMPILING_GHC)
-import Id ( Id )
-import Outputable
+#ifdef COMPILING_GHC
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
+
+import Outputable ( interpp'SP )
import Pretty
-import Util
+#else
+import List(partition)
#endif
data Bag a
= EmptyBag
| UnitBag a
| TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least
- -- one branch is non-empty.
+ -- one branch is non-empty
+ | ListBag [a] -- The list is non-empty
| ListOfBags [Bag a] -- The list is non-empty
emptyBag = EmptyBag
unitBag = UnitBag
-#if ! defined(COMPILING_GHC)
--- not used in GHC
+#ifndef COMPILING_GHC
elemBag :: Eq a => a -> Bag a -> Bool
+
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
#endif
-- This one is a bit stricter! The bag will get completely evaluated.
-
unionBags EmptyBag b = b
unionBags b EmptyBag = b
unionBags b1 b2 = TwoBags b1 b2
+consBag :: a -> Bag a -> Bag a
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 other = False
filterBag :: (a -> Bool) -> Bag a -> Bag a
filterBag pred EmptyBag = EmptyBag
where
sat1 = filterBag pred b1
sat2 = filterBag pred b2
+filterBag pred (ListBag vs) = listToBag (filter pred vs)
filterBag pred (ListOfBags bs) = ListOfBags sats
- where
+ 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)
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
+partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
Bag a {- Don't -})
partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
where
(sat1,fail1) = partitionBag pred b1
(sat2,fail2) = partitionBag pred b2
+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
+ -> (a -> r) -- Replace UnitBag with this
+ -> r -- Replace EmptyBag with this
+ -> Bag a
+ -> r
+
+{- Standard definition
+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"
+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
+
+
+mapBag :: (a -> b) -> Bag a -> Bag b
+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)
+
+
listToBag :: [a] -> Bag a
-listToBag lst = foldr TwoBags EmptyBag (map UnitBag lst)
+listToBag [] = EmptyBag
+listToBag vs = ListBag vs
bagToList :: Bag a -> [a]
-bagToList b = b_to_l b []
- where
- -- (b_to_l b xs) flattens b and puts xs on the end.
- b_to_l EmptyBag xs = xs
- b_to_l (UnitBag x) xs = x:xs
- b_to_l (TwoBags b1 b2) xs = b_to_l b1 (b_to_l b2 xs)
- b_to_l (ListOfBags bs) xs = foldr b_to_l xs bs
+bagToList EmptyBag = []
+bagToList (ListBag vs) = vs
+bagToList b = bagToList_append b []
+
+ -- (bagToList_append b xs) flattens b and puts xs on the end.
+ -- (not exported)
+bagToList_append EmptyBag xs = xs
+bagToList_append (UnitBag x) xs = x:xs
+bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
+bagToList_append (ListBag xx) xs = xx++xs
+bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
\end{code}
\begin{code}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
instance (Outputable a) => Outputable (Bag a) where
ppr sty EmptyBag = ppStr "emptyBag"
ppr sty (UnitBag a) = ppr sty a
ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2]
+ ppr sty (ListBag as) = interpp'SP sty as
ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack]
#endif {- COMPILING_GHC -}
projects / ghc-hetmet.git / blobdiff