{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Mustache.Render
( renderMustache
, renderMustacheW )
where
import Control.Monad.Reader
import Control.Monad.State.Strict (State, modify', execState)
import Data.Aeson
import Data.Foldable (asum)
import Data.List (tails)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Semigroup ((<>))
import Data.Text (Text)
import Text.Megaparsec.Pos (Pos, unPos)
import Text.Mustache.Type
import qualified Data.HashMap.Strict as H
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import qualified Data.Semigroup as S
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
type Render a = ReaderT RenderContext (State S) a
data S = S ([MustacheWarning] -> [MustacheWarning]) B.Builder
data RenderContext = RenderContext
{ rcIndent :: Maybe Pos
, rcContext :: NonEmpty Value
, rcPrefix :: Key
, rcTemplate :: Template
, rcLastNode :: Bool
}
renderMustache :: Template -> Value -> TL.Text
renderMustache t = snd . renderMustacheW t
renderMustacheW :: Template -> Value -> ([MustacheWarning], TL.Text)
renderMustacheW t =
runRender (renderPartial (templateActual t) Nothing renderNode) t
renderNode :: Node -> Render ()
renderNode (TextBlock txt) = outputIndented txt
renderNode (EscapedVar k) =
lookupKey k >>= renderValue k >>= outputRaw . escapeHtml
renderNode (UnescapedVar k) =
lookupKey k >>= renderValue k >>= outputRaw
renderNode (Section k ns) = do
val <- lookupKey k
enterSection k $
unless (isBlank val) $
case val of
Array xs ->
forM_ (V.toList xs) $ \x ->
addToLocalContext x (renderMany renderNode ns)
_ ->
addToLocalContext val (renderMany renderNode ns)
renderNode (InvertedSection k ns) = do
val <- lookupKey k
when (isBlank val) $
renderMany renderNode ns
renderNode (Partial pname indent) =
renderPartial pname indent renderNode
runRender :: Render a -> Template -> Value -> ([MustacheWarning], TL.Text)
runRender m t v = (ws [], B.toLazyText b)
where
S ws b = execState (runReaderT m rc) (S id mempty)
rc = RenderContext
{ rcIndent = Nothing
, rcContext = v :| []
, rcPrefix = mempty
, rcTemplate = t
, rcLastNode = True }
{-# INLINE runRender #-}
outputRaw :: Text -> Render ()
outputRaw = tellBuilder . B.fromText
{-# INLINE outputRaw #-}
outputIndent :: Render ()
outputIndent = asks rcIndent >>= outputRaw . buildIndent
{-# INLINE outputIndent #-}
outputIndented :: Text -> Render ()
outputIndented txt = do
level <- asks rcIndent
lnode <- asks rcLastNode
let f x = outputRaw (T.replace "\n" ("\n" <> buildIndent level) x)
if lnode && T.isSuffixOf "\n" txt
then f (T.init txt) >> outputRaw "\n"
else f txt
{-# INLINE outputIndented #-}
renderPartial
:: PName
-> Maybe Pos
-> (Node -> Render ())
-> Render ()
renderPartial pname i f =
local u (outputIndent >> getNodes >>= renderMany f)
where
u rc = rc
{ rcIndent = addIndents i (rcIndent rc)
, rcPrefix = mempty
, rcTemplate = (rcTemplate rc) { templateActual = pname }
, rcLastNode = True }
{-# INLINE renderPartial #-}
getNodes :: Render [Node]
getNodes = do
Template actual cache <- asks rcTemplate
return (M.findWithDefault [] actual cache)
{-# INLINE getNodes #-}
renderMany
:: (Node -> Render ())
-> [Node]
-> Render ()
renderMany _ [] = return ()
renderMany f [n] = do
ln <- asks rcLastNode
local (\rc -> rc { rcLastNode = ln && rcLastNode rc }) (f n)
renderMany f (n:ns) = do
local (\rc -> rc { rcLastNode = False }) (f n)
renderMany f ns
lookupKey :: Key -> Render Value
lookupKey (Key []) = NE.head <$> asks rcContext
lookupKey k = do
v <- asks rcContext
p <- asks rcPrefix
let f x = asum (simpleLookup False (x <> k) <$> v)
case asum (fmap (f . Key) . reverse . tails $ unKey p) of
Nothing ->
Null <$ tellWarning (MustacheVariableNotFound (p <> k))
Just r ->
return r
simpleLookup
:: Bool
-> Key
-> Value
-> Maybe Value
simpleLookup _ (Key []) obj = return obj
simpleLookup c (Key (k:ks)) (Object m) =
case H.lookup k m of
Nothing -> if c then Just Null else Nothing
Just v -> simpleLookup True (Key ks) v
simpleLookup _ _ _ = Nothing
{-# INLINE simpleLookup #-}
enterSection :: Key -> Render a -> Render a
enterSection p =
local (\rc -> rc { rcPrefix = p <> rcPrefix rc })
{-# INLINE enterSection #-}
addToLocalContext :: Value -> Render a -> Render a
addToLocalContext v =
local (\rc -> rc { rcContext = NE.cons v (rcContext rc) })
{-# INLINE addToLocalContext #-}
tellWarning :: MustacheWarning -> Render ()
tellWarning w = modify' $ \(S ws b) -> S (ws . (w:)) b
tellBuilder :: B.Builder -> Render ()
tellBuilder b' = modify' $ \(S ws b) -> S ws (b <> b')
addIndents :: Maybe Pos -> Maybe Pos -> Maybe Pos
addIndents Nothing Nothing = Nothing
addIndents Nothing (Just x) = Just x
addIndents (Just x) Nothing = Just x
addIndents (Just x) (Just y) = Just (x S.<> y)
{-# INLINE addIndents #-}
buildIndent :: Maybe Pos -> Text
buildIndent Nothing = ""
buildIndent (Just p) = let n = fromIntegral (unPos p) - 1 in T.replicate n " "
{-# INLINE buildIndent #-}
isBlank :: Value -> Bool
isBlank Null = True
isBlank (Bool False) = True
isBlank (Object m) = H.null m
isBlank (Array a) = V.null a
isBlank (String s) = T.null s
isBlank _ = False
{-# INLINE isBlank #-}
renderValue :: Key -> Value -> Render Text
renderValue k v =
case v of
Null -> return ""
String str -> return str
Object _ -> do
tellWarning (MustacheDirectlyRenderedValue k)
render v
Array _ -> do
tellWarning (MustacheDirectlyRenderedValue k)
render v
_ -> render v
where
render = return . TL.toStrict . TL.decodeUtf8 . encode
{-# INLINE renderValue #-}
escapeHtml :: Text -> Text
escapeHtml txt = foldr (uncurry T.replace) txt
[ ("\"", """)
, ("'", "'")
, ("<", "<")
, (">", ">")
, ("&", "&") ]
{-# INLINE escapeHtml #-}