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

84 lines
2.7 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
import Prelude hiding ( appendFile )
import System.Console.Pretty
2021-05-14 21:09:45 +00:00
import System.Directory hiding ( findFiles )
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
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 ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
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: "
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-05-14 21:09:45 +00:00
createDirectoryIfMissing True logsDir
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