1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
--------------------------------------------------------------------------------
--- 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, showLogEntry, levelGte
  , putStrELM, putStrLnELM
  , fromErrorLogger
  , showExecCmd, execQuietCmd, liftIOEL, tryEL
  , inDirectoryEL, inTempDirEL
  ) where

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

---------------------------------------------------------------------------

instance Functor ErrorLogger where
  fmap f e = ErrorLogger $ \l s -> do
    (st, (msgs, err)) <- runErrorLogger e l s
    let (glob, _) = st
    mapM (showLogEntry 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 (showLogEntry 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 (showLogEntry 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.
showLogEntry :: LogLevel -> LogEntry -> IO ()
showLogEntry 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 "

--- 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) ++ "." ++ show ((t `mod` 1000) `div` 10)

--- 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 (showLogEntry glob) msgs
  case err of
    Right v -> return v
    Left  m -> showLogEntry glob m >> exitWith 1

--- Executes a system command and show the command as debug message.
showExecCmd :: String -> ErrorLogger Int
showExecCmd cmd = logDebug ("Executing: " ++ cmd) >>
  liftIOEL (system cmd)

--- Executes a parameterized system command.
--- The parameter is set to `-q` unless the LogLevel is Debug.
execQuietCmd :: (String -> String) -> ErrorLogger Int
execQuietCmd cmd = logDebug ("Executing: " ++ cmd "") >>
  ErrorLogger (\l s -> do i <- system $ cmd (if l == Debug then "" else "-q")
                          return ((l, s), ([], Right i)))

getLogLevel :: ErrorLogger LogLevel
getLogLevel = ErrorLogger $ \ l s -> return ((l, s), ([], Right l))

getWithShowTime :: ErrorLogger Bool
getWithShowTime = ErrorLogger $ \ l s -> return ((l, s), ([], Right s))

setLogLevel :: LogLevel -> ErrorLogger ()
setLogLevel l = ErrorLogger $ \ _ s -> return ((l, s), ([], Right ()))

setWithShowTime :: Bool -> ErrorLogger ()
setWithShowTime s = ErrorLogger $ \ l _ -> return ((l, s), ([], Right ()))

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.
tryEL :: ErrorLogger a -> ErrorLogger (Either LogEntry a)
tryEL a = liftIOEL $ fmap (snd . snd) $ runErrorLogger a Quiet False

--- 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
  liftIOEL $ setCurrentDirectory dir
  b' <- b
  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