summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Text/Hakyll/Context.hs47
-rw-r--r--src/Text/Hakyll/Page.hs12
-rw-r--r--src/Text/Hakyll/Render.hs42
3 files changed, 83 insertions, 18 deletions
diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs
new file mode 100644
index 0000000..e3069b5
--- /dev/null
+++ b/src/Text/Hakyll/Context.hs
@@ -0,0 +1,47 @@
+-- | Module containing various functions to manipulate contexts.
+module Text.Hakyll.Context
+ ( ContextManipulation
+ , renderValue
+ , renderDate
+ ) where
+
+import qualified Data.Map as M
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import System.Locale (defaultTimeLocale)
+import System.FilePath (takeFileName)
+import Text.Regex (subRegex, mkRegex)
+import Text.Template (Context)
+import Data.Time.Format (parseTime, formatTime)
+import Data.Time.Clock (UTCTime)
+import Data.Maybe (fromMaybe)
+
+-- | Type for context manipulating functions.
+type ContextManipulation = Context -> Context
+
+-- | Do something with a value of a context.
+renderValue :: String -- ^ Key of which the value should be copied.
+ -> String -- ^ Key the value should be copied to.
+ -> (B.ByteString -> B.ByteString) -- ^ Function to apply on the value.
+ -> ContextManipulation
+renderValue src dst f context = case M.lookup (B.pack src) context of
+ Nothing -> context
+ (Just value) -> M.insert (B.pack dst) (f value) context
+
+-- | When the context has a key called `path` in a `yyyy-mm-dd-title.extension`
+-- format (default for pages), this function can render the date.
+renderDate :: String -- ^ Key in which the rendered date should be placed.
+ -> String -- ^ Format to use on the date.
+ -> String -- ^ Default value when the date cannot be parsed.
+ -> ContextManipulation
+renderDate key format defaultValue context =
+ M.insert (B.pack key) (B.pack value) context
+ where value = fromMaybe defaultValue pretty
+ pretty = do filePath <- M.lookup (B.pack "path") context
+ let dateString = subRegex (mkRegex "^([0-9]*-[0-9]*-[0-9]*).*")
+ (takeFileName $ B.unpack filePath)
+ "\\1"
+ time <- parseTime defaultTimeLocale
+ "%Y-%m-%d"
+ dateString :: Maybe UTCTime
+ return $ formatTime defaultTimeLocale format time
diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs
index 25ba880..7baf31b 100644
--- a/src/Text/Hakyll/Page.hs
+++ b/src/Text/Hakyll/Page.hs
@@ -2,7 +2,6 @@ module Text.Hakyll.Page
( Page
, fromContext
, getValue
- , copyValueWith
, getBody
, readPage
, writePage
@@ -36,17 +35,6 @@ fromContext = Page
getValue :: String -> Page -> B.ByteString
getValue str (Page page) = fromMaybe B.empty $ M.lookup (B.pack str) page
--- | Do something with a value of the page.
-copyValueWith :: String -- ^ Key of which the value should be copied.
- -> String -- ^ Key the value should be copied to.
- -> (B.ByteString -> B.ByteString) -- ^ Function to apply on the value.
- -> Page -- ^ Page on which to apply this modification.
- -> Page -- ^ Result.
-copyValueWith src dst f p@(Page page) = case M.lookup (B.pack src) page of
- Nothing -> p
- (Just value) -> Page $ M.insert (B.pack dst) (f value) page
-
-
-- | Auxiliary function to pack a pair.
packPair :: (String, String) -> (B.ByteString, B.ByteString)
packPair (a, b) = (B.pack a, B.pack b)
diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs
index 7420d1c..ac529e8 100644
--- a/src/Text/Hakyll/Render.hs
+++ b/src/Text/Hakyll/Render.hs
@@ -1,8 +1,11 @@
module Text.Hakyll.Render
( depends
, render
+ , renderWith
, renderAndConcat
+ , renderAndConcatWith
, renderChain
+ , renderChainWith
, static
, css
) where
@@ -15,6 +18,7 @@ import Control.Monad (unless, liftM, foldM)
import System.Directory (copyFile)
import System.IO
+import Text.Hakyll.Context (ContextManipulation)
import Text.Hakyll.Page
import Text.Hakyll.Renderable
import Text.Hakyll.File
@@ -34,21 +38,41 @@ render :: Renderable a
=> FilePath -- ^ Template to use for rendering.
-> a -- ^ Renderable object to render with given template.
-> IO Page -- ^ The body of the result will contain the render.
-render templatePath renderable = do
+render = renderWith id
+
+-- | Render to a Page. This function allows you to manipulate the context
+-- first.
+renderWith :: Renderable a
+ => ContextManipulation -- ^ Manipulation to apply on the context.
+ -> FilePath -- ^ Template to use for rendering.
+ -> a -- ^ Renderable object to render with given template.
+ -> IO Page -- ^ The body of the result will contain the render.
+renderWith manipulation templatePath renderable = do
handle <- openFile templatePath ReadMode
templateString <- liftM B.pack $ hGetContents handle
seq templateString $ hClose handle
- context <- toContext renderable
+ context <- liftM manipulation $ toContext renderable
let body = substitute templateString context
return $ fromContext (M.insert (B.pack "body") body context)
-- | Render each renderable with the given template, then concatenate the
-- result.
renderAndConcat :: Renderable a => FilePath -> [a] -> IO B.ByteString
-renderAndConcat templatePath renderables = foldM concatRender' B.empty renderables
+renderAndConcat = renderAndConcatWith id
+
+-- | Render each renderable with the given template, then concatenate the
+-- result. This function allows you to specify a "ContextManipulation" to
+-- apply on every "Renderable".
+renderAndConcatWith :: Renderable a
+ => ContextManipulation
+ -> FilePath
+ -> [a]
+ -> IO B.ByteString
+renderAndConcatWith manipulation templatePath renderables =
+ foldM concatRender' B.empty renderables
where concatRender' :: Renderable a => B.ByteString -> a -> IO B.ByteString
concatRender' chunk renderable = do
- rendered <- render templatePath renderable
+ rendered <- renderWith manipulation templatePath renderable
let body = getBody rendered
return $ B.append chunk $ body
@@ -56,9 +80,15 @@ renderAndConcat templatePath renderables = foldM concatRender' B.empty renderabl
-- also write the result to the site destination. This is the preferred way
-- to do general rendering.
renderChain :: Renderable a => [FilePath] -> a -> IO ()
-renderChain templates renderable =
+renderChain = renderChainWith id
+
+-- | A more custom render chain that allows you to specify a
+-- "ContextManipulation" which to apply on the context when it is read first.
+renderChainWith :: Renderable a
+ => ContextManipulation -> [FilePath] -> a -> IO ()
+renderChainWith manipulation templates renderable =
depends (getURL renderable) (getDependencies renderable ++ templates) $
- do initialPage <- toContext renderable
+ do initialPage <- liftM manipulation $ toContext renderable
result <- foldM (flip render) (fromContext initialPage) templates
writePage result