Added context manipulating functions and associated render functions. Also, version bump.

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