summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJasper Van der Jeugt <m@jaspervdj.be>2012-11-09 18:13:51 +0100
committerJasper Van der Jeugt <m@jaspervdj.be>2012-11-09 18:13:51 +0100
commit4cb6f9241435fae7a23a7f9fbbdab99e65285eff (patch)
tree462f951e02579518958e15accb95be5d6d11abba /src
parent2834fd94945ad20bf19c39957cddfdf858c0ba22 (diff)
downloadhakyll-4cb6f9241435fae7a23a7f9fbbdab99e65285eff.tar.gz
Rewrite template application
Diffstat (limited to 'src')
-rw-r--r--src/Hakyll/Core/Compiler.hs7
-rw-r--r--src/Hakyll/Core/Compiler/Internal.hs6
-rw-r--r--src/Hakyll/Core/Util/Arrow.hs37
-rw-r--r--src/Hakyll/Web/Feed.hs4
-rw-r--r--src/Hakyll/Web/Page/List.hs4
-rw-r--r--src/Hakyll/Web/Tags.hs6
-rw-r--r--src/Hakyll/Web/Template.hs100
7 files changed, 92 insertions, 72 deletions
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
--------------------------------------------------------------------------------
@@ -139,6 +140,11 @@ instance ArrowChoice Compiler where
--------------------------------------------------------------------------------
+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
-> Identifier () -- ^ Target identifier
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 @@
-- > <a href="/about.html"> About
-- > <a href="/code.html"> 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