summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Hakyll/Core/DirectedGraph.hs31
-rw-r--r--src/Hakyll/Core/DirectedGraph/Dot.hs14
-rw-r--r--src/Hakyll/Web/Template/Context.hs50
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