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

61 lines
2.1 KiB
Haskell
Raw Permalink Normal View History

2020-01-11 20:15:05 +00:00
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Utils.Logger where
import GHCup.Utils
import Control.Monad
import Control.Monad.Logger
import HPath
import HPath.IO
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.IO.Error
import qualified Data.ByteString as B
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")
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
$ 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
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
initGHCupFileLogging context = do
logs <- ghcupLogsDir
let logfile = logs </> context
createDirIfMissing newDirPerms logs
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile