{-# 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
  hndl <- IORef (Maybe Handle) -> IO (Maybe Handle)
forall a. IORef a -> IO a
readIORef IORef (Maybe Handle)
dbgHandle
  case hndl of
    Maybe Handle
Nothing -> do FilePath -> IOMode -> IO Handle
openFile FilePath
f IOMode
WriteMode IO Handle -> (Handle -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 :: forall a. 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
e
{-# NOINLINE trace #-}

error :: T.Text -> a
error :: forall a. 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 a b. IO a -> IO b -> IO b
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 :: forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
s = IO () -> m ()
forall α. 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Handle
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Handle
h -> do
      time <-  IO UTCTime
getCurrentTime
      tId <- myThreadId
      let 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
      hPutStrLn h $ formatTime defaultTimeLocale rfc822DateFormat' time ++ m
      hFlush 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 :: forall (m :: * -> *). MonadBase IO m => 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 :: forall a. Show a => 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
  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
  labelThread logThreadId "LogStream"

logStreamThread :: Show a => T.Text -> Chan a -> IO ()
logStreamThread :: forall a. Show a => Text -> Chan a -> IO ()
logStreamThread Text
msg Chan a
ch = do
  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
  mapM_ logPutStrLn [ msg `T.snoc` '(' <> T.pack (show i) `T.snoc` ')'
                     <> T.pack (show event)
                    | (event, i) <- zip stream [(0::Int)..]
                    ]

-- | Traces @x@ and returns @y@.
traceM :: Monad m => T.Text -> a -> m a
traceM :: forall (m :: * -> *) a. Monad m => 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 a. 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_ :: forall (m :: * -> *). Monad m => Text -> m ()
traceM_ Text
x = Text -> () -> m ()
forall (m :: * -> *) a. Monad m => Text -> a -> m a
traceM Text
x ()