summaryrefslogtreecommitdiff
path: root/src/Hakyll/Core/Logger.hs
blob: 4731c20f8291841f05c18fb21ae6c69a0a2bd926 (plain)
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
--------------------------------------------------------------------------------
-- | Produce pretty, thread-safe logs
module Hakyll.Core.Logger
    ( Verbosity (..)
    , Logger
    , new
    , flush
    , error
    , header
    , message
    , 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           Prelude                 hiding (error)


--------------------------------------------------------------------------------
data Verbosity
    = Error
    | 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
    }


--------------------------------------------------------------------------------
-- | Create a new logger
new :: Verbosity -> IO Logger
new vbty = do
    logger <- Logger <$>
        newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty
    _      <- 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 Message


--------------------------------------------------------------------------------
message :: MonadIO m => Logger -> String -> m ()
message l m = string l Message $ "  " ++ m


--------------------------------------------------------------------------------
debug :: MonadIO m => Logger -> String -> m ()
debug l m = string l Debug $ "  [DEBUG] " ++ m