git.iko.soy/hakyll
on 877cb21 help sign in
hakyll/src/Hakyll/Core/Logger.hs
98 lines 3.3 kB history raw
1--------------------------------------------------------------------------------
2-- | Produce pretty, thread-safe logs
3module Hakyll.Core.Logger
4 ( Verbosity (..)
5 , Logger
6 , new
7 , flush
8 , error
9 , header
10 , message
11 , debug
12 ) where
15--------------------------------------------------------------------------------
16import Control.Applicative (pure, (<$>), (<*>))
17import Control.Concurrent (forkIO)
18import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
19import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
20import Control.Monad (forever)
21import Control.Monad.Trans (MonadIO, liftIO)
22import Prelude hiding (error)
25--------------------------------------------------------------------------------
26data Verbosity
27 = Error
28 | Message
29 | Debug
30 deriving (Eq, Ord, Show)
33--------------------------------------------------------------------------------
34-- | Logger structure. Very complicated.
35data Logger = Logger
36 { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end
37 , loggerSync :: MVar () -- ^ Used for sync on quit
38 , loggerSink :: String -> IO () -- ^ Out sink
39 , loggerVerbosity :: Verbosity -- ^ Verbosity
40 }
43--------------------------------------------------------------------------------
44-- | Create a new logger
45new :: Verbosity -> (String -> IO ()) -> IO Logger
46new vbty sink = do
47 logger <- Logger <$>
48 newChan <*> newEmptyMVar <*> pure sink <*> pure vbty
49 _ <- forkIO $ loggerThread logger
50 return logger
51 where
52 loggerThread logger = forever $ do
53 msg <- readChan $ loggerChan logger
54 case msg of
55 -- Stop: sync
56 Nothing -> putMVar (loggerSync logger) ()
57 -- Print and continue
58 Just m -> loggerSink logger m
61--------------------------------------------------------------------------------
62-- | Flush the logger (blocks until flushed)
63flush :: Logger -> IO ()
64flush logger = do
65 writeChan (loggerChan logger) Nothing
66 () <- takeMVar $ loggerSync logger
67 return ()
70--------------------------------------------------------------------------------
71string :: MonadIO m
72 => Logger -- ^ Logger
73 -> Verbosity -- ^ Verbosity of the string
74 -> String -- ^ Section name
75 -> m () -- ^ No result
76string l v m
77 | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)
78 | otherwise = return ()
81--------------------------------------------------------------------------------
82error :: MonadIO m => Logger -> String -> m ()
83error l m = string l Error $ " [ERROR] " ++ m
86--------------------------------------------------------------------------------
87header :: MonadIO m => Logger -> String -> m ()
88header l = string l Message
91--------------------------------------------------------------------------------
92message :: MonadIO m => Logger -> String -> m ()
93message l m = string l Message $ " " ++ m
96--------------------------------------------------------------------------------
97debug :: MonadIO m => Logger -> String -> m ()
98debug l m = string l Debug $ " [DEBUG] " ++ m