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

   1 module STEx where
   2 import LazyST
   3 import Monad
   4
   5 infixl 1 `handle`
   6
   7 -- Begin Signature ----------------------------------------------------------
   8
   9 {-
  10   STEx synthesizes the state and exception monads.
  11 -}
  12
  13
  14 {-data STEx s a-}
  15
  16 {-instance Monad (STEx s)-}
  17 {-instance MonadPlus (STEx s)-}
  18
  19 -- c `handle` x, return x if c raises an exception
  20 handle :: STEx a b -> b -> ST a b
  21
  22 -- lift an exception or st monad thing or into STEx
  23 liftEx :: Maybe a -> STEx s a
  24 liftST :: ST s a -> STEx s a
  25
  26 -- raise an exception if Bool is False
  27 assert :: Bool -> STEx s ()
  28
  29 -- the following functions have the same meaning as their corresponding
  30 -- state monad functions
  31 {-readVarSTEx :: MutVar a b -> STEx a b-}
  32 {-writeVarSTEx :: MutVar a b -> b -> STEx a ()-}
  33 {-newVarSTEx :: a -> STEx b (MutVar b a)-}
  34
  35 {-readArraySTEx :: Ix b => MutArr a b c -> b -> STEx a c-}
  36 {-writeArraySTEx :: Ix b => MutArr a b c -> b -> c -> STEx a ()-}
  37 {-newArraySTEx :: Ix a => (a,a) -> b -> STEx c (MutArr c a b)-}
  38
  39 -- End Signature -----------------------------------------------------------
  40
  41 newtype STEx s a = STEx (ST s (Maybe a))
  42
  43 instance Monad (STEx s) where
  44         return = STEx . return . return
  45         (STEx x) >>= f
  46              = STEx $ do y <- x
  47                          case y of
  48                             Just z -> let STEx z' = f z
  49                                       in z'
  50                             Nothing -> return Nothing
  51
  52 instance MonadPlus (STEx s) where
  53         mzero = liftEx mzero
  54         (STEx x) `mplus` (STEx y) = STEx $ do x' <- x
  55                                               y' <- y
  56                                               return $ mplus x' y'
  57 liftST x = STEx $ do {z <- x ; return $ return z}
  58
  59 liftEx x = STEx $ return x
  60
  61
  62 handle (STEx m) x
  63     = do y <- m
  64          case y of
  65             Just z -> return z
  66             Nothing -> return x
  67
  68 readVarSTEx v    = liftST $ readSTRef v
  69 writeVarSTEx v x = liftST $ writeSTRef v x
  70 newVarSTEx x     = liftST $ newSTRef x
  71
  72 readArraySTEx v n    = liftST $ readSTArray v n
  73 writeArraySTEx v x n = liftST $ writeSTArray v x n
  74 newArraySTEx x n     = liftST $ newSTArray x n
  75
  76 {- example
  77 f x = do y <- liftEx x
  78          v <- newVarSTEx y
  79          readVarSTEx v
  80
  81 g x = runST (handle (f x) 2)
  82 -}
  83
  84 assert True = liftEx $ Just ()
  85 assert False = liftEx $ Nothing
  86