| 4 | 4 |
, warn
|
| 5 | 5 |
, error
|
| 6 | 6 |
, critical
|
| 7 |
, die
|
| 7 | 8 |
|
| 8 | 9 |
, Logger
|
| 9 | 10 |
, Level(..)
|
| 10 | |
, setLogger
|
| 11 |
, HasLogger(..)
|
| 12 |
, setGlobalLogger
|
| 11 | 13 |
, mkLogger
|
| 12 | 14 |
) where
|
| 13 | 15 |
|
|
| 17 | 19 |
import qualified Data.IORef as IORef
|
| 18 | 20 |
import qualified GHC.Stack as GHC
|
| 19 | 21 |
import qualified System.Environment as Env
|
| 22 |
import qualified System.Exit as Exit
|
| 20 | 23 |
import qualified System.IO as IO
|
| 21 | 24 |
import qualified System.IO.Unsafe as Unsafe
|
| 22 | 25 |
import Prelude hiding (log, error)
|
| 23 | 26 |
|
| 24 | 27 |
import Logging.Bock.Color (supportsColor)
|
| 25 | 28 |
|
| 29 |
-- | A 'Logger' represents the current configuration of log messages,
|
| 30 |
-- and includes where to send log messages (e.g. to stderr or to
|
| 31 |
-- files) and the current severity cutoff.
|
| 26 | 32 |
data Logger = Logger
|
| 27 | 33 |
{ logUseColors :: !Bool
|
| 28 | 34 |
, logWrite :: !(String -> IO ())
|
| 29 | 35 |
, logLevel :: !Level
|
| 30 | 36 |
}
|
| 31 | 37 |
|
| 38 |
-- | The level of severity of the log. Severity levels are used for
|
| 39 |
-- controlling which logging messages are important enough to be shown
|
| 40 |
-- and which should not be. The default severity level of the logger
|
| 41 |
-- is 'Info', which means all messages except 'Debug' messages will be
|
| 42 |
-- shown. This can be modified upwards (to show only more important
|
| 43 |
-- messages) or downwards (to show all messages.)
|
| 32 | 44 |
data Level
|
| 33 | 45 |
= Debug
|
| 34 | 46 |
| Info
|
|
| 37 | 49 |
| Critical
|
| 38 | 50 |
deriving (Eq, Show, Ord)
|
| 39 | 51 |
|
| 52 |
-- | The default logger will
|
| 40 | 53 |
parseLevel :: String -> Maybe Level
|
| 41 | 54 |
parseLevel s = case map Char.toUpper s of
|
| 42 | 55 |
"DEBUG" -> Just Debug
|
|
| 80 | 93 |
Nothing -> pure IO.stderr
|
| 81 | 94 |
IORef.newIORef logger
|
| 82 | 95 |
|
| 83 | |
setLogger :: Logger -> IO ()
|
| 84 | |
setLogger = IORef.writeIORef defaultLogger
|
| 96 |
-- | Modify the current global logger.
|
| 97 |
setGlobalLogger :: Logger -> IO ()
|
| 98 |
setGlobalLogger = IORef.writeIORef defaultLogger
|
| 85 | 99 |
|
| 100 |
-- | Create a logger with a specified severity cutoff and a handle to
|
| 101 |
-- write to. This will automatically support message coloring if the
|
| 102 |
-- handle corresponds to a TTY (i.e. if it is pointed at
|
| 103 |
-- stdout/stderr) and otherwise will not.
|
| 86 | 104 |
mkLogger :: Level -> IO.Handle -> IO Logger
|
| 87 | 105 |
mkLogger level h = do
|
| 88 | 106 |
useColors <- supportsColor h
|
|
| 92 | 110 |
, logLevel = level
|
| 93 | 111 |
}
|
| 94 | 112 |
|
| 113 |
-- | A typeclass for monads which support producing log
|
| 114 |
-- messages. These can piggyback on the IO instance, which uses a
|
| 115 |
-- shared global logger, or they can create a derived and locally
|
| 116 |
-- stored logger which might put its log messages in a different place
|
| 117 |
-- or use a different format
|
| 95 | 118 |
class IOClass.MonadIO m => HasLogger m where
|
| 96 | 119 |
getLogger :: m Logger
|
| 97 | 120 |
|
|
| 112 | 135 |
logWrite l endColorCode
|
| 113 | 136 |
logWrite l "\n"
|
| 114 | 137 |
|
| 138 |
-- | Produce a 'Debug'-level log message.
|
| 115 | 139 |
debug :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
|
| 116 | 140 |
debug = log Debug (getLoc GHC.callStack)
|
| 117 | 141 |
|
| 142 |
-- | Produce an 'Info'-level log message.
|
| 118 | 143 |
info :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
|
| 119 | 144 |
info = log Info (getLoc GHC.callStack)
|
| 120 | 145 |
|
| 146 |
-- | Produce an 'Warn'-level log message.
|
| 121 | 147 |
warn :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
|
| 122 | 148 |
warn = log Warn (getLoc GHC.callStack)
|
| 123 | 149 |
|
| 150 |
-- | Produce an 'Error'-level log message.
|
| 124 | 151 |
error :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
|
| 125 | 152 |
error = log Error (getLoc GHC.callStack)
|
| 126 | 153 |
|
| 154 |
-- | Produce a 'Critical'-level log message.
|
| 127 | 155 |
critical :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
|
| 128 | 156 |
critical = log Critical (getLoc GHC.callStack)
|
| 157 |
|
| 158 |
-- | Produce a 'Critical'-level log message, and then exit the program
|
| 159 |
-- immediately with an error code.
|
| 160 |
die :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
|
| 161 |
die msg = do
|
| 162 |
log Critical (getLoc GHC.callStack) msg
|
| 163 |
IOClass.liftIO Exit.exitFailure
|