From 2dc3dbd68b557cbd8974b9daf84df3d26ab5f843 Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Sun, 13 Aug 2017 12:37:10 +0200 Subject: Use hslua >= 0.7, update Lua code --- pandoc.cabal | 5 +- src/Text/Pandoc/Lua.hs | 181 ++++++++------- src/Text/Pandoc/Lua/Compat.hs | 40 ---- src/Text/Pandoc/Lua/PandocModule.hs | 24 +- src/Text/Pandoc/Lua/SharedInstances.hs | 82 +------ src/Text/Pandoc/Lua/StackInstances.hs | 407 +++++++++++++++++---------------- src/Text/Pandoc/Lua/Util.hs | 102 ++++----- src/Text/Pandoc/Writers/Custom.hs | 237 +++++++++---------- stack.full.yaml | 2 +- stack.pkg.yaml | 2 +- stack.yaml | 2 +- test/Tests/Lua.hs | 31 ++- 12 files changed, 478 insertions(+), 637 deletions(-) delete mode 100644 src/Text/Pandoc/Lua/Compat.hs diff --git a/pandoc.cabal b/pandoc.cabal index 39a390dd6..988f253cd 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -317,7 +317,7 @@ Library yaml >= 0.8.8.2 && < 0.9, scientific >= 0.2 && < 0.4, vector >= 0.10 && < 0.13, - hslua >= 0.4 && < 0.6, + hslua >= 0.7 && < 0.8, binary >= 0.5 && < 0.9, SHA >= 1.6 && < 1.7, haddock-library >= 1.1 && < 1.5, @@ -464,7 +464,6 @@ Library Text.Pandoc.Readers.Org.ParserState, Text.Pandoc.Readers.Org.Parsing, Text.Pandoc.Readers.Org.Shared, - Text.Pandoc.Lua.Compat, Text.Pandoc.Lua.PandocModule, Text.Pandoc.Lua.SharedInstances, Text.Pandoc.Lua.StackInstances, @@ -545,7 +544,7 @@ Test-Suite test-pandoc text >= 0.11 && < 1.3, directory >= 1 && < 1.4, filepath >= 1.1 && < 1.5, - hslua >= 0.4 && < 0.6, + hslua >= 0.7 && < 0.8, process >= 1.2.3 && < 1.7, skylighting >= 0.3.3 && < 0.4, temporary >= 1.1 && < 1.3, diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index 22b68d5e0..c5770a18b 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -41,14 +41,16 @@ import Data.Data (toConstr, showConstr, dataTypeOf, dataTypeConstrs, Data) import Data.Map (Map) import Data.Maybe (isJust) 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.Lua.PandocModule (pushPandocModule) import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Walk import qualified Data.Map as Map -import qualified Scripting.Lua as Lua newtype LuaException = LuaException String deriving (Show, Typeable) @@ -57,123 +59,120 @@ instance Exception LuaException runLuaFilter :: (MonadIO m) => Maybe FilePath -> FilePath -> [String] -> Pandoc -> m Pandoc -runLuaFilter datadir filterPath args pd = liftIO $ do - lua <- Lua.newstate - Lua.openlibs lua +runLuaFilter datadir filterPath args pd = liftIO . runLua $ do + openlibs -- store module in global "pandoc" - pushPandocModule datadir lua - Lua.setglobal lua "pandoc" - top <- Lua.gettop lua - status <- Lua.loadfile lua filterPath - if status /= 0 + pushPandocModule datadir + setglobal "pandoc" + top <- gettop + stat<- dofile filterPath + if stat /= OK then do - Just luaErrMsg <- Lua.peek lua 1 - throwIO (LuaException luaErrMsg) + luaErrMsg <- peek (-1) <* pop 1 + throwLuaError luaErrMsg else do - Lua.call lua 0 Lua.multret - newtop <- Lua.gettop lua + newtop <- gettop -- Use the implicitly defined global filter if nothing was returned - when (newtop - top < 1) $ pushGlobalFilter lua - Just luaFilters <- Lua.peek lua (-1) - Lua.push lua args - Lua.setglobal lua "PandocParameters" - doc <- runAll luaFilters pd - Lua.close lua - return doc - -pushGlobalFilter :: LuaState -> IO () -pushGlobalFilter lua = - Lua.newtable lua - *> Lua.getglobal2 lua "pandoc.global_filter" - *> Lua.call lua 0 1 - *> Lua.rawseti lua (-2) 1 - -runAll :: [LuaFilter] -> Pandoc -> IO Pandoc + when (newtop - top < 1) $ pushGlobalFilter + luaFilters <- peek (-1) + push args + setglobal "PandocParameters" + runAll luaFilters pd + +pushGlobalFilter :: Lua () +pushGlobalFilter = do + newtable + getglobal' "pandoc.global_filter" + call 0 1 + rawseti (-2) 1 + +runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc runAll = foldr ((>=>) . walkMWithLuaFilter) return -walkMWithLuaFilter :: LuaFilter -> Pandoc -> IO Pandoc -walkMWithLuaFilter (LuaFilter lua fnMap) = - (if hasOneOf (constructorsFor (dataTypeOf (Str []))) - then walkM (tryFilter lua fnMap :: Inline -> IO Inline) - else return) - >=> - (if hasOneOf (constructorsFor (dataTypeOf (Para []))) - then walkM (tryFilter lua fnMap :: Block -> IO Block) - else return) - >=> - (case Map.lookup "Meta" fnMap of - Just fn -> walkM (\(Pandoc meta blocks) -> do - meta' <- runFilterFunction lua fn meta - return $ Pandoc meta' blocks) - Nothing -> return) - >=> - (case Map.lookup "Pandoc" fnMap `mplus` Map.lookup "Doc" fnMap of - Just fn -> (runFilterFunction lua fn) :: Pandoc -> IO Pandoc - Nothing -> return) - where hasOneOf = any (\k -> isJust (Map.lookup k fnMap)) - constructorsFor x = map show (dataTypeConstrs x) +walkMWithLuaFilter :: LuaFilter -> Pandoc -> Lua Pandoc +walkMWithLuaFilter (LuaFilter fnMap) = liftLua1 walkLua + where + walkLua :: LuaState -> Pandoc -> IO Pandoc + walkLua l = + (if hasOneOf (constructorsFor (dataTypeOf (Str []))) + then walkM (runLuaWith l . (tryFilter fnMap :: Inline -> Lua Inline)) + else return) + >=> + (if hasOneOf (constructorsFor (dataTypeOf (Para []))) + then walkM ((runLuaWith l . (tryFilter fnMap :: Block -> Lua Block))) + else return) + >=> + (case Map.lookup "Meta" fnMap of + Just fn -> walkM ((\(Pandoc meta blocks) -> runLuaWith l $ do + meta' <- runFilterFunction fn meta + return $ Pandoc meta' blocks)) + Nothing -> return) + >=> + (case Map.lookup "Pandoc" fnMap `mplus` Map.lookup "Doc" fnMap of + Just fn -> runLuaWith l . (runFilterFunction fn :: Pandoc -> Lua Pandoc) + Nothing -> return) + hasOneOf = any (\k -> isJust (Map.lookup k fnMap)) + constructorsFor x = map show (dataTypeConstrs x) type FunctionMap = Map String LuaFilterFunction -data LuaFilter = LuaFilter LuaState FunctionMap +data LuaFilter = LuaFilter FunctionMap newtype LuaFilterFunction = LuaFilterFunction { functionIndex :: Int } -tryFilter :: (Data a, StackValue a) => LuaState -> FunctionMap -> a -> IO a -tryFilter lua fnMap x = +-- | Try running a filter for the given element +tryFilter :: (Data a, FromLuaStack a, ToLuaStack a) => FunctionMap -> a -> Lua a +tryFilter fnMap x = let filterFnName = showConstr (toConstr x) in case Map.lookup filterFnName fnMap of Nothing -> return x - Just fn -> runFilterFunction lua fn x + Just fn -> runFilterFunction fn x -instance StackValue LuaFilter where - valuetype _ = Lua.TTABLE - push = undefined - peek lua idx = fmap (LuaFilter lua) <$> Lua.peek lua idx +instance FromLuaStack LuaFilter where + peek idx = LuaFilter <$> peek idx -- | Push a value to the stack via a lua filter function. The filter function is -- called with given element as argument and is expected to return an element. -- Alternatively, the function can return nothing or nil, in which case the -- element is left unchanged. -runFilterFunction :: StackValue a => LuaState -> LuaFilterFunction -> a -> IO a -runFilterFunction lua lf x = do - pushFilterFunction lua lf - Lua.push lua x - z <- Lua.pcall lua 1 1 0 - if (z /= 0) +runFilterFunction :: (FromLuaStack a, ToLuaStack a) + => LuaFilterFunction -> a -> Lua a +runFilterFunction lf x = do + pushFilterFunction lf + push x + z <- pcall 1 1 Nothing + if z /= OK then do - msg <- Lua.peek lua (-1) + msg <- peek (-1) let prefix = "Error while running filter function: " - throwIO . LuaException $ - case msg of - Nothing -> prefix ++ "could not read error message" - Just msg' -> prefix ++ msg' + throwLuaError $ prefix ++ msg else do - resType <- Lua.ltype lua (-1) + resType <- ltype (-1) case resType of - Lua.TNIL -> Lua.pop lua 1 *> return x - _ -> do - mbres <- Lua.peek lua (-1) + TypeNil -> pop 1 *> return x + _ -> do + mbres <- peekEither (-1) case mbres of - Nothing -> throwIO $ LuaException - ("Error while trying to get a filter's return " - ++ "value from lua stack.") - Just res -> res <$ Lua.pop lua 1 + Left err -> throwLuaError + ("Error while trying to get a filter's return " + ++ "value from lua stack.\n" ++ err) + Right res -> res <$ pop 1 -- | Push the filter function to the top of the stack. -pushFilterFunction :: Lua.LuaState -> LuaFilterFunction -> IO () -pushFilterFunction lua lf = +pushFilterFunction :: LuaFilterFunction -> Lua () +pushFilterFunction lf = -- The function is stored in a lua registry table, retrieve it from there. - Lua.rawgeti lua Lua.registryindex (functionIndex lf) - -registerFilterFunction :: LuaState -> Int -> IO LuaFilterFunction -registerFilterFunction lua idx = do - isFn <- Lua.isfunction lua idx - unless isFn . throwIO . LuaException $ "Not a function at index " ++ show idx - Lua.pushvalue lua idx - refIdx <- Lua.ref lua Lua.registryindex + rawgeti registryindex (functionIndex lf) + +registerFilterFunction :: StackIndex -> Lua LuaFilterFunction +registerFilterFunction idx = do + isFn <- isfunction idx + unless isFn . throwLuaError $ "Not a function at index " ++ show idx + pushvalue idx + refIdx <- ref registryindex return $ LuaFilterFunction refIdx -instance StackValue LuaFilterFunction where - valuetype _ = Lua.TFUNCTION +instance ToLuaStack LuaFilterFunction where push = pushFilterFunction - peek = fmap (fmap Just) . registerFilterFunction + +instance FromLuaStack LuaFilterFunction where + peek = registerFilterFunction diff --git a/src/Text/Pandoc/Lua/Compat.hs b/src/Text/Pandoc/Lua/Compat.hs deleted file mode 100644 index 3fc81a15c..000000000 --- a/src/Text/Pandoc/Lua/Compat.hs +++ /dev/null @@ -1,40 +0,0 @@ -{- -Copyright © 2017 Albert Krewinkel - -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 - 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 diff --git a/src/Text/Pandoc/Lua/PandocModule.hs b/src/Text/Pandoc/Lua/PandocModule.hs index d46ed3629..c8eaf3da0 100644 --- a/src/Text/Pandoc/Lua/PandocModule.hs +++ b/src/Text/Pandoc/Lua/PandocModule.hs @@ -31,31 +31,31 @@ import Control.Monad (unless) import Data.ByteString.Char8 (unpack) import Data.Default (Default (..)) 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.Definition (Pandoc) import Text.Pandoc.Options (ReaderOptions(readerExtensions)) -import Text.Pandoc.Lua.Compat (loadstring) import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Readers (Reader (..), getReader) -- | Push the "pandoc" on the lua stack. -pushPandocModule :: Maybe FilePath -> LuaState -> IO () -pushPandocModule datadir lua = do - script <- pandocModuleScript datadir - status <- loadstring lua script "pandoc.lua" - unless (status /= 0) $ call lua 0 1 - push lua "__read" - pushhsfunction lua read_doc - rawset lua (-3) +pushPandocModule :: Maybe FilePath -> Lua () +pushPandocModule datadir = do + script <- liftIO (pandocModuleScript datadir) + status <- loadstring script + unless (status /= OK) $ call 0 1 + push "__read" + pushHaskellFunction readDoc + rawset (-3) -- | Get the string representation of the pandoc module pandocModuleScript :: Maybe FilePath -> IO String pandocModuleScript datadir = unpack <$> runIOorExplode (setUserDataDir datadir >> readDataFile "pandoc.lua") -read_doc :: String -> String -> IO (Either String Pandoc) -read_doc formatSpec content = do +readDoc :: String -> String -> Lua (Either String Pandoc) +readDoc formatSpec content = liftIO $ do case getReader formatSpec of Left s -> return $ Left s Right (reader, es) -> diff --git a/src/Text/Pandoc/Lua/SharedInstances.hs b/src/Text/Pandoc/Lua/SharedInstances.hs index a5d4ba1e9..e9e72c219 100644 --- a/src/Text/Pandoc/Lua/SharedInstances.hs +++ b/src/Text/Pandoc/Lua/SharedInstances.hs @@ -36,81 +36,9 @@ Shared StackValue instances for pandoc and generic types. -} module Text.Pandoc.Lua.SharedInstances () where -import Scripting.Lua (LTYPE (..), StackValue (..), newtable) -import Text.Pandoc.Lua.Util (addRawInt, addValue, getRawInt, keyValuePairs) +import Foreign.Lua (ToLuaStack (push)) -import qualified Data.Map as M -import qualified Text.Pandoc.UTF8 as UTF8 - -#if MIN_VERSION_base(4,8,0) -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 +instance (ToLuaStack a, ToLuaStack b) => ToLuaStack (Either a b) where + push = \case + Left x -> push x + Right x -> push x diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs index d2e3f630a..4eea5bc2f 100644 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -33,243 +33,244 @@ StackValue instances for pandoc types. module Text.Pandoc.Lua.StackInstances () where import Control.Applicative ((<|>)) -import Scripting.Lua (LTYPE (..), LuaState, StackValue (..), ltype, newtable, - objlen) +import Foreign.Lua (Lua, Type (..), FromLuaStack (peek), ToLuaStack (push), + StackIndex, peekEither, throwLuaError) +import Foreign.Lua.Api (getfield, ltype, newtable, pop, rawlen) import Text.Pandoc.Definition import Text.Pandoc.Lua.SharedInstances () import Text.Pandoc.Lua.Util (addValue, getTable, pushViaConstructor) import Text.Pandoc.Shared (safeRead) -instance StackValue Pandoc where - push lua (Pandoc meta blocks) = do - newtable lua - addValue lua "blocks" blocks - addValue lua "meta" meta - peek lua idx = do - blocks <- getTable lua idx "blocks" - meta <- getTable lua idx "meta" - return $ Pandoc <$> meta <*> blocks - valuetype _ = TTABLE - -instance StackValue Meta where - push lua (Meta mmap) = push lua mmap - peek lua idx = fmap Meta <$> peek lua idx - valuetype _ = TTABLE - -instance StackValue MetaValue where +instance ToLuaStack Pandoc where + push (Pandoc meta blocks) = do + newtable + addValue "blocks" blocks + addValue "meta" meta +instance FromLuaStack Pandoc where + peek idx = do + blocks <- getTable idx "blocks" + meta <- getTable idx "meta" + return $ Pandoc meta blocks + +instance ToLuaStack Meta where + push (Meta mmap) = push mmap +instance FromLuaStack Meta where + peek idx = Meta <$> peek idx + +instance ToLuaStack MetaValue where push = pushMetaValue +instance FromLuaStack MetaValue where 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 + +instance FromLuaStack Block where peek = peekBlock - valuetype _ = TTABLE -instance StackValue Inline where +-- Inline +instance ToLuaStack Inline where push = pushInline + +instance FromLuaStack Inline where peek = peekInline - valuetype _ = TTABLE - -instance StackValue Citation where - push lua (Citation cid prefix suffix mode noteNum hash) = - pushViaConstructor lua "Citation" cid mode prefix suffix noteNum hash - peek lua idx = do - 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 - push lua = push lua . show - peek lua idx = (>>= safeRead) <$> peek lua idx - valuetype _ = TSTRING - -instance StackValue CitationMode where - push lua = push lua . show - peek lua idx = (>>= safeRead) <$> peek lua idx - valuetype _ = TSTRING - -instance StackValue Format where - push lua (Format f) = push lua f - peek lua idx = fmap Format <$> peek lua idx - valuetype _ = TSTRING - -instance StackValue ListNumberDelim where - push lua = push lua . show - peek lua idx = (>>= safeRead) <$> peek lua idx - valuetype _ = TSTRING - -instance StackValue ListNumberStyle where - push lua = push lua . show - peek lua idx = (>>= safeRead) <$> peek lua idx - valuetype _ = TSTRING - -instance StackValue MathType where - push lua = push lua . show - peek lua idx = (>>= safeRead) <$> peek lua idx - valuetype _ = TSTRING - -instance StackValue QuoteType where - push lua = push lua . show - peek lua idx = (>>= safeRead) <$> peek lua idx - valuetype _ = TSTRING + +-- Citation +instance ToLuaStack Citation where + push (Citation cid prefix suffix mode noteNum hash) = + pushViaConstructor "Citation" cid mode prefix suffix noteNum hash + +instance FromLuaStack Citation where + peek idx = do + id' <- getTable idx "citationId" + 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 ToLuaStack Alignment where + push = push . show +instance FromLuaStack Alignment where + peek idx = safeRead' =<< peek idx + +instance ToLuaStack CitationMode where + push = push . show +instance FromLuaStack CitationMode where + peek idx = safeRead' =<< peek idx + +instance ToLuaStack Format where + push (Format f) = push f +instance FromLuaStack Format where + peek idx = Format <$> peek idx + +instance ToLuaStack ListNumberDelim where + push = push . show +instance FromLuaStack ListNumberDelim where + peek idx = safeRead' =<< peek idx + +instance ToLuaStack ListNumberStyle where + push = push . show +instance FromLuaStack ListNumberStyle where + peek idx = safeRead' =<< peek idx + +instance ToLuaStack MathType where + push = push . show +instance FromLuaStack MathType where + 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. -pushMetaValue :: LuaState -> MetaValue -> IO () -pushMetaValue lua = \case - MetaBlocks blcks -> pushViaConstructor lua "MetaBlocks" blcks - MetaBool bool -> push lua bool - MetaInlines inlns -> pushViaConstructor lua "MetaInlines" inlns - MetaList metalist -> pushViaConstructor lua "MetaList" metalist - MetaMap metamap -> pushViaConstructor lua "MetaMap" metamap - MetaString str -> push lua str +pushMetaValue :: MetaValue -> Lua () +pushMetaValue = \case + MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks + MetaBool bool -> push bool + MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns + MetaList metalist -> pushViaConstructor "MetaList" metalist + MetaMap metamap -> pushViaConstructor "MetaMap" metamap + MetaString str -> push str -- | Interpret the value at the given stack index as meta value. -peekMetaValue :: LuaState -> Int -> IO (Maybe MetaValue) -peekMetaValue lua idx = do +peekMetaValue :: StackIndex -> Lua MetaValue +peekMetaValue idx = do -- Get the contents of an AST element. - let elementContent :: StackValue a => IO (Maybe a) - elementContent = peek lua idx - luatype <- ltype lua idx + let elementContent :: FromLuaStack a => Lua a + elementContent = peek idx + luatype <- ltype idx case luatype of - TBOOLEAN -> fmap MetaBool <$> peek lua idx - TSTRING -> fmap MetaString <$> peek lua idx - TTABLE -> do - tag <- getTable lua idx "t" + TypeBoolean -> MetaBool <$> peek idx + TypeString -> MetaString <$> peek idx + TypeTable -> do + tag <- getfield idx "t" *> peekEither (-1) <* pop 1 case tag of - Just "MetaBlocks" -> fmap MetaBlocks <$> elementContent - Just "MetaBool" -> fmap MetaBool <$> elementContent - Just "MetaMap" -> fmap MetaMap <$> elementContent - Just "MetaInlines" -> fmap MetaInlines <$> elementContent - Just "MetaList" -> fmap MetaList <$> elementContent - Just "MetaString" -> fmap MetaString <$> elementContent - Nothing -> do + Right "MetaBlocks" -> MetaBlocks <$> elementContent + Right "MetaBool" -> MetaBool <$> elementContent + Right "MetaMap" -> MetaMap <$> elementContent + Right "MetaInlines" -> MetaInlines <$> elementContent + Right "MetaList" -> MetaList <$> elementContent + Right "MetaString" -> MetaString <$> elementContent + Right t -> throwLuaError ("Unknown meta tag: " ++ t) + Left _ -> do -- no meta value tag given, try to guess. - len <- objlen lua idx + len <- rawlen idx if len <= 0 - then fmap MetaMap <$> peek lua idx - else (fmap MetaInlines <$> peek lua idx) - <|> (fmap MetaBlocks <$> peek lua idx) - <|> (fmap MetaList <$> peek lua idx) - _ -> return Nothing - _ -> return Nothing + then MetaMap <$> peek idx + else (MetaInlines <$> peek idx) + <|> (MetaBlocks <$> peek idx) + <|> (MetaList <$> peek idx) + _ -> throwLuaError ("could not get meta value") -- | Push an block element to the top of the lua stack. -pushBlock :: LuaState -> Block -> IO () -pushBlock lua = \case - BlockQuote blcks -> pushViaConstructor lua "BlockQuote" blcks - BulletList items -> pushViaConstructor lua "BulletList" items - CodeBlock attr code -> pushViaConstructor lua "CodeBlock" code (LuaAttr attr) - DefinitionList items -> pushViaConstructor lua "DefinitionList" items - Div attr blcks -> pushViaConstructor lua "Div" blcks (LuaAttr attr) - Header lvl attr inlns -> pushViaConstructor lua "Header" lvl inlns (LuaAttr attr) - HorizontalRule -> pushViaConstructor lua "HorizontalRule" - LineBlock blcks -> pushViaConstructor lua "LineBlock" blcks - OrderedList lstAttr list -> pushViaConstructor lua "OrderedList" list lstAttr - Null -> pushViaConstructor lua "Null" - Para blcks -> pushViaConstructor lua "Para" blcks - Plain blcks -> pushViaConstructor lua "Plain" blcks - RawBlock f cs -> pushViaConstructor lua "RawBlock" f cs +pushBlock :: Block -> Lua () +pushBlock = \case + BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks + BulletList items -> pushViaConstructor "BulletList" items + CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr) + DefinitionList items -> pushViaConstructor "DefinitionList" items + Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr) + Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr) + HorizontalRule -> pushViaConstructor "HorizontalRule" + LineBlock blcks -> pushViaConstructor "LineBlock" blcks + OrderedList lstAttr list -> pushViaConstructor "OrderedList" list lstAttr + Null -> pushViaConstructor "Null" + Para blcks -> pushViaConstructor "Para" blcks + Plain blcks -> pushViaConstructor "Plain" blcks + RawBlock f cs -> pushViaConstructor "RawBlock" f cs 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. -peekBlock :: LuaState -> Int -> IO (Maybe Block) -peekBlock lua idx = do - tag <- getTable lua idx "t" +peekBlock :: StackIndex -> Lua Block +peekBlock idx = do + tag <- getTable idx "t" case tag of - Nothing -> return Nothing - Just t -> case t of - "BlockQuote" -> fmap BlockQuote <$> elementContent - "BulletList" -> fmap BulletList <$> elementContent - "CodeBlock" -> fmap (withAttr CodeBlock) <$> elementContent - "DefinitionList" -> fmap DefinitionList <$> elementContent - "Div" -> fmap (withAttr Div) <$> elementContent - "Header" -> fmap (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst) + "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 (Just HorizontalRule) - "LineBlock" -> fmap LineBlock <$> elementContent - "OrderedList" -> fmap (uncurry OrderedList) <$> elementContent - "Null" -> return (Just Null) - "Para" -> fmap Para <$> elementContent - "Plain" -> fmap Plain <$> elementContent - "RawBlock" -> fmap (uncurry RawBlock) <$> elementContent - "Table" -> fmap (\(capt, aligns, widths, headers, body) -> + "HorizontalRule" -> return HorizontalRule + "LineBlock" -> LineBlock <$> elementContent + "OrderedList" -> (uncurry OrderedList) <$> elementContent + "Null" -> return Null + "Para" -> Para <$> elementContent + "Plain" -> Plain <$> elementContent + "RawBlock" -> (uncurry RawBlock) <$> elementContent + "Table" -> (\(capt, aligns, widths, headers, body) -> Table capt aligns widths headers body) <$> elementContent - _ -> return Nothing + _ -> throwLuaError ("Unknown block type: " ++ tag) where -- Get the contents of an AST element. - elementContent :: StackValue a => IO (Maybe a) - elementContent = getTable lua idx "c" + elementContent :: FromLuaStack a => Lua a + elementContent = getTable idx "c" -- | Push an inline element to the top of the lua stack. -pushInline :: LuaState -> Inline -> IO () -pushInline lua = \case - Cite citations lst -> pushViaConstructor lua "Cite" lst citations - Code attr lst -> pushViaConstructor lua "Code" lst (LuaAttr attr) - Emph inlns -> pushViaConstructor lua "Emph" inlns - Image attr alt (src,tit) -> pushViaConstructor lua "Image" alt src tit (LuaAttr attr) - LineBreak -> pushViaConstructor lua "LineBreak" - Link attr lst (src,tit) -> pushViaConstructor lua "Link" lst src tit (LuaAttr attr) - Note blcks -> pushViaConstructor lua "Note" blcks - Math mty str -> pushViaConstructor lua "Math" mty str - Quoted qt inlns -> pushViaConstructor lua "Quoted" qt inlns - RawInline f cs -> pushViaConstructor lua "RawInline" f cs - SmallCaps inlns -> pushViaConstructor lua "SmallCaps" inlns - SoftBreak -> pushViaConstructor lua "SoftBreak" - Space -> pushViaConstructor lua "Space" - Span attr inlns -> pushViaConstructor lua "Span" inlns (LuaAttr attr) - Str str -> pushViaConstructor lua "Str" str - Strikeout inlns -> pushViaConstructor lua "Strikeout" inlns - Strong inlns -> pushViaConstructor lua "Strong" inlns - Subscript inlns -> pushViaConstructor lua "Subscript" inlns - Superscript inlns -> pushViaConstructor lua "Superscript" inlns +pushInline :: Inline -> Lua () +pushInline = \case + Cite citations lst -> pushViaConstructor "Cite" lst citations + Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr) + Emph inlns -> pushViaConstructor "Emph" inlns + Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr) + LineBreak -> pushViaConstructor "LineBreak" + Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr) + Note blcks -> pushViaConstructor "Note" blcks + Math mty str -> pushViaConstructor "Math" mty str + Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns + RawInline f cs -> pushViaConstructor "RawInline" f cs + SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns + SoftBreak -> pushViaConstructor "SoftBreak" + Space -> pushViaConstructor "Space" + Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr) + Str str -> pushViaConstructor "Str" str + Strikeout inlns -> pushViaConstructor "Strikeout" inlns + Strong inlns -> pushViaConstructor "Strong" inlns + Subscript inlns -> pushViaConstructor "Subscript" inlns + Superscript inlns -> pushViaConstructor "Superscript" inlns -- | Return the value at the given index as inline if possible. -peekInline :: LuaState -> Int -> IO (Maybe Inline) -peekInline lua idx = do - tag <- getTable lua idx "t" +peekInline :: StackIndex -> Lua Inline +peekInline idx = do + tag <- getTable idx "t" case tag of - Nothing -> return Nothing - Just t -> case t of - "Cite" -> fmap (uncurry Cite) <$> elementContent - "Code" -> fmap (withAttr Code) <$> elementContent - "Emph" -> fmap Emph <$> elementContent - "Image" -> fmap (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt) - <$> elementContent - "Link" -> fmap (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt) - <$> elementContent - "LineBreak" -> return (Just LineBreak) - "Note" -> fmap Note <$> elementContent - "Math" -> fmap (uncurry Math) <$> elementContent - "Quoted" -> fmap (uncurry Quoted) <$> elementContent - "RawInline" -> fmap (uncurry RawInline) <$> elementContent - "SmallCaps" -> fmap SmallCaps <$> elementContent - "SoftBreak" -> return (Just SoftBreak) - "Space" -> return (Just Space) - "Span" -> fmap (withAttr Span) <$> elementContent - "Str" -> fmap Str <$> elementContent - "Strikeout" -> fmap Strikeout <$> elementContent - "Strong" -> fmap Strong <$> elementContent - "Subscript" -> fmap Subscript <$> elementContent - "Superscript"-> fmap Superscript <$> elementContent - _ -> return Nothing + "Cite" -> (uncurry Cite) <$> elementContent + "Code" -> (withAttr Code) <$> elementContent + "Emph" -> Emph <$> elementContent + "Image" -> (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt) + <$> elementContent + "Link" -> (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt) + <$> elementContent + "LineBreak" -> return LineBreak + "Note" -> Note <$> elementContent + "Math" -> (uncurry Math) <$> elementContent + "Quoted" -> (uncurry Quoted) <$> elementContent + "RawInline" -> (uncurry RawInline) <$> elementContent + "SmallCaps" -> SmallCaps <$> elementContent + "SoftBreak" -> return SoftBreak + "Space" -> return Space + "Span" -> (withAttr Span) <$> elementContent + "Str" -> Str <$> elementContent + "Strikeout" -> Strikeout <$> elementContent + "Strong" -> Strong <$> elementContent + "Subscript" -> Subscript <$> elementContent + "Superscript"-> Superscript <$> elementContent + _ -> throwLuaError ("Unknown inline type: " ++ tag) where -- Get the contents of an AST element. - elementContent :: StackValue a => IO (Maybe a) - elementContent = getTable lua idx "c" + elementContent :: FromLuaStack a => Lua a + elementContent = getTable idx "c" withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b withAttr f (attributes, x) = f (fromLuaAttr attributes) x @@ -277,8 +278,8 @@ withAttr f (attributes, x) = f (fromLuaAttr attributes) x -- | Wrapper for Attr newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr } -instance StackValue LuaAttr where - push lua (LuaAttr (id', classes, kv)) = - pushViaConstructor lua "Attr" id' classes kv - peek lua idx = fmap LuaAttr <$> peek lua idx - valuetype _ = TTABLE +instance ToLuaStack LuaAttr where + push (LuaAttr (id', classes, kv)) = + pushViaConstructor "Attr" id' classes kv +instance FromLuaStack LuaAttr where + peek idx = LuaAttr <$> peek idx diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index 0a704d027..9e72b652c 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -36,103 +36,79 @@ module Text.Pandoc.Lua.Util , getRawInt , setRawInt , addRawInt - , keyValuePairs , PushViaCall , pushViaCall , pushViaConstructor ) where -import Scripting.Lua (LuaState, StackValue (..), call, getglobal2, gettable, - next, pop, pushnil, rawgeti, rawseti, settable) +import Foreign.Lua (Lua, FromLuaStack (..), ToLuaStack (..), NumArgs, + 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 -- the stack. -adjustIndexBy :: Int -> Int -> Int +adjustIndexBy :: StackIndex -> StackIndex -> StackIndex adjustIndexBy idx n = if idx < 0 then idx - n else idx -- | Get value behind key from table at given index. -getTable :: (StackValue a, StackValue b) => LuaState -> Int -> a -> IO (Maybe b) -getTable lua idx key = do - push lua key - gettable lua (idx `adjustIndexBy` 1) - peek lua (-1) <* pop lua 1 +getTable :: (ToLuaStack a, FromLuaStack b) => StackIndex -> a -> Lua b +getTable idx key = do + push key + gettable (idx `adjustIndexBy` 1) + peek (-1) <* pop 1 -- | Set value for key for table at the given index -setTable :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO () -setTable lua idx key value = do - push lua key - push lua value - settable lua (idx `adjustIndexBy` 2) +setTable :: (ToLuaStack a, ToLuaStack b) => StackIndex -> a -> b -> Lua () +setTable idx key value = do + push key + push value + settable (idx `adjustIndexBy` 2) -- | Add a key-value pair to the table at the top of the stack -addValue :: (StackValue a, StackValue b) => LuaState -> a -> b -> IO () -addValue lua = setTable lua (-1) +addValue :: (ToLuaStack a, ToLuaStack b) => a -> b -> Lua () +addValue = setTable (-1) -- | Get value behind key from table at given index. -getRawInt :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a) -getRawInt lua idx key = - rawgeti lua idx key - *> peek lua (-1) - <* pop lua 1 +getRawInt :: FromLuaStack a => StackIndex -> Int -> Lua a +getRawInt idx key = + rawgeti idx key + *> peek (-1) + <* pop 1 -- | Set numeric key/value in table at the given index -setRawInt :: StackValue a => LuaState -> Int -> Int -> a -> IO () -setRawInt lua idx key value = do - push lua value - rawseti lua (idx `adjustIndexBy` 1) key +setRawInt :: ToLuaStack a => StackIndex -> Int -> a -> Lua () +setRawInt idx key value = do + push value + rawseti (idx `adjustIndexBy` 1) key -- | Set numeric key/value in table at the top of the stack. -addRawInt :: StackValue a => LuaState -> Int -> a -> IO () -addRawInt lua = setRawInt lua (-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 +addRawInt :: ToLuaStack a => Int -> a -> Lua () +addRawInt = setRawInt (-1) -- | Helper class for pushing a single value to the stack via a lua function. -- See @pushViaCall@. class PushViaCall a where - pushViaCall' :: LuaState -> String -> IO () -> Int -> a + pushViaCall' :: String -> Lua () -> NumArgs -> a -instance PushViaCall (IO ()) where - pushViaCall' lua fn pushArgs num = do - getglobal2 lua fn +instance PushViaCall (Lua ()) where + pushViaCall' fn pushArgs num = do + getglobal' fn pushArgs - call lua num 1 + call num 1 -instance (StackValue a, PushViaCall b) => PushViaCall (a -> b) where - pushViaCall' lua fn pushArgs num x = - pushViaCall' lua fn (pushArgs *> push lua x) (num + 1) +instance (ToLuaStack a, PushViaCall b) => PushViaCall (a -> b) where + pushViaCall' fn pushArgs num x = + pushViaCall' fn (pushArgs *> push x) (num + 1) -- | Push an value to the stack via a lua function. The lua function is called -- with all arguments that are passed to this function and is expected to return -- a single value. -pushViaCall :: PushViaCall a => LuaState -> String -> a -pushViaCall lua fn = pushViaCall' lua fn (return ()) 0 +pushViaCall :: PushViaCall a => String -> a +pushViaCall fn = pushViaCall' fn (return ()) 0 -- | Call a pandoc element constructor within lua, passing all given arguments. -pushViaConstructor :: PushViaCall a => LuaState -> String -> a -pushViaConstructor lua pandocFn = pushViaCall lua ("pandoc." ++ pandocFn) +pushViaConstructor :: PushViaCall a => String -> a +pushViaConstructor pandocFn = pushViaCall ("pandoc." ++ pandocFn) diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 363bad99b..485394187 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -44,10 +44,9 @@ import qualified Data.Map as M import Data.Text (Text, pack) import Data.Typeable import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8) -import Scripting.Lua (LuaState, StackValue, callfunc) -import qualified Scripting.Lua as Lua +import Foreign.Lua (Lua, ToLuaStack (..), callFunc, runLua) +import Foreign.Lua.Api import Text.Pandoc.Error -import Text.Pandoc.Lua.Compat ( loadstring ) import Text.Pandoc.Lua.Util ( addValue ) import Text.Pandoc.Lua.SharedInstances () import Text.Pandoc.Definition @@ -62,55 +61,40 @@ attrToMap (id',classes,keyvals) = M.fromList : ("class", unwords classes) : keyvals -instance StackValue Format where - push lua (Format f) = Lua.push lua (map toLower f) - peek l n = fmap Format `fmap` Lua.peek l n - valuetype _ = Lua.TSTRING +instance ToLuaStack Format where + push (Format f) = push (map toLower f) #if MIN_VERSION_base(4,8,0) -instance {-# OVERLAPS #-} StackValue [Inline] where +instance {-# OVERLAPS #-} ToLuaStack [Inline] where #else -instance StackValue [Inline] where +instance ToLuaStack [Inline] where #endif - push l ils = Lua.push l =<< inlineListToCustom l ils - peek _ _ = undefined - valuetype _ = Lua.TSTRING + push ils = push =<< inlineListToCustom ils #if MIN_VERSION_base(4,8,0) -instance {-# OVERLAPS #-} StackValue [Block] where +instance {-# OVERLAPS #-} ToLuaStack [Block] where #else -instance StackValue [Block] where +instance ToLuaStack [Block] where #endif - push l ils = Lua.push l =<< blockListToCustom l ils - peek _ _ = undefined - valuetype _ = Lua.TSTRING - -instance StackValue MetaValue where - push l (MetaMap m) = Lua.push l m - push l (MetaList xs) = Lua.push l xs - push l (MetaBool x) = Lua.push l x - push l (MetaString s) = Lua.push l s - push l (MetaInlines ils) = Lua.push l ils - push l (MetaBlocks bs) = Lua.push l 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 - push lua cit = do - Lua.createtable lua 6 0 - addValue lua "citationId" $ citationId cit - addValue lua "citationPrefix" $ citationPrefix cit - addValue lua "citationSuffix" $ citationSuffix cit - addValue lua "citationMode" $ show (citationMode cit) - addValue lua "citationNoteNum" $ citationNoteNum cit - addValue lua "citationHash" $ citationHash cit - peek = undefined - valuetype _ = Lua.TTABLE + push ils = push =<< blockListToCustom ils + +instance ToLuaStack MetaValue where + push (MetaMap m) = push m + push (MetaList xs) = push xs + push (MetaBool x) = push x + push (MetaString s) = push s + push (MetaInlines ils) = push ils + push (MetaBlocks bs) = push bs + +instance ToLuaStack Citation where + push cit = do + createtable 6 0 + addValue "citationId" $ citationId cit + addValue "citationPrefix" $ citationPrefix cit + addValue "citationSuffix" $ citationSuffix cit + addValue "citationMode" $ show (citationMode cit) + addValue "citationNoteNum" $ citationNoteNum cit + addValue "citationHash" $ citationHash cit data PandocLuaException = PandocLuaException String deriving (Show, Typeable) @@ -123,23 +107,22 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do luaScript <- UTF8.readFile luaFile enc <- getForeignEncoding setForeignEncoding utf8 - lua <- Lua.newstate - Lua.openlibs lua - status <- loadstring lua luaScript luaFile - -- check for error in lua script (later we'll change the return type - -- to handle this more gracefully): - when (status /= 0) $ - Lua.tostring lua 1 >>= throw . PandocLuaException . UTF8.toString - Lua.call lua 0 0 + (body, context) <- runLua $ do + openlibs + stat <- loadstring luaScript + -- check for error in lua script (later we'll change the return type + -- to handle this more gracefully): + when (stat /= OK) $ + tostring 1 >>= throw . PandocLuaException . UTF8.toString + call 0 0 -- TODO - call hierarchicalize, so we have that info - rendered <- docToCustom lua opts doc - context <- metaToJSON opts - (blockListToCustom lua) - (inlineListToCustom lua) - meta - Lua.close lua + rendered <- docToCustom opts doc + context <- metaToJSON opts + blockListToCustom + inlineListToCustom + meta + return (rendered, context) setForeignEncoding enc - let body = rendered case writerTemplate opts of Nothing -> return $ pack body Just tpl -> @@ -147,117 +130,115 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do Left e -> throw (PandocTemplateError e) Right r -> return (pack r) -docToCustom :: LuaState -> WriterOptions -> Pandoc -> IO String -docToCustom lua opts (Pandoc (Meta metamap) blocks) = do - body <- blockListToCustom lua blocks - callfunc lua "Doc" body metamap (writerVariables opts) +docToCustom :: WriterOptions -> Pandoc -> Lua String +docToCustom opts (Pandoc (Meta metamap) blocks) = do + body <- blockListToCustom blocks + callFunc "Doc" body metamap (writerVariables opts) -- | Convert Pandoc block element to Custom. -blockToCustom :: LuaState -- ^ Lua state - -> Block -- ^ Block element - -> IO String +blockToCustom :: Block -- ^ Block element + -> Lua 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)]) = - callfunc lua "CaptionedImage" src tit txt (attrToMap attr) +blockToCustom (Para [Image attr txt (src,tit)]) = + 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) = - callfunc lua "RawBlock" format str +blockToCustom (RawBlock format str) = + callFunc "RawBlock" format str -blockToCustom lua HorizontalRule = callfunc lua "HorizontalRule" +blockToCustom HorizontalRule = callFunc "HorizontalRule" -blockToCustom lua (Header level attr inlines) = - callfunc lua "Header" level inlines (attrToMap attr) +blockToCustom (Header level attr inlines) = + callFunc "Header" level inlines (attrToMap attr) -blockToCustom lua (CodeBlock attr str) = - callfunc lua "CodeBlock" str (attrToMap attr) +blockToCustom (CodeBlock attr str) = + 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') = - callfunc lua "Table" capt (map show aligns) widths headers rows' +blockToCustom (Table capt 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) = - callfunc lua "OrderedList" items num (show sty) (show delim) +blockToCustom (OrderedList (num,sty,delim) items) = + callFunc "OrderedList" items num (show sty) (show delim) -blockToCustom lua (DefinitionList items) = - callfunc lua "DefinitionList" items +blockToCustom (DefinitionList items) = + callFunc "DefinitionList" items -blockToCustom lua (Div attr items) = - callfunc lua "Div" items (attrToMap attr) +blockToCustom (Div attr items) = + callFunc "Div" items (attrToMap attr) -- | Convert list of Pandoc block elements to Custom. -blockListToCustom :: LuaState -- ^ Options - -> [Block] -- ^ List of block elements - -> IO String -blockListToCustom lua xs = do - blocksep <- callfunc lua "Blocksep" - bs <- mapM (blockToCustom lua) xs +blockListToCustom :: [Block] -- ^ List of block elements + -> Lua String +blockListToCustom xs = do + blocksep <- callFunc "Blocksep" + bs <- mapM blockToCustom xs return $ mconcat $ intersperse blocksep bs -- | Convert list of Pandoc inline elements to Custom. -inlineListToCustom :: LuaState -> [Inline] -> IO String -inlineListToCustom lua lst = do - xs <- mapM (inlineToCustom lua) lst - return $ concat xs +inlineListToCustom :: [Inline] -> Lua String +inlineListToCustom lst = do + xs <- mapM inlineToCustom lst + return $ mconcat xs -- | 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) = - callfunc lua "Code" str (attrToMap attr) +inlineToCustom (Code attr str) = + callFunc "Code" str (attrToMap attr) -inlineToCustom lua (Math DisplayMath str) = - callfunc lua "DisplayMath" str +inlineToCustom (Math DisplayMath str) = + callFunc "DisplayMath" str -inlineToCustom lua (Math InlineMath str) = - callfunc lua "InlineMath" str +inlineToCustom (Math InlineMath str) = + callFunc "InlineMath" str -inlineToCustom lua (RawInline format str) = - callfunc lua "RawInline" format str +inlineToCustom (RawInline format str) = + callFunc "RawInline" format str -inlineToCustom lua (LineBreak) = callfunc lua "LineBreak" +inlineToCustom (LineBreak) = callFunc "LineBreak" -inlineToCustom lua (Link attr txt (src,tit)) = - callfunc lua "Link" txt src tit (attrToMap attr) +inlineToCustom (Link attr txt (src,tit)) = + callFunc "Link" txt src tit (attrToMap attr) -inlineToCustom lua (Image attr alt (src,tit)) = - callfunc lua "Image" alt src tit (attrToMap attr) +inlineToCustom (Image attr alt (src,tit)) = + 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) = - callfunc lua "Span" items (attrToMap attr) +inlineToCustom (Span attr items) = + callFunc "Span" items (attrToMap attr) diff --git a/stack.full.yaml b/stack.full.yaml index e5fff5a4e..c75f5b89f 100644 --- a/stack.full.yaml +++ b/stack.full.yaml @@ -20,6 +20,6 @@ packages: - '../pandoc-types' - '../texmath' extra-deps: -- hslua-0.5.0 +- hslua-0.7.0 - skylighting-0.3.3 resolver: lts-8.12 diff --git a/stack.pkg.yaml b/stack.pkg.yaml index 721cb64fc..9e03834ee 100644 --- a/stack.pkg.yaml +++ b/stack.pkg.yaml @@ -17,7 +17,7 @@ packages: commit: 2e27f5cb40577c9b3ffe0fc112687084f3d9d877 extra-dep: false extra-deps: -- hslua-0.5.0 +- hslua-0.7.0 - skylighting-0.3.3 - cmark-gfm-0.1.1 - QuickCheck-2.10.0.1 diff --git a/stack.yaml b/stack.yaml index 1f2ff7f42..c3bc1041d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,7 +7,7 @@ flags: packages: - '.' extra-deps: -- hslua-0.5.0 +- hslua-0.7.0 - skylighting-0.3.3 - cmark-gfm-0.1.1 - QuickCheck-2.10.0.1 diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs index ebd39366b..8cbda996a 100644 --- a/test/Tests/Lua.hs +++ b/test/Tests/Lua.hs @@ -13,7 +13,7 @@ import Text.Pandoc.Builder ( (<>), bulletList, doc, doubleQuoted, emph , space, str, strong) import Text.Pandoc.Lua -import qualified Scripting.Lua as Lua +import Foreign.Lua tests :: [TestTree] tests = map (localOption (QuickCheckTests 20)) @@ -71,23 +71,20 @@ assertFilterConversion msg filterPath docIn docExpected = do docRes <- runLuaFilter Nothing ("lua" filterPath) [] docIn 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 where - roundtripped :: (Lua.StackValue a) => IO a - roundtripped = do - lua <- Lua.newstate - Lua.openlibs lua - pushPandocModule Nothing lua - Lua.setglobal lua "pandoc" - oldSize <- Lua.gettop lua - Lua.push lua x - size <- Lua.gettop lua + roundtripped :: (FromLuaStack a, ToLuaStack a) => IO a + roundtripped = runLua $ do + openlibs + pushPandocModule Nothing + setglobal "pandoc" + oldSize <- gettop + push x + size <- gettop when ((size - oldSize) /= 1) $ error ("not exactly one additional element on the stack: " ++ show size) - res <- Lua.peek lua (-1) - retval <- case res of - Nothing -> error "could not read from stack" - Just y -> return y - Lua.close lua - return retval + res <- peekEither (-1) + case res of + Left _ -> error "could not read from stack" + Right y -> return y -- cgit v1.2.3