104 lines
2.9 KiB
Haskell
104 lines
2.9 KiB
Haskell
{-# 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 = logInternal Info
|
|
|
|
logWarn :: ( MonadReader env m
|
|
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
|
, MonadIO m
|
|
)
|
|
=> Text
|
|
-> m ()
|
|
logWarn = logInternal Warn
|
|
|
|
logDebug :: ( MonadReader env m
|
|
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
|
, MonadIO m
|
|
)
|
|
=> Text
|
|
-> m ()
|
|
logDebug = logInternal Debug
|
|
|
|
logError :: ( MonadReader env m
|
|
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
|
, MonadIO m
|
|
)
|
|
=> Text
|
|
-> m ()
|
|
logError = logInternal Error
|
|
|
|
|
|
logInternal :: ( MonadReader env m
|
|
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
|
, MonadIO m
|
|
) => LogLevel
|
|
-> Text
|
|
-> m ()
|
|
logInternal logLevel msg = do
|
|
LoggerConfig {..} <- gets @"loggerConfig"
|
|
let color' c = if fancyColors then color c else id
|
|
let style' = case logLevel of
|
|
Debug -> style Bold . color' Blue
|
|
Info -> style Bold . color' Green
|
|
Warn -> style Bold . color' Yellow
|
|
Error -> style Bold . color' Red
|
|
let l = case logLevel of
|
|
Debug -> style' "[ Debug ]"
|
|
Info -> style' "[ Info ]"
|
|
Warn -> style' "[ Warn ]"
|
|
Error -> style' "[ Error ]"
|
|
let strs = T.split (== '\n') msg
|
|
let out = case strs of
|
|
[] -> T.empty
|
|
(x:xs) ->
|
|
foldr (\a b -> a <> "\n" <> b) mempty
|
|
. ((l <> " " <> x) :)
|
|
. fmap (\line' -> style' "[ ... ] " <> line' )
|
|
$ xs
|
|
|
|
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
|
|
$ liftIO $ consoleOutter out
|
|
|
|
-- raw output
|
|
let lr = case logLevel of
|
|
Debug -> "Debug:"
|
|
Info -> "Info:"
|
|
Warn -> "Warn:"
|
|
Error -> "Error:"
|
|
let outr = lr <> " " <> msg <> "\n"
|
|
liftIO $ fileOutter outr
|
|
|