[API change] Add Figure block constructor

The new Figure block represents a figure with attributes, caption,
and arbitrary block content.

Author: tarleb

src/Text/Pandoc/Arbitrary.hs

@@ -86,6 +86,7 @@ instance Arbitrary Blocks where
                                                    flattenTableHead hd <>
                                                    concatMap flattenTableBody bd <>
                                                    flattenTableFoot ft
+          flattenBlock (Figure _ capt blks) = flattenCaption capt <> blks
           flattenBlock (Div _ blks) = blks
           flattenBlock Null = []
 
@@ -204,6 +205,10 @@ instance Arbitrary Block where
     [Table attr capt specs thead tbody' tfoot | tbody' <- shrink tbody] ++
     [Table attr capt specs thead tbody tfoot' | tfoot' <- shrink tfoot] ++
     [Table attr capt' specs thead tbody tfoot | capt' <- shrink capt]
+  shrink (Figure attr capt blks) =
+    [Figure attr capt blks' | blks' <- shrinkBlockList blks] ++
+    [Figure attr capt' blks | capt' <- shrink capt] ++
+    [Figure attr' capt blks | attr' <- shrinkAttr attr]
   shrink (Div attr blks) = (Div attr <$> shrinkBlockList blks)
                         ++ (flip Div blks <$> shrinkAttr attr)
   shrink Null = []
@@ -246,6 +251,9 @@ arbBlock n = frequency $ [ (10, Plain <$> arbInlines (n-1))
                                   <*> arbTableHead (n-1)
                                   <*> vectorOf bs (arbTableBody (n-1))
                                   <*> arbTableFoot (n-1))
+                   , (2, Figure <$> arbAttr
+                                <*> arbitrary
+                                <*> listOf1 (arbBlock (n-1)))
                    ]
 
 arbRow :: Int -> Gen Row

src/Text/Pandoc/Builder.hs

@@ -168,6 +168,8 @@ module Text.Pandoc.Builder ( module Text.Pandoc.Definition
                            , table
                            , simpleTable
                            , tableWith
+                           , figure
+                           , figureWith
                            , caption
                            , simpleCaption
                            , emptyCaption
@@ -560,6 +562,12 @@ simpleTable headers rows =
         tb = TableBody nullAttr 0 [] $ map toRow rows
         tf = TableFoot nullAttr []
 
+figure :: Caption -> Blocks -> Blocks
+figure = figureWith nullAttr
+
+figureWith :: Attr -> Caption -> Blocks -> Blocks
+figureWith attr capt = singleton . Figure attr capt . toList
+
 caption :: Maybe ShortCaption -> Blocks -> Caption
 caption x = Caption x . toList
 
@@ -571,7 +579,8 @@ emptyCaption = simpleCaption mempty
 
 simpleFigureWith :: Attr -> Inlines -> Text -> Text -> Blocks
 simpleFigureWith attr figureCaption url title =
-  para $ imageWith attr url ("fig:" <> title) figureCaption
+  figure (simpleCaption $ plain figureCaption) . plain $
+    imageWith attr url title mempty
 
 simpleFigure :: Inlines -> Text -> Text -> Blocks
 simpleFigure = simpleFigureWith nullAttr

src/Text/Pandoc/Definition.hs

@@ -254,7 +254,7 @@ data TableFoot = TableFoot Attr [Row]
 -- | A short caption, for use in, for instance, lists of figures.
 type ShortCaption = [Inline]
 
--- | The caption of a table, with an optional short caption.
+-- | The caption of a table or figure, with optional short caption.
 data Caption = Caption (Maybe ShortCaption) [Block]
   deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)
 
@@ -301,6 +301,9 @@ data Block
     -- column alignments and widths (required), table head, table
     -- bodies, and table foot
     | Table Attr Caption [ColSpec] TableHead [TableBody] TableFoot
+    -- | Figure, with attributes, caption and caption position, width
+    -- (optional), and content (list of blocks)
+    | Figure Attr Caption [Block]
     -- | Generic block container with attributes
     | Div Attr [Block]
     -- | Nothing

src/Text/Pandoc/Walk.hs

@@ -472,6 +472,10 @@ walkBlockM f (Table attr capt as hs bs fs)
        bs' <- walkM f bs
        fs' <- walkM f fs
        return $ Table attr capt' as hs' bs' fs'
+walkBlockM f (Figure attr capt blks)
+  = do capt' <- walkM f capt
+       blks' <- walkM f blks
+       return $ Figure attr capt' blks'
 
 -- | Perform a query on elements nested below a @'Block'@ element by
 -- querying all directly nested lists of @Inline@s or @Block@s.
@@ -495,6 +499,9 @@ queryBlock f (Table _ capt _ hs bs fs)
     query f hs <>
     query f bs <>
     query f fs
+queryBlock f (Figure _ capt blks)
+  = query f capt <>
+    query f blks
 queryBlock f (Div _ bs)               = query f bs
 queryBlock _ Null                     = mempty
 

test/test-pandoc-types.hs

@@ -437,6 +437,14 @@ t_table = ( Table
     tCell' i = Cell ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) AlignDefault 1 1 [Plain i]
     tRow = Row ("id", ["kls"], [("k1", "v1"), ("k2", "v2")])
 
+t_figure :: (Block, ByteString)
+t_figure = (Figure
+            ("id", ["kls"], [("k1", "v1"), ("k2", "v2")])
+            (Caption (Just [Str "hello"]) [Para [Str "cap content"]])
+            [Para [Str "fig content"]]
+           ,[s|{"t":"Figure","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[{"t":"Str","c":"hello"}],[{"t":"Para","c":[{"t":"Str","c":"cap content"}]}]],[{"t":"Para","c":[{"t":"Str","c":"fig content"}]}]]}|]
+           )
+
 t_div :: (Block, ByteString)
 t_div = ( Div ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) [Para [Str "Hello"]]
          , [s|{"t":"Div","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Para","c":[{"t":"Str","c":"Hello"}]}]]}|]
@@ -644,15 +652,17 @@ t_tableNormExample = testCase "table normalization example" assertion
     generated = table emptyCaption spec (th initialHeads) [initialTB] (tf initialHeads)
 
 p_figureRepresentation :: Property
-p_figureRepresentation = forAll (arbitrary :: Gen [Inline]) (\figureCaption ->
+p_figureRepresentation = forAll (arbitrary :: Gen [Inline]) $ \figureCaption ->
   simpleFigureWith
       ("", [], [])
       (Builder.fromList figureCaption)
       "url"
       "title" ==
       Builder.fromList
-          [Para [Image ("", [], []) figureCaption ("url", "fig:title") ]]
-  )
+        [Figure
+         nullAttr
+         (Caption Nothing [Plain figureCaption | not (null figureCaption)])
+         [Plain [Image ("", [], []) [] ("url", "title") ]]]
 
 tests :: [Test]
 tests =
@@ -727,6 +737,7 @@ tests =
         , testEncodeDecode "DefinitionList" t_definitionlist
         , testEncodeDecode "Header" t_header
         , testEncodeDecode "Table" t_table
+        , testEncodeDecode "Figure" t_figure
         , testEncodeDecode "Div" t_div
         , testEncodeDecode "Null" t_null
         ]