Add new dependency analyzer & tests

2 files changed, 163 insertions, 0 deletions

diff --git a/src/Hakyll/Core/DependencyAnalyzer.hs b/src/Hakyll/Core/DependencyAnalyzer.hs
new file mode 100644
index 0000000..97a571f
--- /dev/null
+++ b/src/Hakyll/Core/DependencyAnalyzer.hs
@@ -0,0 +1,155 @@
+module Hakyll.Core.DependencyAnalyzer
+    ( DependencyAnalyzer
+    , Signal (..)
+    , makeDependencyAnalyzer
+    , step
+    , stepAll
+    ) where
+
+import Prelude hiding (reverse)
+import qualified Prelude as P (reverse)
+import Control.Arrow (first)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Monoid (Monoid, mappend, mempty)
+
+import Hakyll.Core.DirectedGraph
+
+-- | This data structure represents the state of the dependency analyzer. It
+-- holds a complete graph in 'analyzerGraph', which always contains all items,
+-- whether they are to be compiled or not.
+--
+-- The 'analyzerRemains' fields holds the items that still need to be compiled,
+-- and 'analyzerDone' holds the items which are already compiled. This means
+-- that initally, 'analyzerDone' is empty and 'analyzerRemains' contains the
+-- items which are out-of-date (or items which have out-of-date dependencies).
+--
+-- We also hold the dependency graph from the previous run because we need it
+-- when we want to determine when an item is out-of-date. An item is out-of-date
+-- when:
+--
+-- * the resource from which it compiles is out-of-date, or;
+--
+-- * any of it's dependencies is out-of-date, or;
+--
+-- * it's set of dependencies has changed since the previous run.
+--
+data DependencyAnalyzer a = DependencyAnalyzer
+    { -- | The complete dependency graph
+      analyzerGraph         :: DirectedGraph a
+    , -- | A set of items yet to be compiled
+      analyzerRemains       :: Set a
+    , -- | A set of items already compiled
+      analyzerDone          :: Set a
+    , -- | The dependency graph from the previous run
+      analyzerPreviousGraph :: DirectedGraph a
+    } deriving (Show)
+
+data Signal a = Build a
+              | Cycle [a]
+              | Done
+
+instance (Ord a, Show a) => Monoid (DependencyAnalyzer a) where
+    mempty = DependencyAnalyzer mempty mempty mempty mempty
+    mappend x y = growRemains $ DependencyAnalyzer
+        (analyzerGraph x `mappend` analyzerGraph y)
+        (analyzerRemains x `mappend` analyzerRemains y)
+        (analyzerDone x `mappend` analyzerDone y)
+        (analyzerPreviousGraph x `mappend` analyzerPreviousGraph y)
+
+-- | Construct a dependency analyzer
+--
+makeDependencyAnalyzer :: (Ord a, Show a)
+                       => DirectedGraph a       -- ^ The dependency graph
+                       -> (a -> Bool)           -- ^ Is an item out-of-date?
+                       -> DirectedGraph a       -- ^ The old dependency graph
+                       -> DependencyAnalyzer a  -- ^ Resulting analyzer
+makeDependencyAnalyzer graph isOutOfDate prev =
+    growRemains $ DependencyAnalyzer graph remains S.empty prev
+  where
+    -- Construct the remains set by filtering using the given predicate
+    remains = S.fromList $ filter isOutOfDate $ map fst $ toList graph
+
+-- | The 'analyzerRemains' field of a 'DependencyAnalyzer' is supposed to
+-- contain all out-of-date items, including the items with out-of-date
+-- dependencies. However, it is easier to just set up the directly out-of-date
+-- items initially -- and then grow the remains fields.
+--
+-- This function assumes the 'analyzerRemains' fields in incomplete, and tries
+-- to correct it. Running it when the field is complete has no effect -- but it
+-- is a pretty expensive function, and it should be used with care.
+--
+growRemains :: (Ord a, Show a) => DependencyAnalyzer a -> DependencyAnalyzer a
+growRemains (DependencyAnalyzer graph remains done prev) =
+    (DependencyAnalyzer graph remains' done prev)
+  where
+    -- Grow the remains set using the indirect and changedDeps values, then
+    -- filter out the items already done
+    remains' = S.filter (`S.notMember` done) indirect
+
+    -- Select the nodes which are reachable from the remaining nodes in the
+    -- reversed dependency graph: these are the indirectly out-of-date items
+    indirect = reachableNodes (remains `S.union` changedDeps) $ reverse graph
+
+    -- For all nodes in the graph, check which items have a different dependency
+    -- set compared to the previous run
+    changedDeps = S.fromList $ map fst $
+        filter (uncurry (/=) . first (`neighbours` prev)) $ toList graph
+
+-- | Step a dependency analyzer
+--
+step :: (Ord a, Show a) => DependencyAnalyzer a -> (Signal a, DependencyAnalyzer a)
+step analyzer@(DependencyAnalyzer graph remains done prev)
+    -- No remaining items
+    | S.null remains = (Done, analyzer)
+    -- An item remains, let's find a ready item
+    | otherwise =
+        let item = S.findMin remains
+        in case findReady analyzer item of
+            Done        -> (Done, analyzer)
+            Cycle c     -> (Cycle c, analyzer)
+            -- A ready item was found, signal a build
+            Build build ->
+                let remains' = S.delete build remains
+                    done'    = S.insert build done
+                in (Build build, DependencyAnalyzer graph remains' done' prev)
+
+-- | Step until done, creating a set of items we need to build -- mostly used
+-- for debugging purposes
+--
+stepAll :: (Ord a, Show a) => DependencyAnalyzer a -> Maybe (Set a)
+stepAll = stepAll' S.empty
+  where
+    stepAll' xs analyzer = case step analyzer of
+        (Build x, analyzer') -> stepAll' (S.insert x xs) analyzer'
+        (Done, _)            -> Just xs
+        (Cycle _, _)         -> Nothing
+
+-- | Find an item ready to be compiled
+--
+findReady :: (Ord a, Show a) => DependencyAnalyzer a -> a -> Signal a
+findReady analyzer = findReady' [] S.empty
+  where
+    -- The dependency graph
+    graph = analyzerGraph analyzer
+
+    -- Items to do
+    todo = analyzerRemains analyzer `S.difference` analyzerDone analyzer
+
+    -- Worker
+    findReady' stack visited item
+        -- We already visited this item, the cycle is the reversed stack
+        | item `S.member` visited = Cycle $ P.reverse stack'
+        -- Look at the neighbours we to do
+        | otherwise = case filter (`S.member` todo) neighbours' of
+            -- No neighbours available to be done: it's ready!
+            []      -> Build item
+            -- At least one neighbour is available, search for that one
+            (x : _) -> findReady' stack' visited' x
+      where
+        -- Our neighbours
+        neighbours' = S.toList $ neighbours item graph
+
+        -- The new visited stack/set
+        stack' = item : stack
+        visited' = S.insert item visited
diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs
index 76a030b..6be5c5c 100644
--- a/src/Hakyll/Core/DirectedGraph.hs
+++ b/src/Hakyll/Core/DirectedGraph.hs
@@ -4,6 +4,7 @@
 module Hakyll.Core.DirectedGraph
     ( DirectedGraph
     , fromList
+    , toList
     , member
     , nodes
     , neighbours
@@ -13,6 +14,7 @@ module Hakyll.Core.DirectedGraph
     ) where
 
 import Prelude hiding (reverse)
+import Control.Arrow (second)
 import Data.Monoid (mconcat)
 import Data.Set (Set)
 import Data.Maybe (fromMaybe)
@@ -28,6 +30,12 @@ fromList :: Ord a
          -> DirectedGraph a  -- ^ Resulting directed graph
 fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d))
 
+-- | Deconstruction of directed graphs
+--
+toList :: DirectedGraph a
+       -> [(a, Set a)]
+toList = map (second nodeNeighbours) . M.toList . unDirectedGraph
+
 -- | Check if a node lies in the given graph
 --
 member :: Ord a