--------------------------------------------------------------------------------
--- Contains combinators for chaining IO actions that can fail and log messages.
--------------------------------------------------------------------------------

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