Add pretty, thread-safe logger

1 files changed, 82 insertions, 0 deletions

diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs
new file mode 100644
index 0000000..c5b8531
--- /dev/null
+++ b/src/Hakyll/Core/Logger.hs
@@ -0,0 +1,82 @@
+-- | Produce pretty, thread-safe logs
+--
+{-# LANGUAGE BangPatterns #-}
+module Hakyll.Core.Logger
+    ( Logger
+    , makeLogger
+    , flushLogger
+    , section
+    , timed
+    ) where
+
+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 = do
+        msg <- readChan $ loggerChan logger
+        case msg of
+            -- Stop: sync
+            Nothing -> putMVar (loggerSync logger) ()
+            -- Print and continue
+            Just m  -> do
+                putStrLn m
+                loggerThread logger
+
+-- | 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