{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Util.Debug(
debug,
debugAct,
(@:),
alwaysDebug,
alwaysDebugAct,
debugString,
(@@:),
wrapError,
) where
import System.IO as IO
import System.IO.Unsafe
import Control.Exception as Exception
import Util.WBFiles
openDebugFile :: IO (Maybe Handle)
openDebugFile :: IO (Maybe Handle)
openDebugFile =
do
String
debugFileName <- IO String
getDebugFileName
IO (Maybe Handle)
-> (IOException -> IO (Maybe Handle)) -> IO (Maybe Handle)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch (
do
Handle
handle <- String -> IOMode -> IO Handle
openFile String
debugFileName IOMode
WriteMode
Handle -> BufferMode -> IO ()
hSetBuffering Handle
handle BufferMode
NoBuffering
Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle)
)
(\ (IOException
_ :: IOException) -> Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing)
debugFile :: Maybe Handle
debugFile = IO (Maybe Handle) -> Maybe Handle
forall a. IO a -> a
unsafePerformIO IO (Maybe Handle)
openDebugFile
debugFile :: Maybe Handle
{-# NOINLINE debugFile #-}
#ifdef DEBUG
debugString s =
case debugFile of
Just f -> IO.hPutStr f s
Nothing -> return ()
debug s =
case debugFile of
Just f -> IO.hPutStrLn f (show s)
Nothing -> return ()
debugAct mess act =
do
res <- Exception.try act
case res of
Left error ->
do
debug ("Debug.debug caught "++mess)
throw (error :: SomeException)
Right success -> return success
#else
debugString :: String -> IO ()
debugString String
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
debug :: a -> IO ()
debug a
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# inline debug #-}
debugAct :: String -> IO a -> IO a
debugAct String
_ IO a
act = IO a
act
{-# inline debugAct #-}
#endif
debug :: Show a => a -> IO()
debugString :: String -> IO ()
debugAct :: String -> IO a -> IO a
(@:) :: String -> IO a -> IO a
@: :: String -> IO a -> IO a
(@:) = String -> IO a -> IO a
forall a. String -> IO a -> IO a
debugAct
alwaysDebug :: Show a => a -> IO()
alwaysDebug :: a -> IO ()
alwaysDebug a
s =
case Maybe Handle
debugFile of
Just Handle
f -> Handle -> String -> IO ()
IO.hPutStrLn Handle
f (a -> String
forall a. Show a => a -> String
show a
s)
Maybe Handle
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
alwaysDebugAct :: String -> IO a -> IO a
alwaysDebugAct :: String -> IO a -> IO a
alwaysDebugAct String
mess IO a
act =
do
Either SomeException a
res <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO a
act
case Either SomeException a
res of
Left SomeException
error ->
do
String -> IO ()
forall a. Show a => a -> IO ()
alwaysDebug (String
"AlwaysDebug.debug caught "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mess)
SomeException -> IO a
forall a e. Exception e => e -> a
throw (SomeException
error :: SomeException)
Right a
success -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
success
(@@:) :: String -> IO a -> IO a
@@: :: String -> IO a -> IO a
(@@:) = String -> IO a -> IO a
forall a. String -> IO a -> IO a
alwaysDebugAct
wrapError :: String -> a -> a
#ifdef DEBUG
wrapError str value = unsafePerformIO (wrapErrorIO str value)
#else
wrapError :: String -> a -> a
wrapError String
str a
value = a
value
#endif
wrapErrorIO :: String -> a -> IO a
wrapErrorIO :: String -> a -> IO a
wrapErrorIO String
str a
value =
IO a -> (ErrorCall -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch (a
value a -> IO a -> IO a
`seq` a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value)
(\ ErrorCall
mess -> String -> IO a
forall a. HasCallStack => String -> a
error (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++ ErrorCall -> String
forall a. Show a => a -> String
show (ErrorCall
mess :: ErrorCall)))