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

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

Here we define our main logger.
-}
module GHCup.Utils.Logger where

import           GHCup.Types
import           GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
import           GHCup.Utils.String.QQ

import           Control.Exception.Safe
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           System.FilePath
import           System.IO.Error
import           Text.Regex.Posix

import qualified Data.ByteString               as B
import GHCup.Utils.Prelude
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


initGHCupFileLogging :: ( MonadReader env m
                        , HasDirs env
                        , MonadIO m
                        , MonadMask m
                        ) => m FilePath
initGHCupFileLogging :: m FilePath
initGHCupFileLogging = do
  Dirs { FilePath
$sel:logsDir:Dirs :: Dirs -> FilePath
logsDir :: FilePath
logsDir } <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let logfile :: FilePath
logfile = FilePath
logsDir FilePath -> FilePath -> FilePath
</> FilePath
"ghcup.log"
  [FilePath]
logFiles <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
    FilePath
logsDir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
                   ExecOption
execBlank
                   ([s|^.*\.log$|] :: B.ByteString)
    )
  [FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
logFiles ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> (FilePath -> m ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile (FilePath -> m ()) -> (FilePath -> FilePath) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
logsDir FilePath -> FilePath -> FilePath
</>)

  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile FilePath
logfile FilePath
""
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
logfile