|
sourcecode:
|
module CPM.ErrorLogger
( ErrorLogger (runErrorLogger)
, LogEntry
, LogLevel (..), logLevelOf
, logAt, getLogLevel, setLogLevel, getWithShowTime, setWithShowTime
, logInfo, logDebug, logError, logCritical, printLogEntry, levelGte
, putStrELM, putStrLnELM
, fromErrorLogger, fromErrorLoggerMsgs
, showExecCmd, execQuietCmd, liftIOEL, tryEL
, inDirectoryEL, inTempDirEL
) where
import Control.Monad ( unless )
import Data.Char ( toUpper )
import System.IO ( hPutStrLn, stderr )
import System.Process ( exitWith, system )
import System.Directory
import CPM.FileUtil
import Debug.Profile -- for show run-time
import Text.Pretty hiding (empty)
-- A value or an error, along with logs.
type ErrorLog a = ([LogEntry], Either LogEntry a)
--- An error logging IO monad.
newtype ErrorLogger a = ErrorLogger
{
runErrorLogger :: LogLevel -> Bool
-> IO ((LogLevel, Bool), ErrorLog a)
}
--- A log entry.
data LogEntry = LogEntry LogLevel String
logLevelOf :: LogEntry -> LogLevel
logLevelOf (LogEntry ll _) = ll
--- A log level.
data LogLevel = Quiet
| Info
| Debug
| Error
| Critical
deriving (Eq, Show)
---------------------------------------------------------------------------
instance Functor ErrorLogger where
fmap f e = ErrorLogger $ \l s -> do
(st, (msgs, err)) <- runErrorLogger e l s
let (glob, _) = st
mapM (printLogEntry glob) msgs
case err of
Left v -> return (st, ([], Left v))
Right a -> return (st, ([], Right (f a)))
instance Applicative ErrorLogger where
pure = return
f <*> v = f >>= \f' -> fmap f' v
instance Alternative ErrorLogger where
empty = fail "empty"
a <|> b = ErrorLogger $ \l s -> do
(st, (msgs, a')) <- runErrorLogger a l s
let (glob, showTime) = st
mapM (printLogEntry glob) msgs
case a' of
Left _ -> runErrorLogger b glob showTime
Right v -> return (st, ([], Right v))
instance Monad ErrorLogger where
return a = ErrorLogger $ \l s -> return ((l, s), ([], Right a))
m >>= f = ErrorLogger $ \l s -> do
(st, (msgs, err)) <- runErrorLogger m l s
let (glob, showTime) = st
mapM (printLogEntry glob) msgs
case err of
Right v -> do
(st', (msgs', err')) <- runErrorLogger (f v) glob showTime
return $ (st', (msgs', err'))
Left e -> return $ (st, ([], Left e))
instance MonadFail ErrorLogger where
fail msg = ErrorLogger $ \l s -> return ((l, s), ([logMsg], Left logMsg))
where logMsg = LogEntry Critical msg
--- Renders a log entry to stderr.
printLogEntry :: LogLevel -> LogEntry -> IO ()
printLogEntry minLevel (LogEntry lvl msg) = do
if levelGte lvl minLevel
then mapM_ (\l -> hPutStrLn stderr $ pPrint $ lvlText <+> text l)
(lines msg)
else return ()
where
lvlText = case lvl of
Quiet -> text "QUIET " -- should not occur...
Info -> text "INFO "
Debug -> green $ text "DEBUG "
Critical -> red $ text "CRITICAL "
Error -> red $ text "ERROR "
--- Renders a log entry relative to the given `LogLevel`.
showLogEntry :: LogLevel -> LogEntry -> String
showLogEntry minLevel (LogEntry lvl msg) =
if levelGte lvl minLevel
then unlines $ map (\l -> pPrint $ lvlText <+> text l) (lines msg)
else ""
where
lvlText = text (map toUpper (show lvl) ++ ":")
--- Compares two log levels.
levelGte :: LogLevel -> LogLevel -> Bool
levelGte Debug Debug = True
levelGte Debug Quiet = False
levelGte Debug Info = False
levelGte Debug Error = False
levelGte Debug Critical = False
levelGte Info Debug = True
levelGte Info Info = True
levelGte Info Quiet = False
levelGte Info Error = False
levelGte Info Critical = False
levelGte Quiet Debug = True
levelGte Quiet Quiet = True
levelGte Quiet Info = False
levelGte Quiet Error = False
levelGte Quiet Critical = False
levelGte Error Debug = True
levelGte Error Info = True
levelGte Error Quiet = True
levelGte Error Error = True
levelGte Error Critical = True
levelGte Critical Debug = True
levelGte Critical Info = True
levelGte Critical Quiet = True
levelGte Critical Error = True
levelGte Critical Critical = True
--- Logs a message at a user-defined level.
logAt :: LogLevel -> String -> ErrorLogger ()
logAt lvl msg = ErrorLogger $ \l wst ->
if wst
then do
runtime <- getProcessInfos >>= return . maybe 0 id . lookup ElapsedTime
return ((l, wst), ([LogEntry lvl (showTime runtime ++ 's':' ':msg)], Right ()))
else
return ((l, wst), ([LogEntry lvl msg], Right ()))
where
showTime t = show (t `div` 1000) ++ "." ++ show2 ((t `mod` 1000) `div` 10)
show2 i = if i < 10 then '0' : show i else show i
--- Logs a message at the info level.
logInfo :: String -> ErrorLogger ()
logInfo = logAt Info
--- Logs a message at the debug level.
logDebug :: String -> ErrorLogger ()
logDebug = logAt Debug
--- Logs a message at the error level.
logError :: String -> ErrorLogger ()
logError = logAt Error
--- Logs a message at the critical level.
logCritical :: String -> ErrorLogger ()
logCritical = logAt Critical
--- Prints a string in the `ErrorLogger` monad.
putStrELM :: String -> ErrorLogger ()
putStrELM = liftIOEL . putStr
--- Prints a line in the `ErrorLogger` monad.
putStrLnELM :: String -> ErrorLogger ()
putStrLnELM = liftIOEL . putStrLn
--- Transforms an error logger action into a standard IO action.
--- It shows all messages and, if the result is not available,
--- exits with a non-zero code.
--- The first argument specifies the logging level for messages.
--- If the second argument is true, timings are shown in the messages.
fromErrorLogger :: LogLevel -> Bool -> ErrorLogger a -> IO a
fromErrorLogger l s a = do
((glob, _), (msgs, err)) <- runErrorLogger a l s
mapM (printLogEntry glob) msgs
case err of
Right v -> return v
Left m -> printLogEntry glob m >> exitWith 1
--- Transforms an error logger action into a standard IO action
--- where all messages and the result (or `Nothing` in case of a failure)
--- are returned.
--- The first argument specifies the logging level for messages.
fromErrorLoggerMsgs :: LogLevel -> ErrorLogger a -> IO (String, Maybe a)
fromErrorLoggerMsgs lvl a = do
((glob, _), (msgs, err)) <- runErrorLogger a lvl False
let msgstxt = unlines $ map (showLogEntry glob) msgs
case err of
Right v -> return (msgstxt, Just v)
Left m -> do let errtxt = showLogEntry glob m
return (msgstxt ++ '\n' : errtxt, Nothing)
--- Returns the current log level.
getLogLevel :: ErrorLogger LogLevel
getLogLevel = ErrorLogger $ \ l s -> return ((l, s), ([], Right l))
--- Sets the current log level.
setLogLevel :: LogLevel -> ErrorLogger ()
setLogLevel l = ErrorLogger $ \ _ s -> return ((l, s), ([], Right ()))
--- Returns the current time-showing mode.
getWithShowTime :: ErrorLogger Bool
getWithShowTime = ErrorLogger $ \ l s -> return ((l, s), ([], Right s))
--- Sets the current time-showing mode.
setWithShowTime :: Bool -> ErrorLogger ()
setWithShowTime s = ErrorLogger $ \ l _ -> return ((l, s), ([], Right ()))
--- Lifts an IO action into the `ErrorLogger` monad.
liftIOEL :: IO a -> ErrorLogger a
liftIOEL ma = ErrorLogger (\l s -> do a <- ma
return ((l, s), ([], Right a)))
--- Tries to execute an EL action and returns either an error that
--- occurred or the value. If the first argument is `True`, the execution
--- will run quietly.
tryEL :: Bool -> ErrorLogger a -> ErrorLogger (Either LogEntry a)
tryEL quiet a = do
ll <- if quiet then return Quiet else getLogLevel
stime <- getWithShowTime
liftIOEL $ fmap (snd . snd) $ runErrorLogger a ll stime
--- Executes a system command and shows the command as debug message.
showExecCmd :: String -> ErrorLogger Int
showExecCmd cmd = do
logDebug $ "Executing: " ++ cmd
ec <- liftIOEL $ system cmd
unless (ec == 0) $
logDebug $ "Command terminated with non-zero exit code " ++ show ec
return ec
--- Executes a command depending on the verbosity mode.
--- If the log level is not `Debug`, the first (quiet) command is executed,
--- otherwise the second (more verbose) command is executed.
execQuietCmd :: String -> String -> ErrorLogger Int
execQuietCmd quietcmd verbosecmd = do
l <- getLogLevel
showExecCmd $ if l == Debug then verbosecmd else quietcmd
--- Executes an EL action with the current directory set to a specific
--- directory.
inDirectoryEL :: String -> ErrorLogger b -> ErrorLogger b
inDirectoryEL dir b = do
previous <- liftIOEL getCurrentDirectory
logDebug $ "Set current working directory to: " ++ dir
liftIOEL $ setCurrentDirectory dir
b' <- b
logDebug $ "Set current working directory to: " ++ previous
liftIOEL $ setCurrentDirectory previous
return b'
--- Executes an EL action with the current directory set to CPM's temporary
--- directory.
inTempDirEL :: ErrorLogger b -> ErrorLogger b
inTempDirEL b = do
t <- liftIOEL tempDir
exists <- liftIOEL $ doesDirectoryExist t
if exists
then return ()
else liftIOEL $ createDirectory t
inDirectoryEL t b
|