summaryrefslogtreecommitdiff
path: root/src/Hakyll/Core/Logger.hs
blob: 5d75fa959778d62eea6fbc53b44e8e5c0e02a7cc (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
99
-- | 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 ((<$>), (<*>))
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
    }

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