2012-11-14 10:17:28 +00:00
|
|
|
--------------------------------------------------------------------------------
|
2011-02-21 01:56:57 +00:00
|
|
|
-- | Produce pretty, thread-safe logs
|
|
|
|
module Hakyll.Core.Logger
|
2012-11-14 10:17:28 +00:00
|
|
|
( Verbosity (..)
|
|
|
|
, Logger
|
|
|
|
, new
|
|
|
|
, flush
|
|
|
|
, error
|
|
|
|
, header
|
2012-11-14 12:32:31 +00:00
|
|
|
, message
|
2012-11-14 10:17:28 +00:00
|
|
|
, debug
|
2011-02-21 01:56:57 +00:00
|
|
|
) where
|
|
|
|
|
|
|
|
|
2012-11-14 10:17:28 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
import Control.Applicative (pure, (<$>), (<*>))
|
|
|
|
import Control.Concurrent (forkIO)
|
|
|
|
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
|
|
|
|
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
|
|
|
|
import Control.Monad (forever)
|
|
|
|
import Control.Monad.Trans (MonadIO, liftIO)
|
|
|
|
import Prelude hiding (error)
|
2011-02-21 01:56:57 +00:00
|
|
|
|
2012-11-14 10:17:28 +00:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
data Verbosity
|
|
|
|
= Error
|
|
|
|
| Message
|
|
|
|
| Debug
|
|
|
|
deriving (Eq, Ord, Show)
|
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2011-02-21 01:56:57 +00:00
|
|
|
-- | Logger structure. Very complicated.
|
|
|
|
data Logger = Logger
|
2012-11-14 10:17:28 +00:00
|
|
|
{ loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end
|
|
|
|
, loggerSync :: MVar () -- ^ Used for sync on quit
|
|
|
|
, loggerSink :: String -> IO () -- ^ Out sink
|
|
|
|
, loggerVerbosity :: Verbosity -- ^ Verbosity
|
2011-02-21 01:56:57 +00:00
|
|
|
}
|
|
|
|
|
2012-11-14 10:17:28 +00:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2011-02-21 01:56:57 +00:00
|
|
|
-- | Create a new logger
|
2012-11-14 10:17:28 +00:00
|
|
|
new :: Verbosity -> (String -> IO ()) -> IO Logger
|
|
|
|
new vbty sink = do
|
|
|
|
logger <- Logger <$>
|
2012-11-14 12:32:31 +00:00
|
|
|
newChan <*> newEmptyMVar <*> pure sink <*> pure vbty
|
2012-11-14 10:17:28 +00:00
|
|
|
_ <- forkIO $ loggerThread logger
|
2011-02-21 01:56:57 +00:00
|
|
|
return logger
|
|
|
|
where
|
2011-02-21 09:56:04 +00:00
|
|
|
loggerThread logger = forever $ do
|
2011-02-21 01:56:57 +00:00
|
|
|
msg <- readChan $ loggerChan logger
|
|
|
|
case msg of
|
|
|
|
-- Stop: sync
|
|
|
|
Nothing -> putMVar (loggerSync logger) ()
|
|
|
|
-- Print and continue
|
2011-05-25 09:23:50 +00:00
|
|
|
Just m -> loggerSink logger m
|
2011-02-21 01:56:57 +00:00
|
|
|
|
2012-11-14 10:17:28 +00:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2011-02-21 01:56:57 +00:00
|
|
|
-- | Flush the logger (blocks until flushed)
|
2012-11-14 10:17:28 +00:00
|
|
|
flush :: Logger -> IO ()
|
|
|
|
flush logger = do
|
2011-02-21 01:56:57 +00:00
|
|
|
writeChan (loggerChan logger) Nothing
|
|
|
|
() <- takeMVar $ loggerSync logger
|
|
|
|
return ()
|
|
|
|
|
2012-11-14 10:17:28 +00:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
string :: MonadIO m
|
|
|
|
=> Logger -- ^ Logger
|
|
|
|
-> Verbosity -- ^ Verbosity of the string
|
|
|
|
-> String -- ^ Section name
|
|
|
|
-> m () -- ^ No result
|
|
|
|
string l v m
|
|
|
|
| loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)
|
|
|
|
| otherwise = return ()
|
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
error :: MonadIO m => Logger -> String -> m ()
|
2012-11-14 12:32:31 +00:00
|
|
|
error l m = string l Error $ " [ERROR] " ++ m
|
2012-11-14 10:17:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
header :: MonadIO m => Logger -> String -> m ()
|
2012-11-14 12:32:31 +00:00
|
|
|
header l = string l Message
|
2012-11-14 10:17:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2012-11-14 12:32:31 +00:00
|
|
|
message :: MonadIO m => Logger -> String -> m ()
|
|
|
|
message l m = string l Message $ " " ++ m
|
2012-11-14 10:17:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
debug :: MonadIO m => Logger -> String -> m ()
|
2012-11-14 12:32:31 +00:00
|
|
|
debug l m = string l Debug $ " [DEBUG] " ++ m
|