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

Use hslua >= 0.7, update Lua code

Browse source
This commit is contained in:
Albert Krewinkel 2017-08-13 12:37:10 +02:00
parent 418bda8128
commit 2dc3dbd68b
12 changed files with 462 additions and 621 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
pandoc.cabal
View file

@ -317,7 +317,7 @@ Library
yaml >= 0.8.8.2 && < 0.9, yaml >= 0.8.8.2 && < 0.9,
scientific >= 0.2 && < 0.4, scientific >= 0.2 && < 0.4,
vector >= 0.10 && < 0.13, vector >= 0.10 && < 0.13,
hslua >= 0.4 && < 0.6, hslua >= 0.7 && < 0.8,
binary >= 0.5 && < 0.9, binary >= 0.5 && < 0.9,
SHA >= 1.6 && < 1.7, SHA >= 1.6 && < 1.7,
haddock-library >= 1.1 && < 1.5, haddock-library >= 1.1 && < 1.5,
@ -464,7 +464,6 @@ Library
Text.Pandoc.Readers.Org.ParserState, Text.Pandoc.Readers.Org.ParserState,
Text.Pandoc.Readers.Org.Parsing, Text.Pandoc.Readers.Org.Parsing,
Text.Pandoc.Readers.Org.Shared, Text.Pandoc.Readers.Org.Shared,
Text.Pandoc.Lua.Compat,
Text.Pandoc.Lua.PandocModule, Text.Pandoc.Lua.PandocModule,
Text.Pandoc.Lua.SharedInstances, Text.Pandoc.Lua.SharedInstances,
Text.Pandoc.Lua.StackInstances, Text.Pandoc.Lua.StackInstances,
@ -545,7 +544,7 @@ Test-Suite test-pandoc
text >= 0.11 && < 1.3, text >= 0.11 && < 1.3,
directory >= 1 && < 1.4, directory >= 1 && < 1.4,
filepath >= 1.1 && < 1.5, filepath >= 1.1 && < 1.5,
hslua >= 0.4 && < 0.6, hslua >= 0.7 && < 0.8,
process >= 1.2.3 && < 1.7, process >= 1.2.3 && < 1.7,
skylighting >= 0.3.3 && < 0.4, skylighting >= 0.3.3 && < 0.4,
temporary >= 1.1 && < 1.3, temporary >= 1.1 && < 1.3,

147
src/Text/Pandoc/Lua.hs
View file

@ -41,14 +41,16 @@ import Data.Data (toConstr, showConstr, dataTypeOf, dataTypeConstrs, Data)
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Scripting.Lua (LuaState, StackValue (..)) import Foreign.Lua (Lua, FromLuaStack (..), ToLuaStack (..), runLua,
peekEither, getglobal', throwLuaError)
import Foreign.Lua.Types.Lua (runLuaWith, liftLua1)
import Foreign.Lua.Api
import Text.Pandoc.Definition import Text.Pandoc.Definition
import Text.Pandoc.Lua.PandocModule (pushPandocModule) import Text.Pandoc.Lua.PandocModule (pushPandocModule)
import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Lua.StackInstances ()
import Text.Pandoc.Walk import Text.Pandoc.Walk
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Scripting.Lua as Lua
newtype LuaException = LuaException String newtype LuaException = LuaException String
deriving (Show, Typeable) deriving (Show, Typeable)
@ -57,123 +59,120 @@ instance Exception LuaException
runLuaFilter :: (MonadIO m) runLuaFilter :: (MonadIO m)
=> Maybe FilePath -> FilePath -> [String] -> Pandoc -> m Pandoc => Maybe FilePath -> FilePath -> [String] -> Pandoc -> m Pandoc
runLuaFilter datadir filterPath args pd = liftIO $ do runLuaFilter datadir filterPath args pd = liftIO . runLua $ do
lua <- Lua.newstate openlibs
Lua.openlibs lua
-- store module in global "pandoc" -- store module in global "pandoc"
pushPandocModule datadir lua pushPandocModule datadir
Lua.setglobal lua "pandoc" setglobal "pandoc"
top <- Lua.gettop lua top <- gettop
status <- Lua.loadfile lua filterPath stat<- dofile filterPath
if status /= 0 if stat /= OK
then do then do
Just luaErrMsg <- Lua.peek lua 1 luaErrMsg <- peek (-1) <* pop 1
throwIO (LuaException luaErrMsg) throwLuaError luaErrMsg
else do else do
Lua.call lua 0 Lua.multret newtop <- gettop
newtop <- Lua.gettop lua
-- Use the implicitly defined global filter if nothing was returned -- Use the implicitly defined global filter if nothing was returned
when (newtop - top < 1) $ pushGlobalFilter lua when (newtop - top < 1) $ pushGlobalFilter
Just luaFilters <- Lua.peek lua (-1) luaFilters <- peek (-1)
Lua.push lua args push args
Lua.setglobal lua "PandocParameters" setglobal "PandocParameters"
doc <- runAll luaFilters pd runAll luaFilters pd
Lua.close lua
return doc
pushGlobalFilter :: LuaState -> IO () pushGlobalFilter :: Lua ()
pushGlobalFilter lua = pushGlobalFilter = do
Lua.newtable lua newtable
*> Lua.getglobal2 lua "pandoc.global_filter" getglobal' "pandoc.global_filter"
*> Lua.call lua 0 1 call 0 1
*> Lua.rawseti lua (-2) 1 rawseti (-2) 1
runAll :: [LuaFilter] -> Pandoc -> IO Pandoc runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc
runAll = foldr ((>=>) . walkMWithLuaFilter) return runAll = foldr ((>=>) . walkMWithLuaFilter) return
walkMWithLuaFilter :: LuaFilter -> Pandoc -> IO Pandoc walkMWithLuaFilter :: LuaFilter -> Pandoc -> Lua Pandoc
walkMWithLuaFilter (LuaFilter lua fnMap) = walkMWithLuaFilter (LuaFilter fnMap) = liftLua1 walkLua
where
walkLua :: LuaState -> Pandoc -> IO Pandoc
walkLua l =
(if hasOneOf (constructorsFor (dataTypeOf (Str []))) (if hasOneOf (constructorsFor (dataTypeOf (Str [])))
then walkM (tryFilter lua fnMap :: Inline -> IO Inline) then walkM (runLuaWith l . (tryFilter fnMap :: Inline -> Lua Inline))
else return) else return)
>=> >=>
(if hasOneOf (constructorsFor (dataTypeOf (Para []))) (if hasOneOf (constructorsFor (dataTypeOf (Para [])))
then walkM (tryFilter lua fnMap :: Block -> IO Block) then walkM ((runLuaWith l . (tryFilter fnMap :: Block -> Lua Block)))
else return) else return)
>=> >=>
(case Map.lookup "Meta" fnMap of (case Map.lookup "Meta" fnMap of
Just fn -> walkM (\(Pandoc meta blocks) -> do Just fn -> walkM ((\(Pandoc meta blocks) -> runLuaWith l $ do
meta' <- runFilterFunction lua fn meta meta' <- runFilterFunction fn meta
return $ Pandoc meta' blocks) return $ Pandoc meta' blocks))
Nothing -> return) Nothing -> return)
>=> >=>
(case Map.lookup "Pandoc" fnMap `mplus` Map.lookup "Doc" fnMap of (case Map.lookup "Pandoc" fnMap `mplus` Map.lookup "Doc" fnMap of
Just fn -> (runFilterFunction lua fn) :: Pandoc -> IO Pandoc Just fn -> runLuaWith l . (runFilterFunction fn :: Pandoc -> Lua Pandoc)
Nothing -> return) Nothing -> return)
where hasOneOf = any (\k -> isJust (Map.lookup k fnMap)) hasOneOf = any (\k -> isJust (Map.lookup k fnMap))
constructorsFor x = map show (dataTypeConstrs x) constructorsFor x = map show (dataTypeConstrs x)
type FunctionMap = Map String LuaFilterFunction type FunctionMap = Map String LuaFilterFunction
data LuaFilter = LuaFilter LuaState FunctionMap data LuaFilter = LuaFilter FunctionMap
newtype LuaFilterFunction = LuaFilterFunction { functionIndex :: Int } newtype LuaFilterFunction = LuaFilterFunction { functionIndex :: Int }
tryFilter :: (Data a, StackValue a) => LuaState -> FunctionMap -> a -> IO a -- | Try running a filter for the given element
tryFilter lua fnMap x = tryFilter :: (Data a, FromLuaStack a, ToLuaStack a) => FunctionMap -> a -> Lua a
tryFilter fnMap x =
let filterFnName = showConstr (toConstr x) in let filterFnName = showConstr (toConstr x) in
case Map.lookup filterFnName fnMap of case Map.lookup filterFnName fnMap of
Nothing -> return x Nothing -> return x
Just fn -> runFilterFunction lua fn x Just fn -> runFilterFunction fn x
instance StackValue LuaFilter where instance FromLuaStack LuaFilter where
valuetype _ = Lua.TTABLE peek idx = LuaFilter <$> peek idx
push = undefined
peek lua idx = fmap (LuaFilter lua) <$> Lua.peek lua idx
-- | 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 function is
-- called with given element as argument and is expected to return an element. -- called with given element as argument and is expected to return an element.
-- Alternatively, the function can return nothing or nil, in which case the -- Alternatively, the function can return nothing or nil, in which case the
-- element is left unchanged. -- element is left unchanged.
runFilterFunction :: StackValue a => LuaState -> LuaFilterFunction -> a -> IO a runFilterFunction :: (FromLuaStack a, ToLuaStack a)
runFilterFunction lua lf x = do => LuaFilterFunction -> a -> Lua a
pushFilterFunction lua lf runFilterFunction lf x = do
Lua.push lua x pushFilterFunction lf
z <- Lua.pcall lua 1 1 0 push x
if (z /= 0) z <- pcall 1 1 Nothing
if z /= OK
then do then do
msg <- Lua.peek lua (-1) msg <- peek (-1)
let prefix = "Error while running filter function: " let prefix = "Error while running filter function: "
throwIO . LuaException $ throwLuaError $ prefix ++ msg
case msg of
Nothing -> prefix ++ "could not read error message"
Just msg' -> prefix ++ msg'
else do else do
resType <- Lua.ltype lua (-1) resType <- ltype (-1)
case resType of case resType of
Lua.TNIL -> Lua.pop lua 1 *> return x TypeNil -> pop 1 *> return x
_ -> do _ -> do
mbres <- Lua.peek lua (-1) mbres <- peekEither (-1)
case mbres of case mbres of
Nothing -> throwIO $ LuaException Left err -> throwLuaError
("Error while trying to get a filter's return " ("Error while trying to get a filter's return "
++ "value from lua stack.") ++ "value from lua stack.\n" ++ err)
Just res -> res <$ Lua.pop lua 1 Right res -> res <$ pop 1
-- | Push the filter function to the top of the stack. -- | Push the filter function to the top of the stack.
pushFilterFunction :: Lua.LuaState -> LuaFilterFunction -> IO () pushFilterFunction :: LuaFilterFunction -> Lua ()
pushFilterFunction lua lf = pushFilterFunction lf =
-- The function is stored in a lua registry table, retrieve it from there. -- The function is stored in a lua registry table, retrieve it from there.
Lua.rawgeti lua Lua.registryindex (functionIndex lf) rawgeti registryindex (functionIndex lf)
registerFilterFunction :: LuaState -> Int -> IO LuaFilterFunction registerFilterFunction :: StackIndex -> Lua LuaFilterFunction
registerFilterFunction lua idx = do registerFilterFunction idx = do
isFn <- Lua.isfunction lua idx isFn <- isfunction idx
unless isFn . throwIO . LuaException $ "Not a function at index " ++ show idx unless isFn . throwLuaError $ "Not a function at index " ++ show idx
Lua.pushvalue lua idx pushvalue idx
refIdx <- Lua.ref lua Lua.registryindex refIdx <- ref registryindex
return $ LuaFilterFunction refIdx return $ LuaFilterFunction refIdx
instance StackValue LuaFilterFunction where instance ToLuaStack LuaFilterFunction where
valuetype _ = Lua.TFUNCTION
push = pushFilterFunction push = pushFilterFunction
peek = fmap (fmap Just) . registerFilterFunction
instance FromLuaStack LuaFilterFunction where
peek = registerFilterFunction

40
src/Text/Pandoc/Lua/Compat.hs
View file

@ -1,40 +0,0 @@
{-
Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-# LANGUAGE CPP #-}
{- |
Module : Text.Pandoc.Lua.Compat
Copyright : Copyright © 2017 Albert Krewinkel
License : GNU GPL, version 2 or above
Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
Stability : alpha
Compatibility helpers for hslua
-}
module Text.Pandoc.Lua.Compat ( loadstring ) where
import Scripting.Lua (LuaState)
import qualified Scripting.Lua as Lua
-- | Interpret string as lua code and load into the lua environment.
loadstring :: LuaState -> String -> String -> IO Int
#if MIN_VERSION_hslua(0,5,0)
loadstring lua script _ = Lua.loadstring lua script
#else
loadstring lua script cn = Lua.loadstring lua script cn
#endif

24
src/Text/Pandoc/Lua/PandocModule.hs
View file

@ -31,31 +31,31 @@ import Control.Monad (unless)
import Data.ByteString.Char8 (unpack) import Data.ByteString.Char8 (unpack)
import Data.Default (Default (..)) import Data.Default (Default (..))
import Data.Text (pack) import Data.Text (pack)
import Scripting.Lua (LuaState, call, push, pushhsfunction, rawset) import Foreign.Lua (Lua, Status (OK), liftIO, push, pushHaskellFunction)
import Foreign.Lua.Api (call, loadstring, rawset)
import Text.Pandoc.Class import Text.Pandoc.Class
import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Definition (Pandoc)
import Text.Pandoc.Options (ReaderOptions(readerExtensions)) import Text.Pandoc.Options (ReaderOptions(readerExtensions))
import Text.Pandoc.Lua.Compat (loadstring)
import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Lua.StackInstances ()
import Text.Pandoc.Readers (Reader (..), getReader) import Text.Pandoc.Readers (Reader (..), getReader)
-- | Push the "pandoc" on the lua stack. -- | Push the "pandoc" on the lua stack.
pushPandocModule :: Maybe FilePath -> LuaState -> IO () pushPandocModule :: Maybe FilePath -> Lua ()
pushPandocModule datadir lua = do pushPandocModule datadir = do
script <- pandocModuleScript datadir script <- liftIO (pandocModuleScript datadir)
status <- loadstring lua script "pandoc.lua" status <- loadstring script
unless (status /= 0) $ call lua 0 1 unless (status /= OK) $ call 0 1
push lua "__read" push "__read"
pushhsfunction lua read_doc pushHaskellFunction readDoc
rawset lua (-3) rawset (-3)
-- | Get the string representation of the pandoc module -- | Get the string representation of the pandoc module
pandocModuleScript :: Maybe FilePath -> IO String pandocModuleScript :: Maybe FilePath -> IO String
pandocModuleScript datadir = unpack <$> pandocModuleScript datadir = unpack <$>
runIOorExplode (setUserDataDir datadir >> readDataFile "pandoc.lua") runIOorExplode (setUserDataDir datadir >> readDataFile "pandoc.lua")
read_doc :: String -> String -> IO (Either String Pandoc) readDoc :: String -> String -> Lua (Either String Pandoc)
read_doc formatSpec content = do readDoc formatSpec content = liftIO $ do
case getReader formatSpec of case getReader formatSpec of
Left s -> return $ Left s Left s -> return $ Left s
Right (reader, es) -> Right (reader, es) ->

82
src/Text/Pandoc/Lua/SharedInstances.hs
View file

@ -36,81 +36,9 @@ Shared StackValue instances for pandoc and generic types.
-} -}
module Text.Pandoc.Lua.SharedInstances () where module Text.Pandoc.Lua.SharedInstances () where
import Scripting.Lua (LTYPE (..), StackValue (..), newtable) import Foreign.Lua (ToLuaStack (push))
import Text.Pandoc.Lua.Util (addRawInt, addValue, getRawInt, keyValuePairs)
import qualified Data.Map as M instance (ToLuaStack a, ToLuaStack b) => ToLuaStack (Either a b) where
import qualified Text.Pandoc.UTF8 as UTF8 push = \case
Left x -> push x
#if MIN_VERSION_base(4,8,0) Right x -> push x
instance {-# OVERLAPS #-} StackValue [Char] where
#else
instance StackValue [Char] where
#endif
push lua cs = push lua (UTF8.fromString cs)
peek lua i = fmap UTF8.toString <$> peek lua i
valuetype _ = TSTRING
instance (StackValue a, StackValue b) => StackValue (a, b) where
push lua (a, b) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
return $ (,) <$> a <*> b
valuetype _ = TTABLE
instance (StackValue a, StackValue b, StackValue c) =>
StackValue (a, b, c)
where
push lua (a, b, c) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
addRawInt lua 3 c
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
c <- getRawInt lua idx 3
return $ (,,) <$> a <*> b <*> c
valuetype _ = TTABLE
instance (StackValue a, StackValue b, StackValue c,
StackValue d, StackValue e) =>
StackValue (a, b, c, d, e)
where
push lua (a, b, c, d, e) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
addRawInt lua 3 c
addRawInt lua 4 d
addRawInt lua 5 e
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
c <- getRawInt lua idx 3
d <- getRawInt lua idx 4
e <- getRawInt lua idx 5
return $ (,,,,) <$> a <*> b <*> c <*> d <*> e
valuetype _ = TTABLE
instance (Ord a, StackValue a, StackValue b) =>
StackValue (M.Map a b) where
push lua m = do
newtable lua
mapM_ (uncurry $ addValue lua) $ M.toList m
peek lua idx = fmap M.fromList <$> keyValuePairs lua idx
valuetype _ = TTABLE
instance (StackValue a, StackValue b) => StackValue (Either a b) where
push lua = \case
Left x -> push lua x
Right x -> push lua x
peek lua idx = peek lua idx >>= \case
Just left -> return . Just $ Left left
Nothing -> fmap Right <$> peek lua idx
valuetype (Left x) = valuetype x
valuetype (Right x) = valuetype x

381
src/Text/Pandoc/Lua/StackInstances.hs
View file

@ -33,243 +33,244 @@ StackValue instances for pandoc types.
module Text.Pandoc.Lua.StackInstances () where module Text.Pandoc.Lua.StackInstances () where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Scripting.Lua (LTYPE (..), LuaState, StackValue (..), ltype, newtable, import Foreign.Lua (Lua, Type (..), FromLuaStack (peek), ToLuaStack (push),
objlen) StackIndex, peekEither, throwLuaError)
import Foreign.Lua.Api (getfield, ltype, newtable, pop, rawlen)
import Text.Pandoc.Definition import Text.Pandoc.Definition
import Text.Pandoc.Lua.SharedInstances () import Text.Pandoc.Lua.SharedInstances ()
import Text.Pandoc.Lua.Util (addValue, getTable, pushViaConstructor) import Text.Pandoc.Lua.Util (addValue, getTable, pushViaConstructor)
import Text.Pandoc.Shared (safeRead) import Text.Pandoc.Shared (safeRead)
instance StackValue Pandoc where instance ToLuaStack Pandoc where
push lua (Pandoc meta blocks) = do push (Pandoc meta blocks) = do
newtable lua newtable
addValue lua "blocks" blocks addValue "blocks" blocks
addValue lua "meta" meta addValue "meta" meta
peek lua idx = do instance FromLuaStack Pandoc where
blocks <- getTable lua idx "blocks" peek idx = do
meta <- getTable lua idx "meta" blocks <- getTable idx "blocks"
return $ Pandoc <$> meta <*> blocks meta <- getTable idx "meta"
valuetype _ = TTABLE return $ Pandoc meta blocks
instance StackValue Meta where instance ToLuaStack Meta where
push lua (Meta mmap) = push lua mmap push (Meta mmap) = push mmap
peek lua idx = fmap Meta <$> peek lua idx instance FromLuaStack Meta where
valuetype _ = TTABLE peek idx = Meta <$> peek idx
instance StackValue MetaValue where instance ToLuaStack MetaValue where
push = pushMetaValue push = pushMetaValue
instance FromLuaStack MetaValue where
peek = peekMetaValue peek = peekMetaValue
valuetype = \case
MetaBlocks _ -> TTABLE
MetaBool _ -> TBOOLEAN
MetaInlines _ -> TTABLE
MetaList _ -> TTABLE
MetaMap _ -> TTABLE
MetaString _ -> TSTRING
instance StackValue Block where instance ToLuaStack Block where
push = pushBlock push = pushBlock
instance FromLuaStack Block where
peek = peekBlock peek = peekBlock
valuetype _ = TTABLE
instance StackValue Inline where -- Inline
instance ToLuaStack Inline where
push = pushInline push = pushInline
instance FromLuaStack Inline where
peek = peekInline peek = peekInline
valuetype _ = TTABLE
instance StackValue Citation where -- Citation
push lua (Citation cid prefix suffix mode noteNum hash) = instance ToLuaStack Citation where
pushViaConstructor lua "Citation" cid mode prefix suffix noteNum hash push (Citation cid prefix suffix mode noteNum hash) =
peek lua idx = do pushViaConstructor "Citation" cid mode prefix suffix noteNum hash
id' <- getTable lua idx "citationId"
prefix <- getTable lua idx "citationPrefix"
suffix <- getTable lua idx "citationSuffix"
mode <- getTable lua idx "citationMode"
num <- getTable lua idx "citationNoteNum"
hash <- getTable lua idx "citationHash"
return $ Citation <$> id' <*> prefix <*> suffix <*> mode <*> num <*> hash
valuetype _ = TTABLE
instance StackValue Alignment where instance FromLuaStack Citation where
push lua = push lua . show peek idx = do
peek lua idx = (>>= safeRead) <$> peek lua idx id' <- getTable idx "citationId"
valuetype _ = TSTRING prefix <- getTable idx "citationPrefix"
suffix <- getTable idx "citationSuffix"
mode <- getTable idx "citationMode"
num <- getTable idx "citationNoteNum"
hash <- getTable idx "citationHash"
return $ Citation id' prefix suffix mode num hash
instance StackValue CitationMode where instance ToLuaStack Alignment where
push lua = push lua . show push = push . show
peek lua idx = (>>= safeRead) <$> peek lua idx instance FromLuaStack Alignment where
valuetype _ = TSTRING peek idx = safeRead' =<< peek idx
instance StackValue Format where instance ToLuaStack CitationMode where
push lua (Format f) = push lua f push = push . show
peek lua idx = fmap Format <$> peek lua idx instance FromLuaStack CitationMode where
valuetype _ = TSTRING peek idx = safeRead' =<< peek idx
instance StackValue ListNumberDelim where instance ToLuaStack Format where
push lua = push lua . show push (Format f) = push f
peek lua idx = (>>= safeRead) <$> peek lua idx instance FromLuaStack Format where
valuetype _ = TSTRING peek idx = Format <$> peek idx
instance StackValue ListNumberStyle where instance ToLuaStack ListNumberDelim where
push lua = push lua . show push = push . show
peek lua idx = (>>= safeRead) <$> peek lua idx instance FromLuaStack ListNumberDelim where
valuetype _ = TSTRING peek idx = safeRead' =<< peek idx
instance StackValue MathType where instance ToLuaStack ListNumberStyle where
push lua = push lua . show push = push . show
peek lua idx = (>>= safeRead) <$> peek lua idx instance FromLuaStack ListNumberStyle where
valuetype _ = TSTRING peek idx = safeRead' =<< peek idx
instance StackValue QuoteType where instance ToLuaStack MathType where
push lua = push lua . show push = push . show
peek lua idx = (>>= safeRead) <$> peek lua idx instance FromLuaStack MathType where
valuetype _ = TSTRING peek idx = safeRead' =<< peek idx
instance ToLuaStack QuoteType where
push = push . show
instance FromLuaStack QuoteType where
peek idx = safeRead' =<< peek idx
safeRead' :: Read a => String -> Lua a
safeRead' s = case safeRead s of
Nothing -> throwLuaError ("Could not read: " ++ s)
Just x -> return x
-- | 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 :: LuaState -> MetaValue -> IO () pushMetaValue :: MetaValue -> Lua ()
pushMetaValue lua = \case pushMetaValue = \case
MetaBlocks blcks -> pushViaConstructor lua "MetaBlocks" blcks MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks
MetaBool bool -> push lua bool MetaBool bool -> push bool
MetaInlines inlns -> pushViaConstructor lua "MetaInlines" inlns MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns
MetaList metalist -> pushViaConstructor lua "MetaList" metalist MetaList metalist -> pushViaConstructor "MetaList" metalist
MetaMap metamap -> pushViaConstructor lua "MetaMap" metamap MetaMap metamap -> pushViaConstructor "MetaMap" metamap
MetaString str -> push lua str MetaString str -> 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 :: LuaState -> Int -> IO (Maybe MetaValue) peekMetaValue :: StackIndex -> Lua MetaValue
peekMetaValue lua idx = do peekMetaValue idx = do
-- Get the contents of an AST element. -- Get the contents of an AST element.
let elementContent :: StackValue a => IO (Maybe a) let elementContent :: FromLuaStack a => Lua a
elementContent = peek lua idx elementContent = peek idx
luatype <- ltype lua idx luatype <- ltype idx
case luatype of case luatype of
TBOOLEAN -> fmap MetaBool <$> peek lua idx TypeBoolean -> MetaBool <$> peek idx
TSTRING -> fmap MetaString <$> peek lua idx TypeString -> MetaString <$> peek idx
TTABLE -> do TypeTable -> do
tag <- getTable lua idx "t" tag <- getfield idx "t" *> peekEither (-1) <* pop 1
case tag of case tag of
Just "MetaBlocks" -> fmap MetaBlocks <$> elementContent Right "MetaBlocks" -> MetaBlocks <$> elementContent
Just "MetaBool" -> fmap MetaBool <$> elementContent Right "MetaBool" -> MetaBool <$> elementContent
Just "MetaMap" -> fmap MetaMap <$> elementContent Right "MetaMap" -> MetaMap <$> elementContent
Just "MetaInlines" -> fmap MetaInlines <$> elementContent Right "MetaInlines" -> MetaInlines <$> elementContent
Just "MetaList" -> fmap MetaList <$> elementContent Right "MetaList" -> MetaList <$> elementContent
Just "MetaString" -> fmap MetaString <$> elementContent Right "MetaString" -> MetaString <$> elementContent
Nothing -> do Right t -> throwLuaError ("Unknown meta tag: " ++ t)
Left _ -> do
-- no meta value tag given, try to guess. -- no meta value tag given, try to guess.
len <- objlen lua idx len <- rawlen idx
if len <= 0 if len <= 0
then fmap MetaMap <$> peek lua idx then MetaMap <$> peek idx
else (fmap MetaInlines <$> peek lua idx) else (MetaInlines <$> peek idx)
<|> (fmap MetaBlocks <$> peek lua idx) <|> (MetaBlocks <$> peek idx)
<|> (fmap MetaList <$> peek lua idx) <|> (MetaList <$> peek idx)
_ -> return Nothing _ -> throwLuaError ("could not get meta value")
_ -> return Nothing
-- | Push an block element to the top of the lua stack. -- | Push an block element to the top of the lua stack.
pushBlock :: LuaState -> Block -> IO () pushBlock :: Block -> Lua ()
pushBlock lua = \case pushBlock = \case
BlockQuote blcks -> pushViaConstructor lua "BlockQuote" blcks BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks
BulletList items -> pushViaConstructor lua "BulletList" items BulletList items -> pushViaConstructor "BulletList" items
CodeBlock attr code -> pushViaConstructor lua "CodeBlock" code (LuaAttr attr) CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr)
DefinitionList items -> pushViaConstructor lua "DefinitionList" items DefinitionList items -> pushViaConstructor "DefinitionList" items
Div attr blcks -> pushViaConstructor lua "Div" blcks (LuaAttr attr) Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr)
Header lvl attr inlns -> pushViaConstructor lua "Header" lvl inlns (LuaAttr attr) Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr)
HorizontalRule -> pushViaConstructor lua "HorizontalRule" HorizontalRule -> pushViaConstructor "HorizontalRule"
LineBlock blcks -> pushViaConstructor lua "LineBlock" blcks LineBlock blcks -> pushViaConstructor "LineBlock" blcks
OrderedList lstAttr list -> pushViaConstructor lua "OrderedList" list lstAttr OrderedList lstAttr list -> pushViaConstructor "OrderedList" list lstAttr
Null -> pushViaConstructor lua "Null" Null -> pushViaConstructor "Null"
Para blcks -> pushViaConstructor lua "Para" blcks Para blcks -> pushViaConstructor "Para" blcks
Plain blcks -> pushViaConstructor lua "Plain" blcks Plain blcks -> pushViaConstructor "Plain" blcks
RawBlock f cs -> pushViaConstructor lua "RawBlock" f cs RawBlock f cs -> pushViaConstructor "RawBlock" f cs
Table capt aligns widths headers rows -> Table capt aligns widths headers rows ->
pushViaConstructor lua "Table" capt aligns widths headers rows pushViaConstructor "Table" capt aligns widths headers rows
-- | Return the value at the given index as block if possible. -- | Return the value at the given index as block if possible.
peekBlock :: LuaState -> Int -> IO (Maybe Block) peekBlock :: StackIndex -> Lua Block
peekBlock lua idx = do peekBlock idx = do
tag <- getTable lua idx "t" tag <- getTable idx "t"
case tag of case tag of
Nothing -> return Nothing "BlockQuote" -> BlockQuote <$> elementContent
Just t -> case t of "BulletList" -> BulletList <$> elementContent
"BlockQuote" -> fmap BlockQuote <$> elementContent "CodeBlock" -> (withAttr CodeBlock) <$> elementContent
"BulletList" -> fmap BulletList <$> elementContent "DefinitionList" -> DefinitionList <$> elementContent
"CodeBlock" -> fmap (withAttr CodeBlock) <$> elementContent "Div" -> (withAttr Div) <$> elementContent
"DefinitionList" -> fmap DefinitionList <$> elementContent "Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst)
"Div" -> fmap (withAttr Div) <$> elementContent
"Header" -> fmap (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst)
<$> elementContent <$> elementContent
"HorizontalRule" -> return (Just HorizontalRule) "HorizontalRule" -> return HorizontalRule
"LineBlock" -> fmap LineBlock <$> elementContent "LineBlock" -> LineBlock <$> elementContent
"OrderedList" -> fmap (uncurry OrderedList) <$> elementContent "OrderedList" -> (uncurry OrderedList) <$> elementContent
"Null" -> return (Just Null) "Null" -> return Null
"Para" -> fmap Para <$> elementContent "Para" -> Para <$> elementContent
"Plain" -> fmap Plain <$> elementContent "Plain" -> Plain <$> elementContent
"RawBlock" -> fmap (uncurry RawBlock) <$> elementContent "RawBlock" -> (uncurry RawBlock) <$> elementContent
"Table" -> fmap (\(capt, aligns, widths, headers, body) -> "Table" -> (\(capt, aligns, widths, headers, body) ->
Table capt aligns widths headers body) Table capt aligns widths headers body)
<$> elementContent <$> elementContent
_ -> return Nothing _ -> throwLuaError ("Unknown block type: " ++ tag)
where where
-- Get the contents of an AST element. -- Get the contents of an AST element.
elementContent :: StackValue a => IO (Maybe a) elementContent :: FromLuaStack a => Lua a
elementContent = getTable lua idx "c" elementContent = getTable idx "c"
-- | Push an inline element to the top of the lua stack. -- | Push an inline element to the top of the lua stack.
pushInline :: LuaState -> Inline -> IO () pushInline :: Inline -> Lua ()
pushInline lua = \case pushInline = \case
Cite citations lst -> pushViaConstructor lua "Cite" lst citations Cite citations lst -> pushViaConstructor "Cite" lst citations
Code attr lst -> pushViaConstructor lua "Code" lst (LuaAttr attr) Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr)
Emph inlns -> pushViaConstructor lua "Emph" inlns Emph inlns -> pushViaConstructor "Emph" inlns
Image attr alt (src,tit) -> pushViaConstructor lua "Image" alt src tit (LuaAttr attr) Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr)
LineBreak -> pushViaConstructor lua "LineBreak" LineBreak -> pushViaConstructor "LineBreak"
Link attr lst (src,tit) -> pushViaConstructor lua "Link" lst src tit (LuaAttr attr) Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr)
Note blcks -> pushViaConstructor lua "Note" blcks Note blcks -> pushViaConstructor "Note" blcks
Math mty str -> pushViaConstructor lua "Math" mty str Math mty str -> pushViaConstructor "Math" mty str
Quoted qt inlns -> pushViaConstructor lua "Quoted" qt inlns Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns
RawInline f cs -> pushViaConstructor lua "RawInline" f cs RawInline f cs -> pushViaConstructor "RawInline" f cs
SmallCaps inlns -> pushViaConstructor lua "SmallCaps" inlns SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns
SoftBreak -> pushViaConstructor lua "SoftBreak" SoftBreak -> pushViaConstructor "SoftBreak"
Space -> pushViaConstructor lua "Space" Space -> pushViaConstructor "Space"
Span attr inlns -> pushViaConstructor lua "Span" inlns (LuaAttr attr) Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr)
Str str -> pushViaConstructor lua "Str" str Str str -> pushViaConstructor "Str" str
Strikeout inlns -> pushViaConstructor lua "Strikeout" inlns Strikeout inlns -> pushViaConstructor "Strikeout" inlns
Strong inlns -> pushViaConstructor lua "Strong" inlns Strong inlns -> pushViaConstructor "Strong" inlns
Subscript inlns -> pushViaConstructor lua "Subscript" inlns Subscript inlns -> pushViaConstructor "Subscript" inlns
Superscript inlns -> pushViaConstructor lua "Superscript" inlns Superscript inlns -> pushViaConstructor "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 :: LuaState -> Int -> IO (Maybe Inline) peekInline :: StackIndex -> Lua Inline
peekInline lua idx = do peekInline idx = do
tag <- getTable lua idx "t" tag <- getTable idx "t"
case tag of case tag of
Nothing -> return Nothing "Cite" -> (uncurry Cite) <$> elementContent
Just t -> case t of "Code" -> (withAttr Code) <$> elementContent
"Cite" -> fmap (uncurry Cite) <$> elementContent "Emph" -> Emph <$> elementContent
"Code" -> fmap (withAttr Code) <$> elementContent "Image" -> (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt)
"Emph" -> fmap Emph <$> elementContent
"Image" -> fmap (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt)
<$> elementContent <$> elementContent
"Link" -> fmap (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt) "Link" -> (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt)
<$> elementContent <$> elementContent
"LineBreak" -> return (Just LineBreak) "LineBreak" -> return LineBreak
"Note" -> fmap Note <$> elementContent "Note" -> Note <$> elementContent
"Math" -> fmap (uncurry Math) <$> elementContent "Math" -> (uncurry Math) <$> elementContent
"Quoted" -> fmap (uncurry Quoted) <$> elementContent "Quoted" -> (uncurry Quoted) <$> elementContent
"RawInline" -> fmap (uncurry RawInline) <$> elementContent "RawInline" -> (uncurry RawInline) <$> elementContent
"SmallCaps" -> fmap SmallCaps <$> elementContent "SmallCaps" -> SmallCaps <$> elementContent
"SoftBreak" -> return (Just SoftBreak) "SoftBreak" -> return SoftBreak
"Space" -> return (Just Space) "Space" -> return Space
"Span" -> fmap (withAttr Span) <$> elementContent "Span" -> (withAttr Span) <$> elementContent
"Str" -> fmap Str <$> elementContent "Str" -> Str <$> elementContent
"Strikeout" -> fmap Strikeout <$> elementContent "Strikeout" -> Strikeout <$> elementContent
"Strong" -> fmap Strong <$> elementContent "Strong" -> Strong <$> elementContent
"Subscript" -> fmap Subscript <$> elementContent "Subscript" -> Subscript <$> elementContent
"Superscript"-> fmap Superscript <$> elementContent "Superscript"-> Superscript <$> elementContent
_ -> return Nothing _ -> throwLuaError ("Unknown inline type: " ++ tag)
where where
-- Get the contents of an AST element. -- Get the contents of an AST element.
elementContent :: StackValue a => IO (Maybe a) elementContent :: FromLuaStack a => Lua a
elementContent = getTable lua idx "c" elementContent = getTable idx "c"
withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b
withAttr f (attributes, x) = f (fromLuaAttr attributes) x withAttr f (attributes, x) = f (fromLuaAttr attributes) x
@ -277,8 +278,8 @@ withAttr f (attributes, x) = f (fromLuaAttr attributes) x
-- | Wrapper for Attr -- | Wrapper for Attr
newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr } newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr }
instance StackValue LuaAttr where instance ToLuaStack LuaAttr where
push lua (LuaAttr (id', classes, kv)) = push (LuaAttr (id', classes, kv)) =
pushViaConstructor lua "Attr" id' classes kv pushViaConstructor "Attr" id' classes kv
peek lua idx = fmap LuaAttr <$> peek lua idx instance FromLuaStack LuaAttr where
valuetype _ = TTABLE peek idx = LuaAttr <$> peek idx

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

@ -36,103 +36,79 @@ module Text.Pandoc.Lua.Util
, getRawInt , getRawInt
, setRawInt , setRawInt
, addRawInt , addRawInt
, keyValuePairs
, PushViaCall , PushViaCall
, pushViaCall , pushViaCall
, pushViaConstructor , pushViaConstructor
) where ) where
import Scripting.Lua (LuaState, StackValue (..), call, getglobal2, gettable, import Foreign.Lua (Lua, FromLuaStack (..), ToLuaStack (..), NumArgs,
next, pop, pushnil, rawgeti, rawseti, settable) StackIndex, getglobal')
import Foreign.Lua.Api (call, gettable, pop, rawgeti, rawseti, settable)
-- | Adjust the stack index, assuming that @n@ new elements have been pushed on -- | Adjust the stack index, assuming that @n@ new elements have been pushed on
-- the stack. -- the stack.
adjustIndexBy :: Int -> Int -> Int adjustIndexBy :: StackIndex -> StackIndex -> StackIndex
adjustIndexBy idx n = adjustIndexBy idx n =
if idx < 0 if idx < 0
then idx - n then idx - n
else idx else idx
-- | Get value behind key from table at given index. -- | Get value behind key from table at given index.
getTable :: (StackValue a, StackValue b) => LuaState -> Int -> a -> IO (Maybe b) getTable :: (ToLuaStack a, FromLuaStack b) => StackIndex -> a -> Lua b
getTable lua idx key = do getTable idx key = do
push lua key push key
gettable lua (idx `adjustIndexBy` 1) gettable (idx `adjustIndexBy` 1)
peek lua (-1) <* pop lua 1 peek (-1) <* pop 1
-- | Set value for key for table at the given index -- | Set value for key for table at the given index
setTable :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO () setTable :: (ToLuaStack a, ToLuaStack b) => StackIndex -> a -> b -> Lua ()
setTable lua idx key value = do setTable idx key value = do
push lua key push key
push lua value push value
settable lua (idx `adjustIndexBy` 2) settable (idx `adjustIndexBy` 2)
-- | Add a key-value pair to the table at the top of the stack -- | Add a key-value pair to the table at the top of the stack
addValue :: (StackValue a, StackValue b) => LuaState -> a -> b -> IO () addValue :: (ToLuaStack a, ToLuaStack b) => a -> b -> Lua ()
addValue lua = setTable lua (-1) addValue = setTable (-1)
-- | Get value behind key from table at given index. -- | Get value behind key from table at given index.
getRawInt :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a) getRawInt :: FromLuaStack a => StackIndex -> Int -> Lua a
getRawInt lua idx key = getRawInt idx key =
rawgeti lua idx key rawgeti idx key
*> peek lua (-1) *> peek (-1)
<* pop lua 1 <* pop 1
-- | Set numeric key/value in table at the given index -- | Set numeric key/value in table at the given index
setRawInt :: StackValue a => LuaState -> Int -> Int -> a -> IO () setRawInt :: ToLuaStack a => StackIndex -> Int -> a -> Lua ()
setRawInt lua idx key value = do setRawInt idx key value = do
push lua value push value
rawseti lua (idx `adjustIndexBy` 1) key rawseti (idx `adjustIndexBy` 1) key
-- | Set numeric key/value in table at the top of the stack. -- | Set numeric key/value in table at the top of the stack.
addRawInt :: StackValue a => LuaState -> Int -> a -> IO () addRawInt :: ToLuaStack a => Int -> a -> Lua ()
addRawInt lua = setRawInt lua (-1) addRawInt = setRawInt (-1)
-- | Try reading the table under the given index as a list of key-value pairs.
keyValuePairs :: (StackValue a, StackValue b)
=> LuaState -> Int -> IO (Maybe [(a, b)])
keyValuePairs lua idx = do
pushnil lua
sequence <$> remainingPairs
where
remainingPairs = do
res <- nextPair
case res of
Nothing -> return []
Just a -> (a:) <$> remainingPairs
nextPair :: (StackValue a, StackValue b) => IO (Maybe (Maybe (a,b)))
nextPair = do
hasNext <- next lua (idx `adjustIndexBy` 1)
if hasNext
then do
val <- peek lua (-1)
key <- peek lua (-2)
pop lua 1 -- removes the value, keeps the key
return $ Just <$> ((,) <$> key <*> val)
else do
return Nothing
-- | 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 function.
-- See @pushViaCall@. -- See @pushViaCall@.
class PushViaCall a where class PushViaCall a where
pushViaCall' :: LuaState -> String -> IO () -> Int -> a pushViaCall' :: String -> Lua () -> NumArgs -> a
instance PushViaCall (IO ()) where instance PushViaCall (Lua ()) where
pushViaCall' lua fn pushArgs num = do pushViaCall' fn pushArgs num = do
getglobal2 lua fn getglobal' fn
pushArgs pushArgs
call lua num 1 call num 1
instance (StackValue a, PushViaCall b) => PushViaCall (a -> b) where instance (ToLuaStack a, PushViaCall b) => PushViaCall (a -> b) where
pushViaCall' lua fn pushArgs num x = pushViaCall' fn pushArgs num x =
pushViaCall' lua fn (pushArgs *> push lua x) (num + 1) pushViaCall' fn (pushArgs *> 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 => LuaState -> String -> a pushViaCall :: PushViaCall a => String -> a
pushViaCall lua fn = pushViaCall' lua fn (return ()) 0 pushViaCall fn = pushViaCall' 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 => LuaState -> String -> a pushViaConstructor :: PushViaCall a => String -> a
pushViaConstructor lua pandocFn = pushViaCall lua ("pandoc." ++ pandocFn) pushViaConstructor pandocFn = pushViaCall ("pandoc." ++ pandocFn)

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

@ -44,10 +44,9 @@ import qualified Data.Map as M
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Data.Typeable import Data.Typeable
import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8) import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8)
import Scripting.Lua (LuaState, StackValue, callfunc) import Foreign.Lua (Lua, ToLuaStack (..), callFunc, runLua)
import qualified Scripting.Lua as Lua import Foreign.Lua.Api
import Text.Pandoc.Error import Text.Pandoc.Error
import Text.Pandoc.Lua.Compat ( loadstring )
import Text.Pandoc.Lua.Util ( addValue ) import Text.Pandoc.Lua.Util ( addValue )
import Text.Pandoc.Lua.SharedInstances () import Text.Pandoc.Lua.SharedInstances ()
import Text.Pandoc.Definition import Text.Pandoc.Definition
@ -62,55 +61,40 @@ attrToMap (id',classes,keyvals) = M.fromList
: ("class", unwords classes) : ("class", unwords classes)
: keyvals : keyvals
instance StackValue Format where instance ToLuaStack Format where
push lua (Format f) = Lua.push lua (map toLower f) push (Format f) = push (map toLower f)
peek l n = fmap Format `fmap` Lua.peek l n
valuetype _ = Lua.TSTRING
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Inline] where instance {-# OVERLAPS #-} ToLuaStack [Inline] where
#else #else
instance StackValue [Inline] where instance ToLuaStack [Inline] where
#endif #endif
push l ils = Lua.push l =<< inlineListToCustom l ils push ils = push =<< inlineListToCustom ils
peek _ _ = undefined
valuetype _ = Lua.TSTRING
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Block] where instance {-# OVERLAPS #-} ToLuaStack [Block] where
#else #else
instance StackValue [Block] where instance ToLuaStack [Block] where
#endif #endif
push l ils = Lua.push l =<< blockListToCustom l ils push ils = push =<< blockListToCustom ils
peek _ _ = undefined
valuetype _ = Lua.TSTRING
instance StackValue MetaValue where instance ToLuaStack MetaValue where
push l (MetaMap m) = Lua.push l m push (MetaMap m) = push m
push l (MetaList xs) = Lua.push l xs push (MetaList xs) = push xs
push l (MetaBool x) = Lua.push l x push (MetaBool x) = push x
push l (MetaString s) = Lua.push l s push (MetaString s) = push s
push l (MetaInlines ils) = Lua.push l ils push (MetaInlines ils) = push ils
push l (MetaBlocks bs) = Lua.push l bs push (MetaBlocks bs) = push bs
peek _ _ = undefined
valuetype (MetaMap _) = Lua.TTABLE
valuetype (MetaList _) = Lua.TTABLE
valuetype (MetaBool _) = Lua.TBOOLEAN
valuetype (MetaString _) = Lua.TSTRING
valuetype (MetaInlines _) = Lua.TSTRING
valuetype (MetaBlocks _) = Lua.TSTRING
instance StackValue Citation where instance ToLuaStack Citation where
push lua cit = do push cit = do
Lua.createtable lua 6 0 createtable 6 0
addValue lua "citationId" $ citationId cit addValue "citationId" $ citationId cit
addValue lua "citationPrefix" $ citationPrefix cit addValue "citationPrefix" $ citationPrefix cit
addValue lua "citationSuffix" $ citationSuffix cit addValue "citationSuffix" $ citationSuffix cit
addValue lua "citationMode" $ show (citationMode cit) addValue "citationMode" $ show (citationMode cit)
addValue lua "citationNoteNum" $ citationNoteNum cit addValue "citationNoteNum" $ citationNoteNum cit
addValue lua "citationHash" $ citationHash cit addValue "citationHash" $ citationHash cit
peek = undefined
valuetype _ = Lua.TTABLE
data PandocLuaException = PandocLuaException String data PandocLuaException = PandocLuaException String
deriving (Show, Typeable) deriving (Show, Typeable)
@ -123,23 +107,22 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do
luaScript <- UTF8.readFile luaFile luaScript <- UTF8.readFile luaFile
enc <- getForeignEncoding enc <- getForeignEncoding
setForeignEncoding utf8 setForeignEncoding utf8
lua <- Lua.newstate (body, context) <- runLua $ do
Lua.openlibs lua openlibs
status <- loadstring lua luaScript luaFile stat <- loadstring luaScript
-- 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 (status /= 0) $ when (stat /= OK) $
Lua.tostring lua 1 >>= throw . PandocLuaException . UTF8.toString tostring 1 >>= throw . PandocLuaException . UTF8.toString
Lua.call lua 0 0 call 0 0
-- TODO - call hierarchicalize, so we have that info -- TODO - call hierarchicalize, so we have that info
rendered <- docToCustom lua opts doc rendered <- docToCustom opts doc
context <- metaToJSON opts context <- metaToJSON opts
(blockListToCustom lua) blockListToCustom
(inlineListToCustom lua) inlineListToCustom
meta meta
Lua.close lua return (rendered, context)
setForeignEncoding enc setForeignEncoding enc
let body = rendered
case writerTemplate opts of case writerTemplate opts of
Nothing -> return $ pack body Nothing -> return $ pack body
Just tpl -> Just tpl ->
@ -147,117 +130,115 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do
Left e -> throw (PandocTemplateError e) Left e -> throw (PandocTemplateError e)
Right r -> return (pack r) Right r -> return (pack r)
docToCustom :: LuaState -> WriterOptions -> Pandoc -> IO String docToCustom :: WriterOptions -> Pandoc -> Lua String
docToCustom lua opts (Pandoc (Meta metamap) blocks) = do docToCustom opts (Pandoc (Meta metamap) blocks) = do
body <- blockListToCustom lua blocks body <- blockListToCustom blocks
callfunc lua "Doc" body metamap (writerVariables opts) callFunc "Doc" body metamap (writerVariables opts)
-- | Convert Pandoc block element to Custom. -- | Convert Pandoc block element to Custom.
blockToCustom :: LuaState -- ^ Lua state blockToCustom :: Block -- ^ Block element
-> Block -- ^ Block element -> Lua String
-> IO String
blockToCustom _ Null = return "" blockToCustom Null = return ""
blockToCustom lua (Plain inlines) = callfunc lua "Plain" inlines blockToCustom (Plain inlines) = callFunc "Plain" inlines
blockToCustom lua (Para [Image attr txt (src,tit)]) = blockToCustom (Para [Image attr txt (src,tit)]) =
callfunc lua "CaptionedImage" src tit txt (attrToMap attr) callFunc "CaptionedImage" src tit txt (attrToMap attr)
blockToCustom lua (Para inlines) = callfunc lua "Para" inlines blockToCustom (Para inlines) = callFunc "Para" inlines
blockToCustom lua (LineBlock linesList) = callfunc lua "LineBlock" linesList blockToCustom (LineBlock linesList) = callFunc "LineBlock" linesList
blockToCustom lua (RawBlock format str) = blockToCustom (RawBlock format str) =
callfunc lua "RawBlock" format str callFunc "RawBlock" format str
blockToCustom lua HorizontalRule = callfunc lua "HorizontalRule" blockToCustom HorizontalRule = callFunc "HorizontalRule"
blockToCustom lua (Header level attr inlines) = blockToCustom (Header level attr inlines) =
callfunc lua "Header" level inlines (attrToMap attr) callFunc "Header" level inlines (attrToMap attr)
blockToCustom lua (CodeBlock attr str) = blockToCustom (CodeBlock attr str) =
callfunc lua "CodeBlock" str (attrToMap attr) callFunc "CodeBlock" str (attrToMap attr)
blockToCustom lua (BlockQuote blocks) = callfunc lua "BlockQuote" blocks blockToCustom (BlockQuote blocks) = callFunc "BlockQuote" blocks
blockToCustom lua (Table capt aligns widths headers rows') = blockToCustom (Table capt aligns widths headers rows') =
callfunc lua "Table" capt (map show aligns) widths headers rows' callFunc "Table" capt (map show aligns) widths headers rows'
blockToCustom lua (BulletList items) = callfunc lua "BulletList" items blockToCustom (BulletList items) = callFunc "BulletList" items
blockToCustom lua (OrderedList (num,sty,delim) items) = blockToCustom (OrderedList (num,sty,delim) items) =
callfunc lua "OrderedList" items num (show sty) (show delim) callFunc "OrderedList" items num (show sty) (show delim)
blockToCustom lua (DefinitionList items) = blockToCustom (DefinitionList items) =
callfunc lua "DefinitionList" items callFunc "DefinitionList" items
blockToCustom lua (Div attr items) = blockToCustom (Div attr items) =
callfunc lua "Div" items (attrToMap attr) callFunc "Div" items (attrToMap attr)
-- | Convert list of Pandoc block elements to Custom. -- | Convert list of Pandoc block elements to Custom.
blockListToCustom :: LuaState -- ^ Options blockListToCustom :: [Block] -- ^ List of block elements
-> [Block] -- ^ List of block elements -> Lua String
-> IO String blockListToCustom xs = do
blockListToCustom lua xs = do blocksep <- callFunc "Blocksep"
blocksep <- callfunc lua "Blocksep" bs <- mapM blockToCustom xs
bs <- mapM (blockToCustom lua) 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 :: LuaState -> [Inline] -> IO String inlineListToCustom :: [Inline] -> Lua String
inlineListToCustom lua lst = do inlineListToCustom lst = do
xs <- mapM (inlineToCustom lua) lst xs <- mapM inlineToCustom lst
return $ concat xs return $ mconcat xs
-- | Convert Pandoc inline element to Custom. -- | Convert Pandoc inline element to Custom.
inlineToCustom :: LuaState -> Inline -> IO String inlineToCustom :: Inline -> Lua String
inlineToCustom lua (Str str) = callfunc lua "Str" str inlineToCustom (Str str) = callFunc "Str" str
inlineToCustom lua Space = callfunc lua "Space" inlineToCustom Space = callFunc "Space"
inlineToCustom lua SoftBreak = callfunc lua "SoftBreak" inlineToCustom SoftBreak = callFunc "SoftBreak"
inlineToCustom lua (Emph lst) = callfunc lua "Emph" lst inlineToCustom (Emph lst) = callFunc "Emph" lst
inlineToCustom lua (Strong lst) = callfunc lua "Strong" lst inlineToCustom (Strong lst) = callFunc "Strong" lst
inlineToCustom lua (Strikeout lst) = callfunc lua "Strikeout" lst inlineToCustom (Strikeout lst) = callFunc "Strikeout" lst
inlineToCustom lua (Superscript lst) = callfunc lua "Superscript" lst inlineToCustom (Superscript lst) = callFunc "Superscript" lst
inlineToCustom lua (Subscript lst) = callfunc lua "Subscript" lst inlineToCustom (Subscript lst) = callFunc "Subscript" lst
inlineToCustom lua (SmallCaps lst) = callfunc lua "SmallCaps" lst inlineToCustom (SmallCaps lst) = callFunc "SmallCaps" lst
inlineToCustom lua (Quoted SingleQuote lst) = callfunc lua "SingleQuoted" lst inlineToCustom (Quoted SingleQuote lst) = callFunc "SingleQuoted" lst
inlineToCustom lua (Quoted DoubleQuote lst) = callfunc lua "DoubleQuoted" lst inlineToCustom (Quoted DoubleQuote lst) = callFunc "DoubleQuoted" lst
inlineToCustom lua (Cite cs lst) = callfunc lua "Cite" lst cs inlineToCustom (Cite cs lst) = callFunc "Cite" lst cs
inlineToCustom lua (Code attr str) = inlineToCustom (Code attr str) =
callfunc lua "Code" str (attrToMap attr) callFunc "Code" str (attrToMap attr)
inlineToCustom lua (Math DisplayMath str) = inlineToCustom (Math DisplayMath str) =
callfunc lua "DisplayMath" str callFunc "DisplayMath" str
inlineToCustom lua (Math InlineMath str) = inlineToCustom (Math InlineMath str) =
callfunc lua "InlineMath" str callFunc "InlineMath" str
inlineToCustom lua (RawInline format str) = inlineToCustom (RawInline format str) =
callfunc lua "RawInline" format str callFunc "RawInline" format str
inlineToCustom lua (LineBreak) = callfunc lua "LineBreak" inlineToCustom (LineBreak) = callFunc "LineBreak"
inlineToCustom lua (Link attr txt (src,tit)) = inlineToCustom (Link attr txt (src,tit)) =
callfunc lua "Link" txt src tit (attrToMap attr) callFunc "Link" txt src tit (attrToMap attr)
inlineToCustom lua (Image attr alt (src,tit)) = inlineToCustom (Image attr alt (src,tit)) =
callfunc lua "Image" alt src tit (attrToMap attr) callFunc "Image" alt src tit (attrToMap attr)
inlineToCustom lua (Note contents) = callfunc lua "Note" contents inlineToCustom (Note contents) = callFunc "Note" contents
inlineToCustom lua (Span attr items) = inlineToCustom (Span attr items) =
callfunc lua "Span" items (attrToMap attr) callFunc "Span" items (attrToMap attr)

2
stack.full.yaml
View file

@ -20,6 +20,6 @@ packages:
- '../pandoc-types' - '../pandoc-types'
- '../texmath' - '../texmath'
extra-deps: extra-deps:
- hslua-0.5.0 - hslua-0.7.0
- skylighting-0.3.3 - skylighting-0.3.3
resolver: lts-8.12 resolver: lts-8.12

2
stack.pkg.yaml
View file

@ -17,7 +17,7 @@ packages:
commit: 2e27f5cb40577c9b3ffe0fc112687084f3d9d877 commit: 2e27f5cb40577c9b3ffe0fc112687084f3d9d877
extra-dep: false extra-dep: false
extra-deps: extra-deps:
- hslua-0.5.0 - hslua-0.7.0
- skylighting-0.3.3 - skylighting-0.3.3
- cmark-gfm-0.1.1 - cmark-gfm-0.1.1
- QuickCheck-2.10.0.1 - QuickCheck-2.10.0.1

2
stack.yaml
View file

@ -7,7 +7,7 @@ flags:
packages: packages:
- '.' - '.'
extra-deps: extra-deps:
- hslua-0.5.0 - hslua-0.7.0
- skylighting-0.3.3 - skylighting-0.3.3
- cmark-gfm-0.1.1 - cmark-gfm-0.1.1
- QuickCheck-2.10.0.1 - QuickCheck-2.10.0.1

31
test/Tests/Lua.hs
View file

@ -13,7 +13,7 @@ import Text.Pandoc.Builder ( (<>), bulletList, doc, doubleQuoted, emph
, space, str, strong) , space, str, strong)
import Text.Pandoc.Lua import Text.Pandoc.Lua
import qualified Scripting.Lua as Lua import Foreign.Lua
tests :: [TestTree] tests :: [TestTree]
tests = map (localOption (QuickCheckTests 20)) tests = map (localOption (QuickCheckTests 20))
@ -71,23 +71,20 @@ assertFilterConversion msg filterPath docIn docExpected = do
docRes <- runLuaFilter Nothing ("lua" </> filterPath) [] docIn docRes <- runLuaFilter Nothing ("lua" </> filterPath) [] docIn
assertEqual msg docExpected docRes assertEqual msg docExpected docRes
roundtripEqual :: (Eq a, Lua.StackValue a) => a -> IO Bool roundtripEqual :: (Eq a, FromLuaStack a, ToLuaStack a) => a -> IO Bool
roundtripEqual x = (x ==) <$> roundtripped roundtripEqual x = (x ==) <$> roundtripped
where where
roundtripped :: (Lua.StackValue a) => IO a roundtripped :: (FromLuaStack a, ToLuaStack a) => IO a
roundtripped = do roundtripped = runLua $ do
lua <- Lua.newstate openlibs
Lua.openlibs lua pushPandocModule Nothing
pushPandocModule Nothing lua setglobal "pandoc"
Lua.setglobal lua "pandoc" oldSize <- gettop
oldSize <- Lua.gettop lua push x
Lua.push lua x size <- gettop
size <- Lua.gettop lua
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)
res <- Lua.peek lua (-1) res <- peekEither (-1)
retval <- case res of case res of
Nothing -> error "could not read from stack" Left _ -> error "could not read from stack"
Just y -> return y Right y -> return y
Lua.close lua
return retval