diff options
| -rw-r--r-- | src/Hakyll/Core/DirectedGraph.hs | 87 | ||||
| -rw-r--r-- | src/Hakyll/Core/DirectedGraph/DependencySolver.hs | 68 | ||||
| -rw-r--r-- | src/Hakyll/Core/DirectedGraph/Internal.hs | 39 | ||||
| -rw-r--r-- | src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs | 25 |
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 |