{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} module Control.Exception.FileLocation ( thrwIO , thrwsIO , reThrow ) where import Language.Haskell.TH.Syntax import FileLocation.LocationString (locationToString) import Control.Exception.Base hiding (throwIO) import qualified Control.Exception.Lifted as E import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Typeable (Typeable) throwIO :: (Exception e, MonadIO m) => e -> m a throwIO :: e -> m a throwIO = IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO a -> m a) -> (e -> IO a) -> e -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . e -> IO a forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a E.throwIO thrwIO :: Q Exp thrwIO :: Q Exp thrwIO = do Loc loc <- Q Loc forall (m :: * -> *). Quasi m => m Loc qLocation let locStr :: String locStr = Loc -> String locationToString Loc loc [|(\_mkEx -> throwIO (_mkEx locStr))|] thrwsIO :: String -> Q Exp thrwsIO :: String -> Q Exp thrwsIO errMsg :: String errMsg = do Loc loc <- Q Loc forall (m :: * -> *). Quasi m => m Loc qLocation let locStr :: String locStr = Loc -> String locationToString Loc loc [|(\_mkEx -> throwIO (_mkEx (locStr ++ " " ++ errMsg)))|] data ReThrownException = ReThrownException String E.SomeException deriving Typeable instance Show ReThrownException where show :: ReThrownException -> String show (ReThrownException s :: String s e :: SomeException e) = "ReThrownException (" String -> ShowS forall a. [a] -> [a] -> [a] ++ String s String -> ShowS forall a. [a] -> [a] -> [a] ++ "): " String -> ShowS forall a. [a] -> [a] -> [a] ++ SomeException -> String forall a. Show a => a -> String show SomeException e instance Exception ReThrownException reThrow :: Q Exp reThrow :: Q Exp reThrow = do Loc loc <- Q Loc forall (m :: * -> *). Quasi m => m Loc qLocation let locStr :: String locStr = Loc -> String locationToString Loc loc [|E.handle (E.throwIO . ReThrownException locStr)|]