{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : GHCup.Utils.Logger.Internal
Description : logger definition
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable

Breaking import cycles.
-}
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 :: 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 :: 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 :: 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 :: 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 :: LogLevel -> Text -> m ()
logInternal LogLevel
logLevel Text
msg = do
  LoggerConfig {Bool
Text -> IO ()
$sel:fancyColors:LoggerConfig :: LoggerConfig -> Bool
$sel:fileOutter:LoggerConfig :: LoggerConfig -> Text -> IO ()
$sel:consoleOutter:LoggerConfig :: LoggerConfig -> Text -> IO ()
$sel:lcPrintDebug:LoggerConfig :: LoggerConfig -> Bool
fancyColors :: Bool
fileOutter :: Text -> IO ()
consoleOutter :: Text -> IO ()
lcPrintDebug :: Bool
..} <- forall a env (m :: * -> *).
(MonadReader env m, LabelOptic' "loggerConfig" A_Lens env a) =>
m a
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 (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 (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 (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

  -- raw output
  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 (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