Lua: add a `pandoc.log` module.

5 files changed, 201 insertions, 25 deletions

diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs
index 2faf56061..e0dd830b2 100644
--- a/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Init.hs
@@ -30,8 +30,7 @@ import Text.Pandoc.Logging (LogMessage (ScriptingWarning))
 import Text.Pandoc.Lua.Global (Global (..), setGlobals)
 import Text.Pandoc.Lua.Marshal.List (newListMetatable, pushListModule)
 import Text.Pandoc.Lua.PandocLua (PandocLua (..), liftPandocLua)
-import Text.Parsec.Pos (newPos)
-import Text.Read (readMaybe)
+import Text.Pandoc.Lua.SourcePos (luaSourcePos)
 import qualified Data.ByteString.Char8 as Char8
 import qualified Data.Text as T
 import qualified Lua.LPeg as LPeg
@@ -43,6 +42,7 @@ import qualified Text.Pandoc.Lua.Module.CLI as Pandoc.CLI
 import qualified Text.Pandoc.Lua.Module.Format as Pandoc.Format
 import qualified Text.Pandoc.Lua.Module.Image as Pandoc.Image
 import qualified Text.Pandoc.Lua.Module.JSON as Pandoc.JSON
+import qualified Text.Pandoc.Lua.Module.Log as Pandoc.Log
 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
@@ -94,6 +94,7 @@ loadedModules =
   , Pandoc.Format.documentedModule
   , Pandoc.Image.documentedModule
   , Pandoc.JSON.documentedModule
+  , Pandoc.Log.documentedModule
   , Pandoc.MediaBag.documentedModule
   , Pandoc.Scaffolding.documentedModule
   , Pandoc.Structure.documentedModule
@@ -247,10 +248,5 @@ setWarnFunction = liftPandocLua . setwarnf' $ \msg -> do
   -- 1: userdata wrapper function for the hook,
   -- 2: warn,
   -- 3: function calling warn.
-  where' 3
-  loc <- UTF8.toText <$> tostring' top
-  unPandocLua . report $ ScriptingWarning (UTF8.toText msg) (toSourcePos loc)
- where
-   toSourcePos loc = (T.breakOnEnd ":" <$> T.stripSuffix ": " loc)
-     >>= (\(prfx, sfx) -> (,) <$> T.unsnoc prfx <*> readMaybe (T.unpack sfx))
-     >>= \((source, _), line) -> Just $ newPos (T.unpack source) line 1
+  pos <- luaSourcePos 3
+  unPandocLua . report $ ScriptingWarning (UTF8.toText msg) pos
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Marshal/CommonState.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Marshal/CommonState.hs
index 27c797fb5..043ccdb20 100644
--- a/pandoc-lua-engine/src/Text/Pandoc/Lua/Marshal/CommonState.hs
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Marshal/CommonState.hs
@@ -17,9 +17,8 @@ module Text.Pandoc.Lua.Marshal.CommonState
 
 import HsLua
 import Text.Pandoc.Class (CommonState (..))
-import Text.Pandoc.Logging (LogMessage, showLogMessage)
 import Text.Pandoc.Lua.Marshal.List (pushPandocList)
-import qualified Data.Aeson as Aeson
+import Text.Pandoc.Lua.Marshal.LogMessage (pushLogMessage)
 
 -- | Lua type used for the @CommonState@ object.
 typeCommonState :: LuaError e => DocumentedType e CommonState
@@ -31,7 +30,7 @@ typeCommonState = deftype "pandoc CommonState" []
       (maybe pushnil pushString, stOutputFile)
 
   , readonly "log" "list of log messages"
-      (pushPandocList (pushUD typeLogMessage), stLog)
+      (pushPandocList pushLogMessage, stLog)
 
   , readonly "request_headers" "headers to add for HTTP requests"
       (pushPandocList (pushPair pushText pushText), stRequestHeaders)
@@ -58,16 +57,3 @@ peekCommonState = peekUD typeCommonState
 
 pushCommonState :: LuaError e => Pusher e CommonState
 pushCommonState = pushUD typeCommonState
-
-typeLogMessage :: LuaError e => DocumentedType e LogMessage
-typeLogMessage = deftype "pandoc LogMessage"
-  [ operation Index $ defun "__tostring"
-      ### liftPure showLogMessage
-      <#> udparam typeLogMessage "msg" "object"
-      =#> functionResult pushText "string" "stringified log message"
-  , operation (CustomOperation "__tojson") $ lambda
-      ### liftPure Aeson.encode
-      <#> udparam typeLogMessage "msg" "object"
-      =#> functionResult pushLazyByteString "string" "JSON encoded object"
-  ]
-  mempty -- no members
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Marshal/LogMessage.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Marshal/LogMessage.hs
new file mode 100644
index 000000000..580b80134
--- /dev/null
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Marshal/LogMessage.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{- |
+   Module      : Text.Pandoc.Lua.Marshal.LogMessage
+   Copyright   : © 2017-2023 Albert Krewinkel
+   License     : GPL-2.0-or-later
+   Maintainer  : Albert Krewinkel <[email protected]>
+
+Pushing and retrieving of pandoc log messages.
+-}
+module Text.Pandoc.Lua.Marshal.LogMessage
+  ( peekLogMessage
+  , pushLogMessage
+  , typeLogMessage
+  ) where
+
+import HsLua
+import Text.Pandoc.Logging (LogMessage, showLogMessage)
+import qualified Data.Aeson as Aeson
+
+-- | Type definition for pandoc log messages.
+typeLogMessage :: LuaError e => DocumentedType e LogMessage
+typeLogMessage = deftype "pandoc LogMessage"
+  [ operation Index $ defun "__tostring"
+      ### liftPure showLogMessage
+      <#> udparam typeLogMessage "msg" "object"
+      =#> functionResult pushText "string" "stringified log message"
+  , operation (CustomOperation "__tojson") $ lambda
+      ### liftPure Aeson.encode
+      <#> udparam typeLogMessage "msg" "object"
+      =#> functionResult pushLazyByteString "string" "JSON encoded object"
+  ]
+  mempty -- no members
+
+-- | Pushes a LogMessage to the stack.
+pushLogMessage :: LuaError e => Pusher e LogMessage
+pushLogMessage = pushUD typeLogMessage
+
+peekLogMessage :: LuaError e => Peeker e LogMessage
+peekLogMessage  = peekUD typeLogMessage
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/Module/Log.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/Module/Log.hs
new file mode 100644
index 000000000..6c5cd9ef5
--- /dev/null
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/Module/Log.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+{- |
+   Module      : Text.Pandoc.Lua.Module.Log
+   Copyright   : © 2024 Albert Krewinkel
+   License     : GPL-2.0-or-later
+   Maintainer  : Albert Krewinkel <[email protected]>
+
+Logging module.
+-}
+module Text.Pandoc.Lua.Module.Log
+  ( documentedModule
+  ) where
+
+import Data.Version (makeVersion)
+import HsLua
+import Text.Pandoc.Class
+  ( CommonState (stVerbosity, stLog)
+  , PandocMonad (putCommonState, getCommonState)
+  , report )
+import Text.Pandoc.Error (PandocError)
+import Text.Pandoc.Logging
+  ( Verbosity (ERROR)
+  , LogMessage (ScriptingInfo, ScriptingWarning) )
+import Text.Pandoc.Lua.Marshal.List (pushPandocList)
+import Text.Pandoc.Lua.Marshal.LogMessage (pushLogMessage)
+import Text.Pandoc.Lua.PandocLua (liftPandocLua, unPandocLua)
+import Text.Pandoc.Lua.SourcePos (luaSourcePos)
+import qualified Data.Text as T
+import qualified HsLua.Core.Utf8 as UTF8
+
+-- | Push the pandoc.log module on the Lua stack.
+documentedModule :: Module PandocError
+documentedModule = Module
+  { moduleName = "pandoc.log"
+  , moduleDescription =
+      "Access to pandoc's logging system."
+  , moduleFields = []
+  , moduleFunctions =
+      [ defun "info"
+        ### (\msg -> do
+                -- reporting levels:
+                -- 0: this function,
+                -- 1: userdata wrapper function for the function,
+                -- 2: function calling warn.
+                pos <- luaSourcePos 2
+                unPandocLua $ report $ ScriptingInfo (UTF8.toText msg) pos)
+        <#> parameter peekByteString "string" "message" "the info message"
+        =#> []
+        #? "Reports a ScriptingInfo message to pandoc's logging system."
+        `since` makeVersion [3, 2]
+
+      , defun "silence"
+        ### const silence
+        <#> parameter pure "function" "fn"
+              "function to be silenced"
+        =?> ("List of log messages triggered during the function call, " <>
+             "and any value returned by the function.")
+        #? T.unlines
+           [ "Applies the function to the given arguments while"
+           , "preventing log messages from being added to the log."
+           , "The warnings and info messages reported during the function"
+           , "call are returned as the first return value, with the"
+           , "results of the function call following thereafter."
+           ]
+        `since` makeVersion [3, 2]
+
+      , defun "warn"
+        ### (\msg -> do
+                -- reporting levels:
+                -- 0: this function,
+                -- 1: userdata wrapper function for the function,
+                -- 2: function calling warn.
+                pos <- luaSourcePos 2
+                unPandocLua $ report $ ScriptingWarning (UTF8.toText msg) pos)
+        <#> parameter peekByteString "string" "message"
+              "the warning message"
+        =#> []
+        #? T.unlines
+           [ "Reports a ScriptingWarning to pandoc's logging system."
+           , "The warning will be printed to stderr unless logging"
+           , "verbosity has been set to *ERROR*."
+           ]
+        `since` makeVersion [3, 2]
+      ]
+  , moduleOperations = []
+  , moduleTypeInitializers = []
+  }
+
+-- | Calls the function given as the first argument, but suppresses logging.
+-- Returns the list of generated log messages as the first result, and the other
+-- results of the function call after that.
+silence :: LuaE PandocError NumResults
+silence = unPandocLua $ do
+  -- get current log messages
+  origState <- getCommonState
+  let origLog = stLog origState
+  let origVerbosity = stVerbosity origState
+  putCommonState (origState { stLog = [], stVerbosity = ERROR })
+
+  -- call function given as the first argument
+  liftPandocLua $ do
+    nargs <- (NumArgs . subtract 1 . fromStackIndex) <$> gettop
+    call @PandocError nargs multret
+
+  -- restore original log messages
+  newState <- getCommonState
+  let newLog = stLog newState
+  putCommonState (newState { stLog = origLog, stVerbosity = origVerbosity })
+
+  liftPandocLua $ do
+    pushPandocList pushLogMessage newLog
+    insert 1
+    (NumResults . fromStackIndex) <$> gettop
diff --git a/pandoc-lua-engine/src/Text/Pandoc/Lua/SourcePos.hs b/pandoc-lua-engine/src/Text/Pandoc/Lua/SourcePos.hs
new file mode 100644
index 000000000..fc9062c84
--- /dev/null
+++ b/pandoc-lua-engine/src/Text/Pandoc/Lua/SourcePos.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+   Module      : Text.Pandoc.Lua.SourcePos
+   Copyright   : © 2024 Albert Krewinkel
+   License     : GPL-2.0-or-later
+   Maintainer  : Albert Krewinkel <[email protected]>
+
+Helper function to retrieve the 'SourcePos' in a Lua script.
+-}
+module Text.Pandoc.Lua.SourcePos
+  ( luaSourcePos
+  ) where
+
+import HsLua
+import Text.Parsec.Pos (SourcePos, newPos)
+import Text.Read (readMaybe)
+import qualified Data.Text as T
+import qualified HsLua.Core.Utf8 as UTF8
+
+-- | Returns the current position in a Lua script.
+--
+-- The reporting level is the level of the call stack, for which the
+-- position should be reported. There might not always be a position
+-- available, e.g., in C functions.
+luaSourcePos :: LuaError e
+             => Int                -- ^ reporting level
+             -> LuaE e (Maybe SourcePos)
+luaSourcePos lvl = do
+  -- reporting levels:
+  -- 0: this hook,
+  -- 1: userdata wrapper function for the hook,
+  -- 2: warn,
+  -- 3: function calling warn.
+  where' lvl
+  locStr <- UTF8.toText <$> tostring' top
+  return $ do
+    (prfx, sfx) <- T.breakOnEnd ":" <$> T.stripSuffix ": " locStr
+    (source, _) <- T.unsnoc prfx
+    line <- readMaybe (T.unpack sfx)
+    -- We have no column information, so always use column 1
+    Just $ newPos (T.unpack source) line 1