Ticket #2411: stmcrash.hs

File stmcrash.hs, 2.6 KB (added by sclv, 6 years ago)

Test case

Line 
1{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
2module Main where
3import Control.Concurrent.STM
4import GHC.Conc
5import Control.Exception
6import Control.Monad.Reader
7import Control.Monad.Writer
8import Control.Monad.Error
9import Control.Monad.Trans
10import Data.List
11
12{--------------------------------------------------------------------
13  MonadSTM, gcatchSTM, and gOrElse
14--------------------------------------------------------------------}
15
16class (Monad m) => MonadSTM m where
17    liftSTM :: STM a -> m a
18
19instance MonadSTM STM where
20    liftSTM = id
21instance (Monoid w, MonadSTM m) => MonadSTM (WriterT w m) where
22    liftSTM = lift . liftSTM
23instance (MonadSTM m) => MonadSTM (ReaderT r m) where
24    liftSTM = lift . liftSTM
25
26class (MonadSTM m, MonadIO n) => MonadAtomically m n where
27    gAtomically :: m a -> n a
28instance MonadAtomically STM IO where
29    gAtomically m = atomically m
30instance MonadAtomically m n => MonadAtomically (ReaderT r m) (ReaderT r n) where
31    gAtomically m = ReaderT $
32                 \r -> gAtomically (runReaderT m r)
33instance (Monoid w, MonadAtomically m n) => MonadAtomically (WriterT w m) (WriterT w n) where
34    gAtomically m = WriterT $ gAtomically (runWriterT m)
35
36class MonadSTM m => CaughtMonadSTM m where
37    gOrElse :: m a -> m a -> m a
38    gcatchSTM :: m a -> (Exception -> m a) -> m a
39instance CaughtMonadSTM STM where
40    gOrElse = orElse
41    gcatchSTM = catchSTM
42instance CaughtMonadSTM m => CaughtMonadSTM (ReaderT r m) where
43    gOrElse m n = ReaderT $
44                  \r -> gOrElse (runReaderT m r) (runReaderT n r)
45    gcatchSTM m f = ReaderT $
46                    \r -> gcatchSTM (runReaderT m r) (\e -> runReaderT (f e) r)
47instance (Monoid w, CaughtMonadSTM m) => CaughtMonadSTM (WriterT w m) where
48        m `gOrElse` n = WriterT $ runWriterT m
49                `gOrElse` runWriterT n
50        m `gcatchSTM` f = WriterT $ runWriterT m
51                `gcatchSTM` \e -> runWriterT (f e)
52
53runM :: ReaderT Int (WriterT [String] IO) String -> IO (String, [String])
54runM m = runWriterT $ runReaderT m 12
55
56act :: TVar String -> String -> ReaderT Int (WriterT [String] STM) String
57act tv s = do
58  x <- ask
59  foo <- liftSTM $ readTVar tv
60  liftSTM $ writeTVar tv (show x)
61  if read s `mod` 25 == 0
62     then throw $ AssertionFailed ("Simulated Exception " ++ s)
63     else do
64       tell [s ++ foo]
65       return (show x)
66
67main = do
68  tv <- atomically $ newTVar "test"
69  mapM_ (go tv) (map show ([1..100] ++ [1..1000] :: [Int]))
70    where go tv s = forkIO $ do
71                      (a,w) <- (runM . gAtomically) (act tv s `gcatchSTM` (\e -> tell [show e] >> return "except"))
72                      putStrLn (concat w)