module Text.Pandoc.Lua.StackInstances () where
import Control.Applicative ((<|>))
import Control.Monad (when)
import Foreign.Lua (FromLuaStack (peek), Lua, LuaInteger, LuaNumber, StackIndex,
ToLuaStack (push), Type (..), throwLuaError, tryLua)
import Text.Pandoc.Definition
import Text.Pandoc.Lua.Util (adjustIndexBy, getTable, pushViaConstructor)
import Text.Pandoc.Shared (Element (Blk, Sec), safeRead)
import qualified Foreign.Lua as Lua
import qualified Text.Pandoc.Lua.Util as LuaUtil
instance ToLuaStack Pandoc where
push (Pandoc meta blocks) =
pushViaConstructor "Pandoc" blocks 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) =
pushViaConstructor "Meta" mmap
instance FromLuaStack Meta where
peek idx = Meta <$> peek idx
instance ToLuaStack MetaValue where
push = pushMetaValue
instance FromLuaStack MetaValue where
peek = peekMetaValue
instance ToLuaStack Block where
push = pushBlock
instance FromLuaStack Block where
peek = peekBlock
instance ToLuaStack Inline where
push = pushInline
instance FromLuaStack Inline where
peek = peekInline
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
instance ToLuaStack Double where
push = push . (realToFrac :: Double -> LuaNumber)
instance FromLuaStack Double where
peek = fmap (realToFrac :: LuaNumber -> Double) . peek
instance ToLuaStack Int where
push = push . (fromIntegral :: Int -> LuaInteger)
instance FromLuaStack Int where
peek = fmap (fromIntegral :: LuaInteger-> Int) . peek
safeRead' :: Read a => String -> Lua a
safeRead' s = case safeRead s of
Nothing -> throwLuaError ("Could not read: " ++ s)
Just x -> return x
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
peekMetaValue :: StackIndex -> Lua MetaValue
peekMetaValue idx = do
let elementContent :: FromLuaStack a => Lua a
elementContent = peek idx
luatype <- Lua.ltype idx
case luatype of
TypeBoolean -> MetaBool <$> peek idx
TypeString -> MetaString <$> peek idx
TypeTable -> do
tag <- tryLua $ getTag idx
case tag of
Right "MetaBlocks" -> MetaBlocks <$> elementContent
Right "MetaBool" -> MetaBool <$> elementContent
Right "MetaMap" -> MetaMap <$> elementContent
Right "MetaInlines" -> MetaInlines <$> elementContent
Right "MetaList" -> MetaList <$> elementContent
Right "MetaString" -> MetaString <$> elementContent
Right t -> throwLuaError ("Unknown meta tag: " ++ t)
Left _ -> do
len <- Lua.rawlen idx
if len <= 0
then MetaMap <$> peek idx
else (MetaInlines <$> peek idx)
<|> (MetaBlocks <$> peek idx)
<|> (MetaList <$> peek idx)
_ -> throwLuaError "could not get meta value"
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 "Table" capt aligns widths headers rows
peekBlock :: StackIndex -> Lua Block
peekBlock idx = do
tag <- getTag idx
case tag of
"BlockQuote" -> BlockQuote <$> elementContent
"BulletList" -> BulletList <$> elementContent
"CodeBlock" -> withAttr CodeBlock <$> elementContent
"DefinitionList" -> DefinitionList <$> elementContent
"Div" -> withAttr Div <$> elementContent
"Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst)
<$> elementContent
"HorizontalRule" -> return HorizontalRule
"LineBlock" -> LineBlock <$> elementContent
"OrderedList" -> 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
_ -> throwLuaError ("Unknown block type: " ++ tag)
where
elementContent :: FromLuaStack a => Lua a
elementContent = getTable idx "c"
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
peekInline :: StackIndex -> Lua Inline
peekInline idx = do
tag <- getTag idx
case tag of
"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
elementContent :: FromLuaStack a => Lua a
elementContent = getTable idx "c"
getTag :: StackIndex -> Lua String
getTag idx = do
top <- Lua.gettop
hasMT <- Lua.getmetatable idx
push "tag"
if hasMT then Lua.rawget (2) else Lua.rawget (idx `adjustIndexBy` 1)
r <- tryLua (peek (1))
Lua.settop top
case r of
Left (Lua.LuaException err) -> throwLuaError err
Right res -> return res
withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b
withAttr f (attributes, x) = f (fromLuaAttr attributes) x
newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr }
instance ToLuaStack LuaAttr where
push (LuaAttr (id', classes, kv)) =
pushViaConstructor "Attr" id' classes kv
instance FromLuaStack LuaAttr where
peek idx = LuaAttr <$> peek idx
instance ToLuaStack Element where
push (Blk blk) = push blk
push (Sec lvl num attr label contents) = do
Lua.newtable
LuaUtil.addValue "level" lvl
LuaUtil.addValue "numbering" num
LuaUtil.addValue "attr" (LuaAttr attr)
LuaUtil.addValue "label" label
LuaUtil.addValue "contents" contents
pushSecMetaTable
Lua.setmetatable (2)
where
pushSecMetaTable :: Lua ()
pushSecMetaTable = do
inexistant <- Lua.newmetatable "PandocElementSec"
when inexistant $ do
LuaUtil.addValue "t" "Sec"
Lua.push "__index"
Lua.pushvalue (2)
Lua.rawset (3)