module Text.Microstache.Render
( renderMustache, renderMustacheW )
where
import Control.Monad (when, forM_, unless)
import Control.Monad.Trans.Reader (ReaderT (..), asks, local)
#if MIN_VERSION_transformers(0,4,0)
import Control.Monad.Trans.State.Strict (State, modify', execState)
#else
import Control.Monad.Trans.State.Strict (State, get, put, execState)
#endif
import Control.Monad.Trans.Class (lift)
import Data.Aeson (Value (..), encode)
import Data.Monoid (mempty)
import Data.Semigroup ((<>))
import Data.Foldable (asum)
import Data.List (tails)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import Data.Word (Word)
import Text.Microstache.Type
import qualified Data.HashMap.Strict as H
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding 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
#if !(MIN_VERSION_transformers(0,4,0))
modify' :: (s -> s) -> State s ()
modify' f = do
s <- get
put $! f s
#endif
type Render a = ReaderT RenderContext (State S) a
data S = S ([MustacheWarning] -> [MustacheWarning]) B.Builder
tellWarning :: MustacheWarning -> Render ()
tellWarning w = lift (modify' f) where
f (S ws b) = S (ws . (w:)) b
tellBuilder :: B.Builder -> Render ()
tellBuilder b' = lift (modify' f) where
f (S ws b) = S ws (b <> b')
data RenderContext = RenderContext
{ rcIndent :: Maybe Word
, 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 = case execState (runReaderT m rc) (S id mempty) of
S ws b -> (ws [], B.toLazyText b)
where
rc = RenderContext
{ rcIndent = Nothing
, rcContext = v :| []
, rcPrefix = mempty
, rcTemplate = t
, rcLastNode = True
}
outputRaw :: Text -> Render ()
outputRaw = tellBuilder . 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 Word
-> (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)
case asum (fmap (f . Key) . reverse . tails $ unKey p) of
Nothing -> do
tellWarning $ MustacheVariableNotFound (p <> k)
return (String "")
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
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 Word -> Maybe Word -> Maybe Word
addIndents Nothing Nothing = Nothing
addIndents Nothing (Just x) = Just x
addIndents (Just x) Nothing = Just x
addIndents (Just x) (Just y) = Just (x + y)
buildIndent :: Maybe Word -> Text
buildIndent Nothing = ""
buildIndent (Just p) = let n = fromIntegral 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 :: 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
escapeHtml :: Text -> Text
escapeHtml txt = foldr (uncurry T.replace) txt
[ ("\"", """)
, ("<", "<")
, (">", ">")
, ("&", "&") ]