summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Hakyll/Core/DirectedGraph.hs87
-rw-r--r--src/Hakyll/Core/DirectedGraph/DependencySolver.hs68
-rw-r--r--src/Hakyll/Core/DirectedGraph/Internal.hs39
-rw-r--r--src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs25
4 files changed, 219 insertions, 0 deletions
diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs
new file mode 100644
index 0000000..6dc6ae5
--- /dev/null
+++ b/src/Hakyll/Core/DirectedGraph.hs
@@ -0,0 +1,87 @@
+-- | Representation of a directed graph. In Hakyll, this is used for dependency
+-- tracking.
+--
+module Hakyll.Core.DirectedGraph
+ ( DirectedGraph
+ , fromList
+ , neighbours
+ , reverse
+ , filter
+ , reachableNodes
+ ) where
+
+import Prelude hiding (reverse, filter)
+import Data.Monoid (mconcat)
+import Data.Set (Set)
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import Hakyll.Core.DirectedGraph.Internal
+
+-- | Construction of directed graphs
+--
+fromList :: Ord a
+ => [(a, Set a)] -- ^ List of (node, reachable neighbours)
+ -> DirectedGraph a -- ^ Resulting directed graph
+fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d))
+
+-- | Get a set of reachable neighbours from a directed graph
+--
+neighbours :: Ord a
+ => a -- ^ Node to get the neighbours of
+ -> DirectedGraph a -- ^ Graph to search in
+ -> Set a -- ^ Set containing the neighbours
+neighbours x = fromMaybe S.empty . fmap nodeNeighbours
+ . M.lookup x . unDirectedGraph
+
+-- | Reverse a directed graph (i.e. flip all edges)
+--
+reverse :: Ord a
+ => DirectedGraph a
+ -> DirectedGraph a
+reverse = mconcat . map reverse' . M.toList . unDirectedGraph
+ where
+ reverse' (id', Node _ neighbours') = fromList $
+ zip (S.toList neighbours') $ repeat $ S.singleton id'
+
+-- | Filter a directed graph (i.e. remove nodes based on a predicate)
+--
+filter :: Ord a
+ => (a -> Bool) -- ^ Predicate
+ -> DirectedGraph a -- ^ Graph
+ -> DirectedGraph a -- ^ Resulting graph
+filter predicate =
+ DirectedGraph . M.filterWithKey (\k _ -> predicate k) . unDirectedGraph
+
+-- | Find all reachable nodes from a given node in the directed graph
+--
+reachableNodes :: Ord a => a -> DirectedGraph a -> Set a
+reachableNodes x graph = reachable (neighbours x graph) (S.singleton x)
+ where
+ reachable next visited
+ | S.null next = visited
+ | otherwise = reachable (sanitize neighbours') (next `S.union` visited)
+ where
+ sanitize = S.filter (`S.notMember` visited)
+ neighbours' = S.unions $ map (flip neighbours graph)
+ $ S.toList $ sanitize next
+
+{-
+exampleGraph :: DirectedGraph Int
+exampleGraph = fromList
+ [ makeNode 8 [2, 4, 6]
+ , makeNode 2 [4, 3]
+ , makeNode 4 [3]
+ , makeNode 6 [4]
+ , makeNode 3 []
+ ]
+ where
+ makeNode tag deps = (tag, S.fromList deps)
+
+cyclic :: DirectedGraph Int
+cyclic = fromList
+ [ (1, S.fromList [2])
+ , (2, S.fromList [1, 3])
+ ]
+-}
diff --git a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs
new file mode 100644
index 0000000..dce59e0
--- /dev/null
+++ b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs
@@ -0,0 +1,68 @@
+-- | Given a dependency graph, this module provides a function that will
+-- generate an order in which the graph can be visited, so that all the
+-- dependencies of a given node have been visited before the node itself is
+-- visited.
+--
+module Hakyll.Core.DirectedGraph.DependencySolver
+ ( solveDependencies
+ ) where
+
+import Prelude
+import qualified Prelude as P
+import Data.Set (Set)
+import Data.Maybe (catMaybes)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import Hakyll.Core.DirectedGraph
+import qualified Hakyll.Core.DirectedGraph as DG
+import Hakyll.Core.DirectedGraph.Internal
+
+-- | Solve a dependency graph. This function returns an order to run the
+-- different nodes
+--
+solveDependencies :: Ord a
+ => DirectedGraph a -- ^ Graph
+ -> [a] -- ^ Resulting plan
+solveDependencies = P.reverse . order [] [] S.empty
+
+-- | Produce a reversed order using a stack
+--
+order :: Ord a
+ => [a] -- ^ Temporary result
+ -> [Node a] -- ^ Backtrace stack
+ -> Set a -- ^ Items in the stack
+ -> DirectedGraph a -- ^ Graph
+ -> [a] -- ^ Ordered result
+order temp stack set graph@(DirectedGraph graph')
+ -- Empty graph - return our current result
+ | M.null graph' = temp
+ | otherwise = case stack of
+
+ -- Empty stack - pick a node, and add it to the stack
+ [] ->
+ let (tag, node) = M.findMin graph'
+ in order temp (node : stack) (S.insert tag set) graph
+
+ -- At least one item on the stack - continue using this item
+ (node : stackTail) ->
+ -- Check which dependencies are still in the graph
+ let tag = nodeTag node
+ deps = S.toList $ nodeNeighbours node
+ unsatisfied = catMaybes $ map (flip M.lookup graph') deps
+ in case unsatisfied of
+
+ -- All dependencies for node are satisfied, we can return it and
+ -- remove it from the graph
+ [] -> order (tag : temp) stackTail (S.delete tag set)
+ (DG.filter (== tag) graph)
+
+ -- There is at least one dependency left. We need to solve that
+ -- one first...
+ (dep : _) -> if (nodeTag dep) `S.member` set
+ -- The dependency is already in our stack - cycle detected!
+ then error "order: Cycle detected!" -- TODO: Dump cycle
+ -- Continue with the dependency
+ else order temp (dep : node : stackTail)
+ (S.insert (nodeTag dep) set)
+ graph
diff --git a/src/Hakyll/Core/DirectedGraph/Internal.hs b/src/Hakyll/Core/DirectedGraph/Internal.hs
new file mode 100644
index 0000000..9890fc0
--- /dev/null
+++ b/src/Hakyll/Core/DirectedGraph/Internal.hs
@@ -0,0 +1,39 @@
+-- | Internal structure of the DirectedGraph type. Not exported in the library.
+--
+module Hakyll.Core.DirectedGraph.Internal
+ ( Node (..)
+ , DirectedGraph (..)
+ ) where
+
+import Prelude hiding (reverse, filter)
+import Data.Monoid (Monoid, mempty, mappend)
+import Data.Set (Set)
+import Data.Map (Map)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+-- | A node in the directed graph
+--
+data Node a = Node
+ { nodeTag :: a -- ^ Tag identifying the node
+ , nodeNeighbours :: (Set a) -- ^ Edges starting at this node
+ } deriving (Show)
+
+-- | Append two nodes. Useful for joining graphs.
+--
+appendNodes :: Ord a => Node a -> Node a -> Node a
+appendNodes (Node t1 n1) (Node t2 n2)
+ | t1 /= t2 = error "appendNodes: Appending differently tagged nodes"
+ | otherwise = Node t1 (n1 `S.union` n2)
+
+-- | Type used to represent a directed graph
+--
+newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a (Node a)}
+ deriving (Show)
+
+-- | Allow users to concatenate different graphs
+--
+instance Ord a => Monoid (DirectedGraph a) where
+ mempty = DirectedGraph M.empty
+ mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $
+ M.unionWith appendNodes m1 m2
diff --git a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs
new file mode 100644
index 0000000..a3bc57a
--- /dev/null
+++ b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs
@@ -0,0 +1,25 @@
+-- | Module exporting a function that works as a filter on a dependency graph.
+-- Given a list of obsolete nodes, this filter will reduce the graph so it only
+-- contains obsolete nodes and nodes that depend (directly or indirectly) on
+-- obsolete nodes.
+--
+module Hakyll.Core.DirectedGraph.ObsoleteFilter
+ ( obsoleteFilter
+ ) where
+
+import qualified Data.Set as S
+
+import Hakyll.Core.DirectedGraph
+import qualified Hakyll.Core.DirectedGraph as DG
+
+-- | Given a list of obsolete items, filter the dependency graph so it only
+-- contains these items
+--
+obsoleteFilter :: Ord a
+ => [a] -- ^ List of obsolete items
+ -> DirectedGraph a -- ^ Dependency graph
+ -> DirectedGraph a -- ^ Resulting dependency graph
+obsoleteFilter obsolete graph =
+ let reversed = DG.reverse graph
+ allObsolete = S.unions $ map (flip reachableNodes reversed) obsolete
+ in DG.filter (`S.member` allObsolete) graph