From 1fdffc6a19ffad86a3f00408a72d19082fc5c6db Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 3 Jan 2010 12:21:15 +0100 Subject: Added context manipulating functions and associated render functions. Also, version bump. --- src/Text/Hakyll/Context.hs | 47 ++++++++++++++++++++++++++++++++++++++++++++++ src/Text/Hakyll/Page.hs | 12 ------------ src/Text/Hakyll/Render.hs | 42 +++++++++++++++++++++++++++++++++++------ 3 files changed, 83 insertions(+), 18 deletions(-) create mode 100644 src/Text/Hakyll/Context.hs (limited to 'src/Text') 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 -- cgit v1.2.3