Exception.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}

module AlphaHeavy.Exception
  ( setDefaultUncaughtExceptionHandler
  , lastException
  , uncaughtExceptionHandler
  ) where

import Control.Exception (Exception(..), SomeException(..))
import Data.IORef (IORef, newIORef, writeIORef)
import Data.Typeable (Typeable)
import GHC.Conc (setUncaughtExceptionHandler)
import System.IO (hPutStrLn, stderr)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Signals (raiseSignal, sigABRT)
import System.Posix.Syslog

-- | a dummy exception to initialize the global IORef with
data NoException = NoException deriving (Typeable)

instance Show NoException where
  show _ = "<<no exception>>"

instance Exception NoException

-- | storage for the last exception
lastException :: IORef SomeException
{-# NOINLINE lastException #-}
lastException = unsafePerformIO . newIORef $ SomeException NoException

-- | when no catch frame handles an exception dump core and terminate the process
uncaughtExceptionHandler :: SomeException -> IO () 
{-# NOINLINE uncaughtExceptionHandler #-}
uncaughtExceptionHandler !e = do
  writeIORef lastException e
  syslog Error $ "Unhandled exception: " ++ show e
  hPutStrLn stderr $ "Unhandled exception: " ++ show e
  raiseSignal sigABRT

setDefaultUncaughtExceptionHandler :: IO ()
setDefaultUncaughtExceptionHandler =
  setUncaughtExceptionHandler uncaughtExceptionHandler