Avoid looking at up-to-date items at all

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