@@ -1,40 +1,56 @@
1+--------------------------------------------------------------------------------
12-- | Produce pretty, thread-safe logs
2−--
3−{-# LANGUAGE BangPatterns #-}
43module Hakyll.Core.Logger
5− ( Logger
6− , makeLogger
7− , flushLogger
8− , section
9− , timed
10− , report
11− , thrown
4+ ( Verbosity (..)
5+ , Logger
6+ , new
7+ , flush
8+ , error
9+ , header
10+ , item
11+ , subitem
12+ , debug
1213 ) where
1314
14−import Control.Monad (forever)
15−import Control.Monad.Trans (MonadIO, liftIO)
16−import Control.Applicative (pure, (<$>), (<*>))
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
19−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
20−import Text.Printf (printf)
2115
22−import Data.Time (getCurrentTime, diffUTCTime)
16+--------------------------------------------------------------------------------
17+import Control.Applicative (pure, (<$>), (<*>))
18+import Control.Concurrent (forkIO)
19+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
20+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
21+import Control.Monad (forever)
22+import Control.Monad.Trans (MonadIO, liftIO)
23+import Data.List (intercalate)
24+import Prelude hiding (error)
2325
26+
27+--------------------------------------------------------------------------------
28+data Verbosity
29+ = Error
30+ | Header
31+ | Message
32+ | Debug
33+ deriving (Eq, Ord, Show)
34+
35+
36+--------------------------------------------------------------------------------
2437-- | Logger structure. Very complicated.
25−--
2638data 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
39+ { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end
40+ , loggerSync :: MVar () -- ^ Used for sync on quit
41+ , loggerSink :: String -> IO () -- ^ Out sink
42+ , loggerVerbosity :: Verbosity -- ^ Verbosity
43+ , loggerColumns :: Int -- ^ Preferred number of columns
3044 }
3145
46+
47+--------------------------------------------------------------------------------
3248-- | Create a new logger
33−--
34−makeLogger :: (String -> IO ()) -> IO Logger
35−makeLogger sink = do
36− logger <- Logger <$> newChan <*> newEmptyMVar <*> pure sink
37− _ <- forkIO $ loggerThread logger
49+new :: Verbosity -> (String -> IO ()) -> IO Logger
50+new vbty sink = do
51+ logger <- Logger <$>
52+ newChan <*> newEmptyMVar <*> pure sink <*> pure vbty <*> pure 80
53+ _ <- forkIO $ loggerThread logger
3854 return logger
3955 where
4056 loggerThread logger = forever $ do
@@ -45,56 +61,58 @@ makeLogger sink = do
4561 -- Print and continue
4662 Just m -> loggerSink logger m
4763
64+
65+--------------------------------------------------------------------------------
4866-- | Flush the logger (blocks until flushed)
49−--
50−flushLogger :: Logger -> IO ()
51−flushLogger logger = do
67+flush :: Logger -> IO ()
68+flush logger = do
5269 writeChan (loggerChan logger) Nothing
5370 () <- takeMVar $ loggerSync logger
5471 return ()
5572
56−-- | Send a raw message to the logger
57−--
58−message :: Logger -> String -> IO ()
59−message logger = writeChan (loggerChan logger) . Just
60−
61−-- | Start a section in the log
62−--
63−section :: MonadIO m
64− => Logger -- ^ Logger
65− -> String -- ^ Section name
66− -> m () -- ^ No result
67−section logger = liftIO . message logger
68−
69−-- | Execute a monadic action and log the duration
70−--
71−timed :: MonadIO m
72− => Logger -- ^ Logger
73− -> String -- ^ Message
74− -> m a -- ^ Action
75− -> m a -- ^ Timed and logged action
76−timed 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
85−
86−-- | Log something at the same level as 'timed', but without the timing
87−--
88−report :: MonadIO m
89− => Logger -- ^ Logger
90− -> String -- ^ Message
91− -> m () -- ^ No result
92−report logger msg = liftIO $ message logger $ " [ ] " ++ msg
93−
94−-- | Log an error that was thrown in the compilation phase
95−--
96−thrown :: MonadIO m
97− => Logger -- ^ Logger
98− -> String -- ^ Message
99− -> m () -- ^ No result
100−thrown logger msg = liftIO $ message logger $ " [ ERROR] " ++ msg
73+
74+--------------------------------------------------------------------------------
75+string :: MonadIO m
76+ => Logger -- ^ Logger
77+ -> Verbosity -- ^ Verbosity of the string
78+ -> String -- ^ Section name
79+ -> m () -- ^ No result
80+string l v m
81+ | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)
82+ | otherwise = return ()
83+
84+
85+--------------------------------------------------------------------------------
86+error :: MonadIO m => Logger -> String -> m ()
87+error l m = string l Error $ "ERROR: " ++ m
88+
89+
90+--------------------------------------------------------------------------------
91+header :: MonadIO m => Logger -> String -> m ()
92+header l = string l Header
93+
94+
95+--------------------------------------------------------------------------------
96+item :: MonadIO m => Logger -> [String] -> m ()
97+item = itemWith 2
98+
99+
100+--------------------------------------------------------------------------------
101+subitem :: MonadIO m => Logger -> [String] -> m ()
102+subitem = itemWith 4
103+
104+
105+--------------------------------------------------------------------------------
106+itemWith :: MonadIO m => Int -> Logger -> [String] -> m ()
107+itemWith _ _ [] = return ()
108+itemWith i l [x] = string l Message $ replicate i ' ' ++ x
109+itemWith i l (x : ys) = string l Message $ indent ++ x ++ spaces ++ ys'
110+ where
111+ indent = replicate i ' '
112+ spaces = replicate (max 1 $ loggerColumns l - i - length x - length ys') ' '
113+ ys' = intercalate ", " ys
114+
115+
116+--------------------------------------------------------------------------------
117+debug :: MonadIO m => Logger -> String -> m ()
118+debug l m = string l Debug $ " DEBUG: " ++ m