Rewrite template application

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