Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Switch to hslua-2.0

Browse source 
The new HsLua version takes a somewhat different approach to marshalling
and unmarshalling, relying less on typeclasses and more on specialized
types. This allows for better performance and improved error messages.

Furthermore, new abstractions allow to document the code and exposed
functions.
This commit is contained in:
Albert Krewinkel 2021-10-20 21:40:07 +02:00 committed by John MacFarlane
parent e10f495a01
commit 9e74826ba9
29 changed files with 1129 additions and 1226 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
cabal.project
View file

@ -41,4 +41,3 @@ source-repository-package
-- type: git
-- location: https://github.com/jgm/ipynb.git
-- tag: 1f1ddb29227335091a3a158b9aeeeb47a372c683

15
pandoc.cabal
View file

@ -551,10 +551,11 @@ library
file-embed >= 0.0 && < 0.1,
filepath >= 1.1 && < 1.5,
haddock-library >= 1.10 && < 1.11,
hslua >= 1.1 && < 1.4,
hslua-module-path >= 0.1.0 && < 0.2.0,
hslua-module-system >= 0.2 && < 0.3,
hslua-module-text >= 0.2.1 && < 0.4,
hslua >= 2.0 && < 2.1,
hslua-marshalling >= 2.0 && < 2.1,
hslua-module-path >= 1.0 && < 1.1,
hslua-module-system >= 1.0 && < 1.1,
hslua-module-text >= 1.0 && < 1.1,
http-client >= 0.4.30 && < 0.8,
http-client-tls >= 0.2.4 && < 0.4,
http-types >= 0.8 && < 0.13,
@ -775,11 +776,9 @@ library
Text.Pandoc.Lua.Init,
Text.Pandoc.Lua.Marshaling,
Text.Pandoc.Lua.Marshaling.AST,
Text.Pandoc.Lua.Marshaling.AnyValue,
Text.Pandoc.Lua.Marshaling.CommonState,
Text.Pandoc.Lua.Marshaling.Context,
Text.Pandoc.Lua.Marshaling.List,
Text.Pandoc.Lua.Marshaling.MediaBag,
Text.Pandoc.Lua.Marshaling.PandocError,
Text.Pandoc.Lua.Marshaling.ReaderOptions,
Text.Pandoc.Lua.Marshaling.SimpleTable,
@ -847,14 +846,14 @@ test-suite test-pandoc
doctemplates >= 0.10 && < 0.11,
exceptions >= 0.8 && < 0.11,
filepath >= 1.1 && < 1.5,
hslua >= 1.1 && < 1.4,
hslua >= 2.0 && < 2.1,
mtl >= 2.2 && < 2.3,
pandoc-types >= 1.22 && < 1.23,
process >= 1.2.3 && < 1.7,
tasty >= 0.11 && < 1.5,
tasty-golden >= 2.3 && < 2.4,
tasty-hunit >= 0.9 && < 0.11,
tasty-lua >= 0.2 && < 0.3,
tasty-lua >= 1.0 && < 1.1,
tasty-quickcheck >= 0.8 && < 0.11,
text >= 1.1.1.0 && < 1.3,
time >= 1.5 && < 1.13,

63
src/Text/Pandoc/Lua/ErrorConversion.hs
View file

@ -1,6 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Text.Pandoc.Lua.ErrorConversion
Copyright : © 2020-2021 Albert Krewinkel
@ -13,49 +12,37 @@ Define how Lua errors are converted into @'PandocError'@ Haskell
exceptions, and /vice versa/.
-}
module Text.Pandoc.Lua.ErrorConversion
( errorConversion
( addContextToException
) where
import Foreign.Lua (Lua (..), NumResults)
import HsLua (LuaError, LuaE, top)
import HsLua.Marshalling (resultToEither, runPeek)
import HsLua.Class.Peekable (PeekError (..))
import Text.Pandoc.Error (PandocError (PandocLuaError))
import Text.Pandoc.Lua.Marshaling.PandocError (pushPandocError, peekPandocError)
import qualified Control.Monad.Catch as Catch
import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified HsLua as Lua
-- | Conversions between Lua errors and Haskell exceptions, assuming
-- that all exceptions are of type @'PandocError'@.
errorConversion :: Lua.ErrorConversion
errorConversion = Lua.ErrorConversion
{ Lua.addContextToException = addContextToException
, Lua.alternative = alternative
, Lua.errorToException = errorToException
, Lua.exceptionToError = exceptionToError
}
addContextToException :: ()
addContextToException = undefined
-- | Convert a Lua error, which must be at the top of the stack, into a
-- @'PandocError'@, popping the value from the stack.
errorToException :: forall a . Lua.State -> IO a
errorToException l = Lua.unsafeRunWith l $ do
err <- peekPandocError Lua.stackTop
Lua.pop 1
Catch.throwM err
-- | Retrieve a @'PandocError'@ from the Lua stack.
popPandocError :: LuaE PandocError PandocError
popPandocError = do
errResult <- runPeek $ peekPandocError top
case resultToEither errResult of
Right x -> return x
Left err -> return $ PandocLuaError (T.pack err)
-- | Try the first op -- if it doesn't succeed, run the second.
alternative :: forall a . Lua a -> Lua a -> Lua a
alternative x y = Catch.try x >>= \case
Left (_ :: PandocError) -> y
Right x' -> return x'
-- Ensure conversions between Lua errors and 'PandocError' exceptions
-- are possible.
instance LuaError PandocError where
popException = popPandocError
pushException = pushPandocError
luaException = PandocLuaError . T.pack
-- | Add more context to an error
addContextToException :: forall a . String -> Lua a -> Lua a
addContextToException ctx op = op `Catch.catch` \case
PandocLuaError msg -> Catch.throwM $ PandocLuaError (T.pack ctx <> msg)
e -> Catch.throwM e
-- | Catch a @'PandocError'@ exception and raise it as a Lua error.
exceptionToError :: Lua NumResults -> Lua NumResults
exceptionToError op = op `Catch.catch` \e -> do
pushPandocError e
Lua.error
instance PeekError PandocError where
messageFromException = \case
PandocLuaError m -> T.unpack m
err -> show err

178
src/Text/Pandoc/Lua/Filter.hs
View file

@ -1,4 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Text.Pandoc.Lua.Filter
Copyright : © 2012-2021 John MacFarlane,
@ -19,43 +22,42 @@ module Text.Pandoc.Lua.Filter ( LuaFilterFunction
, module Text.Pandoc.Lua.Walk
) where
import Control.Applicative ((<|>))
import Control.Monad (mplus, (>=>))
import Control.Monad.Catch (finally, try)
import Control.Monad (mplus, (>=>), (<$!>))
import Data.Data (Data, DataType, dataTypeConstrs, dataTypeName, dataTypeOf,
showConstr, toConstr, tyconUQname)
import Data.Foldable (foldrM)
import Data.List (foldl')
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex)
import Data.String (IsString (fromString))
import HsLua as Lua
import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Marshaling.List (List (..))
import Text.Pandoc.Lua.Marshaling.AST
import Text.Pandoc.Lua.Marshaling.List (List (..), peekList')
import Text.Pandoc.Lua.Walk (SingletonsList (..))
import Text.Pandoc.Walk (Walkable (walkM))
import qualified Data.Map.Strict as Map
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
-- | Transform document using the filter defined in the given file.
runFilterFile :: FilePath -> Pandoc -> Lua Pandoc
runFilterFile :: FilePath -> Pandoc -> LuaE PandocError Pandoc
runFilterFile filterPath doc = do
top <- Lua.gettop
oldtop <- Lua.gettop
stat <- LuaUtil.dofileWithTraceback filterPath
if stat /= Lua.OK
then Lua.throwTopMessage
then Lua.throwErrorAsException
else do
newtop <- Lua.gettop
-- Use the returned filters, or the implicitly defined global
-- filter if nothing was returned.
luaFilters <- if newtop - top >= 1
then Lua.peek Lua.stackTop
luaFilters <- if newtop - oldtop >= 1
then Lua.peek Lua.top
else Lua.pushglobaltable *> fmap (:[]) Lua.popValue
runAll luaFilters doc
runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc
runAll :: [LuaFilter] -> Pandoc -> LuaE PandocError Pandoc
runAll = foldr ((>=>) . walkMWithLuaFilter) return
-- | Filter function stored in the registry
@ -63,7 +65,7 @@ newtype LuaFilterFunction = LuaFilterFunction Lua.Reference
-- | Collection of filter functions (at most one function per element
-- constructor)
newtype LuaFilter = LuaFilter (Map String LuaFilterFunction)
newtype LuaFilter = LuaFilter (Map Name LuaFilterFunction)
instance Peekable LuaFilter where
peek idx = do
@ -79,19 +81,19 @@ instance Peekable LuaFilter where
return $ case filterFn of
Nothing -> acc
Just fn -> Map.insert constr fn acc
LuaFilter <$> foldrM go Map.empty constrs
LuaFilter <$!> foldrM go Map.empty constrs
-- | Register the function at the top of the stack as a filter function in the
-- registry.
registerFilterFunction :: Lua (Maybe LuaFilterFunction)
registerFilterFunction :: LuaError e => LuaE e (Maybe LuaFilterFunction)
registerFilterFunction = do
isFn <- Lua.isfunction Lua.stackTop
isFn <- Lua.isfunction Lua.top
if isFn
then Just . LuaFilterFunction <$> Lua.ref Lua.registryindex
else Nothing <$ Lua.pop 1
-- | Retrieve filter function from registry and push it to the top of the stack.
pushFilterFunction :: LuaFilterFunction -> Lua ()
pushFilterFunction :: LuaFilterFunction -> LuaE PandocError ()
pushFilterFunction (LuaFilterFunction fnRef) =
Lua.getref Lua.registryindex fnRef
@ -99,58 +101,66 @@ pushFilterFunction (LuaFilterFunction fnRef) =
-- element instead of a list, fetch that element as a singleton list. If the top
-- of the stack is nil, return the default element that was passed to this
-- function. If none of these apply, raise an error.
elementOrList :: Peekable a => a -> Lua [a]
elementOrList x = do
let topOfStack = Lua.stackTop
elementUnchanged <- Lua.isnil topOfStack
elementOrList :: Peeker PandocError a -> a -> LuaE PandocError [a]
elementOrList p x = do
elementUnchanged <- Lua.isnil top
if elementUnchanged
then [x] <$ Lua.pop 1
else do
mbres <- peekEither topOfStack
case mbres of
Right res -> [res] <$ Lua.pop 1
Left _ -> Lua.peekList topOfStack `finally` Lua.pop 1
then [x] <$ pop 1
else forcePeek . (`lastly` pop 1) $ (((:[]) <$!> p top) <|> peekList p top)
-- | Fetches a single element; returns the fallback if the value is @nil@.
singleElement :: forall a e. (LuaError e) => Peeker e a -> a -> LuaE e a
singleElement p x = do
elementUnchanged <- Lua.isnil top
if elementUnchanged
then x <$ Lua.pop 1
else forcePeek $ p top `lastly` pop 1
-- | Pop and return a value from the stack; if the value at the top of
-- the stack is @nil@, return the fallback element.
popOption :: Peekable a => a -> Lua a
popOption fallback = fromMaybe fallback . Lua.fromOptional <$> Lua.popValue
popOption :: Peeker PandocError a -> a -> LuaE PandocError a
popOption peeker fallback = forcePeek . (`lastly` pop 1) $
(fallback <$ peekNil top) <|> peeker top
-- | Apply filter on a sequence of AST elements. Both lists and single
-- value are accepted as filter function return values.
runOnSequence :: (Data a, Peekable a, Pushable a)
=> LuaFilter -> SingletonsList a -> Lua (SingletonsList a)
runOnSequence (LuaFilter fnMap) (SingletonsList xs) =
runOnSequence :: forall a. (Data a, Pushable a)
=> Peeker PandocError a -> LuaFilter -> SingletonsList a
-> LuaE PandocError (SingletonsList a)
runOnSequence peeker (LuaFilter fnMap) (SingletonsList xs) =
SingletonsList <$> mconcatMapM tryFilter xs
where
tryFilter :: (Data a, Peekable a, Pushable a) => a -> Lua [a]
tryFilter :: a -> LuaE PandocError [a]
tryFilter x =
let filterFnName = showConstr (toConstr x)
catchAllName = tyconUQname $ dataTypeName (dataTypeOf x)
let filterFnName = fromString $ showConstr (toConstr x)
catchAllName = fromString . tyconUQname $ dataTypeName (dataTypeOf x)
in case Map.lookup filterFnName fnMap <|> Map.lookup catchAllName fnMap of
Just fn -> runFilterFunction fn x *> elementOrList x
Just fn -> runFilterFunction fn x *> elementOrList peeker x
Nothing -> return [x]
-- | Try filtering the given value without type error corrections on
-- the return value.
runOnValue :: (Data a, Peekable a, Pushable a)
=> String -> LuaFilter -> a -> Lua a
runOnValue filterFnName (LuaFilter fnMap) x =
runOnValue :: (Data a, Pushable a)
=> Name -> Peeker PandocError a
-> LuaFilter -> a
-> LuaE PandocError a
runOnValue filterFnName peeker (LuaFilter fnMap) x =
case Map.lookup filterFnName fnMap of
Just fn -> runFilterFunction fn x *> popOption x
Just fn -> runFilterFunction fn x *> popOption peeker x
Nothing -> return x
-- | Push a value to the stack via a lua filter function. The filter function is
-- called with given element as argument and is expected to return an element.
-- Alternatively, the function can return nothing or nil, in which case the
-- element is left unchanged.
runFilterFunction :: Pushable a => LuaFilterFunction -> a -> Lua ()
-- | Push a value to the stack via a Lua filter function. The filter
-- function is called with the given element as argument and is expected
-- to return an element. Alternatively, the function can return nothing
-- or nil, in which case the element is left unchanged.
runFilterFunction :: Pushable a
=> LuaFilterFunction -> a -> LuaE PandocError ()
runFilterFunction lf x = do
pushFilterFunction lf
Lua.push x
LuaUtil.callWithTraceback 1 1
walkMWithLuaFilter :: LuaFilter -> Pandoc -> Lua Pandoc
walkMWithLuaFilter :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc
walkMWithLuaFilter f =
walkInlines f
>=> walkInlineLists f
@ -162,92 +172,76 @@ walkMWithLuaFilter f =
mconcatMapM :: (Monad m) => (a -> m [a]) -> [a] -> m [a]
mconcatMapM f = fmap mconcat . mapM f
hasOneOf :: LuaFilter -> [String] -> Bool
hasOneOf :: LuaFilter -> [Name] -> Bool
hasOneOf (LuaFilter fnMap) = any (`Map.member` fnMap)
contains :: LuaFilter -> String -> Bool
contains :: LuaFilter -> Name -> Bool
contains (LuaFilter fnMap) = (`Map.member` fnMap)
walkInlines :: Walkable (SingletonsList Inline) a => LuaFilter -> a -> Lua a
walkInlines :: Walkable (SingletonsList Inline) a
=> LuaFilter -> a -> LuaE PandocError a
walkInlines lf =
let f :: SingletonsList Inline -> Lua (SingletonsList Inline)
f = runOnSequence lf
let f :: SingletonsList Inline -> LuaE PandocError (SingletonsList Inline)
f = runOnSequence peekInline lf
in if lf `hasOneOf` inlineElementNames
then walkM f
else return
walkInlineLists :: Walkable (List Inline) a => LuaFilter -> a -> Lua a
walkInlineLists :: Walkable (List Inline) a
=> LuaFilter -> a -> LuaE PandocError a
walkInlineLists lf =
let f :: List Inline -> Lua (List Inline)
f = runOnValue listOfInlinesFilterName lf
let f :: List Inline -> LuaE PandocError (List Inline)
f = runOnValue listOfInlinesFilterName (peekList' peekInline) lf
in if lf `contains` listOfInlinesFilterName
then walkM f
else return
walkBlocks :: Walkable (SingletonsList Block) a => LuaFilter -> a -> Lua a
walkBlocks :: Walkable (SingletonsList Block) a
=> LuaFilter -> a -> LuaE PandocError a
walkBlocks lf =
let f :: SingletonsList Block -> Lua (SingletonsList Block)
f = runOnSequence lf
let f :: SingletonsList Block -> LuaE PandocError (SingletonsList Block)
f = runOnSequence peekBlock lf
in if lf `hasOneOf` blockElementNames
then walkM f
else return
walkBlockLists :: Walkable (List Block) a => LuaFilter -> a -> Lua a
walkBlockLists :: Walkable (List Block) a
=> LuaFilter -> a -> LuaE PandocError a
walkBlockLists lf =
let f :: List Block -> Lua (List Block)
f = runOnValue listOfBlocksFilterName lf
let f :: List Block -> LuaE PandocError (List Block)
f = runOnValue listOfBlocksFilterName (peekList' peekBlock) lf
in if lf `contains` listOfBlocksFilterName
then walkM f
else return
walkMeta :: LuaFilter -> Pandoc -> Lua Pandoc
walkMeta :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc
walkMeta lf (Pandoc m bs) = do
m' <- runOnValue "Meta" lf m
m' <- runOnValue "Meta" peekMeta lf m
return $ Pandoc m' bs
walkPandoc :: LuaFilter -> Pandoc -> Lua Pandoc
walkPandoc :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc
walkPandoc (LuaFilter fnMap) =
case foldl' mplus Nothing (map (`Map.lookup` fnMap) pandocFilterNames) of
Just fn -> \x -> runFilterFunction fn x *> singleElement x
Just fn -> \x -> runFilterFunction fn x *> singleElement peekPandoc x
Nothing -> return
constructorsFor :: DataType -> [String]
constructorsFor x = map show (dataTypeConstrs x)
constructorsFor :: DataType -> [Name]
constructorsFor x = map (fromString . show) (dataTypeConstrs x)
inlineElementNames :: [String]
inlineElementNames :: [Name]
inlineElementNames = "Inline" : constructorsFor (dataTypeOf (Str mempty))
blockElementNames :: [String]
blockElementNames :: [Name]
blockElementNames = "Block" : constructorsFor (dataTypeOf (Para []))
listOfInlinesFilterName :: String
listOfInlinesFilterName :: Name
listOfInlinesFilterName = "Inlines"
listOfBlocksFilterName :: String
listOfBlocksFilterName :: Name
listOfBlocksFilterName = "Blocks"
metaFilterName :: String
metaFilterName :: Name
metaFilterName = "Meta"
pandocFilterNames :: [String]
pandocFilterNames :: [Name]
pandocFilterNames = ["Pandoc", "Doc"]
singleElement :: Peekable a => a -> Lua a
singleElement x = do
elementUnchanged <- Lua.isnil (-1)
if elementUnchanged
then x <$ Lua.pop 1
else do
mbres <- peekEither (-1)
case mbres of
Right res -> res <$ Lua.pop 1
Left err -> do
Lua.pop 1
Lua.throwMessage
("Error while trying to get a filter's return " <>
"value from Lua stack.\n" <> show err)
-- | Try to convert the value at the given stack index to a Haskell value.
-- Returns @Left@ with an error message on failure.
peekEither :: Peekable a => StackIndex -> Lua (Either PandocError a)
peekEither = try . Lua.peek

45
src/Text/Pandoc/Lua/Global.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Lua
Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -14,19 +14,17 @@ module Text.Pandoc.Lua.Global
, setGlobals
) where
import Data.Data (Data)
import Foreign.Lua (Lua, Peekable, Pushable)
import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable
, metatableName)
import HsLua as Lua
import Paths_pandoc (version)
import Text.Pandoc.Class.CommonState (CommonState)
import Text.Pandoc.Definition (Pandoc (Pandoc), pandocTypesVersion)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Util (addFunction)
import Text.Pandoc.Lua.Marshaling.CommonState (pushCommonState)
import Text.Pandoc.Lua.Marshaling.ReaderOptions (pushReaderOptions)
import Text.Pandoc.Options (ReaderOptions)
import qualified Data.Text as Text
import qualified Foreign.Lua as Lua
-- | Permissible global Lua variables.
data Global =
@ -40,10 +38,10 @@ data Global =
-- Cannot derive instance of Data because of CommonState
-- | Set all given globals.
setGlobals :: [Global] -> Lua ()
setGlobals :: [Global] -> LuaE PandocError ()
setGlobals = mapM_ setGlobal
setGlobal :: Global -> Lua ()
setGlobal :: Global -> LuaE PandocError ()
setGlobal global = case global of
-- This could be simplified if Global was an instance of Data.
FORMAT format -> do
@ -53,37 +51,24 @@ setGlobal global = case global of
Lua.push pandocTypesVersion
Lua.setglobal "PANDOC_API_VERSION"
PANDOC_DOCUMENT doc -> do
Lua.push (LazyPandoc doc)
pushUD typePandocLazy doc
Lua.setglobal "PANDOC_DOCUMENT"
PANDOC_READER_OPTIONS ropts -> do
Lua.push ropts
pushReaderOptions ropts
Lua.setglobal "PANDOC_READER_OPTIONS"
PANDOC_SCRIPT_FILE filePath -> do
Lua.push filePath
Lua.setglobal "PANDOC_SCRIPT_FILE"
PANDOC_STATE commonState -> do
Lua.push commonState
pushCommonState commonState
Lua.setglobal "PANDOC_STATE"
PANDOC_VERSION -> do
Lua.push version
Lua.setglobal "PANDOC_VERSION"
-- | Readonly and lazy pandoc objects.
newtype LazyPandoc = LazyPandoc Pandoc
deriving (Data)
instance Pushable LazyPandoc where
push lazyDoc = pushAnyWithMetatable pushPandocMetatable lazyDoc
where
pushPandocMetatable = ensureUserdataMetatable (metatableName lazyDoc) $
addFunction "__index" indexLazyPandoc
instance Peekable LazyPandoc where
peek = Lua.peekAny
indexLazyPandoc :: LazyPandoc -> String -> Lua Lua.NumResults
indexLazyPandoc (LazyPandoc (Pandoc meta blks)) field = 1 <$
case field of
"blocks" -> Lua.push blks
"meta" -> Lua.push meta
_ -> Lua.pushnil
typePandocLazy :: LuaError e => DocumentedType e Pandoc
typePandocLazy = deftype "Pandoc (lazy)" []
[ readonly "meta" "document metadata" (push, \(Pandoc meta _) -> meta)
, readonly "blocks" "content blocks" (push, \(Pandoc _ blocks) -> blocks)
]

37
src/Text/Pandoc/Lua/Init.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Lua
Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -13,23 +14,23 @@ module Text.Pandoc.Lua.Init
) where
import Control.Monad (when)
import Control.Monad.Catch (try)
import Control.Monad.Catch (throwM, try)
import Control.Monad.Trans (MonadIO (..))
import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr)
import Foreign.Lua (Lua)
import HsLua as Lua hiding (status, try)
import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8)
import Text.Pandoc.Class.PandocMonad (readDataFile, PandocMonad)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Class.PandocMonad (PandocMonad, readDataFile)
import Text.Pandoc.Error (PandocError (PandocLuaError))
import Text.Pandoc.Lua.Packages (installPandocPackageSearcher)
import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, runPandocLua)
import Text.Pandoc.Lua.Util (throwTopMessageAsError')
import qualified Foreign.Lua as Lua
import qualified Data.Text as T
import qualified Text.Pandoc.Definition as Pandoc
import qualified Text.Pandoc.Lua.Module.Pandoc as ModulePandoc
-- | Run the lua interpreter, using pandoc's default way of environment
-- initialization.
runLua :: (PandocMonad m, MonadIO m) => Lua a -> m (Either PandocError a)
runLua :: (PandocMonad m, MonadIO m)
=> LuaE PandocError a -> m (Either PandocError a)
runLua luaOp = do
enc <- liftIO $ getForeignEncoding <* setForeignEncoding utf8
res <- runPandocLua . try $ do
@ -52,9 +53,9 @@ initLuaState = do
ModulePandoc.pushModule
-- register as loaded module
liftPandocLua $ do
Lua.pushvalue Lua.stackTop
Lua.getfield Lua.registryindex Lua.loadedTableRegistryField
Lua.setfield (Lua.nthFromTop 2) "pandoc"
Lua.pushvalue Lua.top
Lua.getfield Lua.registryindex Lua.loaded
Lua.setfield (Lua.nth 2) "pandoc"
Lua.pop 1
-- copy constructors into registry
putConstructorsInRegistry
@ -65,10 +66,12 @@ initLuaState = do
loadInitScript scriptFile = do
script <- readDataFile scriptFile
status <- liftPandocLua $ Lua.dostring script
when (status /= Lua.OK) . liftPandocLua $
throwTopMessageAsError'
(("Couldn't load '" ++ scriptFile ++ "'.\n") ++)
when (status /= Lua.OK) . liftPandocLua $ do
err <- popException
let prefix = "Couldn't load '" <> T.pack scriptFile <> "':\n"
throwM . PandocLuaError . (prefix <>) $ case err of
PandocLuaError msg -> msg
_ -> T.pack $ show err
-- | AST elements are marshaled via normal constructor functions in the
-- @pandoc@ module. However, accessing Lua globals from Haskell is
@ -91,12 +94,12 @@ putConstructorsInRegistry = liftPandocLua $ do
putInReg "List" -- pandoc.List
putInReg "SimpleTable" -- helper for backward-compatible table handling
where
constrsToReg :: Data a => a -> Lua ()
constrsToReg :: Data a => a -> LuaE PandocError ()
constrsToReg = mapM_ (putInReg . showConstr) . dataTypeConstrs . dataTypeOf
putInReg :: String -> Lua ()
putInReg :: String -> LuaE PandocError ()
putInReg name = do
Lua.push ("pandoc." ++ name) -- name in registry
Lua.push name -- in pandoc module
Lua.rawget (Lua.nthFromTop 3)
Lua.rawget (Lua.nth 3)
Lua.rawset Lua.registryindex

1
src/Text/Pandoc/Lua/Marshaling.hs
View file

@ -17,3 +17,4 @@ import Text.Pandoc.Lua.Marshaling.Context ()
import Text.Pandoc.Lua.Marshaling.PandocError()
import Text.Pandoc.Lua.Marshaling.ReaderOptions ()
import Text.Pandoc.Lua.Marshaling.Version ()
import Text.Pandoc.Lua.ErrorConversion ()

525
src/Text/Pandoc/Lua/Marshaling/AST.hs
View file

@ -1,6 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Lua.Marshaling.AST
Copyright : © 2012-2021 John MacFarlane
@ -13,223 +15,254 @@
Marshaling/unmarshaling instances for document AST elements.
-}
module Text.Pandoc.Lua.Marshaling.AST
( LuaAttr (..)
, LuaListAttributes (..)
( peekAttr
, peekBlock
, peekBlocks
, peekCaption
, peekCitation
, peekInline
, peekInlines
, peekListAttributes
, peekMeta
, peekMetaValue
, peekPandoc
, pushAttr
, pushBlock
, pushInline
, pushListAttributes
, pushMetaValue
, pushPandoc
) where
import Control.Applicative ((<|>))
import Control.Monad ((<$!>))
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex)
import Control.Applicative ((<|>), optional)
import Control.Monad ((<$!>), (>=>))
import HsLua hiding (Operation (Div))
import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor)
import Text.Pandoc.Lua.Util (pushViaConstr', pushViaConstructor)
import Text.Pandoc.Lua.Marshaling.CommonState ()
import qualified Control.Monad.Catch as Catch
import qualified Foreign.Lua as Lua
import qualified HsLua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
instance Pushable Pandoc where
push (Pandoc meta blocks) =
pushViaConstructor "Pandoc" blocks meta
push = pushPandoc
instance Peekable Pandoc where
peek idx = defineHowTo "get Pandoc value" $! Pandoc
<$!> LuaUtil.rawField idx "meta"
<*> LuaUtil.rawField idx "blocks"
pushPandoc :: LuaError e => Pusher e Pandoc
pushPandoc (Pandoc meta blocks) =
pushViaConstr' "Pandoc" [pushList pushBlock blocks, push meta]
peekPandoc :: LuaError e => Peeker e Pandoc
peekPandoc = fmap (retrieving "Pandoc value")
. typeChecked "table" Lua.istable $ \idx -> do
meta <- peekFieldRaw peekMeta "meta" idx
blks <- peekFieldRaw peekBlocks "blocks" idx
return $ Pandoc meta blks
instance Pushable Meta where
push (Meta mmap) =
pushViaConstructor "Meta" mmap
instance Peekable Meta where
peek idx = defineHowTo "get Meta value" $!
Meta <$!> Lua.peek idx
pushViaConstr' "Meta" [push mmap]
peekMeta :: LuaError e => Peeker e Meta
peekMeta idx = retrieving "Meta" $
Meta <$!> peekMap peekText peekMetaValue idx
instance Pushable MetaValue where
push = pushMetaValue
instance Peekable MetaValue where
peek = peekMetaValue
instance Pushable Block where
push = pushBlock
instance Peekable Block where
peek = peekBlock
-- Inline
instance Pushable Inline where
push = pushInline
instance Peekable Inline where
peek = peekInline
-- Citation
instance Pushable Citation where
push (Citation cid prefix suffix mode noteNum hash) =
pushViaConstructor "Citation" cid mode prefix suffix noteNum hash
pushViaConstr' "Citation"
[ push cid, push mode, push prefix, push suffix, push noteNum, push hash
]
peekCitation :: LuaError e => Peeker e Citation
peekCitation = fmap (retrieving "Citation")
. typeChecked "table" Lua.istable $ \idx -> do
idx' <- liftLua $ absindex idx
Citation
<$!> peekFieldRaw peekText "id" idx'
<*> peekFieldRaw (peekList peekInline) "prefix" idx'
<*> peekFieldRaw (peekList peekInline) "suffix" idx'
<*> peekFieldRaw peekRead "mode" idx'
<*> peekFieldRaw peekIntegral "note_num" idx'
<*> peekFieldRaw peekIntegral "hash" idx'
instance Peekable Citation where
peek idx = Citation
<$!> LuaUtil.rawField idx "id"
<*> LuaUtil.rawField idx "prefix"
<*> LuaUtil.rawField idx "suffix"
<*> LuaUtil.rawField idx "mode"
<*> LuaUtil.rawField idx "note_num"
<*> LuaUtil.rawField idx "hash"
instance Pushable Alignment where
push = Lua.push . show
instance Peekable Alignment where
peek = Lua.peekRead
push = Lua.pushString . show
instance Pushable CitationMode where
push = Lua.push . show
instance Peekable CitationMode where
peek = Lua.peekRead
instance Pushable Format where
push (Format f) = Lua.push f
instance Peekable Format where
peek idx = Format <$!> Lua.peek idx
peekFormat :: LuaError e => Peeker e Format
peekFormat idx = Format <$!> peekText idx
instance Pushable ListNumberDelim where
push = Lua.push . show
instance Peekable ListNumberDelim where
peek = Lua.peekRead
instance Pushable ListNumberStyle where
push = Lua.push . show
instance Peekable ListNumberStyle where
peek = Lua.peekRead
instance Pushable MathType where
push = Lua.push . show
instance Peekable MathType where
peek = Lua.peekRead
instance Pushable QuoteType where
push = Lua.push . show
instance Peekable QuoteType where
peek = Lua.peekRead
-- | Push an meta value element to the top of the lua stack.
pushMetaValue :: MetaValue -> Lua ()
pushMetaValue :: LuaError e => MetaValue -> LuaE e ()
pushMetaValue = \case
MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks
MetaBlocks blcks -> pushViaConstr' "MetaBlocks" [pushList pushBlock blcks]
MetaBool bool -> Lua.push bool
MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns
MetaList metalist -> pushViaConstructor "MetaList" metalist
MetaMap metamap -> pushViaConstructor "MetaMap" metamap
MetaInlines inlns -> pushViaConstr' "MetaInlines"
[pushList pushInline inlns]
MetaList metalist -> pushViaConstr' "MetaList"
[pushList pushMetaValue metalist]
MetaMap metamap -> pushViaConstr' "MetaMap"
[pushMap pushText pushMetaValue metamap]
MetaString str -> Lua.push str
-- | Interpret the value at the given stack index as meta value.
peekMetaValue :: StackIndex -> Lua MetaValue
peekMetaValue idx = defineHowTo "get MetaValue" $ do
peekMetaValue :: forall e. LuaError e => Peeker e MetaValue
peekMetaValue = retrieving "MetaValue $ " . \idx -> do
-- Get the contents of an AST element.
let elementContent :: Peekable a => Lua a
elementContent = Lua.peek idx
luatype <- Lua.ltype idx
case luatype of
Lua.TypeBoolean -> MetaBool <$!> Lua.peek idx
Lua.TypeString -> MetaString <$!> Lua.peek idx
Lua.TypeTable -> do
tag <- try $ LuaUtil.getTag idx
case tag of
Right "MetaBlocks" -> MetaBlocks <$!> elementContent
Right "MetaBool" -> MetaBool <$!> elementContent
Right "MetaMap" -> MetaMap <$!> elementContent
Right "MetaInlines" -> MetaInlines <$!> elementContent
Right "MetaList" -> MetaList <$!> elementContent
Right "MetaString" -> MetaString <$!> elementContent
Right t -> Lua.throwMessage ("Unknown meta tag: " <> t)
Left _ -> do
let mkMV :: (a -> MetaValue) -> Peeker e a -> Peek e MetaValue
mkMV f p = f <$!> p idx
peekTagged = \case
"MetaBlocks" -> mkMV MetaBlocks $
retrieving "MetaBlocks" . peekBlocks
"MetaBool" -> mkMV MetaBool $
retrieving "MetaBool" . peekBool
"MetaMap" -> mkMV MetaMap $
retrieving "MetaMap" . peekMap peekText peekMetaValue
"MetaInlines" -> mkMV MetaInlines $
retrieving "MetaInlines" . peekInlines
"MetaList" -> mkMV MetaList $
retrieving "MetaList" . peekList peekMetaValue
"MetaString" -> mkMV MetaString $
retrieving "MetaString" . peekText
(Name t) -> failPeek ("Unknown meta tag: " <> t)
peekUntagged = do
-- no meta value tag given, try to guess.
len <- Lua.rawlen idx
len <- liftLua $ Lua.rawlen idx
if len <= 0
then MetaMap <$!> Lua.peek idx
else (MetaInlines <$!> Lua.peek idx)
<|> (MetaBlocks <$!> Lua.peek idx)
<|> (MetaList <$!> Lua.peek idx)
_ -> Lua.throwMessage "could not get meta value"
then MetaMap <$!> peekMap peekText peekMetaValue idx
else (MetaInlines <$!> peekInlines idx)
<|> (MetaBlocks <$!> peekBlocks idx)
<|> (MetaList <$!> peekList peekMetaValue idx)
luatype <- liftLua $ Lua.ltype idx
case luatype of
Lua.TypeBoolean -> MetaBool <$!> peekBool idx
Lua.TypeString -> MetaString <$!> peekText idx
Lua.TypeTable -> do
optional (LuaUtil.getTag idx) >>= \case
Just tag -> peekTagged tag
Nothing -> peekUntagged
_ -> failPeek "could not get meta value"
-- | Push a block element to the top of the Lua stack.
pushBlock :: Block -> Lua ()
pushBlock :: forall e. LuaError e => Block -> LuaE e ()
pushBlock = \case
BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks
BulletList items -> pushViaConstructor "BulletList" items
CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr)
DefinitionList items -> pushViaConstructor "DefinitionList" items
Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr)
Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr)
HorizontalRule -> pushViaConstructor "HorizontalRule"
LineBlock blcks -> pushViaConstructor "LineBlock" blcks
OrderedList lstAttr list -> pushViaConstructor "OrderedList" list
(LuaListAttributes lstAttr)
Null -> pushViaConstructor "Null"
Para blcks -> pushViaConstructor "Para" blcks
Plain blcks -> pushViaConstructor "Plain" blcks
RawBlock f cs -> pushViaConstructor "RawBlock" f cs
BlockQuote blcks -> pushViaConstructor @e "BlockQuote" blcks
BulletList items -> pushViaConstructor @e "BulletList" items
CodeBlock attr code -> pushViaConstr' @e "CodeBlock"
[ push code, pushAttr attr ]
DefinitionList items -> pushViaConstructor @e "DefinitionList" items
Div attr blcks -> pushViaConstr' @e "Div"
[push blcks, pushAttr attr]
Header lvl attr inlns -> pushViaConstr' @e "Header"
[push lvl, push inlns, pushAttr attr]
HorizontalRule -> pushViaConstructor @e "HorizontalRule"
LineBlock blcks -> pushViaConstructor @e "LineBlock" blcks
OrderedList lstAttr list -> pushViaConstr' @e "OrderedList"
[ push list, pushListAttributes @e lstAttr ]
Null -> pushViaConstructor @e "Null"
Para blcks -> pushViaConstructor @e "Para" blcks
Plain blcks -> pushViaConstructor @e "Plain" blcks
RawBlock f cs -> pushViaConstructor @e "RawBlock" f cs
Table attr blkCapt specs thead tbody tfoot ->
pushViaConstructor "Table" blkCapt specs thead tbody tfoot attr
pushViaConstr' @e "Table"
[ pushCaption blkCapt, push specs, push thead, push tbody
, push tfoot, pushAttr attr]
-- | Return the value at the given index as block if possible.
peekBlock :: StackIndex -> Lua Block
peekBlock idx = defineHowTo "get Block value" $! do
tag <- LuaUtil.getTag idx
case tag of
"BlockQuote" -> BlockQuote <$!> elementContent
"BulletList" -> BulletList <$!> elementContent
"CodeBlock" -> withAttr CodeBlock <$!> elementContent
"DefinitionList" -> DefinitionList <$!> elementContent
"Div" -> withAttr Div <$!> elementContent
"Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst)
<$!> elementContent
"HorizontalRule" -> return HorizontalRule
"LineBlock" -> LineBlock <$!> elementContent
"OrderedList" -> (\(LuaListAttributes lstAttr, lst) ->
OrderedList lstAttr lst)
<$!> elementContent
"Null" -> return Null
"Para" -> Para <$!> elementContent
"Plain" -> Plain <$!> elementContent
"RawBlock" -> uncurry RawBlock <$!> elementContent
"Table" -> (\(attr, capt, colSpecs, thead, tbodies, tfoot) ->
Table (fromLuaAttr attr)
capt
colSpecs
thead
tbodies
tfoot)
<$!> elementContent
_ -> Lua.throwMessage ("Unknown block type: " <> tag)
where
peekBlock :: forall e. LuaError e => Peeker e Block
peekBlock = fmap (retrieving "Block")
. typeChecked "table" Lua.istable
$ \idx -> do
-- Get the contents of an AST element.
elementContent :: Peekable a => Lua a
elementContent = LuaUtil.rawField idx "c"
let mkBlock :: (a -> Block) -> Peeker e a -> Peek e Block
mkBlock f p = f <$!> peekFieldRaw p "c" idx
LuaUtil.getTag idx >>= \case
"BlockQuote" -> mkBlock BlockQuote peekBlocks
"BulletList" -> mkBlock BulletList (peekList peekBlocks)
"CodeBlock" -> mkBlock (uncurry CodeBlock)
(peekPair peekAttr peekText)
"DefinitionList" -> mkBlock DefinitionList
(peekList (peekPair peekInlines (peekList peekBlocks)))
"Div" -> mkBlock (uncurry Div) (peekPair peekAttr peekBlocks)
"Header" -> mkBlock (\(lvl, attr, lst) -> Header lvl attr lst)
(peekTriple peekIntegral peekAttr peekInlines)
"HorizontalRule" -> return HorizontalRule
"LineBlock" -> mkBlock LineBlock (peekList peekInlines)
"OrderedList" -> mkBlock (uncurry OrderedList)
(peekPair peekListAttributes (peekList peekBlocks))
"Null" -> return Null
"Para" -> mkBlock Para peekInlines
"Plain" -> mkBlock Plain peekInlines
"RawBlock" -> mkBlock (uncurry RawBlock)
(peekPair peekFormat peekText)
"Table" -> mkBlock id
(retrieving "Table" . (liftLua . absindex >=> (\idx' -> cleanup $ do
attr <- liftLua (rawgeti idx' 1) *> peekAttr top
capt <- liftLua (rawgeti idx' 2) *> peekCaption top
cs <- liftLua (rawgeti idx' 3) *> peekList peekColSpec top
thead <- liftLua (rawgeti idx' 4) *> peekTableHead top
tbods <- liftLua (rawgeti idx' 5) *> peekList peekTableBody top
tfoot <- liftLua (rawgeti idx' 6) *> peekTableFoot top
return $! Table attr capt cs thead tbods tfoot)))
Name tag -> failPeek ("Unknown block type: " <> tag)
instance Pushable Caption where
push = pushCaption
peekBlocks :: LuaError e => Peeker e [Block]
peekBlocks = peekList peekBlock
instance Peekable Caption where
peek = peekCaption
peekInlines :: LuaError e => Peeker e [Inline]
peekInlines = peekList peekInline
-- | Push Caption element
pushCaption :: Caption -> Lua ()
pushCaption :: LuaError e => Caption -> LuaE e ()
pushCaption (Caption shortCaption longCaption) = do
Lua.newtable
LuaUtil.addField "short" (Lua.Optional shortCaption)
LuaUtil.addField "long" longCaption
-- | Peek Caption element
peekCaption :: StackIndex -> Lua Caption
peekCaption idx = Caption
<$!> (Lua.fromOptional <$!> LuaUtil.rawField idx "short")
<*> LuaUtil.rawField idx "long"
peekCaption :: LuaError e => Peeker e Caption
peekCaption = retrieving "Caption" . \idx -> do
short <- optional $ peekFieldRaw peekInlines "short" idx
long <- peekFieldRaw peekBlocks "long" idx
return $! Caption short long
instance Peekable ColWidth where
peek idx = do
width <- Lua.fromOptional <$!> Lua.peek idx
return $! maybe ColWidthDefault ColWidth width
peekColWidth :: LuaError e => Peeker e ColWidth
peekColWidth = retrieving "ColWidth" . \idx -> do
maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx)
peekColSpec :: LuaError e => Peeker e ColSpec
peekColSpec = peekPair peekRead peekColWidth
instance Pushable ColWidth where
push = \case
@ -240,7 +273,12 @@ instance Pushable Row where
push (Row attr cells) = Lua.push (attr, cells)
instance Peekable Row where
peek = fmap (uncurry Row) . Lua.peek
peek = forcePeek . peekRow
peekRow :: LuaError e => Peeker e Row
peekRow = ((uncurry Row) <$!>)
. retrieving "Row"
. peekPair peekAttr (peekList peekCell)
instance Pushable TableBody where
push (TableBody attr (RowHeadColumns rowHeadColumns) head' body) = do
@ -250,32 +288,38 @@ instance Pushable TableBody where
LuaUtil.addField "head" head'
LuaUtil.addField "body" body
instance Peekable TableBody where
peek idx = TableBody
<$!> LuaUtil.rawField idx "attr"
<*> (RowHeadColumns <$!> LuaUtil.rawField idx "row_head_columns")
<*> LuaUtil.rawField idx "head"
<*> LuaUtil.rawField idx "body"
peekTableBody :: LuaError e => Peeker e TableBody
peekTableBody = fmap (retrieving "TableBody")
. typeChecked "table" Lua.istable
$ \idx -> TableBody
<$!> peekFieldRaw peekAttr "attr" idx
<*> peekFieldRaw ((fmap RowHeadColumns) . peekIntegral) "row_head_columns" idx
<*> peekFieldRaw (peekList peekRow) "head" idx
<*> peekFieldRaw (peekList peekRow) "body" idx
instance Pushable TableHead where
push (TableHead attr rows) = Lua.push (attr, rows)
instance Peekable TableHead where
peek = fmap (uncurry TableHead) . Lua.peek
peekTableHead :: LuaError e => Peeker e TableHead
peekTableHead = ((uncurry TableHead) <$!>)
. retrieving "TableHead"
. peekPair peekAttr (peekList peekRow)
instance Pushable TableFoot where
push (TableFoot attr cells) = Lua.push (attr, cells)
instance Peekable TableFoot where
peek = fmap (uncurry TableFoot) . Lua.peek
peekTableFoot :: LuaError e => Peeker e TableFoot
peekTableFoot = ((uncurry TableFoot) <$!>)
. retrieving "TableFoot"
. peekPair peekAttr (peekList peekRow)
instance Pushable Cell where
push = pushCell
instance Peekable Cell where
peek = peekCell
peek = forcePeek . peekCell
pushCell :: Cell -> Lua ()
pushCell :: LuaError e => Cell -> LuaE e ()
pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do
Lua.newtable
LuaUtil.addField "attr" attr
@ -284,95 +328,112 @@ pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do
LuaUtil.addField "col_span" colSpan
LuaUtil.addField "contents" contents
peekCell :: StackIndex -> Lua Cell
peekCell idx = Cell
<$!> (fromLuaAttr <$!> LuaUtil.rawField idx "attr")
<*> LuaUtil.rawField idx "alignment"
<*> (RowSpan <$!> LuaUtil.rawField idx "row_span")
<*> (ColSpan <$!> LuaUtil.rawField idx "col_span")
<*> LuaUtil.rawField idx "contents"
peekCell :: LuaError e => Peeker e Cell
peekCell = fmap (retrieving "Cell")
. typeChecked "table" Lua.istable
$ \idx -> do
attr <- peekFieldRaw peekAttr "attr" idx
algn <- peekFieldRaw peekRead "alignment" idx
rs <- RowSpan <$!> peekFieldRaw peekIntegral "row_span" idx
cs <- ColSpan <$!> peekFieldRaw peekIntegral "col_span" idx
blks <- peekFieldRaw peekBlocks "contents" idx
return $! Cell attr algn rs cs blks
-- | Push an inline element to the top of the lua stack.
pushInline :: Inline -> Lua ()
pushInline :: forall e. LuaError e => Inline -> LuaE e ()
pushInline = \case
Cite citations lst -> pushViaConstructor "Cite" lst citations
Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr)
Emph inlns -> pushViaConstructor "Emph" inlns
Underline inlns -> pushViaConstructor "Underline" inlns
Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr)
LineBreak -> pushViaConstructor "LineBreak"
Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr)
Note blcks -> pushViaConstructor "Note" blcks
Math mty str -> pushViaConstructor "Math" mty str
Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns
RawInline f cs -> pushViaConstructor "RawInline" f cs
SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns
SoftBreak -> pushViaConstructor "SoftBreak"
Space -> pushViaConstructor "Space"
Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr)
Str str -> pushViaConstructor "Str" str
Strikeout inlns -> pushViaConstructor "Strikeout" inlns
Strong inlns -> pushViaConstructor "Strong" inlns
Subscript inlns -> pushViaConstructor "Subscript" inlns
Superscript inlns -> pushViaConstructor "Superscript" inlns
Cite citations lst -> pushViaConstructor @e "Cite" lst citations
Code attr lst -> pushViaConstr' @e "Code"
[push lst, pushAttr attr]
Emph inlns -> pushViaConstructor @e "Emph" inlns
Underline inlns -> pushViaConstructor @e "Underline" inlns
Image attr alt (src,tit) -> pushViaConstr' @e "Image"
[push alt, push src, push tit, pushAttr attr]
LineBreak -> pushViaConstructor @e "LineBreak"
Link attr lst (src,tit) -> pushViaConstr' @e "Link"
[push lst, push src, push tit, pushAttr attr]
Note blcks -> pushViaConstructor @e "Note" blcks
Math mty str -> pushViaConstructor @e "Math" mty str
Quoted qt inlns -> pushViaConstructor @e "Quoted" qt inlns
RawInline f cs -> pushViaConstructor @e "RawInline" f cs
SmallCaps inlns -> pushViaConstructor @e "SmallCaps" inlns
SoftBreak -> pushViaConstructor @e "SoftBreak"
Space -> pushViaConstructor @e "Space"
Span attr inlns -> pushViaConstr' @e "Span"
[push inlns, pushAttr attr]
Str str -> pushViaConstructor @e "Str" str
Strikeout inlns -> pushViaConstructor @e "Strikeout" inlns
Strong inlns -> pushViaConstructor @e "Strong" inlns
Subscript inlns -> pushViaConstructor @e "Subscript" inlns
Superscript inlns -> pushViaConstructor @e "Superscript" inlns
-- | Return the value at the given index as inline if possible.
peekInline :: StackIndex -> Lua Inline
peekInline idx = defineHowTo "get Inline value" $ do
tag <- LuaUtil.getTag idx
case tag of
"Cite" -> uncurry Cite <$!> elementContent
"Code" -> withAttr Code <$!> elementContent
"Emph" -> Emph <$!> elementContent
"Underline" -> Underline <$!> elementContent
"Image" -> (\(LuaAttr !attr, !lst, !tgt) -> Image attr lst tgt)
<$!> elementContent
"Link" -> (\(LuaAttr !attr, !lst, !tgt) -> Link attr lst tgt)
<$!> elementContent
peekInline :: forall e. LuaError e => Peeker e Inline
peekInline = retrieving "Inline" . \idx -> do
-- Get the contents of an AST element.
let mkBlock :: (a -> Inline) -> Peeker e a -> Peek e Inline
mkBlock f p = f <$!> peekFieldRaw p "c" idx
LuaUtil.getTag idx >>= \case
"Cite" -> mkBlock (uncurry Cite) $
peekPair (peekList peekCitation) peekInlines
"Code" -> mkBlock (uncurry Code) (peekPair peekAttr peekText)
"Emph" -> mkBlock Emph peekInlines
"Underline" -> mkBlock Underline peekInlines
"Image" -> mkBlock (\(attr, lst, tgt) -> Image attr lst tgt)
$ peekTriple peekAttr peekInlines
(peekPair peekText peekText)
"Link" -> mkBlock (\(attr, lst, tgt) -> Link attr lst tgt) $
peekTriple peekAttr peekInlines (peekPair peekText peekText)
"LineBreak" -> return LineBreak
"Note" -> Note <$!> elementContent
"Math" -> uncurry Math <$!> elementContent
"Quoted" -> uncurry Quoted <$!> elementContent
"RawInline" -> uncurry RawInline <$!> elementContent
"SmallCaps" -> SmallCaps <$!> elementContent
"Note" -> mkBlock Note peekBlocks
"Math" -> mkBlock (uncurry Math) (peekPair peekRead peekText)
"Quoted" -> mkBlock (uncurry Quoted) (peekPair peekRead peekInlines)
"RawInline" -> mkBlock (uncurry RawInline) (peekPair peekFormat peekText)
"SmallCaps" -> mkBlock SmallCaps peekInlines
"SoftBreak" -> return SoftBreak
"Space" -> return Space
"Span" -> withAttr Span <$!> elementContent
-- strict to Lua string is copied before gc
"Str" -> Str <$!> elementContent
"Strikeout" -> Strikeout <$!> elementContent
"Strong" -> Strong <$!> elementContent
"Subscript" -> Subscript <$!> elementContent
"Superscript"-> Superscript <$!> elementContent
_ -> Lua.throwMessage ("Unknown inline type: " <> tag)
where
-- Get the contents of an AST element.
elementContent :: Peekable a => Lua a
elementContent = LuaUtil.rawField idx "c"
"Span" -> mkBlock (uncurry Span) (peekPair peekAttr peekInlines)
"Str" -> mkBlock Str peekText
"Strikeout" -> mkBlock Strikeout peekInlines
"Strong" -> mkBlock Strong peekInlines
"Subscript" -> mkBlock Subscript peekInlines
"Superscript"-> mkBlock Superscript peekInlines
Name tag -> Lua.failPeek ("Unknown inline type: " <> tag)
try :: Lua a -> Lua (Either PandocError a)
try = Catch.try
pushAttr :: forall e. LuaError e => Attr -> LuaE e ()
pushAttr (id', classes, kv) = pushViaConstr' @e "Attr"
[ pushText id'
, pushList pushText classes
, pushList (pushPair pushText pushText) kv
]
withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b
withAttr f (attributes, x) = f (fromLuaAttr attributes) x
peekAttr :: LuaError e => Peeker e Attr
peekAttr = retrieving "Attr" . peekTriple
peekText
(peekList peekText)
(peekList (peekPair peekText peekText))
-- | Wrapper for Attr
newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr }
pushListAttributes :: forall e. LuaError e => ListAttributes -> LuaE e ()
pushListAttributes (start, style, delimiter) =
pushViaConstr' "ListAttributes"
[ push start, push style, push delimiter ]
instance Pushable LuaAttr where
push (LuaAttr (id', classes, kv)) =
pushViaConstructor "Attr" id' classes kv
peekListAttributes :: LuaError e => Peeker e ListAttributes
peekListAttributes = retrieving "ListAttributes" . peekTriple
peekIntegral
peekRead
peekRead
instance Peekable LuaAttr where
peek idx = defineHowTo "get Attr value" $! (LuaAttr <$!> Lua.peek idx)
-- These instances exist only for testing. It's a hack to avoid making
-- the marshalling modules public.
instance Peekable Inline where
peek = forcePeek . peekInline
-- | Wrapper for ListAttributes
newtype LuaListAttributes = LuaListAttributes ListAttributes
instance Peekable Block where
peek = forcePeek . peekBlock
instance Pushable LuaListAttributes where
push (LuaListAttributes (start, style, delimiter)) =
pushViaConstructor "ListAttributes" start style delimiter
instance Peekable Meta where
peek = forcePeek . peekMeta
instance Peekable LuaListAttributes where
peek = defineHowTo "get ListAttributes value" .
fmap LuaListAttributes . Lua.peek
instance Peekable Pandoc where
peek = forcePeek . peekPandoc

24
src/Text/Pandoc/Lua/Marshaling/AnyValue.hs
View file

@ -1,24 +0,0 @@
{- |
Module : Text.Pandoc.Lua.Marshaling.AnyValue
Copyright : © 2017-2021 Albert Krewinkel
License : GNU GPL, version 2 or above
Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
Stability : alpha
Helper type to work with raw Lua stack indices instead of unmarshaled
values.
TODO: Most of this module should be abstracted, factored out, and go
into HsLua.
-}
module Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) where
import Foreign.Lua (Peekable (peek), StackIndex)
-- | Dummy type to allow values of arbitrary Lua type. This just wraps
-- stack indices, using it requires extra care.
newtype AnyValue = AnyValue StackIndex
instance Peekable AnyValue where
peek = return . AnyValue

122
src/Text/Pandoc/Lua/Marshaling/CommonState.hs
View file

@ -1,5 +1,3 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Lua.Marshaling.CommonState
@ -11,92 +9,62 @@
Instances to marshal (push) and unmarshal (peek) the common state.
-}
module Text.Pandoc.Lua.Marshaling.CommonState () where
module Text.Pandoc.Lua.Marshaling.CommonState
( typeCommonState
, peekCommonState
, pushCommonState
) where
import Foreign.Lua (Lua, Peekable, Pushable)
import Foreign.Lua.Types.Peekable (reportValueOnFailure)
import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable,
toAnyWithName)
import HsLua.Core
import HsLua.Marshalling
import HsLua.Packaging
import Text.Pandoc.Class (CommonState (..))
import Text.Pandoc.Logging (LogMessage, showLogMessage)
import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..))
import Text.Pandoc.Lua.Marshaling.List (pushPandocList)
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
-- | Lua type used for the @CommonState@ object.
typeCommonState :: LuaError e => DocumentedType e CommonState
typeCommonState = deftype "pandoc CommonState" []
[ readonly "input_files" "input files passed to pandoc"
(pushPandocList pushString, stInputFiles)
-- | Name used by Lua for the @CommonState@ type.
commonStateTypeName :: String
commonStateTypeName = "Pandoc CommonState"
, readonly "output_file" "the file to which pandoc will write"
(maybe pushnil pushString, stOutputFile)
instance Peekable CommonState where
peek idx = reportValueOnFailure commonStateTypeName
(`toAnyWithName` commonStateTypeName) idx
, readonly "log" "list of log messages"
(pushPandocList (pushUD typeLogMessage), stLog)
instance Pushable CommonState where
push st = pushAnyWithMetatable pushCommonStateMetatable st
where
pushCommonStateMetatable = ensureUserdataMetatable commonStateTypeName $ do
LuaUtil.addFunction "__index" indexCommonState
LuaUtil.addFunction "__pairs" pairsCommonState
, readonly "request_headers" "headers to add for HTTP requests"
(pushPandocList (pushPair pushText pushText), stRequestHeaders)
indexCommonState :: CommonState -> AnyValue -> Lua Lua.NumResults
indexCommonState st (AnyValue idx) = Lua.ltype idx >>= \case
Lua.TypeString -> 1 <$ (Lua.peek idx >>= pushField)
_ -> 1 <$ Lua.pushnil
where
pushField :: Text.Text -> Lua ()
pushField name = case lookup name commonStateFields of
Just pushValue -> pushValue st
Nothing -> Lua.pushnil
, readonly "resource_path"
"path to search for resources like included images"
(pushPandocList pushString, stResourcePath)
pairsCommonState :: CommonState -> Lua Lua.NumResults
pairsCommonState st = do
Lua.pushHaskellFunction nextFn
Lua.pushnil
Lua.pushnil
return 3
where
nextFn :: AnyValue -> AnyValue -> Lua Lua.NumResults
nextFn _ (AnyValue idx) =
Lua.ltype idx >>= \case
Lua.TypeNil -> case commonStateFields of
[] -> 2 <$ (Lua.pushnil *> Lua.pushnil)
(key, pushValue):_ -> 2 <$ (Lua.push key *> pushValue st)
Lua.TypeString -> do
key <- Lua.peek idx
case tail $ dropWhile ((/= key) . fst) commonStateFields of
[] -> 2 <$ (Lua.pushnil *> Lua.pushnil)
(nextKey, pushValue):_ -> 2 <$ (Lua.push nextKey *> pushValue st)
_ -> 2 <$ (Lua.pushnil *> Lua.pushnil)
, readonly "source_url" "absolute URL + dir of 1st source file"
(maybe pushnil pushText, stSourceURL)
commonStateFields :: [(Text.Text, CommonState -> Lua ())]
commonStateFields =
[ ("input_files", Lua.push . stInputFiles)
, ("output_file", Lua.push . Lua.Optional . stOutputFile)
, ("log", Lua.push . stLog)
, ("request_headers", Lua.push . Map.fromList . stRequestHeaders)
, ("resource_path", Lua.push . stResourcePath)
, ("source_url", Lua.push . Lua.Optional . stSourceURL)
, ("user_data_dir", Lua.push . Lua.Optional . stUserDataDir)
, ("trace", Lua.push . stTrace)
, ("verbosity", Lua.push . show . stVerbosity)
, readonly "user_data_dir" "directory to search for data files"
(maybe pushnil pushString, stUserDataDir)
, readonly "trace" "controls whether tracing messages are issued"
(pushBool, stTrace)
, readonly "verbosity" "verbosity level"
(pushString . show, stVerbosity)
]
-- | Name used by Lua for the @CommonState@ type.
logMessageTypeName :: String
logMessageTypeName = "Pandoc LogMessage"
peekCommonState :: LuaError e => Peeker e CommonState
peekCommonState = peekUD typeCommonState
instance Peekable LogMessage where
peek idx = reportValueOnFailure logMessageTypeName
(`toAnyWithName` logMessageTypeName) idx
pushCommonState :: LuaError e => Pusher e CommonState
pushCommonState = pushUD typeCommonState
instance Pushable LogMessage where
push msg = pushAnyWithMetatable pushLogMessageMetatable msg
where
pushLogMessageMetatable = ensureUserdataMetatable logMessageTypeName $
LuaUtil.addFunction "__tostring" tostringLogMessage
tostringLogMessage :: LogMessage -> Lua Text.Text
tostringLogMessage = return . showLogMessage
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"
]
mempty -- no members

4
src/Text/Pandoc/Lua/Marshaling/Context.hs
View file

@ -12,8 +12,8 @@ Marshaling instance for doctemplates Context and its components.
-}
module Text.Pandoc.Lua.Marshaling.Context () where
import qualified Foreign.Lua as Lua
import Foreign.Lua (Pushable)
import qualified HsLua as Lua
import HsLua (Pushable)
import Text.DocTemplates (Context(..), Val(..), TemplateTarget)
import Text.DocLayout (render)

24
src/Text/Pandoc/Lua/Marshaling/List.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{- |
Module : Text.Pandoc.Lua.Marshaling.List
@ -14,27 +15,30 @@ Marshaling/unmarshaling instances for @pandoc.List@s.
-}
module Text.Pandoc.Lua.Marshaling.List
( List (..)
, peekList'
, pushPandocList
) where
import Control.Monad ((<$!>))
import Data.Data (Data)
import Foreign.Lua (Peekable, Pushable)
import HsLua (LuaError, Peeker, Pusher, Pushable (push), peekList, pushList)
import Text.Pandoc.Walk (Walkable (..))
import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor)
import qualified Foreign.Lua as Lua
import Text.Pandoc.Lua.Util (pushViaConstr')
-- | List wrapper which is marshalled as @pandoc.List@.
newtype List a = List { fromList :: [a] }
deriving (Data, Eq, Show)
instance Pushable a => Pushable (List a) where
push (List xs) =
pushViaConstructor "List" xs
push (List xs) = pushPandocList push xs
instance Peekable a => Peekable (List a) where
peek idx = defineHowTo "get List" $ do
xs <- Lua.peek idx
return $ List xs
-- | Pushes a list as a numerical Lua table, setting a metatable that offers a
-- number of convenience functions.
pushPandocList :: LuaError e => Pusher e a -> Pusher e [a]
pushPandocList pushItem xs = pushViaConstr' "List" [pushList pushItem xs]
peekList' :: LuaError e => Peeker e a -> Peeker e (List a)
peekList' p = (List <$!>) . peekList p
-- List is just a wrapper, so we can reuse the walk instance for
-- unwrapped Hasekll lists.

73
src/Text/Pandoc/Lua/Marshaling/MediaBag.hs
View file

@ -1,73 +0,0 @@
{- |
Module : Text.Pandoc.Lua.Marshaling.MediaBag
Copyright : © 2012-2021 John MacFarlane
© 2017-2021 Albert Krewinkel
License : GNU GPL, version 2 or above
Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
Stability : alpha
Instances to marshal (push) and unmarshal (peek) media data.
-}
module Text.Pandoc.Lua.Marshaling.MediaBag (pushIterator) where
import Foreign.Ptr (Ptr)
import Foreign.StablePtr (StablePtr, deRefStablePtr, newStablePtr)
import Foreign.Lua (Lua, NumResults, Peekable, Pushable, StackIndex)
import Foreign.Lua.Types.Peekable (reportValueOnFailure)
import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable,
toAnyWithName)
import Text.Pandoc.MediaBag (MediaBag, mediaItems)
import Text.Pandoc.MIME (MimeType)
import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..))
import qualified Data.ByteString.Lazy as BL
import qualified Foreign.Lua as Lua
import qualified Foreign.Storable as Storable
-- | A list of 'MediaBag' items.
newtype MediaItems = MediaItems [(String, MimeType, BL.ByteString)]
instance Pushable MediaItems where
push = pushMediaItems
instance Peekable MediaItems where
peek = peekMediaItems
-- | Push an iterator triple to be used with Lua's @for@ loop construct.
-- Each iterator invocation returns a triple containing the item's
-- filename, MIME type, and content.
pushIterator :: MediaBag -> Lua NumResults
pushIterator mb = do
Lua.pushHaskellFunction nextItem
Lua.push (MediaItems $ mediaItems mb)
Lua.pushnil
return 3
-- | Lua type name for @'MediaItems'@.
mediaItemsTypeName :: String
mediaItemsTypeName = "pandoc MediaItems"
-- | Push a @MediaItems@ element to the stack.
pushMediaItems :: MediaItems -> Lua ()
pushMediaItems xs = pushAnyWithMetatable pushMT xs
where
pushMT = ensureUserdataMetatable mediaItemsTypeName (return ())
-- | Retrieve a @MediaItems@ element from the stack.
peekMediaItems :: StackIndex -> Lua MediaItems
peekMediaItems = reportValueOnFailure mediaItemsTypeName
(`toAnyWithName` mediaItemsTypeName)
-- | Retrieve a list of items from an iterator state, return the first
-- item (if present), and advance the state.
nextItem :: Ptr (StablePtr MediaItems) -> AnyValue -> Lua NumResults
nextItem ptr _ = do
(MediaItems items) <- Lua.liftIO $ deRefStablePtr =<< Storable.peek ptr
case items of
[] -> 2 <$ (Lua.pushnil *> Lua.pushnil)
(key, mt, content):xs -> do
Lua.liftIO $ Storable.poke ptr =<< newStablePtr (MediaItems xs)
Lua.push key
Lua.push mt
Lua.push content
return 3

58
src/Text/Pandoc/Lua/Marshaling/PandocError.hs
View file

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Lua.Marshaling.PandocError
Copyright : © 2020-2021 Albert Krewinkel
@ -15,51 +15,37 @@ Marshaling of @'PandocError'@ values.
module Text.Pandoc.Lua.Marshaling.PandocError
( peekPandocError
, pushPandocError
, typePandocError
)
where
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex)
import HsLua.Core (LuaError)
import HsLua.Marshalling (Peeker, Pusher, pushString, liftLua)
import HsLua.Packaging
import Text.Pandoc.Error (PandocError (PandocLuaError))
import qualified Foreign.Lua as Lua
import qualified Foreign.Lua.Userdata as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
import qualified HsLua as Lua
import qualified Text.Pandoc.UTF8 as UTF8
-- | Userdata name used by Lua for the @PandocError@ type.
pandocErrorName :: String
pandocErrorName = "pandoc error"
-- | Lua userdata type definition for PandocError.
typePandocError :: LuaError e => DocumentedType e PandocError
typePandocError = deftype "PandocError"
[ operation Tostring $ defun "__tostring"
### liftPure (show @PandocError)
<#> udparam typePandocError "obj" "PandocError object"
=#> functionResult pushString "string" "string representation of error."
]
mempty -- no members
-- | Peek a @'PandocError'@ element to the Lua stack.
pushPandocError :: PandocError -> Lua ()
pushPandocError = Lua.pushAnyWithMetatable pushPandocErrorMT
where
pushPandocErrorMT = Lua.ensureUserdataMetatable pandocErrorName $
LuaUtil.addFunction "__tostring" __tostring
pushPandocError :: LuaError e => Pusher e PandocError
pushPandocError = pushUD typePandocError
-- | Retrieve a @'PandocError'@ from the Lua stack.
peekPandocError :: StackIndex -> Lua PandocError
peekPandocError idx = Lua.ltype idx >>= \case
Lua.TypeUserdata -> do
errMb <- Lua.toAnyWithName idx pandocErrorName
return $ case errMb of
Just err -> err
Nothing -> PandocLuaError "could not retrieve original error"
peekPandocError :: LuaError e => Peeker e PandocError
peekPandocError idx = Lua.retrieving "PandocError" $
liftLua (Lua.ltype idx) >>= \case
Lua.TypeUserdata -> peekUD typePandocError idx
_ -> do
Lua.pushvalue idx
msg <- Lua.state >>= \l -> Lua.liftIO (Lua.errorMessage l)
msg <- liftLua $ Lua.state >>= \l -> Lua.liftIO (Lua.popErrorMessage l)
return $ PandocLuaError (UTF8.toText msg)
-- | Convert to string.
__tostring :: PandocError -> Lua String
__tostring = return . show
--
-- Instances
--
instance Pushable PandocError where
push = pushPandocError
instance Peekable PandocError where
peek = peekPandocError

106
src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -13,67 +12,60 @@
Marshaling instance for ReaderOptions and its components.
-}
module Text.Pandoc.Lua.Marshaling.ReaderOptions () where
module Text.Pandoc.Lua.Marshaling.ReaderOptions
( peekReaderOptions
, pushReaderOptions
) where
import Data.Data (showConstr, toConstr)
import Foreign.Lua (Lua, Pushable)
import Text.Pandoc.Extensions (Extensions)
import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..))
import Text.Pandoc.Lua.Marshaling.CommonState ()
import Text.Pandoc.Options (ReaderOptions (..), TrackChanges)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
import HsLua as Lua
import Text.Pandoc.Lua.Marshaling.List (pushPandocList)
import Text.Pandoc.Options (ReaderOptions (..))
--
-- Reader Options
--
instance Pushable Extensions where
push exts = Lua.push (show exts)
instance Pushable TrackChanges where
push = Lua.push . showConstr . toConstr
peekReaderOptions :: LuaError e => Peeker e ReaderOptions
peekReaderOptions = peekUD typeReaderOptions
instance Pushable ReaderOptions where
push ro = do
let ReaderOptions
(extensions :: Extensions)
(standalone :: Bool)
(columns :: Int)
(tabStop :: Int)
(indentedCodeClasses :: [Text.Text])
(abbreviations :: Set.Set Text.Text)
(defaultImageExtension :: Text.Text)
(trackChanges :: TrackChanges)
(stripComments :: Bool)
= ro
Lua.newtable
LuaUtil.addField "extensions" extensions
LuaUtil.addField "standalone" standalone
LuaUtil.addField "columns" columns
LuaUtil.addField "tab_stop" tabStop
LuaUtil.addField "indented_code_classes" indentedCodeClasses
LuaUtil.addField "abbreviations" abbreviations
LuaUtil.addField "default_image_extension" defaultImageExtension
LuaUtil.addField "track_changes" trackChanges
LuaUtil.addField "strip_comments" stripComments
pushReaderOptions :: LuaError e => Pusher e ReaderOptions
pushReaderOptions = pushUD typeReaderOptions
-- add metatable
let indexReaderOptions :: AnyValue -> AnyValue -> Lua Lua.NumResults
indexReaderOptions _tbl (AnyValue key) = do
Lua.ltype key >>= \case
Lua.TypeString -> Lua.peek key >>= \case
("defaultImageExtension" :: Text.Text)
-> Lua.push defaultImageExtension
"indentedCodeClasses" -> Lua.push indentedCodeClasses
"stripComments" -> Lua.push stripComments
"tabStop" -> Lua.push tabStop
"trackChanges" -> Lua.push trackChanges
_ -> Lua.pushnil
_ -> Lua.pushnil
return 1
Lua.newtable
LuaUtil.addFunction "__index" indexReaderOptions
Lua.setmetatable (Lua.nthFromTop 2)
typeReaderOptions :: LuaError e => DocumentedType e ReaderOptions
typeReaderOptions = deftype "pandoc ReaderOptions"
[ operation Tostring luaShow
]
[ readonly "extensions" ""
( pushString . show
, readerExtensions)
, readonly "standalone" ""
( pushBool
, readerStandalone)
, readonly "columns" ""
( pushIntegral
, readerColumns)
, readonly "tab_stop" ""
( pushIntegral
, readerTabStop)
, readonly "indented_code_classes" ""
( pushPandocList pushText
, readerIndentedCodeClasses)
, readonly "abbreviations" ""
( pushSet pushText
, readerAbbreviations)
, readonly "track_changes" ""
( pushString . show
, readerTrackChanges)
, readonly "strip_comments" ""
( pushBool
, readerStripComments)
, readonly "default_image_extension" ""
( pushText
, readerDefaultImageExtension)
]
luaShow :: LuaError e => DocumentedFunction e
luaShow = defun "__tostring"
### liftPure show
<#> udparam typeReaderOptions "state" "object to print in native format"
=#> functionResult pushString "string" "Haskell representation"

37
src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs
View file

@ -1,3 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Lua.Marshaling.SimpleTable
Copyright : © 2020-2021 Albert Krewinkel
@ -16,12 +19,11 @@ module Text.Pandoc.Lua.Marshaling.SimpleTable
)
where
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex)
import Control.Monad ((<$!>))
import HsLua as Lua
import Text.Pandoc.Definition
import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor, rawField)
import Text.Pandoc.Lua.Marshaling.AST ()
import qualified Foreign.Lua as Lua
import Text.Pandoc.Lua.Util (pushViaConstructor)
import Text.Pandoc.Lua.Marshaling.AST
-- | A simple (legacy-style) table.
data SimpleTable = SimpleTable
@ -32,16 +34,10 @@ data SimpleTable = SimpleTable
, simpleTableBody :: [[[Block]]]
}
instance Pushable SimpleTable where
push = pushSimpleTable
instance Peekable SimpleTable where
peek = peekSimpleTable
-- | Push a simple table to the stack by calling the
-- @pandoc.SimpleTable@ constructor.
pushSimpleTable :: SimpleTable -> Lua ()
pushSimpleTable tbl = pushViaConstructor "SimpleTable"
pushSimpleTable :: forall e. LuaError e => SimpleTable -> LuaE e ()
pushSimpleTable tbl = pushViaConstructor @e "SimpleTable"
(simpleTableCaption tbl)
(simpleTableAlignments tbl)
(simpleTableColumnWidths tbl)
@ -49,11 +45,10 @@ pushSimpleTable tbl = pushViaConstructor "SimpleTable"
(simpleTableBody tbl)
-- | Retrieve a simple table from the stack.
peekSimpleTable :: StackIndex -> Lua SimpleTable
peekSimpleTable idx = defineHowTo "get SimpleTable" $
SimpleTable
<$> rawField idx "caption"
<*> rawField idx "aligns"
<*> rawField idx "widths"
<*> rawField idx "headers"
<*> rawField idx "rows"
peekSimpleTable :: forall e. LuaError e => Peeker e SimpleTable
peekSimpleTable idx = retrieving "SimpleTable" $ SimpleTable
<$!> peekFieldRaw peekInlines "caption" idx
<*> peekFieldRaw (peekList peekRead) "aligns" idx
<*> peekFieldRaw (peekList peekRealFloat) "widths" idx
<*> peekFieldRaw (peekList peekBlocks) "headers" idx
<*> peekFieldRaw (peekList (peekList peekBlocks)) "rows" idx

164
src/Text/Pandoc/Lua/Marshaling/Version.hs
View file

@ -16,133 +16,92 @@ default comparison operators (like @>@ and @<=@).
module Text.Pandoc.Lua.Marshaling.Version
( peekVersion
, pushVersion
, peekVersionFuzzy
)
where
import Data.Text (Text)
import Data.Maybe (fromMaybe)
import Data.Version (Version (..), makeVersion, parseVersion, showVersion)
import Foreign.Lua (Lua, Optional (..), NumResults,
Peekable, Pushable, StackIndex)
import Foreign.Lua.Types.Peekable (reportValueOnFailure)
import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable,
toAnyWithName)
import Safe (atMay, lastMay)
import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..))
import HsLua as Lua
import Safe (lastMay)
import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Text.Pandoc.UTF8 as UTF8
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
-- | Push a @'Version'@ element to the Lua stack.
pushVersion :: Version -> Lua ()
pushVersion version = pushAnyWithMetatable pushVersionMT version
where
pushVersionMT = ensureUserdataMetatable versionTypeName $ do
LuaUtil.addFunction "__eq" __eq
LuaUtil.addFunction "__le" __le
LuaUtil.addFunction "__lt" __lt
LuaUtil.addFunction "__len" __len
LuaUtil.addFunction "__index" __index
LuaUtil.addFunction "__pairs" __pairs
LuaUtil.addFunction "__tostring" __tostring
instance Peekable Version where
peek = forcePeek . peekVersionFuzzy
instance Pushable Version where
push = pushVersion
peekVersion :: StackIndex -> Lua Version
peekVersion idx = Lua.ltype idx >>= \case
-- | Push a @'Version'@ element to the Lua stack.
pushVersion :: LuaError e => Pusher e Version
pushVersion = pushUD typeVersion
peekVersionFuzzy :: LuaError e => Peeker e Version
peekVersionFuzzy idx = retrieving "Version" $ liftLua (Lua.ltype idx) >>= \case
Lua.TypeUserdata -> peekVersion idx
Lua.TypeString -> do
versionStr <- Lua.peek idx
versionStr <- peekString idx
let parses = readP_to_S parseVersion versionStr
case lastMay parses of
Just (v, "") -> return v
_ -> Lua.throwMessage $ "could not parse as Version: " ++ versionStr
_ -> Lua.failPeek $
UTF8.fromString $ "could not parse as Version: " ++ versionStr
Lua.TypeUserdata ->
reportValueOnFailure versionTypeName
(`toAnyWithName` versionTypeName)
idx
Lua.TypeNumber -> do
n <- Lua.peek idx
return (makeVersion [n])
(makeVersion . (:[])) <$> peekIntegral idx
Lua.TypeTable ->
makeVersion <$> Lua.peek idx
makeVersion <$> peekList peekIntegral idx
_ ->
Lua.throwMessage "could not peek Version"
Lua.failPeek "could not peek Version"
instance Peekable Version where
peek = peekVersion
peekVersion :: LuaError e => Peeker e Version
peekVersion = peekUD typeVersion
-- | Name used by Lua for the @CommonState@ type.
versionTypeName :: String
versionTypeName = "HsLua Version"
__eq :: Version -> Version -> Lua Bool
__eq v1 v2 = return (v1 == v2)
__le :: Version -> Version -> Lua Bool
__le v1 v2 = return (v1 <= v2)
__lt :: Version -> Version -> Lua Bool
__lt v1 v2 = return (v1 < v2)
-- | Get number of version components.
__len :: Version -> Lua Int
__len = return . length . versionBranch
-- | Access fields.
__index :: Version -> AnyValue -> Lua NumResults
__index v (AnyValue k) = do
ty <- Lua.ltype k
case ty of
Lua.TypeNumber -> do
n <- Lua.peek k
let versionPart = atMay (versionBranch v) (n - 1)
Lua.push (Lua.Optional versionPart)
return 1
Lua.TypeString -> do
(str :: Text) <- Lua.peek k
if str == "must_be_at_least"
then 1 <$ Lua.pushHaskellFunction must_be_at_least
else 1 <$ Lua.pushnil
_ -> 1 <$ Lua.pushnil
-- | Create iterator.
__pairs :: Version -> Lua NumResults
__pairs v = do
Lua.pushHaskellFunction nextFn
Lua.pushnil
Lua.pushnil
return 3
where
nextFn :: AnyValue -> Optional Int -> Lua Lua.NumResults
nextFn _ (Optional key) =
case key of
Nothing -> case versionBranch v of
[] -> 2 <$ (Lua.pushnil *> Lua.pushnil)
n:_ -> 2 <$ (Lua.push (1 :: Int) *> Lua.push n)
Just n -> case atMay (versionBranch v) n of
Nothing -> 2 <$ (Lua.pushnil *> Lua.pushnil)
Just b -> 2 <$ (Lua.push (n + 1) *> Lua.push b)
-- | Convert to string.
__tostring :: Version -> Lua String
__tostring v = return (showVersion v)
-- | Default error message when a version is too old. This message is
-- formatted in Lua with the expected and actual versions as arguments.
versionTooOldMessage :: String
versionTooOldMessage = "expected version %s or newer, got %s"
typeVersion :: LuaError e => DocumentedType e Version
typeVersion = deftype "Version"
[ operation Eq $ defun "__eq"
### liftPure2 (==)
<#> parameter peekVersionFuzzy "Version" "v1" ""
<#> parameter peekVersionFuzzy "Version" "v2" ""
=#> functionResult pushBool "boolean" "true iff v1 == v2"
, operation Lt $ defun "__lt"
### liftPure2 (<)
<#> parameter peekVersionFuzzy "Version" "v1" ""
<#> parameter peekVersionFuzzy "Version" "v2" ""
=#> functionResult pushBool "boolean" "true iff v1 < v2"
, operation Le $ defun "__le"
### liftPure2 (<=)
<#> parameter peekVersionFuzzy "Version" "v1" ""
<#> parameter peekVersionFuzzy "Version" "v2" ""
=#> functionResult pushBool "boolean" "true iff v1 <= v2"
, operation Len $ defun "__len"
### liftPure (length . versionBranch)
<#> parameter peekVersionFuzzy "Version" "v1" ""
=#> functionResult pushIntegral "integer" "number of version components"
, operation Tostring $ defun "__tostring"
### liftPure showVersion
<#> parameter peekVersionFuzzy "Version" "version" ""
=#> functionResult pushString "string" "stringified version"
]
[ method $ defun "must_be_at_least"
### must_be_at_least
<#> parameter peekVersionFuzzy "Version" "self" "version to check"
<#> parameter peekVersionFuzzy "Version" "reference" "minimum version"
<#> optionalParameter peekString "string" "msg" "alternative message"
=?> "Returns no result, and throws an error if this version is older than reference"
]
-- | Throw an error if this version is older than the given version.
-- FIXME: This function currently requires the string library to be
-- loaded.
must_be_at_least :: Version -> Version -> Optional String -> Lua NumResults
must_be_at_least actual expected optMsg = do
let msg = fromMaybe versionTooOldMessage (fromOptional optMsg)
must_be_at_least :: LuaError e
=> Version -> Version -> Maybe String
-> LuaE e NumResults
must_be_at_least actual expected mMsg = do
let msg = fromMaybe versionTooOldMessage mMsg
if expected <= actual
then return 0
else do
@ -152,3 +111,8 @@ must_be_at_least actual expected optMsg = do
Lua.push (showVersion actual)
Lua.call 3 1
Lua.error
-- | Default error message when a version is too old. This message is
-- formatted in Lua with the expected and actual versions as arguments.
versionTooOldMessage :: String
versionTooOldMessage = "expected version %s or newer, got %s"

19
src/Text/Pandoc/Lua/Module/MediaBag.hs
View file

@ -15,18 +15,19 @@ module Text.Pandoc.Lua.Module.MediaBag
import Prelude hiding (lookup)
import Control.Monad (zipWithM_)
import Foreign.Lua (Lua, NumResults, Optional)
import HsLua (LuaE, NumResults, Optional)
import HsLua.Marshalling (pushIterator)
import Text.Pandoc.Class.CommonState (CommonState (..))
import Text.Pandoc.Class.PandocMonad (fetchItem, getMediaBag, modifyCommonState,
setMediaBag)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Marshaling.MediaBag (pushIterator)
import Text.Pandoc.Lua.PandocLua (PandocLua (..), liftPandocLua, addFunction)
import Text.Pandoc.MIME (MimeType)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified HsLua as Lua
import qualified Text.Pandoc.MediaBag as MB
--
@ -65,7 +66,15 @@ insert fp optionalMime contents = do
-- | Returns iterator values to be used with a Lua @for@ loop.
items :: PandocLua NumResults
items = getMediaBag >>= liftPandocLua . pushIterator
items = do
mb <- getMediaBag
liftPandocLua $ do
let pushItem (fp, mimetype, contents) = do
Lua.pushString fp
Lua.pushText mimetype
Lua.pushByteString $ BL.toStrict contents
return (Lua.NumResults 3)
pushIterator pushItem (MB.mediaItems mb)
lookup :: FilePath
-> PandocLua NumResults
@ -86,7 +95,7 @@ list = do
zipWithM_ addEntry [1..] dirContents
return 1
where
addEntry :: Lua.Integer -> (FilePath, MimeType, Int) -> Lua ()
addEntry :: Lua.Integer -> (FilePath, MimeType, Int) -> LuaE PandocError ()
addEntry idx (fp, mimeType, contentLength) = do
Lua.newtable
Lua.push ("path" :: T.Text) *> Lua.push fp *> Lua.rawset (-3)

61
src/Text/Pandoc/Lua/Module/Pandoc.hs
View file

@ -15,29 +15,30 @@ module Text.Pandoc.Lua.Module.Pandoc
) where
import Prelude hiding (read)
import Control.Monad (when)
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 HsLua as Lua hiding (pushModule)
import HsLua.Class.Peekable (PeekError)
import System.Exit (ExitCode (..))
import Text.Pandoc.Class.PandocIO (runIO)
import Text.Pandoc.Definition (Block, Inline)
import Text.Pandoc.Lua.Filter (LuaFilter, SingletonsList (..), walkInlines,
import Text.Pandoc.Lua.Filter (SingletonsList (..), walkInlines,
walkInlineLists, walkBlocks, walkBlockLists)
import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Marshaling.AST
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 Text.Pandoc.Walk (Walkable)
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
@ -48,23 +49,25 @@ pushModule = do
loadDefaultModule "pandoc"
addFunction "read" read
addFunction "pipe" pipe
addFunction "walk_block" walk_block
addFunction "walk_inline" walk_inline
addFunction "walk_block" (walkElement peekBlock pushBlock)
addFunction "walk_inline" (walkElement peekInline pushInline)
return 1
walkElement :: (Walkable (SingletonsList Inline) a,
Walkable (SingletonsList Block) a,
Walkable (List Inline) a,
Walkable (List Block) a)
=> a -> LuaFilter -> PandocLua a
walkElement x f = liftPandocLua $
walkInlines f x >>= walkInlineLists f >>= walkBlocks f >>= walkBlockLists f
walk_inline :: Inline -> LuaFilter -> PandocLua Inline
walk_inline = walkElement
walk_block :: Block -> LuaFilter -> PandocLua Block
walk_block = walkElement
=> Peeker PandocError a -> Pusher PandocError a
-> LuaE PandocError NumResults
walkElement peek' push' = do
x <- forcePeek $ peek' (nthBottom 1)
f <- peek (nthBottom 2)
let walk' = walkInlines f
>=> walkInlineLists f
>=> walkBlocks f
>=> walkBlockLists f
walk' x >>= push'
return (NumResults 1)
read :: T.Text -> Optional T.Text -> PandocLua NumResults
read content formatSpecOrNil = liftPandocLua $ do
@ -93,7 +96,9 @@ pipe command args input = liftPandocLua $ do
(ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input
case ec of
ExitSuccess -> 1 <$ Lua.push output
ExitFailure n -> Lua.raiseError (PipeError (T.pack command) n output)
ExitFailure n -> do
pushPipeError (PipeError (T.pack command) n output)
Lua.error
data PipeError = PipeError
{ pipeErrorCommand :: T.Text
@ -101,15 +106,15 @@ data PipeError = PipeError
, pipeErrorOutput :: BL.ByteString
}
instance Peekable PipeError where
peek idx =
peekPipeError :: PeekError e => StackIndex -> LuaE e PipeError
peekPipeError idx =
PipeError
<$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1)
<*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1)
<*> (Lua.getfield idx "output" *> Lua.peek (-1) <* Lua.pop 1)
instance Pushable PipeError where
push pipeErr = do
pushPipeError :: PeekError e => Pusher e PipeError
pushPipeError pipeErr = do
Lua.newtable
LuaUtil.addField "command" (pipeErrorCommand pipeErr)
LuaUtil.addField "error_code" (pipeErrorCode pipeErr)
@ -117,13 +122,18 @@ instance Pushable PipeError where
pushPipeErrorMetaTable
Lua.setmetatable (-2)
where
pushPipeErrorMetaTable :: Lua ()
pushPipeErrorMetaTable :: PeekError e => LuaE e ()
pushPipeErrorMetaTable = do
v <- Lua.newmetatable "pandoc pipe error"
when v $ LuaUtil.addFunction "__tostring" pipeErrorMessage
when v $ do
pushName "__tostring"
pushHaskellFunction pipeErrorMessage
rawset (nth 3)
pipeErrorMessage :: PipeError -> Lua BL.ByteString
pipeErrorMessage (PipeError cmd errorCode output) = return $ mconcat
pipeErrorMessage :: PeekError e => LuaE e NumResults
pipeErrorMessage = do
(PipeError cmd errorCode output) <- peekPipeError (nthBottom 1)
pushByteString . BSL.toStrict . BSL.concat $
[ BSL.pack "Error running "
, BSL.pack $ T.unpack cmd
, BSL.pack " (error code "
@ -131,3 +141,4 @@ instance Pushable PipeError where
, BSL.pack "): "
, if output == mempty then BSL.pack "<no output>" else output
]
return (NumResults 1)

39
src/Text/Pandoc/Lua/Module/System.hs
View file

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Text.Pandoc.Lua.Module.System
Copyright : © 2019-2021 Albert Krewinkel
@ -12,22 +14,31 @@ module Text.Pandoc.Lua.Module.System
( pushModule
) where
import Foreign.Lua (Lua, NumResults)
import Foreign.Lua.Module.System (arch, env, getwd, os,
with_env, with_tmpdir, with_wd)
import Text.Pandoc.Lua.Util (addFunction, addField)
import HsLua hiding (pushModule)
import HsLua.Module.System
(arch, env, getwd, os, with_env, with_tmpdir, with_wd)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.ErrorConversion ()
import qualified Foreign.Lua as Lua
import qualified HsLua as Lua
-- | Push the pandoc.system module on the Lua stack.
pushModule :: Lua NumResults
pushModule :: LuaE PandocError NumResults
pushModule = do
Lua.newtable
addField "arch" arch
addField "os" os
addFunction "environment" env
addFunction "get_working_directory" getwd
addFunction "with_environment" with_env
addFunction "with_temporary_directory" with_tmpdir
addFunction "with_working_directory" with_wd
Lua.pushModule $ Module
{ moduleName = "system"
, moduleDescription = "system functions"
, moduleFields =
[ arch
, os
]
, moduleFunctions =
[ setName "environment" env
, setName "get_working_directory" getwd
, setName "with_environment" with_env
, setName "with_temporary_directory" with_tmpdir
, setName "with_working_directory" with_wd
]
, moduleOperations = []
}
return 1

66
src/Text/Pandoc/Lua/Module/Types.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Lua.Module.Types
Copyright : © 2019-2021 Albert Krewinkel
@ -13,56 +14,41 @@ module Text.Pandoc.Lua.Module.Types
) where
import Data.Version (Version)
import Foreign.Lua (Lua, NumResults)
import Text.Pandoc.Definition
import Text.Pandoc.Lua.Marshaling.AST (LuaAttr, LuaListAttributes)
import HsLua (LuaE, NumResults, Peeker, Pusher)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.ErrorConversion ()
import Text.Pandoc.Lua.Marshaling.AST
import Text.Pandoc.Lua.Marshaling.Version ()
import Text.Pandoc.Lua.Util (addFunction)
import qualified Foreign.Lua as Lua
import qualified HsLua as Lua
-- | Push the pandoc.system module on the Lua stack.
pushModule :: Lua NumResults
-- | Push the pandoc.types module on the Lua stack.
pushModule :: LuaE PandocError NumResults
pushModule = do
Lua.newtable
addFunction "Version" (return :: Version -> Lua Version)
addFunction "Version" (return :: Version -> LuaE PandocError Version)
pushCloneTable
Lua.setfield (Lua.nthFromTop 2) "clone"
Lua.setfield (Lua.nth 2) "clone"
return 1
pushCloneTable :: Lua NumResults
pushCloneTable :: LuaE PandocError NumResults
pushCloneTable = do
Lua.newtable
addFunction "Attr" cloneAttr
addFunction "Block" cloneBlock
addFunction "Citation" cloneCitation
addFunction "Inline" cloneInline
addFunction "Meta" cloneMeta
addFunction "MetaValue" cloneMetaValue
addFunction "ListAttributes" cloneListAttributes
addFunction "Pandoc" clonePandoc
addFunction "Attr" $ cloneWith peekAttr pushAttr
addFunction "Block" $ cloneWith peekBlock pushBlock
addFunction "Citation" $ cloneWith peekCitation Lua.push
addFunction "Inline" $ cloneWith peekInline pushInline
addFunction "Meta" $ cloneWith peekMeta Lua.push
addFunction "MetaValue" $ cloneWith peekMetaValue pushMetaValue
addFunction "ListAttributes" $ cloneWith peekListAttributes pushListAttributes
addFunction "Pandoc" $ cloneWith peekPandoc pushPandoc
return 1
cloneAttr :: LuaAttr -> Lua LuaAttr
cloneAttr = return
cloneBlock :: Block -> Lua Block
cloneBlock = return
cloneCitation :: Citation -> Lua Citation
cloneCitation = return
cloneInline :: Inline -> Lua Inline
cloneInline = return
cloneListAttributes :: LuaListAttributes -> Lua LuaListAttributes
cloneListAttributes = return
cloneMeta :: Meta -> Lua Meta
cloneMeta = return
cloneMetaValue :: MetaValue -> Lua MetaValue
cloneMetaValue = return
clonePandoc :: Pandoc -> Lua Pandoc
clonePandoc = return
cloneWith :: Peeker PandocError a
-> Pusher PandocError a
-> LuaE PandocError NumResults
cloneWith peeker pusher = do
x <- Lua.forcePeek $ peeker (Lua.nthBottom 1)
pusher x
return (Lua.NumResults 1)

211
src/Text/Pandoc/Lua/Module/Utils.hs
View file

@ -1,5 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Lua.Module.Utils
Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -15,82 +17,137 @@ module Text.Pandoc.Lua.Module.Utils
) where
import Control.Applicative ((<|>))
import Control.Monad.Catch (try)
import Control.Monad ((<$!>))
import Data.Data (showConstr, toConstr)
import Data.Default (def)
import Data.Version (Version)
import Foreign.Lua (Peekable, Lua, NumResults (..))
import HsLua as Lua hiding (pushModule)
import HsLua.Class.Peekable (PeekError)
import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Marshaling.AST
( peekBlock, peekInline, peekPandoc, pushBlock, pushInline, pushPandoc
, peekAttr, peekListAttributes, peekMeta, peekMetaValue)
import Text.Pandoc.Lua.Marshaling.List (pushPandocList)
import Text.Pandoc.Lua.Marshaling.SimpleTable
( SimpleTable (..)
, pushSimpleTable
)
import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua)
( SimpleTable (..), peekSimpleTable, pushSimpleTable )
import Text.Pandoc.Lua.Marshaling.Version (peekVersionFuzzy, pushVersion)
import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua))
import qualified Data.Digest.Pure.SHA as SHA
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified HsLua.Packaging as Lua
import qualified Text.Pandoc.Builder as B
import qualified Text.Pandoc.Filter.JSON as JSONFilter
import qualified Text.Pandoc.Shared as Shared
import qualified Text.Pandoc.UTF8 as UTF8
import qualified Text.Pandoc.Writers.Shared as Shared
-- | Push the "pandoc.utils" module to the Lua stack.
pushModule :: PandocLua NumResults
pushModule = do
liftPandocLua Lua.newtable
addFunction "blocks_to_inlines" blocksToInlines
addFunction "equals" equals
addFunction "from_simple_table" from_simple_table
addFunction "make_sections" makeSections
addFunction "normalize_date" normalizeDate
addFunction "run_json_filter" runJSONFilter
addFunction "sha1" sha1
addFunction "stringify" stringify
addFunction "to_roman_numeral" toRomanNumeral
addFunction "to_simple_table" to_simple_table
addFunction "Version" (return :: Version -> Lua Version)
return 1
pandocUtilsModule :: Module PandocError
pandocUtilsModule = Module
{ moduleName = "pandoc.utils"
, moduleDescription = "pandoc utility functions"
, moduleFields = []
, moduleOperations = []
, moduleFunctions =
[ defun "blocks_to_inlines"
### (\blks mSep -> do
let sep = maybe Shared.defaultBlocksSeparator B.fromList mSep
return $ B.toList (Shared.blocksToInlinesWithSep sep blks))
<#> parameter (peekList peekBlock) "list of blocks"
"blocks" ""
<#> optionalParameter (peekList peekInline) "list of inlines"
"inline" ""
=#> functionResult (pushPandocList pushInline) "list of inlines" ""
-- | Squashes a list of blocks into inlines.
blocksToInlines :: [Block] -> Lua.Optional [Inline] -> PandocLua [Inline]
blocksToInlines blks optSep = liftPandocLua $ do
let sep = maybe Shared.defaultBlocksSeparator B.fromList
$ Lua.fromOptional optSep
return $ B.toList (Shared.blocksToInlinesWithSep sep blks)
, defun "equals"
### liftPure2 (==)
<#> parameter peekAstElement "AST element" "elem1" ""
<#> parameter peekAstElement "AST element" "elem2" ""
=#> functionResult pushBool "boolean" "true iff elem1 == elem2"
-- | Convert list of Pandoc blocks into sections using Divs.
makeSections :: Bool -> Lua.Optional Int -> [Block] -> Lua [Block]
makeSections number baselevel =
return . Shared.makeSections number (Lua.fromOptional baselevel)
, defun "make_sections"
### liftPure3 Shared.makeSections
<#> parameter peekBool "boolean" "numbering" "add header numbers"
<#> parameter (\i -> (Nothing <$ peekNil i) <|> (Just <$!> peekIntegral i))
"integer or nil" "baselevel" ""
<#> parameter (peekList peekBlock) "list of blocks"
"blocks" "document blocks to process"
=#> functionResult (pushPandocList pushBlock) "list of Blocks"
"processes blocks"
-- | Parse a date and convert (if possible) to "YYYY-MM-DD" format. We
-- limit years to the range 1601-9999 (ISO 8601 accepts greater than
-- or equal to 1583, but MS Word only accepts dates starting 1601).
-- Returns nil instead of a string if the conversion failed.
normalizeDate :: T.Text -> Lua (Lua.Optional T.Text)
normalizeDate = return . Lua.Optional . Shared.normalizeDate
, defun "normalize_date"
### liftPure Shared.normalizeDate
<#> parameter peekText "string" "date" "the date string"
=#> functionResult (maybe pushnil pushText) "string or nil"
"normalized date, or nil if normalization failed."
#? T.unwords
[ "Parse a date and convert (if possible) to \"YYYY-MM-DD\" format. We"
, "limit years to the range 1601-9999 (ISO 8601 accepts greater than"
, "or equal to 1583, but MS Word only accepts dates starting 1601)."
, "Returns nil instead of a string if the conversion failed."
]
-- | Run a JSON filter on the given document.
runJSONFilter :: Pandoc
-> FilePath
-> Lua.Optional [String]
-> PandocLua Pandoc
runJSONFilter doc filterFile optArgs = do
args <- case Lua.fromOptional optArgs of
Just x -> return x
Nothing -> liftPandocLua $ do
, defun "sha1"
### liftPure (SHA.showDigest . SHA.sha1)
<#> parameter (fmap BSL.fromStrict . peekByteString) "string"
"input" ""
=#> functionResult pushString "string" "hexadecimal hash value"
#? "Compute the hash of the given string value."
, defun "Version"
### liftPure (id @Version)
<#> parameter peekVersionFuzzy
"version string, list of integers, or integer"
"v" "version description"
=#> functionResult pushVersion "Version" "new Version object"
#? "Creates a Version object."
, defun "run_json_filter"
### (\doc filterPath margs -> do
args <- case margs of
Just xs -> return xs
Nothing -> do
Lua.getglobal "FORMAT"
(:[]) <$> Lua.popValue
JSONFilter.apply def args filterFile doc
(forcePeek ((:[]) <$!> peekString top) <* pop 1)
JSONFilter.apply def args filterPath doc
)
<#> parameter peekPandoc "Pandoc" "doc" "input document"
<#> parameter peekString "filepath" "filter_path" "path to filter"
<#> optionalParameter (peekList peekString) "list of strings"
"args" "arguments to pass to the filter"
=#> functionResult pushPandoc "Pandoc" "filtered document"
, defun "stringify"
### unPandocLua . stringify
<#> parameter peekAstElement "AST element" "elem" "some pandoc AST element"
=#> functionResult pushText "string" "stringified element"
, defun "from_simple_table"
### from_simple_table
<#> parameter peekSimpleTable "SimpleTable" "simple_tbl" ""
=?> "Simple table"
, defun "to_roman_numeral"
### liftPure Shared.toRomanNumeral
<#> parameter (peekIntegral @Int) "integer" "n" "number smaller than 4000"
=#> functionResult pushText "string" "roman numeral"
#? "Converts a number < 4000 to uppercase roman numeral."
, defun "to_simple_table"
### to_simple_table
<#> parameter peekTable "Block" "tbl" "a table"
=#> functionResult pushSimpleTable "SimpleTable" "SimpleTable object"
#? "Converts a table into an old/simple table."
]
}
pushModule :: LuaE PandocError NumResults
pushModule = 1 <$ Lua.pushModule pandocUtilsModule
-- | Calculate the hash of the given contents.
sha1 :: BSL.ByteString
-> Lua T.Text
sha1 = return . T.pack . SHA.showDigest . SHA.sha1
-- | Convert pandoc structure to a string with formatting removed.
-- Footnotes are skipped (since we don't want their contents in link
@ -111,9 +168,6 @@ stringifyMetaValue mv = case mv of
MetaString s -> s
_ -> Shared.stringify mv
equals :: AstElement -> AstElement -> PandocLua Bool
equals e1 e2 = return (e1 == e2)
data AstElement
= PandocElement Pandoc
| MetaElement Meta
@ -125,22 +179,19 @@ data AstElement
| CitationElement Citation
deriving (Eq, Show)
instance Peekable AstElement where
peek idx = do
res <- try $ (PandocElement <$> Lua.peek idx)
<|> (InlineElement <$> Lua.peek idx)
<|> (BlockElement <$> Lua.peek idx)
<|> (AttrElement <$> Lua.peek idx)
<|> (ListAttributesElement <$> Lua.peek idx)
<|> (MetaElement <$> Lua.peek idx)
<|> (MetaValueElement <$> Lua.peek idx)
case res of
Right x -> return x
Left (_ :: PandocError) -> Lua.throwMessage
"Expected an AST element, but could not parse value as such."
peekAstElement :: PeekError e => Peeker e AstElement
peekAstElement = retrieving "pandoc AST element" . choice
[ (fmap PandocElement . peekPandoc)
, (fmap InlineElement . peekInline)
, (fmap BlockElement . peekBlock)
, (fmap AttrElement . peekAttr)
, (fmap ListAttributesElement . peekListAttributes)
, (fmap MetaElement . peekMeta)
, (fmap MetaValueElement . peekMetaValue)
]
-- | Converts an old/simple table into a normal table block element.
from_simple_table :: SimpleTable -> Lua NumResults
from_simple_table :: SimpleTable -> LuaE PandocError NumResults
from_simple_table (SimpleTable capt aligns widths head' body) = do
Lua.push $ Table
nullAttr
@ -159,17 +210,19 @@ from_simple_table (SimpleTable capt aligns widths head' body) = do
toColWidth w = ColWidth w
-- | Converts a table into an old/simple table.
to_simple_table :: Block -> Lua NumResults
to_simple_table :: Block -> LuaE PandocError SimpleTable
to_simple_table = \case
Table _attr caption specs thead tbodies tfoot -> do
let (capt, aligns, widths, headers, rows) =
Shared.toLegacyTable caption specs thead tbodies tfoot
pushSimpleTable $ SimpleTable capt aligns widths headers rows
return (NumResults 1)
blk ->
Lua.throwMessage $
"Expected Table, got " <> showConstr (toConstr blk) <> "."
return $ SimpleTable capt aligns widths headers rows
blk -> Lua.failLua $ mconcat
[ "Expected Table, got ", showConstr (toConstr blk), "." ]
-- | Convert a number < 4000 to uppercase roman numeral.
toRomanNumeral :: Lua.Integer -> PandocLua T.Text
toRomanNumeral = return . Shared.toRomanNumeral . fromIntegral
peekTable :: LuaError e => Peeker e Block
peekTable idx = peekBlock idx >>= \case
t@(Table {}) -> return t
b -> Lua.failPeek $ mconcat
[ "Expected Table, got "
, UTF8.fromString $ showConstr (toConstr b)
, "." ]

34
src/Text/Pandoc/Lua/Packages.hs
View file

@ -1,3 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Lua.Packages
Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -13,12 +16,13 @@ module Text.Pandoc.Lua.Packages
) where
import Control.Monad (forM_)
import Foreign.Lua (NumResults)
import HsLua (NumResults)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, loadDefaultModule)
import qualified Foreign.Lua as Lua
import qualified Foreign.Lua.Module.Path as Path
import qualified Foreign.Lua.Module.Text as Text
import qualified HsLua as Lua
import qualified HsLua.Module.Path as Path
import qualified HsLua.Module.Text as Text
import qualified Text.Pandoc.Lua.Module.Pandoc as Pandoc
import qualified Text.Pandoc.Lua.Module.MediaBag as MediaBag
import qualified Text.Pandoc.Lua.Module.System as System
@ -30,8 +34,8 @@ installPandocPackageSearcher :: PandocLua ()
installPandocPackageSearcher = liftPandocLua $ do
Lua.getglobal' "package.searchers"
shiftArray
Lua.pushHaskellFunction pandocPackageSearcher
Lua.rawseti (Lua.nthFromTop 2) 1
Lua.pushHaskellFunction $ Lua.toHaskellFunction pandocPackageSearcher
Lua.rawseti (Lua.nth 2) 1
Lua.pop 1 -- remove 'package.searchers' from stack
where
shiftArray = forM_ [4, 3, 2, 1] $ \i -> do
@ -42,14 +46,16 @@ installPandocPackageSearcher = liftPandocLua $ do
pandocPackageSearcher :: String -> PandocLua NumResults
pandocPackageSearcher pkgName =
case pkgName of
"pandoc" -> pushWrappedHsFun Pandoc.pushModule
"pandoc.mediabag" -> pushWrappedHsFun MediaBag.pushModule
"pandoc.path" -> pushWrappedHsFun Path.pushModule
"pandoc.system" -> pushWrappedHsFun System.pushModule
"pandoc.types" -> pushWrappedHsFun Types.pushModule
"pandoc.utils" -> pushWrappedHsFun Utils.pushModule
"text" -> pushWrappedHsFun Text.pushModule
"pandoc.List" -> pushWrappedHsFun (loadDefaultModule pkgName)
"pandoc" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Pandoc.pushModule
"pandoc.mediabag" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError MediaBag.pushModule
"pandoc.path" -> pushWrappedHsFun
(Lua.NumResults 1 <$ Lua.pushModule @PandocError Path.documentedModule)
"pandoc.system" -> pushWrappedHsFun $ Lua.toHaskellFunction System.pushModule
"pandoc.types" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Types.pushModule
"pandoc.utils" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Utils.pushModule
"text" -> pushWrappedHsFun
(Lua.NumResults 1 <$ Lua.pushModule @PandocError Text.documentedModule)
"pandoc.List" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError (loadDefaultModule pkgName)
_ -> reportPandocSearcherFailure
where
pushWrappedHsFun f = liftPandocLua $ do

33
src/Text/Pandoc/Lua/PandocLua.hs
View file

@ -28,20 +28,19 @@ module Text.Pandoc.Lua.PandocLua
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Except (MonadError (catchError, throwError))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Foreign.Lua (Lua (..), NumResults, Pushable, ToHaskellFunction)
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.ErrorConversion (errorConversion)
import Text.Pandoc.Lua.Marshaling.CommonState (peekCommonState)
import qualified Control.Monad.Catch as Catch
import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Class.IO as IO
-- | Type providing access to both, pandoc and Lua operations.
newtype PandocLua a = PandocLua { unPandocLua :: Lua a }
newtype PandocLua a = PandocLua { unPandocLua :: LuaE PandocError a }
deriving
( Applicative
, Functor
@ -53,7 +52,7 @@ newtype PandocLua a = PandocLua { unPandocLua :: Lua a }
)
-- | Lift a @'Lua'@ operation into the @'PandocLua'@ type.
liftPandocLua :: Lua a -> PandocLua a
liftPandocLua :: LuaE PandocError a -> PandocLua a
liftPandocLua = PandocLua
-- | Evaluate a @'PandocLua'@ computation, running all contained Lua
@ -62,7 +61,7 @@ runPandocLua :: (PandocMonad m, MonadIO m) => PandocLua a -> m a
runPandocLua pLua = do
origState <- getCommonState
globals <- defaultGlobals
(result, newState) <- liftIO . Lua.run' errorConversion . unPandocLua $ do
(result, newState) <- liftIO . Lua.run . unPandocLua $ do
putCommonState origState
liftPandocLua $ setGlobals globals
r <- pLua
@ -71,17 +70,17 @@ runPandocLua pLua = do
putCommonState newState
return result
instance {-# OVERLAPPING #-} ToHaskellFunction (PandocLua NumResults) where
toHsFun _narg = unPandocLua
instance {-# OVERLAPPING #-} Exposable PandocError (PandocLua NumResults) where
partialApply _narg = unPandocLua
instance Pushable a => ToHaskellFunction (PandocLua a) where
toHsFun _narg x = 1 <$ (unPandocLua x >>= Lua.push)
instance Pushable a => Exposable PandocError (PandocLua a) where
partialApply _narg x = 1 <$ (unPandocLua x >>= Lua.push)
-- | Add a function to the table at the top of the stack, using the given name.
addFunction :: ToHaskellFunction a => String -> a -> PandocLua ()
addFunction :: Exposable PandocError a => Name -> a -> PandocLua ()
addFunction name fn = liftPandocLua $ do
Lua.push name
Lua.pushHaskellFunction fn
Lua.pushName name
Lua.pushHaskellFunction $ toHaskellFunction fn
Lua.rawset (-3)
-- | Load a pure Lua module included with pandoc. Leaves the result on
@ -93,8 +92,8 @@ addFunction name fn = liftPandocLua $ do
loadDefaultModule :: String -> PandocLua NumResults
loadDefaultModule name = do
script <- readDefaultDataFile (name <> ".lua")
status <- liftPandocLua $ Lua.dostring script
if status == Lua.OK
result <- liftPandocLua $ Lua.dostring script
if result == Lua.OK
then return (1 :: NumResults)
else do
msg <- liftPandocLua Lua.popValue
@ -135,7 +134,7 @@ instance PandocMonad PandocLua where
getCommonState = PandocLua $ do
Lua.getglobal "PANDOC_STATE"
Lua.peek Lua.stackTop
forcePeek $ peekCommonState Lua.top
putCommonState = PandocLua . setGlobals . (:[]) . PANDOC_STATE
logOutput = IO.logOutput

112
src/Text/Pandoc/Lua/Util.hs
View file

@ -1,6 +1,9 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Lua.Util
Copyright : © 2012-2021 John MacFarlane,
@ -14,114 +17,91 @@ Lua utility functions.
-}
module Text.Pandoc.Lua.Util
( getTag
, rawField
, addField
, addFunction
, addValue
, pushViaConstructor
, defineHowTo
, throwTopMessageAsError'
, callWithTraceback
, dofileWithTraceback
, pushViaConstr'
) where
import Control.Monad (unless, when)
import Data.Text (Text)
import Foreign.Lua ( Lua, NumArgs, NumResults, Peekable, Pushable, StackIndex
, Status, ToHaskellFunction )
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.UTF8 as UTF8
-- | Get value behind key from table at given index.
rawField :: Peekable a => StackIndex -> String -> Lua a
rawField idx key = do
absidx <- Lua.absindex idx
Lua.push key
Lua.rawget absidx
Lua.popValue
import HsLua
import qualified HsLua as Lua
-- | Add a value to the table at the top of the stack at a string-index.
addField :: Pushable a => String -> a -> Lua ()
addField = addValue
-- | Add a key-value pair to the table at the top of the stack.
addValue :: (Pushable a, Pushable b) => a -> b -> Lua ()
addValue key value = do
addField :: (LuaError e, Pushable a) => String -> a -> LuaE e ()
addField key value = do
Lua.push key
Lua.push value
Lua.rawset (Lua.nthFromTop 3)
Lua.rawset (Lua.nth 3)
-- | Add a function to the table at the top of the stack, using the given name.
addFunction :: ToHaskellFunction a => String -> a -> Lua ()
-- | Add a function to the table at the top of the stack, using the
-- given name.
addFunction :: Exposable e a => String -> a -> LuaE e ()
addFunction name fn = do
Lua.push name
Lua.pushHaskellFunction fn
Lua.pushHaskellFunction $ toHaskellFunction fn
Lua.rawset (-3)
-- | Helper class for pushing a single value to the stack via a lua function.
-- See @pushViaCall@.
class PushViaCall a where
pushViaCall' :: String -> Lua () -> NumArgs -> a
-- | Helper class for pushing a single value to the stack via a lua
-- function. See @pushViaCall@.
class LuaError e => PushViaCall e a where
pushViaCall' :: LuaError e => Name -> LuaE e () -> NumArgs -> a
instance PushViaCall (Lua ()) where
instance LuaError e => PushViaCall e (LuaE e ()) where
pushViaCall' fn pushArgs num = do
Lua.push fn
Lua.pushName @e fn
Lua.rawget Lua.registryindex
pushArgs
Lua.call num 1
instance (Pushable a, PushViaCall b) => PushViaCall (a -> b) where
instance (LuaError e, Pushable a, PushViaCall e b) =>
PushViaCall e (a -> b) where
pushViaCall' fn pushArgs num x =
pushViaCall' fn (pushArgs *> Lua.push x) (num + 1)
pushViaCall' @e fn (pushArgs *> Lua.push x) (num + 1)
-- | Push an value to the stack via a lua function. The lua function is called
-- with all arguments that are passed to this function and is expected to return
-- a single value.
pushViaCall :: PushViaCall a => String -> a
pushViaCall fn = pushViaCall' fn (return ()) 0
pushViaCall :: forall e a. LuaError e => PushViaCall e a => Name -> a
pushViaCall fn = pushViaCall' @e fn (return ()) 0
-- | Call a pandoc element constructor within Lua, passing all given arguments.
pushViaConstructor :: PushViaCall a => String -> a
pushViaConstructor pandocFn = pushViaCall ("pandoc." ++ pandocFn)
pushViaConstructor :: forall e a. LuaError e => PushViaCall e a => Name -> a
pushViaConstructor pandocFn = pushViaCall @e ("pandoc." <> pandocFn)
-- | Get the tag of a value. This is an optimized and specialized version of
-- @Lua.getfield idx "tag"@. It only checks for the field on the table at index
-- @idx@ and on its metatable, also ignoring any @__index@ value on the
-- metatable.
getTag :: StackIndex -> Lua String
getTag :: LuaError e => Peeker e Name
getTag idx = do
-- push metatable or just the table
liftLua $ do
Lua.getmetatable idx >>= \hasMT -> unless hasMT (Lua.pushvalue idx)
Lua.push ("tag" :: Text)
Lua.rawget (Lua.nthFromTop 2)
Lua.tostring Lua.stackTop <* Lua.pop 2 >>= \case
Nothing -> Lua.throwMessage "untagged value"
Just x -> return (UTF8.toString x)
Lua.pushName "tag"
Lua.rawget (Lua.nth 2)
Lua.peekName Lua.top `lastly` Lua.pop 2 -- table/metatable and `tag` field
-- | Modify the message at the top of the stack before throwing it as an
-- Exception.
throwTopMessageAsError' :: (String -> String) -> Lua a
throwTopMessageAsError' modifier = do
msg <- Lua.tostring' Lua.stackTop
Lua.pop 2 -- remove error and error string pushed by tostring'
Lua.throwMessage (modifier (UTF8.toString msg))
-- | Mark the context of a Lua computation for better error reporting.
defineHowTo :: String -> Lua a -> Lua a
defineHowTo ctx op = Lua.errorConversion >>= \ec ->
Lua.addContextToException ec ("Could not " <> ctx <> ": ") op
pushViaConstr' :: forall e. LuaError e => Name -> [LuaE e ()] -> LuaE e ()
pushViaConstr' fnname pushArgs = do
pushName @e ("pandoc." <> fnname)
rawget @e registryindex
sequence_ pushArgs
call @e (fromIntegral (length pushArgs)) 1
-- | Like @'Lua.pcall'@, but uses a predefined error handler which adds a
-- traceback on error.
pcallWithTraceback :: NumArgs -> NumResults -> Lua Status
pcallWithTraceback :: LuaError e => NumArgs -> NumResults -> LuaE e Status
pcallWithTraceback nargs nresults = do
let traceback' :: Lua NumResults
let traceback' :: LuaError e => LuaE e NumResults
traceback' = do
l <- Lua.state
msg <- Lua.tostring' (Lua.nthFromBottom 1)
Lua.traceback l (Just (UTF8.toString msg)) 2
msg <- Lua.tostring' (Lua.nthBottom 1)
Lua.traceback l (Just msg) 2
return 1
tracebackIdx <- Lua.absindex (Lua.nthFromTop (Lua.fromNumArgs nargs + 1))
tracebackIdx <- Lua.absindex (Lua.nth (Lua.fromNumArgs nargs + 1))
Lua.pushHaskellFunction traceback'
Lua.insert tracebackIdx
result <- Lua.pcall nargs nresults (Just tracebackIdx)
@ -129,15 +109,15 @@ pcallWithTraceback nargs nresults = do
return result
-- | Like @'Lua.call'@, but adds a traceback to the error message (if any).
callWithTraceback :: NumArgs -> NumResults -> Lua ()
callWithTraceback :: LuaError e => NumArgs -> NumResults -> LuaE e ()
callWithTraceback nargs nresults = do
result <- pcallWithTraceback nargs nresults
when (result /= Lua.OK)
Lua.throwTopMessage
Lua.throwErrorAsException
-- | Run the given string as a Lua program, while also adding a traceback to the
-- error message if an error occurs.
dofileWithTraceback :: FilePath -> Lua Status
dofileWithTraceback :: LuaError e => FilePath -> LuaE e Status
dofileWithTraceback fp = do
loadRes <- Lua.loadfile fp
case loadRes of

150
src/Text/Pandoc/Writers/Custom.hs
View file

@ -1,5 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Writers.Custom
Copyright : Copyright (C) 2012-2021 John MacFarlane
@ -10,7 +13,7 @@
Portability : portable
Conversion of 'Pandoc' documents to custom markup using
a lua writer.
a Lua writer.
-}
module Text.Pandoc.Writers.Custom ( writeCustom ) where
import Control.Arrow ((***))
@ -20,7 +23,8 @@ import Data.List (intersperse)
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text, pack)
import Foreign.Lua (Lua, Pushable)
import HsLua as Lua hiding (Operation (Div), render)
import HsLua.Class.Peekable (PeekError)
import Text.DocLayout (render, literal)
import Control.Monad.IO.Class (MonadIO)
import Text.Pandoc.Definition
@ -31,39 +35,39 @@ import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Writers.Shared
import qualified Foreign.Lua as Lua
attrToMap :: Attr -> M.Map T.Text T.Text
attrToMap (id',classes,keyvals) = M.fromList
$ ("id", id')
: ("class", T.unwords classes)
: keyvals
newtype Stringify a = Stringify a
newtype Stringify e a = Stringify a
instance Pushable (Stringify Format) where
instance Pushable (Stringify e Format) where
push (Stringify (Format f)) = Lua.push (T.toLower f)
instance Pushable (Stringify [Inline]) where
push (Stringify ils) = Lua.push =<< inlineListToCustom ils
instance PeekError e => Pushable (Stringify e [Inline]) where
push (Stringify ils) = Lua.push =<<
changeErrorType ((inlineListToCustom @e) ils)
instance Pushable (Stringify [Block]) where
push (Stringify blks) = Lua.push =<< blockListToCustom blks
instance PeekError e => Pushable (Stringify e [Block]) where
push (Stringify blks) = Lua.push =<<
changeErrorType ((blockListToCustom @e) blks)
instance Pushable (Stringify MetaValue) where
push (Stringify (MetaMap m)) = Lua.push (fmap Stringify m)
push (Stringify (MetaList xs)) = Lua.push (map Stringify xs)
instance PeekError e => Pushable (Stringify e MetaValue) where
push (Stringify (MetaMap m)) = Lua.push (fmap (Stringify @e) m)
push (Stringify (MetaList xs)) = Lua.push (map (Stringify @e) xs)
push (Stringify (MetaBool x)) = Lua.push x
push (Stringify (MetaString s)) = Lua.push s
push (Stringify (MetaInlines ils)) = Lua.push (Stringify ils)
push (Stringify (MetaBlocks bs)) = Lua.push (Stringify bs)
push (Stringify (MetaInlines ils)) = Lua.push (Stringify @e ils)
push (Stringify (MetaBlocks bs)) = Lua.push (Stringify @e bs)
instance Pushable (Stringify Citation) where
instance PeekError e => Pushable (Stringify e Citation) where
push (Stringify cit) = do
Lua.createtable 6 0
addField "citationId" $ citationId cit
addField "citationPrefix" . Stringify $ citationPrefix cit
addField "citationSuffix" . Stringify $ citationSuffix cit
addField "citationPrefix" . Stringify @e $ citationPrefix cit
addField "citationSuffix" . Stringify @e $ citationSuffix cit
addField "citationMode" $ show (citationMode cit)
addField "citationNoteNum" $ citationNoteNum cit
addField "citationHash" $ citationHash cit
@ -77,7 +81,7 @@ instance (Pushable a, Pushable b) => Pushable (KeyValue a b) where
Lua.newtable
Lua.push k
Lua.push v
Lua.rawset (Lua.nthFromTop 3)
Lua.rawset (Lua.nth 3)
-- | Convert Pandoc to custom markup.
writeCustom :: (PandocMonad m, MonadIO m)
@ -92,7 +96,7 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do
-- check for error in lua script (later we'll change the return type
-- to handle this more gracefully):
when (stat /= Lua.OK)
Lua.throwTopMessage
Lua.throwErrorAsException
rendered <- docToCustom opts doc
context <- metaToContext opts
(fmap (literal . pack) . blockListToCustom)
@ -107,126 +111,132 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do
Just tpl -> render Nothing $
renderTemplate tpl $ setField "body" body context
docToCustom :: WriterOptions -> Pandoc -> Lua String
docToCustom :: forall e. PeekError e
=> WriterOptions -> Pandoc -> LuaE e String
docToCustom opts (Pandoc (Meta metamap) blocks) = do
body <- blockListToCustom blocks
Lua.callFunc "Doc" body (fmap Stringify metamap) (writerVariables opts)
invoke @e "Doc" body (fmap (Stringify @e) metamap) (writerVariables opts)
-- | Convert Pandoc block element to Custom.
blockToCustom :: Block -- ^ Block element
-> Lua String
blockToCustom :: forall e. PeekError e
=> Block -- ^ Block element
-> LuaE e String
blockToCustom Null = return ""
blockToCustom (Plain inlines) = Lua.callFunc "Plain" (Stringify inlines)
blockToCustom (Plain inlines) = invoke @e "Plain" (Stringify @e inlines)
blockToCustom (Para [Image attr txt (src,tit)]) =
Lua.callFunc "CaptionedImage" src tit (Stringify txt) (attrToMap attr)
invoke @e "CaptionedImage" src tit (Stringify @e txt) (attrToMap attr)
blockToCustom (Para inlines) = Lua.callFunc "Para" (Stringify inlines)
blockToCustom (Para inlines) = invoke @e "Para" (Stringify @e inlines)
blockToCustom (LineBlock linesList) =
Lua.callFunc "LineBlock" (map Stringify linesList)
invoke @e "LineBlock" (map (Stringify @e) linesList)
blockToCustom (RawBlock format str) =
Lua.callFunc "RawBlock" (Stringify format) str
invoke @e "RawBlock" (Stringify @e format) str
blockToCustom HorizontalRule = Lua.callFunc "HorizontalRule"
blockToCustom HorizontalRule = invoke @e "HorizontalRule"
blockToCustom (Header level attr inlines) =
Lua.callFunc "Header" level (Stringify inlines) (attrToMap attr)
invoke @e "Header" level (Stringify @e inlines) (attrToMap attr)
blockToCustom (CodeBlock attr str) =
Lua.callFunc "CodeBlock" str (attrToMap attr)
invoke @e "CodeBlock" str (attrToMap attr)
blockToCustom (BlockQuote blocks) =
Lua.callFunc "BlockQuote" (Stringify blocks)
invoke @e "BlockQuote" (Stringify @e blocks)
blockToCustom (Table _ blkCapt specs thead tbody tfoot) =
let (capt, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot
aligns' = map show aligns
capt' = Stringify capt
headers' = map Stringify headers
rows' = map (map Stringify) rows
in Lua.callFunc "Table" capt' aligns' widths headers' rows'
capt' = Stringify @e capt
headers' = map (Stringify @e) headers
rows' = map (map (Stringify @e)) rows
in invoke @e "Table" capt' aligns' widths headers' rows'
blockToCustom (BulletList items) =
Lua.callFunc "BulletList" (map Stringify items)
invoke @e "BulletList" (map (Stringify @e) items)
blockToCustom (OrderedList (num,sty,delim) items) =
Lua.callFunc "OrderedList" (map Stringify items) num (show sty) (show delim)
invoke @e "OrderedList" (map (Stringify @e) items) num (show sty) (show delim)
blockToCustom (DefinitionList items) =
Lua.callFunc "DefinitionList"
(map (KeyValue . (Stringify *** map Stringify)) items)
invoke @e "DefinitionList"
(map (KeyValue . (Stringify @e *** map (Stringify @e))) items)
blockToCustom (Div attr items) =
Lua.callFunc "Div" (Stringify items) (attrToMap attr)
invoke @e "Div" (Stringify @e items) (attrToMap attr)
-- | Convert list of Pandoc block elements to Custom.
blockListToCustom :: [Block] -- ^ List of block elements
-> Lua String
blockListToCustom :: forall e. PeekError e
=> [Block] -- ^ List of block elements
-> LuaE e String
blockListToCustom xs = do
blocksep <- Lua.callFunc "Blocksep"
blocksep <- invoke @e "Blocksep"
bs <- mapM blockToCustom xs
return $ mconcat $ intersperse blocksep bs
-- | Convert list of Pandoc inline elements to Custom.
inlineListToCustom :: [Inline] -> Lua String
inlineListToCustom :: forall e. PeekError e => [Inline] -> LuaE e String
inlineListToCustom lst = do
xs <- mapM inlineToCustom lst
xs <- mapM (inlineToCustom @e) lst
return $ mconcat xs
-- | Convert Pandoc inline element to Custom.
inlineToCustom :: Inline -> Lua String
inlineToCustom :: forall e. PeekError e => Inline -> LuaE e String
inlineToCustom (Str str) = Lua.callFunc "Str" str
inlineToCustom (Str str) = invoke @e "Str" str
inlineToCustom Space = Lua.callFunc "Space"
inlineToCustom Space = invoke @e "Space"
inlineToCustom SoftBreak = Lua.callFunc "SoftBreak"
inlineToCustom SoftBreak = invoke @e "SoftBreak"
inlineToCustom (Emph lst) = Lua.callFunc "Emph" (Stringify lst)
inlineToCustom (Emph lst) = invoke @e "Emph" (Stringify @e lst)
inlineToCustom (Underline lst) = Lua.callFunc "Underline" (Stringify lst)
inlineToCustom (Underline lst) = invoke @e "Underline" (Stringify @e lst)
inlineToCustom (Strong lst) = Lua.callFunc "Strong" (Stringify lst)
inlineToCustom (Strong lst) = invoke @e "Strong" (Stringify @e lst)
inlineToCustom (Strikeout lst) = Lua.callFunc "Strikeout" (Stringify lst)
inlineToCustom (Strikeout lst) = invoke @e "Strikeout" (Stringify @e lst)
inlineToCustom (Superscript lst) = Lua.callFunc "Superscript" (Stringify lst)
inlineToCustom (Superscript lst) = invoke @e "Superscript" (Stringify @e lst)
inlineToCustom (Subscript lst) = Lua.callFunc "Subscript" (Stringify lst)
inlineToCustom (Subscript lst) = invoke @e "Subscript" (Stringify @e lst)
inlineToCustom (SmallCaps lst) = Lua.callFunc "SmallCaps" (Stringify lst)
inlineToCustom (SmallCaps lst) = invoke @e "SmallCaps" (Stringify @e lst)
inlineToCustom (Quoted SingleQuote lst) = Lua.callFunc "SingleQuoted" (Stringify lst)
inlineToCustom (Quoted SingleQuote lst) =
invoke @e "SingleQuoted" (Stringify @e lst)
inlineToCustom (Quoted DoubleQuote lst) = Lua.callFunc "DoubleQuoted" (Stringify lst)
inlineToCustom (Quoted DoubleQuote lst) =
invoke @e "DoubleQuoted" (Stringify @e lst)
inlineToCustom (Cite cs lst) = Lua.callFunc "Cite" (Stringify lst) (map Stringify cs)
inlineToCustom (Cite cs lst) =
invoke @e "Cite" (Stringify @e lst) (map (Stringify @e) cs)
inlineToCustom (Code attr str) =
Lua.callFunc "Code" str (attrToMap attr)
invoke @e "Code" str (attrToMap attr)
inlineToCustom (Math DisplayMath str) =
Lua.callFunc "DisplayMath" str
invoke @e "DisplayMath" str
inlineToCustom (Math InlineMath str) =
Lua.callFunc "InlineMath" str
invoke @e "InlineMath" str
inlineToCustom (RawInline format str) =
Lua.callFunc "RawInline" (Stringify format) str
invoke @e "RawInline" (Stringify @e format) str
inlineToCustom LineBreak = Lua.callFunc "LineBreak"
inlineToCustom LineBreak = invoke @e "LineBreak"
inlineToCustom (Link attr txt (src,tit)) =
Lua.callFunc "Link" (Stringify txt) src tit (attrToMap attr)
invoke @e "Link" (Stringify @e txt) src tit (attrToMap attr)
inlineToCustom (Image attr alt (src,tit)) =
Lua.callFunc "Image" (Stringify alt) src tit (attrToMap attr)
invoke @e "Image" (Stringify @e alt) src tit (attrToMap attr)
inlineToCustom (Note contents) = Lua.callFunc "Note" (Stringify contents)
inlineToCustom (Note contents) = invoke @e "Note" (Stringify @e contents)
inlineToCustom (Span attr items) =
Lua.callFunc "Span" (Stringify items) (attrToMap attr)
invoke @e "Span" (Stringify @e items) (attrToMap attr)

15
stack.yaml
View file

@ -12,6 +12,19 @@ extra-deps:
- doctemplates-0.10
- emojis-0.1.2
- doclayout-0.3.1.1
- hslua-2.0.0
- hslua-classes-2.0.0
- hslua-core-2.0.0
- hslua-marshalling-2.0.0
- hslua-module-path-1.0.0
- hslua-module-system-1.0.0
- hslua-module-text-1.0.0
- hslua-module-version-1.0.0
- hslua-objectorientation-2.0.0
- hslua-packaging-2.0.0
- lua-2.0.0
- tasty-hslua-1.0.0
- tasty-lua-1.0.0
- git: https://github.com/jgm/pandoc-types.git
commit: 99402a46361a3e52805935b1fbe9dfe54f852d6a
- git: https://github.com/jgm/texmath.git
@ -26,5 +39,3 @@ ghc-options:
resolver: lts-18.10
nix:
packages: [zlib]

61
test/Tests/Lua.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Tests.Lua
Copyright : © 2017-2021 Albert Krewinkel
@ -14,9 +15,10 @@ Unit and integration tests for pandoc's Lua subsystem.
module Tests.Lua ( runLuaTest, tests ) where
import Control.Monad (when)
import HsLua as Lua hiding (Operation (Div), error)
import System.FilePath ((</>))
import Test.Tasty (TestTree, localOption)
import Test.Tasty.HUnit (Assertion, assertEqual, testCase)
import Test.Tasty.HUnit (Assertion, HasCallStack, assertEqual, testCase)
import Test.Tasty.QuickCheck (QuickCheckTests (..), ioProperty, testProperty)
import Text.Pandoc.Arbitrary ()
import Text.Pandoc.Builder (bulletList, definitionList, displayMath, divWith,
@ -25,8 +27,8 @@ import Text.Pandoc.Builder (bulletList, definitionList, displayMath, divWith,
singleQuoted, space, str, strong,
HasMeta (setMeta))
import Text.Pandoc.Class (runIOorExplode, setUserDataDir)
import Text.Pandoc.Definition (Block (BlockQuote, Div, Para), Inline (Emph, Str),
Attr, Meta, Pandoc, pandocTypesVersion)
import Text.Pandoc.Definition (Attr, Block (BlockQuote, Div, Para), Pandoc,
Inline (Emph, Str), Meta, pandocTypesVersion)
import Text.Pandoc.Error (PandocError (PandocLuaError))
import Text.Pandoc.Filter (Filter (LuaFilter), applyFilters)
import Text.Pandoc.Lua (runLua)
@ -34,23 +36,22 @@ import Text.Pandoc.Options (def)
import Text.Pandoc.Shared (pandocVersion)
import qualified Control.Monad.Catch as Catch
import qualified Foreign.Lua as Lua
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
tests :: [TestTree]
tests = map (localOption (QuickCheckTests 20))
[ testProperty "inline elements can be round-tripped through the lua stack" $
\x -> ioProperty (roundtripEqual (x::Inline))
ioProperty . roundtripEqual @Inline
, testProperty "block elements can be round-tripped through the lua stack" $
\x -> ioProperty (roundtripEqual (x::Block))
ioProperty . roundtripEqual @Block
, testProperty "meta blocks can be round-tripped through the lua stack" $
\x -> ioProperty (roundtripEqual (x::Meta))
ioProperty . roundtripEqual @Meta
, testProperty "documents can be round-tripped through the lua stack" $
\x -> ioProperty (roundtripEqual (x::Pandoc))
ioProperty . roundtripEqual @Pandoc
, testCase "macro expansion via filter" $
assertFilterConversion "a '{{helloworld}}' string is expanded"
@ -163,12 +164,12 @@ tests = map (localOption (QuickCheckTests 20))
Lua.getglobal "PANDOC_VERSION"
Lua.liftIO .
assertEqual "pandoc version is wrong" (TE.encodeUtf8 pandocVersion)
=<< Lua.tostring' Lua.stackTop
=<< Lua.tostring' Lua.top
, testCase "Pandoc types version is set" . runLuaTest $ do
Lua.getglobal "PANDOC_API_VERSION"
Lua.liftIO . assertEqual "pandoc-types version is wrong" pandocTypesVersion
=<< Lua.peek Lua.stackTop
=<< Lua.peek Lua.top
, testCase "require file" $
assertFilterConversion "requiring file failed"
@ -177,38 +178,47 @@ tests = map (localOption (QuickCheckTests 20))
(doc $ para (str . T.pack $ "lua" </> "require-file.lua"))
, testCase "Allow singleton inline in constructors" . runLuaTest $ do
Lua.liftIO . assertEqual "Not the expected Emph" (Emph [Str "test"])
=<< Lua.callFunc "pandoc.Emph" (Str "test")
Lua.liftIO . assertEqual "Unexpected element" (Para [Str "test"])
=<< Lua.callFunc "pandoc.Para" ("test" :: String)
Lua.liftIO . assertEqual "Not the expected Emph"
(Emph [Str "test"]) =<< do
Lua.OK <- Lua.dostring "return pandoc.Emph"
Lua.push @Inline (Str "test")
Lua.call 1 1
Lua.peek @Inline top
Lua.liftIO . assertEqual "Unexpected element"
(Para [Str "test"]) =<< do
Lua.getglobal' "pandoc.Para"
Lua.pushString "test"
Lua.call 1 1
Lua.peek @Block top
Lua.liftIO . assertEqual "Unexptected element"
(BlockQuote [Para [Str "foo"]]) =<< (
do
Lua.getglobal' "pandoc.BlockQuote"
Lua.push (Para [Str "foo"])
_ <- Lua.call 1 1
Lua.peek Lua.stackTop
Lua.peek @Block Lua.top
)
, testCase "Elements with Attr have `attr` accessor" . runLuaTest $ do
Lua.push (Div ("hi", ["moin"], [])
[Para [Str "ignored"]])
Lua.getfield Lua.stackTop "attr"
Lua.getfield Lua.top "attr"
Lua.liftIO . assertEqual "no accessor" (("hi", ["moin"], []) :: Attr)
=<< Lua.peek Lua.stackTop
=<< Lua.peek Lua.top
, testCase "module `pandoc.system` is present" . runLuaTest $ do
Lua.getglobal' "pandoc.system"
ty <- Lua.ltype Lua.stackTop
ty <- Lua.ltype Lua.top
Lua.liftIO $ assertEqual "module should be a table" Lua.TypeTable ty
, testCase "informative error messages" . runLuaTest $ do
Lua.pushboolean True
eitherPandoc <- Catch.try (Lua.peek Lua.stackTop :: Lua.Lua Pandoc)
-- Lua.newtable
eitherPandoc <- Catch.try (peek @Pandoc Lua.top)
case eitherPandoc of
Left (PandocLuaError msg) -> do
let expectedMsg = "Could not get Pandoc value: "
<> "table expected, got boolean"
let expectedMsg = "table expected, got boolean\n"
<> "\twhile retrieving Pandoc value"
Lua.liftIO $ assertEqual "unexpected error message" expectedMsg msg
Left e -> error ("Expected a Lua error, but got " <> show e)
Right _ -> error "Getting a Pandoc element from a bool should fail."
@ -221,19 +231,20 @@ assertFilterConversion msg filterPath docIn expectedDoc = do
applyFilters def [LuaFilter ("lua" </> filterPath)] ["HTML"] docIn
assertEqual msg expectedDoc actualDoc
roundtripEqual :: (Eq a, Lua.Peekable a, Lua.Pushable a) => a -> IO Bool
roundtripEqual :: forall a. (Eq a, Lua.Pushable a, Lua.Peekable a)
=> a -> IO Bool
roundtripEqual x = (x ==) <$> roundtripped
where
roundtripped :: Lua.Peekable a => IO a
roundtripped :: IO a
roundtripped = runLuaTest $ do
oldSize <- Lua.gettop
Lua.push x
size <- Lua.gettop
when (size - oldSize /= 1) $
error ("not exactly one additional element on the stack: " ++ show size)
Lua.peek (-1)
Lua.peek Lua.top
runLuaTest :: Lua.Lua a -> IO a
runLuaTest :: HasCallStack => Lua.LuaE PandocError a -> IO a
runLuaTest op = runIOorExplode $ do
setUserDataDir (Just "../data")
res <- runLua op

25
test/lua/module/pandoc-types.lua
View file

@ -55,31 +55,6 @@ return {
end),
},
group 'list-like behavior' {
test('can access version component numbers', function ()
local version = Version '2.7.3'
assert.is_nil(version[0])
assert.are_equal(version[1], 2)
assert.are_equal(version[2], 7)
assert.are_equal(version[3], 3)
end),
test('can be iterated over', function ()
local version_list = {2, 7, 3}
local final_index = 0
for i, v in pairs(Version(version_list)) do
assert.are_equal(v, version_list[i])
final_index = i
end
assert.are_equal(final_index, 3)
end),
test('length is the number of components', function ()
assert.are_equal(#(Version '0'), 1)
assert.are_equal(#(Version '1.6'), 2)
assert.are_equal(#(Version '8.7.5'), 3)
assert.are_equal(#(Version '2.9.1.5'), 4)
end)
},
group 'conversion to string' {
test('converting from and to string is a noop', function ()
local version_string = '1.19.4'