@@ -0,0 +1,71 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module TestAuxiliary ( -- Running tests
3+ runTest
4+ , runTests
5+ -- Writing tests
6+ , forkTry
7+ , trySome
8+ , randomThreadDelay
9+ ) where
10+
11+import Prelude hiding (catch)
12+import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
13+import Control.Monad (liftM2, unless)
14+import Control.Exception (SomeException, try, catch)
15+import System.Timeout (timeout)
16+import System.IO (stdout, hFlush)
17+import System.Console.ANSI ( SGR(SetColor, Reset)
18+ , Color(Red, Green)
19+ , ConsoleLayer(Foreground)
20+ , ColorIntensity(Vivid)
21+ , setSGR
22+ )
23+import System.Random (randomIO)
24+
25+-- | Like fork, but throw exceptions in the child thread to the parent
26+forkTry :: IO () -> IO ThreadId
27+forkTry p = do
28+ tid <- myThreadId
29+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
30+
31+-- | Like try, but specialized to SomeException
32+trySome :: IO a -> IO (Either SomeException a)
33+trySome = try
34+
35+-- | Run the given test, catching timeouts and exceptions
36+runTest :: String -> IO () -> IO Bool
37+runTest description test = do
38+ putStr $ "Running " ++ show description ++ ": "
39+ hFlush stdout
40+ done <- try . timeout 60000000 $ test -- 60 seconds
41+ case done of
42+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
43+ Right Nothing -> failed "(timeout)"
44+ Right (Just ()) -> ok
45+ where
46+ failed :: String -> IO Bool
47+ failed err = do
48+ setSGR [SetColor Foreground Vivid Red]
49+ putStr "failed "
50+ setSGR [Reset]
51+ putStrLn err
52+ return False
53+
54+ ok :: IO Bool
55+ ok = do
56+ setSGR [SetColor Foreground Vivid Green]
57+ putStrLn "ok"
58+ setSGR [Reset]
59+ return True
60+
61+-- | Run a bunch of tests and throw an exception if any fails
62+runTests :: [(String, IO ())] -> IO ()
63+runTests tests = do
64+ success <- foldr (liftM2 (&&) . uncurry runTest) (return True) tests
65+ unless success $ fail "Some tests failed"
66+
67+-- | Random thread delay between 0 and the specified max
68+randomThreadDelay :: Int -> IO ()
69+randomThreadDelay maxDelay = do
70+ delay <- randomIO :: IO Int
71+ threadDelay (delay `mod` maxDelay)