{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module GHCup.Prelude.Logger.Internal where
import GHCup.Types
import GHCup.Types.Optics
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text ( Text )
import Optics
import Prelude hiding ( appendFile )
import System.Console.Pretty
import qualified Data.Text as T
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo :: forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo = LogLevel -> Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
LogLevel -> Text -> m ()
logInternal LogLevel
Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn :: forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn = LogLevel -> Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
LogLevel -> Text -> m ()
logInternal LogLevel
Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug :: forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug = LogLevel -> Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
LogLevel -> Text -> m ()
logInternal LogLevel
Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError :: forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logError = LogLevel -> Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
LogLevel -> Text -> m ()
logInternal LogLevel
Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal :: forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
LogLevel -> Text -> m ()
logInternal LogLevel
logLevel Text
msg = do
LoggerConfig {Bool
Text -> IO ()
lcPrintDebug :: Bool
consoleOutter :: Text -> IO ()
fileOutter :: Text -> IO ()
fancyColors :: Bool
$sel:lcPrintDebug:LoggerConfig :: LoggerConfig -> Bool
$sel:consoleOutter:LoggerConfig :: LoggerConfig -> Text -> IO ()
$sel:fileOutter:LoggerConfig :: LoggerConfig -> Text -> IO ()
$sel:fancyColors:LoggerConfig :: LoggerConfig -> Bool
..} <- forall (f :: Symbol) a env (m :: * -> *).
(MonadReader env m, LabelOptic' f A_Lens env a) =>
m a
gets @"loggerConfig"
let color' :: Color -> Text -> Text
color' Color
c = if Bool
fancyColors then Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
c else Text -> Text
forall a. a -> a
id
let style' :: Text -> Text
style' = case LogLevel
logLevel of
LogLevel
Debug -> Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Bold (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Text -> Text
color' Color
Blue
LogLevel
Info -> Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Bold (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Text -> Text
color' Color
Green
LogLevel
Warn -> Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Bold (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Text -> Text
color' Color
Yellow
LogLevel
Error -> Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Bold (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Text -> Text
color' Color
Red
let l :: Text
l = case LogLevel
logLevel of
LogLevel
Debug -> Text -> Text
style' Text
"[ Debug ]"
LogLevel
Info -> Text -> Text
style' Text
"[ Info ]"
LogLevel
Warn -> Text -> Text
style' Text
"[ Warn ]"
LogLevel
Error -> Text -> Text
style' Text
"[ Error ]"
let strs :: [Text]
strs = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
msg
let out :: Text
out = case [Text]
strs of
[] -> Text
T.empty
(Text
x:[Text]
xs) ->
(Text -> Text -> Text) -> Text -> [Text] -> Text
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Text
a Text
b -> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b) Text
forall a. Monoid a => a
mempty
([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
line' -> Text -> Text
style' Text
"[ ... ] " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line' )
([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
xs
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
lcPrintDebug Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
lcPrintDebug Bool -> Bool -> Bool
&& (LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
/= LogLevel
Debug)))
(m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
consoleOutter Text
out
let lr :: Text
lr = case LogLevel
logLevel of
LogLevel
Debug -> Text
"Debug:"
LogLevel
Info -> Text
"Info:"
LogLevel
Warn -> Text
"Warn:"
LogLevel
Error -> Text
"Error:"
let outr :: Text
outr = Text
lr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
fileOutter Text
outr