[API change] Add a Figure block, modify Table block

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

Since the figure block represents captioned material, the Caption in
Table is no longer necessary, and has been removed.

src/Text/Pandoc/Arbitrary.hs

@@ -82,15 +82,15 @@ instance Arbitrary Blocks where
           flattenBlock (DefinitionList defs) = concat [Para ils:concat blks | (ils, blks) <- defs]
           flattenBlock (Header _ _ ils) = [Para ils]
           flattenBlock HorizontalRule = []
-          flattenBlock (Table _ capt _ hd bd ft) = flattenCaption capt <>
-                                                   flattenTableHead hd <>
-                                                   concatMap flattenTableBody bd <>
-                                                   flattenTableFoot ft
+          flattenBlock (Table _ _ hd bd ft) = flattenTableHead hd <>
+                                              concatMap flattenTableBody bd <>
+                                              flattenTableFoot ft
+          flattenBlock (Figure _ _ capt blks) = flattenCaption capt <> blks
           flattenBlock (Div _ blks) = blks
           flattenBlock Null = []
 
-          flattenCaption (Caption Nothing body)    = body
-          flattenCaption (Caption (Just ils) body) = Para ils : body
+          flattenCaption (Caption _ Nothing body)    = body
+          flattenCaption (Caption _ (Just ils) body) = Para ils : body
 
           flattenTableHead (TableHead _ body) = flattenRows body
           flattenTableBody (TableBody _ _ hd bd) = flattenRows hd <> flattenRows bd
@@ -197,13 +197,16 @@ instance Arbitrary Block where
   shrink (Header n attr ils) = (Header n attr <$> shrinkInlineList ils)
                             ++ (flip (Header n) ils <$> shrinkAttr attr)
   shrink HorizontalRule = []
-  shrink (Table attr capt specs thead tbody tfoot) =
+  shrink (Table attr specs thead tbody tfoot) =
     -- TODO: shrink number of columns
-    [Table attr' capt specs thead tbody tfoot | attr' <- shrinkAttr attr] ++
-    [Table attr capt specs thead' tbody tfoot | thead' <- shrink thead] ++
-    [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]
+    [Table attr' specs thead tbody tfoot | attr' <- shrinkAttr attr] ++
+    [Table attr specs thead' tbody tfoot | thead' <- shrink thead] ++
+    [Table attr specs thead tbody' tfoot | tbody' <- shrink tbody] ++
+    [Table attr specs thead tbody tfoot' | tfoot' <- shrink tfoot]
+  shrink (Figure attr cp capt blks) =
+    [Figure attr cp capt blks' | blks' <- shrinkBlockList blks] ++
+    [Figure attr cp capt' blks | capt' <- shrink capt] ++
+    [Figure attr' cp capt blks | attr' <- shrinkAttr attr]
   shrink (Div attr blks) = (Div attr <$> shrinkBlockList blks)
                         ++ (flip Div blks <$> shrinkAttr attr)
   shrink Null = []
@@ -238,14 +241,17 @@ arbBlock n = frequency $ [ (10, Plain <$> arbInlines (n-1))
                    , (2, do cs <- choose (1 :: Int, 6)
                             bs <- choose (0 :: Int, 2)
                             Table <$> arbAttr
-                                  <*> arbitrary
                                   <*> vectorOf cs ((,) <$> arbitrary
                                                        <*> elements [ ColWidthDefault
                                                                     , ColWidth (1/3)
                                                                     , ColWidth 0.25 ])
                                   <*> arbTableHead (n-1)
                                   <*> vectorOf bs (arbTableBody (n-1))
                                   <*> arbTableFoot (n-1))
+                   , (2, Figure <$> arbAttr
+                                <*> arbitrary
+                                <*> arbitrary
+                                <*> listOf1 (arbBlock (n-1)))
                    ]
 
 arbRow :: Int -> Gen Row
@@ -335,10 +341,15 @@ instance Arbitrary Cell where
       [Cell attr malign' h w body | malign' <- shrink malign]
 
 instance Arbitrary Caption where
-  arbitrary = Caption <$> arbitrary <*> arbitrary
-  shrink (Caption mshort body)
-    = [Caption mshort' body | mshort' <- shrink mshort] ++
-      [Caption mshort body' | body' <- shrinkBlockList body]
+  arbitrary = Caption <$> arbAttr <*> arbitrary <*> arbitrary
+  shrink (Caption attr mshort body)
+    = [Caption attr mshort' body | mshort' <- shrink mshort] ++
+      [Caption attr mshort body' | body' <- shrinkBlockList body] ++
+      [Caption attr' mshort body | attr' <- shrinkAttr attr]
+
+instance Arbitrary CaptionPos where
+        arbitrary
+          = arbitraryBoundedEnum
 
 instance Arbitrary MathType where
         arbitrary

src/Text/Pandoc/Builder.hs

@@ -167,6 +167,8 @@ module Text.Pandoc.Builder ( module Text.Pandoc.Definition
                            , table
                            , simpleTable
                            , tableWith
+                           , figure
+                           , figureWith
                            , caption
                            , simpleCaption
                            , emptyCaption
@@ -517,23 +519,21 @@ emptyCell = simpleCell mempty
 -- | Table builder. Performs normalization with 'normalizeTableHead',
 -- 'normalizeTableBody', and 'normalizeTableFoot'. The number of table
 -- columns is given by the length of @['ColSpec']@.
-table :: Caption
-      -> [ColSpec]
+table :: [ColSpec]
       -> TableHead
       -> [TableBody]
       -> TableFoot
       -> Blocks
 table = tableWith nullAttr
 
 tableWith :: Attr
-          -> Caption
           -> [ColSpec]
           -> TableHead
           -> [TableBody]
           -> TableFoot
           -> Blocks
-tableWith attr capt specs th tbs tf
-  = singleton $ Table attr capt specs th' tbs' tf'
+tableWith attr specs th tbs tf
+  = singleton $ Table attr specs th' tbs' tf'
   where
     twidth = length specs
     th'  = normalizeTableHead twidth th
@@ -545,7 +545,7 @@ simpleTable :: [Blocks]   -- ^ Headers
             -> [[Blocks]] -- ^ Rows
             -> Blocks
 simpleTable headers rows =
-  table emptyCaption (replicate numcols defaults) th [tb] tf
+  table (replicate numcols defaults) th [tb] tf
   where defaults = (AlignDefault, ColWidthDefault)
         numcols  = maximum (map length (headers:rows))
         toRow = Row nullAttr . map simpleCell
@@ -556,8 +556,17 @@ simpleTable headers rows =
         tb = TableBody nullAttr 0 [] $ map toRow rows
         tf = TableFoot nullAttr []
 
+figure :: CaptionPos -> Caption -> Blocks -> Blocks
+figure = figureWith nullAttr
+
+figureWith :: Attr -> CaptionPos -> Caption -> Blocks -> Blocks
+figureWith attr capt cp = singleton . Figure attr capt cp . toList
+
 caption :: Maybe ShortCaption -> Blocks -> Caption
-caption x = Caption x . toList
+caption = captionWith nullAttr
+
+captionWith :: Attr -> Maybe ShortCaption -> Blocks -> Caption
+captionWith x y = Caption x y . toList
 
 simpleCaption :: Blocks -> Caption
 simpleCaption = caption Nothing

src/Text/Pandoc/Definition.hs

@@ -65,6 +65,7 @@ module Text.Pandoc.Definition ( Pandoc(..)
                               , nullAttr
                               , Caption(..)
                               , ShortCaption
+                              , CaptionPos(..)
                               , RowHeadColumns(..)
                               , Alignment(..)
                               , ColWidth(..)
@@ -251,8 +252,8 @@ 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.
-data Caption = Caption (Maybe ShortCaption) [Block]
+-- | The caption of a figure, with optional short caption.
+data Caption = Caption Attr (Maybe ShortCaption) [Block]
   deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)
 
 -- | A table cell.
@@ -267,6 +268,10 @@ newtype RowSpan = RowSpan Int
 newtype ColSpan = ColSpan Int
   deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum)
 
+-- | The position of a caption relative to the content of a figure.
+data CaptionPos = CaptionBefore | CaptionAfter
+  deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Enum, Bounded)
+
 -- | Block element.
 data Block
     -- | Plain text, not a paragraph
@@ -294,10 +299,12 @@ data Block
     | Header Int Attr [Inline]
     -- | Horizontal rule
     | HorizontalRule
-    -- | Table, with attributes, caption, optional short caption,
-    -- column alignments and widths (required), table head, table
-    -- bodies, and table foot
-    | Table Attr Caption [ColSpec] TableHead [TableBody] TableFoot
+    -- | Table, with attributes, column alignments and widths
+    -- (required), table head, table bodies, and table foot
+    | Table Attr [ColSpec] TableHead [TableBody] TableFoot
+    -- | Figure, with attributes, caption and caption position, width
+    -- (optional), and content (list of blocks)
+    | Figure Attr CaptionPos Caption [Block]
     -- | Generic block container with attributes
     | Div Attr [Block]
     -- | Nothing
@@ -546,12 +553,12 @@ instance FromJSON Caption where
   parseJSON (Object v) = do
     t <- v .: "t" :: Aeson.Parser Value
     case t of
-      "Caption" -> do (mshort, body) <- v .: "c"
-                      return $ Caption mshort body
+      "Caption" -> do (attr, mshort, body) <- v .: "c"
+                      return $ Caption attr mshort body
       _     -> mempty
   parseJSON _ = mempty
 instance ToJSON Caption where
-  toJSON (Caption mshort body) = tagged "Caption" (mshort, body)
+  toJSON (Caption attr mshort body) = tagged "Caption" (attr, mshort, body)
 
 instance FromJSON RowSpan where
   parseJSON (Object v) = do
@@ -627,6 +634,20 @@ instance FromJSON Cell where
 instance ToJSON Cell where
   toJSON (Cell attr malign rs cs body) = tagged "Cell" (attr, malign, rs, cs, body)
 
+instance FromJSON CaptionPos where
+  parseJSON (Object v) = do
+    t <- v .: "t" :: Aeson.Parser Value
+    case t of
+      "CaptionBefore" -> return CaptionBefore
+      "CaptionAfter"  -> return CaptionAfter
+      _               -> mempty
+  parseJSON _ = mempty
+instance ToJSON CaptionPos where
+  toJSON delim = taggedNoContent s
+    where s = case delim of
+            CaptionBefore -> "CaptionBefore"
+            CaptionAfter  -> "CaptionAfter"
+
 instance FromJSON Inline where
   parseJSON (Object v) = do
     t <- v .: "t" :: Aeson.Parser Value
@@ -703,8 +724,10 @@ instance FromJSON Block where
       "Header"         -> do (n, attr, ils) <- v .: "c"
                              return $ Header n attr ils
       "HorizontalRule" -> return HorizontalRule
-      "Table"          -> do (attr, cpt, align, hdr, body, foot) <- v .: "c"
-                             return $ Table attr cpt align hdr body foot
+      "Table"          -> do (attr, align, hdr, body, foot) <- v .: "c"
+                             return $ Table attr align hdr body foot
+      "Figure"         -> do (attr, cpos, cpt, blks) <- v .: "c"
+                             return $ Figure attr cpos cpt blks
       "Div"            -> do (attr, blks) <- v .: "c"
                              return $ Div attr blks
       "Null"           -> return Null
@@ -722,8 +745,10 @@ instance ToJSON Block where
   toJSON (DefinitionList defs) = tagged "DefinitionList" defs
   toJSON (Header n attr ils) = tagged "Header" (n, attr, ils)
   toJSON HorizontalRule = taggedNoContent "HorizontalRule"
-  toJSON (Table attr caption aligns hd body foot) =
-    tagged "Table" (attr, caption, aligns, hd, body, foot)
+  toJSON (Table attr aligns hd body foot) =
+    tagged "Table" (attr, aligns, hd, body, foot)
+  toJSON (Figure attr cp capt blks) =
+    tagged "Figure" (attr, cp, capt, blks)
   toJSON (Div attr blks) = tagged "Div" (attr, blks)
   toJSON Null = taggedNoContent "Null"
 
@@ -774,6 +799,7 @@ instance NFData ListNumberDelim
 instance NFData ListNumberStyle
 instance NFData ColWidth
 instance NFData RowHeadColumns
+instance NFData CaptionPos
 instance NFData Block
 instance NFData Pandoc
 

src/Text/Pandoc/Walk.hs

@@ -466,12 +466,15 @@ walkBlockM _ x@CodeBlock {}           = return x
 walkBlockM _ x@RawBlock {}            = return x
 walkBlockM _ HorizontalRule           = return HorizontalRule
 walkBlockM _ Null                     = return Null
-walkBlockM f (Table attr capt as hs bs fs)
-  = do capt' <- walkM f capt
-       hs' <- walkM f hs
+walkBlockM f (Table attr as hs bs fs)
+  = do hs' <- walkM f hs
        bs' <- walkM f bs
        fs' <- walkM f fs
-       return $ Table attr capt' as hs' bs' fs'
+       return $ Table attr as hs' bs' fs'
+walkBlockM f (Figure attr cp capt blks)
+  = do capt' <- walkM f capt
+       blks' <- walkM f blks
+       return $ Figure attr cp capt' blks'
 
 -- | Perform a query on elements nested below a @'Block'@ element by
 -- querying all directly nested lists of @Inline@s or @Block@s.
@@ -490,11 +493,13 @@ queryBlock f (BulletList cs)          = query f cs
 queryBlock f (DefinitionList xs)      = query f xs
 queryBlock f (Header _ _ xs)          = query f xs
 queryBlock _ HorizontalRule           = mempty
-queryBlock f (Table _ capt _ hs bs fs)
-  = query f capt <>
-    query f hs <>
+queryBlock f (Table _ _ 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
 
@@ -605,12 +610,12 @@ queryCell f (Cell _ _ _ _ content) = query f content
 -- nodes.
 walkCaptionM :: (Walkable a [Block], Walkable a [Inline], Monad m, Walkable a ShortCaption)
           => (a -> m a) -> Caption -> m Caption
-walkCaptionM f (Caption mshort body) = Caption <$> walkM f mshort <*> walkM f body
+walkCaptionM f (Caption attr mshort body) = Caption attr <$> walkM f mshort <*> walkM f body
 
 -- | Query the elements below a 'Cell' element.
 queryCaption :: (Walkable a [Block], Walkable a [Inline], Walkable a ShortCaption, Monoid c)
           => (a -> c) -> Caption -> c
-queryCaption f (Caption mshort body) = query f mshort <> query f body
+queryCaption f (Caption _ mshort body) = query f mshort <> query f body
 
 -- | Helper method to walk the components of a Pandoc element.
 walkPandocM :: (Walkable a Meta, Walkable a [Block], Monad m,