{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.Mustache.Render
-- Copyright   :  © 2016–present Stack Builders
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Functions for rendering Mustache templates. You don't usually need to
-- import the module, because "Text.Mustache" re-exports everything you may
-- need, import that module instead.
module Text.Mustache.Render
  ( renderMustache,
    renderMustacheW,
  )
where

import Control.Monad (forM_, unless, when)
import Control.Monad.Reader (MonadReader (local), ReaderT (runReaderT), asks)
import Control.Monad.State.Strict (State, execState, modify')
import Data.Aeson hiding (Key)
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
import Data.Foldable (asum)
import Data.List (tails)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Vector as V
import Text.Megaparsec.Pos (Pos, mkPos, unPos)
import Text.Mustache.Type

----------------------------------------------------------------------------
-- The rendering monad

-- | Synonym for the monad we use for rendering. It allows us to share
-- context and accumulate the result as 'B.Builder' data which is then
-- turned into a lazy 'TL.Text'.
type Render a = ReaderT RenderContext (State S) a

data S = S ([MustacheWarning] -> [MustacheWarning]) B.Builder

-- | The render monad context.
data RenderContext = RenderContext
  { -- | Actual indentation level
    RenderContext -> Maybe Pos
rcIndent :: Maybe Pos,
    -- | The context stack
    RenderContext -> NonEmpty Value
rcContext :: NonEmpty Value,
    -- | Prefix accumulated by entering sections
    RenderContext -> Key
rcPrefix :: Key,
    -- | The template to render
    RenderContext -> Template
rcTemplate :: Template,
    -- | Is this last node in this partial?
    RenderContext -> Bool
rcLastNode :: Bool
  }

----------------------------------------------------------------------------
-- High-level interface

-- | Render a Mustache 'Template' using Aeson's 'Value' to get actual values
-- for interpolation.
renderMustache :: Template -> Value -> TL.Text
renderMustache :: Template -> Value -> Text
renderMustache Template
t = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Template -> Value -> ([MustacheWarning], Text)
renderMustacheW Template
t

-- | Like 'renderMustache', but also returns a collection of warnings.
--
-- @since 1.1.1
renderMustacheW :: Template -> Value -> ([MustacheWarning], TL.Text)
renderMustacheW :: Template -> Value -> ([MustacheWarning], Text)
renderMustacheW Template
t =
  forall a.
Render a -> Template -> Value -> ([MustacheWarning], Text)
runRender (PName -> Maybe Pos -> (Node -> Render ()) -> Render ()
renderPartial (Template -> PName
templateActual Template
t) forall a. Maybe a
Nothing Node -> Render ()
renderNode) Template
t

-- | Render a single 'Node'.
renderNode :: Node -> Render ()
renderNode :: Node -> Render ()
renderNode (TextBlock Text
txt) = Text -> Render ()
outputIndented Text
txt
renderNode (EscapedVar Key
k) =
  Key -> Render Value
lookupKey Key
k forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Value -> ReaderT RenderContext (State S) Text
renderValue Key
k forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Render ()
outputRaw forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeHtml
renderNode (UnescapedVar Key
k) =
  Key -> Render Value
lookupKey Key
k forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Value -> ReaderT RenderContext (State S) Text
renderValue Key
k forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Render ()
outputRaw
renderNode (Section Key
k [Node]
ns) = do
  Value
val <- Key -> Render Value
lookupKey Key
k
  forall a. Key -> Render a -> Render a
enterSection Key
k forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> Bool
isBlank Value
val) forall a b. (a -> b) -> a -> b
$
      case Value
val of
        Array Array
xs ->
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Vector a -> [a]
V.toList Array
xs) forall a b. (a -> b) -> a -> b
$ \Value
x ->
            forall a. Value -> Render a -> Render a
addToLocalContext Value
x ((Node -> Render ()) -> [Node] -> Render ()
renderMany Node -> Render ()
renderNode [Node]
ns)
        Value
_ ->
          forall a. Value -> Render a -> Render a
addToLocalContext Value
val ((Node -> Render ()) -> [Node] -> Render ()
renderMany Node -> Render ()
renderNode [Node]
ns)
renderNode (InvertedSection Key
k [Node]
ns) = do
  Value
val <- Key -> Render Value
lookupKey Key
k
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value -> Bool
isBlank Value
val) forall a b. (a -> b) -> a -> b
$
    (Node -> Render ()) -> [Node] -> Render ()
renderMany Node -> Render ()
renderNode [Node]
ns
renderNode (Partial PName
pname Maybe Pos
indent) =
  PName -> Maybe Pos -> (Node -> Render ()) -> Render ()
renderPartial PName
pname Maybe Pos
indent Node -> Render ()
renderNode

----------------------------------------------------------------------------
-- The rendering monad vocabulary

-- | Run 'Render' monad given template to render and a 'Value' to take
-- values from.
runRender :: Render a -> Template -> Value -> ([MustacheWarning], TL.Text)
runRender :: forall a.
Render a -> Template -> Value -> ([MustacheWarning], Text)
runRender Render a
m Template
t Value
v = ([MustacheWarning] -> [MustacheWarning]
ws [], Builder -> Text
B.toLazyText Builder
b)
  where
    S [MustacheWarning] -> [MustacheWarning]
ws Builder
b = forall s a. State s a -> s -> s
execState (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Render a
m RenderContext
rc) (([MustacheWarning] -> [MustacheWarning]) -> Builder -> S
S forall a. a -> a
id forall a. Monoid a => a
mempty)
    rc :: RenderContext
rc =
      RenderContext
        { rcIndent :: Maybe Pos
rcIndent = forall a. Maybe a
Nothing,
          rcContext :: NonEmpty Value
rcContext = Value
v forall a. a -> [a] -> NonEmpty a
:| [],
          rcPrefix :: Key
rcPrefix = forall a. Monoid a => a
mempty,
          rcTemplate :: Template
rcTemplate = Template
t,
          rcLastNode :: Bool
rcLastNode = Bool
True
        }
{-# INLINE runRender #-}

-- | Output a piece of strict 'Text'.
outputRaw :: Text -> Render ()
outputRaw :: Text -> Render ()
outputRaw = Builder -> Render ()
tellBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
B.fromText
{-# INLINE outputRaw #-}

-- | Output indentation consisting of appropriate number of spaces.
outputIndent :: Render ()
outputIndent :: Render ()
outputIndent = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> Maybe Pos
rcIndent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Render ()
outputRaw forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Pos -> Text
buildIndent
{-# INLINE outputIndent #-}

-- | Output piece of strict 'Text' with added indentation.
outputIndented :: Text -> Render ()
outputIndented :: Text -> Render ()
outputIndented Text
txt = do
  Maybe Pos
level <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> Maybe Pos
rcIndent
  Bool
lnode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> Bool
rcLastNode
  let f :: Text -> Render ()
f Text
x = Text -> Render ()
outputRaw (Text -> Text -> Text -> Text
T.replace Text
"\n" (Text
"\n" forall a. Semigroup a => a -> a -> a
<> Maybe Pos -> Text
buildIndent Maybe Pos
level) Text
x)
  if Bool
lnode Bool -> Bool -> Bool
&& Text -> Text -> Bool
T.isSuffixOf Text
"\n" Text
txt
    then Text -> Render ()
f (Text -> Text
T.init Text
txt) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Render ()
outputRaw Text
"\n"
    else Text -> Render ()
f Text
txt
{-# INLINE outputIndented #-}

-- | Render a partial.
renderPartial ::
  -- | Name of partial to render
  PName ->
  -- | Indentation level to use
  Maybe Pos ->
  -- | How to render nodes in that partial
  (Node -> Render ()) ->
  Render ()
renderPartial :: PName -> Maybe Pos -> (Node -> Render ()) -> Render ()
renderPartial PName
pname Maybe Pos
i Node -> Render ()
f =
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RenderContext -> RenderContext
u (Render ()
outputIndent forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT RenderContext (State S) [Node]
getNodes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Node -> Render ()) -> [Node] -> Render ()
renderMany Node -> Render ()
f)
  where
    u :: RenderContext -> RenderContext
u RenderContext
rc =
      RenderContext
rc
        { rcIndent :: Maybe Pos
rcIndent = Maybe Pos -> Maybe Pos -> Maybe Pos
addIndents Maybe Pos
i (RenderContext -> Maybe Pos
rcIndent RenderContext
rc),
          rcPrefix :: Key
rcPrefix = forall a. Monoid a => a
mempty,
          rcTemplate :: Template
rcTemplate = (RenderContext -> Template
rcTemplate RenderContext
rc) {templateActual :: PName
templateActual = PName
pname},
          rcLastNode :: Bool
rcLastNode = Bool
True
        }
{-# INLINE renderPartial #-}

-- | Get collection of 'Node's for actual template.
getNodes :: Render [Node]
getNodes :: ReaderT RenderContext (State S) [Node]
getNodes = do
  Template PName
actual Map PName [Node]
cache <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> Template
rcTemplate
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PName
actual Map PName [Node]
cache)
{-# INLINE getNodes #-}

-- | Render many nodes.
renderMany ::
  -- | How to render a node
  (Node -> Render ()) ->
  -- | The collection of nodes to render
  [Node] ->
  Render ()
renderMany :: (Node -> Render ()) -> [Node] -> Render ()
renderMany Node -> Render ()
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
renderMany Node -> Render ()
f [Node
n] = do
  Bool
ln <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> Bool
rcLastNode
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\RenderContext
rc -> RenderContext
rc {rcLastNode :: Bool
rcLastNode = Bool
ln Bool -> Bool -> Bool
&& RenderContext -> Bool
rcLastNode RenderContext
rc}) (Node -> Render ()
f Node
n)
renderMany Node -> Render ()
f (Node
n : [Node]
ns) = do
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\RenderContext
rc -> RenderContext
rc {rcLastNode :: Bool
rcLastNode = Bool
False}) (Node -> Render ()
f Node
n)
  (Node -> Render ()) -> [Node] -> Render ()
renderMany Node -> Render ()
f [Node]
ns

-- | Lookup a 'Value' by its 'Key'.
lookupKey :: Key -> Render Value
lookupKey :: Key -> Render Value
lookupKey (Key []) = forall a. NonEmpty a -> a
NE.head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> NonEmpty Value
rcContext
lookupKey Key
k = do
  NonEmpty Value
v <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> NonEmpty Value
rcContext
  Key
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RenderContext -> Key
rcPrefix
  let f :: Key -> Maybe Value
f Key
x = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (Bool -> Key -> Value -> Maybe Value
simpleLookup Bool
False (Key
x forall a. Semigroup a => a -> a -> a
<> Key
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Value
v)
  case forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key -> Maybe Value
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Key
Key) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
tails forall a b. (a -> b) -> a -> b
$ Key -> [Text]
unKey Key
p) of
    Maybe Value
Nothing ->
      Value
Null forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MustacheWarning -> Render ()
tellWarning (Key -> MustacheWarning
MustacheVariableNotFound (Key
p forall a. Semigroup a => a -> a -> a
<> Key
k))
    Just Value
r ->
      forall (m :: * -> *) a. Monad m => a -> m a
return Value
r

-- | Lookup a 'Value' by traversing another 'Value' using given 'Key' as
-- “path”.
simpleLookup ::
  -- | At least one part of the path matched, in this case we are
  -- “committed” to this lookup and cannot say “there is nothing, try
  -- other level”. This is necessary to pass the “Dotted Names—Context
  -- Precedence” test from the “interpolation.yml” spec.
  Bool ->
  -- | The key to lookup
  Key ->
  -- | Source value
  Value ->
  -- | Looked-up value
  Maybe Value
simpleLookup :: Bool -> Key -> Value -> Maybe Value
simpleLookup Bool
_ (Key []) Value
obj = forall (m :: * -> *) a. Monad m => a -> m a
return Value
obj
simpleLookup Bool
c (Key (Text
k : [Text]
ks)) (Object Object
m) =
  case forall v. Key -> KeyMap v -> Maybe v
Aeson.KeyMap.lookup (Text -> Key
Aeson.Key.fromText Text
k) Object
m of
    Maybe Value
Nothing -> if Bool
c then forall a. a -> Maybe a
Just Value
Null else forall a. Maybe a
Nothing
    Just Value
v -> Bool -> Key -> Value -> Maybe Value
simpleLookup Bool
True ([Text] -> Key
Key [Text]
ks) Value
v
simpleLookup Bool
_ Key
_ Value
_ = forall a. Maybe a
Nothing
{-# INLINE simpleLookup #-}

-- | Enter the section by adding given 'Key' prefix to current prefix.
enterSection :: Key -> Render a -> Render a
enterSection :: forall a. Key -> Render a -> Render a
enterSection Key
p =
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\RenderContext
rc -> RenderContext
rc {rcPrefix :: Key
rcPrefix = Key
p forall a. Semigroup a => a -> a -> a
<> RenderContext -> Key
rcPrefix RenderContext
rc})
{-# INLINE enterSection #-}

-- | Add new value on the top of context. The new value has the highest
-- priority when lookup takes place.
addToLocalContext :: Value -> Render a -> Render a
addToLocalContext :: forall a. Value -> Render a -> Render a
addToLocalContext Value
v =
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\RenderContext
rc -> RenderContext
rc {rcContext :: NonEmpty Value
rcContext = forall a. a -> NonEmpty a -> NonEmpty a
NE.cons Value
v (RenderContext -> NonEmpty Value
rcContext RenderContext
rc)})
{-# INLINE addToLocalContext #-}

----------------------------------------------------------------------------
-- Helpers

-- | Register a warning.
tellWarning :: MustacheWarning -> Render ()
tellWarning :: MustacheWarning -> Render ()
tellWarning MustacheWarning
w = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \(S [MustacheWarning] -> [MustacheWarning]
ws Builder
b) -> ([MustacheWarning] -> [MustacheWarning]) -> Builder -> S
S ([MustacheWarning] -> [MustacheWarning]
ws forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MustacheWarning
w forall a. a -> [a] -> [a]
:)) Builder
b

-- | Register a piece of output.
tellBuilder :: B.Builder -> Render ()
tellBuilder :: Builder -> Render ()
tellBuilder Builder
b' = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \(S [MustacheWarning] -> [MustacheWarning]
ws Builder
b) -> ([MustacheWarning] -> [MustacheWarning]) -> Builder -> S
S [MustacheWarning] -> [MustacheWarning]
ws (Builder
b forall a. Semigroup a => a -> a -> a
<> Builder
b')

-- | Add two @'Maybe' 'Pos'@ values together.
addIndents :: Maybe Pos -> Maybe Pos -> Maybe Pos
addIndents :: Maybe Pos -> Maybe Pos -> Maybe Pos
addIndents Maybe Pos
Nothing Maybe Pos
Nothing = forall a. Maybe a
Nothing
addIndents Maybe Pos
Nothing (Just Pos
x) = forall a. a -> Maybe a
Just Pos
x
addIndents (Just Pos
x) Maybe Pos
Nothing = forall a. a -> Maybe a
Just Pos
x
addIndents (Just Pos
x) (Just Pos
y) = forall a. a -> Maybe a
Just (Int -> Pos
mkPos forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos Pos
x forall a. Num a => a -> a -> a
+ Pos -> Int
unPos Pos
y forall a. Num a => a -> a -> a
- Int
1)
{-# INLINE addIndents #-}

-- | Build indentation of specified length by repeating the space character.
buildIndent :: Maybe Pos -> Text
buildIndent :: Maybe Pos -> Text
buildIndent Maybe Pos
Nothing = Text
""
buildIndent (Just Pos
p) = let n :: Int
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Int
unPos Pos
p) forall a. Num a => a -> a -> a
- Int
1 in Int -> Text -> Text
T.replicate Int
n Text
" "
{-# INLINE buildIndent #-}

-- | Select invisible values.
isBlank :: Value -> Bool
isBlank :: Value -> Bool
isBlank Value
Null = Bool
True
isBlank (Bool Bool
False) = Bool
True
isBlank (Object Object
m) = forall v. KeyMap v -> Bool
Aeson.KeyMap.null Object
m
isBlank (Array Array
a) = forall a. Vector a -> Bool
V.null Array
a
isBlank (String Text
s) = Text -> Bool
T.null Text
s
isBlank Value
_ = Bool
False
{-# INLINE isBlank #-}

-- | Render Aeson's 'Value' /without/ HTML escaping.
renderValue :: Key -> Value -> Render Text
renderValue :: Key -> Value -> ReaderT RenderContext (State S) Text
renderValue Key
k Value
v =
  case Value
v of
    Value
Null -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
    String Text
str -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
str
    Object Object
_ -> do
      MustacheWarning -> Render ()
tellWarning (Key -> MustacheWarning
MustacheDirectlyRenderedValue Key
k)
      Value -> ReaderT RenderContext (State S) Text
render Value
v
    Array Array
_ -> do
      MustacheWarning -> Render ()
tellWarning (Key -> MustacheWarning
MustacheDirectlyRenderedValue Key
k)
      Value -> ReaderT RenderContext (State S) Text
render Value
v
    Value
_ -> Value -> ReaderT RenderContext (State S) Text
render Value
v
  where
    render :: Value -> ReaderT RenderContext (State S) Text
render = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode
{-# INLINE renderValue #-}

-- | Escape HTML represented as strict 'Text'.
escapeHtml :: Text -> Text
escapeHtml :: Text -> Text
escapeHtml Text
txt =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text -> Text
T.replace)
    Text
txt
    [ (Text
"\"", Text
"&quot;"),
      (Text
"'", Text
"&#39;"),
      (Text
"<", Text
"&lt;"),
      (Text
">", Text
"&gt;"),
      (Text
"&", Text
"&amp;")
    ]
{-# INLINE escapeHtml #-}