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 -- type: git
-- location: https://github.com/jgm/ipynb.git -- location: https://github.com/jgm/ipynb.git
-- tag: 1f1ddb29227335091a3a158b9aeeeb47a372c683 -- tag: 1f1ddb29227335091a3a158b9aeeeb47a372c683

15
pandoc.cabal
View file

@ -551,10 +551,11 @@ library
file-embed >= 0.0 && < 0.1, file-embed >= 0.0 && < 0.1,
filepath >= 1.1 && < 1.5, filepath >= 1.1 && < 1.5,
haddock-library >= 1.10 && < 1.11, haddock-library >= 1.10 && < 1.11,
hslua >= 1.1 && < 1.4, hslua >= 2.0 && < 2.1,
hslua-module-path >= 0.1.0 && < 0.2.0, hslua-marshalling >= 2.0 && < 2.1,
hslua-module-system >= 0.2 && < 0.3, hslua-module-path >= 1.0 && < 1.1,
hslua-module-text >= 0.2.1 && < 0.4, hslua-module-system >= 1.0 && < 1.1,
hslua-module-text >= 1.0 && < 1.1,
http-client >= 0.4.30 && < 0.8, http-client >= 0.4.30 && < 0.8,
http-client-tls >= 0.2.4 && < 0.4, http-client-tls >= 0.2.4 && < 0.4,
http-types >= 0.8 && < 0.13, http-types >= 0.8 && < 0.13,
@ -775,11 +776,9 @@ library
Text.Pandoc.Lua.Init, Text.Pandoc.Lua.Init,
Text.Pandoc.Lua.Marshaling, Text.Pandoc.Lua.Marshaling,
Text.Pandoc.Lua.Marshaling.AST, Text.Pandoc.Lua.Marshaling.AST,
Text.Pandoc.Lua.Marshaling.AnyValue,
Text.Pandoc.Lua.Marshaling.CommonState, Text.Pandoc.Lua.Marshaling.CommonState,
Text.Pandoc.Lua.Marshaling.Context, Text.Pandoc.Lua.Marshaling.Context,
Text.Pandoc.Lua.Marshaling.List, Text.Pandoc.Lua.Marshaling.List,
Text.Pandoc.Lua.Marshaling.MediaBag,
Text.Pandoc.Lua.Marshaling.PandocError, Text.Pandoc.Lua.Marshaling.PandocError,
Text.Pandoc.Lua.Marshaling.ReaderOptions, Text.Pandoc.Lua.Marshaling.ReaderOptions,
Text.Pandoc.Lua.Marshaling.SimpleTable, Text.Pandoc.Lua.Marshaling.SimpleTable,
@ -847,14 +846,14 @@ test-suite test-pandoc
doctemplates >= 0.10 && < 0.11, doctemplates >= 0.10 && < 0.11,
exceptions >= 0.8 && < 0.11, exceptions >= 0.8 && < 0.11,
filepath >= 1.1 && < 1.5, filepath >= 1.1 && < 1.5,
hslua >= 1.1 && < 1.4, hslua >= 2.0 && < 2.1,
mtl >= 2.2 && < 2.3, mtl >= 2.2 && < 2.3,
pandoc-types >= 1.22 && < 1.23, pandoc-types >= 1.22 && < 1.23,
process >= 1.2.3 && < 1.7, process >= 1.2.3 && < 1.7,
tasty >= 0.11 && < 1.5, tasty >= 0.11 && < 1.5,
tasty-golden >= 2.3 && < 2.4, tasty-golden >= 2.3 && < 2.4,
tasty-hunit >= 0.9 && < 0.11, tasty-hunit >= 0.9 && < 0.11,
tasty-lua >= 0.2 && < 0.3, tasty-lua >= 1.0 && < 1.1,
tasty-quickcheck >= 0.8 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11,
text >= 1.1.1.0 && < 1.3, text >= 1.1.1.0 && < 1.3,
time >= 1.5 && < 1.13, 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 LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- | {- |
Module : Text.Pandoc.Lua.ErrorConversion Module : Text.Pandoc.Lua.ErrorConversion
Copyright : © 2020-2021 Albert Krewinkel Copyright : © 2020-2021 Albert Krewinkel
@ -13,49 +12,37 @@ Define how Lua errors are converted into @'PandocError'@ Haskell
exceptions, and /vice versa/. exceptions, and /vice versa/.
-} -}
module Text.Pandoc.Lua.ErrorConversion module Text.Pandoc.Lua.ErrorConversion
( errorConversion ( addContextToException
) where ) 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.Error (PandocError (PandocLuaError))
import Text.Pandoc.Lua.Marshaling.PandocError (pushPandocError, peekPandocError) import Text.Pandoc.Lua.Marshaling.PandocError (pushPandocError, peekPandocError)
import qualified Control.Monad.Catch as Catch
import qualified Data.Text as T 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 addContextToException :: ()
-- that all exceptions are of type @'PandocError'@. addContextToException = undefined
errorConversion :: Lua.ErrorConversion
errorConversion = Lua.ErrorConversion
{ Lua.addContextToException = addContextToException
, Lua.alternative = alternative
, Lua.errorToException = errorToException
, Lua.exceptionToError = exceptionToError
}
-- | Convert a Lua error, which must be at the top of the stack, into a -- | Retrieve a @'PandocError'@ from the Lua stack.
-- @'PandocError'@, popping the value from the stack. popPandocError :: LuaE PandocError PandocError
errorToException :: forall a . Lua.State -> IO a popPandocError = do
errorToException l = Lua.unsafeRunWith l $ do errResult <- runPeek $ peekPandocError top
err <- peekPandocError Lua.stackTop case resultToEither errResult of
Lua.pop 1 Right x -> return x
Catch.throwM err Left err -> return $ PandocLuaError (T.pack err)
-- | Try the first op -- if it doesn't succeed, run the second. -- Ensure conversions between Lua errors and 'PandocError' exceptions
alternative :: forall a . Lua a -> Lua a -> Lua a -- are possible.
alternative x y = Catch.try x >>= \case instance LuaError PandocError where
Left (_ :: PandocError) -> y popException = popPandocError
Right x' -> return x' pushException = pushPandocError
luaException = PandocLuaError . T.pack
-- | Add more context to an error instance PeekError PandocError where
addContextToException :: forall a . String -> Lua a -> Lua a messageFromException = \case
addContextToException ctx op = op `Catch.catch` \case PandocLuaError m -> T.unpack m
PandocLuaError msg -> Catch.throwM $ PandocLuaError (T.pack ctx <> msg) err -> show err
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

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

@ -1,4 +1,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- | {- |
Module : Text.Pandoc.Lua.Filter Module : Text.Pandoc.Lua.Filter
Copyright : © 2012-2021 John MacFarlane, Copyright : © 2012-2021 John MacFarlane,
@ -19,43 +22,42 @@ module Text.Pandoc.Lua.Filter ( LuaFilterFunction
, module Text.Pandoc.Lua.Walk , module Text.Pandoc.Lua.Walk
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad (mplus, (>=>)) import Control.Monad (mplus, (>=>), (<$!>))
import Control.Monad.Catch (finally, try)
import Data.Data (Data, DataType, dataTypeConstrs, dataTypeName, dataTypeOf, import Data.Data (Data, DataType, dataTypeConstrs, dataTypeName, dataTypeOf,
showConstr, toConstr, tyconUQname) showConstr, toConstr, tyconUQname)
import Data.Foldable (foldrM) import Data.Foldable (foldrM)
import Data.List (foldl') import Data.List (foldl')
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (fromMaybe) import Data.String (IsString (fromString))
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) import HsLua as Lua
import Text.Pandoc.Definition import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError) import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling () 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.Lua.Walk (SingletonsList (..))
import Text.Pandoc.Walk (Walkable (walkM)) import Text.Pandoc.Walk (Walkable (walkM))
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil import qualified Text.Pandoc.Lua.Util as LuaUtil
-- | Transform document using the filter defined in the given file. -- | 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 runFilterFile filterPath doc = do
top <- Lua.gettop oldtop <- Lua.gettop
stat <- LuaUtil.dofileWithTraceback filterPath stat <- LuaUtil.dofileWithTraceback filterPath
if stat /= Lua.OK if stat /= Lua.OK
then Lua.throwTopMessage then Lua.throwErrorAsException
else do else do
newtop <- Lua.gettop newtop <- Lua.gettop
-- Use the returned filters, or the implicitly defined global -- Use the returned filters, or the implicitly defined global
-- filter if nothing was returned. -- filter if nothing was returned.
luaFilters <- if newtop - top >= 1 luaFilters <- if newtop - oldtop >= 1
then Lua.peek Lua.stackTop then Lua.peek Lua.top
else Lua.pushglobaltable *> fmap (:[]) Lua.popValue else Lua.pushglobaltable *> fmap (:[]) Lua.popValue
runAll luaFilters doc runAll luaFilters doc
runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc runAll :: [LuaFilter] -> Pandoc -> LuaE PandocError Pandoc
runAll = foldr ((>=>) . walkMWithLuaFilter) return runAll = foldr ((>=>) . walkMWithLuaFilter) return
-- | Filter function stored in the registry -- | 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 -- | Collection of filter functions (at most one function per element
-- constructor) -- constructor)
newtype LuaFilter = LuaFilter (Map String LuaFilterFunction) newtype LuaFilter = LuaFilter (Map Name LuaFilterFunction)
instance Peekable LuaFilter where instance Peekable LuaFilter where
peek idx = do peek idx = do
@ -79,19 +81,19 @@ instance Peekable LuaFilter where
return $ case filterFn of return $ case filterFn of
Nothing -> acc Nothing -> acc
Just fn -> Map.insert constr fn 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 -- | Register the function at the top of the stack as a filter function in the
-- registry. -- registry.
registerFilterFunction :: Lua (Maybe LuaFilterFunction) registerFilterFunction :: LuaError e => LuaE e (Maybe LuaFilterFunction)
registerFilterFunction = do registerFilterFunction = do
isFn <- Lua.isfunction Lua.stackTop isFn <- Lua.isfunction Lua.top
if isFn if isFn
then Just . LuaFilterFunction <$> Lua.ref Lua.registryindex then Just . LuaFilterFunction <$> Lua.ref Lua.registryindex
else Nothing <$ Lua.pop 1 else Nothing <$ Lua.pop 1
-- | Retrieve filter function from registry and push it to the top of the stack. -- | Retrieve filter function from registry and push it to the top of the stack.
pushFilterFunction :: LuaFilterFunction -> Lua () pushFilterFunction :: LuaFilterFunction -> LuaE PandocError ()
pushFilterFunction (LuaFilterFunction fnRef) = pushFilterFunction (LuaFilterFunction fnRef) =
Lua.getref Lua.registryindex 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 -- 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 -- of the stack is nil, return the default element that was passed to this
-- function. If none of these apply, raise an error. -- function. If none of these apply, raise an error.
elementOrList :: Peekable a => a -> Lua [a] elementOrList :: Peeker PandocError a -> a -> LuaE PandocError [a]
elementOrList x = do elementOrList p x = do
let topOfStack = Lua.stackTop elementUnchanged <- Lua.isnil top
elementUnchanged <- Lua.isnil topOfStack
if elementUnchanged if elementUnchanged
then [x] <$ Lua.pop 1 then [x] <$ pop 1
else do else forcePeek . (`lastly` pop 1) $ (((:[]) <$!> p top) <|> peekList p top)
mbres <- peekEither topOfStack
case mbres of -- | Fetches a single element; returns the fallback if the value is @nil@.
Right res -> [res] <$ Lua.pop 1 singleElement :: forall a e. (LuaError e) => Peeker e a -> a -> LuaE e a
Left _ -> Lua.peekList topOfStack `finally` Lua.pop 1 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 -- | Pop and return a value from the stack; if the value at the top of
-- the stack is @nil@, return the fallback element. -- the stack is @nil@, return the fallback element.
popOption :: Peekable a => a -> Lua a popOption :: Peeker PandocError a -> a -> LuaE PandocError a
popOption fallback = fromMaybe fallback . Lua.fromOptional <$> Lua.popValue popOption peeker fallback = forcePeek . (`lastly` pop 1) $
(fallback <$ peekNil top) <|> peeker top
-- | Apply filter on a sequence of AST elements. Both lists and single -- | Apply filter on a sequence of AST elements. Both lists and single
-- value are accepted as filter function return values. -- value are accepted as filter function return values.
runOnSequence :: (Data a, Peekable a, Pushable a) runOnSequence :: forall a. (Data a, Pushable a)
=> LuaFilter -> SingletonsList a -> Lua (SingletonsList a) => Peeker PandocError a -> LuaFilter -> SingletonsList a
runOnSequence (LuaFilter fnMap) (SingletonsList xs) = -> LuaE PandocError (SingletonsList a)
runOnSequence peeker (LuaFilter fnMap) (SingletonsList xs) =
SingletonsList <$> mconcatMapM tryFilter xs SingletonsList <$> mconcatMapM tryFilter xs
where where
tryFilter :: (Data a, Peekable a, Pushable a) => a -> Lua [a] tryFilter :: a -> LuaE PandocError [a]
tryFilter x = tryFilter x =
let filterFnName = showConstr (toConstr x) let filterFnName = fromString $ showConstr (toConstr x)
catchAllName = tyconUQname $ dataTypeName (dataTypeOf x) catchAllName = fromString . tyconUQname $ dataTypeName (dataTypeOf x)
in case Map.lookup filterFnName fnMap <|> Map.lookup catchAllName fnMap of 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] Nothing -> return [x]
-- | Try filtering the given value without type error corrections on -- | Try filtering the given value without type error corrections on
-- the return value. -- the return value.
runOnValue :: (Data a, Peekable a, Pushable a) runOnValue :: (Data a, Pushable a)
=> String -> LuaFilter -> a -> Lua a => Name -> Peeker PandocError a
runOnValue filterFnName (LuaFilter fnMap) x = -> LuaFilter -> a
-> LuaE PandocError a
runOnValue filterFnName peeker (LuaFilter fnMap) x =
case Map.lookup filterFnName fnMap of case Map.lookup filterFnName fnMap of
Just fn -> runFilterFunction fn x *> popOption x Just fn -> runFilterFunction fn x *> popOption peeker x
Nothing -> return x Nothing -> return x
-- | Push a value to the stack via a lua filter function. The filter function is -- | Push a value to the stack via a Lua filter function. The filter
-- called with given element as argument and is expected to return an element. -- function is called with the given element as argument and is expected
-- Alternatively, the function can return nothing or nil, in which case the -- to return an element. Alternatively, the function can return nothing
-- element is left unchanged. -- or nil, in which case the element is left unchanged.
runFilterFunction :: Pushable a => LuaFilterFunction -> a -> Lua () runFilterFunction :: Pushable a
=> LuaFilterFunction -> a -> LuaE PandocError ()
runFilterFunction lf x = do runFilterFunction lf x = do
pushFilterFunction lf pushFilterFunction lf
Lua.push x Lua.push x
LuaUtil.callWithTraceback 1 1 LuaUtil.callWithTraceback 1 1
walkMWithLuaFilter :: LuaFilter -> Pandoc -> Lua Pandoc walkMWithLuaFilter :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc
walkMWithLuaFilter f = walkMWithLuaFilter f =
walkInlines f walkInlines f
>=> walkInlineLists f >=> walkInlineLists f
@ -162,92 +172,76 @@ walkMWithLuaFilter f =
mconcatMapM :: (Monad m) => (a -> m [a]) -> [a] -> m [a] mconcatMapM :: (Monad m) => (a -> m [a]) -> [a] -> m [a]
mconcatMapM f = fmap mconcat . mapM f mconcatMapM f = fmap mconcat . mapM f
hasOneOf :: LuaFilter -> [String] -> Bool hasOneOf :: LuaFilter -> [Name] -> Bool
hasOneOf (LuaFilter fnMap) = any (`Map.member` fnMap) hasOneOf (LuaFilter fnMap) = any (`Map.member` fnMap)
contains :: LuaFilter -> String -> Bool contains :: LuaFilter -> Name -> Bool
contains (LuaFilter fnMap) = (`Map.member` fnMap) 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 = walkInlines lf =
let f :: SingletonsList Inline -> Lua (SingletonsList Inline) let f :: SingletonsList Inline -> LuaE PandocError (SingletonsList Inline)
f = runOnSequence lf f = runOnSequence peekInline lf
in if lf `hasOneOf` inlineElementNames in if lf `hasOneOf` inlineElementNames
then walkM f then walkM f
else return else return
walkInlineLists :: Walkable (List Inline) a => LuaFilter -> a -> Lua a walkInlineLists :: Walkable (List Inline) a
=> LuaFilter -> a -> LuaE PandocError a
walkInlineLists lf = walkInlineLists lf =
let f :: List Inline -> Lua (List Inline) let f :: List Inline -> LuaE PandocError (List Inline)
f = runOnValue listOfInlinesFilterName lf f = runOnValue listOfInlinesFilterName (peekList' peekInline) lf
in if lf `contains` listOfInlinesFilterName in if lf `contains` listOfInlinesFilterName
then walkM f then walkM f
else return else return
walkBlocks :: Walkable (SingletonsList Block) a => LuaFilter -> a -> Lua a walkBlocks :: Walkable (SingletonsList Block) a
=> LuaFilter -> a -> LuaE PandocError a
walkBlocks lf = walkBlocks lf =
let f :: SingletonsList Block -> Lua (SingletonsList Block) let f :: SingletonsList Block -> LuaE PandocError (SingletonsList Block)
f = runOnSequence lf f = runOnSequence peekBlock lf
in if lf `hasOneOf` blockElementNames in if lf `hasOneOf` blockElementNames
then walkM f then walkM f
else return else return
walkBlockLists :: Walkable (List Block) a => LuaFilter -> a -> Lua a walkBlockLists :: Walkable (List Block) a
=> LuaFilter -> a -> LuaE PandocError a
walkBlockLists lf = walkBlockLists lf =
let f :: List Block -> Lua (List Block) let f :: List Block -> LuaE PandocError (List Block)
f = runOnValue listOfBlocksFilterName lf f = runOnValue listOfBlocksFilterName (peekList' peekBlock) lf
in if lf `contains` listOfBlocksFilterName in if lf `contains` listOfBlocksFilterName
then walkM f then walkM f
else return else return
walkMeta :: LuaFilter -> Pandoc -> Lua Pandoc walkMeta :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc
walkMeta lf (Pandoc m bs) = do walkMeta lf (Pandoc m bs) = do
m' <- runOnValue "Meta" lf m m' <- runOnValue "Meta" peekMeta lf m
return $ Pandoc m' bs return $ Pandoc m' bs
walkPandoc :: LuaFilter -> Pandoc -> Lua Pandoc walkPandoc :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc
walkPandoc (LuaFilter fnMap) = walkPandoc (LuaFilter fnMap) =
case foldl' mplus Nothing (map (`Map.lookup` fnMap) pandocFilterNames) of 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 Nothing -> return
constructorsFor :: DataType -> [String] constructorsFor :: DataType -> [Name]
constructorsFor x = map show (dataTypeConstrs x) constructorsFor x = map (fromString . show) (dataTypeConstrs x)
inlineElementNames :: [String] inlineElementNames :: [Name]
inlineElementNames = "Inline" : constructorsFor (dataTypeOf (Str mempty)) inlineElementNames = "Inline" : constructorsFor (dataTypeOf (Str mempty))
blockElementNames :: [String] blockElementNames :: [Name]
blockElementNames = "Block" : constructorsFor (dataTypeOf (Para [])) blockElementNames = "Block" : constructorsFor (dataTypeOf (Para []))
listOfInlinesFilterName :: String listOfInlinesFilterName :: Name
listOfInlinesFilterName = "Inlines" listOfInlinesFilterName = "Inlines"
listOfBlocksFilterName :: String listOfBlocksFilterName :: Name
listOfBlocksFilterName = "Blocks" listOfBlocksFilterName = "Blocks"
metaFilterName :: String metaFilterName :: Name
metaFilterName = "Meta" metaFilterName = "Meta"
pandocFilterNames :: [String] pandocFilterNames :: [Name]
pandocFilterNames = ["Pandoc", "Doc"] 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 Module : Text.Pandoc.Lua
Copyright : Copyright © 2017-2021 Albert Krewinkel Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -14,19 +14,17 @@ module Text.Pandoc.Lua.Global
, setGlobals , setGlobals
) where ) where
import Data.Data (Data) import HsLua as Lua
import Foreign.Lua (Lua, Peekable, Pushable)
import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable
, metatableName)
import Paths_pandoc (version) import Paths_pandoc (version)
import Text.Pandoc.Class.CommonState (CommonState) import Text.Pandoc.Class.CommonState (CommonState)
import Text.Pandoc.Definition (Pandoc (Pandoc), pandocTypesVersion) import Text.Pandoc.Definition (Pandoc (Pandoc), pandocTypesVersion)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling () 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 Text.Pandoc.Options (ReaderOptions)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Foreign.Lua as Lua
-- | Permissible global Lua variables. -- | Permissible global Lua variables.
data Global = data Global =
@ -40,10 +38,10 @@ data Global =
-- Cannot derive instance of Data because of CommonState -- Cannot derive instance of Data because of CommonState
-- | Set all given globals. -- | Set all given globals.
setGlobals :: [Global] -> Lua () setGlobals :: [Global] -> LuaE PandocError ()
setGlobals = mapM_ setGlobal setGlobals = mapM_ setGlobal
setGlobal :: Global -> Lua () setGlobal :: Global -> LuaE PandocError ()
setGlobal global = case global of setGlobal global = case global of
-- This could be simplified if Global was an instance of Data. -- This could be simplified if Global was an instance of Data.
FORMAT format -> do FORMAT format -> do
@ -53,37 +51,24 @@ setGlobal global = case global of
Lua.push pandocTypesVersion Lua.push pandocTypesVersion
Lua.setglobal "PANDOC_API_VERSION" Lua.setglobal "PANDOC_API_VERSION"
PANDOC_DOCUMENT doc -> do PANDOC_DOCUMENT doc -> do
Lua.push (LazyPandoc doc) pushUD typePandocLazy doc
Lua.setglobal "PANDOC_DOCUMENT" Lua.setglobal "PANDOC_DOCUMENT"
PANDOC_READER_OPTIONS ropts -> do PANDOC_READER_OPTIONS ropts -> do
Lua.push ropts pushReaderOptions ropts
Lua.setglobal "PANDOC_READER_OPTIONS" Lua.setglobal "PANDOC_READER_OPTIONS"
PANDOC_SCRIPT_FILE filePath -> do PANDOC_SCRIPT_FILE filePath -> do
Lua.push filePath Lua.push filePath
Lua.setglobal "PANDOC_SCRIPT_FILE" Lua.setglobal "PANDOC_SCRIPT_FILE"
PANDOC_STATE commonState -> do PANDOC_STATE commonState -> do
Lua.push commonState pushCommonState commonState
Lua.setglobal "PANDOC_STATE" Lua.setglobal "PANDOC_STATE"
PANDOC_VERSION -> do PANDOC_VERSION -> do
Lua.push version Lua.push version
Lua.setglobal "PANDOC_VERSION" Lua.setglobal "PANDOC_VERSION"
-- | Readonly and lazy pandoc objects. -- | Readonly and lazy pandoc objects.
newtype LazyPandoc = LazyPandoc Pandoc typePandocLazy :: LuaError e => DocumentedType e Pandoc
deriving (Data) typePandocLazy = deftype "Pandoc (lazy)" []
[ readonly "meta" "document metadata" (push, \(Pandoc meta _) -> meta)
instance Pushable LazyPandoc where , readonly "blocks" "content blocks" (push, \(Pandoc _ blocks) -> blocks)
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

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

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{- | {- |
Module : Text.Pandoc.Lua Module : Text.Pandoc.Lua
Copyright : Copyright © 2017-2021 Albert Krewinkel Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -13,23 +14,23 @@ module Text.Pandoc.Lua.Init
) where ) where
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.Catch (try) import Control.Monad.Catch (throwM, try)
import Control.Monad.Trans (MonadIO (..)) import Control.Monad.Trans (MonadIO (..))
import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) 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 GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8)
import Text.Pandoc.Class.PandocMonad (readDataFile, PandocMonad) import Text.Pandoc.Class.PandocMonad (PandocMonad, readDataFile)
import Text.Pandoc.Error (PandocError) import Text.Pandoc.Error (PandocError (PandocLuaError))
import Text.Pandoc.Lua.Packages (installPandocPackageSearcher) import Text.Pandoc.Lua.Packages (installPandocPackageSearcher)
import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, runPandocLua) import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, runPandocLua)
import Text.Pandoc.Lua.Util (throwTopMessageAsError') import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Definition as Pandoc import qualified Text.Pandoc.Definition as Pandoc
import qualified Text.Pandoc.Lua.Module.Pandoc as ModulePandoc import qualified Text.Pandoc.Lua.Module.Pandoc as ModulePandoc
-- | Run the lua interpreter, using pandoc's default way of environment -- | Run the lua interpreter, using pandoc's default way of environment
-- initialization. -- 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 runLua luaOp = do
enc <- liftIO $ getForeignEncoding <* setForeignEncoding utf8 enc <- liftIO $ getForeignEncoding <* setForeignEncoding utf8
res <- runPandocLua . try $ do res <- runPandocLua . try $ do
@ -52,9 +53,9 @@ initLuaState = do
ModulePandoc.pushModule ModulePandoc.pushModule
-- register as loaded module -- register as loaded module
liftPandocLua $ do liftPandocLua $ do
Lua.pushvalue Lua.stackTop Lua.pushvalue Lua.top
Lua.getfield Lua.registryindex Lua.loadedTableRegistryField Lua.getfield Lua.registryindex Lua.loaded
Lua.setfield (Lua.nthFromTop 2) "pandoc" Lua.setfield (Lua.nth 2) "pandoc"
Lua.pop 1 Lua.pop 1
-- copy constructors into registry -- copy constructors into registry
putConstructorsInRegistry putConstructorsInRegistry
@ -65,10 +66,12 @@ initLuaState = do
loadInitScript scriptFile = do loadInitScript scriptFile = do
script <- readDataFile scriptFile script <- readDataFile scriptFile
status <- liftPandocLua $ Lua.dostring script status <- liftPandocLua $ Lua.dostring script
when (status /= Lua.OK) . liftPandocLua $ when (status /= Lua.OK) . liftPandocLua $ do
throwTopMessageAsError' err <- popException
(("Couldn't load '" ++ scriptFile ++ "'.\n") ++) 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 -- | AST elements are marshaled via normal constructor functions in the
-- @pandoc@ module. However, accessing Lua globals from Haskell is -- @pandoc@ module. However, accessing Lua globals from Haskell is
@ -91,12 +94,12 @@ putConstructorsInRegistry = liftPandocLua $ do
putInReg "List" -- pandoc.List putInReg "List" -- pandoc.List
putInReg "SimpleTable" -- helper for backward-compatible table handling putInReg "SimpleTable" -- helper for backward-compatible table handling
where where
constrsToReg :: Data a => a -> Lua () constrsToReg :: Data a => a -> LuaE PandocError ()
constrsToReg = mapM_ (putInReg . showConstr) . dataTypeConstrs . dataTypeOf constrsToReg = mapM_ (putInReg . showConstr) . dataTypeConstrs . dataTypeOf
putInReg :: String -> Lua () putInReg :: String -> LuaE PandocError ()
putInReg name = do putInReg name = do
Lua.push ("pandoc." ++ name) -- name in registry Lua.push ("pandoc." ++ name) -- name in registry
Lua.push name -- in pandoc module Lua.push name -- in pandoc module
Lua.rawget (Lua.nthFromTop 3) Lua.rawget (Lua.nth 3)
Lua.rawset Lua.registryindex 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.PandocError()
import Text.Pandoc.Lua.Marshaling.ReaderOptions () import Text.Pandoc.Lua.Marshaling.ReaderOptions ()
import Text.Pandoc.Lua.Marshaling.Version () 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 #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- | {- |
Module : Text.Pandoc.Lua.Marshaling.AST Module : Text.Pandoc.Lua.Marshaling.AST
Copyright : © 2012-2021 John MacFarlane Copyright : © 2012-2021 John MacFarlane
@ -13,223 +15,254 @@
Marshaling/unmarshaling instances for document AST elements. Marshaling/unmarshaling instances for document AST elements.
-} -}
module Text.Pandoc.Lua.Marshaling.AST module Text.Pandoc.Lua.Marshaling.AST
( LuaAttr (..) ( peekAttr
, LuaListAttributes (..) , peekBlock
, peekBlocks
, peekCaption
, peekCitation
, peekInline
, peekInlines
, peekListAttributes
, peekMeta
, peekMetaValue
, peekPandoc
, pushAttr
, pushBlock
, pushInline
, pushListAttributes
, pushMetaValue
, pushPandoc
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>), optional)
import Control.Monad ((<$!>)) import Control.Monad ((<$!>), (>=>))
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) import HsLua hiding (Operation (Div))
import Text.Pandoc.Definition import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError) import Text.Pandoc.Lua.Util (pushViaConstr', pushViaConstructor)
import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor)
import Text.Pandoc.Lua.Marshaling.CommonState () import Text.Pandoc.Lua.Marshaling.CommonState ()
import qualified Control.Monad.Catch as Catch import qualified HsLua as Lua
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil import qualified Text.Pandoc.Lua.Util as LuaUtil
instance Pushable Pandoc where instance Pushable Pandoc where
push (Pandoc meta blocks) = push = pushPandoc
pushViaConstructor "Pandoc" blocks meta
instance Peekable Pandoc where pushPandoc :: LuaError e => Pusher e Pandoc
peek idx = defineHowTo "get Pandoc value" $! Pandoc pushPandoc (Pandoc meta blocks) =
<$!> LuaUtil.rawField idx "meta" pushViaConstr' "Pandoc" [pushList pushBlock blocks, push meta]
<*> LuaUtil.rawField idx "blocks"
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 instance Pushable Meta where
push (Meta mmap) = push (Meta mmap) =
pushViaConstructor "Meta" mmap pushViaConstr' "Meta" [push mmap]
instance Peekable Meta where
peek idx = defineHowTo "get Meta value" $! peekMeta :: LuaError e => Peeker e Meta
Meta <$!> Lua.peek idx peekMeta idx = retrieving "Meta" $
Meta <$!> peekMap peekText peekMetaValue idx
instance Pushable MetaValue where instance Pushable MetaValue where
push = pushMetaValue push = pushMetaValue
instance Peekable MetaValue where
peek = peekMetaValue
instance Pushable Block where instance Pushable Block where
push = pushBlock push = pushBlock
instance Peekable Block where
peek = peekBlock
-- Inline -- Inline
instance Pushable Inline where instance Pushable Inline where
push = pushInline push = pushInline
instance Peekable Inline where
peek = peekInline
-- Citation -- Citation
instance Pushable Citation where instance Pushable Citation where
push (Citation cid prefix suffix mode noteNum hash) = 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 instance Pushable Alignment where
push = Lua.push . show push = Lua.pushString . show
instance Peekable Alignment where
peek = Lua.peekRead
instance Pushable CitationMode where instance Pushable CitationMode where
push = Lua.push . show push = Lua.push . show
instance Peekable CitationMode where
peek = Lua.peekRead
instance Pushable Format where instance Pushable Format where
push (Format f) = Lua.push f 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 instance Pushable ListNumberDelim where
push = Lua.push . show push = Lua.push . show
instance Peekable ListNumberDelim where
peek = Lua.peekRead
instance Pushable ListNumberStyle where instance Pushable ListNumberStyle where
push = Lua.push . show push = Lua.push . show
instance Peekable ListNumberStyle where
peek = Lua.peekRead
instance Pushable MathType where instance Pushable MathType where
push = Lua.push . show push = Lua.push . show
instance Peekable MathType where
peek = Lua.peekRead
instance Pushable QuoteType where instance Pushable QuoteType where
push = Lua.push . show push = Lua.push . show
instance Peekable QuoteType where
peek = Lua.peekRead
-- | Push an meta value element to the top of the lua stack. -- | Push an meta value element to the top of the lua stack.
pushMetaValue :: MetaValue -> Lua () pushMetaValue :: LuaError e => MetaValue -> LuaE e ()
pushMetaValue = \case pushMetaValue = \case
MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks MetaBlocks blcks -> pushViaConstr' "MetaBlocks" [pushList pushBlock blcks]
MetaBool bool -> Lua.push bool MetaBool bool -> Lua.push bool
MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns MetaInlines inlns -> pushViaConstr' "MetaInlines"
MetaList metalist -> pushViaConstructor "MetaList" metalist [pushList pushInline inlns]
MetaMap metamap -> pushViaConstructor "MetaMap" metamap MetaList metalist -> pushViaConstr' "MetaList"
[pushList pushMetaValue metalist]
MetaMap metamap -> pushViaConstr' "MetaMap"
[pushMap pushText pushMetaValue metamap]
MetaString str -> Lua.push str MetaString str -> Lua.push str
-- | Interpret the value at the given stack index as meta value. -- | Interpret the value at the given stack index as meta value.
peekMetaValue :: StackIndex -> Lua MetaValue peekMetaValue :: forall e. LuaError e => Peeker e MetaValue
peekMetaValue idx = defineHowTo "get MetaValue" $ do peekMetaValue = retrieving "MetaValue $ " . \idx -> do
-- Get the contents of an AST element. -- Get the contents of an AST element.
let elementContent :: Peekable a => Lua a let mkMV :: (a -> MetaValue) -> Peeker e a -> Peek e MetaValue
elementContent = Lua.peek idx mkMV f p = f <$!> p idx
luatype <- Lua.ltype idx
case luatype of peekTagged = \case
Lua.TypeBoolean -> MetaBool <$!> Lua.peek idx "MetaBlocks" -> mkMV MetaBlocks $
Lua.TypeString -> MetaString <$!> Lua.peek idx retrieving "MetaBlocks" . peekBlocks
Lua.TypeTable -> do "MetaBool" -> mkMV MetaBool $
tag <- try $ LuaUtil.getTag idx retrieving "MetaBool" . peekBool
case tag of "MetaMap" -> mkMV MetaMap $
Right "MetaBlocks" -> MetaBlocks <$!> elementContent retrieving "MetaMap" . peekMap peekText peekMetaValue
Right "MetaBool" -> MetaBool <$!> elementContent "MetaInlines" -> mkMV MetaInlines $
Right "MetaMap" -> MetaMap <$!> elementContent retrieving "MetaInlines" . peekInlines
Right "MetaInlines" -> MetaInlines <$!> elementContent "MetaList" -> mkMV MetaList $
Right "MetaList" -> MetaList <$!> elementContent retrieving "MetaList" . peekList peekMetaValue
Right "MetaString" -> MetaString <$!> elementContent "MetaString" -> mkMV MetaString $
Right t -> Lua.throwMessage ("Unknown meta tag: " <> t) retrieving "MetaString" . peekText
Left _ -> do (Name t) -> failPeek ("Unknown meta tag: " <> t)
peekUntagged = do
-- no meta value tag given, try to guess. -- no meta value tag given, try to guess.
len <- Lua.rawlen idx len <- liftLua $ Lua.rawlen idx
if len <= 0 if len <= 0
then MetaMap <$!> Lua.peek idx then MetaMap <$!> peekMap peekText peekMetaValue idx
else (MetaInlines <$!> Lua.peek idx) else (MetaInlines <$!> peekInlines idx)
<|> (MetaBlocks <$!> Lua.peek idx) <|> (MetaBlocks <$!> peekBlocks idx)
<|> (MetaList <$!> Lua.peek idx) <|> (MetaList <$!> peekList peekMetaValue idx)
_ -> Lua.throwMessage "could not get meta value" 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. -- | Push a block element to the top of the Lua stack.
pushBlock :: Block -> Lua () pushBlock :: forall e. LuaError e => Block -> LuaE e ()
pushBlock = \case pushBlock = \case
BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks BlockQuote blcks -> pushViaConstructor @e "BlockQuote" blcks
BulletList items -> pushViaConstructor "BulletList" items BulletList items -> pushViaConstructor @e "BulletList" items
CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr) CodeBlock attr code -> pushViaConstr' @e "CodeBlock"
DefinitionList items -> pushViaConstructor "DefinitionList" items [ push code, pushAttr attr ]
Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr) DefinitionList items -> pushViaConstructor @e "DefinitionList" items
Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr) Div attr blcks -> pushViaConstr' @e "Div"
HorizontalRule -> pushViaConstructor "HorizontalRule" [push blcks, pushAttr attr]
LineBlock blcks -> pushViaConstructor "LineBlock" blcks Header lvl attr inlns -> pushViaConstr' @e "Header"
OrderedList lstAttr list -> pushViaConstructor "OrderedList" list [push lvl, push inlns, pushAttr attr]
(LuaListAttributes lstAttr) HorizontalRule -> pushViaConstructor @e "HorizontalRule"
Null -> pushViaConstructor "Null" LineBlock blcks -> pushViaConstructor @e "LineBlock" blcks
Para blcks -> pushViaConstructor "Para" blcks OrderedList lstAttr list -> pushViaConstr' @e "OrderedList"
Plain blcks -> pushViaConstructor "Plain" blcks [ push list, pushListAttributes @e lstAttr ]
RawBlock f cs -> pushViaConstructor "RawBlock" f cs 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 -> 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. -- | Return the value at the given index as block if possible.
peekBlock :: StackIndex -> Lua Block peekBlock :: forall e. LuaError e => Peeker e Block
peekBlock idx = defineHowTo "get Block value" $! do peekBlock = fmap (retrieving "Block")
tag <- LuaUtil.getTag idx . typeChecked "table" Lua.istable
case tag of $ \idx -> do
"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
-- Get the contents of an AST element. -- Get the contents of an AST element.
elementContent :: Peekable a => Lua a let mkBlock :: (a -> Block) -> Peeker e a -> Peek e Block
elementContent = LuaUtil.rawField idx "c" 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 peekBlocks :: LuaError e => Peeker e [Block]
push = pushCaption peekBlocks = peekList peekBlock
instance Peekable Caption where peekInlines :: LuaError e => Peeker e [Inline]
peek = peekCaption peekInlines = peekList peekInline
-- | Push Caption element -- | Push Caption element
pushCaption :: Caption -> Lua () pushCaption :: LuaError e => Caption -> LuaE e ()
pushCaption (Caption shortCaption longCaption) = do pushCaption (Caption shortCaption longCaption) = do
Lua.newtable Lua.newtable
LuaUtil.addField "short" (Lua.Optional shortCaption) LuaUtil.addField "short" (Lua.Optional shortCaption)
LuaUtil.addField "long" longCaption LuaUtil.addField "long" longCaption
-- | Peek Caption element -- | Peek Caption element
peekCaption :: StackIndex -> Lua Caption peekCaption :: LuaError e => Peeker e Caption
peekCaption idx = Caption peekCaption = retrieving "Caption" . \idx -> do
<$!> (Lua.fromOptional <$!> LuaUtil.rawField idx "short") short <- optional $ peekFieldRaw peekInlines "short" idx
<*> LuaUtil.rawField idx "long" long <- peekFieldRaw peekBlocks "long" idx
return $! Caption short long
instance Peekable ColWidth where peekColWidth :: LuaError e => Peeker e ColWidth
peek idx = do peekColWidth = retrieving "ColWidth" . \idx -> do
width <- Lua.fromOptional <$!> Lua.peek idx maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx)
return $! maybe ColWidthDefault ColWidth width
peekColSpec :: LuaError e => Peeker e ColSpec
peekColSpec = peekPair peekRead peekColWidth
instance Pushable ColWidth where instance Pushable ColWidth where
push = \case push = \case
@ -240,7 +273,12 @@ instance Pushable Row where
push (Row attr cells) = Lua.push (attr, cells) push (Row attr cells) = Lua.push (attr, cells)
instance Peekable Row where 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 instance Pushable TableBody where
push (TableBody attr (RowHeadColumns rowHeadColumns) head' body) = do push (TableBody attr (RowHeadColumns rowHeadColumns) head' body) = do
@ -250,32 +288,38 @@ instance Pushable TableBody where
LuaUtil.addField "head" head' LuaUtil.addField "head" head'
LuaUtil.addField "body" body LuaUtil.addField "body" body
instance Peekable TableBody where peekTableBody :: LuaError e => Peeker e TableBody
peek idx = TableBody peekTableBody = fmap (retrieving "TableBody")
<$!> LuaUtil.rawField idx "attr" . typeChecked "table" Lua.istable
<*> (RowHeadColumns <$!> LuaUtil.rawField idx "row_head_columns") $ \idx -> TableBody
<*> LuaUtil.rawField idx "head" <$!> peekFieldRaw peekAttr "attr" idx
<*> LuaUtil.rawField idx "body" <*> peekFieldRaw ((fmap RowHeadColumns) . peekIntegral) "row_head_columns" idx
<*> peekFieldRaw (peekList peekRow) "head" idx
<*> peekFieldRaw (peekList peekRow) "body" idx
instance Pushable TableHead where instance Pushable TableHead where
push (TableHead attr rows) = Lua.push (attr, rows) push (TableHead attr rows) = Lua.push (attr, rows)
instance Peekable TableHead where peekTableHead :: LuaError e => Peeker e TableHead
peek = fmap (uncurry TableHead) . Lua.peek peekTableHead = ((uncurry TableHead) <$!>)
. retrieving "TableHead"
. peekPair peekAttr (peekList peekRow)
instance Pushable TableFoot where instance Pushable TableFoot where
push (TableFoot attr cells) = Lua.push (attr, cells) push (TableFoot attr cells) = Lua.push (attr, cells)
instance Peekable TableFoot where peekTableFoot :: LuaError e => Peeker e TableFoot
peek = fmap (uncurry TableFoot) . Lua.peek peekTableFoot = ((uncurry TableFoot) <$!>)
. retrieving "TableFoot"
. peekPair peekAttr (peekList peekRow)
instance Pushable Cell where instance Pushable Cell where
push = pushCell push = pushCell
instance Peekable Cell where 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 pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do
Lua.newtable Lua.newtable
LuaUtil.addField "attr" attr 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 "col_span" colSpan
LuaUtil.addField "contents" contents LuaUtil.addField "contents" contents
peekCell :: StackIndex -> Lua Cell peekCell :: LuaError e => Peeker e Cell
peekCell idx = Cell peekCell = fmap (retrieving "Cell")
<$!> (fromLuaAttr <$!> LuaUtil.rawField idx "attr") . typeChecked "table" Lua.istable
<*> LuaUtil.rawField idx "alignment" $ \idx -> do
<*> (RowSpan <$!> LuaUtil.rawField idx "row_span") attr <- peekFieldRaw peekAttr "attr" idx
<*> (ColSpan <$!> LuaUtil.rawField idx "col_span") algn <- peekFieldRaw peekRead "alignment" idx
<*> LuaUtil.rawField idx "contents" 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. -- | Push an inline element to the top of the lua stack.
pushInline :: Inline -> Lua () pushInline :: forall e. LuaError e => Inline -> LuaE e ()
pushInline = \case pushInline = \case
Cite citations lst -> pushViaConstructor "Cite" lst citations Cite citations lst -> pushViaConstructor @e "Cite" lst citations
Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr) Code attr lst -> pushViaConstr' @e "Code"
Emph inlns -> pushViaConstructor "Emph" inlns [push lst, pushAttr attr]
Underline inlns -> pushViaConstructor "Underline" inlns Emph inlns -> pushViaConstructor @e "Emph" inlns
Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr) Underline inlns -> pushViaConstructor @e "Underline" inlns
LineBreak -> pushViaConstructor "LineBreak" Image attr alt (src,tit) -> pushViaConstr' @e "Image"
Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr) [push alt, push src, push tit, pushAttr attr]
Note blcks -> pushViaConstructor "Note" blcks LineBreak -> pushViaConstructor @e "LineBreak"
Math mty str -> pushViaConstructor "Math" mty str Link attr lst (src,tit) -> pushViaConstr' @e "Link"
Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns [push lst, push src, push tit, pushAttr attr]
RawInline f cs -> pushViaConstructor "RawInline" f cs Note blcks -> pushViaConstructor @e "Note" blcks
SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns Math mty str -> pushViaConstructor @e "Math" mty str
SoftBreak -> pushViaConstructor "SoftBreak" Quoted qt inlns -> pushViaConstructor @e "Quoted" qt inlns
Space -> pushViaConstructor "Space" RawInline f cs -> pushViaConstructor @e "RawInline" f cs
Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr) SmallCaps inlns -> pushViaConstructor @e "SmallCaps" inlns
Str str -> pushViaConstructor "Str" str SoftBreak -> pushViaConstructor @e "SoftBreak"
Strikeout inlns -> pushViaConstructor "Strikeout" inlns Space -> pushViaConstructor @e "Space"
Strong inlns -> pushViaConstructor "Strong" inlns Span attr inlns -> pushViaConstr' @e "Span"
Subscript inlns -> pushViaConstructor "Subscript" inlns [push inlns, pushAttr attr]
Superscript inlns -> pushViaConstructor "Superscript" inlns 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. -- | Return the value at the given index as inline if possible.
peekInline :: StackIndex -> Lua Inline peekInline :: forall e. LuaError e => Peeker e Inline
peekInline idx = defineHowTo "get Inline value" $ do peekInline = retrieving "Inline" . \idx -> do
tag <- LuaUtil.getTag idx -- Get the contents of an AST element.
case tag of let mkBlock :: (a -> Inline) -> Peeker e a -> Peek e Inline
"Cite" -> uncurry Cite <$!> elementContent mkBlock f p = f <$!> peekFieldRaw p "c" idx
"Code" -> withAttr Code <$!> elementContent LuaUtil.getTag idx >>= \case
"Emph" -> Emph <$!> elementContent "Cite" -> mkBlock (uncurry Cite) $
"Underline" -> Underline <$!> elementContent peekPair (peekList peekCitation) peekInlines
"Image" -> (\(LuaAttr !attr, !lst, !tgt) -> Image attr lst tgt) "Code" -> mkBlock (uncurry Code) (peekPair peekAttr peekText)
<$!> elementContent "Emph" -> mkBlock Emph peekInlines
"Link" -> (\(LuaAttr !attr, !lst, !tgt) -> Link attr lst tgt) "Underline" -> mkBlock Underline peekInlines
<$!> elementContent "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 "LineBreak" -> return LineBreak
"Note" -> Note <$!> elementContent "Note" -> mkBlock Note peekBlocks
"Math" -> uncurry Math <$!> elementContent "Math" -> mkBlock (uncurry Math) (peekPair peekRead peekText)
"Quoted" -> uncurry Quoted <$!> elementContent "Quoted" -> mkBlock (uncurry Quoted) (peekPair peekRead peekInlines)
"RawInline" -> uncurry RawInline <$!> elementContent "RawInline" -> mkBlock (uncurry RawInline) (peekPair peekFormat peekText)
"SmallCaps" -> SmallCaps <$!> elementContent "SmallCaps" -> mkBlock SmallCaps peekInlines
"SoftBreak" -> return SoftBreak "SoftBreak" -> return SoftBreak
"Space" -> return Space "Space" -> return Space
"Span" -> withAttr Span <$!> elementContent "Span" -> mkBlock (uncurry Span) (peekPair peekAttr peekInlines)
-- strict to Lua string is copied before gc "Str" -> mkBlock Str peekText
"Str" -> Str <$!> elementContent "Strikeout" -> mkBlock Strikeout peekInlines
"Strikeout" -> Strikeout <$!> elementContent "Strong" -> mkBlock Strong peekInlines
"Strong" -> Strong <$!> elementContent "Subscript" -> mkBlock Subscript peekInlines
"Subscript" -> Subscript <$!> elementContent "Superscript"-> mkBlock Superscript peekInlines
"Superscript"-> Superscript <$!> elementContent Name tag -> Lua.failPeek ("Unknown inline type: " <> tag)
_ -> Lua.throwMessage ("Unknown inline type: " <> tag)
where
-- Get the contents of an AST element.
elementContent :: Peekable a => Lua a
elementContent = LuaUtil.rawField idx "c"
try :: Lua a -> Lua (Either PandocError a) pushAttr :: forall e. LuaError e => Attr -> LuaE e ()
try = Catch.try pushAttr (id', classes, kv) = pushViaConstr' @e "Attr"
[ pushText id'
, pushList pushText classes
, pushList (pushPair pushText pushText) kv
]
withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b peekAttr :: LuaError e => Peeker e Attr
withAttr f (attributes, x) = f (fromLuaAttr attributes) x peekAttr = retrieving "Attr" . peekTriple
peekText
(peekList peekText)
(peekList (peekPair peekText peekText))
-- | Wrapper for Attr pushListAttributes :: forall e. LuaError e => ListAttributes -> LuaE e ()
newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr } pushListAttributes (start, style, delimiter) =
pushViaConstr' "ListAttributes"
[ push start, push style, push delimiter ]
instance Pushable LuaAttr where peekListAttributes :: LuaError e => Peeker e ListAttributes
push (LuaAttr (id', classes, kv)) = peekListAttributes = retrieving "ListAttributes" . peekTriple
pushViaConstructor "Attr" id' classes kv peekIntegral
peekRead
peekRead
instance Peekable LuaAttr where -- These instances exist only for testing. It's a hack to avoid making
peek idx = defineHowTo "get Attr value" $! (LuaAttr <$!> Lua.peek idx) -- the marshalling modules public.
instance Peekable Inline where
peek = forcePeek . peekInline
-- | Wrapper for ListAttributes instance Peekable Block where
newtype LuaListAttributes = LuaListAttributes ListAttributes peek = forcePeek . peekBlock
instance Pushable LuaListAttributes where instance Peekable Meta where
push (LuaListAttributes (start, style, delimiter)) = peek = forcePeek . peekMeta
pushViaConstructor "ListAttributes" start style delimiter
instance Peekable LuaListAttributes where instance Peekable Pandoc where
peek = defineHowTo "get ListAttributes value" . peek = forcePeek . peekPandoc
fmap LuaListAttributes . Lua.peek

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

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

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{- | {- |
Module : Text.Pandoc.Lua.Marshaling.List Module : Text.Pandoc.Lua.Marshaling.List
@ -14,27 +15,30 @@ Marshaling/unmarshaling instances for @pandoc.List@s.
-} -}
module Text.Pandoc.Lua.Marshaling.List module Text.Pandoc.Lua.Marshaling.List
( List (..) ( List (..)
, peekList'
, pushPandocList
) where ) where
import Control.Monad ((<$!>))
import Data.Data (Data) 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.Walk (Walkable (..))
import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) import Text.Pandoc.Lua.Util (pushViaConstr')
import qualified Foreign.Lua as Lua
-- | List wrapper which is marshalled as @pandoc.List@. -- | List wrapper which is marshalled as @pandoc.List@.
newtype List a = List { fromList :: [a] } newtype List a = List { fromList :: [a] }
deriving (Data, Eq, Show) deriving (Data, Eq, Show)
instance Pushable a => Pushable (List a) where instance Pushable a => Pushable (List a) where
push (List xs) = push (List xs) = pushPandocList push xs
pushViaConstructor "List" xs
instance Peekable a => Peekable (List a) where -- | Pushes a list as a numerical Lua table, setting a metatable that offers a
peek idx = defineHowTo "get List" $ do -- number of convenience functions.
xs <- Lua.peek idx pushPandocList :: LuaError e => Pusher e a -> Pusher e [a]
return $ List xs 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 -- List is just a wrapper, so we can reuse the walk instance for
-- unwrapped Hasekll lists. -- 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 LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- | {- |
Module : Text.Pandoc.Lua.Marshaling.PandocError Module : Text.Pandoc.Lua.Marshaling.PandocError
Copyright : © 2020-2021 Albert Krewinkel Copyright : © 2020-2021 Albert Krewinkel
@ -15,51 +15,37 @@ Marshaling of @'PandocError'@ values.
module Text.Pandoc.Lua.Marshaling.PandocError module Text.Pandoc.Lua.Marshaling.PandocError
( peekPandocError ( peekPandocError
, pushPandocError , pushPandocError
, typePandocError
) )
where 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 Text.Pandoc.Error (PandocError (PandocLuaError))
import qualified Foreign.Lua as Lua import qualified HsLua as Lua
import qualified Foreign.Lua.Userdata as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
import qualified Text.Pandoc.UTF8 as UTF8 import qualified Text.Pandoc.UTF8 as UTF8
-- | Userdata name used by Lua for the @PandocError@ type. -- | Lua userdata type definition for PandocError.
pandocErrorName :: String typePandocError :: LuaError e => DocumentedType e PandocError
pandocErrorName = "pandoc error" 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. -- | Peek a @'PandocError'@ element to the Lua stack.
pushPandocError :: PandocError -> Lua () pushPandocError :: LuaError e => Pusher e PandocError
pushPandocError = Lua.pushAnyWithMetatable pushPandocErrorMT pushPandocError = pushUD typePandocError
where
pushPandocErrorMT = Lua.ensureUserdataMetatable pandocErrorName $
LuaUtil.addFunction "__tostring" __tostring
-- | Retrieve a @'PandocError'@ from the Lua stack. -- | Retrieve a @'PandocError'@ from the Lua stack.
peekPandocError :: StackIndex -> Lua PandocError peekPandocError :: LuaError e => Peeker e PandocError
peekPandocError idx = Lua.ltype idx >>= \case peekPandocError idx = Lua.retrieving "PandocError" $
Lua.TypeUserdata -> do liftLua (Lua.ltype idx) >>= \case
errMb <- Lua.toAnyWithName idx pandocErrorName Lua.TypeUserdata -> peekUD typePandocError idx
return $ case errMb of
Just err -> err
Nothing -> PandocLuaError "could not retrieve original error"
_ -> do _ -> do
Lua.pushvalue idx msg <- liftLua $ Lua.state >>= \l -> Lua.liftIO (Lua.popErrorMessage l)
msg <- Lua.state >>= \l -> Lua.liftIO (Lua.errorMessage l)
return $ PandocLuaError (UTF8.toText msg) 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 OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
@ -13,67 +12,60 @@
Marshaling instance for ReaderOptions and its components. 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 HsLua as Lua
import Foreign.Lua (Lua, Pushable) import Text.Pandoc.Lua.Marshaling.List (pushPandocList)
import Text.Pandoc.Extensions (Extensions) import Text.Pandoc.Options (ReaderOptions (..))
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
-- --
-- Reader Options -- Reader Options
-- --
instance Pushable Extensions where
push exts = Lua.push (show exts)
instance Pushable TrackChanges where peekReaderOptions :: LuaError e => Peeker e ReaderOptions
push = Lua.push . showConstr . toConstr peekReaderOptions = peekUD typeReaderOptions
instance Pushable ReaderOptions where pushReaderOptions :: LuaError e => Pusher e ReaderOptions
push ro = do pushReaderOptions = pushUD typeReaderOptions
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
-- add metatable typeReaderOptions :: LuaError e => DocumentedType e ReaderOptions
let indexReaderOptions :: AnyValue -> AnyValue -> Lua Lua.NumResults typeReaderOptions = deftype "pandoc ReaderOptions"
indexReaderOptions _tbl (AnyValue key) = do [ operation Tostring luaShow
Lua.ltype key >>= \case ]
Lua.TypeString -> Lua.peek key >>= \case [ readonly "extensions" ""
("defaultImageExtension" :: Text.Text) ( pushString . show
-> Lua.push defaultImageExtension , readerExtensions)
"indentedCodeClasses" -> Lua.push indentedCodeClasses , readonly "standalone" ""
"stripComments" -> Lua.push stripComments ( pushBool
"tabStop" -> Lua.push tabStop , readerStandalone)
"trackChanges" -> Lua.push trackChanges , readonly "columns" ""
_ -> Lua.pushnil ( pushIntegral
_ -> Lua.pushnil , readerColumns)
return 1 , readonly "tab_stop" ""
Lua.newtable ( pushIntegral
LuaUtil.addFunction "__index" indexReaderOptions , readerTabStop)
Lua.setmetatable (Lua.nthFromTop 2) , 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 Module : Text.Pandoc.Lua.Marshaling.SimpleTable
Copyright : © 2020-2021 Albert Krewinkel Copyright : © 2020-2021 Albert Krewinkel
@ -16,12 +19,11 @@ module Text.Pandoc.Lua.Marshaling.SimpleTable
) )
where where
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) import Control.Monad ((<$!>))
import HsLua as Lua
import Text.Pandoc.Definition import Text.Pandoc.Definition
import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor, rawField) import Text.Pandoc.Lua.Util (pushViaConstructor)
import Text.Pandoc.Lua.Marshaling.AST () import Text.Pandoc.Lua.Marshaling.AST
import qualified Foreign.Lua as Lua
-- | A simple (legacy-style) table. -- | A simple (legacy-style) table.
data SimpleTable = SimpleTable data SimpleTable = SimpleTable
@ -32,16 +34,10 @@ data SimpleTable = SimpleTable
, simpleTableBody :: [[[Block]]] , simpleTableBody :: [[[Block]]]
} }
instance Pushable SimpleTable where
push = pushSimpleTable
instance Peekable SimpleTable where
peek = peekSimpleTable
-- | Push a simple table to the stack by calling the -- | Push a simple table to the stack by calling the
-- @pandoc.SimpleTable@ constructor. -- @pandoc.SimpleTable@ constructor.
pushSimpleTable :: SimpleTable -> Lua () pushSimpleTable :: forall e. LuaError e => SimpleTable -> LuaE e ()
pushSimpleTable tbl = pushViaConstructor "SimpleTable" pushSimpleTable tbl = pushViaConstructor @e "SimpleTable"
(simpleTableCaption tbl) (simpleTableCaption tbl)
(simpleTableAlignments tbl) (simpleTableAlignments tbl)
(simpleTableColumnWidths tbl) (simpleTableColumnWidths tbl)
@ -49,11 +45,10 @@ pushSimpleTable tbl = pushViaConstructor "SimpleTable"
(simpleTableBody tbl) (simpleTableBody tbl)
-- | Retrieve a simple table from the stack. -- | Retrieve a simple table from the stack.
peekSimpleTable :: StackIndex -> Lua SimpleTable peekSimpleTable :: forall e. LuaError e => Peeker e SimpleTable
peekSimpleTable idx = defineHowTo "get SimpleTable" $ peekSimpleTable idx = retrieving "SimpleTable" $ SimpleTable
SimpleTable <$!> peekFieldRaw peekInlines "caption" idx
<$> rawField idx "caption" <*> peekFieldRaw (peekList peekRead) "aligns" idx
<*> rawField idx "aligns" <*> peekFieldRaw (peekList peekRealFloat) "widths" idx
<*> rawField idx "widths" <*> peekFieldRaw (peekList peekBlocks) "headers" idx
<*> rawField idx "headers" <*> peekFieldRaw (peekList (peekList peekBlocks)) "rows" idx
<*> rawField idx "rows"

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 module Text.Pandoc.Lua.Marshaling.Version
( peekVersion ( peekVersion
, pushVersion , pushVersion
, peekVersionFuzzy
) )
where where
import Data.Text (Text)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Version (Version (..), makeVersion, parseVersion, showVersion) import Data.Version (Version (..), makeVersion, parseVersion, showVersion)
import Foreign.Lua (Lua, Optional (..), NumResults, import HsLua as Lua
Peekable, Pushable, StackIndex) import Safe (lastMay)
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 Text.ParserCombinators.ReadP (readP_to_S) import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Text.Pandoc.UTF8 as UTF8
import qualified Foreign.Lua as Lua instance Peekable Version where
import qualified Text.Pandoc.Lua.Util as LuaUtil peek = forcePeek . peekVersionFuzzy
-- | 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 Pushable Version where instance Pushable Version where
push = pushVersion push = pushVersion
peekVersion :: StackIndex -> Lua Version -- | Push a @'Version'@ element to the Lua stack.
peekVersion idx = Lua.ltype idx >>= \case 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 Lua.TypeString -> do
versionStr <- Lua.peek idx versionStr <- peekString idx
let parses = readP_to_S parseVersion versionStr let parses = readP_to_S parseVersion versionStr
case lastMay parses of case lastMay parses of
Just (v, "") -> return v 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 Lua.TypeNumber -> do
n <- Lua.peek idx (makeVersion . (:[])) <$> peekIntegral idx
return (makeVersion [n])
Lua.TypeTable -> 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 peekVersion :: LuaError e => Peeker e Version
peek = peekVersion peekVersion = peekUD typeVersion
-- | Name used by Lua for the @CommonState@ type. typeVersion :: LuaError e => DocumentedType e Version
versionTypeName :: String typeVersion = deftype "Version"
versionTypeName = "HsLua Version" [ operation Eq $ defun "__eq"
### liftPure2 (==)
__eq :: Version -> Version -> Lua Bool <#> parameter peekVersionFuzzy "Version" "v1" ""
__eq v1 v2 = return (v1 == v2) <#> parameter peekVersionFuzzy "Version" "v2" ""
=#> functionResult pushBool "boolean" "true iff v1 == v2"
__le :: Version -> Version -> Lua Bool , operation Lt $ defun "__lt"
__le v1 v2 = return (v1 <= v2) ### liftPure2 (<)
<#> parameter peekVersionFuzzy "Version" "v1" ""
__lt :: Version -> Version -> Lua Bool <#> parameter peekVersionFuzzy "Version" "v2" ""
__lt v1 v2 = return (v1 < v2) =#> functionResult pushBool "boolean" "true iff v1 < v2"
, operation Le $ defun "__le"
-- | Get number of version components. ### liftPure2 (<=)
__len :: Version -> Lua Int <#> parameter peekVersionFuzzy "Version" "v1" ""
__len = return . length . versionBranch <#> parameter peekVersionFuzzy "Version" "v2" ""
=#> functionResult pushBool "boolean" "true iff v1 <= v2"
-- | Access fields. , operation Len $ defun "__len"
__index :: Version -> AnyValue -> Lua NumResults ### liftPure (length . versionBranch)
__index v (AnyValue k) = do <#> parameter peekVersionFuzzy "Version" "v1" ""
ty <- Lua.ltype k =#> functionResult pushIntegral "integer" "number of version components"
case ty of , operation Tostring $ defun "__tostring"
Lua.TypeNumber -> do ### liftPure showVersion
n <- Lua.peek k <#> parameter peekVersionFuzzy "Version" "version" ""
let versionPart = atMay (versionBranch v) (n - 1) =#> functionResult pushString "string" "stringified version"
Lua.push (Lua.Optional versionPart) ]
return 1 [ method $ defun "must_be_at_least"
Lua.TypeString -> do ### must_be_at_least
(str :: Text) <- Lua.peek k <#> parameter peekVersionFuzzy "Version" "self" "version to check"
if str == "must_be_at_least" <#> parameter peekVersionFuzzy "Version" "reference" "minimum version"
then 1 <$ Lua.pushHaskellFunction must_be_at_least <#> optionalParameter peekString "string" "msg" "alternative message"
else 1 <$ Lua.pushnil =?> "Returns no result, and throws an error if this version is older than reference"
_ -> 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"
-- | Throw an error if this version is older than the given version. -- | Throw an error if this version is older than the given version.
-- FIXME: This function currently requires the string library to be -- FIXME: This function currently requires the string library to be
-- loaded. -- loaded.
must_be_at_least :: Version -> Version -> Optional String -> Lua NumResults must_be_at_least :: LuaError e
must_be_at_least actual expected optMsg = do => Version -> Version -> Maybe String
let msg = fromMaybe versionTooOldMessage (fromOptional optMsg) -> LuaE e NumResults
must_be_at_least actual expected mMsg = do
let msg = fromMaybe versionTooOldMessage mMsg
if expected <= actual if expected <= actual
then return 0 then return 0
else do else do
@ -152,3 +111,8 @@ must_be_at_least actual expected optMsg = do
Lua.push (showVersion actual) Lua.push (showVersion actual)
Lua.call 3 1 Lua.call 3 1
Lua.error 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 Prelude hiding (lookup)
import Control.Monad (zipWithM_) 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.CommonState (CommonState (..))
import Text.Pandoc.Class.PandocMonad (fetchItem, getMediaBag, modifyCommonState, import Text.Pandoc.Class.PandocMonad (fetchItem, getMediaBag, modifyCommonState,
setMediaBag) setMediaBag)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Marshaling.MediaBag (pushIterator)
import Text.Pandoc.Lua.PandocLua (PandocLua (..), liftPandocLua, addFunction) import Text.Pandoc.Lua.PandocLua (PandocLua (..), liftPandocLua, addFunction)
import Text.Pandoc.MIME (MimeType) import Text.Pandoc.MIME (MimeType)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
import qualified Foreign.Lua as Lua import qualified HsLua as Lua
import qualified Text.Pandoc.MediaBag as MB 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. -- | Returns iterator values to be used with a Lua @for@ loop.
items :: PandocLua NumResults 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 lookup :: FilePath
-> PandocLua NumResults -> PandocLua NumResults
@ -86,7 +95,7 @@ list = do
zipWithM_ addEntry [1..] dirContents zipWithM_ addEntry [1..] dirContents
return 1 return 1
where where
addEntry :: Lua.Integer -> (FilePath, MimeType, Int) -> Lua () addEntry :: Lua.Integer -> (FilePath, MimeType, Int) -> LuaE PandocError ()
addEntry idx (fp, mimeType, contentLength) = do addEntry idx (fp, mimeType, contentLength) = do
Lua.newtable Lua.newtable
Lua.push ("path" :: T.Text) *> Lua.push fp *> Lua.rawset (-3) 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 ) where
import Prelude hiding (read) import Prelude hiding (read)
import Control.Monad (when) import Control.Monad ((>=>), when)
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Data.Default (Default (..)) import Data.Default (Default (..))
import Data.Maybe (fromMaybe) 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 System.Exit (ExitCode (..))
import Text.Pandoc.Class.PandocIO (runIO) import Text.Pandoc.Class.PandocIO (runIO)
import Text.Pandoc.Definition (Block, Inline) import Text.Pandoc.Definition (Block, Inline)
import Text.Pandoc.Lua.Filter (LuaFilter, SingletonsList (..), walkInlines, import Text.Pandoc.Lua.Filter (SingletonsList (..), walkInlines,
walkInlineLists, walkBlocks, walkBlockLists) walkInlineLists, walkBlocks, walkBlockLists)
import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Lua.Marshaling ()
import Text.Pandoc.Lua.Marshaling.AST
import Text.Pandoc.Lua.Marshaling.List (List (..)) import Text.Pandoc.Lua.Marshaling.List (List (..))
import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua, import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua,
loadDefaultModule) loadDefaultModule)
import Text.Pandoc.Walk (Walkable)
import Text.Pandoc.Options (ReaderOptions (readerExtensions)) import Text.Pandoc.Options (ReaderOptions (readerExtensions))
import Text.Pandoc.Process (pipeProcess) import Text.Pandoc.Process (pipeProcess)
import Text.Pandoc.Readers (Reader (..), getReader) import Text.Pandoc.Readers (Reader (..), getReader)
import Text.Pandoc.Walk (Walkable)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Text as T import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil import qualified Text.Pandoc.Lua.Util as LuaUtil
import Text.Pandoc.Error import Text.Pandoc.Error
@ -48,23 +49,25 @@ pushModule = do
loadDefaultModule "pandoc" loadDefaultModule "pandoc"
addFunction "read" read addFunction "read" read
addFunction "pipe" pipe addFunction "pipe" pipe
addFunction "walk_block" walk_block addFunction "walk_block" (walkElement peekBlock pushBlock)
addFunction "walk_inline" walk_inline addFunction "walk_inline" (walkElement peekInline pushInline)
return 1 return 1
walkElement :: (Walkable (SingletonsList Inline) a, walkElement :: (Walkable (SingletonsList Inline) a,
Walkable (SingletonsList Block) a, Walkable (SingletonsList Block) a,
Walkable (List Inline) a, Walkable (List Inline) a,
Walkable (List Block) a) Walkable (List Block) a)
=> a -> LuaFilter -> PandocLua a => Peeker PandocError a -> Pusher PandocError a
walkElement x f = liftPandocLua $ -> LuaE PandocError NumResults
walkInlines f x >>= walkInlineLists f >>= walkBlocks f >>= walkBlockLists f walkElement peek' push' = do
x <- forcePeek $ peek' (nthBottom 1)
walk_inline :: Inline -> LuaFilter -> PandocLua Inline f <- peek (nthBottom 2)
walk_inline = walkElement let walk' = walkInlines f
>=> walkInlineLists f
walk_block :: Block -> LuaFilter -> PandocLua Block >=> walkBlocks f
walk_block = walkElement >=> walkBlockLists f
walk' x >>= push'
return (NumResults 1)
read :: T.Text -> Optional T.Text -> PandocLua NumResults read :: T.Text -> Optional T.Text -> PandocLua NumResults
read content formatSpecOrNil = liftPandocLua $ do read content formatSpecOrNil = liftPandocLua $ do
@ -93,7 +96,9 @@ pipe command args input = liftPandocLua $ do
(ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input (ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input
case ec of case ec of
ExitSuccess -> 1 <$ Lua.push output 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 data PipeError = PipeError
{ pipeErrorCommand :: T.Text { pipeErrorCommand :: T.Text
@ -101,15 +106,15 @@ data PipeError = PipeError
, pipeErrorOutput :: BL.ByteString , pipeErrorOutput :: BL.ByteString
} }
instance Peekable PipeError where peekPipeError :: PeekError e => StackIndex -> LuaE e PipeError
peek idx = peekPipeError idx =
PipeError PipeError
<$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1) <$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1)
<*> (Lua.getfield idx "error_code" *> 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) <*> (Lua.getfield idx "output" *> Lua.peek (-1) <* Lua.pop 1)
instance Pushable PipeError where pushPipeError :: PeekError e => Pusher e PipeError
push pipeErr = do pushPipeError pipeErr = do
Lua.newtable Lua.newtable
LuaUtil.addField "command" (pipeErrorCommand pipeErr) LuaUtil.addField "command" (pipeErrorCommand pipeErr)
LuaUtil.addField "error_code" (pipeErrorCode pipeErr) LuaUtil.addField "error_code" (pipeErrorCode pipeErr)
@ -117,13 +122,18 @@ instance Pushable PipeError where
pushPipeErrorMetaTable pushPipeErrorMetaTable
Lua.setmetatable (-2) Lua.setmetatable (-2)
where where
pushPipeErrorMetaTable :: Lua () pushPipeErrorMetaTable :: PeekError e => LuaE e ()
pushPipeErrorMetaTable = do pushPipeErrorMetaTable = do
v <- Lua.newmetatable "pandoc pipe error" 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 :: PeekError e => LuaE e NumResults
pipeErrorMessage (PipeError cmd errorCode output) = return $ mconcat pipeErrorMessage = do
(PipeError cmd errorCode output) <- peekPipeError (nthBottom 1)
pushByteString . BSL.toStrict . BSL.concat $
[ BSL.pack "Error running " [ BSL.pack "Error running "
, BSL.pack $ T.unpack cmd , BSL.pack $ T.unpack cmd
, BSL.pack " (error code " , BSL.pack " (error code "
@ -131,3 +141,4 @@ instance Pushable PipeError where
, BSL.pack "): " , BSL.pack "): "
, if output == mempty then BSL.pack "<no output>" else output , 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 Module : Text.Pandoc.Lua.Module.System
Copyright : © 2019-2021 Albert Krewinkel Copyright : © 2019-2021 Albert Krewinkel
@ -12,22 +14,31 @@ module Text.Pandoc.Lua.Module.System
( pushModule ( pushModule
) where ) where
import Foreign.Lua (Lua, NumResults) import HsLua hiding (pushModule)
import Foreign.Lua.Module.System (arch, env, getwd, os, import HsLua.Module.System
with_env, with_tmpdir, with_wd) (arch, env, getwd, os, with_env, with_tmpdir, with_wd)
import Text.Pandoc.Lua.Util (addFunction, addField) 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. -- | Push the pandoc.system module on the Lua stack.
pushModule :: Lua NumResults pushModule :: LuaE PandocError NumResults
pushModule = do pushModule = do
Lua.newtable Lua.pushModule $ Module
addField "arch" arch { moduleName = "system"
addField "os" os , moduleDescription = "system functions"
addFunction "environment" env , moduleFields =
addFunction "get_working_directory" getwd [ arch
addFunction "with_environment" with_env , os
addFunction "with_temporary_directory" with_tmpdir ]
addFunction "with_working_directory" with_wd , 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 return 1

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

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

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

@ -1,5 +1,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- | {- |
Module : Text.Pandoc.Lua.Module.Utils Module : Text.Pandoc.Lua.Module.Utils
Copyright : Copyright © 2017-2021 Albert Krewinkel Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -15,82 +17,137 @@ module Text.Pandoc.Lua.Module.Utils
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad.Catch (try) import Control.Monad ((<$!>))
import Data.Data (showConstr, toConstr) import Data.Data (showConstr, toConstr)
import Data.Default (def) import Data.Default (def)
import Data.Version (Version) 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.Definition
import Text.Pandoc.Error (PandocError) import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Lua.Marshaling () 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 import Text.Pandoc.Lua.Marshaling.SimpleTable
( SimpleTable (..) ( SimpleTable (..), peekSimpleTable, pushSimpleTable )
, pushSimpleTable import Text.Pandoc.Lua.Marshaling.Version (peekVersionFuzzy, pushVersion)
) import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua))
import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua)
import qualified Data.Digest.Pure.SHA as SHA import qualified Data.Digest.Pure.SHA as SHA
import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T 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.Builder as B
import qualified Text.Pandoc.Filter.JSON as JSONFilter import qualified Text.Pandoc.Filter.JSON as JSONFilter
import qualified Text.Pandoc.Shared as Shared import qualified Text.Pandoc.Shared as Shared
import qualified Text.Pandoc.UTF8 as UTF8
import qualified Text.Pandoc.Writers.Shared as Shared import qualified Text.Pandoc.Writers.Shared as Shared
-- | Push the "pandoc.utils" module to the Lua stack. -- | Push the "pandoc.utils" module to the Lua stack.
pushModule :: PandocLua NumResults pandocUtilsModule :: Module PandocError
pushModule = do pandocUtilsModule = Module
liftPandocLua Lua.newtable { moduleName = "pandoc.utils"
addFunction "blocks_to_inlines" blocksToInlines , moduleDescription = "pandoc utility functions"
addFunction "equals" equals , moduleFields = []
addFunction "from_simple_table" from_simple_table , moduleOperations = []
addFunction "make_sections" makeSections , moduleFunctions =
addFunction "normalize_date" normalizeDate [ defun "blocks_to_inlines"
addFunction "run_json_filter" runJSONFilter ### (\blks mSep -> do
addFunction "sha1" sha1 let sep = maybe Shared.defaultBlocksSeparator B.fromList mSep
addFunction "stringify" stringify return $ B.toList (Shared.blocksToInlinesWithSep sep blks))
addFunction "to_roman_numeral" toRomanNumeral <#> parameter (peekList peekBlock) "list of blocks"
addFunction "to_simple_table" to_simple_table "blocks" ""
addFunction "Version" (return :: Version -> Lua Version) <#> optionalParameter (peekList peekInline) "list of inlines"
return 1 "inline" ""
=#> functionResult (pushPandocList pushInline) "list of inlines" ""
-- | Squashes a list of blocks into inlines. , defun "equals"
blocksToInlines :: [Block] -> Lua.Optional [Inline] -> PandocLua [Inline] ### liftPure2 (==)
blocksToInlines blks optSep = liftPandocLua $ do <#> parameter peekAstElement "AST element" "elem1" ""
let sep = maybe Shared.defaultBlocksSeparator B.fromList <#> parameter peekAstElement "AST element" "elem2" ""
$ Lua.fromOptional optSep =#> functionResult pushBool "boolean" "true iff elem1 == elem2"
return $ B.toList (Shared.blocksToInlinesWithSep sep blks)
-- | Convert list of Pandoc blocks into sections using Divs. , defun "make_sections"
makeSections :: Bool -> Lua.Optional Int -> [Block] -> Lua [Block] ### liftPure3 Shared.makeSections
makeSections number baselevel = <#> parameter peekBool "boolean" "numbering" "add header numbers"
return . Shared.makeSections number (Lua.fromOptional baselevel) <#> 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 , defun "normalize_date"
-- limit years to the range 1601-9999 (ISO 8601 accepts greater than ### liftPure Shared.normalizeDate
-- or equal to 1583, but MS Word only accepts dates starting 1601). <#> parameter peekText "string" "date" "the date string"
-- Returns nil instead of a string if the conversion failed. =#> functionResult (maybe pushnil pushText) "string or nil"
normalizeDate :: T.Text -> Lua (Lua.Optional T.Text) "normalized date, or nil if normalization failed."
normalizeDate = return . Lua.Optional . Shared.normalizeDate #? 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. , defun "sha1"
runJSONFilter :: Pandoc ### liftPure (SHA.showDigest . SHA.sha1)
-> FilePath <#> parameter (fmap BSL.fromStrict . peekByteString) "string"
-> Lua.Optional [String] "input" ""
-> PandocLua Pandoc =#> functionResult pushString "string" "hexadecimal hash value"
runJSONFilter doc filterFile optArgs = do #? "Compute the hash of the given string value."
args <- case Lua.fromOptional optArgs of
Just x -> return x , defun "Version"
Nothing -> liftPandocLua $ do ### 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.getglobal "FORMAT"
(:[]) <$> Lua.popValue (forcePeek ((:[]) <$!> peekString top) <* pop 1)
JSONFilter.apply def args filterFile doc 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. -- | Convert pandoc structure to a string with formatting removed.
-- Footnotes are skipped (since we don't want their contents in link -- Footnotes are skipped (since we don't want their contents in link
@ -111,9 +168,6 @@ stringifyMetaValue mv = case mv of
MetaString s -> s MetaString s -> s
_ -> Shared.stringify mv _ -> Shared.stringify mv
equals :: AstElement -> AstElement -> PandocLua Bool
equals e1 e2 = return (e1 == e2)
data AstElement data AstElement
= PandocElement Pandoc = PandocElement Pandoc
| MetaElement Meta | MetaElement Meta
@ -125,22 +179,19 @@ data AstElement
| CitationElement Citation | CitationElement Citation
deriving (Eq, Show) deriving (Eq, Show)
instance Peekable AstElement where peekAstElement :: PeekError e => Peeker e AstElement
peek idx = do peekAstElement = retrieving "pandoc AST element" . choice
res <- try $ (PandocElement <$> Lua.peek idx) [ (fmap PandocElement . peekPandoc)
<|> (InlineElement <$> Lua.peek idx) , (fmap InlineElement . peekInline)
<|> (BlockElement <$> Lua.peek idx) , (fmap BlockElement . peekBlock)
<|> (AttrElement <$> Lua.peek idx) , (fmap AttrElement . peekAttr)
<|> (ListAttributesElement <$> Lua.peek idx) , (fmap ListAttributesElement . peekListAttributes)
<|> (MetaElement <$> Lua.peek idx) , (fmap MetaElement . peekMeta)
<|> (MetaValueElement <$> Lua.peek idx) , (fmap MetaValueElement . peekMetaValue)
case res of ]
Right x -> return x
Left (_ :: PandocError) -> Lua.throwMessage
"Expected an AST element, but could not parse value as such."
-- | Converts an old/simple table into a normal table block element. -- | 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 from_simple_table (SimpleTable capt aligns widths head' body) = do
Lua.push $ Table Lua.push $ Table
nullAttr nullAttr
@ -159,17 +210,19 @@ from_simple_table (SimpleTable capt aligns widths head' body) = do
toColWidth w = ColWidth w toColWidth w = ColWidth w
-- | Converts a table into an old/simple table. -- | 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 to_simple_table = \case
Table _attr caption specs thead tbodies tfoot -> do Table _attr caption specs thead tbodies tfoot -> do
let (capt, aligns, widths, headers, rows) = let (capt, aligns, widths, headers, rows) =
Shared.toLegacyTable caption specs thead tbodies tfoot Shared.toLegacyTable caption specs thead tbodies tfoot
pushSimpleTable $ SimpleTable capt aligns widths headers rows return $ SimpleTable capt aligns widths headers rows
return (NumResults 1) blk -> Lua.failLua $ mconcat
blk -> [ "Expected Table, got ", showConstr (toConstr blk), "." ]
Lua.throwMessage $
"Expected Table, got " <> showConstr (toConstr blk) <> "."
-- | Convert a number < 4000 to uppercase roman numeral. peekTable :: LuaError e => Peeker e Block
toRomanNumeral :: Lua.Integer -> PandocLua T.Text peekTable idx = peekBlock idx >>= \case
toRomanNumeral = return . Shared.toRomanNumeral . fromIntegral 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 Module : Text.Pandoc.Lua.Packages
Copyright : Copyright © 2017-2021 Albert Krewinkel Copyright : Copyright © 2017-2021 Albert Krewinkel
@ -13,12 +16,13 @@ module Text.Pandoc.Lua.Packages
) where ) where
import Control.Monad (forM_) 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 Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, loadDefaultModule)
import qualified Foreign.Lua as Lua import qualified HsLua as Lua
import qualified Foreign.Lua.Module.Path as Path import qualified HsLua.Module.Path as Path
import qualified Foreign.Lua.Module.Text as Text import qualified HsLua.Module.Text as Text
import qualified Text.Pandoc.Lua.Module.Pandoc as Pandoc import qualified Text.Pandoc.Lua.Module.Pandoc as Pandoc
import qualified Text.Pandoc.Lua.Module.MediaBag as MediaBag import qualified Text.Pandoc.Lua.Module.MediaBag as MediaBag
import qualified Text.Pandoc.Lua.Module.System as System import qualified Text.Pandoc.Lua.Module.System as System
@ -30,8 +34,8 @@ installPandocPackageSearcher :: PandocLua ()
installPandocPackageSearcher = liftPandocLua $ do installPandocPackageSearcher = liftPandocLua $ do
Lua.getglobal' "package.searchers" Lua.getglobal' "package.searchers"
shiftArray shiftArray
Lua.pushHaskellFunction pandocPackageSearcher Lua.pushHaskellFunction $ Lua.toHaskellFunction pandocPackageSearcher
Lua.rawseti (Lua.nthFromTop 2) 1 Lua.rawseti (Lua.nth 2) 1
Lua.pop 1 -- remove 'package.searchers' from stack Lua.pop 1 -- remove 'package.searchers' from stack
where where
shiftArray = forM_ [4, 3, 2, 1] $ \i -> do shiftArray = forM_ [4, 3, 2, 1] $ \i -> do
@ -42,14 +46,16 @@ installPandocPackageSearcher = liftPandocLua $ do
pandocPackageSearcher :: String -> PandocLua NumResults pandocPackageSearcher :: String -> PandocLua NumResults
pandocPackageSearcher pkgName = pandocPackageSearcher pkgName =
case pkgName of case pkgName of
"pandoc" -> pushWrappedHsFun Pandoc.pushModule "pandoc" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Pandoc.pushModule
"pandoc.mediabag" -> pushWrappedHsFun MediaBag.pushModule "pandoc.mediabag" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError MediaBag.pushModule
"pandoc.path" -> pushWrappedHsFun Path.pushModule "pandoc.path" -> pushWrappedHsFun
"pandoc.system" -> pushWrappedHsFun System.pushModule (Lua.NumResults 1 <$ Lua.pushModule @PandocError Path.documentedModule)
"pandoc.types" -> pushWrappedHsFun Types.pushModule "pandoc.system" -> pushWrappedHsFun $ Lua.toHaskellFunction System.pushModule
"pandoc.utils" -> pushWrappedHsFun Utils.pushModule "pandoc.types" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Types.pushModule
"text" -> pushWrappedHsFun Text.pushModule "pandoc.utils" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Utils.pushModule
"pandoc.List" -> pushWrappedHsFun (loadDefaultModule pkgName) "text" -> pushWrappedHsFun
(Lua.NumResults 1 <$ Lua.pushModule @PandocError Text.documentedModule)
"pandoc.List" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError (loadDefaultModule pkgName)
_ -> reportPandocSearcherFailure _ -> reportPandocSearcherFailure
where where
pushWrappedHsFun f = liftPandocLua $ do 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.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Except (MonadError (catchError, throwError)) import Control.Monad.Except (MonadError (catchError, throwError))
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO)
import Foreign.Lua (Lua (..), NumResults, Pushable, ToHaskellFunction) import HsLua as Lua
import Text.Pandoc.Class.PandocMonad (PandocMonad (..), readDefaultDataFile) import Text.Pandoc.Class.PandocMonad (PandocMonad (..), readDefaultDataFile)
import Text.Pandoc.Error (PandocError (PandocLuaError)) import Text.Pandoc.Error (PandocError (PandocLuaError))
import Text.Pandoc.Lua.Global (Global (..), setGlobals) 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 Control.Monad.Catch as Catch
import qualified Data.Text as T import qualified Data.Text as T
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Class.IO as IO import qualified Text.Pandoc.Class.IO as IO
-- | Type providing access to both, pandoc and Lua operations. -- | 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 deriving
( Applicative ( Applicative
, Functor , Functor
@ -53,7 +52,7 @@ newtype PandocLua a = PandocLua { unPandocLua :: Lua a }
) )
-- | Lift a @'Lua'@ operation into the @'PandocLua'@ type. -- | Lift a @'Lua'@ operation into the @'PandocLua'@ type.
liftPandocLua :: Lua a -> PandocLua a liftPandocLua :: LuaE PandocError a -> PandocLua a
liftPandocLua = PandocLua liftPandocLua = PandocLua
-- | Evaluate a @'PandocLua'@ computation, running all contained Lua -- | Evaluate a @'PandocLua'@ computation, running all contained Lua
@ -62,7 +61,7 @@ runPandocLua :: (PandocMonad m, MonadIO m) => PandocLua a -> m a
runPandocLua pLua = do runPandocLua pLua = do
origState <- getCommonState origState <- getCommonState
globals <- defaultGlobals globals <- defaultGlobals
(result, newState) <- liftIO . Lua.run' errorConversion . unPandocLua $ do (result, newState) <- liftIO . Lua.run . unPandocLua $ do
putCommonState origState putCommonState origState
liftPandocLua $ setGlobals globals liftPandocLua $ setGlobals globals
r <- pLua r <- pLua
@ -71,17 +70,17 @@ runPandocLua pLua = do
putCommonState newState putCommonState newState
return result return result
instance {-# OVERLAPPING #-} ToHaskellFunction (PandocLua NumResults) where instance {-# OVERLAPPING #-} Exposable PandocError (PandocLua NumResults) where
toHsFun _narg = unPandocLua partialApply _narg = unPandocLua
instance Pushable a => ToHaskellFunction (PandocLua a) where instance Pushable a => Exposable PandocError (PandocLua a) where
toHsFun _narg x = 1 <$ (unPandocLua x >>= Lua.push) partialApply _narg x = 1 <$ (unPandocLua x >>= Lua.push)
-- | Add a function to the table at the top of the stack, using the given name. -- | 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 addFunction name fn = liftPandocLua $ do
Lua.push name Lua.pushName name
Lua.pushHaskellFunction fn Lua.pushHaskellFunction $ toHaskellFunction fn
Lua.rawset (-3) Lua.rawset (-3)
-- | Load a pure Lua module included with pandoc. Leaves the result on -- | 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 :: String -> PandocLua NumResults
loadDefaultModule name = do loadDefaultModule name = do
script <- readDefaultDataFile (name <> ".lua") script <- readDefaultDataFile (name <> ".lua")
status <- liftPandocLua $ Lua.dostring script result <- liftPandocLua $ Lua.dostring script
if status == Lua.OK if result == Lua.OK
then return (1 :: NumResults) then return (1 :: NumResults)
else do else do
msg <- liftPandocLua Lua.popValue msg <- liftPandocLua Lua.popValue
@ -135,7 +134,7 @@ instance PandocMonad PandocLua where
getCommonState = PandocLua $ do getCommonState = PandocLua $ do
Lua.getglobal "PANDOC_STATE" Lua.getglobal "PANDOC_STATE"
Lua.peek Lua.stackTop forcePeek $ peekCommonState Lua.top
putCommonState = PandocLua . setGlobals . (:[]) . PANDOC_STATE putCommonState = PandocLua . setGlobals . (:[]) . PANDOC_STATE
logOutput = IO.logOutput logOutput = IO.logOutput

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

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

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

@ -1,5 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{- | {- |
Module : Text.Pandoc.Writers.Custom Module : Text.Pandoc.Writers.Custom
Copyright : Copyright (C) 2012-2021 John MacFarlane Copyright : Copyright (C) 2012-2021 John MacFarlane
@ -10,7 +13,7 @@
Portability : portable Portability : portable
Conversion of 'Pandoc' documents to custom markup using Conversion of 'Pandoc' documents to custom markup using
a lua writer. a Lua writer.
-} -}
module Text.Pandoc.Writers.Custom ( writeCustom ) where module Text.Pandoc.Writers.Custom ( writeCustom ) where
import Control.Arrow ((***)) import Control.Arrow ((***))
@ -20,7 +23,8 @@ import Data.List (intersperse)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text (Text, pack) 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 Text.DocLayout (render, literal)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Text.Pandoc.Definition import Text.Pandoc.Definition
@ -31,39 +35,39 @@ import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Writers.Shared import Text.Pandoc.Writers.Shared
import qualified Foreign.Lua as Lua
attrToMap :: Attr -> M.Map T.Text T.Text attrToMap :: Attr -> M.Map T.Text T.Text
attrToMap (id',classes,keyvals) = M.fromList attrToMap (id',classes,keyvals) = M.fromList
$ ("id", id') $ ("id", id')
: ("class", T.unwords classes) : ("class", T.unwords classes)
: keyvals : 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) push (Stringify (Format f)) = Lua.push (T.toLower f)
instance Pushable (Stringify [Inline]) where instance PeekError e => Pushable (Stringify e [Inline]) where
push (Stringify ils) = Lua.push =<< inlineListToCustom ils push (Stringify ils) = Lua.push =<<
changeErrorType ((inlineListToCustom @e) ils)
instance Pushable (Stringify [Block]) where instance PeekError e => Pushable (Stringify e [Block]) where
push (Stringify blks) = Lua.push =<< blockListToCustom blks push (Stringify blks) = Lua.push =<<
changeErrorType ((blockListToCustom @e) blks)
instance Pushable (Stringify MetaValue) where instance PeekError e => Pushable (Stringify e MetaValue) where
push (Stringify (MetaMap m)) = Lua.push (fmap Stringify m) push (Stringify (MetaMap m)) = Lua.push (fmap (Stringify @e) m)
push (Stringify (MetaList xs)) = Lua.push (map Stringify xs) push (Stringify (MetaList xs)) = Lua.push (map (Stringify @e) xs)
push (Stringify (MetaBool x)) = Lua.push x push (Stringify (MetaBool x)) = Lua.push x
push (Stringify (MetaString s)) = Lua.push s push (Stringify (MetaString s)) = Lua.push s
push (Stringify (MetaInlines ils)) = Lua.push (Stringify ils) push (Stringify (MetaInlines ils)) = Lua.push (Stringify @e ils)
push (Stringify (MetaBlocks bs)) = Lua.push (Stringify bs) 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 push (Stringify cit) = do
Lua.createtable 6 0 Lua.createtable 6 0
addField "citationId" $ citationId cit addField "citationId" $ citationId cit
addField "citationPrefix" . Stringify $ citationPrefix cit addField "citationPrefix" . Stringify @e $ citationPrefix cit
addField "citationSuffix" . Stringify $ citationSuffix cit addField "citationSuffix" . Stringify @e $ citationSuffix cit
addField "citationMode" $ show (citationMode cit) addField "citationMode" $ show (citationMode cit)
addField "citationNoteNum" $ citationNoteNum cit addField "citationNoteNum" $ citationNoteNum cit
addField "citationHash" $ citationHash cit addField "citationHash" $ citationHash cit
@ -77,7 +81,7 @@ instance (Pushable a, Pushable b) => Pushable (KeyValue a b) where
Lua.newtable Lua.newtable
Lua.push k Lua.push k
Lua.push v Lua.push v
Lua.rawset (Lua.nthFromTop 3) Lua.rawset (Lua.nth 3)
-- | Convert Pandoc to custom markup. -- | Convert Pandoc to custom markup.
writeCustom :: (PandocMonad m, MonadIO m) 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 -- check for error in lua script (later we'll change the return type
-- to handle this more gracefully): -- to handle this more gracefully):
when (stat /= Lua.OK) when (stat /= Lua.OK)
Lua.throwTopMessage Lua.throwErrorAsException
rendered <- docToCustom opts doc rendered <- docToCustom opts doc
context <- metaToContext opts context <- metaToContext opts
(fmap (literal . pack) . blockListToCustom) (fmap (literal . pack) . blockListToCustom)
@ -107,126 +111,132 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do
Just tpl -> render Nothing $ Just tpl -> render Nothing $
renderTemplate tpl $ setField "body" body context 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 docToCustom opts (Pandoc (Meta metamap) blocks) = do
body <- blockListToCustom blocks 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. -- | Convert Pandoc block element to Custom.
blockToCustom :: Block -- ^ Block element blockToCustom :: forall e. PeekError e
-> Lua String => Block -- ^ Block element
-> LuaE e String
blockToCustom Null = return "" 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)]) = 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) = blockToCustom (LineBlock linesList) =
Lua.callFunc "LineBlock" (map Stringify linesList) invoke @e "LineBlock" (map (Stringify @e) linesList)
blockToCustom (RawBlock format str) = 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) = 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) = blockToCustom (CodeBlock attr str) =
Lua.callFunc "CodeBlock" str (attrToMap attr) invoke @e "CodeBlock" str (attrToMap attr)
blockToCustom (BlockQuote blocks) = blockToCustom (BlockQuote blocks) =
Lua.callFunc "BlockQuote" (Stringify blocks) invoke @e "BlockQuote" (Stringify @e blocks)
blockToCustom (Table _ blkCapt specs thead tbody tfoot) = blockToCustom (Table _ blkCapt specs thead tbody tfoot) =
let (capt, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot let (capt, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot
aligns' = map show aligns aligns' = map show aligns
capt' = Stringify capt capt' = Stringify @e capt
headers' = map Stringify headers headers' = map (Stringify @e) headers
rows' = map (map Stringify) rows rows' = map (map (Stringify @e)) rows
in Lua.callFunc "Table" capt' aligns' widths headers' rows' in invoke @e "Table" capt' aligns' widths headers' rows'
blockToCustom (BulletList items) = blockToCustom (BulletList items) =
Lua.callFunc "BulletList" (map Stringify items) invoke @e "BulletList" (map (Stringify @e) items)
blockToCustom (OrderedList (num,sty,delim) 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) = blockToCustom (DefinitionList items) =
Lua.callFunc "DefinitionList" invoke @e "DefinitionList"
(map (KeyValue . (Stringify *** map Stringify)) items) (map (KeyValue . (Stringify @e *** map (Stringify @e))) items)
blockToCustom (Div attr 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. -- | Convert list of Pandoc block elements to Custom.
blockListToCustom :: [Block] -- ^ List of block elements blockListToCustom :: forall e. PeekError e
-> Lua String => [Block] -- ^ List of block elements
-> LuaE e String
blockListToCustom xs = do blockListToCustom xs = do
blocksep <- Lua.callFunc "Blocksep" blocksep <- invoke @e "Blocksep"
bs <- mapM blockToCustom xs bs <- mapM blockToCustom xs
return $ mconcat $ intersperse blocksep bs return $ mconcat $ intersperse blocksep bs
-- | Convert list of Pandoc inline elements to Custom. -- | Convert list of Pandoc inline elements to Custom.
inlineListToCustom :: [Inline] -> Lua String inlineListToCustom :: forall e. PeekError e => [Inline] -> LuaE e String
inlineListToCustom lst = do inlineListToCustom lst = do
xs <- mapM inlineToCustom lst xs <- mapM (inlineToCustom @e) lst
return $ mconcat xs return $ mconcat xs
-- | Convert Pandoc inline element to Custom. -- | 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) = inlineToCustom (Code attr str) =
Lua.callFunc "Code" str (attrToMap attr) invoke @e "Code" str (attrToMap attr)
inlineToCustom (Math DisplayMath str) = inlineToCustom (Math DisplayMath str) =
Lua.callFunc "DisplayMath" str invoke @e "DisplayMath" str
inlineToCustom (Math InlineMath str) = inlineToCustom (Math InlineMath str) =
Lua.callFunc "InlineMath" str invoke @e "InlineMath" str
inlineToCustom (RawInline format 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)) = 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)) = 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) = 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 - doctemplates-0.10
- emojis-0.1.2 - emojis-0.1.2
- doclayout-0.3.1.1 - 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 - git: https://github.com/jgm/pandoc-types.git
commit: 99402a46361a3e52805935b1fbe9dfe54f852d6a commit: 99402a46361a3e52805935b1fbe9dfe54f852d6a
- git: https://github.com/jgm/texmath.git - git: https://github.com/jgm/texmath.git
@ -26,5 +39,3 @@ ghc-options:
resolver: lts-18.10 resolver: lts-18.10
nix: nix:
packages: [zlib] packages: [zlib]

61
test/Tests/Lua.hs
View file

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

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

@ -55,31 +55,6 @@ return {
end), 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' { group 'conversion to string' {
test('converting from and to string is a noop', function () test('converting from and to string is a noop', function ()
local version_string = '1.19.4' local version_string = '1.19.4'