diff options
| -rw-r--r-- | src/Hakyll/Core/Compiler.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Core/Logger.hs | 82 | ||||
| -rw-r--r-- | src/Hakyll/Core/Run.hs | 80 |
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 |