Pick dependency analyzer from old develop branch

1 files changed, 138 insertions, 150 deletions

diff --git a/src/Hakyll/Core/DependencyAnalyzer.hs b/src/Hakyll/Core/DependencyAnalyzer.hs
index c39b399..be470b3 100644
--- a/src/Hakyll/Core/DependencyAnalyzer.hs
+++ b/src/Hakyll/Core/DependencyAnalyzer.hs
@@ -1,156 +1,144 @@
+--------------------------------------------------------------------------------
 module Hakyll.Core.DependencyAnalyzer
-    ( DependencyAnalyzer (..)
-    , Signal (..)
-    , makeDependencyAnalyzer
-    , step
-    , stepAll
+    ( Analysis (..)
+    , analyze
     ) 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
-              deriving (Show)
-
-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)
+
+--------------------------------------------------------------------------------
+import           Control.Applicative       ((<$>))
+import           Control.DeepSeq           (NFData (..))
+import           Control.Monad             (filterM, forM_, msum, when)
+import           Control.Monad.Reader      (ask)
+import           Control.Monad.RWS         (RWS, runRWS)
+import           Control.Monad.State       (evalState, get, modify)
+import           Control.Monad.Writer      (tell)
+import qualified Data.Map                  as M
+import           Data.Set                  (Set)
+import qualified Data.Set                  as S
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.DirectedGraph
+
+
+--------------------------------------------------------------------------------
+data Analysis a
+    = Cycle [a]
+    | Order [a]
+    deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance NFData a => NFData (Analysis a) where
+    rnf (Cycle c) = rnf c `seq` ()
+    rnf (Order o) = rnf o `seq` ()
+
+
+--------------------------------------------------------------------------------
+analyze :: Ord a
+        => DirectedGraph a  -- ^ Old graph
+        -> DirectedGraph a  -- ^ New graph
+        -> (a -> Bool)      -- ^ Out of date?
+        -> Analysis a       -- ^ Result
+analyze old new ood = case findCycle new of
+    Just c  -> Cycle c
+    Nothing -> Order $ findOrder old new ood
+
+
+--------------------------------------------------------------------------------
+-- | Simple algorithm do find a cycle in a graph, if any exists. This one can
+-- still be optimised by a lot.
+findCycle :: Ord a
+          => DirectedGraph a
+          -> Maybe [a]
+findCycle dg = fmap reverse $ msum
+    [ findCycle' [x] x n
+    | x <- S.toList $ nodes dg
+    , n <- neighbours x dg
+    ]
   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
+    findCycle' stack start x
+        | x == start = Just (x : stack)
+        | otherwise  = msum
+            [ findCycle' (x : stack) start n
+            | n <- neighbours x dg
+            ]
+
+
+--------------------------------------------------------------------------------
+-- | Do not call this on graphs with cycles
+findOrder :: Ord a
+          => DirectedGraph a
+          -> DirectedGraph a
+          -> (a -> Bool)
+          -> [a]
+findOrder old new ood = ls
   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
+    -- Make an extension of ood: an item is ood when it is actually ood OR if
+    -- the list of its dependencies has changed. Based on that, create a set of
+    -- dirty items.
+    ood' x = ood x || neighbours x old /= neighbours x new
+    dirty' = dirty ood' new
+
+    -- Run all walks in our own little monad...
+    (_, _, ls) = runRWS walks new dirty'
+
+
+--------------------------------------------------------------------------------
+type Analyzer i a = RWS (DirectedGraph i) [i] (Set i) a
+
+
+--------------------------------------------------------------------------------
+isDirty :: Ord a => a -> Analyzer a Bool
+isDirty x = (x `S.member`) <$> get
+
+
+--------------------------------------------------------------------------------
+walks :: Ord a
+      => Analyzer a ()
+walks = do
+    dirty' <- get
+    if S.null dirty'
+        then return ()
+        else do
+            walk $ S.findMin dirty'
+            walks
+
+
+--------------------------------------------------------------------------------
+-- | Invariant: given node to walk /must/ be dirty
+walk :: Ord a
+     => a
+     -> Analyzer a ()
+walk x = do
+    -- Determine dirty neighbours and walk them
+    dg <- ask
+    forM_ (neighbours x dg) $ \n -> do
+        d <- isDirty n
+        when d $ walk n
+
+    -- Once all dirty neighbours are done, we're safe to go
+    tell [x]
+    modify $ S.delete x
+
+
+--------------------------------------------------------------------------------
+-- | This auxiliary function checks which nodes are dirty: a node is dirty if
+-- it's out-of-date or if one of its dependencies is dirty.
+dirty :: Ord a
+      => (a -> Bool)      -- ^ Out of date?
+      -> DirectedGraph a  -- ^ Graph
+      -> Set a            -- ^ All dirty items
+dirty ood dg = S.fromList $ flip evalState M.empty $
+    filterM go $ S.toList $ nodes dg
   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
+    go x = do
+        m <- get
+        case M.lookup x m of
+            Just d  -> return d
+            Nothing -> do
+                nd <- mapM go $ neighbours x dg
+                let d = ood x || or nd
+                modify $ M.insert x d
+                return d