Lua: use strict evaluation when retrieving AST value from the stack

Fixes: #6674

1 files changed, 77 insertions, 79 deletions

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