diff --git a/CHANGELOG.md b/CHANGELOG.md index 801d384..dc95ae6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,10 @@ +## Unreleased + +* Fix indentation inheritance in partials. [Issue + 72](https://github.com/mrkkrp/stache/issues/72). + ## Stache 2.3.4 + * Support GHC 9.6 thanks to @ysangkok * Fix infinite loop caused by unclosed sections thanks to @ernius diff --git a/Text/Mustache/Render.hs b/Text/Mustache/Render.hs index f8865e8..1eb3ff0 100644 --- a/Text/Mustache/Render.hs +++ b/Text/Mustache/Render.hs @@ -19,49 +19,21 @@ module Text.Mustache.Render 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 Data.Aeson.Key qualified as Aeson.Key import Data.Aeson.KeyMap qualified as Aeson.KeyMap import Data.Foldable (asum) import Data.List (tails) -import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL -import Data.Text.Lazy.Builder qualified as B +import Data.Text.Lazy.Builder qualified as TLB import Data.Text.Lazy.Encoding qualified as TL import Data.Vector qualified as V -import Text.Megaparsec.Pos (Pos, mkPos, unPos) +import Text.Mustache.Render.Internal 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 - rcIndent :: Maybe Pos, - -- | The context stack - rcContext :: NonEmpty Value, - -- | Prefix accumulated by entering sections - rcPrefix :: Key, - -- | The template to render - rcTemplate :: Template, - -- | Is this last node in this partial? - rcLastNode :: Bool - } - ---------------------------------------------------------------------------- -- High-level interface @@ -74,131 +46,67 @@ renderMustache t = snd . renderMustacheW t -- -- @since 1.1.1 renderMustacheW :: Template -> Value -> ([MustacheWarning], TL.Text) -renderMustacheW t = - runRender (renderPartial (templateActual t) Nothing renderNode) t +renderMustacheW template value = + runR (renderTemplate (templateActual template)) value (templateCache template) + +-- | Main template rendering function. +renderTemplate :: PName -> R () +renderTemplate name = do + mns <- lookupTemplate name + case mns of + Just ns -> mapM_ renderNode ns + Nothing -> return () + +---------------------------------------------------------------------------- +-- Node rendering -- | Render a single 'Node'. -renderNode :: Node -> Render () -renderNode (TextBlock txt) = outputIndented txt +renderNode :: Node -> R () +renderNode (TextBlock text) = txt IndentEveryLine text renderNode (EscapedVar k) = - lookupKey k >>= renderValue k >>= outputRaw . escapeHtml + lookupKey k >>= renderValue k >>= txt IndentOnlyFirstLine . escapeHtml renderNode (UnescapedVar k) = - lookupKey k >>= renderValue k >>= outputRaw + lookupKey k >>= renderValue k >>= txt IndentOnlyFirstLine renderNode (Section k ns) = do val <- lookupKey k - enterSection k $ - unless (isBlank val) $ + unless (isBlank val) $ + addPrefix k $ case val of Array xs -> forM_ (V.toList xs) $ \x -> - addToLocalContext x (renderMany renderNode ns) + addContext x (mapM_ renderNode ns) _ -> - addToLocalContext val (renderMany renderNode ns) + addContext val (mapM_ renderNode ns) renderNode (InvertedSection k ns) = do val <- lookupKey k when (isBlank val) $ - renderMany renderNode ns -renderNode (Partial pname indent) = - renderPartial pname indent renderNode + mapM_ renderNode ns +renderNode (Partial pname mindent) = do + mns <- lookupTemplate pname + let adjustIndent = case mindent of + Nothing -> id + Just indent -> incrementIndentBy indent + adjustIndent . resetPrefix $ case mns of + Nothing -> txt IndentEveryLine "" + Just ns -> mapM_ renderNode ns ---------------------------------------------------------------------------- --- 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 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 #-} - --- | Output a piece of strict 'Text'. -outputRaw :: Text -> Render () -outputRaw = tellBuilder . B.fromText -{-# INLINE outputRaw #-} - --- | Output indentation consisting of appropriate number of spaces. -outputIndent :: Render () -outputIndent = asks rcIndent >>= outputRaw . buildIndent -{-# INLINE outputIndent #-} - --- | Output piece of strict 'Text' with added indentation. -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 #-} - --- | 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 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 #-} - --- | Get collection of 'Node's for actual template. -getNodes :: Render [Node] -getNodes = do - Template actual cache <- asks rcTemplate - return (M.findWithDefault [] actual cache) -{-# INLINE getNodes #-} - --- | Render many nodes. -renderMany :: - -- | How to render a node - (Node -> Render ()) -> - -- | The collection of nodes to 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 +-- Value lookup -- | Lookup a 'Value' by its 'Key'. -lookupKey :: Key -> Render Value -lookupKey (Key []) = NE.head <$> asks rcContext +lookupKey :: Key -> R Value +lookupKey (Key []) = NE.head <$> getContext 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 + context <- getContext + prefix <- getPrefix + let f x = asum (simpleLookup False (x <> k) <$> context) + case asum (fmap (f . Key) . reverse . tails $ unKey prefix) of Nothing -> - Null <$ tellWarning (MustacheVariableNotFound (p <> k)) + Null <$ addWarning (MustacheVariableNotFound (prefix <> k)) Just r -> return r --- | Lookup a 'Value' by traversing another 'Value' using given 'Key' as --- “path”. +-- | 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 @@ -217,45 +125,9 @@ simpleLookup c (Key (k : ks)) (Object m) = Nothing -> if c then Just Null else Nothing Just v -> simpleLookup True (Key ks) v simpleLookup _ _ _ = Nothing -{-# INLINE simpleLookup #-} - --- | Enter the section by adding given 'Key' prefix to current prefix. -enterSection :: Key -> Render a -> Render a -enterSection p = - local (\rc -> rc {rcPrefix = p <> rcPrefix 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 v = - local (\rc -> rc {rcContext = NE.cons v (rcContext rc)}) -{-# INLINE addToLocalContext #-} ---------------------------------------------------------------------------- --- Helpers - --- | Register a warning. -tellWarning :: MustacheWarning -> Render () -tellWarning w = modify' $ \(S ws b) -> S (ws . (w :)) b - --- | Register a piece of output. -tellBuilder :: B.Builder -> Render () -tellBuilder b' = modify' $ \(S ws b) -> S ws (b <> b') - --- | Add two @'Maybe' 'Pos'@ values together. -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 (mkPos $ unPos x + unPos y - 1) -{-# INLINE addIndents #-} - --- | Build indentation of specified length by repeating the space character. -buildIndent :: Maybe Pos -> Text -buildIndent Nothing = "" -buildIndent (Just p) = let n = fromIntegral (unPos p) - 1 in T.replicate n " " -{-# INLINE buildIndent #-} +-- Helper functions -- | Select invisible values. isBlank :: Value -> Bool @@ -265,35 +137,31 @@ isBlank (Object m) = Aeson.KeyMap.null m isBlank (Array a) = V.null a isBlank (String s) = T.null s isBlank _ = False -{-# INLINE isBlank #-} -- | Render Aeson's 'Value' /without/ HTML escaping. -renderValue :: Key -> Value -> Render Text +renderValue :: Key -> Value -> R Text renderValue k v = case v of Null -> return "" String str -> return str Object _ -> do - tellWarning (MustacheDirectlyRenderedValue k) - render v + addWarning (MustacheDirectlyRenderedValue k) + return $ TL.toStrict $ TL.decodeUtf8 $ encode v Array _ -> do - tellWarning (MustacheDirectlyRenderedValue k) - render v - _ -> render v - where - render = return . TL.toStrict . TL.decodeUtf8 . encode -{-# INLINE renderValue #-} + addWarning (MustacheDirectlyRenderedValue k) + return $ TL.toStrict $ TL.decodeUtf8 $ encode v + _ -> return $ TL.toStrict $ TL.decodeUtf8 $ encode v --- | Escape HTML represented as strict 'Text'. +-- | Escape HTML represented as strict 'Text' in a single pass. escapeHtml :: Text -> Text -escapeHtml txt = - foldr - (uncurry T.replace) - txt - [ ("\"", """), - ("'", "'"), - ("<", "<"), - (">", ">"), - ("&", "&") - ] -{-# INLINE escapeHtml #-} +escapeHtml = TL.toStrict . TLB.toLazyText . T.foldl' escapeChar mempty + where + escapeChar :: TLB.Builder -> Char -> TLB.Builder + escapeChar acc c = + acc <> case c of + '&' -> TLB.fromText "&" + '<' -> TLB.fromText "<" + '>' -> TLB.fromText ">" + '"' -> TLB.fromText """ + '\'' -> TLB.fromText "'" + _ -> TLB.singleton c diff --git a/Text/Mustache/Render/Internal.hs b/Text/Mustache/Render/Internal.hs new file mode 100644 index 0000000..9cbcd74 --- /dev/null +++ b/Text/Mustache/Render/Internal.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Text.Mustache.Render.Internal +-- Copyright : © 2016–present Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Internal machinery of the rendering monad. +-- +-- @since 2.4.0 +module Text.Mustache.Render.Internal + ( R, + runR, + IndentationPolicy (..), + txt, + incrementIndentBy, + addContext, + addPrefix, + resetPrefix, + addWarning, + getContext, + getPrefix, + lookupTemplate, + ) +where + +import Control.Monad.Reader (ReaderT, asks, local, runReaderT) +import Control.Monad.State.Strict (State, execState, modify') +import Data.Aeson (Value) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder qualified as TLB +import Text.Megaparsec.Pos (Pos, mkPos, pos1, unPos) +import Text.Mustache.Type (Key, MustacheWarning, Node, PName) + +-- | The 'R' monad supports printing with some helpful functionality to deal +-- with indentation. +newtype R a = R (ReaderT RC (State SC) a) + deriving (Functor, Applicative, Monad) + +-- | The reader context of 'R'. +data RC = RC + { -- | Indentation level, as the column index we need to start from after + -- a newline + rcIndent :: !Pos, + -- | The context stack + rcContext :: NonEmpty Value, + -- | The prefix accumulated by entering sections + rcPrefix :: Key, + -- | The template cache + rcTemplateCache :: Map PName [Node] + } + +-- | The state context of 'R'. +data SC = SC + { -- | Index of the next column to render + scColumn :: !Pos, + -- | Are we at the beginning of a newline? + scBeginningOfLine :: !Bool, + -- | Mustache warnings + scWarnings :: [MustacheWarning] -> [MustacheWarning], + -- | The output we have rendered so far (using Builder for efficiency) + scBuilder :: TLB.Builder + } + +-- | The indentation policy to use when rendering text. +data IndentationPolicy + = -- | Indent every line + IndentEveryLine + | -- | Only indent the very first line, provided we are at the beginning + -- of the line + IndentOnlyFirstLine + +-- | Run the 'R' monad. +runR :: + -- | Monad to run + R () -> + -- | The Context to use + Value -> + -- | The template cache + Map PName [Node] -> + ([MustacheWarning], TL.Text) +runR (R m) v cache = (scWarnings s [], TLB.toLazyText (scBuilder s)) + where + rc = + RC + { rcIndent = pos1, + rcContext = v :| [], + rcPrefix = mempty, + rcTemplateCache = cache + } + sc = + SC + { scColumn = pos1, + scBeginningOfLine = True, + scWarnings = id, + scBuilder = mempty + } + s = execState (runReaderT m rc) sc + +-- | Output text, handling indentation appropriately. When we're at the +-- beginning of a line and the indentation level is non-zero, we first +-- output the appropriate amount of spaces. +txt :: + -- | Indentation policy to use + IndentationPolicy -> + -- | The text to output + Text -> + R () +txt _ "" = R $ do + indent <- asks rcIndent + modify' $ \sc -> + if scBeginningOfLine sc && indent > pos1 + then + let indentText = T.replicate (unPos indent - 1) " " + in sc + { scColumn = mkPos (unPos indent), + scBeginningOfLine = False, + scBuilder = scBuilder sc <> TLB.fromText indentText + } + else sc +txt policy t = R $ do + indent <- asks rcIndent + modify' $ \sc -> + let processLine isFirstLine line sc' = + let shouldIndent = case policy of + IndentEveryLine -> + scBeginningOfLine sc' + && not (T.null line) + && indent > pos1 + IndentOnlyFirstLine -> + isFirstLine + && scBeginningOfLine sc' + && not (T.null line) + && indent > pos1 + indentText = + if shouldIndent + then T.replicate (unPos indent - 1) " " + else T.empty + indentedLine = indentText <> line + newColumn = + if T.null indentedLine + then scColumn sc' + else mkPos (unPos (scColumn sc') + T.length indentedLine) + in sc' + { scColumn = newColumn, + scBeginningOfLine = T.null indentedLine && scBeginningOfLine sc', + scBuilder = scBuilder sc' <> TLB.fromText indentedLine + } + go _ [] sc' = sc' + go isFirst [line] sc' = processLine isFirst line sc' + go isFirst (line : rest) sc' = + let sc'' = processLine isFirst line sc' + sc''' = + sc'' + { scColumn = pos1, + scBeginningOfLine = True, + scBuilder = scBuilder sc'' <> TLB.singleton '\n' + } + in go False rest sc''' + lines' = T.lines t + endsWithNewline = not (T.null t) && T.last t == '\n' + processedState = go True lines' sc + in if endsWithNewline + then + processedState + { scColumn = pos1, + scBeginningOfLine = True, + scBuilder = scBuilder processedState <> TLB.singleton '\n' + } + else processedState + +-- | Increment the indentation level by the given amount. +incrementIndentBy :: Pos -> R a -> R a +incrementIndentBy n (R m) = + R $ + local (\rc -> rc {rcIndent = mkPos (unPos (rcIndent rc) + unPos n - 1)}) m + +-- | Add a value to the context stack. +addContext :: Value -> R a -> R a +addContext v (R m) = + R $ + local (\rc -> rc {rcContext = NE.cons v (rcContext rc)}) m + +-- | Add to the key prefix. +addPrefix :: Key -> R a -> R a +addPrefix key (R m) = + R $ + local (\rc -> rc {rcPrefix = rcPrefix rc <> key}) m + +-- | Reset prefix. +resetPrefix :: R a -> R a +resetPrefix (R m) = + R $ + local (\rc -> rc {rcPrefix = mempty}) m + +-- | Add a warning to the warnings list. +addWarning :: MustacheWarning -> R () +addWarning w = R $ + modify' $ + \sc -> sc {scWarnings = scWarnings sc . (w :)} + +-- | Get the current context stack. +getContext :: R (NonEmpty Value) +getContext = R $ asks rcContext + +-- | Get the current key prefix. +getPrefix :: R Key +getPrefix = R $ asks rcPrefix + +-- | Lookup the template by its name. +lookupTemplate :: PName -> R (Maybe [Node]) +lookupTemplate name = R $ asks $ \rc -> + M.lookup name (rcTemplateCache rc) diff --git a/stache.cabal b/stache.cabal index c593eb4..1b2f2e1 100644 --- a/stache.cabal +++ b/stache.cabal @@ -37,6 +37,7 @@ library Text.Mustache.Compile.TH Text.Mustache.Parser Text.Mustache.Render + Text.Mustache.Render.Internal Text.Mustache.Type default-language: GHC2021 diff --git a/tests/Text/Mustache/RenderSpec.hs b/tests/Text/Mustache/RenderSpec.hs index 9037790..da0b2e3 100644 --- a/tests/Text/Mustache/RenderSpec.hs +++ b/tests/Text/Mustache/RenderSpec.hs @@ -152,6 +152,121 @@ spec = describe "renderMustache" $ do ] in renderMustache template Null `shouldBe` " one\n two\n three*" + context "when rendering a partial with list sections" $ do + it "maintains indentation for all iterations in a partial with sections" $ + let template = + Template "test" $ + M.fromList + [ ("test", [TextBlock "Subnets:\n", Partial "myPartial" (Just $ mkPos 3)]), + ( "myPartial", + [ Section + (key "subnets") + [ TextBlock "- ", + EscapedVar (Key []), + TextBlock "\n\"Test string\"\n" + ] + ] + ) + ] + value = + object + [ "subnets" + .= [ "subnet-0a0a0a0a" :: Text, + "subnet-0b0b0b0b", + "subnet-0c0c0c0c" + ] + ] + in renderMustache template value + `shouldBe` "Subnets:\n - subnet-0a0a0a0a\n \"Test string\"\n - subnet-0b0b0b0b\n \"Test string\"\n - subnet-0c0c0c0c\n \"Test string\"\n" + context "when rendering nested partials with list sections" $ do + it "maintains indentation through multiple levels of nested partials with sections" $ + let template = + Template "test" $ + M.fromList + [ ("test", [TextBlock "Configuration:\n", Partial "level1" (Just $ mkPos 3)]), + ( "level1", + [ TextBlock "Services:\n", + Partial "level2" (Just $ mkPos 3) + ] + ), + ( "level2", + [ Section + (key "services") + [ TextBlock "- name: ", + EscapedVar (key "name"), + TextBlock "\n port: ", + EscapedVar (key "port"), + TextBlock "\n" + ] + ] + ) + ] + value = + object + [ "services" + .= [ object ["name" .= ("web" :: Text), "port" .= (8080 :: Int)], + object ["name" .= ("api" :: Text), "port" .= (3000 :: Int)], + object ["name" .= ("db" :: Text), "port" .= (5432 :: Int)] + ] + ] + in renderMustache template value + `shouldBe` "Configuration:\n Services:\n - name: web\n port: 8080\n - name: api\n port: 3000\n - name: db\n port: 5432\n" + it "handles mixed content with nested partials and multiple sections" $ + let template = + Template "test" $ + M.fromList + [ ( "test", + [ TextBlock "Project:\n", + Section + (key "project") + [ TextBlock " Name: ", + EscapedVar (key "name"), + TextBlock "\n", + Partial "components" (Just $ mkPos 3) + ] + ] + ), + ( "components", + [ TextBlock "Components:\n", + Section + (key "components") + [ Partial "component-detail" (Just $ mkPos 3) + ] + ] + ), + ( "component-detail", + [ TextBlock "- ", + EscapedVar (key "type"), + TextBlock ":\n", + Section + (key "items") + [ TextBlock " * ", + EscapedVar (Key []), + TextBlock "\n" + ] + ] + ) + ] + value = + object + [ "project" + .= [ object + [ "name" .= ("MyApp" :: Text), + "components" + .= [ object + [ "type" .= ("Frontend" :: Text), + "items" .= ["React" :: Text, "TypeScript", "CSS"] + ], + object + [ "type" .= ("Backend" :: Text), + "items" .= ["Node.js" :: Text, "Express", "MongoDB"] + ] + ] + ] + ] + ] + in renderMustache template value + `shouldBe` "Project:\n Name: MyApp\n Components:\n - Frontend:\n * React\n * TypeScript\n * CSS\n - Backend:\n * Node.js\n * Express\n * MongoDB\n" context "when rendering a nested partial" $ it "renders outer partial correctly" $ let template =