ghc/tests/programs/jeff-bug/BoundedSet.hs

   1 module BoundedSet
   2   ( new
   3   , readBound
   4   , readSize
   5   , read
   6   , clear
   7   , insert
   8   , spaceAvail
   9   , rmSuch
  10   , rmSuchN
  11   , BoundedSet
  12   , iterateSet
  13   ) where
  14
  15 import LazyST
  16 import Prelude hiding (read)
  17 import List    hiding (insert)
  18
  19
  20 new        :: Int -> ST s (BoundedSet s a)
  21 readBound  :: BoundedSet s a -> ST s Int
  22 readSize   :: BoundedSet s a -> ST s Int
  23 read       :: BoundedSet s a -> ST s [a]
  24 clear      :: BoundedSet s a -> ST s [a]
  25 insert     :: BoundedSet s a -> [a] -> ST s ()
  26 spaceAvail :: BoundedSet s a -> ST s Int
  27 rmSuch     :: BoundedSet s a -> (a -> Bool) -> ST s [a]
  28 rmSuchN    :: BoundedSet s a -> Int -> (a -> Bool) -> ST s [a]
  29 iterateSet :: BoundedSet s a -> (a -> a) -> ST s ()
  30
  31
  32 -- Implementation ----------------------------------------------------
  33 type BoundedSet s a = (STRef s [a],Int)
  34
  35
  36 iterateSet s f =
  37    do { set <- read s
  38       ; write s (map f set)
  39       }
  40
  41 read (s,n) = readSTRef s
  42
  43 rmSuch s f
  44   = do { set <- read s
  45        ; let (yes,no) = partition f set
  46        ; write s no
  47        ; return yes
  48        }
  49
  50 rmSuchN s n f
  51   = do { such <- rmSuch s f
  52        ; let (big,small) = splitAt n such
  53        ; insert s small
  54        ; return big
  55        }
  56
  57 write    :: BoundedSet s a -> [a] -> ST s ()
  58 write (s,n) x = writeSTRef s x
  59
  60
  61 readBound (s,n) = return n
  62
  63 new n
  64   = do { set <- newSTRef []
  65        ; return (set,n)
  66        }
  67
  68 clear s =
  69   do { set <- read s
  70      ; write s []
  71      ; return set
  72      }
  73
  74 readSize s =
  75   do { set <- read s
  76      ; return ( length set)
  77      }
  78
  79 spaceAvail s
  80   = do { bnd <- readBound s
  81        ; sz  <- readSize s
  82        ; return (bnd - sz)
  83        }
  84
  85
  86 insert s l
  87   = do { set <- read s
  88        ; n <- readBound s
  89        ; write s $ take n (set ++ l)
  90        }
  91
  92
  93