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

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
@@ -518,23 +520,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
@@ -546,7 +546,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
@@ -557,8 +557,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

@@ -66,6 +66,7 @@ module Text.Pandoc.Definition ( Pandoc(..)
                               , nullAttr
                               , Caption(..)
                               , ShortCaption
+                              , CaptionPos(..)
                               , RowHeadColumns(..)
                               , Alignment(..)
                               , ColWidth(..)
@@ -253,8 +254,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.
@@ -269,6 +270,10 @@ newtype RowSpan = RowSpan Int
 newtype ColSpan = ColSpan Int
   deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON)
 
+-- | 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
@@ -296,10 +301,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
@@ -374,6 +381,7 @@ $(let jsonOpts = defaultOptions
      , ''ColWidth
      , ''Row
      , ''Caption
+     , ''CaptionPos
      , ''TableHead
      , ''TableBody
      , ''TableFoot
@@ -440,6 +448,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,