{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Lighthouse.Utils.Logging
    ( -- * Logging levels
      LogLevel (..)
    , errorLevel, warnLevel, infoLevel, debugLevel, traceLevel
      -- * Log messages
    , LogMessage (..)
      -- * Log handling
    , LogHandler, simpleLogHandler, noopLogHandler
    , MonadLogger (..)
      -- * Convenience functions
    , logError, logWarn, logInfo, logDebug, logTrace
    , runExceptTOrLog
    ) where

import Control.Monad (guard, void)
import Control.Monad.Trans (lift, MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.Monad.Trans.State (StateT (..))
import Control.Monad.Trans.Writer (WriterT (..))
import qualified Data.Text as T

-- | The level to log at.
data LogLevel = LogLevel { LogLevel -> Int
llValue :: Int, LogLevel -> Text
llName :: T.Text }

-- | The log level for errors.
errorLevel :: LogLevel
errorLevel :: LogLevel
errorLevel = Int -> Text -> LogLevel
LogLevel Int
2 Text
"ERROR"

-- | The log level for warnings.
warnLevel :: LogLevel
warnLevel :: LogLevel
warnLevel = Int -> Text -> LogLevel
LogLevel Int
1 Text
"WARN"

-- | The log level for informational messages.
infoLevel :: LogLevel
infoLevel :: LogLevel
infoLevel = Int -> Text -> LogLevel
LogLevel Int
0 Text
"INFO"

-- | The log level for debug messages.
debugLevel :: LogLevel
debugLevel :: LogLevel
debugLevel = Int -> Text -> LogLevel
LogLevel (-Int
1) Text
"DEBUG"

-- | The log level for trace messages.
traceLevel :: LogLevel
traceLevel :: LogLevel
traceLevel = Int -> Text -> LogLevel
LogLevel (-Int
2) Text
"TRACE"

-- | A logged message along with a level to log it at and an origin.
data LogMessage = LogMessage
    { LogMessage -> LogLevel
lmLevel   :: LogLevel
    , LogMessage -> Text
lmOrigin  :: T.Text
    , LogMessage -> Text
lmMessage :: T.Text
    }

-- | A processor for log messages.
type LogHandler = LogMessage -> IO ()

-- | A simple stdout-based log handler.
simpleLogHandler :: LogLevel -> LogHandler
simpleLogHandler :: LogLevel -> LogHandler
simpleLogHandler LogLevel
handlerLevel LogMessage {Text
LogLevel
lmLevel :: LogMessage -> LogLevel
lmOrigin :: LogMessage -> Text
lmMessage :: LogMessage -> Text
lmLevel :: LogLevel
lmOrigin :: Text
lmMessage :: Text
..} = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MaybeT IO () -> IO (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO () -> IO (Maybe ())) -> MaybeT IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
    Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (LogLevel -> Int
llValue LogLevel
lmLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel -> Int
llValue LogLevel
handlerLevel)
    IO () -> MaybeT IO ()
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LogLevel -> Text
llName LogLevel
lmLevel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lmOrigin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lmMessage

-- | A log handler that swallows messages and outputs nothing.
noopLogHandler :: LogHandler
noopLogHandler :: LogHandler
noopLogHandler = IO () -> LogHandler
forall a b. a -> b -> a
const (IO () -> LogHandler) -> IO () -> LogHandler
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

class Monad m => MonadLogger m where
    -- | Logs the given message within the monad.
    logMessage :: LogMessage -> m ()

instance MonadLogger m => MonadLogger (ExceptT e m) where
    logMessage :: LogMessage -> ExceptT e m ()
logMessage = m () -> ExceptT e m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ())
-> (LogMessage -> m ()) -> LogMessage -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage

instance MonadLogger m => MonadLogger (ReaderT r m) where
    logMessage :: LogMessage -> ReaderT r m ()
logMessage = m () -> ReaderT r m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ())
-> (LogMessage -> m ()) -> LogMessage -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage

instance MonadLogger m => MonadLogger (MaybeT m) where
    logMessage :: LogMessage -> MaybeT m ()
logMessage = m () -> MaybeT m ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ())
-> (LogMessage -> m ()) -> LogMessage -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage

instance MonadLogger m => MonadLogger (StateT s m) where
    logMessage :: LogMessage -> StateT s m ()
logMessage = m () -> StateT s m ()
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (LogMessage -> m ()) -> LogMessage -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage

instance (Monoid w, MonadLogger m) => MonadLogger (WriterT w m) where
    logMessage :: LogMessage -> WriterT w m ()
logMessage = m () -> WriterT w m ()
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ())
-> (LogMessage -> m ()) -> LogMessage -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage

-- | Logs a message at the error level.
logError :: MonadLogger m => T.Text -> T.Text -> m ()
logError :: forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logError Text
o Text
m = LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage LogMessage { lmLevel :: LogLevel
lmLevel = LogLevel
errorLevel, lmOrigin :: Text
lmOrigin = Text
o, lmMessage :: Text
lmMessage = Text
m }

-- | Logs a message at the warn level.
logWarn :: MonadLogger m => T.Text -> T.Text -> m ()
logWarn :: forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logWarn Text
o Text
m = LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage LogMessage { lmLevel :: LogLevel
lmLevel = LogLevel
warnLevel, lmOrigin :: Text
lmOrigin = Text
o, lmMessage :: Text
lmMessage = Text
m }

-- | Logs a message at the info level.
logInfo :: MonadLogger m => T.Text -> T.Text -> m ()
logInfo :: forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logInfo Text
o Text
m = LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage LogMessage { lmLevel :: LogLevel
lmLevel = LogLevel
infoLevel, lmOrigin :: Text
lmOrigin = Text
o, lmMessage :: Text
lmMessage = Text
m }

-- | Logs a message at the debug level.
logDebug :: MonadLogger m => T.Text -> T.Text -> m ()
logDebug :: forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebug Text
o Text
m = LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage LogMessage { lmLevel :: LogLevel
lmLevel = LogLevel
debugLevel, lmOrigin :: Text
lmOrigin = Text
o, lmMessage :: Text
lmMessage = Text
m }

-- | Logs a message at the trace level.
logTrace :: MonadLogger m => T.Text -> T.Text -> m ()
logTrace :: forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logTrace Text
o Text
m = LogMessage -> m ()
forall (m :: * -> *). MonadLogger m => LogMessage -> m ()
logMessage LogMessage { lmLevel :: LogLevel
lmLevel = LogLevel
traceLevel, lmOrigin :: Text
lmOrigin = Text
o, lmMessage :: Text
lmMessage = Text
m }

-- | Runs the ExceptT transformer or logs if needed.
runExceptTOrLog :: (MonadLogger m, Show e) => ExceptT e m a -> m ()
runExceptTOrLog :: forall (m :: * -> *) e a.
(MonadLogger m, Show e) =>
ExceptT e m a -> m ()
runExceptTOrLog ExceptT e m a
e = do
    Either e a
res <- ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
e
    case Either e a
res of
        Left e
err -> Text -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logError Text
"runExceptTOrLog" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Got error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (e -> String
forall a. Show a => a -> String
show e
err)
        Right a
_  -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()