{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Microstache.Render
( renderMustache, renderMustacheW )
where
import Control.Monad (forM_, unless, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT (..), asks, local)
import Data.Aeson (Value (..), encode)
import Data.Foldable (asum)
import Data.List (tails)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid (mempty)
import Data.Semigroup ((<>))
import Data.Text (Text)
import Data.Word (Word)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Encoding as LTE
import qualified Data.Vector as V
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as Key
#else
import qualified Data.HashMap.Strict as KM
#endif
#if MIN_VERSION_transformers(0,4,0)
import Control.Monad.Trans.State.Strict (State, execState, modify')
#else
import Control.Monad.Trans.State.Strict (State, execState, get, put)
#endif
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Text.Microstache.Type
#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 :: MustacheWarning -> Render ()
tellWarning MustacheWarning
w = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' S -> S
f) where
f :: S -> S
f (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
wforall a. a -> [a] -> [a]
:)) Builder
b
tellBuilder :: B.Builder -> Render ()
tellBuilder :: Builder -> Render ()
tellBuilder Builder
b' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' S -> S
f) where
f :: S -> S
f (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')
data RenderContext = RenderContext
{ RenderContext -> Maybe Word
rcIndent :: Maybe Word
, RenderContext -> NonEmpty Value
rcContext :: NonEmpty Value
, RenderContext -> Key
rcPrefix :: Key
, RenderContext -> Template
rcTemplate :: Template
, RenderContext -> Bool
rcLastNode :: Bool
}
renderMustache :: Template -> Value -> LT.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
renderMustacheW :: Template -> Value -> ([MustacheWarning], LT.Text)
renderMustacheW :: Template -> Value -> ([MustacheWarning], Text)
renderMustacheW Template
t =
forall a.
Render a -> Template -> Value -> ([MustacheWarning], Text)
runRender (PName -> Maybe Word -> (Node -> Render ()) -> Render ()
renderPartial (Template -> PName
templateActual Template
t) forall a. Maybe a
Nothing Node -> Render ()
renderNode) Template
t
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 Word
indent) =
PName -> Maybe Word -> (Node -> Render ()) -> Render ()
renderPartial PName
pname Maybe Word
indent Node -> Render ()
renderNode
runRender :: Render a -> Template -> Value -> ([MustacheWarning], LT.Text)
runRender :: forall a.
Render a -> Template -> Value -> ([MustacheWarning], Text)
runRender Render a
m Template
t Value
v = case 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) of
S [MustacheWarning] -> [MustacheWarning]
ws Builder
b -> ([MustacheWarning] -> [MustacheWarning]
ws [], Builder -> Text
B.toLazyText Builder
b)
where
rc :: RenderContext
rc = RenderContext
{ rcIndent :: Maybe Word
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 #-}
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 #-}
outputIndent :: Render ()
outputIndent :: Render ()
outputIndent = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks RenderContext -> Maybe Word
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 Word -> Text
buildIndent
{-# INLINE outputIndent #-}
outputIndented :: Text -> Render ()
outputIndented :: Text -> Render ()
outputIndented Text
txt = do
Maybe Word
level <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks RenderContext -> Maybe Word
rcIndent
Bool
lnode <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r 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 Word -> Text
buildIndent Maybe Word
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 #-}
renderPartial
:: PName
-> Maybe Word
-> (Node -> Render ())
-> Render ()
renderPartial :: PName -> Maybe Word -> (Node -> Render ()) -> Render ()
renderPartial PName
pname Maybe Word
i Node -> Render ()
f =
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r 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 Word
rcIndent = Maybe Word -> Maybe Word -> Maybe Word
addIndents Maybe Word
i (RenderContext -> Maybe Word
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 #-}
getNodes :: Render [Node]
getNodes :: ReaderT RenderContext (State S) [Node]
getNodes = do
Template PName
actual Map PName [Node]
cache <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r 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
Map.findWithDefault [] PName
actual Map PName [Node]
cache)
{-# INLINE getNodes #-}
renderMany
:: (Node -> 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 (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks RenderContext -> Bool
rcLastNode
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r 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.
(r -> r) -> ReaderT r m a -> ReaderT r 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
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 (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks RenderContext -> NonEmpty Value
rcContext
lookupKey Key
k = do
NonEmpty Value
v <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks RenderContext -> NonEmpty Value
rcContext
Key
p <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r 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 -> do
MustacheWarning -> Render ()
tellWarning forall a b. (a -> b) -> a -> b
$ Key -> MustacheWarning
MustacheVariableNotFound (Key
p forall a. Semigroup a => a -> a -> a
<> Key
k)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Value
String Text
"")
Just Value
r -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
r
simpleLookup
:: Bool
-> Key
-> 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) =
#if MIN_VERSION_aeson(2,0,0)
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
k) Object
m of
#else
case KM.lookup k m of
#endif
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 #-}
enterSection :: Key -> Render a -> Render a
enterSection :: forall a. Key -> Render a -> Render a
enterSection Key
p =
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r 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 #-}
addToLocalContext :: Value -> Render a -> Render a
addToLocalContext :: forall a. Value -> Render a -> Render a
addToLocalContext Value
v =
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r 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 #-}
addIndents :: Maybe Word -> Maybe Word -> Maybe Word
addIndents :: Maybe Word -> Maybe Word -> Maybe Word
addIndents Maybe Word
Nothing Maybe Word
Nothing = forall a. Maybe a
Nothing
addIndents Maybe Word
Nothing (Just Word
x) = forall a. a -> Maybe a
Just Word
x
addIndents (Just Word
x) Maybe Word
Nothing = forall a. a -> Maybe a
Just Word
x
addIndents (Just Word
x) (Just Word
y) = forall a. a -> Maybe a
Just (Word
x forall a. Num a => a -> a -> a
+ Word
y)
{-# INLINE addIndents #-}
buildIndent :: Maybe Word -> Text
buildIndent :: Maybe Word -> Text
buildIndent Maybe Word
Nothing = Text
""
buildIndent (Just Word
p) = let n :: Int
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p forall a. Num a => a -> a -> a
- Int
1 in Int -> Text -> Text
T.replicate Int
n Text
" "
{-# INLINE buildIndent #-}
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
KM.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 #-}
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
LT.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LTE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode
{-# INLINE renderValue #-}
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
""")
, (Text
"<", Text
"<")
, (Text
">", Text
">")
, (Text
"&", Text
"&") ]
{-# INLINE escapeHtml #-}