{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
   Module      : Text.Pandoc.Lua.PandocLua
   Copyright   : Copyright © 2020-2021 Albert Krewinkel
   License     : GNU GPL, version 2 or above

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

PandocMonad instance which allows execution of Lua operations and which
uses Lua to handle state.
-}
module Text.Pandoc.Lua.PandocLua
  ( PandocLua (..)
  , runPandocLua
  , liftPandocLua
  , addFunction
  , loadDefaultModule
  ) where

import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Except (MonadError (catchError, throwError))
import Control.Monad.IO.Class (MonadIO)
import HsLua as Lua
import Text.Pandoc.Class.PandocMonad (PandocMonad (..), readDefaultDataFile)
import Text.Pandoc.Error (PandocError (PandocLuaError))
import Text.Pandoc.Lua.Global (Global (..), setGlobals)
import Text.Pandoc.Lua.Marshaling.CommonState (peekCommonState)

import qualified Control.Monad.Catch as Catch
import qualified Data.Text as T
import qualified Text.Pandoc.Class.IO as IO

-- | Type providing access to both, pandoc and Lua operations.
newtype PandocLua a = PandocLua { PandocLua a -> LuaE PandocError a
unPandocLua :: LuaE PandocError a }
  deriving
    ( Functor PandocLua
a -> PandocLua a
Functor PandocLua
-> (forall a. a -> PandocLua a)
-> (forall a b. PandocLua (a -> b) -> PandocLua a -> PandocLua b)
-> (forall a b c.
    (a -> b -> c) -> PandocLua a -> PandocLua b -> PandocLua c)
-> (forall a b. PandocLua a -> PandocLua b -> PandocLua b)
-> (forall a b. PandocLua a -> PandocLua b -> PandocLua a)
-> Applicative PandocLua
PandocLua a -> PandocLua b -> PandocLua b
PandocLua a -> PandocLua b -> PandocLua a
PandocLua (a -> b) -> PandocLua a -> PandocLua b
(a -> b -> c) -> PandocLua a -> PandocLua b -> PandocLua c
forall a. a -> PandocLua a
forall a b. PandocLua a -> PandocLua b -> PandocLua a
forall a b. PandocLua a -> PandocLua b -> PandocLua b
forall a b. PandocLua (a -> b) -> PandocLua a -> PandocLua b
forall a b c.
(a -> b -> c) -> PandocLua a -> PandocLua b -> PandocLua c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PandocLua a -> PandocLua b -> PandocLua a
$c<* :: forall a b. PandocLua a -> PandocLua b -> PandocLua a
*> :: PandocLua a -> PandocLua b -> PandocLua b
$c*> :: forall a b. PandocLua a -> PandocLua b -> PandocLua b
liftA2 :: (a -> b -> c) -> PandocLua a -> PandocLua b -> PandocLua c
$cliftA2 :: forall a b c.
(a -> b -> c) -> PandocLua a -> PandocLua b -> PandocLua c
<*> :: PandocLua (a -> b) -> PandocLua a -> PandocLua b
$c<*> :: forall a b. PandocLua (a -> b) -> PandocLua a -> PandocLua b
pure :: a -> PandocLua a
$cpure :: forall a. a -> PandocLua a
$cp1Applicative :: Functor PandocLua
Applicative
    , a -> PandocLua b -> PandocLua a
(a -> b) -> PandocLua a -> PandocLua b
(forall a b. (a -> b) -> PandocLua a -> PandocLua b)
-> (forall a b. a -> PandocLua b -> PandocLua a)
-> Functor PandocLua
forall a b. a -> PandocLua b -> PandocLua a
forall a b. (a -> b) -> PandocLua a -> PandocLua b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PandocLua b -> PandocLua a
$c<$ :: forall a b. a -> PandocLua b -> PandocLua a
fmap :: (a -> b) -> PandocLua a -> PandocLua b
$cfmap :: forall a b. (a -> b) -> PandocLua a -> PandocLua b
Functor
    , Applicative PandocLua
a -> PandocLua a
Applicative PandocLua
-> (forall a b. PandocLua a -> (a -> PandocLua b) -> PandocLua b)
-> (forall a b. PandocLua a -> PandocLua b -> PandocLua b)
-> (forall a. a -> PandocLua a)
-> Monad PandocLua
PandocLua a -> (a -> PandocLua b) -> PandocLua b
PandocLua a -> PandocLua b -> PandocLua b
forall a. a -> PandocLua a
forall a b. PandocLua a -> PandocLua b -> PandocLua b
forall a b. PandocLua a -> (a -> PandocLua b) -> PandocLua b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PandocLua a
$creturn :: forall a. a -> PandocLua a
>> :: PandocLua a -> PandocLua b -> PandocLua b
$c>> :: forall a b. PandocLua a -> PandocLua b -> PandocLua b
>>= :: PandocLua a -> (a -> PandocLua b) -> PandocLua b
$c>>= :: forall a b. PandocLua a -> (a -> PandocLua b) -> PandocLua b
$cp1Monad :: Applicative PandocLua
Monad
    , MonadThrow PandocLua
MonadThrow PandocLua
-> (forall e a.
    Exception e =>
    PandocLua a -> (e -> PandocLua a) -> PandocLua a)
-> MonadCatch PandocLua
PandocLua a -> (e -> PandocLua a) -> PandocLua a
forall e a.
Exception e =>
PandocLua a -> (e -> PandocLua a) -> PandocLua a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: PandocLua a -> (e -> PandocLua a) -> PandocLua a
$ccatch :: forall e a.
Exception e =>
PandocLua a -> (e -> PandocLua a) -> PandocLua a
$cp1MonadCatch :: MonadThrow PandocLua
MonadCatch
    , Monad PandocLua
Monad PandocLua
-> (forall a. IO a -> PandocLua a) -> MonadIO PandocLua
IO a -> PandocLua a
forall a. IO a -> PandocLua a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> PandocLua a
$cliftIO :: forall a. IO a -> PandocLua a
$cp1MonadIO :: Monad PandocLua
MonadIO
    , MonadCatch PandocLua
MonadCatch PandocLua
-> (forall b.
    ((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
    -> PandocLua b)
-> (forall b.
    ((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
    -> PandocLua b)
-> (forall a b c.
    PandocLua a
    -> (a -> ExitCase b -> PandocLua c)
    -> (a -> PandocLua b)
    -> PandocLua (b, c))
-> MonadMask PandocLua
PandocLua a
-> (a -> ExitCase b -> PandocLua c)
-> (a -> PandocLua b)
-> PandocLua (b, c)
((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
-> PandocLua b
((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
-> PandocLua b
forall b.
((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
-> PandocLua b
forall a b c.
PandocLua a
-> (a -> ExitCase b -> PandocLua c)
-> (a -> PandocLua b)
-> PandocLua (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: PandocLua a
-> (a -> ExitCase b -> PandocLua c)
-> (a -> PandocLua b)
-> PandocLua (b, c)
$cgeneralBracket :: forall a b c.
PandocLua a
-> (a -> ExitCase b -> PandocLua c)
-> (a -> PandocLua b)
-> PandocLua (b, c)
uninterruptibleMask :: ((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
-> PandocLua b
$cuninterruptibleMask :: forall b.
((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
-> PandocLua b
mask :: ((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
-> PandocLua b
$cmask :: forall b.
((forall a. PandocLua a -> PandocLua a) -> PandocLua b)
-> PandocLua b
$cp1MonadMask :: MonadCatch PandocLua
MonadMask
    , Monad PandocLua
e -> PandocLua a
Monad PandocLua
-> (forall e a. Exception e => e -> PandocLua a)
-> MonadThrow PandocLua
forall e a. Exception e => e -> PandocLua a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> PandocLua a
$cthrowM :: forall e a. Exception e => e -> PandocLua a
$cp1MonadThrow :: Monad PandocLua
MonadThrow
    )

-- | Lift a @'Lua'@ operation into the @'PandocLua'@ type.
liftPandocLua :: LuaE PandocError a -> PandocLua a
liftPandocLua :: LuaE PandocError a -> PandocLua a
liftPandocLua = LuaE PandocError a -> PandocLua a
forall a. LuaE PandocError a -> PandocLua a
PandocLua

-- | Evaluate a @'PandocLua'@ computation, running all contained Lua
-- operations..
runPandocLua :: (PandocMonad m, MonadIO m) => PandocLua a -> m a
runPandocLua :: PandocLua a -> m a
runPandocLua PandocLua a
pLua = do
  CommonState
origState <- m CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
  [Global]
globals <- m [Global]
forall (m :: * -> *). PandocMonad m => m [Global]
defaultGlobals
  (a
result, CommonState
newState) <- IO (a, CommonState) -> m (a, CommonState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, CommonState) -> m (a, CommonState))
-> (PandocLua (a, CommonState) -> IO (a, CommonState))
-> PandocLua (a, CommonState)
-> m (a, CommonState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LuaE PandocError (a, CommonState) -> IO (a, CommonState)
forall e a. LuaE e a -> IO a
Lua.run (LuaE PandocError (a, CommonState) -> IO (a, CommonState))
-> (PandocLua (a, CommonState)
    -> LuaE PandocError (a, CommonState))
-> PandocLua (a, CommonState)
-> IO (a, CommonState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocLua (a, CommonState) -> LuaE PandocError (a, CommonState)
forall a. PandocLua a -> LuaE PandocError a
unPandocLua (PandocLua (a, CommonState) -> m (a, CommonState))
-> PandocLua (a, CommonState) -> m (a, CommonState)
forall a b. (a -> b) -> a -> b
$ do
    CommonState -> PandocLua ()
forall (m :: * -> *). PandocMonad m => CommonState -> m ()
putCommonState CommonState
origState
    LuaE PandocError () -> PandocLua ()
forall a. LuaE PandocError a -> PandocLua a
liftPandocLua (LuaE PandocError () -> PandocLua ())
-> LuaE PandocError () -> PandocLua ()
forall a b. (a -> b) -> a -> b
$ [Global] -> LuaE PandocError ()
setGlobals [Global]
globals
    a
r <- PandocLua a
pLua
    CommonState
c <- PandocLua CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
    (a, CommonState) -> PandocLua (a, CommonState)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r, CommonState
c)
  CommonState -> m ()
forall (m :: * -> *). PandocMonad m => CommonState -> m ()
putCommonState CommonState
newState
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

instance {-# OVERLAPPING #-} Exposable PandocError (PandocLua NumResults) where
  partialApply :: StackIndex -> PandocLua NumResults -> LuaE PandocError NumResults
partialApply StackIndex
_narg = PandocLua NumResults -> LuaE PandocError NumResults
forall a. PandocLua a -> LuaE PandocError a
unPandocLua

instance Pushable a => Exposable PandocError (PandocLua a) where
  partialApply :: StackIndex -> PandocLua a -> LuaE PandocError NumResults
partialApply StackIndex
_narg PandocLua a
x = NumResults
1 NumResults -> LuaE PandocError () -> LuaE PandocError NumResults
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (PandocLua a -> LuaE PandocError a
forall a. PandocLua a -> LuaE PandocError a
unPandocLua PandocLua a
x LuaE PandocError a
-> (a -> LuaE PandocError ()) -> LuaE PandocError ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> LuaE PandocError ()
forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
Lua.push)

-- | Add a function to the table at the top of the stack, using the given name.
addFunction :: Exposable PandocError a => Name -> a -> PandocLua ()
addFunction :: Name -> a -> PandocLua ()
addFunction Name
name a
fn = LuaE PandocError () -> PandocLua ()
forall a. LuaE PandocError a -> PandocLua a
liftPandocLua (LuaE PandocError () -> PandocLua ())
-> LuaE PandocError () -> PandocLua ()
forall a b. (a -> b) -> a -> b
$ do
  Name -> LuaE PandocError ()
forall e. Name -> LuaE e ()
Lua.pushName Name
name
  LuaE PandocError NumResults -> LuaE PandocError ()
forall e. LuaError e => HaskellFunction e -> LuaE e ()
Lua.pushHaskellFunction (LuaE PandocError NumResults -> LuaE PandocError ())
-> LuaE PandocError NumResults -> LuaE PandocError ()
forall a b. (a -> b) -> a -> b
$ a -> LuaE PandocError NumResults
forall e a. Exposable e a => a -> HaskellFunction e
toHaskellFunction a
fn
  StackIndex -> LuaE PandocError ()
forall e. LuaError e => StackIndex -> LuaE e ()
Lua.rawset (-StackIndex
3)

-- | Load a pure Lua module included with pandoc. Leaves the result on
-- the stack and returns @NumResults 1@.
--
-- The script is loaded from the default data directory. We do not load
-- from data directories supplied via command line, as this could cause
-- scripts to be executed even though they had not been passed explicitly.
loadDefaultModule :: String -> PandocLua NumResults
loadDefaultModule :: String -> PandocLua NumResults
loadDefaultModule String
name = do
  ByteString
script <- String -> PandocLua ByteString
forall (m :: * -> *). PandocMonad m => String -> m ByteString
readDefaultDataFile (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".lua")
  Status
result <- LuaE PandocError Status -> PandocLua Status
forall a. LuaE PandocError a -> PandocLua a
liftPandocLua (LuaE PandocError Status -> PandocLua Status)
-> LuaE PandocError Status -> PandocLua Status
forall a b. (a -> b) -> a -> b
$ ByteString -> LuaE PandocError Status
forall e. ByteString -> LuaE e Status
Lua.dostring ByteString
script
  if Status
result Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Lua.OK
    then NumResults -> PandocLua NumResults
forall (m :: * -> *) a. Monad m => a -> m a
return (NumResults
1 :: NumResults)
    else do
      String
msg <- LuaE PandocError String -> PandocLua String
forall a. LuaE PandocError a -> PandocLua a
liftPandocLua LuaE PandocError String
forall e a. (PeekError e, Peekable a) => LuaE e a
Lua.popValue
      let err :: String
err = String
"Error while loading `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`.\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
      PandocError -> PandocLua NumResults
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> PandocLua NumResults)
-> PandocError -> PandocLua NumResults
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocLuaError (String -> Text
T.pack String
err)

-- | Global variables which should always be set.
defaultGlobals :: PandocMonad m => m [Global]
defaultGlobals :: m [Global]
defaultGlobals = do
  CommonState
commonState <- m CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
  [Global] -> m [Global]
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Global
PANDOC_API_VERSION
    , CommonState -> Global
PANDOC_STATE CommonState
commonState
    , Global
PANDOC_VERSION
    ]

instance MonadError PandocError PandocLua where
  catchError :: PandocLua a -> (PandocError -> PandocLua a) -> PandocLua a
catchError = PandocLua a -> (PandocError -> PandocLua a) -> PandocLua a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Catch.catch
  throwError :: PandocError -> PandocLua a
throwError = PandocError -> PandocLua a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM

instance PandocMonad PandocLua where
  lookupEnv :: Text -> PandocLua (Maybe Text)
lookupEnv = Text -> PandocLua (Maybe Text)
forall (m :: * -> *). MonadIO m => Text -> m (Maybe Text)
IO.lookupEnv
  getCurrentTime :: PandocLua UTCTime
getCurrentTime = PandocLua UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
IO.getCurrentTime
  getCurrentTimeZone :: PandocLua TimeZone
getCurrentTimeZone = PandocLua TimeZone
forall (m :: * -> *). MonadIO m => m TimeZone
IO.getCurrentTimeZone
  newStdGen :: PandocLua StdGen
newStdGen = PandocLua StdGen
forall (m :: * -> *). MonadIO m => m StdGen
IO.newStdGen
  newUniqueHash :: PandocLua Int
newUniqueHash = PandocLua Int
forall (m :: * -> *). MonadIO m => m Int
IO.newUniqueHash

  openURL :: Text -> PandocLua (ByteString, Maybe Text)
openURL = Text -> PandocLua (ByteString, Maybe Text)
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
Text -> m (ByteString, Maybe Text)
IO.openURL

  readFileLazy :: String -> PandocLua ByteString
readFileLazy = String -> PandocLua ByteString
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m ByteString
IO.readFileLazy
  readFileStrict :: String -> PandocLua ByteString
readFileStrict = String -> PandocLua ByteString
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m ByteString
IO.readFileStrict
  readStdinStrict :: PandocLua ByteString
readStdinStrict = PandocLua ByteString
forall (m :: * -> *). (PandocMonad m, MonadIO m) => m ByteString
IO.readStdinStrict

  glob :: String -> PandocLua [String]
glob = String -> PandocLua [String]
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m [String]
IO.glob
  fileExists :: String -> PandocLua Bool
fileExists = String -> PandocLua Bool
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m Bool
IO.fileExists
  getDataFileName :: String -> PandocLua String
getDataFileName = String -> PandocLua String
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m String
IO.getDataFileName
  getModificationTime :: String -> PandocLua UTCTime
getModificationTime = String -> PandocLua UTCTime
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m UTCTime
IO.getModificationTime

  getCommonState :: PandocLua CommonState
getCommonState = LuaE PandocError CommonState -> PandocLua CommonState
forall a. LuaE PandocError a -> PandocLua a
PandocLua (LuaE PandocError CommonState -> PandocLua CommonState)
-> LuaE PandocError CommonState -> PandocLua CommonState
forall a b. (a -> b) -> a -> b
$ do
    Name -> LuaE PandocError Type
forall e. LuaError e => Name -> LuaE e Type
Lua.getglobal Name
"PANDOC_STATE"
    Peek PandocError CommonState -> LuaE PandocError CommonState
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek PandocError CommonState -> LuaE PandocError CommonState)
-> Peek PandocError CommonState -> LuaE PandocError CommonState
forall a b. (a -> b) -> a -> b
$ Peeker PandocError CommonState
forall e. LuaError e => Peeker e CommonState
peekCommonState StackIndex
Lua.top
  putCommonState :: CommonState -> PandocLua ()
putCommonState = LuaE PandocError () -> PandocLua ()
forall a. LuaE PandocError a -> PandocLua a
PandocLua (LuaE PandocError () -> PandocLua ())
-> (CommonState -> LuaE PandocError ())
-> CommonState
-> PandocLua ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Global] -> LuaE PandocError ()
setGlobals ([Global] -> LuaE PandocError ())
-> (CommonState -> [Global]) -> CommonState -> LuaE PandocError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Global -> [Global] -> [Global]
forall a. a -> [a] -> [a]
:[]) (Global -> [Global])
-> (CommonState -> Global) -> CommonState -> [Global]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommonState -> Global
PANDOC_STATE

  logOutput :: LogMessage -> PandocLua ()
logOutput = LogMessage -> PandocLua ()
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
LogMessage -> m ()
IO.logOutput