Add pretty, thread-safe logger

3 files changed, 129 insertions, 35 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 8d713c2..7d2d116 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -253,8 +253,6 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
     identifier <- compilerIdentifier <$> ask
     store <- compilerStore <$> ask
     modified <- compilerResourceModified <$> ask
-    liftIO $ putStrLn $
-        show identifier ++ ": " ++ if modified then "MODIFIED" else "OK"
     if modified
         then do v <- unCompilerM $ j $ Resource identifier
                 liftIO $ storeSet store name identifier v
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
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index b4c69f1..54c22c2 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -10,7 +10,7 @@ import Control.Monad (filterM)
 import Control.Monad.Trans (liftIO)
 import Control.Applicative (Applicative, (<$>))
 import Control.Monad.Reader (ReaderT, runReaderT, ask)
-import Control.Monad.State (StateT, evalStateT, get, modify)
+import Control.Monad.State.Strict (StateT, evalStateT, get, modify)
 import Control.Arrow ((&&&))
 import qualified Data.Map as M
 import Data.Monoid (mempty, mappend)
@@ -31,25 +31,36 @@ import Hakyll.Core.DirectedGraph.DependencySolver
 import Hakyll.Core.Writable
 import Hakyll.Core.Store
 import Hakyll.Core.Configuration
+import Hakyll.Core.Logger
 
 -- | Run all rules needed, return the rule set used
 --
 run :: HakyllConfiguration -> Rules -> IO RuleSet
 run configuration rules = do
-    store <- makeStore $ storeDirectory configuration
-    provider <- fileResourceProvider configuration
+    logger <- makeLogger
+
+    section logger "Initialising"
+    store <- timed logger "Creating store" $
+        makeStore $ storeDirectory configuration
+    provider <- timed logger "Creating provider" $
+        fileResourceProvider configuration
+
     let ruleSet = runRules rules provider
         compilers = rulesCompilers ruleSet
 
         -- Extract the reader/state
         reader = unRuntime $ addNewCompilers [] compilers
-        state' = runReaderT reader $ env ruleSet provider store
+        state' = runReaderT reader $ env logger ruleSet provider store
 
     evalStateT state' state
+
+    -- Flush and return
+    flushLogger logger
     return ruleSet
   where
-    env ruleSet provider store = RuntimeEnvironment
-        { hakyllConfiguration    = configuration
+    env logger ruleSet provider store = RuntimeEnvironment
+        { hakyllLogger           = logger
+        , hakyllConfiguration    = configuration
         , hakyllRoutes           = rulesRoutes ruleSet
         , hakyllResourceProvider = provider
         , hakyllStore            = store
@@ -61,7 +72,8 @@ run configuration rules = do
         }
 
 data RuntimeEnvironment = RuntimeEnvironment
-    { hakyllConfiguration    :: HakyllConfiguration
+    { hakyllLogger           :: Logger
+    , hakyllConfiguration    :: HakyllConfiguration
     , hakyllRoutes           :: Routes
     , hakyllResourceProvider :: ResourceProvider
     , hakyllStore            :: Store
@@ -96,6 +108,8 @@ addNewCompilers :: [(Identifier, Compiler () CompileRule)]
                 -> Runtime ()
 addNewCompilers oldCompilers newCompilers = Runtime $ do
     -- Get some information
+    logger <- hakyllLogger <$> ask
+    section logger "Adding new compilers"
     provider <- hakyllResourceProvider <$> ask
     store <- hakyllStore <$> ask
 
@@ -115,31 +129,31 @@ addNewCompilers oldCompilers newCompilers = Runtime $ do
 
     -- Find the old graph and append the new graph to it. This forms the
     -- complete graph
-    completeGraph <- mappend currentGraph . hakyllGraph <$> get
-
-    -- Check which items are up-to-date. This only needs to happen for the new
-    -- compilers
-    oldModified <- hakyllModified <$> get 
-    newModified <- liftIO $ modified provider store $ map fst newCompilers
+    completeGraph <- timed logger "Creating graph" $
+        mappend currentGraph . hakyllGraph <$> get
 
-    let modified' = oldModified `S.union` newModified
-        
-        -- Find obsolete items. Every item that is reachable from a modified
-        -- item is considered obsolete. From these obsolete items, we are only
-        -- interested in ones that are in the current subgraph.
-        obsolete = S.filter (`member` currentGraph)
-                 $ reachableNodes modified' $ reverse completeGraph
+    orderedCompilers <- timed logger "Solving dependencies" $ do
+        -- Check which items are up-to-date. This only needs to happen for the new
+        -- compilers
+        oldModified <- hakyllModified <$> get 
+        newModified <- liftIO $ modified provider store $ map fst newCompilers
 
-        -- Solve the graph and retain only the obsolete items
-        ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph
+        let modified' = oldModified `S.union` newModified
+            
+            -- Find obsolete items. Every item that is reachable from a modified
+            -- item is considered obsolete. From these obsolete items, we are only
+            -- interested in ones that are in the current subgraph.
+            obsolete = S.filter (`member` currentGraph)
+                     $ reachableNodes modified' $ reverse completeGraph
 
-        -- Join the order with the compilers again
-        orderedCompilers = map (id &&& (compilerMap M.!)) ordered
+            -- Solve the graph and retain only the obsolete items
+            ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph
 
-    liftIO $ putStrLn "Adding compilers..."
-    liftIO $ putStrLn $ "Added: " ++ show (map fst orderedCompilers)
+        -- Update the state
+        modify $ updateState modified' completeGraph
 
-    modify $ updateState modified' completeGraph
+        -- Join the order with the compilers again
+        return $ map (id &&& (compilerMap M.!)) ordered
 
     -- Now run the ordered list of compilers
     unRuntime $ runCompilers orderedCompilers
@@ -157,33 +171,33 @@ runCompilers :: [(Identifier, Compiler () CompileRule)]
 runCompilers [] = return ()
 runCompilers ((id', compiler) : compilers) = Runtime $ do
     -- Obtain information
+    logger <- hakyllLogger <$> ask
     routes <- hakyllRoutes <$> ask
     provider <- hakyllResourceProvider <$> ask
     store <- hakyllStore <$> ask
     modified' <- hakyllModified <$> get
 
+    section logger $ "Compiling " ++ show id'
+
     let -- Check if the resource was modified
         isModified = id' `S.member` modified'
 
     -- Run the compiler
-    result <- liftIO $ runCompiler compiler id' provider routes store isModified
-    liftIO $ putStrLn $ "Generated target: " ++ show id'
+    result <- timed logger "Compiling item" $
+        liftIO $ runCompiler compiler id' provider routes store isModified
 
     case result of
         -- Compile rule for one item, easy stuff
         CompileRule compiled -> do
             case runRoutes routes id' of
                 Nothing  -> return ()
-                Just url -> do
-                    liftIO $ putStrLn $ "Routing " ++ show id' ++ " to " ++ url
+                Just url -> timed logger ("Routing to " ++ url) $ do
                     destination <-
                         destinationDirectory . hakyllConfiguration <$> ask
                     let path = destination </> url
                     liftIO $ makeDirectories path
                     liftIO $ write path compiled
 
-            liftIO $ putStrLn ""
-
             -- Continue for the remaining compilers
             unRuntime $ runCompilers compilers