Merge remote-tracking branch 'sphynx/master'

4 files changed, 75 insertions, 40 deletions

diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index bf384bf..fbb7528 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -2,6 +2,8 @@
 -- | Internally used compiler module
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 module Hakyll.Core.Compiler.Internal
     ( -- * Types
       CompilerRead (..)
@@ -29,6 +31,7 @@ import           Control.Applicative            (Alternative (..),
                                                  Applicative (..), (<$>))
 import           Control.Exception              (SomeException, handle)
 import           Control.Monad                  (forM_)
+import           Control.Monad.Error
 import           Data.Monoid                    (Monoid (..))
 import           Data.Set                       (Set)
 import qualified Data.Set                       as S
@@ -146,6 +149,11 @@ instance MonadMetadata Compiler where
     getMetadata = compilerGetMetadata
     getMatches  = compilerGetMatches
 
+--------------------------------------------------------------------------------
+instance MonadError [String] Compiler where
+  throwError = compilerThrow
+  catchError = compilerCatch
+
 
 --------------------------------------------------------------------------------
 runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index 07a8ff3..371ccef 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -44,7 +44,8 @@ module Hakyll.Web.Template
 
 
 --------------------------------------------------------------------------------
-import           Control.Monad                (forM, liftM)
+import           Control.Monad                (liftM)
+import           Control.Monad.Error          (MonadError(..))
 import           Data.Monoid                  (mappend)
 import           Prelude                      hiding (id)
 
@@ -112,11 +113,17 @@ applyAsTemplate context item =
 
 --------------------------------------------------------------------------------
 -- | Overloaded apply template function to work in an arbitrary Monad.
-applyTemplateWith :: Monad m
+applyTemplateWith :: MonadError e m
                   => (String -> a -> m String)
                   -> Template -> a -> m String
-applyTemplateWith context tpl x = liftM concat $
-    forM (unTemplate tpl) $ \e -> case e of
-        Chunk c -> return c
-        Escaped -> return "$"
-        Key k   -> context k x
+applyTemplateWith context tpl x = go tpl where
+
+    go = liftM concat . mapM applyElem . unTemplate
+
+    applyElem (Chunk c)   = return c
+    applyElem Escaped     = return "$"
+    applyElem (Key k)     = context k x
+    applyElem (If k t mf) = (context k x >> go t) `catchError` handler where
+      handler _ = case mf of
+        Nothing -> return ""
+        Just f  -> go f
diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs
index e264731..0bd999e 100644
--- a/src/Hakyll/Web/Template/Internal.hs
+++ b/src/Hakyll/Web/Template/Internal.hs
@@ -9,7 +9,7 @@ module Hakyll.Web.Template.Internal
 
 
 --------------------------------------------------------------------------------
-import           Control.Applicative  ((<$>))
+import           Control.Applicative  (pure, (<$>), (<*>))
 import           Data.Binary          (Binary, get, getWord8, put, putWord8)
 import           Data.Typeable        (Typeable)
 
@@ -38,18 +38,20 @@ data TemplateElement
     = Chunk String
     | Key String
     | Escaped
+    | If String Template (Maybe Template) -- key, then branch, else branch
     deriving (Show, Eq, Typeable)
 
-
 --------------------------------------------------------------------------------
 instance Binary TemplateElement where
-    put (Chunk string)    = putWord8 0 >> put string
-    put (Key key)  = putWord8 1 >> put key
+    put (Chunk string) = putWord8 0 >> put string
+    put (Key key) = putWord8 1 >> put key
     put (Escaped) = putWord8 2
+    put (If key t f) = putWord8 3 >> put key >> put t >> put f
 
     get = getWord8 >>= \tag -> case tag of
             0 -> Chunk <$> get
             1 -> Key   <$> get
-            2 -> return Escaped
+            2 -> pure Escaped
+            3 -> If <$> get <*> get <*> get
             _ -> error $  "Hakyll.Web.Template.Internal: "
                        ++ "Error reading cached template"
diff --git a/src/Hakyll/Web/Template/Read.hs b/src/Hakyll/Web/Template/Read.hs
index 7dfe003..9504f0b 100644
--- a/src/Hakyll/Web/Template/Read.hs
+++ b/src/Hakyll/Web/Template/Read.hs
@@ -4,38 +4,56 @@ module Hakyll.Web.Template.Read
     ( readTemplate
     ) where
 
-
 --------------------------------------------------------------------------------
-import           Data.List                    (isPrefixOf)
-
+import           Control.Applicative          ((<$>), (<$), (<*>))
+import           Control.Monad                (void, mzero)
+import           Text.Parsec
+import           Text.Parsec.String
 
 --------------------------------------------------------------------------------
 import           Hakyll.Web.Template.Internal
 
-
 --------------------------------------------------------------------------------
--- | Construct a @Template@ from a string.
+
 readTemplate :: String -> Template
-readTemplate = Template . readTemplate'
-  where
-    readTemplate' [] = []
-    readTemplate' string
-        | "$$" `isPrefixOf` string =
-            Escaped : readTemplate' (drop 2 string)
-        | "$" `isPrefixOf` string =
-            case readKey (drop 1 string) of
-                Just (key, rest) -> Key key : readTemplate' rest
-                Nothing          -> Chunk "$" : readTemplate' (drop 1 string)
-        | otherwise =
-            let (chunk, rest) = break (== '$') string
-            in Chunk chunk : readTemplate' rest
-
-    -- Parse an key into (key, rest) if it's valid, and return
-    -- Nothing otherwise
-    readKey string =
-        let (key, rest) = span validKeyChar string
-        in if not (null key) && "$" `isPrefixOf` rest
-            then Just (key, drop 1 rest)
-            else Nothing
-
-    validKeyChar x = x `notElem` ['$', '\n', '\r']
+readTemplate input =
+  case parse template "" input of
+    Left err -> error $ "Cannot parse template: " ++ show err
+    Right t -> t
+
+template :: Parser Template
+template = Template <$>
+  (many1 $ chunk <|> escaped <|> conditional <|> key)
+
+chunk :: Parser TemplateElement
+chunk = Chunk <$> (many1 $ noneOf "$")
+
+escaped :: Parser TemplateElement
+escaped = Escaped <$ (try $ string "$$")
+
+conditional :: Parser TemplateElement
+conditional = try $ do
+  void $ string "$if("
+  i <- ident
+  void $ string ")$"
+  thenBranch <- template
+  elseBranch <- optionMaybe $ try (string "$else$") >> template
+  void $ string "$endif$"
+  return $ If i thenBranch elseBranch
+
+ident :: Parser String
+ident = do
+  i <- (:) <$> letter <*> (many $ alphaNum <|> oneOf " _-.")
+  if i `elem` reserved
+     then mzero
+     else return i
+
+reserved :: [String]
+reserved = ["if", "else","endif"]
+
+key :: Parser TemplateElement
+key = try $ do
+  void $ char '$'
+  k <- ident
+  void $ char '$'
+  return $ Key k