    {-# 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 ()