diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Text/Pandoc/Lua.hs | 162 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/StackInstances.hs | 364 |
2 files changed, 362 insertions, 164 deletions
diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index d7c54b6af..9903d4df6 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -15,6 +15,9 @@ 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 FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Lua @@ -26,27 +29,24 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Pandoc lua utils. -} -module Text.Pandoc.Lua ( runLuaFilter ) where +module Text.Pandoc.Lua ( runLuaFilter, pushPandocModule ) where import Control.Monad ( (>=>), when ) import Control.Monad.Trans ( MonadIO(..) ) -import Data.HashMap.Lazy ( HashMap ) -import Data.Text ( Text, pack, unpack ) -import Data.Text.Encoding ( decodeUtf8 ) +import Data.Map ( Map ) import Scripting.Lua ( LuaState, StackValue(..) ) -import Scripting.Lua.Aeson ( newstate ) import Text.Pandoc.Definition ( Block(..), Inline(..), Pandoc(..) ) -import Text.Pandoc.Lua.PandocModule +import Text.Pandoc.Lua.PandocModule ( pushPandocModule ) import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Walk -import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Map as Map import qualified Scripting.Lua as Lua runLuaFilter :: (MonadIO m) => FilePath -> [String] -> Pandoc -> m Pandoc runLuaFilter filterPath args pd = liftIO $ do - lua <- newstate + lua <- Lua.newstate Lua.openlibs lua -- create table in registry to store filter functions Lua.push lua ("PANDOC_FILTER_FUNCTIONS"::String) @@ -58,12 +58,12 @@ runLuaFilter filterPath args pd = liftIO $ do status <- Lua.loadfile lua filterPath if (status /= 0) then do - luaErrMsg <- unpack . decodeUtf8 <$> Lua.tostring lua 1 + Just luaErrMsg <- Lua.peek lua 1 error luaErrMsg else do Lua.call lua 0 1 Just luaFilters <- Lua.peek lua (-1) - Lua.push lua (map pack args) + Lua.push lua args Lua.setglobal lua "PandocParameters" doc <- runAll luaFilters >=> luaFilter lua "filter_doc" $ pd Lua.close lua @@ -86,73 +86,85 @@ walkMWithLuaFilter (LuaFilter lua inlineFnMap blockFnMap docFnMap) = walkM (execBlockLuaFilter lua blockFnMap) >=> walkM (execDocLuaFilter lua docFnMap) -type InlineFunctionMap = HashMap Text (LuaFilterFunction Inline) -type BlockFunctionMap = HashMap Text (LuaFilterFunction Block) -type DocFunctionMap = HashMap Text (LuaFilterFunction Pandoc) +type InlineFunctionMap = Map String (LuaFilterFunction Inline) +type BlockFunctionMap = Map String (LuaFilterFunction Block) +type DocFunctionMap = Map String (LuaFilterFunction Pandoc) data LuaFilter = LuaFilter LuaState InlineFunctionMap BlockFunctionMap DocFunctionMap newtype LuaFilterFunction a = LuaFilterFunction { functionIndex :: Int } execDocLuaFilter :: LuaState - -> HashMap Text (LuaFilterFunction Pandoc) + -> Map String (LuaFilterFunction Pandoc) -> Pandoc -> IO Pandoc execDocLuaFilter lua fnMap x = do let docFnName = "Doc" - case HashMap.lookup docFnName fnMap of + case Map.lookup docFnName fnMap of Nothing -> return x Just fn -> runLuaFilterFunction lua fn x execBlockLuaFilter :: LuaState - -> HashMap Text (LuaFilterFunction Block) + -> Map String (LuaFilterFunction Block) -> Block -> IO Block execBlockLuaFilter lua fnMap x = do - let filterOrId constr = case HashMap.lookup constr fnMap of - Nothing -> return x - Just fn -> runLuaFilterFunction lua fn x + let runFn :: PushViaFilterFunction Block a => LuaFilterFunction Block -> a + runFn fn = runLuaFilterFunction lua fn + let tryFilter :: String -> (LuaFilterFunction Block -> IO Block) -> IO Block + tryFilter fnName callFilterFn = + case Map.lookup fnName fnMap of + Nothing -> return x + Just fn -> callFilterFn fn case x of - Plain _ -> filterOrId "Plain" - Para _ -> filterOrId "Para" - LineBlock _ -> filterOrId "LineBlock" - CodeBlock _ _ -> filterOrId "CodeBlock" - RawBlock _ _ -> filterOrId "RawBlock" - BlockQuote _ -> filterOrId "BlockQuote" - OrderedList _ _ -> filterOrId "OrderedList" - BulletList _ -> filterOrId "BulletList" - DefinitionList _ -> filterOrId "DefinitionList" - Header _ _ _ -> filterOrId "Header" - HorizontalRule -> filterOrId "HorizontalRule" - Table _ _ _ _ _ -> filterOrId "Table" - Div _ _ -> filterOrId "Div" - Null -> filterOrId "Null" + HorizontalRule -> tryFilter "HorizontalRule" runFn + Null -> tryFilter "Null" runFn + BlockQuote blcks -> tryFilter "BlockQuote" $ \fn -> runFn fn blcks + BulletList items -> tryFilter "BulletList" $ \fn -> runFn fn items + CodeBlock attr code -> tryFilter "CodeBlock" $ \fn -> runFn fn attr code + DefinitionList lst -> tryFilter "DefinitionList" $ \fn -> runFn fn lst + Div attr content -> tryFilter "Div" $ \fn -> runFn fn content attr + Header lvl attr inlns -> tryFilter "Header" $ \fn -> runFn fn lvl inlns attr + LineBlock inlns -> tryFilter "LineBlock" $ \fn -> runFn fn inlns + Para inlns -> tryFilter "Para" $ \fn -> runFn fn inlns + Plain inlns -> tryFilter "Plain" $ \fn -> runFn fn inlns + RawBlock format str -> tryFilter "RawBlock" $ \fn -> runFn fn format str + OrderedList (num,sty,delim) items -> + tryFilter "OrderedList" $ \fn -> runFn fn items (num,sty,delim) + Table capt aligns widths headers rows -> + tryFilter "Table" $ \fn -> runFn fn capt aligns widths headers rows execInlineLuaFilter :: LuaState - -> HashMap Text (LuaFilterFunction Inline) + -> Map String (LuaFilterFunction Inline) -> Inline -> IO Inline execInlineLuaFilter lua fnMap x = do - let filterOrId constr = case HashMap.lookup constr fnMap of - Nothing -> return x - Just fn -> runLuaFilterFunction lua fn x + let runFn :: PushViaFilterFunction Inline a => LuaFilterFunction Inline -> a + runFn fn = runLuaFilterFunction lua fn + let tryFilter :: String -> (LuaFilterFunction Inline -> IO Inline) -> IO Inline + tryFilter fnName callFilterFn = + case Map.lookup fnName fnMap of + Nothing -> return x + Just fn -> callFilterFn fn case x of - Cite _ _ -> filterOrId "Cite" - Code _ _ -> filterOrId "Code" - Emph _ -> filterOrId "Emph" - Image _ _ _ -> filterOrId "Image" - LineBreak -> filterOrId "LineBreak" - Link _ _ _ -> filterOrId "Link" - Math _ _ -> filterOrId "Math" - Note _ -> filterOrId "Note" - Quoted _ _ -> filterOrId "Quoted" - RawInline _ _ -> filterOrId "RawInline" - SmallCaps _ -> filterOrId "SmallCaps" - SoftBreak -> filterOrId "SoftBreak" - Space -> filterOrId "Space" - Span _ _ -> filterOrId "Span" - Str _ -> filterOrId "Str" - Strikeout _ -> filterOrId "Strikeout" - Strong _ -> filterOrId "Strong" - Subscript _ -> filterOrId "Subscript" - Superscript _ -> filterOrId "Superscript" + LineBreak -> tryFilter "LineBreak" runFn + SoftBreak -> tryFilter "SoftBreak" runFn + Space -> tryFilter "Space" runFn + Cite cs lst -> tryFilter "Cite" $ \fn -> runFn fn lst cs + Code attr str -> tryFilter "Code" $ \fn -> runFn fn str attr + Emph lst -> tryFilter "Emph" $ \fn -> runFn fn lst + Math mt lst -> tryFilter "Math" $ \fn -> runFn fn lst mt + Note blks -> tryFilter "Note" $ \fn -> runFn fn blks + Quoted qt lst -> tryFilter "Quoted" $ \fn -> runFn fn qt lst + RawInline f str -> tryFilter "RawInline" $ \fn -> runFn fn f str + SmallCaps lst -> tryFilter "SmallCaps" $ \fn -> runFn fn lst + Span attr lst -> tryFilter "Span" $ \fn -> runFn fn lst attr + Str str -> tryFilter "Str" $ \fn -> runFn fn str + Strikeout lst -> tryFilter "Strikeout" $ \fn -> runFn fn lst + Strong lst -> tryFilter "Strong" $ \fn -> runFn fn lst + Subscript lst -> tryFilter "Subscript" $ \fn -> runFn fn lst + Superscript lst -> tryFilter "Superscript" $ \fn -> runFn fn lst + Link attr txt (src, tit) -> tryFilter "Link" $ + \fn -> runFn fn txt src tit attr + Image attr alt (src, tit) -> tryFilter "Image" $ + \fn -> runFn fn alt src tit attr instance StackValue LuaFilter where valuetype _ = Lua.TTABLE @@ -164,17 +176,33 @@ instance StackValue LuaFilter where docFnMap <- Lua.peek lua i return $ LuaFilter lua <$> inlineFnMap <*> blockFnMap <*> docFnMap -runLuaFilterFunction :: (StackValue a) - => LuaState -> LuaFilterFunction a -> a -> IO a -runLuaFilterFunction lua lf inline = do - pushFilterFunction lua lf - Lua.push lua inline - Lua.call lua 1 1 - mbres <- Lua.peek lua (-1) - case mbres of - Nothing -> error $ "Error while trying to get a filter's return " - ++ "value from lua stack." - Just res -> res <$ Lua.pop lua 1 +-- | Helper class for pushing a single value to the stack via a lua function. +-- See @pushViaCall@. +class PushViaFilterFunction a b where + pushViaFilterFunction' :: LuaState -> LuaFilterFunction a -> IO () -> Int -> b + +instance (StackValue a) => PushViaFilterFunction a (IO a) where + pushViaFilterFunction' lua lf pushArgs num = do + pushFilterFunction lua lf + pushArgs + Lua.call lua num 1 + mbres <- Lua.peek lua (-1) + case mbres of + Nothing -> error $ "Error while trying to get a filter's return " + ++ "value from lua stack." + Just res -> res <$ Lua.pop lua 1 + +instance (PushViaFilterFunction a c, StackValue b) => + PushViaFilterFunction a (b -> c) where + pushViaFilterFunction' lua lf pushArgs num x = + pushViaFilterFunction' lua lf (pushArgs *> push lua x) (num + 1) + +-- | Push an value to the stack via a lua filter function. The function is +-- called with all arguments that are passed to this function and is expected to +-- return a single value. +runLuaFilterFunction :: (StackValue a, PushViaFilterFunction a b) + => LuaState -> LuaFilterFunction a -> b +runLuaFilterFunction lua lf = pushViaFilterFunction' lua lf (return ()) 0 -- | Push the filter function to the top of the stack. pushFilterFunction :: Lua.LuaState -> LuaFilterFunction a -> IO () diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs index 690557788..38f392527 100644 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -35,28 +35,22 @@ StackValue instances for pandoc types. -} module Text.Pandoc.Lua.StackInstances () where -import Data.Aeson ( FromJSON(..), ToJSON(..), Result(..), Value, fromJSON ) +import Control.Applicative ( (<|>) ) import Scripting.Lua ( LTYPE(..), LuaState, StackValue(..) - , gettable, newtable, pop, rawgeti, rawset, rawseti, settable + , call, getglobal2, gettable, ltype, newtable, next, objlen + , pop, pushnil, rawgeti, rawseti, settable ) -import Scripting.Lua.Aeson () import Text.Pandoc.Definition - ( Block(..), Inline(..), Meta(..), Pandoc(..) - , Citation(..), CitationMode(..), Format(..), MathType(..), QuoteType(..) ) +import qualified Data.Map as M import qualified Text.Pandoc.UTF8 as UTF8 -maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a -maybeFromJson mv = fromJSON <$> mv >>= \case - Success x -> Just x - _ -> Nothing - instance StackValue Pandoc where push lua (Pandoc meta blocks) = do newtable lua - setField lua (-1) "blocks" blocks - setField lua (-1) "meta" meta + addKeyValue lua "blocks" blocks + addKeyValue lua "meta" meta peek lua idx = do blocks <- getField lua idx "blocks" meta <- getField lua idx "meta" @@ -64,57 +58,122 @@ instance StackValue Pandoc where valuetype _ = TTABLE instance StackValue Meta where - push lua = push lua . toJSON - peek lua = fmap maybeFromJson . peek lua + push lua (Meta mmap) = push lua mmap + peek lua idx = fmap Meta <$> peek lua idx valuetype _ = TTABLE +instance StackValue MetaValue where + push lua = \case + MetaBlocks blcks -> pushViaConstructor lua "MetaBlocks" blcks + MetaBool b -> pushViaConstructor lua "MetaBool" b + MetaInlines inlns -> pushViaConstructor lua "MetaInlines" inlns + MetaList metalist -> pushViaConstructor lua "MetaList" metalist + MetaMap metamap -> pushViaConstructor lua "MetaMap" metamap + MetaString cs -> pushViaConstructor lua "MetaString" cs + peek lua idx = do + luatype <- ltype lua idx + case luatype of + TBOOLEAN -> fmap MetaBool <$> peek lua idx + TSTRING -> fmap MetaString <$> peek lua idx + TTABLE -> do + tag <- push lua "t" + *> gettable lua (idx `adjustIndexBy` 1) + *> peek lua (-1) + <* pop lua 1 + case tag of + Just "MetaBlocks" -> fmap MetaBlocks <$> peekContent lua idx + Just "MetaBool" -> fmap MetaBool <$> peekContent lua idx + Just "MetaMap" -> fmap MetaMap <$> peekContent lua idx + Just "MetaInlines" -> fmap MetaInlines <$> peekContent lua idx + Just "MetaList" -> fmap MetaList <$> peekContent lua idx + Just "MetaString" -> fmap MetaString <$> peekContent lua idx + Nothing -> do + len <- objlen lua 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 + valuetype = \case + MetaBlocks _ -> TTABLE + MetaBool _ -> TBOOLEAN + MetaInlines _ -> TTABLE + MetaList _ -> TTABLE + MetaMap _ -> TTABLE + MetaString _ -> TSTRING + +peekContent :: StackValue a => LuaState -> Int -> IO (Maybe a) +peekContent lua idx = do + push lua "c" + gettable lua (idx `adjustIndexBy` 1) + peek lua (-1) <* pop lua 1 + instance StackValue Block where push lua = \case - BlockQuote blcks -> pushTagged lua "BlockQuote" blcks - BulletList items -> pushTagged lua "BulletList" items - HorizontalRule -> pushTagged' lua "HorizontalRule" - LineBlock blcks -> pushTagged lua "LineBlock" blcks - Null -> pushTagged' lua "Null" - Para blcks -> pushTagged lua "Para" blcks - Plain blcks -> pushTagged lua "Plain" blcks + BlockQuote blcks -> pushViaConstructor lua "BlockQuote" blcks + BulletList items -> pushViaConstructor lua "BulletList" items + CodeBlock attr code -> pushViaConstructor lua "CodeBlock" code attr + DefinitionList items -> pushViaConstructor lua "DefinitionList" items + Div attr blcks -> pushViaConstructor lua "Div" blcks attr + Header lvl attr inlns -> pushViaConstructor lua "Header" lvl attr inlns + 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 + Table capt aligns widths headers rows -> + pushViaConstructor lua "Table" capt aligns widths headers rows -- fall back to conversion via aeson's Value - x -> push lua (toJSON x) peek lua i = peekBlock lua i valuetype _ = TTABLE instance StackValue Inline where push lua = \case - Cite citations lst -> pushTagged lua "Cite" (citations, lst) - Code attr lst -> pushTagged lua "Code" (attr, lst) - Emph inlns -> pushTagged lua "Emph" inlns - Image attr lst tgt -> pushTagged lua "Image" (attr, lst, tgt) - LineBreak -> pushTagged' lua "LineBreak" - Link attr lst tgt -> pushTagged lua "Link" (attr, lst, tgt) - Note blcks -> pushTagged lua "Note" blcks - Math mty str -> pushTagged lua "Math" (mty, str) - Quoted qt inlns -> pushTagged lua "Quoted" (qt, inlns) - RawInline f cs -> pushTagged lua "RawInline" (f, cs) - SmallCaps inlns -> pushTagged lua "SmallCaps" inlns - SoftBreak -> pushTagged' lua "SoftBreak" - Space -> pushTagged' lua "Space" - Span attr inlns -> pushTagged lua "Span" (attr, inlns) - Str str -> pushTagged lua "Str" str - Strikeout inlns -> pushTagged lua "Strikeout" inlns - Strong inlns -> pushTagged lua "Strong" inlns - Subscript inlns -> pushTagged lua "Subscript" inlns - Superscript inlns -> pushTagged lua "Superscript" inlns + Cite citations lst -> pushViaConstructor lua "Cite" lst citations + Code attr lst -> pushViaConstructor lua "Code" lst attr + Emph inlns -> pushViaConstructor lua "Emph" inlns + Image attr alt (src,tit) -> pushViaConstructor lua "Image" alt src tit attr + LineBreak -> pushViaConstructor lua "LineBreak" + Link attr lst (src,tit) -> pushViaConstructor lua "Link" lst src tit 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 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 peek = peekInline valuetype _ = TTABLE +instance StackValue Alignment where + push lua = \case + AlignLeft -> getglobal2 lua "pandoc.AlignLeft" + AlignRight -> getglobal2 lua "pandoc.AlignRight" + AlignCenter -> getglobal2 lua "pandoc.AlignCenter" + AlignDefault -> getglobal2 lua "pandoc.AlignDefault" + peek lua idx = do + tag <- getField lua idx "t" + case tag of + Just "AlignLeft" -> return $ Just AlignLeft + Just "AlignRight" -> return $ Just AlignRight + Just "AlignCenter" -> return $ Just AlignCenter + Just "AlignDefault" -> return $ Just AlignDefault + _ -> return Nothing + valuetype _ = TSTRING + instance StackValue Citation where - push lua c = do - newtable lua - setField lua (-1) "citationId" (citationId c) - setField lua (-1) "citationPrefix" (citationPrefix c) - setField lua (-1) "citationSuffix" (citationSuffix c) - setField lua (-1) "citationMode" (citationMode c) - setField lua (-1) "citationNoteNum" (citationNoteNum c) - setField lua (-1) "citationHash" (citationHash c) + push lua (Citation cid prefix suffix mode noteNum hash) = + pushViaConstructor lua "Citation" cid mode prefix suffix noteNum hash peek lua idx = do id' <- getField lua idx "citationId" prefix <- getField lua idx "citationPrefix" @@ -122,20 +181,14 @@ instance StackValue Citation where mode <- getField lua idx "citationMode" num <- getField lua idx "citationNoteNum" hash <- getField lua idx "citationHash" - return $ Citation - <$> id' - <*> prefix - <*> suffix - <*> mode - <*> num - <*> hash + return $ Citation <$> id' <*> prefix <*> suffix <*> mode <*> num <*> hash valuetype _ = TTABLE instance StackValue CitationMode where push lua = \case - AuthorInText -> pushTagged' lua "AuthorInText" - NormalCitation -> pushTagged' lua "NormalCitation" - SuppressAuthor -> pushTagged' lua "SuppressAuthor" + AuthorInText -> getglobal2 lua "pandoc.AuthorInText" + NormalCitation -> getglobal2 lua "pandoc.NormalCitation" + SuppressAuthor -> getglobal2 lua "pandoc.SuppressAuthor" peek lua idx = do tag <- getField lua idx "t" case tag of @@ -143,17 +196,55 @@ instance StackValue CitationMode where Just "NormalCitation" -> return $ Just NormalCitation Just "SuppressAuthor" -> return $ Just SuppressAuthor _ -> return Nothing - valuetype _ = TSTRING + valuetype _ = TTABLE 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 = \case + DefaultDelim -> getglobal2 lua "pandoc.DefaultDelim" + Period -> getglobal2 lua "pandoc.Period" + OneParen -> getglobal2 lua "pandoc.OneParen" + TwoParens -> getglobal2 lua "pandoc.TwoParens" + peek lua idx = do + tag <- getField lua idx "t" + case tag of + Just "DefaultDelim" -> return $ Just DefaultDelim + Just "Period" -> return $ Just Period + Just "OneParen" -> return $ Just OneParen + Just "TwoParens" -> return $ Just TwoParens + _ -> return Nothing + valuetype _ = TTABLE + +instance StackValue ListNumberStyle where + push lua = \case + DefaultStyle -> getglobal2 lua "pandoc.DefaultStyle" + LowerRoman -> getglobal2 lua "pandoc.LowerRoman" + UpperRoman -> getglobal2 lua "pandoc.UpperRoman" + LowerAlpha -> getglobal2 lua "pandoc.LowerAlpha" + UpperAlpha -> getglobal2 lua "pandoc.UpperAlpha" + Decimal -> getglobal2 lua "pandoc.Decimal" + Example -> getglobal2 lua "pandoc.Example" + peek lua idx = do + tag <- getField lua idx "t" + case tag of + Just "DefaultStyle" -> return $ Just DefaultStyle + Just "LowerRoman" -> return $ Just LowerRoman + Just "UpperRoman" -> return $ Just UpperRoman + Just "LowerAlpha" -> return $ Just LowerAlpha + Just "UpperAlpha" -> return $ Just UpperAlpha + Just "Decimal" -> return $ Just Decimal + Just "Example" -> return $ Just Example + _ -> return Nothing + valuetype _ = TTABLE + instance StackValue MathType where push lua = \case - InlineMath -> pushTagged' lua "InlineMath" - DisplayMath -> pushTagged' lua "DisplayMath" + InlineMath -> getglobal2 lua "pandoc.InlineMath" + DisplayMath -> getglobal2 lua "pandoc.DisplayMath" peek lua idx = do res <- getField lua idx "t" case res of @@ -164,8 +255,8 @@ instance StackValue MathType where instance StackValue QuoteType where push lua = \case - SingleQuote -> pushTagged' lua "SingleQuote" - DoubleQuote -> pushTagged' lua "DoubleQuote" + SingleQuote -> getglobal2 lua "pandoc.SingleQuote" + DoubleQuote -> getglobal2 lua "pandoc.DoubleQuote" peek lua idx = do res <- getField lua idx "t" case res of @@ -186,11 +277,11 @@ instance StackValue [Char] where instance (StackValue a, StackValue b) => StackValue (a, b) where push lua (a, b) = do newtable lua - setIntField lua (-1) 1 a - setIntField lua (-1) 2 b + addIndexedValue lua 1 a + addIndexedValue lua 2 b peek lua idx = do - a <- getIntField lua idx 1 - b <- getIntField lua idx 2 + a <- getIndexedValue lua idx 1 + b <- getIndexedValue lua idx 2 return $ (,) <$> a <*> b valuetype _ = TTABLE @@ -199,31 +290,93 @@ instance (StackValue a, StackValue b, StackValue c) => where push lua (a, b, c) = do newtable lua - setIntField lua (-1) 1 a - setIntField lua (-1) 2 b - setIntField lua (-1) 3 c + addIndexedValue lua 1 a + addIndexedValue lua 2 b + addIndexedValue lua 3 c peek lua idx = do - a <- getIntField lua idx 1 - b <- getIntField lua idx 2 - c <- getIntField lua idx 3 + a <- getIndexedValue lua idx 1 + b <- getIndexedValue lua idx 2 + c <- getIndexedValue lua idx 3 return $ (,,) <$> a <*> b <*> c valuetype _ = TTABLE --- | Push a value to the lua stack, tagged with a given string. This currently --- creates a structure equivalent to what the JSONified value would look like --- when pushed to lua. -pushTagged :: StackValue a => LuaState -> String -> a -> IO () -pushTagged lua tag value = do - newtable lua - setField lua (-1) "t" tag - setField lua (-1) "c" value - -pushTagged' :: LuaState -> String -> IO () -pushTagged' lua tag = do - newtable lua - push lua "t" - push lua tag - rawset lua (-3) +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 + addIndexedValue lua 1 a + addIndexedValue lua 2 b + addIndexedValue lua 3 c + addIndexedValue lua 4 d + addIndexedValue lua 5 e + peek lua idx = do + a <- getIndexedValue lua idx 1 + b <- getIndexedValue lua idx 2 + c <- getIndexedValue lua idx 3 + d <- getIndexedValue lua idx 4 + e <- getIndexedValue 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 $ addKeyValue lua) $ M.toList m + peek lua idx = fmap M.fromList <$> keyValuePairs lua idx + valuetype _ = TTABLE + +-- | Try reading the value 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. +-- See @pushViaCall@. +class PushViaCall a where + pushViaCall' :: LuaState -> String -> IO () -> Int -> a + +instance PushViaCall (IO ()) where + pushViaCall' lua fn pushArgs num = do + getglobal2 lua fn + pushArgs + call lua 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) + +-- | 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 + +-- | Call a pandoc element constructor within lua, passing all given arguments. +pushViaConstructor :: PushViaCall a => LuaState -> String -> a +pushViaConstructor lua pandocFn = pushViaCall lua ("pandoc." ++ pandocFn) -- | Return the value at the given index as inline if possible. peekInline :: LuaState -> Int -> IO (Maybe Inline) @@ -268,13 +421,22 @@ peekBlock lua idx = do Just t -> case t of "BlockQuote" -> fmap BlockQuote <$> elementContent "BulletList" -> fmap BulletList <$> elementContent + "CodeBlock" -> fmap (uncurry CodeBlock) <$> elementContent + "DefinitionList" -> fmap DefinitionList <$> elementContent + "Div" -> fmap (uncurry Div) <$> elementContent + "Header" -> fmap (\(lvl, 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 - -- fall back to construction via aeson's Value - _ -> maybeFromJson <$> peek lua idx + "RawBlock" -> fmap (uncurry RawBlock) <$> elementContent + "Table" -> fmap (\(capt, aligns, widths, headers, body) -> + Table capt aligns widths headers body) + <$> elementContent + _ -> return Nothing where -- Get the contents of an AST element. elementContent :: StackValue a => IO (Maybe a) @@ -296,21 +458,29 @@ getField lua idx key = do peek lua (-1) <* pop lua 1 -- | Set value for key for table at the given index -setField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO () -setField lua idx key value = do +setKeyValue :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO () +setKeyValue lua idx key value = do push lua key push lua value settable lua (idx `adjustIndexBy` 2) +-- | Add a key-value pair to the table at the top of the stack +addKeyValue :: (StackValue a, StackValue b) => LuaState -> a -> b -> IO () +addKeyValue lua = setKeyValue lua (-1) + -- | Get value behind key from table at given index. -getIntField :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a) -getIntField lua idx key = +getIndexedValue :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a) +getIndexedValue lua idx key = rawgeti lua idx key *> peek lua (-1) <* pop lua 1 -- | Set numeric key/value in table at the given index -setIntField :: StackValue a => LuaState -> Int -> Int -> a -> IO () -setIntField lua idx key value = do +setIndexedValue :: StackValue a => LuaState -> Int -> Int -> a -> IO () +setIndexedValue lua idx key value = do push lua value rawseti lua (idx `adjustIndexBy` 1) key + +-- | Set numeric key/value in table at the top of the stack. +addIndexedValue :: StackValue a => LuaState -> Int -> a -> IO () +addIndexedValue lua = setIndexedValue lua (-1) |