ghcup-hs/lib/GHCup/Utils/Logger.hs

96 lines
3.2 KiB
Haskell
Raw Normal View History

2021-04-29 12:47:30 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Utils.Logger
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
Here we define our main logger.
-}
2020-01-11 20:15:05 +00:00
module GHCup.Utils.Logger where
2021-04-29 12:47:30 +00:00
import GHCup.Utils.File
import GHCup.Utils.String.QQ
2020-01-11 20:15:05 +00:00
import Control.Monad
import Control.Monad.IO.Class
2020-01-11 20:15:05 +00:00
import Control.Monad.Logger
2021-07-11 12:34:05 +00:00
import Data.Char ( ord )
2020-01-11 20:15:05 +00:00
import Prelude hiding ( appendFile )
import System.Console.Pretty
2021-05-14 21:09:45 +00:00
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO.Error
2021-04-29 12:47:30 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString as B
2021-05-14 21:09:45 +00:00
import GHCup.Utils.Prelude
2020-01-11 20:15:05 +00:00
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
2021-07-11 12:34:05 +00:00
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
2020-01-11 20:15:05 +00:00
let l = case level of
2021-07-11 12:34:05 +00:00
LevelDebug -> toLogStr (style' "[ Debug ]")
LevelInfo -> toLogStr (style' "[ Info ]")
LevelWarn -> toLogStr (style' "[ Warn ]")
LevelError -> toLogStr (style' "[ Error ]")
2020-01-11 20:15:05 +00:00
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
2021-07-11 12:34:05 +00:00
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' )
2021-07-11 12:34:05 +00:00
$ xs
2020-01-11 20:15:05 +00:00
2021-03-11 16:03:51 +00:00
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
2020-01-11 20:15:05 +00:00
$ colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug:"
2020-01-11 20:15:05 +00:00
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
2021-05-14 21:09:45 +00:00
initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
initGHCupFileLogging logsDir = do
let logfile = logsDir </> "ghcup.log"
liftIO $ do
2021-04-29 12:47:30 +00:00
logFiles <- findFiles
logsDir
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
2021-05-14 21:09:45 +00:00
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
2021-04-29 12:47:30 +00:00
2021-05-14 21:09:45 +00:00
writeFile logfile ""
pure logfile