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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
--------------------------------------------------------------------------------
-- | Produce pretty, thread-safe logs
module Hakyll.Core.Logger
( Verbosity (..)
, Logger
, new
, flush
, error
, header
, item
, subitem
, debug
) where
--------------------------------------------------------------------------------
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 Data.List (intercalate)
import Prelude hiding (error)
--------------------------------------------------------------------------------
data Verbosity
= Error
| Header
| Message
| Debug
deriving (Eq, Ord, Show)
--------------------------------------------------------------------------------
-- | 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
, loggerVerbosity :: Verbosity -- ^ Verbosity
, loggerColumns :: Int -- ^ Preferred number of columns
}
--------------------------------------------------------------------------------
-- | Create a new logger
new :: Verbosity -> (String -> IO ()) -> IO Logger
new vbty sink = do
logger <- Logger <$>
newChan <*> newEmptyMVar <*> pure sink <*> pure vbty <*> pure 80
_ <- 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)
flush :: Logger -> IO ()
flush logger = do
writeChan (loggerChan logger) Nothing
() <- takeMVar $ loggerSync logger
return ()
--------------------------------------------------------------------------------
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 ()
error l m = string l Error $ "ERROR: " ++ m
--------------------------------------------------------------------------------
header :: MonadIO m => Logger -> String -> m ()
header l = string l Header
--------------------------------------------------------------------------------
item :: MonadIO m => Logger -> [String] -> m ()
item = itemWith 2
--------------------------------------------------------------------------------
subitem :: MonadIO m => Logger -> [String] -> m ()
subitem = itemWith 4
--------------------------------------------------------------------------------
itemWith :: MonadIO m => Int -> Logger -> [String] -> m ()
itemWith _ _ [] = return ()
itemWith i l [x] = string l Message $ replicate i ' ' ++ x
itemWith i l (x : ys) = string l Message $ indent ++ x ++ spaces ++ ys'
where
indent = replicate i ' '
spaces = replicate (max 1 $ loggerColumns l - i - length x - length ys') ' '
ys' = intercalate ", " ys
--------------------------------------------------------------------------------
debug :: MonadIO m => Logger -> String -> m ()
debug l m = string l Debug $ " DEBUG: " ++ m
|