path: root/src/Text/Pandoc/Templates.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
    OverloadedStrings, GeneralizedNewtypeDeriving #-}
{-
Copyright (C) 2009-2016 John MacFarlane <jgm@berkeley.edu>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- |
   Module      : Text.Pandoc.Templates
   Copyright   : Copyright (C) 2009-2016 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

A simple templating system with variable substitution and conditionals.
The following program illustrates its use:

> {-# LANGUAGE OverloadedStrings #-}
> import Data.Text
> import Data.Aeson
> import Text.Pandoc.Templates
>
> data Employee = Employee { firstName :: String
>                          , lastName  :: String
>                          , salary    :: Maybe Int }
> instance ToJSON Employee where
>   toJSON e = object [ "name" .= object [ "first" .= firstName e
>                                        , "last"  .= lastName e ]
>                     , "salary" .= salary e ]
>
> employees :: [Employee]
> employees = [ Employee "John" "Doe" Nothing
>             , Employee "Omar" "Smith" (Just 30000)
>             , Employee "Sara" "Chen" (Just 60000) ]
>
> template :: Template
> template = either error id $ compileTemplate
>   "$for(employee)$Hi, $employee.name.first$. $if(employee.salary)$You make $employee.salary$.$else$No salary data.$endif$$sep$\n$endfor$"
>
> main = putStrLn $ renderTemplate template $ object ["employee" .= employees ]

A slot for an interpolated variable is a variable name surrounded
by dollar signs.  To include a literal @$@ in your template, use
@$$@.  Variable names must begin with a letter and can contain letters,
numbers, @_@, @-@, and @.@.

The values of variables are determined by a JSON object that is
passed as a parameter to @renderTemplate@.  So, for example,
@title@ will return the value of the @title@ field, and
@employee.salary@ will return the value of the @salary@ field
of the object that is the value of the @employee@ field.

The value of a variable will be indented to the same level as the
variable.

A conditional begins with @$if(variable_name)$@ and ends with @$endif$@.
It may optionally contain an @$else$@ section.  The if section is
used if @variable_name@ has a non-null value, otherwise the else section
is used.

Conditional keywords should not be indented, or unexpected spacing
problems may occur.

The @$for$@ keyword can be used to iterate over an array.  If
the value of the associated variable is not an array, a single
iteration will be performed on its value.

You may optionally specify separators using @$sep$@, as in the
example above.

-}

module Text.Pandoc.Templates ( renderTemplate
                             , renderTemplate'
                             , TemplateTarget(..)
                             , varListToJSON
                             , compileTemplate
                             , Template
                             , getDefaultTemplate ) where

import Data.Char (isAlphaNum)
import Control.Monad (guard, when)
import Data.Aeson (ToJSON(..), Value(..))
import qualified Text.Parsec as P
import Text.Parsec.Text (Parser)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.List (intersperse)
import System.FilePath ((</>), (<.>))
import qualified Data.Map as M
import qualified Data.HashMap.Strict as H
import Data.Foldable (toList)
import qualified Control.Exception.Extensible as E (try, IOException)
import Text.Blaze.Html (Html)
import Text.Blaze.Internal (preEscapedText)
import Data.ByteString.Lazy (ByteString, fromChunks)
import Text.Pandoc.Shared (readDataFileUTF8, ordNub)
import Data.Vector ((!?))
import Control.Applicative (many, (<|>))

-- | Get default template for the specified writer.
getDefaultTemplate :: (Maybe FilePath) -- ^ User data directory to search first
                   -> String           -- ^ Name of writer
                   -> IO (Either E.IOException String)
getDefaultTemplate user writer = do
  let format = takeWhile (`notElem` ("+-" :: String)) writer  -- strip off extensions
  case format of
       "native" -> return $ Right ""
       "json"   -> return $ Right ""
       "docx"   -> return $ Right ""
       "fb2"    -> return $ Right ""
       "odt"    -> getDefaultTemplate user "opendocument"
       "markdown_strict"   -> getDefaultTemplate user "markdown"
       "multimarkdown"     -> getDefaultTemplate user "markdown"
       "markdown_github"   -> getDefaultTemplate user "markdown"
       "markdown_mmd"      -> getDefaultTemplate user "markdown"
       "markdown_phpextra" -> getDefaultTemplate user "markdown"
       _        -> let fname = "templates" </> "default" <.> format
                   in  E.try $ readDataFileUTF8 user fname

newtype Template = Template { unTemplate :: Value -> Text }
                 deriving Monoid

type Variable = [Text]

class TemplateTarget a where
  toTarget :: Text -> a

instance TemplateTarget Text where
  toTarget = id

instance TemplateTarget String where
  toTarget = T.unpack

instance TemplateTarget ByteString where
  toTarget = fromChunks . (:[]) . encodeUtf8

instance TemplateTarget Html where
  toTarget = preEscapedText

varListToJSON :: [(String, String)] -> Value
varListToJSON assoc = toJSON $ M.fromList assoc'
  where assoc' = [(T.pack k, toVal [T.pack z | (y,z) <- assoc,
                                                not (null z),
                                                y == k])
                        | k <- ordNub $ map fst assoc ]
        toVal [x] = toJSON x
        toVal []  = Null
        toVal xs  = toJSON xs

renderTemplate :: (ToJSON a, TemplateTarget b) => Template -> a -> b
renderTemplate (Template f) context = toTarget $ f $ toJSON context

compileTemplate :: Text -> Either String Template
compileTemplate template =
  case P.parse (pTemplate <* P.eof) "template" template of
       Left e   -> Left (show e)
       Right x  -> Right x

-- | Like 'renderTemplate', but compiles the template first,
-- raising an error if compilation fails.
renderTemplate' :: (ToJSON a, TemplateTarget b) => String -> a -> b
renderTemplate' template =
  renderTemplate (either error id $ compileTemplate $ T.pack template)

var :: Variable -> Template
var = Template . resolveVar

resolveVar :: Variable -> Value -> Text
resolveVar var' val =
  case multiLookup var' val of
       Just (Array vec) -> maybe mempty (resolveVar []) $ vec !? 0
       Just (String t)  -> T.stripEnd t
       Just (Number n)  -> T.pack $ show n
       Just (Bool True) -> "true"
       Just (Object _)  -> "true"
       Just _           -> mempty
       Nothing          -> mempty

multiLookup :: [Text] -> Value -> Maybe Value
multiLookup [] x = Just x
multiLookup (v:vs) (Object o) = H.lookup v o >>= multiLookup vs
multiLookup _ _ = Nothing

lit :: Text -> Template
lit = Template . const

cond :: Variable -> Template -> Template -> Template
cond var' (Template ifyes) (Template ifno) = Template $ \val ->
  case resolveVar var' val of
       "" -> ifno val
       _  -> ifyes val

iter :: Variable -> Template -> Template -> Template
iter var' template sep = Template $ \val -> unTemplate
  (case multiLookup var' val of
           Just (Array vec) -> mconcat $ intersperse sep
                                       $ map (setVar template var')
                                       $ toList vec
           Just x           -> cond var' (setVar template var' x) mempty
           Nothing          -> mempty) val

setVar :: Template -> Variable -> Value -> Template
setVar (Template f) var' val = Template $ f . replaceVar var' val

replaceVar :: Variable -> Value -> Value -> Value
replaceVar []     new _          = new
replaceVar (v:vs) new (Object o) =
  Object $ H.adjust (\x -> replaceVar vs new x) v o
replaceVar _ _ old = old

--- parsing

pTemplate :: Parser Template
pTemplate = do
  sp <- P.option mempty pInitialSpace
  rest <- mconcat <$> many (pConditional <|>
                            pFor <|>
                            pNewline <|>
                            pVar <|>
                            pLit <|>
                            pEscapedDollar)
  return $ sp <> rest

takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 f = T.pack <$> P.many1 (P.satisfy f)

pLit :: Parser Template
pLit = lit <$> takeWhile1 (\x -> x /='$' && x /= '\n')

pNewline :: Parser Template
pNewline = do
  P.char '\n'
  sp <- P.option mempty pInitialSpace
  return $ lit "\n" <> sp

pInitialSpace :: Parser Template
pInitialSpace = do
  sps <- takeWhile1 (==' ')
  let indentVar = if T.null sps
                     then id
                     else indent (T.length sps)
  v <- P.option mempty $ indentVar <$> pVar
  return $ lit sps <> v

pEscapedDollar :: Parser Template
pEscapedDollar = lit "$" <$ P.try (P.string "$$")

pVar :: Parser Template
pVar = var <$> (P.try $ P.char '$' *> pIdent <* P.char '$')

pIdent :: Parser [Text]
pIdent = do
  first <- pIdentPart
  rest <- many (P.char '.' *> pIdentPart)
  return (first:rest)

pIdentPart :: Parser Text
pIdentPart = P.try $ do
  first <- P.letter
  rest <- T.pack <$> P.many (P.satisfy (\c -> isAlphaNum c || c == '_' || c == '-'))
  let id' = T.singleton first <> rest
  guard $ id' `notElem` reservedWords
  return id'

reservedWords :: [Text]
reservedWords = ["else","endif","for","endfor","sep"]

skipEndline :: Parser ()
skipEndline = P.try $ P.skipMany (P.satisfy (`elem` (" \t" :: String))) >> P.char '\n' >> return ()

pConditional :: Parser Template
pConditional = do
  P.try $ P.string "$if("
  id' <- pIdent
  P.string ")$"
  -- if newline after the "if", then a newline after "endif" will be swallowed
  multiline <- P.option False (True <$ skipEndline)
  ifContents <- pTemplate
  elseContents <- P.option mempty $ P.try $
                      do P.string "$else$"
                         when multiline $ P.option () skipEndline
                         pTemplate
  P.string "$endif$"
  when multiline $ P.option () skipEndline
  return $ cond id' ifContents elseContents

pFor :: Parser Template
pFor = do
  P.try $ P.string "$for("
  id' <- pIdent
  P.string ")$"
  -- if newline after the "for", then a newline after "endfor" will be swallowed
  multiline <- P.option False $ skipEndline >> return True
  contents <- pTemplate
  sep <- P.option mempty $
           do P.try $ P.string "$sep$"
              when multiline $ P.option () skipEndline
              pTemplate
  P.string "$endfor$"
  when multiline $ P.option () skipEndline
  return $ iter id' contents sep

indent :: Int -> Template -> Template
indent 0   x            = x
indent ind (Template f) = Template $ \val -> indent' (f val)
  where indent' t = T.concat
                    $ intersperse ("\n" <> T.replicate ind " ") $ T.lines t