{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Debug
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Debug utilities used throughout Yi.

module Yi.Debug ( initDebug, trace, traceM, traceM_, logPutStrLn
                , logError, logStream, Yi.Debug.error ) where

import Control.Concurrent
    ( dupChan, getChanContents, forkIO, myThreadId, Chan )
import Control.Monad.Base ( liftBase, MonadBase )
import Data.IORef ( readIORef, writeIORef, IORef, newIORef )
import Data.Monoid ( (<>) )
import qualified Data.Text as T ( pack, snoc, unpack, Text )
import GHC.Conc ( labelThread )
import System.IO
    ( hFlush, hPutStrLn, IOMode(WriteMode), openFile, Handle )
import System.IO.Unsafe ( unsafePerformIO )

#if __GLASGOW_HASKELL__ < 710
import Data.Time (formatTime, getCurrentTime)
import System.Locale (defaultTimeLocale)
#else
import Data.Time (formatTime, getCurrentTime, defaultTimeLocale)
#endif

dbgHandle :: IORef (Maybe Handle)
dbgHandle :: IORef (Maybe Handle)
dbgHandle = IO (IORef (Maybe Handle)) -> IORef (Maybe Handle)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe Handle)) -> IORef (Maybe Handle))
-> IO (IORef (Maybe Handle)) -> IORef (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ Maybe Handle -> IO (IORef (Maybe Handle))
forall a. a -> IO (IORef a)
newIORef Maybe Handle
forall a. Maybe a
Nothing
{-# NOINLINE dbgHandle #-}

-- | Set the file to which debugging output should be written. Though this
-- is called /init/Debug.
-- Debugging output is not created by default (i.e., if this function
-- is never called.)
-- The target file can not be changed, nor debugging disabled.
initDebug :: FilePath -> IO ()
initDebug :: FilePath -> IO ()
initDebug FilePath
f = do
  Maybe Handle
hndl <- IORef (Maybe Handle) -> IO (Maybe Handle)
forall a. IORef a -> IO a
readIORef IORef (Maybe Handle)
dbgHandle
  case Maybe Handle
hndl of
    Maybe Handle
Nothing -> do FilePath -> IOMode -> IO Handle
openFile FilePath
f IOMode
WriteMode IO Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef (Maybe Handle) -> Maybe Handle -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Handle)
dbgHandle (Maybe Handle -> IO ())
-> (Handle -> Maybe Handle) -> Handle -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Maybe Handle
forall a. a -> Maybe a
Just
                  Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
"Logging initialized."
    Just Handle
_ -> Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
"Attempt to re-initialize the logging system."


-- | Outputs the given string before returning the second argument.
trace :: T.Text -> a -> a
trace :: Text -> a -> a
trace Text
s a
e = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
s IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
e
{-# NOINLINE trace #-}

error :: T.Text -> a
error :: Text -> a
error Text
s = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
s IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO a
forall a. HasCallStack => FilePath -> a
Prelude.error (Text -> FilePath
T.unpack Text
s)

logPutStrLn :: MonadBase IO m => T.Text -> m ()
logPutStrLn :: Text -> m ()
logPutStrLn Text
s = IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
  IORef (Maybe Handle) -> IO (Maybe Handle)
forall a. IORef a -> IO a
readIORef IORef (Maybe Handle)
dbgHandle IO (Maybe Handle) -> (Maybe Handle -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Handle
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Handle
h -> do
      UTCTime
time <-  IO UTCTime
getCurrentTime
      ThreadId
tId <- IO ThreadId
myThreadId
      let m :: FilePath
m = ThreadId -> FilePath
forall a. Show a => a -> FilePath
show ThreadId
tId FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
s
      Handle -> FilePath -> IO ()
hPutStrLn Handle
h (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
rfc822DateFormat' UTCTime
time FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
m
      Handle -> IO ()
hFlush Handle
h
  where
    -- A bug in rfc822DateFormat makes us use our own format string
    rfc822DateFormat' :: FilePath
rfc822DateFormat' = FilePath
"%a, %d %b %Y %H:%M:%S %Z"

logError :: MonadBase IO m => T.Text -> m ()
logError :: Text -> m ()
logError Text
s = Text -> m ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s

logStream :: Show a => T.Text -> Chan a -> IO ()
logStream :: Text -> Chan a -> IO ()
logStream Text
msg Chan a
ch = do
  Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Logging stream " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
  ThreadId
logThreadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Text -> Chan a -> IO ()
forall a. Show a => Text -> Chan a -> IO ()
logStreamThread Text
msg Chan a
ch
  ThreadId -> FilePath -> IO ()
labelThread ThreadId
logThreadId FilePath
"LogStream"

logStreamThread :: Show a => T.Text -> Chan a -> IO ()
logStreamThread :: Text -> Chan a -> IO ()
logStreamThread Text
msg Chan a
ch = do
  [a]
stream <- Chan a -> IO [a]
forall a. Chan a -> IO [a]
getChanContents (Chan a -> IO [a]) -> IO (Chan a) -> IO [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Chan a -> IO (Chan a)
forall a. Chan a -> IO (Chan a)
dupChan Chan a
ch
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn [ Text
msg Text -> Char -> Text
`T.snoc` Char
'(' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) Text -> Char -> Text
`T.snoc` Char
')'
                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
event)
                    | (a
event, Int
i) <- [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
stream [(Int
0::Int)..]
                    ]

-- | Traces @x@ and returns @y@.
traceM :: Monad m => T.Text -> a -> m a
traceM :: Text -> a -> m a
traceM Text
x a
y = Text -> m a -> m a
forall a. Text -> a -> a
trace Text
x (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y

-- | Like traceM, but returns ().
traceM_ :: Monad m => T.Text -> m ()
traceM_ :: Text -> m ()
traceM_ Text
x = Text -> () -> m ()
forall (m :: * -> *) a. Monad m => Text -> a -> m a
traceM Text
x ()