{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
    OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
{- |
   Module      : Text.Pandoc.Templates
   Copyright   : Copyright (C) 2009-2016 John MacFarlane
   License     : BSD3

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

A simple templating system with variable substitution and conditionals.
This module was formerly part of pandoc and is used for pandoc's
templates.  The following program illustrates its use:

> {-# LANGUAGE OverloadedStrings #-}
> import Data.Text
> import Data.Aeson
> import Text.DocTemplates
>
> 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 ]
>
> template :: Text
> template = "$for(employee)$Hi, $employee.name.first$. $if(employee.salary)$You make $employee.salary$.$else$No salary data.$endif$$sep$\n$endfor$"
>
> main = case compileTemplate template of
>          Left e    -> error e
>          Right t   -> putStrLn $ renderTemplate t $ object
>                         ["employee" .=
>                           [ Employee "John" "Doe" Nothing
>                           , Employee "Omar" "Smith" (Just 30000)
>                           , Employee "Sara" "Chen" (Just 60000) ]
>                         ]

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.DocTemplates ( renderTemplate
                         , applyTemplate
                         , TemplateTarget(..)
                         , varListToJSON
                         , compileTemplate
                         , Template
                         ) 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 qualified Data.Set as Set
import Data.Monoid
import Control.Applicative
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.List (intersperse)
import qualified Data.Map as M
import qualified Data.HashMap.Strict as H
import Data.Foldable (toList)
import Text.Blaze.Html (Html)
import Text.Blaze.Internal (preEscapedText)
import Data.ByteString.Lazy (ByteString, fromChunks)
import Data.Vector ((!?))
import Data.Scientific (floatingOrInteger)
import Data.Semigroup (Semigroup)

-- | A 'Template' is essentially a function that takes
-- a JSON 'Value' and produces 'Text'.
newtype Template = Template { unTemplate :: Value -> Text }
                 deriving (Semigroup, 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

-- | A convenience function for passing in an association
-- list of string values instead of a JSON 'Value'.
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

-- An efficient specialization of nub.
ordNub :: (Ord a) => [a] -> [a]
ordNub l = go Set.empty l
  where
    go _ [] = []
    go s (x:xs) = if x `Set.member` s then go s xs
                                      else x : go (Set.insert x s) xs

-- | Compile a template.
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

-- | Render a compiled template using @context@ to resolve variables.
renderTemplate :: (ToJSON a, TemplateTarget b) => Template -> a -> b
renderTemplate (Template f) context = toTarget $ f $ toJSON context

-- | Combines `renderTemplate` and `compileTemplate`.
applyTemplate :: (ToJSON a, TemplateTarget b) => Text -> a -> Either String b
applyTemplate t context =
  case compileTemplate t of
         Left e   -> Left e
         Right f  -> Right $ renderTemplate f context

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)  -> case floatingOrInteger n of
                                   Left (r :: Double)   -> T.pack $ show r
                                   Right (i :: Integer) -> T.pack $ show i
       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 <|>
                            pComment <|>
                            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 "$$")

pComment :: Parser Template
pComment = do
  pos <- P.getPosition
  P.try (P.string "$--")
  P.skipMany (P.satisfy (/='\n'))
  -- If the comment begins in the first column, the line ending
  -- will be consumed; otherwise not.
  when (P.sourceColumn pos == 1) $ () <$ P.char '\n'
  return mempty

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