From 3327b225a1ef96543f912d200229d08940936528 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Sat, 27 Feb 2021 21:35:41 +0100
Subject: Lua: use strict evaluation when retrieving AST value from the stack
Fixes: #6674
---
src/Text/Pandoc/Lua/Marshaling/AST.hs | 156 +++++++++++++++++-----------------
1 file changed, 77 insertions(+), 79 deletions(-)
(limited to 'src')
diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs
index 6485da661..8e12d232c 100644
--- a/src/Text/Pandoc/Lua/Marshaling/AST.hs
+++ b/src/Text/Pandoc/Lua/Marshaling/AST.hs
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{- |
Module : Text.Pandoc.Lua.Marshaling.AST
@@ -17,6 +18,7 @@ module Text.Pandoc.Lua.Marshaling.AST
) where
import Control.Applicative ((<|>))
+import Control.Monad ((<$!>))
import Foreign.Lua (Lua, Peekable, Pushable, StackIndex)
import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError)
@@ -32,17 +34,16 @@ instance Pushable Pandoc where
pushViaConstructor "Pandoc" blocks meta
instance Peekable Pandoc where
- peek idx = defineHowTo "get Pandoc value" $ do
- blocks <- LuaUtil.rawField idx "blocks"
- meta <- LuaUtil.rawField idx "meta"
- return $ Pandoc meta blocks
+ peek idx = defineHowTo "get Pandoc value" $! Pandoc
+ <$!> LuaUtil.rawField idx "meta"
+ <*> LuaUtil.rawField idx "blocks"
instance Pushable Meta where
push (Meta mmap) =
pushViaConstructor "Meta" mmap
instance Peekable Meta where
- peek idx = defineHowTo "get Meta value" $
- Meta <$> Lua.peek idx
+ peek idx = defineHowTo "get Meta value" $!
+ Meta <$!> Lua.peek idx
instance Pushable MetaValue where
push = pushMetaValue
@@ -68,14 +69,13 @@ instance Pushable Citation where
pushViaConstructor "Citation" cid mode prefix suffix noteNum hash
instance Peekable Citation where
- peek idx = do
- id' <- LuaUtil.rawField idx "id"
- prefix <- LuaUtil.rawField idx "prefix"
- suffix <- LuaUtil.rawField idx "suffix"
- mode <- LuaUtil.rawField idx "mode"
- num <- LuaUtil.rawField idx "note_num"
- hash <- LuaUtil.rawField idx "hash"
- return $ Citation id' prefix suffix mode num hash
+ peek idx = Citation
+ <$!> LuaUtil.rawField idx "id"
+ <*> LuaUtil.rawField idx "prefix"
+ <*> LuaUtil.rawField idx "suffix"
+ <*> LuaUtil.rawField idx "mode"
+ <*> LuaUtil.rawField idx "note_num"
+ <*> LuaUtil.rawField idx "hash"
instance Pushable Alignment where
push = Lua.push . show
@@ -90,7 +90,7 @@ instance Peekable CitationMode where
instance Pushable Format where
push (Format f) = Lua.push f
instance Peekable Format where
- peek idx = Format <$> Lua.peek idx
+ peek idx = Format <$!> Lua.peek idx
instance Pushable ListNumberDelim where
push = Lua.push . show
@@ -130,26 +130,26 @@ peekMetaValue idx = defineHowTo "get MetaValue" $ do
elementContent = Lua.peek idx
luatype <- Lua.ltype idx
case luatype of
- Lua.TypeBoolean -> MetaBool <$> Lua.peek idx
- Lua.TypeString -> MetaString <$> Lua.peek idx
+ Lua.TypeBoolean -> MetaBool <$!> Lua.peek idx
+ Lua.TypeString -> MetaString <$!> Lua.peek idx
Lua.TypeTable -> do
tag <- try $ LuaUtil.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 "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 -> Lua.throwMessage ("Unknown meta tag: " <> t)
Left _ -> do
-- no meta value tag given, try to guess.
len <- Lua.rawlen idx
if len <= 0
- then MetaMap <$> Lua.peek idx
- else (MetaInlines <$> Lua.peek idx)
- <|> (MetaBlocks <$> Lua.peek idx)
- <|> (MetaList <$> Lua.peek idx)
+ then MetaMap <$!> Lua.peek idx
+ else (MetaInlines <$!> Lua.peek idx)
+ <|> (MetaBlocks <$!> Lua.peek idx)
+ <|> (MetaList <$!> Lua.peek idx)
_ -> Lua.throwMessage "could not get meta value"
-- | Push a block element to the top of the Lua stack.
@@ -174,25 +174,25 @@ pushBlock = \case
-- | Return the value at the given index as block if possible.
peekBlock :: StackIndex -> Lua Block
-peekBlock idx = defineHowTo "get Block value" $ do
+peekBlock idx = defineHowTo "get Block value" $! do
tag <- LuaUtil.getTag idx
case tag of
- "BlockQuote" -> BlockQuote <$> elementContent
- "BulletList" -> BulletList <$> elementContent
- "CodeBlock" -> withAttr CodeBlock <$> elementContent
- "DefinitionList" -> DefinitionList <$> elementContent
- "Div" -> withAttr Div <$> elementContent
+ "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
+ <$!> elementContent
"HorizontalRule" -> return HorizontalRule
- "LineBlock" -> LineBlock <$> elementContent
+ "LineBlock" -> LineBlock <$!> elementContent
"OrderedList" -> (\(LuaListAttributes lstAttr, lst) ->
OrderedList lstAttr lst)
- <$> elementContent
+ <$!> elementContent
"Null" -> return Null
- "Para" -> Para <$> elementContent
- "Plain" -> Plain <$> elementContent
- "RawBlock" -> uncurry RawBlock <$> elementContent
+ "Para" -> Para <$!> elementContent
+ "Plain" -> Plain <$!> elementContent
+ "RawBlock" -> uncurry RawBlock <$!> elementContent
"Table" -> (\(attr, capt, colSpecs, thead, tbodies, tfoot) ->
Table (fromLuaAttr attr)
capt
@@ -200,7 +200,7 @@ peekBlock idx = defineHowTo "get Block value" $ do
thead
tbodies
tfoot)
- <$> elementContent
+ <$!> elementContent
_ -> Lua.throwMessage ("Unknown block type: " <> tag)
where
-- Get the contents of an AST element.
@@ -222,15 +222,14 @@ pushCaption (Caption shortCaption longCaption) = do
-- | Peek Caption element
peekCaption :: StackIndex -> Lua Caption
-peekCaption idx = do
- short <- Lua.fromOptional <$> LuaUtil.rawField idx "short"
- long <- LuaUtil.rawField idx "long"
- return $ Caption short long
+peekCaption idx = Caption
+ <$!> (Lua.fromOptional <$!> LuaUtil.rawField idx "short")
+ <*> LuaUtil.rawField idx "long"
instance Peekable ColWidth where
peek idx = do
- width <- Lua.fromOptional <$> Lua.peek idx
- return $ maybe ColWidthDefault ColWidth width
+ width <- Lua.fromOptional <$!> Lua.peek idx
+ return $! maybe ColWidthDefault ColWidth width
instance Pushable ColWidth where
push = \case
@@ -252,12 +251,11 @@ instance Pushable TableBody where
LuaUtil.addField "body" body
instance Peekable TableBody where
- peek idx = do
- attr <- LuaUtil.rawField idx "attr"
- rowHeadColumns <- LuaUtil.rawField idx "row_head_columns"
- head' <- LuaUtil.rawField idx "head"
- body <- LuaUtil.rawField idx "body"
- return $ TableBody attr (RowHeadColumns rowHeadColumns) head' body
+ peek idx = TableBody
+ <$!> LuaUtil.rawField idx "attr"
+ <*> (RowHeadColumns <$!> LuaUtil.rawField idx "row_head_columns")
+ <*> LuaUtil.rawField idx "head"
+ <*> LuaUtil.rawField idx "body"
instance Pushable TableHead where
push (TableHead attr rows) = Lua.push (attr, rows)
@@ -287,13 +285,12 @@ pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do
LuaUtil.addField "contents" contents
peekCell :: StackIndex -> Lua Cell
-peekCell idx = do
- attr <- fromLuaAttr <$> LuaUtil.rawField idx "attr"
- align <- LuaUtil.rawField idx "alignment"
- rowSpan <- LuaUtil.rawField idx "row_span"
- colSpan <- LuaUtil.rawField idx "col_span"
- contents <- LuaUtil.rawField idx "contents"
- return $ Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents
+peekCell idx = Cell
+ <$!> (fromLuaAttr <$!> LuaUtil.rawField idx "attr")
+ <*> LuaUtil.rawField idx "alignment"
+ <*> (RowSpan <$!> LuaUtil.rawField idx "row_span")
+ <*> (ColSpan <$!> LuaUtil.rawField idx "col_span")
+ <*> LuaUtil.rawField idx "contents"
-- | Push an inline element to the top of the lua stack.
pushInline :: Inline -> Lua ()
@@ -324,28 +321,29 @@ peekInline :: StackIndex -> Lua Inline
peekInline idx = defineHowTo "get Inline value" $ do
tag <- LuaUtil.getTag idx
case tag of
- "Cite" -> uncurry Cite <$> elementContent
- "Code" -> withAttr Code <$> elementContent
- "Emph" -> Emph <$> elementContent
- "Underline" -> Underline <$> elementContent
- "Image" -> (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt)
- <$> elementContent
- "Link" -> (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt)
- <$> elementContent
+ "Cite" -> uncurry Cite <$!> elementContent
+ "Code" -> withAttr Code <$!> elementContent
+ "Emph" -> Emph <$!> elementContent
+ "Underline" -> Underline <$!> 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
+ "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
+ "Span" -> withAttr Span <$!> elementContent
+ -- strict to Lua string is copied before gc
+ "Str" -> Str <$!> elementContent
+ "Strikeout" -> Strikeout <$!> elementContent
+ "Strong" -> Strong <$!> elementContent
+ "Subscript" -> Subscript <$!> elementContent
+ "Superscript"-> Superscript <$!> elementContent
_ -> Lua.throwMessage ("Unknown inline type: " <> tag)
where
-- Get the contents of an AST element.
@@ -366,7 +364,7 @@ instance Pushable LuaAttr where
pushViaConstructor "Attr" id' classes kv
instance Peekable LuaAttr where
- peek idx = defineHowTo "get Attr value" (LuaAttr <$> Lua.peek idx)
+ peek idx = defineHowTo "get Attr value" $! (LuaAttr <$!> Lua.peek idx)
-- | Wrapper for ListAttributes
newtype LuaListAttributes = LuaListAttributes ListAttributes
--
cgit v1.2.3