Avoid looking at up-to-date items at all
This commit is contained in:
parent
40c75767d4
commit
2ceb5f59d0
5 changed files with 74 additions and 28 deletions
|
@ -4,7 +4,7 @@
|
|||
--
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
module Hakyll.Core.CompiledItem
|
||||
( CompiledItem
|
||||
( CompiledItem (..)
|
||||
, compiledItem
|
||||
, unCompiledItem
|
||||
) where
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
--
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue