X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FBag.lhs;h=a22ccde4000f5539fece9b41f2a1f9f789725ead;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=3734df5886e60af8655de9eaecefe6b936d4c1d4;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs
index 3734df5..a22ccde 100644
--- a/ghc/compiler/utils/Bag.lhs
+++ b/ghc/compiler/utils/Bag.lhs
@@ -1,43 +1,54 @@
 %
-% (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, foldrBag,
+	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
 
@@ -46,18 +57,21 @@ unionManyBags xs = ListOfBags xs
 
 -- 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
@@ -66,12 +80,20 @@ filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
 			       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
 
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, 
+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 -},
 					 Bag a {- Don't -})
 partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
 partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
@@ -79,31 +101,70 @@ partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fa
 				  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
+
+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
+foldrBag k z (ListOfBags bs) = foldr (\b r -> foldrBag k r b) z 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 b = foldrBag (:) [] b
 \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 EmptyBag	    = ppPStr SLIT("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 -}