diff options
| -rw-r--r-- | src/Hakyll/Core/DependencyAnalyzer.hs | 155 | ||||
| -rw-r--r-- | src/Hakyll/Core/DirectedGraph.hs | 8 | ||||
| -rw-r--r-- | tests/Hakyll/Core/DependencyAnalyzer/Tests.hs | 70 | ||||
| -rw-r--r-- | tests/TestSuite.hs | 3 |
4 files changed, 236 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 diff --git a/tests/Hakyll/Core/DependencyAnalyzer/Tests.hs b/tests/Hakyll/Core/DependencyAnalyzer/Tests.hs new file mode 100644 index 0000000..891fa98 --- /dev/null +++ b/tests/Hakyll/Core/DependencyAnalyzer/Tests.hs @@ -0,0 +1,70 @@ +module Hakyll.Core.DependencyAnalyzer.Tests where + +import Control.Arrow (second) +import qualified Data.Set as S +import Data.Monoid (mempty) + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Hakyll.Core.DirectedGraph +import Hakyll.Core.DependencyAnalyzer + +tests :: [Test] +tests = + [ testCase "step [1]" step1 + , testCase "step [2]" step2 + ] + +step1 :: Assertion +step1 = Just (S.fromList [1, 2, 5, 6, 7, 8, 9]) @?= + stepAll (makeDependencyAnalyzer graph isOutOfDate prev) + where + node = curry $ second S.fromList + + graph = fromList + [ node (8 :: Int) [2, 4, 6] + , node 2 [4, 3] + , node 4 [3] + , node 6 [4] + , node 3 [] + , node 9 [5] + , node 5 [7] + , node 1 [7] + , node 7 [] + ] + + prev = fromList + [ node 8 [2, 4, 6] + , node 2 [4, 3] + , node 4 [3] + , node 6 [4] + , node 3 [] + , node 9 [5] + , node 5 [7] + , node 1 [7] + , node 7 [8] + ] + + isOutOfDate = (`elem` [5, 2, 6]) + +step2 :: Assertion +step2 = Nothing @?= stepAll (makeDependencyAnalyzer graph isOutOfDate mempty) + where + node = curry $ second S.fromList + + -- Cycle: 4 -> 7 -> 5 -> 9 -> 4 + graph = fromList + [ node (1 :: Int) [6] + , node 2 [3] + , node 3 [] + , node 4 [1, 7, 8] + , node 5 [9] + , node 6 [3] + , node 7 [5] + , node 8 [2] + , node 9 [4] + ] + + isOutOfDate = const True diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index cb6113d..ba77139 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -3,6 +3,7 @@ module TestSuite where import Test.Framework (defaultMain, testGroup) import qualified Hakyll.Core.DirectedGraph.Tests +import qualified Hakyll.Core.DependencyAnalyzer.Tests import qualified Hakyll.Core.Identifier.Tests import qualified Hakyll.Core.Routes.Tests import qualified Hakyll.Web.Page.Tests @@ -14,6 +15,8 @@ main :: IO () main = defaultMain [ testGroup "Hakyll.Core.DirectedGraph.Tests" Hakyll.Core.DirectedGraph.Tests.tests + , testGroup "Hakyll.Core.DependencyAnalyzer.Tests" + Hakyll.Core.DependencyAnalyzer.Tests.tests , testGroup "Hakyll.Core.Identifier.Tests" Hakyll.Core.Identifier.Tests.tests , testGroup "Hakyll.Core.Routes.Tests" |