hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve logging with newlines

Browse Source
This commit is contained in:
Julian Ospald 2021-07-11 14:34:05 +02:00
parent 83458c6c1e
commit d86f84eef4
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
1 changed files with 19 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
lib/GHCup/Utils/Logger.hs
View File

@ -20,6 +20,7 @@ import GHCup.Utils.String.QQ
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Data.Char ( ord )
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath
@ -43,13 +44,26 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let style' = case level of
LevelDebug -> style Bold . color Blue
LevelInfo -> style Bold . color Green
LevelWarn -> style Bold . color Yellow
LevelError -> style Bold . color Red
LevelOther _ -> id
let l = case level of
LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelDebug -> toLogStr (style' "[ Debug ]")
LevelInfo -> toLogStr (style' "[ Info ]")
LevelWarn -> toLogStr (style' "[ Warn ]")
LevelError -> toLogStr (style' "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
let strs = fmap toLogStr . B.split (fromIntegral $ ord '\n') . fromLogStr $ str'
let out = case strs of
[] -> B.empty
(x:xs) -> fromLogStr
. foldr (\a b -> a <> toLogStr "\n" <> b) mempty
. ((l <> toLogStr " " <> x) :)
. fmap (\line' -> (toLogStr (style' "[ ... ] ") <> line' ))
$ xs
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
$ colorOutter out