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
|
--------------------------------------------------------------------------------
-- | Produce pretty, thread-safe logs
{-# LANGUAGE Rank2Types #-}
module Hakyll.Core.Logger
( Verbosity (..)
, Logger
, new
, flush
, error
, header
, message
, debug
-- * Testing utilities
, newInMem
) where
--------------------------------------------------------------------------------
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (newChan, readChan, writeChan)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Monad (forever, when)
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Data.IORef as IORef
import Data.List (intercalate)
import Prelude hiding (error)
--------------------------------------------------------------------------------
data Verbosity
= Error
| Message
| Debug
deriving (Eq, Ord, Show)
--------------------------------------------------------------------------------
data Logger = Logger
{ -- | Flush the logger (blocks until flushed)
flush :: forall m. MonadIO m => m ()
, string :: forall m. MonadIO m => Verbosity -> String -> m ()
}
--------------------------------------------------------------------------------
-- | Create a new logger
new :: Verbosity -> IO Logger
new vbty = do
chan <- newChan
sync <- newEmptyMVar
_ <- forkIO $ forever $ do
msg <- readChan chan
case msg of
-- Stop: sync
Nothing -> putMVar sync ()
-- Print and continue
Just m -> putStrLn m
return $ Logger
{ flush = liftIO $ do
writeChan chan Nothing
() <- takeMVar sync
return ()
, string = \v m -> when (vbty >= v) $
liftIO $ writeChan chan (Just m)
}
--------------------------------------------------------------------------------
error :: MonadIO m => Logger -> String -> m ()
error l m = string l Error $ " [ERROR] " ++ indent m
--------------------------------------------------------------------------------
header :: MonadIO m => Logger -> String -> m ()
header l = string l Message
--------------------------------------------------------------------------------
message :: MonadIO m => Logger -> String -> m ()
message l m = string l Message $ " " ++ indent m
--------------------------------------------------------------------------------
debug :: MonadIO m => Logger -> String -> m ()
debug l m = string l Debug $ " [DEBUG] " ++ indent m
--------------------------------------------------------------------------------
indent :: String -> String
indent = intercalate "\n " . lines
--------------------------------------------------------------------------------
-- | Create a new logger that just stores all the messages, useful for writing
-- tests.
newInMem :: IO (Logger, IO [(Verbosity, String)])
newInMem = do
ref <- IORef.newIORef []
pure
( Logger
{ string = \vbty msg -> liftIO $ IORef.atomicModifyIORef' ref $
\msgs -> ((vbty, msg) : msgs, ())
, flush = pure ()
}
, reverse <$> IORef.readIORef ref
)
|
