{-# LANGUAGE CPP, ScopedTypeVariables #-}

-- |
-- MODULE        : Debug
-- AUTHOR        : George Russell
-- University of Bremen
-- DATE          : 2000
-- DESCRIPTION   : This module provides a uniform interface for debugging
--              purposes.  In final versions of this module it would
--              be best to make the debug function do nothing and
--              force it to be inlined.
--
-- #########################################################################

module Util.Debug(
  debug, -- show something to log file if debugging is turned on.

  debugAct,
  -- If an action fails print out a message before
  -- propagating message.
  (@:),
  -- inline version of debugAct

  -- The following functions work whether debugging is turned on or
  -- not, and are intended to be used when the debugging facility
  -- itself is causing strange effects . . .
  alwaysDebug,
  alwaysDebugAct,

  debugString, -- Send a string to the debug file.  This differs from
     -- debug, in that debug will Haskell-escape the string and add
     -- a newline, while just writes to the file with no interpretation.
  (@@:),


  wrapError, -- :: String -> a -> a
     -- If debugging is on, transforms value so that when evaluated, if
     -- the evaluation calls an error call, the given String is prepended
     -- to the evaluation.
  ) 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

-- | show something to log file if debugging is turned on.
debug :: Show a => a -> IO()

-- | Send a string to the debug file.  This differs from
-- debug, in that debug will Haskell-escape the string and add
-- a newline, while just writes to the file with no interpretation.
debugString :: String -> IO ()

-- | If an action fails print out a message before
-- propagating message.
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


-- | always show something to the log file
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 ()

-- | always print out a message if action fails.
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)))