From 2ceb5f59d0728c380ad7b4f319a9282741e715b9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 3 Jan 2011 22:13:04 +0100 Subject: [PATCH] Avoid looking at up-to-date items at all --- src/Hakyll/Core/CompiledItem.hs | 2 +- src/Hakyll/Core/Compiler.hs | 34 +++++++++-- src/Hakyll/Core/Compiler/Internal.hs | 2 +- .../Core/DirectedGraph/ObsoleteFilter.hs | 6 +- src/Hakyll/Core/Run.hs | 58 +++++++++++++------ 5 files changed, 74 insertions(+), 28 deletions(-) diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs index d191e2a..d12d172 100644 --- a/src/Hakyll/Core/CompiledItem.hs +++ b/src/Hakyll/Core/CompiledItem.hs @@ -4,7 +4,7 @@ -- {-# LANGUAGE ExistentialQuantification #-} module Hakyll.Core.CompiledItem - ( CompiledItem + ( CompiledItem (..) , compiledItem , unCompiledItem ) where diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index fdc7d20..df1caeb 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -6,6 +6,7 @@ module Hakyll.Core.Compiler , getIdentifier , getRoute , getResourceString + , storeResult , require , requireAll , cached @@ -17,6 +18,7 @@ import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) import Control.Category (Category, (.)) +import Data.Maybe (fromMaybe) import Data.Binary (Binary) import Data.Typeable (Typeable) @@ -48,6 +50,28 @@ getResourceString = getIdentifier >>> getResourceString' provider <- compilerResourceProvider <$> ask liftIO $ resourceString provider id' +-- | Store a finished item in the cache +-- +storeResult :: Store -> Identifier -> CompiledItem -> IO () +storeResult store identifier (CompiledItem x) = + storeSet store "Hakyll.Core.Compiler.storeResult" identifier x + +-- | Auxiliary: get a dependency +-- +getDependencyOrResult :: (Binary a, Writable a, Typeable a) + => Identifier -> CompilerM a +getDependencyOrResult identifier = CompilerM $ do + lookup' <- compilerDependencyLookup <$> ask + store <- compilerStore <$> ask + case lookup' identifier of + -- Found in the dependency lookup + Just r -> return $ unCompiledItem r + -- Not found here, try the main cache + Nothing -> fmap (fromMaybe error') $ liftIO $ + storeGet store "Hakyll.Core.Compiler.storeResult" identifier + where + error' = error "Hakyll.Core.Compiler.getDependency: Not found" + -- | Require another target. Using this function ensures automatic handling of -- dependencies -- @@ -58,9 +82,9 @@ require :: (Binary a, Typeable a, Writable a) require identifier f = fromDependencies (const [identifier]) >>> fromJob require' where - require' x = CompilerM $ do - lookup' <- compilerDependencyLookup <$> ask - return $ f x $ unCompiledItem $ lookup' identifier + require' x = do + y <- getDependencyOrResult identifier + return $ f x y -- | Require a number of targets. Using this function ensures automatic handling -- of dependencies @@ -75,8 +99,8 @@ requireAll pattern f = getDeps = matches pattern . resourceList requireAll' x = CompilerM $ do deps <- getDeps . compilerResourceProvider <$> ask - lookup' <- compilerDependencyLookup <$> ask - return $ f x $ map (unCompiledItem . lookup') deps + items <- mapM (unCompilerM . getDependencyOrResult) deps + return $ f x items cached :: (Binary a) => String diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index a4dd695..262cda0 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -32,7 +32,7 @@ type Dependencies = Set Identifier -- | A lookup with which we can get dependencies -- -type DependencyLookup = Identifier -> CompiledItem +type DependencyLookup = Identifier -> Maybe CompiledItem -- | Environment in which a compiler runs -- diff --git a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs index f781819..9aeb2ff 100644 --- a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs +++ b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs @@ -7,6 +7,7 @@ module Hakyll.Core.DirectedGraph.ObsoleteFilter ( filterObsolete ) where +import Data.Set (Set) import qualified Data.Set as S import Hakyll.Core.DirectedGraph @@ -16,10 +17,11 @@ import qualified Hakyll.Core.DirectedGraph as DG -- contains these items -- filterObsolete :: Ord a - => [a] -- ^ List of obsolete items + => Set a -- ^ Obsolete items -> DirectedGraph a -- ^ Dependency graph -> DirectedGraph a -- ^ Resulting dependency graph filterObsolete obsolete graph = let reversed = DG.reverse graph - allObsolete = S.unions $ map (flip reachableNodes reversed) obsolete + allObsolete = S.unions $ map (flip reachableNodes reversed) + $ S.toList obsolete in DG.filter (`S.member` allObsolete) graph diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 6898b3a..e9ec47e 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -3,13 +3,16 @@ module Hakyll.Core.Run where import Control.Arrow ((&&&)) -import Control.Monad (foldM, forM_, forM) +import Control.Monad (foldM, forM_, forM, filterM) +import Data.Map (Map) import qualified Data.Map as M import Data.Monoid (mempty) import Data.Typeable (Typeable) import Data.Binary (Binary) import System.FilePath (()) import Control.Applicative ((<$>)) +import Data.Set (Set) +import qualified Data.Set as S import Hakyll.Core.Route import Hakyll.Core.Identifier @@ -22,6 +25,7 @@ import Hakyll.Core.Rules import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.Dot import Hakyll.Core.DirectedGraph.DependencySolver +import Hakyll.Core.DirectedGraph.ObsoleteFilter import Hakyll.Core.Writable import Hakyll.Core.Store import Hakyll.Core.CompiledItem @@ -48,9 +52,23 @@ hakyllWith rules provider store = do -- Create a compiler map compilerMap = M.fromList compilers - -- Create and solve the graph, creating a compiler order + -- Create the graph graph = fromList dependencies - ordered = solveDependencies graph + + putStrLn "Writing dependency graph to dependencies.dot..." + writeDot "dependencies.dot" show graph + + -- Check which items are up-to-date + modified' <- modified provider store $ map fst compilers + + let -- Try to reduce the graph + reducedGraph = filterObsolete modified' graph + + putStrLn "Writing reduced graph to reduced.dot..." + writeDot "reduced.dot" show reducedGraph + + let -- Solve the graph + ordered = solveDependencies reducedGraph -- Join the order with the compilers again orderedCompilers = map (id &&& (compilerMap M.!)) ordered @@ -58,30 +76,23 @@ hakyllWith rules provider store = do -- Fetch the routes route' = rulesRoute ruleSet - putStrLn "Writing dependency graph to dependencies.dot..." - writeDot "dependencies.dot" show graph - - -- Check which items are up-to-date: modified will be a Map Identifier Bool - modifiedMap <- fmap M.fromList $ forM orderedCompilers $ \(id', _) -> do - modified <- if resourceExists provider id' - then resourceModified provider id' store - else return False - return (id', modified) + putStrLn $ show reducedGraph + putStrLn $ show ordered -- Generate all the targets in order - _ <- foldM (addTarget route' modifiedMap) M.empty orderedCompilers + _ <- foldM (addTarget route' modified') M.empty orderedCompilers putStrLn "DONE." where - addTarget route' modifiedMap map' (id', comp) = do + addTarget route' modified' map' (id', comp) = do let url = runRoute route' id' -- Check if the resource was modified - let modified = modifiedMap M.! id' + let isModified = id' `S.member` modified' -- Run the compiler compiled <- runCompilerJob comp id' provider (dependencyLookup map') - url store modified + url store isModified putStrLn $ "Generated target: " ++ show id' case url of @@ -92,9 +103,18 @@ hakyllWith rules provider store = do makeDirectories path write path compiled + -- Store it in the cache + storeResult store id' compiled + putStrLn "" return $ M.insert id' compiled map' - dependencyLookup map' id' = case M.lookup id' map' of - Nothing -> error $ "dependencyLookup: " ++ show id' ++ " not found" - Just d -> d + dependencyLookup map' id' = M.lookup id' map' + +modified :: ResourceProvider -- ^ Resource provider + -> Store -- ^ Store + -> [Identifier] -- ^ Identifiers to check + -> IO (Set Identifier) -- ^ Modified resources +modified provider store ids = fmap S.fromList $ flip filterM ids $ \id' -> + if resourceExists provider id' then resourceModified provider id' store + else return False