fixup! T.P.Scripting: add CustomComponents, and change...issue8417

6 files changed, 188 insertions, 16 deletions

diff --git a/pandoc-lua-engine/pandoc-lua-engine.cabal b/pandoc-lua-engine/pandoc-lua-engine.cabal
index 7cd54a6b6..d58e3e1a6 100644
--- a/pandoc-lua-engine/pandoc-lua-engine.cabal
+++ b/pandoc-lua-engine/pandoc-lua-engine.cabal
@@ -64,7 +64,8 @@ library
   import:              common-options
   hs-source-dirs:      src
   exposed-modules:     Text.Pandoc.Lua
-  other-modules:       Text.Pandoc.Lua.Filter
+  other-modules:       Text.Pandoc.Lua.Custom
+                     , Text.Pandoc.Lua.Filter
                      , Text.Pandoc.Lua.Global
                      , Text.Pandoc.Lua.Init
                      , Text.Pandoc.Lua.Marshal.CommonState
@@ -86,7 +87,6 @@ library
                      , Text.Pandoc.Lua.Module.Utils
                      , Text.Pandoc.Lua.Orphans
                      , Text.Pandoc.Lua.PandocLua
-                     , Text.Pandoc.Lua.Custom
                      , Text.Pandoc.Lua.Writer.Classic
                      , Text.Pandoc.Lua.Writer.Scaffolding
 
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua.hs
index cc4bd0519..a42107082 100644
--- a/pandoc-lua-engine/src/Text/Pandoc/Lua.hs
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua.hs
@@ -13,8 +13,7 @@ Running pandoc Lua filters.
 module Text.Pandoc.Lua
   ( -- * High-level functions
     applyFilter
-  , readCustom
-  , writeCustom
+  , loadCustom
   -- * Low-level functions
   , Global(..)
   , setGlobals
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Custom.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Custom.hs
new file mode 100644
index 000000000..14eb3b93b
--- /dev/null
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Custom.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TupleSections       #-}
+{- |
+   Module      : Text.Pandoc.Lua.Custom
+   Copyright   : © 2021-2022 Albert Krewinkel, John MacFarlane
+   License     : GPL-2.0-or-later
+   Maintainer  : Albert Krewinkel <[email protected]>
+
+Supports custom parsers written in Lua which produce a Pandoc AST.
+-}
+module Text.Pandoc.Lua.Custom ( loadCustom ) where
+import Control.Exception
+import Control.Monad ((<=<), (<$!>))
+import Control.Monad.IO.Class (MonadIO)
+import Data.Maybe (fromMaybe)
+import HsLua as Lua hiding (Operation (Div))
+import HsLua.Core.Run (GCManagedState, newGCManagedState, withGCManagedState)
+import Text.Pandoc.Class (PandocMonad, findFileWithDataFallback)
+import Text.Pandoc.Error (PandocError)
+import Text.Pandoc.Lua.Global (Global (..), setGlobals)
+import Text.Pandoc.Lua.Init (runLuaWith)
+import Text.Pandoc.Lua.Marshal.Format (peekExtensionsConfig)
+import Text.Pandoc.Lua.Marshal.Pandoc (peekPandoc)
+import Text.Pandoc.Lua.Marshal.WriterOptions (pushWriterOptions)
+import Text.Pandoc.Readers (Reader (..))
+import Text.Pandoc.Sources (ToSources(..))
+import Text.Pandoc.Scripting (CustomComponents (..))
+import Text.Pandoc.Writers (Writer (..))
+import qualified Text.Pandoc.Lua.Writer.Classic as Classic
+
+-- | Convert custom markup to Pandoc.
+loadCustom :: (PandocMonad m, MonadIO m)
+           => FilePath -> m (CustomComponents m)
+loadCustom luaFile = do
+  luaState <- liftIO newGCManagedState
+  luaFile' <- fromMaybe luaFile <$>
+              findFileWithDataFallback "custom"  luaFile
+  either throw pure <=< runLuaWith luaState $ do
+    let globals = [ PANDOC_SCRIPT_FILE luaFile ]
+    setGlobals globals
+    dofileTrace luaFile' >>= \case
+      OK -> pure ()
+      _  -> throwErrorAsException
+
+    mextsConf <- rawgetglobal "Extensions" >>= \case
+      TypeNil      -> pure Nothing
+      TypeFunction -> Just <$!> do
+        callTrace 0 1
+        forcePeek $ peekExtensionsConfig top `lastly` pop 1
+      _            -> Just <$!> do
+        forcePeek $ peekExtensionsConfig top `lastly` pop 1
+
+    mtemplate <- rawgetglobal "Template" >>= \case
+      TypeNil   -> pure Nothing
+      TypeFunction -> Just <$!> do
+        callTrace 0 1
+        forcePeek $ peekText top `lastly` pop 1
+      _ -> Just <$!> do
+        forcePeek $ peekText top `lastly` pop 1
+
+    mreader <- rawgetglobal "Reader" >>= \case
+      TypeNil -> do
+        pop 1
+        rawgetglobal "ByteStringReader" >>= \case
+          TypeNil -> pure Nothing
+          _ -> do
+            setfield registryindex readerField
+            pure . Just $ byteStringReader luaState
+      _ -> do
+        setfield registryindex readerField
+        pure . Just $ textReader luaState
+
+    mwriter <- rawgetglobal "Writer" >>= \case
+      TypeNil -> rawgetglobal "ByteStringWriter" >>= \case
+        TypeNil -> do
+          -- Neither `Writer` nor `BinaryWriter` are defined. Check for
+          -- "Doc"; if present, use the file as a classic writer.
+          docType <- rawgetglobal "Doc"
+          pop 3  -- remove nils/value of "Writer", "ByteStringWriter", "Doc"
+          pure $
+            if docType /= TypeFunction
+            then Nothing
+            else Just . TextWriter $ \opts doc ->
+              liftIO $ withGCManagedState luaState $
+              Classic.runCustom @PandocError opts doc
+        _ -> Just <$!> do
+          -- Binary writer. Writer function is on top of the stack.
+          setfield registryindex writerField
+          pure $ ByteStringWriter $ \opts doc ->
+            -- Call writer with document and writer options as arguments.
+            liftIO $ withGCManagedState luaState $ do
+              getfield registryindex writerField
+              push doc
+              pushWriterOptions opts
+              callTrace 2 1
+              forcePeek @PandocError $ peekLazyByteString top
+      _ -> Just <$!> do
+        -- New-type text writer. Writer function is on top of the stack.
+        setfield registryindex writerField
+        pure $ TextWriter $ \opts doc ->
+          liftIO $ withGCManagedState luaState $ do
+            getfield registryindex writerField
+            push doc
+            pushWriterOptions opts
+            callTrace 2 1
+            forcePeek @PandocError $ peekText top
+
+    pure $ CustomComponents
+      { customReader = mreader
+      , customWriter = mwriter
+      , customTemplate = mtemplate
+      , customExtensions = mextsConf
+      }
+
+-- | "Raw", non-metatable lookup of a key in the global table.
+--
+-- Most classic writers contain code that throws an error if a global
+-- is not present. This would break our check for the existence of a
+-- "Writer" function. We resort to raw access for that reason, but
+-- could also catch the error instead.
+--
+-- TODO: This function ensures the proper behavior of legacy custom
+-- writers. It should be replaced with 'getglobal' in the future.
+rawgetglobal :: LuaError e => Name -> LuaE e Lua.Type
+rawgetglobal x = do
+  pushglobaltable
+  pushName x
+  rawget (nth 2) <* remove (nth 2) -- remove global table
+
+-- | Name under which the reader function is stored in the registry.
+readerField :: Name
+readerField = "Pandoc Reader function"
+
+-- | Name under which the writer function is stored in the registry.
+writerField :: Name
+writerField = "Pandoc Writer function"
+
+-- | Runs a Lua action in a continueable environment.
+inLua :: MonadIO m => GCManagedState -> LuaE PandocError a -> m a
+inLua st = liftIO . withGCManagedState @PandocError st
+
+-- | Returns the ByteStringReader function
+byteStringReader :: MonadIO m => GCManagedState -> Reader m
+byteStringReader st = ByteStringReader $ \ropts input -> inLua st $ do
+  getfield registryindex readerField
+  push input
+  push ropts
+  pcallTrace 2 1 >>= \case
+    OK -> forcePeek $ peekPandoc top
+    _ -> throwErrorAsException
+
+-- | Returns the TextReader function
+textReader :: MonadIO m => GCManagedState -> Reader m
+textReader st = TextReader $ \ropts srcs -> inLua st $ do
+  let input = toSources srcs
+  getfield registryindex readerField
+  push input
+  push ropts
+  pcallTrace 2 1 >>= \case
+    OK -> forcePeek $ peekPandoc top
+    _ -> throwErrorAsException
diff --git a/pandoc-lua-engine/test/Tests/Lua/Reader.hs b/pandoc-lua-engine/test/Tests/Lua/Reader.hs
index 15ad685b4..dbf125432 100644
--- a/pandoc-lua-engine/test/Tests/Lua/Reader.hs
+++ b/pandoc-lua-engine/test/Tests/Lua/Reader.hs
@@ -9,11 +9,13 @@ Tests for custom Lua readers.
 -}
 module Tests.Lua.Reader (tests) where
 
+import Control.Arrow ((>>>))
 import Data.Char (chr)
 import Data.Default (Default (def))
 import Text.Pandoc.Class (runIOorExplode)
-import Text.Pandoc.Lua (readCustom)
-import Text.Pandoc.Readers (Reader (ByteStringReader, TextReader))
+import Text.Pandoc.Lua (loadCustom)
+import Text.Pandoc.Readers (Reader (ByteStringReader))
+import Text.Pandoc.Scripting (customReader)
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit ((@?=), testCase)
 
@@ -26,9 +28,9 @@ tests =
   [ testCase "read binary to code block" $ do
     input <- BL.readFile "bytestring.bin"
     doc <- runIOorExplode $
-      readCustom "bytestring-reader.lua" >>= \case
-        (ByteStringReader f, _) -> f def input
-        (TextReader {}, _)      -> error "Expected a bytestring reader"
+      loadCustom "bytestring-reader.lua" >>= (customReader >>> \case
+        Just (ByteStringReader f) -> f def input
+        _                         -> error "Expected a bytestring reader")
     let bytes = mconcat $ map (B.str . T.singleton . chr) [0..255]
     doc @?= B.doc (B.plain bytes)
   ]
diff --git a/pandoc-lua-engine/test/Tests/Lua/Writer.hs b/pandoc-lua-engine/test/Tests/Lua/Writer.hs
index 97d772bc5..6a9c9282b 100644
--- a/pandoc-lua-engine/test/Tests/Lua/Writer.hs
+++ b/pandoc-lua-engine/test/Tests/Lua/Writer.hs
@@ -16,9 +16,10 @@ import Text.Pandoc.Class (runIOorExplode, readFileStrict)
 import Text.Pandoc.Extensions (Extension (..))
 import Text.Pandoc.Format (ExtensionsDiff (..), FlavoredFormat (..),
                            applyExtensionsDiff)
-import Text.Pandoc.Lua (writeCustom)
+import Text.Pandoc.Lua (loadCustom)
 import Text.Pandoc.Options (WriterOptions (..))
 import Text.Pandoc.Readers (readNative)
+import Text.Pandoc.Scripting (CustomComponents (..))
 import Text.Pandoc.Writers (Writer (ByteStringWriter, TextWriter))
 import Test.Tasty (TestTree)
 import Test.Tasty.Golden (goldenVsString)
@@ -35,9 +36,9 @@ tests =
     (runIOorExplode $ do
         source <- UTF8.toText <$> readFileStrict "testsuite.native"
         doc <- readNative def source
-        txt <- writeCustom "sample.lua" >>= \case
-          (TextWriter f, _, _) -> f def doc
-          _            -> error "Expected a text writer"
+        txt <- customWriter <$> loadCustom "sample.lua" >>= \case
+          Just (TextWriter f) -> f def doc
+          _                   -> error "Expected a text writer"
         pure $ BL.fromStrict (UTF8.fromText txt))
 
   , goldenVsString "tables testsuite"
@@ -85,3 +86,10 @@ tests =
           _                        -> error "Expected a text writer"
       result @?= "smart extension is enabled;\ncitations extension is enabled\n"
   ]
+ where
+  writeCustom fp = do
+    components <- loadCustom fp
+    let exts = fromMaybe mempty (customExtensions components)
+    case customWriter components of
+      Nothing -> error "Expected a writer to be defined"
+      Just w  -> return (w, exts, customTemplate components)
diff --git a/src/Text/Pandoc/App/CommandLineOptions.hs b/src/Text/Pandoc/App/CommandLineOptions.hs
index a65fe5a04..30b5693fd 100644
--- a/src/Text/Pandoc/App/CommandLineOptions.hs
+++ b/src/Text/Pandoc/App/CommandLineOptions.hs
@@ -51,7 +51,7 @@ import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), IpynbOutput (..),
                             fullDefaultsPath, OptInfo(..))
 import Text.Pandoc.Filter (Filter (..))
 import Text.Pandoc.Highlighting (highlightingStyles, lookupHighlightingStyle)
-import Text.Pandoc.Scripting (ScriptingEngine (..))
+import Text.Pandoc.Scripting (ScriptingEngine (..), customTemplate)
 import Text.Pandoc.Shared (safeStrRead)
 import Text.Printf
 import qualified Control.Exception as E
@@ -161,8 +161,8 @@ handleOptInfo engine info = E.handle (handleError . Left) $ do
                       getDefaultTemplate fmt
                     _ -> do
                       -- format looks like a filepath => custom writer
-                      (_, _, mt) <- engineWriteCustom engine (T.unpack fmt)
-                      case mt of
+                      components <- engineLoadCustom engine (T.unpack fmt)
+                      case customTemplate components of
                         Just t  -> pure t
                         Nothing -> E.throw $ PandocNoTemplateError fmt
       case templ of