Ticket #8006: ExceptionTest.hs

File ExceptionTest.hs, 1.8 KB (added by edsko, 22 months ago)
Line 
1{-# LANGUAGE CPP, DeriveDataTypeable #-}
2module Main (main) where
3
4#define GHC_HEAD
5
6import Control.Applicative
7import Control.Concurrent
8import System.Process
9import System.Random
10import Data.Typeable
11
12import GHC
13import DynFlags
14import MonadUtils
15import Exception
16
17import GHC.Debug
18
19data CountedThreadKilled = CountedThreadKilled Int
20  deriving (Show, Eq, Typeable)
21
22instance Exception CountedThreadKilled where
23  toException   = asyncExceptionToException
24  fromException = asyncExceptionFromException
25
26exceptionTest :: Ghc ()
27exceptionTest = do
28  dynFlags <- getSessionDynFlags
29  let dynFlags' = dynFlags `gopt_unset` Opt_GhciSandbox
30  setSessionDynFlags dynFlags'
31
32  setContext [ IIDecl $ simpleImportDecl $ mkModuleName "Control.Concurrent" ]
33
34  let go n = do
35        _tidMVar <- liftIO newEmptyMVar
36        liftIO . debugLn $ "Round " ++ show n
37
38        runResult <- ghandle (return . RunException) $ do
39          liftIO $ do
40            tid   <- myThreadId
41            delay <- randomRIO (0, 10000)
42            forkIO $ threadDelay delay >> throwTo tid (CountedThreadKilled n)
43          runStmt "Control.Concurrent.threadDelay 10000000" RunToCompletion
44
45        case runResult of
46          RunException ex -> do
47            case fromException ex of
48              Just (CountedThreadKilled n') | n == n' ->
49                go (n + 1)
50              _ -> case fromException ex of
51                Just (ProgramError err) ->
52                  go (n + 1)
53                _ -> liftIO $ do
54                  debugLn $ "Unexpected exception " ++ show ex
55                  debugLn $ "Expected (CountedThreadKilled " ++ show n ++ ")"
56
57          _ ->
58            liftIO $ debugLn "Unexpected run result"
59
60  go 0
61
62main :: IO ()
63main = do
64  [libdir] <- lines <$> readProcess "ghc" ["--print-libdir"] ""
65  runGhc (Just libdir) exceptionTest