第26回　例外の「中断・終了処理」としての側面

Prelude Control.Exception> :t throwTo
throwTo :: (Exception e) => GHC.Conc.ThreadId -> e -> IO ()

module AsyncException where
import Control.Concurrent
import Control.Exception
import Control.Monad

foreverTest'' = do
    tid <- forkIO $ forever $ print "infinite loop."
    threadDelay 5
    throwTo tid (ErrorCall $ "throw exception to " ++ show tid ++ ".")
    threadDelay 1000000
    mid <- myThreadId
    print $ show mid ++ " finished."

Prelude AsyncException> foreverTest''
"infinite loop."
"infinite loop."
"infinite loop."
"infinite loop."
～ 略 ～
"infinite loop."
"infinite loop."
"infinite lo<interactive>: throw exception to ThreadId 24.
"ThreadId 23 finished."

module AsyncException where
import Control.Concurrent
import Control.Exception
import Control.Monad

foreverTest''' = do
    tid <- forkIO $ forever $ print "infinite loop."
    threadDelay 5
    throwTo tid (ErrorCall $ "throw exception to " ++ show tid ++ ".")
    threadDelay 1000000
    throwTo tid (ErrorCall $ "throw exception to " ++ show tid ++ ".")
    mid <- myThreadId
    print $ show mid ++ " finished."

*AsyncException> foreverTest'''
"infinite loop."
"infinite loop."
"infinite loop."
～ 略 ～
"infinite loop."
"infinite loop."
"infinite loop."
"i<interactive>: throw exception to ThreadId 30.
"ThreadId 29 finished."

killThread :: ThreadId -> IO ()
killThread tid = throwTo tid ThreadKilled

Prelude Control.Exception> :i ThreadKilled
data AsyncException = ... | ThreadKilled | ...
        -- Defined in GHC.IOBase

data Timeout = Timeout Unique deriving Eq
INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout")

instance Show Timeout where
    show _ = "<<timeout>>"

instance Exception Timeout

～ 略 ～

timeout :: Int -> IO a -> IO (Maybe a)
timeout n f
    | n <  0    = fmap Just f
    | n == 0    = return Nothing
    | otherwise = do
        pid <- myThreadId
        ex  <- fmap Timeout newUnique
        handleJust (\e -> if e == ex then Just () else Nothing)
                   (\_ -> return Nothing)
                   (bracket (forkIO (threadDelay n >> throwTo pid ex))
                            (killThread)
                            (\_ -> fmap Just f))

catchJust
        :: Exception e
        => (e -> Maybe b)         -- ^ Predicate to select exceptions
        -> IO a                   -- ^ Computation to run
        -> (b -> IO a)            -- ^ Handler
        -> IO a
catchJust p a handler = catch a handler'
  where handler' e = case p e of
                        Nothing -> throw e
                        Just b  -> handler b

～ 略 ～
handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust p =  flip (catchJust p)

Prelude System.Timeout Control.Monad> timeout 10 $ return ()
Just ()
Prelude System.Timeout Control.Monad> timeout 10 $ forever $ return ()
Nothing
Prelude System.Timeout Control.Monad> timeout 0 $ return ()
Nothing
Prelude System.Timeout Control.Monad> timeout (-10) $ forever $ return ()
Interrupted.

Prelude Control.Exception> :t block
block :: IO a -> IO a
Prelude Control.Exception> :t unblock
unblock :: IO a -> IO a

Prelude Control.Exception> :t blocked
blocked :: IO Bool

Prelude Control.Exception> blocked
False
Prelude Control.Exception> block blocked
True
Prelude Control.Exception> unblock blocked
False
Prelude Control.Exception> block $ unblock blocked
False

Prelude Control.Exception> block $ block $ unblock blocked
False
Prelude Control.Exception> block $ block $ blocked
True
Prelude Control.Exception> block $ block $ unblock blocked
False
Prelude Control.Exception> block $ unblock $ block blocked
True
Prelude Control.Exception> unblock $ unblock blocked
False
Prelude Control.Exception> unblock $ unblock $ block blocked
True

bracket
        :: IO a         -- ^ computation to run first (\"acquire resource\")
        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
        -> (a -> IO c)  -- ^ computation to run in-between
        -> IO c         -- returns the value from the in-between computation
bracket before after thing =
  block (do
    a <- before
    r <- unblock (thing a) `onException` after a
    after a
    return r
 )

～ 略 ～

finally :: IO a         -- ^ computation to run first
        -> IO b         -- ^ computation to run afterward (even if an exception
                        -- was raised)
        -> IO a         -- returns the value from the first computation
a `finally` sequel =
  block (do
    r <- unblock a `onException` sequel
    sequel
    return r
  )

～ 略 ～

bracket_ :: IO a -> IO b -> IO c -> IO c
bracket_ before after thing = bracket before (const after) (const thing)

～ 略 ～

bracketOnError
        :: IO a         -- ^ computation to run first (\"acquire resource\")
        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
        -> (a -> IO c)  -- ^ computation to run in-between
        -> IO c         -- returns the value from the in-between computation
bracketOnError before after thing =
  block (do
    a <- before
    unblock (thing a) `onException` after a
  )

onException :: IO a -> IO b -> IO a
onException io what = io `catch` \e -> do what
                                          throw (e :: SomeException)