{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeApplications    #-}
{- |
   Module      : Text.Pandoc.Lua.Custom
   Copyright   : © 2021-2023 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.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 :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
FilePath -> m (CustomComponents m)
loadCustom FilePath
luaFile = do
  GCManagedState
luaState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GCManagedState
newGCManagedState
  FilePath
luaFile' <- forall a. a -> Maybe a -> a
fromMaybe FilePath
luaFile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              forall (m :: * -> *).
PandocMonad m =>
FilePath -> FilePath -> m (Maybe FilePath)
findFileWithDataFallback FilePath
"custom"  FilePath
luaFile
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
GCManagedState -> LuaE PandocError a -> m (Either PandocError a)
runLuaWith GCManagedState
luaState forall a b. (a -> b) -> a -> b
$ do
    let globals :: [Global]
globals = [ FilePath -> Global
PANDOC_SCRIPT_FILE FilePath
luaFile ]
    [Global] -> LuaE PandocError ()
setGlobals [Global]
globals
    forall e. Maybe FilePath -> LuaE e Status
dofileTrace (forall a. a -> Maybe a
Just FilePath
luaFile') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Status
OK -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Status
_  -> forall e a. LuaError e => LuaE e a
throwErrorAsException

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

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

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

    Maybe (Writer m)
mwriter <- forall e. LuaError e => Name -> LuaE e Type
rawgetglobal Name
"Writer" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Type
TypeNil -> forall e. LuaError e => Name -> LuaE e Type
rawgetglobal Name
"ByteStringWriter" 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.
          Type
docType <- forall e. LuaError e => Name -> LuaE e Type
rawgetglobal Name
"Doc"
          forall e. Int -> LuaE e ()
pop Int
3  -- remove nils/value of "Writer", "ByteStringWriter", "Doc"
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            if Type
docType forall a. Eq a => a -> a -> Bool
/= Type
TypeFunction
            then forall a. Maybe a
Nothing
            else forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(WriterOptions -> Pandoc -> m Text) -> Writer m
TextWriter forall a b. (a -> b) -> a -> b
$ \WriterOptions
opts Pandoc
doc ->
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. GCManagedState -> LuaE e a -> IO a
withGCManagedState GCManagedState
luaState forall a b. (a -> b) -> a -> b
$
              forall e. LuaError e => WriterOptions -> Pandoc -> LuaE e Text
Classic.runCustom @PandocError WriterOptions
opts Pandoc
doc
        Type
_ -> forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
          -- Binary writer. Writer function is on top of the stack.
          forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield StackIndex
registryindex Name
writerField
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(WriterOptions -> Pandoc -> m ByteString) -> Writer m
ByteStringWriter forall a b. (a -> b) -> a -> b
$ \WriterOptions
opts Pandoc
doc ->
            -- Call writer with document and writer options as arguments.
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. GCManagedState -> LuaE e a -> IO a
withGCManagedState GCManagedState
luaState forall a b. (a -> b) -> a -> b
$ do
              forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
registryindex Name
writerField
              forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push Pandoc
doc
              Pusher PandocError WriterOptions
pushWriterOptions WriterOptions
opts
              forall e. LuaError e => NumArgs -> NumResults -> LuaE e ()
callTrace NumArgs
2 NumResults
1
              forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek @PandocError forall a b. (a -> b) -> a -> b
$ forall e. Peeker e ByteString
peekLazyByteString StackIndex
top
      Type
_ -> forall a. a -> Maybe a
Just 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.
        forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield StackIndex
registryindex Name
writerField
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(WriterOptions -> Pandoc -> m Text) -> Writer m
TextWriter forall a b. (a -> b) -> a -> b
$ \WriterOptions
opts Pandoc
doc ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. GCManagedState -> LuaE e a -> IO a
withGCManagedState GCManagedState
luaState forall a b. (a -> b) -> a -> b
$ do
            forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
registryindex Name
writerField
            forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push Pandoc
doc
            Pusher PandocError WriterOptions
pushWriterOptions WriterOptions
opts
            forall e. LuaError e => NumArgs -> NumResults -> LuaE e ()
callTrace NumArgs
2 NumResults
1
            forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek @PandocError forall a b. (a -> b) -> a -> b
$ forall e. Peeker e Text
peekText StackIndex
top

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CustomComponents
      { customReader :: Maybe (Reader m)
customReader = Maybe (Reader m)
mreader
      , customWriter :: Maybe (Writer m)
customWriter = Maybe (Writer m)
mwriter
      , customTemplate :: Maybe Text
customTemplate = Maybe Text
mtemplate
      , customExtensions :: Maybe ExtensionsConfig
customExtensions = Maybe ExtensionsConfig
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
  forall e. LuaE e ()
pushglobaltable
  forall e. Name -> LuaE e ()
pushName Name
x
  forall e. LuaError e => StackIndex -> LuaE e Type
rawget (CInt -> StackIndex
nth CInt
2) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall (m :: * -> *).
(ReaderOptions -> ByteString -> m Pandoc) -> Reader m
ByteStringReader forall a b. (a -> b) -> a -> b
$ \ReaderOptions
ropts ByteString
input -> forall (m :: * -> *) a.
MonadIO m =>
GCManagedState -> LuaE PandocError a -> m a
inLua GCManagedState
st forall a b. (a -> b) -> a -> b
$ do
  forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
registryindex Name
readerField
  forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push ByteString
input
  forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push ReaderOptions
ropts
  forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace NumArgs
2 NumResults
1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Status
OK -> forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek forall a b. (a -> b) -> a -> b
$ forall e. LuaError e => Peeker e Pandoc
peekPandoc StackIndex
top
    Status
_ -> 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 (m :: * -> *).
(forall a. ToSources a => ReaderOptions -> a -> m Pandoc)
-> Reader m
TextReader forall a b. (a -> b) -> a -> b
$ \ReaderOptions
ropts a
srcs -> forall (m :: * -> *) a.
MonadIO m =>
GCManagedState -> LuaE PandocError a -> m a
inLua GCManagedState
st forall a b. (a -> b) -> a -> b
$ do
  let input :: Sources
input = forall a. ToSources a => a -> Sources
toSources a
srcs
  forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
registryindex Name
readerField
  forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push Sources
input
  forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push ReaderOptions
ropts
  forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace NumArgs
2 NumResults
1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Status
OK -> forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek forall a b. (a -> b) -> a -> b
$ forall e. LuaError e => Peeker e Pandoc
peekPandoc StackIndex
top
    Status
_ -> forall e a. LuaError e => LuaE e a
throwErrorAsException