BlockingOps.hs

{-# LANGUAGE TemplateHaskell, NamedFieldPuns #-}
-- | Blocking operations such as
--
-- > readMVar v
--
-- may throw an exception such as
--
-- > thread blocked indefinitely in an MVar operation
--
-- Unfortunately, this exception does not give any information of _where_ in
-- the code we are blocked indefinitely. Compiling with profiling info and
-- running with +RTC -xc can address this to some extent, but (1) it requires
-- that all profiling libraries are installed and (2) when we are running
-- multithreaded code the resulting stack trace is often difficult to read
-- (and still does not include line numbers). With this module you can replace
-- the above code with
--
-- > $readMVar v
--
-- and the exception that will be thrown is
--
-- > YourModule:lineNumber: thread blocked indefinitely in an MVar operation
--
-- which is a lot more informative. When the CPP flag DEBUGGING is turned off
-- then @$readMVar@ just turns into @readMVar@.
--
-- NOTE: The type of the exception changes when using DEBUGGING mode -- in order
-- to be able to add the line number, all exceptions are turned into
-- IOExceptions.
module TH.BlockingOps (
    -- * Generic debugging utilities
    lineNumber
  , traceOnException
  , mapExceptionIO
  , mapExceptionShow
    -- * Blocking MVar ops
  , putMVar
  , takeMVar
  , modifyMVar
  , modifyMVar_
  , withMVar
  , readMVar
    -- * Blocking Chan ops
  , readChan
  ) where

import Language.Haskell.TH
import qualified Control.Concurrent as C
import System.IO (hPutStrLn, stderr)
import qualified Control.Exception as Ex

lineNumber :: ExpQ
lineNumber = do
  Loc{loc_module, loc_start=(line, _)} <- location
  [| loc_module ++ ":" ++ show (line :: Int) |]

mapExceptionIO :: (Ex.Exception e1, Ex.Exception e2)
               => (e1 -> e2) -> IO a -> IO a
mapExceptionIO f io = Ex.catch io (Ex.throwIO . f)

mapExceptionShow :: (String -> String) -> IO a -> IO a
mapExceptionShow f = mapExceptionIO (userError . f . showSomeException)
  where
    showSomeException :: Ex.SomeException -> String
    showSomeException = show

traceOnException :: String -> IO a -> IO a
traceOnException str io = Ex.catch io $ \e -> do
  hPutStrLn stderr (str ++ ": " ++ show e)
  Ex.throwIO (e :: Ex.SomeException)

rethrowWithLineNumber1 :: ExpQ -> ExpQ
rethrowWithLineNumber1 expr =
  [| \arg1 -> mapExceptionShow (\e -> $lineNumber ++ ": " ++ e)
                               ($expr arg1)
   |]

rethrowWithLineNumber2 :: ExpQ -> ExpQ
rethrowWithLineNumber2 expr =
  [| \arg1 arg2 -> mapExceptionShow (\e -> $lineNumber ++ ": " ++ e)
                                    ($expr arg1 arg2)
   |]

takeMVar :: ExpQ
takeMVar = rethrowWithLineNumber1 [| C.takeMVar |]

putMVar :: ExpQ
putMVar = rethrowWithLineNumber2 [| C.putMVar |]

readMVar :: ExpQ
readMVar = rethrowWithLineNumber1 [| C.readMVar |]

modifyMVar :: ExpQ
modifyMVar = rethrowWithLineNumber2 [| C.modifyMVar |]

modifyMVar_ :: ExpQ
modifyMVar_ = rethrowWithLineNumber2 [| C.modifyMVar_ |]

withMVar :: ExpQ
withMVar = rethrowWithLineNumber2 [| C.withMVar |]

readChan :: ExpQ
readChan = rethrowWithLineNumber1 [| C.readChan |]