X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FBag.lhs;h=4ee8b0fafb3c76cede275526c4fd3064a93eaf61;hb=f1fd052239528b02d386bc8d07610ec81071a537;hp=15678cfbe8c8049f328568966ab0d80eff0f183f;hpb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs
index 15678cf..4ee8b0f 100644
--- a/ghc/compiler/utils/Bag.lhs
+++ b/ghc/compiler/utils/Bag.lhs
@@ -1,62 +1,52 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \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,
 	mapBag,
-#ifndef COMPILING_GHC
 	elemBag,
-#endif
-	filterBag, partitionBag, concatBag, foldBag,
-	isEmptyBag, consBag, snocBag,
-	listToBag, bagToList
+	filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag,
+	isEmptyBag, isSingletonBag, consBag, snocBag,
+	listToBag, bagToList, 
+	mapBagM, mapAndUnzipBagM
     ) where
 
-#ifdef COMPILING_GHC
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(List(partition))
+#include "HsVersions.h"
+
+import Outputable
+import Util		( isSingleton )
+import List		( partition )
+\end{code}
 
-import Outputable	( interpp'SP )
-import Pretty
-#else
-import List(partition)
-#endif
 
+\begin{code}
 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
 
-#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
 
-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
@@ -67,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
@@ -81,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 -})
@@ -104,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
@@ -120,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"
@@ -128,7 +112,24 @@ 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
+	 -> r
+
+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
+
+foldlBag :: (r -> a -> r) -> r
+	 -> Bag a
+	 -> r
+
+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
 
 
 mapBag :: (a -> b) -> Bag a -> Bag b
@@ -136,36 +137,35 @@ 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
 listToBag vs = ListBag vs
 
 bagToList :: Bag a -> [a]
-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
+bagToList b = foldrBag (:) [] b
 \end{code}
 
 \begin{code}
-#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 -}
+    ppr EmptyBag	= ptext SLIT("emptyBag")
+    ppr (UnitBag a)     = ppr a
+    ppr (TwoBags b1 b2) = hsep [ppr b1 <> comma, ppr b2]
+    ppr (ListBag as)    = interpp'SP as
 \end{code}