From 4cb6f9241435fae7a23a7f9fbbdab99e65285eff Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 9 Nov 2012 18:13:51 +0100 Subject: Rewrite template application --- src/Hakyll/Core/Compiler.hs | 7 --- src/Hakyll/Core/Compiler/Internal.hs | 6 +++ src/Hakyll/Core/Util/Arrow.hs | 37 +++++++++---- src/Hakyll/Web/Feed.hs | 4 +- src/Hakyll/Web/Page/List.hs | 4 +- src/Hakyll/Web/Tags.hs | 6 +-- src/Hakyll/Web/Template.hs | 100 +++++++++++++++++++---------------- 7 files changed, 92 insertions(+), 72 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index e1eab79..840f3bd 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -108,7 +108,6 @@ module Hakyll.Core.Compiler , cached , unsafeCompiler , traceShowCompiler - , mapCompiler , timedCompiler , byPattern , byExtension @@ -328,12 +327,6 @@ traceShowCompiler = fromJob $ \x -> CompilerM $ do report logger $ show x return x --- | Map over a compiler --- -mapCompiler :: Compiler a b - -> Compiler [a] [b] -mapCompiler (Compiler d j) = Compiler d $ mapM j - -- | Log and time a compiler -- timedCompiler :: String -- ^ Message diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index acdfe80..2a3342f 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -38,6 +38,7 @@ import Hakyll.Core.Logger import Hakyll.Core.ResourceProvider import Hakyll.Core.Routes import Hakyll.Core.Store +import Hakyll.Core.Util.Arrow -------------------------------------------------------------------------------- @@ -138,6 +139,11 @@ instance ArrowChoice Compiler where Right r -> Right <$> return r +-------------------------------------------------------------------------------- +instance ArrowMap Compiler where + mapA (Compiler d j) = Compiler d $ mapM j + + -------------------------------------------------------------------------------- -- | Run a compiler, yielding the resulting target runCompilerJob :: Compiler () a -- ^ Compiler to run diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs index f46d083..96a5e09 100644 --- a/src/Hakyll/Core/Util/Arrow.hs +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -1,25 +1,40 @@ +-------------------------------------------------------------------------------- -- | Various arrow utility functions --- module Hakyll.Core.Util.Arrow - ( constA + ( ArrowMap (..) + , constA , sequenceA , unitA ) where -import Control.Arrow (Arrow, (&&&), arr, (>>^)) -constA :: Arrow a - => c - -> a b c +-------------------------------------------------------------------------------- +import Control.Arrow (Arrow, ArrowChoice, arr, (&&&), (>>^)) + + +-------------------------------------------------------------------------------- +-- | Additional arrow typeclass for performance reasons. +class ArrowChoice a => ArrowMap a where + mapA :: a b c -> a [b] [c] + + +-------------------------------------------------------------------------------- +instance ArrowMap (->) where + mapA = map + + +-------------------------------------------------------------------------------- +constA :: Arrow a => c -> a b c constA = arr . const -sequenceA :: Arrow a - => [a b c] - -> a b [c] + +-------------------------------------------------------------------------------- +sequenceA :: Arrow a => [a b c] -> a b [c] sequenceA = foldr reduce $ constA [] where reduce xa la = xa &&& la >>^ arr (uncurry (:)) -unitA :: Arrow a - => a b () + +-------------------------------------------------------------------------------- +unitA :: Arrow a => a b () unitA = constA () diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index f2f3342..218f28c 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -62,7 +62,7 @@ createFeed :: Template -- ^ Feed template -> [Page String] -- ^ Items to include -> String -- ^ Resulting feed createFeed feedTemplate itemTemplate url configuration items = - pageBody $ applyTemplate feedTemplate + pageBody $ applyTemplateToPage feedTemplate $ trySetField "updated" updated $ trySetField "title" (feedTitle configuration) $ trySetField "description" (feedDescription configuration) @@ -73,7 +73,7 @@ createFeed feedTemplate itemTemplate url configuration items = $ fromBody body where -- Preprocess items - items' = flip map items $ applyTemplate itemTemplate + items' = flip map items $ applyTemplateToPage itemTemplate . trySetField "root" (feedRoot configuration) -- Body: concatenated items diff --git a/src/Hakyll/Web/Page/List.hs b/src/Hakyll/Web/Page/List.hs index 1edb250..24721e7 100644 --- a/src/Hakyll/Web/Page/List.hs +++ b/src/Hakyll/Web/Page/List.hs @@ -55,8 +55,8 @@ pageListCompiler sort template = -- applyTemplateToList :: Identifier Template -> Compiler [Page String] [Page String] -applyTemplateToList identifier = - require identifier $ \posts template -> map (applyTemplate template) posts +applyTemplateToList identifier = require identifier $ + \posts template -> map (applyTemplateToPage template) posts -- | Concatenate the bodies of a page list -- diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 42612a7..4ea2ca0 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -65,6 +65,7 @@ import Hakyll.Web.Urls import Hakyll.Core.Writable import Hakyll.Core.Identifier import Hakyll.Core.Compiler +import Hakyll.Core.Util.Arrow import Hakyll.Core.Util.String -- | Data about tags @@ -128,8 +129,7 @@ renderTags :: (String -> Identifier (Page a)) -- ^ Tag cloud renderer renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do -- In tags' we create a list: [((tag, route), count)] - tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length) - -< tags + tags' <- mapA ((id &&& (getRouteFor <<^ makeUrl)) *** arr length) -< tags let -- Absolute frequencies of the pages freqs = map snd tags' @@ -195,7 +195,7 @@ renderTagsFieldWith tags destination makeUrl = -- Compiler creating a comma-separated HTML string for a list of tags renderTags' :: Compiler [String] String renderTags' = arr (map $ id &&& makeUrl) - >>> mapCompiler (id *** getRouteFor) + >>> mapA (id *** getRouteFor) >>> arr (map $ uncurry renderLink) >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes) diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 6b2f915..5b7256a 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -58,66 +58,78 @@ -- > About -- > Code -- > #{body} --- +{-# LANGUAGE Arrows #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template ( Template , applyTemplate - , applyTemplateWith + , applyTemplateToPage , applySelf , templateCompiler , templateCompilerWith , applyTemplateCompiler - , applyTemplateCompilerWith ) where -import Control.Arrow -import Data.Maybe (fromMaybe) -import System.FilePath (takeExtension) -import qualified Data.Map as M -import Text.Hamlet (HamletSettings, defaultHamletSettings) +-------------------------------------------------------------------------------- +import Control.Arrow +import Control.Category (id) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Prelude hiding (id) +import System.FilePath (takeExtension) +import Text.Hamlet (HamletSettings, + defaultHamletSettings) -import Hakyll.Core.Compiler -import Hakyll.Core.Identifier -import Hakyll.Web.Template.Internal -import Hakyll.Web.Template.Read -import Hakyll.Web.Page.Internal +-------------------------------------------------------------------------------- +import Hakyll.Core.Compiler +import Hakyll.Core.Identifier +import Hakyll.Core.Util.Arrow +import Hakyll.Web.Page.Internal +import Hakyll.Web.Template.Internal +import Hakyll.Web.Template.Read --- | Substitutes @$identifiers@ in the given @Template@ by values from the given --- "Page". When a key is not found, it is left as it is. --- -applyTemplate :: Template -> Page String -> Page String -applyTemplate = applyTemplateWith defaultMissingHandler --- | Default solution if a key is missing: render it again -defaultMissingHandler :: String -> String -defaultMissingHandler k = "$" ++ k ++ "$" +-------------------------------------------------------------------------------- +applyTemplate :: forall a b. (ArrowChoice a, ArrowMap a) + => a (String, b) String + -> a (Template, b) String +applyTemplate field = + arr (\(tpl, x) -> [(e, x) | e <- unTemplate tpl]) >>> + mapA applyElement >>^ concat + where + applyElement :: a (TemplateElement, b) String + applyElement = unElement >>> (id ||| field) --- | A version of 'applyTemplate' which allows you to give a fallback option, --- which can produce the value for a key if it is missing. --- -applyTemplateWith :: (String -> String) -- ^ Fallback if key missing - -> Template -- ^ Template to apply - -> Page String -- ^ Input page - -> Page String -- ^ Resulting page -applyTemplateWith missing template page = - fmap (const $ substitute =<< unTemplate template) page + unElement :: a (TemplateElement, b) (Either String (String, b)) + unElement = arr $ \(e, x) -> case e of + Chunk c -> Left c + Escaped -> Left "$" + Key k -> Right (k, x) + + +-------------------------------------------------------------------------------- +-- | TODO: Remove +applyTemplateToPage :: Template -> Page String -> Page String +applyTemplateToPage tpl page = + fmap (const $ applyTemplate pageField (tpl, page)) page where - map' = toMap page - substitute (Chunk chunk) = chunk - substitute (Key key) = fromMaybe (missing key) $ M.lookup key map' - substitute (Escaped) = "$" + pageField (k, p) = fromMaybe ("$" ++ k ++ "$") $ M.lookup k $ toMap p +{-# DEPRECATED applyTemplateToPage "Use applyTemplate" #-} + +-------------------------------------------------------------------------------- -- | Apply a page as it's own template. This is often very useful to fill in -- certain keys like @$root@ and @$url@. --- applySelf :: Page String -> Page String -applySelf page = applyTemplate (readTemplate $ pageBody page) page +applySelf page = applyTemplateToPage (readTemplate $ pageBody page) page +{-# DEPRECATED applySelf "Use applyTemplate" #-} + +-------------------------------------------------------------------------------- -- | Read a template. If the extension of the file we're compiling is -- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed -- as such. --- templateCompiler :: Compiler () Template templateCompiler = templateCompilerWith defaultHamletSettings @@ -135,15 +147,9 @@ templateCompilerWith settings = -- Hakyll template else readTemplate string + +-------------------------------------------------------------------------------- applyTemplateCompiler :: Identifier Template -- ^ Template -> Compiler (Page String) (Page String) -- ^ Compiler -applyTemplateCompiler = applyTemplateCompilerWith defaultMissingHandler - --- | A version of 'applyTemplateCompiler' which allows you to pass a function --- which is called for a key when it is missing. --- -applyTemplateCompilerWith :: (String -> String) - -> Identifier Template - -> Compiler (Page String) (Page String) -applyTemplateCompilerWith missing identifier = - require identifier (flip $ applyTemplateWith missing) +applyTemplateCompiler identifier = require identifier $ + flip applyTemplateToPage -- cgit v1.2.3