Lua: add pandoc.scaffolding.Writer (#8377)

This can be used to reduce boilerplate in custom writers.

6 files changed, 439 insertions, 0 deletions

diff --git a/doc/custom-writers.md b/doc/custom-writers.md
index aa2796d00..0cedec7d7 100644
--- a/doc/custom-writers.md
+++ b/doc/custom-writers.md
@@ -126,6 +126,63 @@ end
 
 [Lua filters documentation]: https://pandoc.org/lua-filters.html
 
+## Reducing boilerplate with `pandoc.scaffolding.Writer`
+
+The `pandoc.scaffolding.Writer` structure is a custom writer scaffold
+that serves to avoid common boilerplate code when defining a custom
+writer. The object can be used as a function and allows to skip details
+like metadata and template handling, requiring only the render functions
+for each AST element type.
+
+The value of `pandoc.scaffolding.Writer` is a function that should
+usually be assigned to the global `Writer`:
+
+``` lua
+Writer = pandoc.scaffolding.Writer
+```
+
+The render functions for Block and Inline values can then be added
+to `Writer.Block` and `Writer.Inline`, respectively. The functions
+are passed the element and the WriterOptions.
+
+``` lua
+Writer.Inline.Str = function (str)
+  return str.text
+end
+Writer.Inline.SoftBreak = function (_, opts)
+  return opts.wrap_text == "wrap-preserve"
+    and cr
+    or space
+end
+Writer.Inline.LineBreak = cr
+
+Writer.Block.Para = function (para)
+  return {Writer.Inlines(para.content), pandoc.layout.blankline}
+end
+```
+
+The render functions must return a string, a pandoc.layout *Doc*
+element, or a list of such elements. In the latter case, the
+values are concatenated as if they were passed to
+`pandoc.layout.concat`. If the value does not depend on the input,
+a constant can be used as well.
+
+The tables `Writer.Block` and `Writer.Inline` can be used as
+functions; they apply the right render function for an element of
+the respective type. E.g., `Writer.Block(pandoc.Para 'x')` will
+delegate to the `Writer.Para` render function and will return the
+result of that call.
+
+Similarly, the functions `Writer.Blocks` and `Writer.Inlines` can
+be used to render lists of elements, and `Writer.Pandoc` renders
+the document's blocks.
+
+All predefined functions can be overwritten when needed.
+
+The resulting Writer uses the render functions to handle metadata
+values and converts them to template variables. The template is
+applied automatically if one is given.
+
 # Classic style
 
 A writer using the classic style defines rendering functions for
diff --git a/doc/lua-filters.md b/doc/lua-filters.md
index 90daa1365..6435280e6 100644
--- a/doc/lua-filters.md
+++ b/doc/lua-filters.md
@@ -5167,6 +5167,19 @@ Returns
 
 [Doc]: #type-doc
 
+# Module pandoc.scaffolding
+
+Scaffolding for custom writers.
+
+## Writer {#pandoc.scaffolding.writer}
+
+A structure to be used as a `Writer` function; the construct
+handles most of the boilerplate, expecting only render functions
+for all AST elements. See the documentation for custom writers for
+details.
+
+
+
 # Module pandoc.template
 
 Handle pandoc templates.
diff --git a/pandoc-lua-engine/pandoc-lua-engine.cabal b/pandoc-lua-engine/pandoc-lua-engine.cabal
index 8ef0cca58..9910b9fef 100644
--- a/pandoc-lua-engine/pandoc-lua-engine.cabal
+++ b/pandoc-lua-engine/pandoc-lua-engine.cabal
@@ -79,6 +79,7 @@ library
                      , Text.Pandoc.Lua.Module.Format
                      , Text.Pandoc.Lua.Module.MediaBag
                      , Text.Pandoc.Lua.Module.Pandoc
+                     , Text.Pandoc.Lua.Module.Scaffolding
                      , Text.Pandoc.Lua.Module.System
                      , Text.Pandoc.Lua.Module.Template
                      , Text.Pandoc.Lua.Module.Types
@@ -88,6 +89,7 @@ library
                      , Text.Pandoc.Lua.Reader
                      , Text.Pandoc.Lua.Writer
                      , Text.Pandoc.Lua.Writer.Classic
+                     , Text.Pandoc.Lua.Writer.Scaffolding
 
   build-depends:       SHA                   >= 1.6     && < 1.7
                      , bytestring            >= 0.9     && < 0.12
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs
index 3eeab3d7c..a05d68355 100644
--- a/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs
@@ -40,6 +40,7 @@ import qualified HsLua.Module.Zip as Module.Zip
 import qualified Text.Pandoc.Lua.Module.Format as Pandoc.Format
 import qualified Text.Pandoc.Lua.Module.MediaBag as Pandoc.MediaBag
 import qualified Text.Pandoc.Lua.Module.Pandoc as Module.Pandoc
+import qualified Text.Pandoc.Lua.Module.Scaffolding as Pandoc.Scaffolding
 import qualified Text.Pandoc.Lua.Module.System as Pandoc.System
 import qualified Text.Pandoc.Lua.Module.Template as Pandoc.Template
 import qualified Text.Pandoc.Lua.Module.Types as Pandoc.Types
@@ -83,6 +84,7 @@ loadedModules :: [Module PandocError]
 loadedModules =
   [ Pandoc.Format.documentedModule
   , Pandoc.MediaBag.documentedModule
+  , Pandoc.Scaffolding.documentedModule
   , Pandoc.System.documentedModule
   , Pandoc.Template.documentedModule
   , Pandoc.Types.documentedModule
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Module/Scaffolding.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Module/Scaffolding.hs
new file mode 100644
index 000000000..8bafe47cb
--- /dev/null
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Module/Scaffolding.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+   Module      : Text.Pandoc.Lua.Module.Scaffolding
+   Copyright   : Copyright © 2022 Albert Krewinkel, John MacFarlane
+   License     : GNU GPL, version 2 or above
+   Maintainer  : Albert Krewinkel <[email protected]>
+
+Scaffolding for custom Writers.
+-}
+module Text.Pandoc.Lua.Module.Scaffolding
+  ( documentedModule
+  ) where
+
+import HsLua
+import Text.Pandoc.Error (PandocError)
+import Text.Pandoc.Lua.Writer.Scaffolding (pushWriterScaffolding)
+import qualified Data.Text as T
+
+-- | The "pandoc.template" module.
+documentedModule :: Module PandocError
+documentedModule = Module
+  { moduleName = "pandoc.scaffolding"
+  , moduleDescription = T.unlines
+    [ "Scaffolding for custom writers."
+    ]
+  , moduleFields = [writerScaffolding]
+  , moduleOperations = []
+  , moduleFunctions = []
+  }
+
+-- | Template module functions.
+writerScaffolding :: Field PandocError
+writerScaffolding = Field
+  { fieldName = "Writer"
+  , fieldDescription = T.unlines
+    [ "An object to be used as a `Writer` function; the construct handles"
+    , "most of the boilerplate, expecting only render functions for all"
+    , "AST elements"
+    ]
+  , fieldPushValue = do
+      pushWriterScaffolding
+      -- pretend that it's a submodule so we get better error messages
+      getfield registryindex loaded
+      pushvalue (nth 2)
+      setfield (nth 2) (submod "Writer")
+      -- same for fields "Block" and "Inline"
+      getfield (nth 2) "Inline" *> setfield (nth 2) (submod "Writer.Inline")
+      getfield (nth 2) "Block" *> setfield (nth 2) (submod "Writer.Block")
+
+      pop 1 -- remove "LOADED_TABLE"
+  }
+ where submod x = moduleName documentedModule <> "." <> x
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Writer/Scaffolding.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Writer/Scaffolding.hs
new file mode 100644
index 000000000..6a3fb184e
--- /dev/null
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Writer/Scaffolding.hs
@@ -0,0 +1,313 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE TypeApplications    #-}
+{- |
+   Module      : Text.Pandoc.Lua.Writer.Scaffolding
+   Copyright   : © 2022 Albert Krewinkel
+   License     : GPL-2.0-or-later
+   Maintainer  : Albert Krewinkel <[email protected]>
+
+Conversion of Pandoc documents using a custom Lua writer.
+-}
+module Text.Pandoc.Lua.Writer.Scaffolding
+  ( pushWriterScaffolding
+  ) where
+
+import Control.Monad ((<$!>), void)
+import Data.ByteString (ByteString)
+import Data.Data (dataTypeConstrs, dataTypeOf, showConstr, toConstr)
+import Data.Default (def)
+import Data.List (intersperse)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.String (IsString (fromString))
+import HsLua
+import HsLua.Module.DocLayout (peekDoc, pushDoc)
+import Text.DocLayout (Doc, blankline, render)
+import Text.DocTemplates (Context)
+import Text.Pandoc.Definition
+import Text.Pandoc.Error (PandocError (..))
+import Text.Pandoc.Options (WriterOptions (..), WrapOption(..))
+import Text.Pandoc.Lua.PandocLua ()
+import Text.Pandoc.Lua.Marshal.AST
+import Text.Pandoc.Lua.Marshal.Context (peekContext)
+import Text.Pandoc.Lua.Marshal.WriterOptions ( peekWriterOptions
+                                             , pushWriterOptions)
+import Text.Pandoc.Templates (renderTemplate)
+import Text.Pandoc.Writers.Shared (metaToContext, setField)
+import qualified Data.Text as T
+import qualified Text.Pandoc.UTF8 as UTF8
+
+-- | Convert Pandoc to custom markup.
+pushWriterScaffolding :: LuaE PandocError NumResults
+pushWriterScaffolding = do
+  newtable
+    *> pushWriterMT *> setmetatable (nth 2)
+  writer <- toWriterTable top
+  addField "Blocks"  $ pushDocumentedFunction (blocksFn writer)
+  addField "Inlines" $ pushDocumentedFunction (inlinesFn writer)
+  addField "Block"   $ newtable *> pushBlockMT  writer *> setmetatable (nth 2)
+  addField "Inline"  $ newtable *> pushInlineMT writer *> setmetatable (nth 2)
+  addField "Pandoc"  $ pushDocumentedFunction $ lambda
+    ### (\(Pandoc _ blks) -> do
+            pushWriterTable writer
+            getfield' top "Blocks"
+            pushBlocks blks
+            callTrace 1 1
+            pure (NumResults 1))
+    <#> parameter peekPandoc "Pandoc" "doc" ""
+    =?> "rendered doc"
+  freeWriter writer
+  return 1
+ where
+  blocksFn w = lambda
+    ### (\blocks msep -> blockListToCustom w msep blocks)
+    <#> parameter peekBlocks "Blocks" "blocks" ""
+    <#> opt (parameter peekDocFuzzy "Doc" "sep" "")
+    =#> functionResult pushDoc "Doc" ""
+  inlinesFn w = lambda
+    ### inlineListToCustom w
+    <#> parameter peekInlines "Inlines" "inlines" ""
+    =#> functionResult pushDoc "Doc" ""
+  pushBlockMT writer = do
+    newtable
+    addField "__call" $ pushDocumentedFunction $ lambda
+      ### blockToCustom
+      <#> parameter peekWriter "table" "writer" ""
+      <#> parameter peekBlockFuzzy "Block" "block" ""
+      =#> functionResult pushDoc "Doc" "rendered blocks"
+    addField "__index" $
+      -- lookup missing fields in the main Writer table
+      pushWriterTable writer
+  pushInlineMT writer = do
+    newtable
+    addField "__call" $ pushDocumentedFunction $ lambda
+      ### inlineToCustom
+      <#> parameter peekWriter "table" "writer" ""
+      <#> parameter peekInlineFuzzy "Inline" "inline" ""
+      =#> functionResult pushDoc "Doc" "rendered inline"
+    addField "__index" $ do
+      -- lookup missing fields in the main Writer table
+      pushWriterTable writer
+
+pushWriterMT :: LuaE PandocError ()
+pushWriterMT = do
+  newtable
+  addField "__call" $ pushDocumentedFunction $ lambda
+    ### (\writer doc mopts -> runWriter writer doc mopts)
+    <#> parameter peekWriter "table" "writer" ""
+    <#> parameter peekPandoc "Pandoc" "doc" ""
+    <#> opt (parameter peekWriterOptions "WriterOptions" "opts" "")
+    =#> functionResult pushText "string" "rendered document"
+  addField "__index" . pushDocumentedFunction $ lambda
+    ### (\_writer key -> handleMissingField key)
+    <#> parameter pure "table"  "writer" ""
+    <#> parameter (liftLua . tostring') "string" "key" ""
+    =#> functionResult (const pushnil) "string" ""
+
+
+addField :: LuaError e => Name -> LuaE e a -> LuaE e ()
+addField name action = do
+  pushName name
+  action
+  rawset (nth 3)
+
+getfield' :: LuaError e => StackIndex -> Name -> LuaE e HsLua.Type
+getfield' idx name = do
+  aidx <- absindex idx
+  pushName name
+  rawget aidx >>= \case
+    TypeNil -> pop 1 *> getfield aidx name
+    ty      -> pure ty
+
+-- | A writer table is just an absolute stack index.
+newtype WriterTable = WriterTable Reference
+
+toWriterTable :: LuaError e => StackIndex -> LuaE e WriterTable
+toWriterTable idx = WriterTable <$!> do
+  pushvalue idx
+  ref registryindex
+
+peekWriter :: LuaError e => Peeker e WriterTable
+peekWriter = liftLua . toWriterTable
+
+pushWriterTable :: LuaError e => Pusher e WriterTable
+pushWriterTable (WriterTable wref) = void $ getref registryindex wref
+
+writerOptionsField :: Name
+writerOptionsField = "Pandoc Writer WriterOptions"
+
+freeWriter :: WriterTable -> LuaE e ()
+freeWriter (WriterTable wref) = unref registryindex wref
+
+pushOpts :: LuaE PandocError ()
+pushOpts = void $ getfield' registryindex writerOptionsField
+
+runWriter :: WriterTable -> Pandoc -> Maybe WriterOptions
+          -> LuaE PandocError Text
+runWriter writer doc@(Pandoc meta _blks) mopts = do
+  let opts = fromMaybe def mopts
+  pushWriterOptions opts *>
+    setfield registryindex writerOptionsField
+
+  (body, mcontext) <- runPeek (pandocToCustom writer doc) >>= force . \case
+    Failure msg contexts -> Failure (cleanupTrace msg) contexts
+    s -> s
+
+  -- convert metavalues to a template context (variables)
+  defaultContext <- metaToContext opts
+                    (blockListToCustom writer Nothing)
+                    (inlineListToCustom writer)
+                    meta
+  let context = setField "body" body
+              $ fromMaybe defaultContext mcontext
+
+  let colwidth = if writerWrapText opts == WrapAuto
+                    then Just $ writerColumns opts
+                    else Nothing
+
+  return $ render colwidth $
+    case writerTemplate opts of
+       Nothing  -> body
+       Just tpl -> renderTemplate tpl context
+
+-- | Keep exactly one traceback and clean it up. This wouldn't be
+-- necessary if the @pcallTrace@ function would do nothing whenever the
+-- error already included a trace, but that would require some bigger
+-- changes; removing the additional traces in this post-process step is
+-- much easier (for now).
+cleanupTrace :: ByteString -> ByteString
+cleanupTrace msg = UTF8.fromText . T.intercalate "\n" $
+  let tmsg = T.lines $ UTF8.toText msg
+      traceStart = (== "stack traceback:")
+  in case break traceStart tmsg of
+        (x, t:traces) -> (x <>) . (t:) $
+                         let (firstTrace, rest) = break traceStart traces
+                             isPeekContext = ("\twhile " `T.isPrefixOf`)
+                             isUnknownCFn = (== "\t[C]: in ?")
+                         in filter (not . isUnknownCFn) firstTrace <>
+                            filter isPeekContext rest
+        _ -> tmsg
+
+-- | Pushes the field in the writer table.
+getWriterField :: LuaError e
+               => WriterTable -> Name -> LuaE e HsLua.Type
+getWriterField writer name = do
+  pushWriterTable writer
+  getfield' top name <* remove (nth 2)
+
+-- | Looks up @Writer.subtable.field@; tries @Writer.field@ as a fallback if the
+-- subtable field is @nil@.
+getNestedWriterField :: LuaError e
+                     => WriterTable -> Name -> Name -> LuaE e HsLua.Type
+getNestedWriterField writer subtable field = do
+  pushWriterTable writer
+  getfield' top subtable >>= \case
+    TypeNil -> TypeNil <$ remove (nth 2) -- remove Writer table
+    _       -> getfield' top field
+               -- remove Writer and subtable
+               <* remove (nth 3) <* remove (nth 2)
+
+pandocToCustom :: WriterTable -> Pandoc
+               -> Peek PandocError (Doc Text, Maybe (Context Text))
+pandocToCustom writer doc = withContext "rendering Pandoc" $ do
+  callStatus <- liftLua $ do
+    getWriterField writer "Pandoc"
+    pushPandoc doc
+    pushOpts
+    pcallTrace 2 2
+  case callStatus of
+    OK -> ((,) <$> peekDocFuzzy (nth 2) <*> orNil peekContext top)
+          `lastly` pop 2
+    _  -> failPeek =<< liftLua (tostring' top)
+
+blockToCustom :: WriterTable -> Block -> LuaE PandocError (Doc Text)
+blockToCustom writer blk = forcePeek $ renderBlock writer blk
+
+renderBlock :: WriterTable -> Block -> Peek PandocError (Doc Text)
+renderBlock writer blk = do
+  let constrName = fromString . showConstr . toConstr $ blk
+  withContext ("rendering Block `" <> constrName <> "`") $
+    liftLua (getNestedWriterField writer "Block" constrName) >>= \case
+      TypeNil -> failPeek =<< typeMismatchMessage "function or Doc" top
+      _       -> callOrDoc (pushBlock blk)
+
+inlineToCustom :: WriterTable -> Inline -> LuaE PandocError (Doc Text)
+inlineToCustom writer inln = forcePeek $ renderInline writer inln
+
+renderInline :: WriterTable -> Inline -> Peek PandocError (Doc Text)
+renderInline writer inln = do
+  let constrName = fromString . showConstr . toConstr $ inln
+  withContext ("rendering Inline `" <> constrName <> "`") $ do
+    liftLua (getNestedWriterField writer "Inline" constrName) >>= \case
+      TypeNil -> failPeek =<< typeMismatchMessage "function or Doc" top
+      _       -> callOrDoc (pushInline inln)
+
+-- | If the value at the top of the stack can be called as a function,
+-- then push the element and writer options to the stack and call it;
+-- otherwise treat it as a plain Doc value
+callOrDoc :: LuaE PandocError ()
+          -> Peek PandocError (Doc Text)
+callOrDoc pushElement = do
+  liftLua (ltype top) >>= \case
+    TypeFunction -> peekCall
+    _            ->
+      liftLua (getmetafield top "__call") >>= \case
+        TypeNil -> peekDocFuzzy top
+        _       -> liftLua (pop 1) *> peekCall
+ where
+   peekCall :: Peek PandocError (Doc Text)
+   peekCall =
+     liftLua (pushElement *> pushOpts *> pcallTrace 2 1) >>= \case
+       OK -> peekDocFuzzy top
+       _  -> failPeek =<< liftLua (tostring' top)
+
+blockListToCustom :: WriterTable -> Maybe (Doc Text) -> [Block]
+                  -> LuaE PandocError (Doc Text)
+blockListToCustom writer msep blocks = forcePeek $
+  renderBlockList writer msep blocks
+
+inlineListToCustom :: WriterTable -> [Inline] -> LuaE PandocError (Doc Text)
+inlineListToCustom writer inlines = forcePeek $
+  renderInlineList writer inlines
+
+renderBlockList :: WriterTable -> Maybe (Doc Text) -> [Block]
+                -> Peek PandocError (Doc Text)
+renderBlockList writer msep blocks = withContext "rendering Blocks" $ do
+  let addSeps = intersperse $ fromMaybe blankline msep
+  mconcat . addSeps <$> mapM (renderBlock writer) blocks
+
+renderInlineList :: WriterTable -> [Inline] -> Peek PandocError (Doc Text)
+renderInlineList writer inlines = withContext "rendering Inlines" $ do
+  mconcat <$> mapM (renderInline writer) inlines
+
+orNil :: Peeker e a -> Peeker e (Maybe a)
+orNil p idx = liftLua (ltype idx) >>= \case
+  TypeNil  -> pure Nothing
+  TypeNone -> pure Nothing
+  _        -> Just <$> p idx
+
+peekDocFuzzy :: LuaError e => Peeker e (Doc Text)
+peekDocFuzzy idx = liftLua (ltype idx) >>= \case
+  TypeTable -> mconcat <$!> peekList peekDoc idx
+  _         -> peekDoc idx
+
+handleMissingField :: LuaError e => ByteString -> LuaE e ()
+handleMissingField key' =
+  let key = UTF8.toString key'
+      blockNames  = map (fromString . show) . dataTypeConstrs . dataTypeOf
+                      $ HorizontalRule
+      inlineNames = map (fromString . show) . dataTypeConstrs . dataTypeOf
+                      $ Space
+      mtypeName = case () of
+       _ | key `elem` blockNames  -> Just "Block"
+       _ | key `elem` inlineNames -> Just "Inline"
+       _                          -> Nothing
+  in case mtypeName of
+       Just typeName  -> failLua $
+                         "No render function for " <> typeName <> " value " <>
+                         "'" <> key <> "';\ndefine a function `Writer." <>
+                         typeName <> "." <> key <> "` that returns " <>
+                         "a string or Doc."
+       _ -> pure ()