diff options
| -rw-r--r-- | src/Hakyll/Web/Template.hs | 21 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal.hs | 12 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Read.hs | 74 | ||||
| -rw-r--r-- | tests/data/template.html | 2 | ||||
| -rw-r--r-- | tests/data/template.html.out | 2 |
5 files changed, 69 insertions, 42 deletions
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..4ef5f2f 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, guard) +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 diff --git a/tests/data/template.html b/tests/data/template.html index 153303c..a8d78eb 100644 --- a/tests/data/template.html +++ b/tests/data/template.html @@ -1,5 +1,5 @@ <div> I'm so rich I have $$3. - $echo test!$ + $echo test$ $body$ </div> diff --git a/tests/data/template.html.out b/tests/data/template.html.out index 07b0851..8bd1879 100644 --- a/tests/data/template.html.out +++ b/tests/data/template.html.out @@ -1,5 +1,5 @@ <div> I'm so rich I have $3. - test! + test <p>This is an example.</p> </div> |