{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Lua.Module.Pandoc
   Copyright   : Copyright © 2017-2021 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
   Stability   : alpha

Pandoc module for lua.
-}
module Text.Pandoc.Lua.Module.Pandoc
  ( pushModule
  ) where

import Prelude hiding (read)
import Control.Monad (when)
import Control.Monad.Except (throwError)
import Data.Default (Default (..))
import Data.Maybe (fromMaybe)
import Foreign.Lua (Lua, NumResults, Optional, Peekable, Pushable)
import System.Exit (ExitCode (..))
import Text.Pandoc.Class.PandocIO (runIO)
import Text.Pandoc.Definition (Block, Inline)
import Text.Pandoc.Lua.Filter (LuaFilter, SingletonsList (..), walkInlines,
                               walkInlineLists, walkBlocks, walkBlockLists)
import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Marshaling.List (List (..))
import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua,
                                  loadDefaultModule)
import Text.Pandoc.Walk (Walkable)
import Text.Pandoc.Options (ReaderOptions (readerExtensions))
import Text.Pandoc.Process (pipeProcess)
import Text.Pandoc.Readers (Reader (..), getReader)

import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
import Text.Pandoc.Error

-- | Push the "pandoc" package to the Lua stack. Requires the `List`
-- module to be loadable.
pushModule :: PandocLua NumResults
pushModule :: PandocLua NumResults
pushModule = do
  String -> PandocLua NumResults
loadDefaultModule String
"pandoc"
  String
-> (Text -> Optional Text -> PandocLua NumResults) -> PandocLua ()
forall a. ToHaskellFunction a => String -> a -> PandocLua ()
addFunction String
"read" Text -> Optional Text -> PandocLua NumResults
read
  String
-> (String -> [String] -> ByteString -> PandocLua NumResults)
-> PandocLua ()
forall a. ToHaskellFunction a => String -> a -> PandocLua ()
addFunction String
"pipe" String -> [String] -> ByteString -> PandocLua NumResults
pipe
  String -> (Block -> LuaFilter -> PandocLua Block) -> PandocLua ()
forall a. ToHaskellFunction a => String -> a -> PandocLua ()
addFunction String
"walk_block" Block -> LuaFilter -> PandocLua Block
walk_block
  String -> (Inline -> LuaFilter -> PandocLua Inline) -> PandocLua ()
forall a. ToHaskellFunction a => String -> a -> PandocLua ()
addFunction String
"walk_inline" Inline -> LuaFilter -> PandocLua Inline
walk_inline
  NumResults -> PandocLua NumResults
forall (m :: * -> *) a. Monad m => a -> m a
return NumResults
1

walkElement :: (Walkable (SingletonsList Inline) a,
                Walkable (SingletonsList Block) a,
                Walkable (List Inline) a,
                Walkable (List Block) a)
            => a -> LuaFilter -> PandocLua a
walkElement :: a -> LuaFilter -> PandocLua a
walkElement a
x LuaFilter
f = Lua a -> PandocLua a
forall a. Lua a -> PandocLua a
liftPandocLua (Lua a -> PandocLua a) -> Lua a -> PandocLua a
forall a b. (a -> b) -> a -> b
$
  LuaFilter -> a -> Lua a
forall a.
Walkable (SingletonsList Inline) a =>
LuaFilter -> a -> Lua a
walkInlines LuaFilter
f a
x Lua a -> (a -> Lua a) -> Lua a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LuaFilter -> a -> Lua a
forall a. Walkable (List Inline) a => LuaFilter -> a -> Lua a
walkInlineLists LuaFilter
f Lua a -> (a -> Lua a) -> Lua a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LuaFilter -> a -> Lua a
forall a.
Walkable (SingletonsList Block) a =>
LuaFilter -> a -> Lua a
walkBlocks LuaFilter
f Lua a -> (a -> Lua a) -> Lua a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LuaFilter -> a -> Lua a
forall a. Walkable (List Block) a => LuaFilter -> a -> Lua a
walkBlockLists LuaFilter
f

walk_inline :: Inline -> LuaFilter -> PandocLua Inline
walk_inline :: Inline -> LuaFilter -> PandocLua Inline
walk_inline = Inline -> LuaFilter -> PandocLua Inline
forall a.
(Walkable (SingletonsList Inline) a,
 Walkable (SingletonsList Block) a, Walkable (List Inline) a,
 Walkable (List Block) a) =>
a -> LuaFilter -> PandocLua a
walkElement

walk_block :: Block -> LuaFilter -> PandocLua Block
walk_block :: Block -> LuaFilter -> PandocLua Block
walk_block = Block -> LuaFilter -> PandocLua Block
forall a.
(Walkable (SingletonsList Inline) a,
 Walkable (SingletonsList Block) a, Walkable (List Inline) a,
 Walkable (List Block) a) =>
a -> LuaFilter -> PandocLua a
walkElement

read :: T.Text -> Optional T.Text -> PandocLua NumResults
read :: Text -> Optional Text -> PandocLua NumResults
read Text
content Optional Text
formatSpecOrNil = Lua NumResults -> PandocLua NumResults
forall a. Lua a -> PandocLua a
liftPandocLua (Lua NumResults -> PandocLua NumResults)
-> Lua NumResults -> PandocLua NumResults
forall a b. (a -> b) -> a -> b
$ do
  let formatSpec :: Text
formatSpec = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"markdown" (Optional Text -> Maybe Text
forall a. Optional a -> Maybe a
Lua.fromOptional Optional Text
formatSpecOrNil)
  Either PandocError Pandoc
res <- IO (Either PandocError Pandoc) -> Lua (Either PandocError Pandoc)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (IO (Either PandocError Pandoc) -> Lua (Either PandocError Pandoc))
-> (PandocIO Pandoc -> IO (Either PandocError Pandoc))
-> PandocIO Pandoc
-> Lua (Either PandocError Pandoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocIO Pandoc -> IO (Either PandocError Pandoc)
forall a. PandocIO a -> IO (Either PandocError a)
runIO (PandocIO Pandoc -> Lua (Either PandocError Pandoc))
-> PandocIO Pandoc -> Lua (Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$
           Text -> PandocIO (Reader PandocIO, Extensions)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (Reader m, Extensions)
getReader Text
formatSpec PandocIO (Reader PandocIO, Extensions)
-> ((Reader PandocIO, Extensions) -> PandocIO Pandoc)
-> PandocIO Pandoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Reader PandocIO
rdr,Extensions
es) ->
             case Reader PandocIO
rdr of
               TextReader forall a. ToSources a => ReaderOptions -> a -> PandocIO Pandoc
r ->
                 ReaderOptions -> Text -> PandocIO Pandoc
forall a. ToSources a => ReaderOptions -> a -> PandocIO Pandoc
r ReaderOptions
forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = Extensions
es } Text
content
               Reader PandocIO
_ -> PandocError -> PandocIO Pandoc
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> PandocIO Pandoc) -> PandocError -> PandocIO Pandoc
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
                      Text
"Only textual formats are supported"
  case Either PandocError Pandoc
res of
    Right Pandoc
pd -> (NumResults
1 :: NumResults) NumResults -> Lua () -> Lua NumResults
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Pandoc -> Lua ()
forall a. Pushable a => a -> Lua ()
Lua.push Pandoc
pd -- success, push Pandoc
    Left  (PandocUnknownReaderError Text
f) -> Text -> Lua NumResults
forall a. Pushable a => a -> Lua NumResults
Lua.raiseError (Text -> Lua NumResults) -> Text -> Lua NumResults
forall a b. (a -> b) -> a -> b
$
       Text
"Unknown reader: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f
    Left  (PandocUnsupportedExtensionError Text
e Text
f) -> Text -> Lua NumResults
forall a. Pushable a => a -> Lua NumResults
Lua.raiseError (Text -> Lua NumResults) -> Text -> Lua NumResults
forall a b. (a -> b) -> a -> b
$
       Text
"Extension " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not supported for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f
    Left  PandocError
e      -> String -> Lua NumResults
forall a. Pushable a => a -> Lua NumResults
Lua.raiseError (String -> Lua NumResults) -> String -> Lua NumResults
forall a b. (a -> b) -> a -> b
$ PandocError -> String
forall a. Show a => a -> String
show PandocError
e

-- | Pipes input through a command.
pipe :: String           -- ^ path to executable
     -> [String]         -- ^ list of arguments
     -> BL.ByteString    -- ^ input passed to process via stdin
     -> PandocLua NumResults
pipe :: String -> [String] -> ByteString -> PandocLua NumResults
pipe String
command [String]
args ByteString
input = Lua NumResults -> PandocLua NumResults
forall a. Lua a -> PandocLua a
liftPandocLua (Lua NumResults -> PandocLua NumResults)
-> Lua NumResults -> PandocLua NumResults
forall a b. (a -> b) -> a -> b
$ do
  (ExitCode
ec, ByteString
output) <- IO (ExitCode, ByteString) -> Lua (ExitCode, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (IO (ExitCode, ByteString) -> Lua (ExitCode, ByteString))
-> IO (ExitCode, ByteString) -> Lua (ExitCode, ByteString)
forall a b. (a -> b) -> a -> b
$ Maybe [(String, String)]
-> String -> [String] -> ByteString -> IO (ExitCode, ByteString)
pipeProcess Maybe [(String, String)]
forall a. Maybe a
Nothing String
command [String]
args ByteString
input
  case ExitCode
ec of
    ExitCode
ExitSuccess -> NumResults
1 NumResults -> Lua () -> Lua NumResults
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Lua ()
forall a. Pushable a => a -> Lua ()
Lua.push ByteString
output
    ExitFailure Int
n -> PipeError -> Lua NumResults
forall a. Pushable a => a -> Lua NumResults
Lua.raiseError (Text -> Int -> ByteString -> PipeError
PipeError (String -> Text
T.pack String
command) Int
n ByteString
output)

data PipeError = PipeError
  { PipeError -> Text
pipeErrorCommand :: T.Text
  , PipeError -> Int
pipeErrorCode :: Int
  , PipeError -> ByteString
pipeErrorOutput :: BL.ByteString
  }

instance Peekable PipeError where
  peek :: StackIndex -> Lua PipeError
peek StackIndex
idx =
    Text -> Int -> ByteString -> PipeError
PipeError
    (Text -> Int -> ByteString -> PipeError)
-> Lua Text -> Lua (Int -> ByteString -> PipeError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StackIndex -> String -> Lua ()
Lua.getfield StackIndex
idx String
"command"    Lua () -> Lua Text -> Lua Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> Lua Text
forall a. Peekable a => StackIndex -> Lua a
Lua.peek (-StackIndex
1) Lua Text -> Lua () -> Lua Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StackIndex -> Lua ()
Lua.pop StackIndex
1)
    Lua (Int -> ByteString -> PipeError)
-> Lua Int -> Lua (ByteString -> PipeError)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (StackIndex -> String -> Lua ()
Lua.getfield StackIndex
idx String
"error_code" Lua () -> Lua Int -> Lua Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> Lua Int
forall a. Peekable a => StackIndex -> Lua a
Lua.peek (-StackIndex
1) Lua Int -> Lua () -> Lua Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StackIndex -> Lua ()
Lua.pop StackIndex
1)
    Lua (ByteString -> PipeError) -> Lua ByteString -> Lua PipeError
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (StackIndex -> String -> Lua ()
Lua.getfield StackIndex
idx String
"output"     Lua () -> Lua ByteString -> Lua ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> Lua ByteString
forall a. Peekable a => StackIndex -> Lua a
Lua.peek (-StackIndex
1) Lua ByteString -> Lua () -> Lua ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StackIndex -> Lua ()
Lua.pop StackIndex
1)

instance Pushable PipeError where
  push :: PipeError -> Lua ()
push PipeError
pipeErr = do
    Lua ()
Lua.newtable
    String -> Text -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
LuaUtil.addField String
"command" (PipeError -> Text
pipeErrorCommand PipeError
pipeErr)
    String -> Int -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
LuaUtil.addField String
"error_code" (PipeError -> Int
pipeErrorCode PipeError
pipeErr)
    String -> ByteString -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
LuaUtil.addField String
"output" (PipeError -> ByteString
pipeErrorOutput PipeError
pipeErr)
    Lua ()
pushPipeErrorMetaTable
    StackIndex -> Lua ()
Lua.setmetatable (-StackIndex
2)
      where
        pushPipeErrorMetaTable :: Lua ()
        pushPipeErrorMetaTable :: Lua ()
pushPipeErrorMetaTable = do
          Bool
v <- String -> Lua Bool
Lua.newmetatable String
"pandoc pipe error"
          Bool -> Lua () -> Lua ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
v (Lua () -> Lua ()) -> Lua () -> Lua ()
forall a b. (a -> b) -> a -> b
$ String -> (PipeError -> Lua ByteString) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
LuaUtil.addFunction String
"__tostring" PipeError -> Lua ByteString
pipeErrorMessage

        pipeErrorMessage :: PipeError -> Lua BL.ByteString
        pipeErrorMessage :: PipeError -> Lua ByteString
pipeErrorMessage (PipeError Text
cmd Int
errorCode ByteString
output) = ByteString -> Lua ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Lua ByteString) -> ByteString -> Lua ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
          [ String -> ByteString
BSL.pack String
"Error running "
          , String -> ByteString
BSL.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cmd
          , String -> ByteString
BSL.pack String
" (error code "
          , String -> ByteString
BSL.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
errorCode
          , String -> ByteString
BSL.pack String
"): "
          , if ByteString
output ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. Monoid a => a
mempty then String -> ByteString
BSL.pack String
"<no output>" else ByteString
output
          ]