ghcup-hs/lib/GHCup/Prelude/Logger/Internal.hs

104 lines
2.9 KiB
Haskell
Raw Normal View History

2021-04-29 12:47:30 +00:00
{-# LANGUAGE FlexibleContexts #-}
2021-09-23 10:53:01 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
2022-05-21 20:54:18 +00:00
Module : GHCup.Utils.Logger.Internal
2020-07-21 23:08:58 +00:00
Description : logger definition
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
2022-05-21 20:54:18 +00:00
Breaking import cycles.
2020-07-21 23:08:58 +00:00
-}
2022-05-21 20:54:18 +00:00
module GHCup.Prelude.Logger.Internal where
2020-01-11 20:15:05 +00:00
import GHCup.Types
import GHCup.Types.Optics
2020-01-11 20:15:05 +00:00
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
2021-09-23 10:53:01 +00:00
import Data.Text ( Text )
import Optics
2020-01-11 20:15:05 +00:00
import Prelude hiding ( appendFile )
2021-09-23 10:53:01 +00:00
import System.Console.Pretty
2020-01-11 20:15:05 +00:00
2021-09-23 10:53:01 +00:00
import qualified Data.Text as T
2020-01-11 20:15:05 +00:00
2021-09-23 10:53:01 +00:00
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') . T.dropWhileEnd (`elem` ("\n\r" :: String)) $ msg
2021-09-23 10:53:01 +00:00
let out = case strs of
[] -> T.empty
2022-05-21 20:54:18 +00:00
(x:xs) ->
2021-09-23 10:53:01 +00:00
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
2020-01-11 20:15:05 +00:00