Commit e4cdbb7b authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Fix warnings in utils/Bag.lhs

parent ff073cf3
......@@ -6,48 +6,41 @@
Bag: an unordered collection with duplicates
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Bag (
Bag, -- abstract type
emptyBag, unitBag, unionBags, unionManyBags,
mapBag,
elemBag,
filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag,
isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
listToBag, bagToList,
mapBagM, mapAndUnzipBagM
Bag, -- abstract type
emptyBag, unitBag, unionBags, unionManyBags,
mapBag,
elemBag,
filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag,
isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
listToBag, bagToList,
mapBagM, mapAndUnzipBagM
) where
#include "HsVersions.h"
import Outputable
import Util ( isSingleton )
import Util ( isSingleton )
import Data.List ( partition )
import Data.List ( partition )
\end{code}
\begin{code}
data Bag a
= EmptyBag
| UnitBag a
| TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
| ListBag [a] -- INVARIANT: the list is non-empty
| UnitBag a
| TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
| ListBag [a] -- INVARIANT: the list is non-empty
emptyBag :: Bag a
emptyBag = EmptyBag
unitBag :: a -> Bag a
unitBag = UnitBag
elemBag :: Eq a => a -> Bag a -> Bool
elemBag x EmptyBag = False
elemBag x (UnitBag y) = x==y
elemBag _ 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
......@@ -67,54 +60,54 @@ snocBag :: Bag a -> a -> Bag a
consBag elt bag = (unitBag elt) `unionBags` bag
snocBag bag elt = bag `unionBags` (unitBag elt)
isEmptyBag :: Bag a -> Bool
isEmptyBag EmptyBag = True
isEmptyBag other = False -- NB invariants
isEmptyBag _ = 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
isSingletonBag EmptyBag = False
isSingletonBag (UnitBag _) = True
isSingletonBag (TwoBags _ _) = False -- Neither is empty
isSingletonBag (ListBag xs) = isSingleton xs
filterBag :: (a -> Bool) -> Bag a -> Bag a
filterBag pred EmptyBag = EmptyBag
filterBag _ EmptyBag = EmptyBag
filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
where
sat1 = filterBag pred b1
sat2 = filterBag pred b2
where sat1 = filterBag pred b1
sat2 = filterBag pred b2
filterBag pred (ListBag vs) = listToBag (filter pred vs)
anyBag :: (a -> Bool) -> Bag a -> Bool
anyBag p EmptyBag = False
anyBag _ EmptyBag = False
anyBag p (UnitBag v) = p v
anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2
anyBag p (ListBag xs) = any p xs
concatBag :: Bag (Bag a) -> Bag a
concatBag EmptyBag = EmptyBag
concatBag (UnitBag b) = b
concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2
concatBag (ListBag bs) = unionManyBags bs
concatBag EmptyBag = EmptyBag
concatBag (UnitBag b) = b
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 -})
partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
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
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
Bag a {- Don't -})
partitionBag _ EmptyBag = (EmptyBag, EmptyBag)
partitionBag pred b@(UnitBag val)
= if pred val then (b, EmptyBag) else (EmptyBag, b)
partitionBag pred (TwoBags b1 b2)
= (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
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
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
......@@ -124,51 +117,56 @@ foldBag t u e (ListBag xs) = foldr (t.u) e xs
-}
-- More tail-recursive definition, exploiting associativity of "t"
foldBag t u e EmptyBag = e
foldBag _ _ 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
foldrBag :: (a -> r -> r) -> r
-> Bag a
-> r
-> Bag a
-> r
foldrBag k z EmptyBag = z
foldrBag _ 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
-> Bag a
-> r
foldlBag k z EmptyBag = z
foldlBag _ 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
mapBag f EmptyBag = EmptyBag
mapBag _ EmptyBag = EmptyBag
mapBag f (UnitBag x) = UnitBag (f x)
mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
mapBag f (ListBag xs) = ListBag (map f xs)
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) }
mapBagM _ 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) }
mapAndUnzipBagM _ 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment