Add directed graph modules

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