module Text.Mustache.Render
( renderMustache )
where
import Control.Monad.Reader
import Control.Monad.Writer.Lazy
import Data.Aeson
import Data.Foldable (asum)
import Data.List (tails)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Text.Megaparsec.Pos (Pos, unPos)
import Text.Mustache.Type
import qualified Data.ByteString.Lazy as B
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.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Vector as V
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
type Render a = ReaderT RenderContext (Writer B.Builder) a
data RenderContext = RenderContext
{ rcIndent :: Maybe Pos
, rcContext :: NonEmpty Value
, rcPrefix :: Key
, rcTemplate :: Template
, rcLastNode :: Bool
}
renderMustache :: Template -> Value -> TL.Text
renderMustache t =
runRender (renderPartial (templateActual t) Nothing renderNode) t
renderNode :: Node -> Render ()
renderNode (TextBlock txt) = outputIndented txt
renderNode (EscapedVar k) =
lookupKey k >>= outputRaw . escapeHtml . renderValue
renderNode (UnescapedVar k) =
lookupKey k >>= outputRaw . renderValue
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 -> TL.Text
runRender m t v = (B.toLazyText . execWriter) (runReaderT m rc)
where
rc = RenderContext
{ rcIndent = Nothing
, rcContext = v :| []
, rcPrefix = mempty
, rcTemplate = t
, rcLastNode = True }
outputRaw :: Text -> Render ()
outputRaw = tell . B.fromText
outputIndent :: Render ()
outputIndent = asks rcIndent >>= outputRaw . buildIndent
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
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 }
getNodes :: Render [Node]
getNodes = do
Template actual cache <- asks rcTemplate
return (M.findWithDefault [] actual cache)
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)
(return . fromMaybe Null . asum) (fmap (f . Key) . reverse . tails $ unKey p)
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
enterSection :: Key -> Render a -> Render a
enterSection p =
local (\rc -> rc { rcPrefix = p <> rcPrefix rc })
addToLocalContext :: Value -> Render a -> Render a
addToLocalContext v =
local (\rc -> rc { rcContext = NE.cons v (rcContext rc) })
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)
buildIndent :: Maybe Pos -> Text
buildIndent Nothing = ""
buildIndent (Just p) = let n = fromIntegral (unPos p) 1 in T.replicate n " "
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
renderValue :: Value -> Text
renderValue Null = ""
renderValue (String str) = str
renderValue value = (T.decodeUtf8 . B.toStrict . encode) value
escapeHtml :: Text -> Text
escapeHtml txt = foldr (uncurry T.replace) txt
[ ("\"", """)
, ("<", "<")
, (">", ">")
, ("&", "&") ]