{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
module Main where
import Control.Concurrent.STM
import GHC.Conc
import Control.Exception
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.Trans
import Data.List
{--------------------------------------------------------------------
MonadSTM, gcatchSTM, and gOrElse
--------------------------------------------------------------------}
class (Monad m) => MonadSTM m where
liftSTM :: STM a -> m a
instance MonadSTM STM where
liftSTM = id
instance (Monoid w, MonadSTM m) => MonadSTM (WriterT w m) where
liftSTM = lift . liftSTM
instance (MonadSTM m) => MonadSTM (ReaderT r m) where
liftSTM = lift . liftSTM
class (MonadSTM m, MonadIO n) => MonadAtomically m n where
gAtomically :: m a -> n a
instance MonadAtomically STM IO where
gAtomically m = atomically m
instance MonadAtomically m n => MonadAtomically (ReaderT r m) (ReaderT r n) where
gAtomically m = ReaderT $
\r -> gAtomically (runReaderT m r)
instance (Monoid w, MonadAtomically m n) => MonadAtomically (WriterT w m) (WriterT w n) where
gAtomically m = WriterT $ gAtomically (runWriterT m)
class MonadSTM m => CaughtMonadSTM m where
gOrElse :: m a -> m a -> m a
gcatchSTM :: m a -> (Exception -> m a) -> m a
instance CaughtMonadSTM STM where
gOrElse = orElse
gcatchSTM = catchSTM
instance CaughtMonadSTM m => CaughtMonadSTM (ReaderT r m) where
gOrElse m n = ReaderT $
\r -> gOrElse (runReaderT m r) (runReaderT n r)
gcatchSTM m f = ReaderT $
\r -> gcatchSTM (runReaderT m r) (\e -> runReaderT (f e) r)
instance (Monoid w, CaughtMonadSTM m) => CaughtMonadSTM (WriterT w m) where
m `gOrElse` n = WriterT $ runWriterT m
`gOrElse` runWriterT n
m `gcatchSTM` f = WriterT $ runWriterT m
`gcatchSTM` \e -> runWriterT (f e)
runM :: ReaderT Int (WriterT [String] IO) String -> IO (String, [String])
runM m = runWriterT $ runReaderT m 12
act :: TVar String -> String -> ReaderT Int (WriterT [String] STM) String
act tv s = do
x <- ask
foo <- liftSTM $ readTVar tv
liftSTM $ writeTVar tv (show x)
if read s `mod` 25 == 0
then throw $ AssertionFailed ("Simulated Exception " ++ s)
else do
tell [s ++ foo]
return (show x)
main = do
tv <- atomically $ newTVar "test"
mapM_ (go tv) (map show ([1..100] ++ [1..1000] :: [Int]))
where go tv s = forkIO $ do
(a,w) <- (runM . gAtomically) (act tv s `gcatchSTM` (\e -> tell [show e] >> return "except"))
putStrLn (concat w)