@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE BangPatterns #-}
23{-# LANGUAGE LambdaCase #-}
34{- |
45 Module : Text.Pandoc.Lua.Marshaling.AST
@@ -17,6 +18,7 @@ module Text.Pandoc.Lua.Marshaling.AST
1718 ) where
1819
1920import Control.Applicative ((<|>))
21+import Control.Monad ((<$!>))
2022import Foreign.Lua (Lua, Peekable, Pushable, StackIndex)
2123import Text.Pandoc.Definition
2224import Text.Pandoc.Error (PandocError)
@@ -32,17 +34,16 @@ instance Pushable Pandoc where
3234 pushViaConstructor "Pandoc" blocks meta
3335
3436instance Peekable Pandoc where
35− peek idx = defineHowTo "get Pandoc value" $ do
36− blocks <- LuaUtil.rawField idx "blocks"
37− meta <- LuaUtil.rawField idx "meta"
38− return $ Pandoc meta blocks
37+ peek idx = defineHowTo "get Pandoc value" $! Pandoc
38+ <$!> LuaUtil.rawField idx "meta"
39+ <*> LuaUtil.rawField idx "blocks"
3940
4041instance Pushable Meta where
4142 push (Meta mmap) =
4243 pushViaConstructor "Meta" mmap
4344instance Peekable Meta where
44− peek idx = defineHowTo "get Meta value" $
45− Meta <$> Lua.peek idx
45+ peek idx = defineHowTo "get Meta value" $!
46+ Meta <$!> Lua.peek idx
4647
4748instance Pushable MetaValue where
4849 push = pushMetaValue
@@ -68,14 +69,13 @@ instance Pushable Citation where
6869 pushViaConstructor "Citation" cid mode prefix suffix noteNum hash
6970
7071instance Peekable Citation where
71− peek idx = do
72− id' <- LuaUtil.rawField idx "id"
73− prefix <- LuaUtil.rawField idx "prefix"
74− suffix <- LuaUtil.rawField idx "suffix"
75− mode <- LuaUtil.rawField idx "mode"
76− num <- LuaUtil.rawField idx "note_num"
77− hash <- LuaUtil.rawField idx "hash"
78− return $ Citation id' prefix suffix mode num hash
72+ peek idx = Citation
73+ <$!> LuaUtil.rawField idx "id"
74+ <*> LuaUtil.rawField idx "prefix"
75+ <*> LuaUtil.rawField idx "suffix"
76+ <*> LuaUtil.rawField idx "mode"
77+ <*> LuaUtil.rawField idx "note_num"
78+ <*> LuaUtil.rawField idx "hash"
7979
8080instance Pushable Alignment where
8181 push = Lua.push . show
@@ -90,7 +90,7 @@ instance Peekable CitationMode where
9090instance Pushable Format where
9191 push (Format f) = Lua.push f
9292instance Peekable Format where
93− peek idx = Format <$> Lua.peek idx
93+ peek idx = Format <$!> Lua.peek idx
9494
9595instance Pushable ListNumberDelim where
9696 push = Lua.push . show
@@ -130,26 +130,26 @@ peekMetaValue idx = defineHowTo "get MetaValue" $ do
130130 elementContent = Lua.peek idx
131131 luatype <- Lua.ltype idx
132132 case luatype of
133− Lua.TypeBoolean -> MetaBool <$> Lua.peek idx
134− Lua.TypeString -> MetaString <$> Lua.peek idx
133+ Lua.TypeBoolean -> MetaBool <$!> Lua.peek idx
134+ Lua.TypeString -> MetaString <$!> Lua.peek idx
135135 Lua.TypeTable -> do
136136 tag <- try $ LuaUtil.getTag idx
137137 case tag of
138− Right "MetaBlocks" -> MetaBlocks <$> elementContent
139− Right "MetaBool" -> MetaBool <$> elementContent
140− Right "MetaMap" -> MetaMap <$> elementContent
141− Right "MetaInlines" -> MetaInlines <$> elementContent
142− Right "MetaList" -> MetaList <$> elementContent
143− Right "MetaString" -> MetaString <$> elementContent
138+ Right "MetaBlocks" -> MetaBlocks <$!> elementContent
139+ Right "MetaBool" -> MetaBool <$!> elementContent
140+ Right "MetaMap" -> MetaMap <$!> elementContent
141+ Right "MetaInlines" -> MetaInlines <$!> elementContent
142+ Right "MetaList" -> MetaList <$!> elementContent
143+ Right "MetaString" -> MetaString <$!> elementContent
144144 Right t -> Lua.throwMessage ("Unknown meta tag: " <> t)
145145 Left _ -> do
146146 -- no meta value tag given, try to guess.
147147 len <- Lua.rawlen idx
148148 if len <= 0
149− then MetaMap <$> Lua.peek idx
150− else (MetaInlines <$> Lua.peek idx)
151− <|> (MetaBlocks <$> Lua.peek idx)
152− <|> (MetaList <$> Lua.peek idx)
149+ then MetaMap <$!> Lua.peek idx
150+ else (MetaInlines <$!> Lua.peek idx)
151+ <|> (MetaBlocks <$!> Lua.peek idx)
152+ <|> (MetaList <$!> Lua.peek idx)
153153 _ -> Lua.throwMessage "could not get meta value"
154154
155155-- | Push a block element to the top of the Lua stack.
@@ -174,25 +174,25 @@ pushBlock = \case
174174
175175-- | Return the value at the given index as block if possible.
176176peekBlock :: StackIndex -> Lua Block
177−peekBlock idx = defineHowTo "get Block value" $ do
177+peekBlock idx = defineHowTo "get Block value" $! do
178178 tag <- LuaUtil.getTag idx
179179 case tag of
180− "BlockQuote" -> BlockQuote <$> elementContent
181− "BulletList" -> BulletList <$> elementContent
182− "CodeBlock" -> withAttr CodeBlock <$> elementContent
183− "DefinitionList" -> DefinitionList <$> elementContent
184− "Div" -> withAttr Div <$> elementContent
180+ "BlockQuote" -> BlockQuote <$!> elementContent
181+ "BulletList" -> BulletList <$!> elementContent
182+ "CodeBlock" -> withAttr CodeBlock <$!> elementContent
183+ "DefinitionList" -> DefinitionList <$!> elementContent
184+ "Div" -> withAttr Div <$!> elementContent
185185 "Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst)
186− <$> elementContent
186+ <$!> elementContent
187187 "HorizontalRule" -> return HorizontalRule
188− "LineBlock" -> LineBlock <$> elementContent
188+ "LineBlock" -> LineBlock <$!> elementContent
189189 "OrderedList" -> (\(LuaListAttributes lstAttr, lst) ->
190190 OrderedList lstAttr lst)
191− <$> elementContent
191+ <$!> elementContent
192192 "Null" -> return Null
193− "Para" -> Para <$> elementContent
194− "Plain" -> Plain <$> elementContent
195− "RawBlock" -> uncurry RawBlock <$> elementContent
193+ "Para" -> Para <$!> elementContent
194+ "Plain" -> Plain <$!> elementContent
195+ "RawBlock" -> uncurry RawBlock <$!> elementContent
196196 "Table" -> (\(attr, capt, colSpecs, thead, tbodies, tfoot) ->
197197 Table (fromLuaAttr attr)
198198 capt
@@ -200,7 +200,7 @@ peekBlock idx = defineHowTo "get Block value" $ do
200200 thead
201201 tbodies
202202 tfoot)
203− <$> elementContent
203+ <$!> elementContent
204204 _ -> Lua.throwMessage ("Unknown block type: " <> tag)
205205 where
206206 -- Get the contents of an AST element.
@@ -222,15 +222,14 @@ pushCaption (Caption shortCaption longCaption) = do
222222
223223-- | Peek Caption element
224224peekCaption :: StackIndex -> Lua Caption
225−peekCaption idx = do
226− short <- Lua.fromOptional <$> LuaUtil.rawField idx "short"
227− long <- LuaUtil.rawField idx "long"
228− return $ Caption short long
225+peekCaption idx = Caption
226+ <$!> (Lua.fromOptional <$!> LuaUtil.rawField idx "short")
227+ <*> LuaUtil.rawField idx "long"
229228
230229instance Peekable ColWidth where
231230 peek idx = do
232− width <- Lua.fromOptional <$> Lua.peek idx
233− return $ maybe ColWidthDefault ColWidth width
231+ width <- Lua.fromOptional <$!> Lua.peek idx
232+ return $! maybe ColWidthDefault ColWidth width
234233
235234instance Pushable ColWidth where
236235 push = \case
@@ -252,12 +251,11 @@ instance Pushable TableBody where
252251 LuaUtil.addField "body" body
253252
254253instance Peekable TableBody where
255− peek idx = do
256− attr <- LuaUtil.rawField idx "attr"
257− rowHeadColumns <- LuaUtil.rawField idx "row_head_columns"
258− head' <- LuaUtil.rawField idx "head"
259− body <- LuaUtil.rawField idx "body"
260− return $ TableBody attr (RowHeadColumns rowHeadColumns) head' body
254+ peek idx = TableBody
255+ <$!> LuaUtil.rawField idx "attr"
256+ <*> (RowHeadColumns <$!> LuaUtil.rawField idx "row_head_columns")
257+ <*> LuaUtil.rawField idx "head"
258+ <*> LuaUtil.rawField idx "body"
261259
262260instance Pushable TableHead where
263261 push (TableHead attr rows) = Lua.push (attr, rows)
@@ -287,13 +285,12 @@ pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do
287285 LuaUtil.addField "contents" contents
288286
289287peekCell :: StackIndex -> Lua Cell
290−peekCell idx = do
291− attr <- fromLuaAttr <$> LuaUtil.rawField idx "attr"
292− align <- LuaUtil.rawField idx "alignment"
293− rowSpan <- LuaUtil.rawField idx "row_span"
294− colSpan <- LuaUtil.rawField idx "col_span"
295− contents <- LuaUtil.rawField idx "contents"
296− return $ Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents
288+peekCell idx = Cell
289+ <$!> (fromLuaAttr <$!> LuaUtil.rawField idx "attr")
290+ <*> LuaUtil.rawField idx "alignment"
291+ <*> (RowSpan <$!> LuaUtil.rawField idx "row_span")
292+ <*> (ColSpan <$!> LuaUtil.rawField idx "col_span")
293+ <*> LuaUtil.rawField idx "contents"
297294
298295-- | Push an inline element to the top of the lua stack.
299296pushInline :: Inline -> Lua ()
@@ -324,28 +321,29 @@ peekInline :: StackIndex -> Lua Inline
324321peekInline idx = defineHowTo "get Inline value" $ do
325322 tag <- LuaUtil.getTag idx
326323 case tag of
327− "Cite" -> uncurry Cite <$> elementContent
328− "Code" -> withAttr Code <$> elementContent
329− "Emph" -> Emph <$> elementContent
330− "Underline" -> Underline <$> elementContent
331− "Image" -> (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt)
332− <$> elementContent
333− "Link" -> (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt)
334− <$> elementContent
324+ "Cite" -> uncurry Cite <$!> elementContent
325+ "Code" -> withAttr Code <$!> elementContent
326+ "Emph" -> Emph <$!> elementContent
327+ "Underline" -> Underline <$!> elementContent
328+ "Image" -> (\(LuaAttr !attr, !lst, !tgt) -> Image attr lst tgt)
329+ <$!> elementContent
330+ "Link" -> (\(LuaAttr !attr, !lst, !tgt) -> Link attr lst tgt)
331+ <$!> elementContent
335332 "LineBreak" -> return LineBreak
336− "Note" -> Note <$> elementContent
337− "Math" -> uncurry Math <$> elementContent
338− "Quoted" -> uncurry Quoted <$> elementContent
339− "RawInline" -> uncurry RawInline <$> elementContent
340− "SmallCaps" -> SmallCaps <$> elementContent
333+ "Note" -> Note <$!> elementContent
334+ "Math" -> uncurry Math <$!> elementContent
335+ "Quoted" -> uncurry Quoted <$!> elementContent
336+ "RawInline" -> uncurry RawInline <$!> elementContent
337+ "SmallCaps" -> SmallCaps <$!> elementContent
341338 "SoftBreak" -> return SoftBreak
342339 "Space" -> return Space
343− "Span" -> withAttr Span <$> elementContent
344− "Str" -> Str <$> elementContent
345− "Strikeout" -> Strikeout <$> elementContent
346− "Strong" -> Strong <$> elementContent
347− "Subscript" -> Subscript <$> elementContent
348− "Superscript"-> Superscript <$> elementContent
340+ "Span" -> withAttr Span <$!> elementContent
341+ -- strict to Lua string is copied before gc
342+ "Str" -> Str <$!> elementContent
343+ "Strikeout" -> Strikeout <$!> elementContent
344+ "Strong" -> Strong <$!> elementContent
345+ "Subscript" -> Subscript <$!> elementContent
346+ "Superscript"-> Superscript <$!> elementContent
349347 _ -> Lua.throwMessage ("Unknown inline type: " <> tag)
350348 where
351349 -- Get the contents of an AST element.
@@ -366,7 +364,7 @@ instance Pushable LuaAttr where
366364 pushViaConstructor "Attr" id' classes kv
367365
368366instance Peekable LuaAttr where
369− peek idx = defineHowTo "get Attr value" (LuaAttr <$> Lua.peek idx)
367+ peek idx = defineHowTo "get Attr value" $! (LuaAttr <$!> Lua.peek idx)
370368
371369-- | Wrapper for ListAttributes
372370newtype LuaListAttributes = LuaListAttributes ListAttributes