ghc/compiler/utils/Bag.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Bags]{@Bag@: an unordered collection with duplicates}
   5
   6 \begin{code}
   7 #ifdef COMPILING_GHC
   8 #include "HsVersions.h"
   9 #endif
  10
  11 module Bag (
  12         Bag,    -- abstract type
  13
  14         emptyBag, unitBag, unionBags, unionManyBags,
  15         mapBag,
  16 #ifndef COMPILING_GHC
  17         elemBag,
  18 #endif
  19         filterBag, partitionBag, concatBag, foldBag,
  20         isEmptyBag, consBag, snocBag,
  21         listToBag, bagToList
  22     ) where
  23
  24 #ifdef COMPILING_GHC
  25 IMP_Ubiq(){-uitous-}
  26 IMPORT_1_3(List(partition))
  27
  28 import Outputable       ( interpp'SP )
  29 import Pretty
  30 #else
  31 import List(partition)
  32 #endif
  33
  34 data Bag a
  35   = EmptyBag
  36   | UnitBag     a
  37   | TwoBags     (Bag a) (Bag a) -- The ADT guarantees that at least
  38                                 -- one branch is non-empty
  39   | ListBag     [a]             -- The list is non-empty
  40   | ListOfBags  [Bag a]         -- The list is non-empty
  41
  42 emptyBag = EmptyBag
  43 unitBag  = UnitBag
  44
  45 #ifndef COMPILING_GHC
  46 elemBag :: Eq a => a -> Bag a -> Bool
  47
  48 elemBag x EmptyBag        = False
  49 elemBag x (UnitBag y)     = x==y
  50 elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
  51 elemBag x (ListBag ys)    = any (x ==) ys
  52 elemBag x (ListOfBags bs) = any (x `elemBag`) bs
  53 #endif
  54
  55 unionManyBags [] = EmptyBag
  56 unionManyBags xs = ListOfBags xs
  57
  58 -- This one is a bit stricter! The bag will get completely evaluated.
  59
  60 unionBags EmptyBag b = b
  61 unionBags b EmptyBag = b
  62 unionBags b1 b2      = TwoBags b1 b2
  63
  64 consBag :: a -> Bag a -> Bag a
  65 snocBag :: Bag a -> a -> Bag a
  66
  67 consBag elt bag = (unitBag elt) `unionBags` bag
  68 snocBag bag elt = bag `unionBags` (unitBag elt)
  69
  70 isEmptyBag EmptyBag         = True
  71 isEmptyBag (UnitBag x)      = False
  72 isEmptyBag (TwoBags b1 b2)  = isEmptyBag b1 && isEmptyBag b2    -- Paranoid, but safe
  73 isEmptyBag (ListBag xs)     = null xs                           -- Paranoid, but safe
  74 isEmptyBag (ListOfBags bs)  = all isEmptyBag bs
  75
  76 filterBag :: (a -> Bool) -> Bag a -> Bag a
  77 filterBag pred EmptyBag = EmptyBag
  78 filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
  79 filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
  80                                where
  81                                  sat1 = filterBag pred b1
  82                                  sat2 = filterBag pred b2
  83 filterBag pred (ListBag vs)    = listToBag (filter pred vs)
  84 filterBag pred (ListOfBags bs) = ListOfBags sats
  85                                 where
  86                                  sats = [filterBag pred b | b <- bs]
  87
  88 concatBag :: Bag (Bag a) -> Bag a
  89
  90 concatBag EmptyBag          = EmptyBag
  91 concatBag (UnitBag b)       = b
  92 concatBag (TwoBags b1 b2)   = concatBag b1 `TwoBags` concatBag b2
  93 concatBag (ListBag bs)      = ListOfBags bs
  94 concatBag (ListOfBags bbs)  = ListOfBags (map concatBag bbs)
  95
  96 partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
  97                                          Bag a {- Don't -})
  98 partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
  99 partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
 100 partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
 101                                   where
 102                                     (sat1,fail1) = partitionBag pred b1
 103                                     (sat2,fail2) = partitionBag pred b2
 104 partitionBag pred (ListBag vs)    = (listToBag sats, listToBag fails)
 105                                   where
 106                                     (sats,fails) = partition pred vs
 107 partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
 108                                   where
 109                                     (sats, fails) = unzip [partitionBag pred b | b <- bs]
 110
 111
 112 foldBag :: (r -> r -> r)        -- Replace TwoBags with this; should be associative
 113         -> (a -> r)             -- Replace UnitBag with this
 114         -> r                    -- Replace EmptyBag with this
 115         -> Bag a
 116         -> r
 117
 118 {- Standard definition
 119 foldBag t u e EmptyBag        = e
 120 foldBag t u e (UnitBag x)     = u x
 121 foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
 122 foldBag t u e (ListBag xs)    = foldr (t.u) e xs
 123 foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
 124 -}
 125
 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
 131 foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
 132
 133
 134 mapBag :: (a -> b) -> Bag a -> Bag b
 135 mapBag f EmptyBag        = EmptyBag
 136 mapBag f (UnitBag x)     = UnitBag (f x)
 137 mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
 138 mapBag f (ListBag xs)    = ListBag (map f xs)
 139 mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
 140
 141
 142 listToBag :: [a] -> Bag a
 143 listToBag [] = EmptyBag
 144 listToBag vs = ListBag vs
 145
 146 bagToList :: Bag a -> [a]
 147 bagToList EmptyBag     = []
 148 bagToList (ListBag vs) = vs
 149 bagToList b = bagToList_append b []
 150
 151     -- (bagToList_append b xs) flattens b and puts xs on the end.
 152     -- (not exported)
 153 bagToList_append EmptyBag        xs = xs
 154 bagToList_append (UnitBag x)     xs = x:xs
 155 bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
 156 bagToList_append (ListBag xx)    xs = xx++xs
 157 bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
 158 \end{code}
 159
 160 \begin{code}
 161 #ifdef COMPILING_GHC
 162
 163 instance (Outputable a) => Outputable (Bag a) where
 164     ppr sty EmptyBag        = ppStr "emptyBag"
 165     ppr sty (UnitBag a)     = ppr sty a
 166     ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2]
 167     ppr sty (ListBag as)    = interpp'SP sty as
 168     ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack]
 169
 170 #endif {- COMPILING_GHC -}
 171 \end{code}