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