git.iko.soy/hakyll
on 5dba607 help sign in
hakyll/src/Hakyll/Core/Logger.hs
100 lines 2.9 kB history raw
1-- | Produce pretty, thread-safe logs
2--
3{-# LANGUAGE BangPatterns #-}
4module Hakyll.Core.Logger
5 ( Logger
6 , makeLogger
7 , flushLogger
8 , section
9 , timed
10 , report
11 , thrown
12 ) where
14import Control.Monad (forever)
15import Control.Monad.Trans (MonadIO, liftIO)
16import Control.Applicative (pure, (<$>), (<*>))
17import Control.Concurrent (forkIO)
18import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
19import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
20import Text.Printf (printf)
22import Data.Time (getCurrentTime, diffUTCTime)
24-- | Logger structure. Very complicated.
25--
26data Logger = Logger
27 { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end
28 , loggerSync :: MVar () -- ^ Used for sync on quit
29 , loggerSink :: String -> IO () -- ^ Out sink
30 }
32-- | Create a new logger
33--
34makeLogger :: (String -> IO ()) -> IO Logger
35makeLogger sink = do
36 logger <- Logger <$> newChan <*> newEmptyMVar <*> pure sink
37 _ <- forkIO $ loggerThread logger
38 return logger
39 where
40 loggerThread logger = forever $ do
41 msg <- readChan $ loggerChan logger
42 case msg of
43 -- Stop: sync
44 Nothing -> putMVar (loggerSync logger) ()
45 -- Print and continue
46 Just m -> loggerSink logger m
48-- | Flush the logger (blocks until flushed)
49--
50flushLogger :: Logger -> IO ()
51flushLogger logger = do
52 writeChan (loggerChan logger) Nothing
53 () <- takeMVar $ loggerSync logger
54 return ()
56-- | Send a raw message to the logger
57--
58message :: Logger -> String -> IO ()
59message logger = writeChan (loggerChan logger) . Just
61-- | Start a section in the log
62--
63section :: MonadIO m
64 => Logger -- ^ Logger
65 -> String -- ^ Section name
66 -> m () -- ^ No result
67section logger = liftIO . message logger
69-- | Execute a monadic action and log the duration
70--
71timed :: MonadIO m
72 => Logger -- ^ Logger
73 -> String -- ^ Message
74 -> m a -- ^ Action
75 -> m a -- ^ Timed and logged action
76timed logger msg action = do
77 start <- liftIO getCurrentTime
78 !result <- action
79 stop <- liftIO getCurrentTime
80 let diff = fromEnum $ diffUTCTime stop start
81 ms = diff `div` 10 ^ (9 :: Int)
82 formatted = printf " [%4dms] %s" ms msg
83 liftIO $ message logger formatted
84 return result
86-- | Log something at the same level as 'timed', but without the timing
87--
88report :: MonadIO m
89 => Logger -- ^ Logger
90 -> String -- ^ Message
91 -> m () -- ^ No result
92report logger msg = liftIO $ message logger $ " [ ] " ++ msg
94-- | Log an error that was thrown in the compilation phase
95--
96thrown :: MonadIO m
97 => Logger -- ^ Logger
98 -> String -- ^ Message
99 -> m () -- ^ No result
100thrown logger msg = liftIO $ message logger $ " [ ERROR] " ++ msg