From 3327b225a1ef96543f912d200229d08940936528 Mon Sep 17 00:00:00 2001 From: Albert Krewinkel 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/Text/Pandoc') 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