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