{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeApplications    #-}
{- |
   Module      : Text.Pandoc.Lua.Custom
   Copyright   : © 2021-2024 Albert Krewinkel, John MacFarlane
   License     : GPL-2.0-or-later
   Maintainer  : Albert Krewinkel <albert+pandoc@tarleb.com>

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 Text.Pandoc.Class (PandocMonad, findFileWithDataFallback)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Global (Global (..), setGlobals)
import Text.Pandoc.Lua.Marshal.Format (peekExtensionsConfig)
import Text.Pandoc.Lua.Marshal.Pandoc (peekPandoc)
import Text.Pandoc.Lua.Marshal.WriterOptions (pushWriterOptions)
import Text.Pandoc.Lua.PandocLua (unPandocLua)
import Text.Pandoc.Lua.Run (runLuaWith)
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
import qualified Text.Pandoc.Class as PandocMonad

-- | Convert custom markup to Pandoc.
loadCustom :: (PandocMonad m, MonadIO m)
           => FilePath -> m (CustomComponents m)
loadCustom :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
FilePath -> m (CustomComponents m)
loadCustom FilePath
luaFile = do
  luaState <- IO GCManagedState -> m GCManagedState
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GCManagedState
newGCManagedState
  luaFile' <- fromMaybe luaFile <$>
              findFileWithDataFallback "custom"  luaFile
  either throw pure <=< runLuaWith luaState $ do
    let globals = [ FilePath -> Global
PANDOC_SCRIPT_FILE FilePath
luaFile' ]
    setGlobals globals
    dofileTrace (Just luaFile') >>= \case
      Status
OK -> () -> LuaE PandocError ()
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Status
_  -> LuaE PandocError ()
forall e a. LuaError e => LuaE e a
throwErrorAsException

    mextsConf <- rawgetglobal "Extensions" >>= \case
      Type
TypeNil      -> Maybe ExtensionsConfig -> LuaE PandocError (Maybe ExtensionsConfig)
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ExtensionsConfig
forall a. Maybe a
Nothing
      Type
TypeFunction -> ExtensionsConfig -> Maybe ExtensionsConfig
forall a. a -> Maybe a
Just (ExtensionsConfig -> Maybe ExtensionsConfig)
-> LuaE PandocError ExtensionsConfig
-> LuaE PandocError (Maybe ExtensionsConfig)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
        NumArgs -> NumResults -> LuaE PandocError ()
forall e. LuaError e => NumArgs -> NumResults -> LuaE e ()
callTrace NumArgs
0 NumResults
1
        Peek PandocError ExtensionsConfig
-> LuaE PandocError ExtensionsConfig
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek PandocError ExtensionsConfig
 -> LuaE PandocError ExtensionsConfig)
-> Peek PandocError ExtensionsConfig
-> LuaE PandocError ExtensionsConfig
forall a b. (a -> b) -> a -> b
$ Peeker PandocError ExtensionsConfig
forall e. LuaError e => Peeker e ExtensionsConfig
peekExtensionsConfig StackIndex
top Peek PandocError ExtensionsConfig
-> LuaE PandocError () -> Peek PandocError ExtensionsConfig
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE PandocError ()
forall e. Int -> LuaE e ()
pop Int
1
      Type
_            -> ExtensionsConfig -> Maybe ExtensionsConfig
forall a. a -> Maybe a
Just (ExtensionsConfig -> Maybe ExtensionsConfig)
-> LuaE PandocError ExtensionsConfig
-> LuaE PandocError (Maybe ExtensionsConfig)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
        Peek PandocError ExtensionsConfig
-> LuaE PandocError ExtensionsConfig
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek PandocError ExtensionsConfig
 -> LuaE PandocError ExtensionsConfig)
-> Peek PandocError ExtensionsConfig
-> LuaE PandocError ExtensionsConfig
forall a b. (a -> b) -> a -> b
$ Peeker PandocError ExtensionsConfig
forall e. LuaError e => Peeker e ExtensionsConfig
peekExtensionsConfig StackIndex
top Peek PandocError ExtensionsConfig
-> LuaE PandocError () -> Peek PandocError ExtensionsConfig
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE PandocError ()
forall e. Int -> LuaE e ()
pop Int
1

    mtemplate <- rawgetglobal "Template" >>= \case
      Type
TypeNil   -> Maybe Text -> LuaE PandocError (Maybe Text)
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
      Type
TypeFunction -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> LuaE PandocError Text -> LuaE PandocError (Maybe Text)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
        NumArgs -> NumResults -> LuaE PandocError ()
forall e. LuaError e => NumArgs -> NumResults -> LuaE e ()
callTrace NumArgs
0 NumResults
1
        Peek PandocError Text -> LuaE PandocError Text
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek PandocError Text -> LuaE PandocError Text)
-> Peek PandocError Text -> LuaE PandocError Text
forall a b. (a -> b) -> a -> b
$ Peeker PandocError Text
forall e. Peeker e Text
peekText StackIndex
top Peek PandocError Text
-> LuaE PandocError () -> Peek PandocError Text
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE PandocError ()
forall e. Int -> LuaE e ()
pop Int
1
      Type
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> LuaE PandocError Text -> LuaE PandocError (Maybe Text)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
        Peek PandocError Text -> LuaE PandocError Text
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek PandocError Text -> LuaE PandocError Text)
-> Peek PandocError Text -> LuaE PandocError Text
forall a b. (a -> b) -> a -> b
$ Peeker PandocError Text
forall e. Peeker e Text
peekText StackIndex
top Peek PandocError Text
-> LuaE PandocError () -> Peek PandocError Text
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE PandocError ()
forall e. Int -> LuaE e ()
pop Int
1

    mreader <- rawgetglobal "Reader" >>= \case
      Type
TypeNil -> do
        Int -> LuaE PandocError ()
forall e. Int -> LuaE e ()
pop Int
1
        Name -> LuaE PandocError Type
forall e. LuaError e => Name -> LuaE e Type
rawgetglobal Name
"ByteStringReader" LuaE PandocError Type
-> (Type -> LuaE PandocError (Maybe (Reader m)))
-> LuaE PandocError (Maybe (Reader m))
forall a b.
LuaE PandocError a
-> (a -> LuaE PandocError b) -> LuaE PandocError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Type
TypeNil -> Maybe (Reader m) -> LuaE PandocError (Maybe (Reader m))
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Reader m)
forall a. Maybe a
Nothing
          Type
_ -> do
            StackIndex -> Name -> LuaE PandocError ()
forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield StackIndex
registryindex Name
readerField
            Maybe (Reader m) -> LuaE PandocError (Maybe (Reader m))
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Reader m) -> LuaE PandocError (Maybe (Reader m)))
-> (Reader m -> Maybe (Reader m))
-> Reader m
-> LuaE PandocError (Maybe (Reader m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reader m -> Maybe (Reader m)
forall a. a -> Maybe a
Just (Reader m -> LuaE PandocError (Maybe (Reader m)))
-> Reader m -> LuaE PandocError (Maybe (Reader m))
forall a b. (a -> b) -> a -> b
$ GCManagedState -> Reader m
forall (m :: * -> *). MonadIO m => GCManagedState -> Reader m
byteStringReader GCManagedState
luaState
      Type
_ -> do
        StackIndex -> Name -> LuaE PandocError ()
forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield StackIndex
registryindex Name
readerField
        Maybe (Reader m) -> LuaE PandocError (Maybe (Reader m))
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Reader m) -> LuaE PandocError (Maybe (Reader m)))
-> (Reader m -> Maybe (Reader m))
-> Reader m
-> LuaE PandocError (Maybe (Reader m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reader m -> Maybe (Reader m)
forall a. a -> Maybe a
Just (Reader m -> LuaE PandocError (Maybe (Reader m)))
-> Reader m -> LuaE PandocError (Maybe (Reader m))
forall a b. (a -> b) -> a -> b
$ GCManagedState -> Reader m
forall (m :: * -> *). MonadIO m => GCManagedState -> Reader m
textReader GCManagedState
luaState

    mwriter <- rawgetglobal "Writer" >>= \case
      Type
TypeNil -> Name -> LuaE PandocError Type
forall e. LuaError e => Name -> LuaE e Type
rawgetglobal Name
"ByteStringWriter" LuaE PandocError Type
-> (Type -> LuaE PandocError (Maybe (Writer m)))
-> LuaE PandocError (Maybe (Writer m))
forall a b.
LuaE PandocError a
-> (a -> LuaE PandocError b) -> LuaE PandocError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Type
TypeNil -> do
          -- Neither `Writer` nor `BinaryWriter` are defined. Check for
          -- "Doc"; if present, use the file as a classic writer.
          docType <- Name -> LuaE PandocError Type
forall e. LuaError e => Name -> LuaE e Type
rawgetglobal Name
"Doc"
          pop 3  -- remove nils/value of "Writer", "ByteStringWriter", "Doc"
          pure $
            if docType /= TypeFunction
            then Nothing
            else Just . TextWriter $ \WriterOptions
opts Pandoc
doc -> do
              -- See TextWriter below for why the state is updated
              st <- m CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
PandocMonad.getCommonState
              liftIO $ withGCManagedState luaState $
                unPandocLua (PandocMonad.putCommonState st) >>
                Classic.runCustom @PandocError opts doc
        Type
_ -> Writer m -> Maybe (Writer m)
forall a. a -> Maybe a
Just (Writer m -> Maybe (Writer m))
-> LuaE PandocError (Writer m)
-> LuaE PandocError (Maybe (Writer m))
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
          -- Binary writer. Writer function is on top of the stack.
          StackIndex -> Name -> LuaE PandocError ()
forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield StackIndex
registryindex Name
writerField
          Writer m -> LuaE PandocError (Writer m)
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Writer m -> LuaE PandocError (Writer m))
-> Writer m -> LuaE PandocError (Writer m)
forall a b. (a -> b) -> a -> b
$ (WriterOptions -> Pandoc -> m ByteString) -> Writer m
forall (m :: * -> *).
(WriterOptions -> Pandoc -> m ByteString) -> Writer m
ByteStringWriter ((WriterOptions -> Pandoc -> m ByteString) -> Writer m)
-> (WriterOptions -> Pandoc -> m ByteString) -> Writer m
forall a b. (a -> b) -> a -> b
$ \WriterOptions
opts Pandoc
doc -> do
            -- See TextWriter below for why the state is updated
            st <- m CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
PandocMonad.getCommonState
            -- Call writer with document and writer options as arguments.
            liftIO $ withGCManagedState luaState $ do
              unPandocLua (PandocMonad.putCommonState st)
              getfield registryindex writerField
              push doc
              pushWriterOptions opts
              callTrace 2 1
              forcePeek @PandocError $ peekLazyByteString top
      Type
_ -> Writer m -> Maybe (Writer m)
forall a. a -> Maybe a
Just (Writer m -> Maybe (Writer m))
-> LuaE PandocError (Writer m)
-> LuaE PandocError (Maybe (Writer m))
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
        -- New-type text writer. Writer function is on top of the stack.
        StackIndex -> Name -> LuaE PandocError ()
forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield StackIndex
registryindex Name
writerField
        Writer m -> LuaE PandocError (Writer m)
forall a. a -> LuaE PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Writer m -> LuaE PandocError (Writer m))
-> Writer m -> LuaE PandocError (Writer m)
forall a b. (a -> b) -> a -> b
$ (WriterOptions -> Pandoc -> m Text) -> Writer m
forall (m :: * -> *).
(WriterOptions -> Pandoc -> m Text) -> Writer m
TextWriter ((WriterOptions -> Pandoc -> m Text) -> Writer m)
-> (WriterOptions -> Pandoc -> m Text) -> Writer m
forall a b. (a -> b) -> a -> b
$ \WriterOptions
opts Pandoc
doc -> do
          -- The CommonState might have changed since the Lua file was
          -- loaded. That's why the state must be updated when the
          -- writer is run. (#9229)
          st <- m CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
PandocMonad.getCommonState
          liftIO $ withGCManagedState luaState $ do
            unPandocLua (PandocMonad.putCommonState st)
            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 :: forall e. LuaError e => Name -> LuaE e Type
rawgetglobal Name
x = do
  LuaE e ()
forall e. LuaE e ()
pushglobaltable
  Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
x
  StackIndex -> LuaE e Type
forall e. LuaError e => StackIndex -> LuaE e Type
rawget (CInt -> StackIndex
nth CInt
2) LuaE e Type -> LuaE e () -> LuaE e Type
forall a b. LuaE e a -> LuaE e b -> LuaE e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
remove (CInt -> StackIndex
nth CInt
2) -- remove global table

-- | Name under which the reader function is stored in the registry.
readerField :: Name
readerField :: Name
readerField = Name
"Pandoc Reader function"

-- | Name under which the writer function is stored in the registry.
writerField :: Name
writerField :: Name
writerField = Name
"Pandoc Writer function"

-- | Runs a Lua action in a continueable environment.
inLua :: MonadIO m => GCManagedState -> LuaE PandocError a -> m a
inLua :: forall (m :: * -> *) a.
MonadIO m =>
GCManagedState -> LuaE PandocError a -> m a
inLua GCManagedState
st = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> (LuaE PandocError a -> IO a) -> LuaE PandocError a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. GCManagedState -> LuaE e a -> IO a
withGCManagedState @PandocError GCManagedState
st

-- | Returns the ByteStringReader function
byteStringReader :: MonadIO m => GCManagedState -> Reader m
byteStringReader :: forall (m :: * -> *). MonadIO m => GCManagedState -> Reader m
byteStringReader GCManagedState
st = (ReaderOptions -> ByteString -> m Pandoc) -> Reader m
forall (m :: * -> *).
(ReaderOptions -> ByteString -> m Pandoc) -> Reader m
ByteStringReader ((ReaderOptions -> ByteString -> m Pandoc) -> Reader m)
-> (ReaderOptions -> ByteString -> m Pandoc) -> Reader m
forall a b. (a -> b) -> a -> b
$ \ReaderOptions
ropts ByteString
input -> GCManagedState -> LuaE PandocError Pandoc -> m Pandoc
forall (m :: * -> *) a.
MonadIO m =>
GCManagedState -> LuaE PandocError a -> m a
inLua GCManagedState
st (LuaE PandocError Pandoc -> m Pandoc)
-> LuaE PandocError Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ do
  StackIndex -> Name -> LuaE PandocError Type
forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
registryindex Name
readerField
  ByteString -> LuaE PandocError ()
forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
forall e. LuaError e => ByteString -> LuaE e ()
push ByteString
input
  ReaderOptions -> LuaE PandocError ()
forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
forall e. LuaError e => ReaderOptions -> LuaE e ()
push ReaderOptions
ropts
  NumArgs -> NumResults -> LuaE PandocError Status
forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace NumArgs
2 NumResults
1 LuaE PandocError Status
-> (Status -> LuaE PandocError Pandoc) -> LuaE PandocError Pandoc
forall a b.
LuaE PandocError a
-> (a -> LuaE PandocError b) -> LuaE PandocError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Status
OK -> Peek PandocError Pandoc -> LuaE PandocError Pandoc
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek PandocError Pandoc -> LuaE PandocError Pandoc)
-> Peek PandocError Pandoc -> LuaE PandocError Pandoc
forall a b. (a -> b) -> a -> b
$ Peeker PandocError Pandoc
forall e. LuaError e => Peeker e Pandoc
peekPandoc StackIndex
top
    Status
_ -> LuaE PandocError Pandoc
forall e a. LuaError e => LuaE e a
throwErrorAsException

-- | Returns the TextReader function
textReader :: MonadIO m => GCManagedState -> Reader m
textReader :: forall (m :: * -> *). MonadIO m => GCManagedState -> Reader m
textReader GCManagedState
st = (forall a. ToSources a => ReaderOptions -> a -> m Pandoc)
-> Reader m
forall (m :: * -> *).
(forall a. ToSources a => ReaderOptions -> a -> m Pandoc)
-> Reader m
TextReader ((forall a. ToSources a => ReaderOptions -> a -> m Pandoc)
 -> Reader m)
-> (forall a. ToSources a => ReaderOptions -> a -> m Pandoc)
-> Reader m
forall a b. (a -> b) -> a -> b
$ \ReaderOptions
ropts a
srcs -> GCManagedState -> LuaE PandocError Pandoc -> m Pandoc
forall (m :: * -> *) a.
MonadIO m =>
GCManagedState -> LuaE PandocError a -> m a
inLua GCManagedState
st (LuaE PandocError Pandoc -> m Pandoc)
-> LuaE PandocError Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ do
  let input :: Sources
input = a -> Sources
forall a. ToSources a => a -> Sources
toSources a
srcs
  StackIndex -> Name -> LuaE PandocError Type
forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
registryindex Name
readerField
  Sources -> LuaE PandocError ()
forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
forall e. LuaError e => Sources -> LuaE e ()
push Sources
input
  ReaderOptions -> LuaE PandocError ()
forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
forall e. LuaError e => ReaderOptions -> LuaE e ()
push ReaderOptions
ropts
  NumArgs -> NumResults -> LuaE PandocError Status
forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace NumArgs
2 NumResults
1 LuaE PandocError Status
-> (Status -> LuaE PandocError Pandoc) -> LuaE PandocError Pandoc
forall a b.
LuaE PandocError a
-> (a -> LuaE PandocError b) -> LuaE PandocError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Status
OK -> Peek PandocError Pandoc -> LuaE PandocError Pandoc
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek PandocError Pandoc -> LuaE PandocError Pandoc)
-> Peek PandocError Pandoc -> LuaE PandocError Pandoc
forall a b. (a -> b) -> a -> b
$ Peeker PandocError Pandoc
forall e. LuaError e => Peeker e Pandoc
peekPandoc StackIndex
top
    Status
_ -> LuaE PandocError Pandoc
forall e a. LuaError e => LuaE e a
throwErrorAsException