summaryrefslogtreecommitdiff
path: root/src/Hakyll
diff options
context:
space:
mode:
authorJasper Van der Jeugt <jaspervdj@gmail.com>2011-02-21 02:56:57 +0100
committerJasper Van der Jeugt <jaspervdj@gmail.com>2011-02-21 02:56:57 +0100
commit256cc760bae2e8bc4238fb8b903ffc92a36d7db9 (patch)
treec51b69b5ee4618f676f49d3a3a645190103e4c2d /src/Hakyll
parentf04efbad3ed6f5cbc215f8aa72b1bd0203712768 (diff)
downloadhakyll-256cc760bae2e8bc4238fb8b903ffc92a36d7db9.tar.gz
Add pretty, thread-safe logger
Diffstat (limited to 'src/Hakyll')
-rw-r--r--src/Hakyll/Core/Compiler.hs2
-rw-r--r--src/Hakyll/Core/Logger.hs82
-rw-r--r--src/Hakyll/Core/Run.hs80
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