diff options
| -rw-r--r-- | src/Hakyll/Core/DirectedGraph.hs | 31 | ||||
| -rw-r--r-- | src/Hakyll/Core/DirectedGraph/Dot.hs | 14 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Context.hs | 50 |
3 files changed, 79 insertions, 16 deletions
diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs index ff9121a..66cb84d 100644 --- a/src/Hakyll/Core/DirectedGraph.hs +++ b/src/Hakyll/Core/DirectedGraph.hs @@ -1,6 +1,6 @@ +-------------------------------------------------------------------------------- -- | Representation of a directed graph. In Hakyll, this is used for dependency -- tracking. --- module Hakyll.Core.DirectedGraph ( DirectedGraph , fromList @@ -12,6 +12,8 @@ module Hakyll.Core.DirectedGraph , reachableNodes ) where + +-------------------------------------------------------------------------------- import Prelude hiding (reverse) import Control.Arrow (second) import Data.Monoid (mconcat) @@ -20,47 +22,55 @@ 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)) + +-------------------------------------------------------------------------------- -- | 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 => a -- ^ Node to check for -> DirectedGraph a -- ^ Directed graph to check in -> Bool -- ^ If the node lies in the graph member n = M.member n . unDirectedGraph + +-------------------------------------------------------------------------------- -- | Get all nodes in the graph --- nodes :: Ord a => DirectedGraph a -- ^ Graph to get the nodes from -> Set a -- ^ All nodes in the graph nodes = M.keysSet . unDirectedGraph + +-------------------------------------------------------------------------------- -- | 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 +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 @@ -69,8 +79,9 @@ reverse = mconcat . map reverse' . M.toList . unDirectedGraph reverse' (id', Node _ neighbours') = fromList $ zip (S.toList neighbours') $ repeat $ S.singleton id' + +-------------------------------------------------------------------------------- -- | Find all reachable nodes from a given set of nodes in the directed graph --- reachableNodes :: Ord a => Set a -> DirectedGraph a -> Set a reachableNodes set graph = reachable (setNeighbours set) set where diff --git a/src/Hakyll/Core/DirectedGraph/Dot.hs b/src/Hakyll/Core/DirectedGraph/Dot.hs index 58f375c..94e2444 100644 --- a/src/Hakyll/Core/DirectedGraph/Dot.hs +++ b/src/Hakyll/Core/DirectedGraph/Dot.hs @@ -1,15 +1,18 @@ +-------------------------------------------------------------------------------- -- | Dump a directed graph in dot format. Used for debugging purposes --- module Hakyll.Core.DirectedGraph.Dot ( toDot , writeDot ) where -import Hakyll.Core.DirectedGraph -import qualified Data.Set as S +-------------------------------------------------------------------------------- +import qualified Data.Set as S +import Hakyll.Core.DirectedGraph + + +-------------------------------------------------------------------------------- -- | Convert a directed graph into dot format for debugging purposes --- toDot :: Ord a => (a -> String) -- ^ Convert nodes to dot names -> DirectedGraph a -- ^ Graph to dump @@ -25,8 +28,9 @@ toDot showTag graph = unlines $ concat showEdges node = map (showEdge node) $ S.toList $ neighbours node graph showEdge x y = " \"" ++ showTag x ++ "\" -> \"" ++ showTag y ++ "\";" + +-------------------------------------------------------------------------------- -- | Write out the @.dot@ file to a given file path. See 'toDot' for more -- information. --- writeDot :: Ord a => FilePath -> (a -> String) -> DirectedGraph a -> IO () writeDot path showTag = writeFile path . toDot showTag diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs index 5ca1556..17db7ca 100644 --- a/src/Hakyll/Web/Template/Context.hs +++ b/src/Hakyll/Web/Template/Context.hs @@ -2,13 +2,26 @@ module Hakyll.Web.Template.Context ( Context , field + + , defaultContext + , bodyField + , urlField + , pathField + , categoryField + , titleField ) where -------------------------------------------------------------------------------- -import Control.Applicative (empty) +import Control.Applicative (empty, (<|>)) import Control.Arrow +import System.FilePath (takeBaseName, takeDirectory) + + +-------------------------------------------------------------------------------- import Hakyll.Core.Compiler +import Hakyll.Core.Identifier +import Hakyll.Web.Urls -------------------------------------------------------------------------------- @@ -22,3 +35,38 @@ field key value = arr checkKey >>> empty ||| value checkKey (k, x) | k == key = Left () | otherwise = Right x + + +-------------------------------------------------------------------------------- +defaultContext :: Context (Identifier String, String) +defaultContext = + bodyField "body" <|> + urlField "url" <|> + pathField "path" <|> + categoryField "category" <|> + titleField "title" + + +-------------------------------------------------------------------------------- +bodyField :: String -> Context (Identifier String, String) +bodyField key = field key $ arr snd + + +-------------------------------------------------------------------------------- +urlField :: String -> Context (Identifier a, a) +urlField key = field key $ fst ^>> getRouteFor >>^ maybe empty toUrl + + +-------------------------------------------------------------------------------- +pathField :: String -> Context (Identifier a, a) +pathField key = field key $ arr $ toFilePath . fst + + +-------------------------------------------------------------------------------- +categoryField :: String -> Context (Identifier a, a) +categoryField key = pathField key >>^ (takeBaseName . takeDirectory) + + +-------------------------------------------------------------------------------- +titleField :: String -> Context (Identifier a, a) +titleField key = pathField key >>^ takeBaseName |