simpleFigure builder [GSoC 2021]

src/Text/Pandoc/Arbitrary.hs

@@ -83,9 +83,10 @@ instance Arbitrary Blocks where
           flattenBlock (Header _ _ ils) = [Para ils]
           flattenBlock HorizontalRule = []
           flattenBlock (Table _ capt _ hd bd ft) = flattenCaption capt <>
-                                                   flattenTableHead hd <>
-                                                   concatMap flattenTableBody bd <>
-                                                   flattenTableFoot ft
+                                              flattenTableHead hd <>
+                                              concatMap flattenTableBody bd <>
+                                              flattenTableFoot ft
+          flattenBlock (Figure _ capt blks) = flattenCaption capt <> blks
           flattenBlock (Div _ blks) = blks
           flattenBlock Null = []
 
@@ -202,8 +203,11 @@ instance Arbitrary Block where
     [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 capt specs thead tbody tfoot' | tfoot' <- shrink tfoot]
+  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 +250,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

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable,
     GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,
     DeriveTraversable, OverloadedStrings, PatternGuards #-}
+
 {-
 Copyright (C) 2010-2019 John MacFarlane
 
@@ -167,9 +168,13 @@ module Text.Pandoc.Builder ( module Text.Pandoc.Definition
                            , table
                            , simpleTable
                            , tableWith
+                           , figure
+                           , figureWith
                            , caption
                            , simpleCaption
                            , emptyCaption
+                           , simpleFigureWith
+                           , simpleFigure
                            , divWith
                            -- * Table processing
                            , normalizeTableHead
@@ -557,15 +562,28 @@ 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
+caption msc = Caption msc . toList
 
 simpleCaption :: Blocks -> Caption
 simpleCaption = caption Nothing
 
 emptyCaption :: Caption
 emptyCaption = simpleCaption mempty
 
+simpleFigureWith :: Attr -> Inlines -> Text -> Text -> Blocks
+simpleFigureWith attr figureCaption url title =
+  para $ imageWith attr url ("fig:" <> title) figureCaption
+
+simpleFigure :: Inlines -> Text -> Text -> Blocks
+simpleFigure = simpleFigureWith nullAttr
+
 divWith :: Attr -> Blocks -> Blocks
 divWith attr = singleton . Div attr . toList
 

src/Text/Pandoc/Definition.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric,
     FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP,
-    TemplateHaskell #-}
+    TemplateHaskell , PatternSynonyms, ViewPatterns #-}
 
 {-
 Copyright (c) 2006-2019, John MacFarlane
@@ -57,6 +57,7 @@ module Text.Pandoc.Definition ( Pandoc(..)
                               , docAuthors
                               , docDate
                               , Block(..)
+                              , pattern SimpleFigure
                               , Inline(..)
                               , ListAttributes
                               , ListNumberStyle(..)
@@ -99,6 +100,7 @@ import Control.DeepSeq
 import Paths_pandoc_types (version)
 import Data.Version (Version, versionBranch)
 import Data.Semigroup (Semigroup(..))
+import Control.Arrow (second)
 
 data Pandoc = Pandoc Meta [Block]
               deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
@@ -252,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 figure, with optional short caption.
 data Caption = Caption (Maybe ShortCaption) [Block]
   deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)
 
@@ -295,10 +297,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, with attributes, 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
@@ -311,6 +315,34 @@ data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeab
 -- | Link target (URL, title).
 type Target = (Text, Text)
 
+isFigureTarget :: Target -> Maybe Target
+isFigureTarget tgt
+  | (src, Just tit) <- second (T.stripPrefix "fig:") tgt = Just (src, tit)
+  | otherwise = Nothing
+
+-- | Bidirectional patter synonym
+--
+-- It can pass as a Block constructor
+--
+-- >>> SimpleFigure nullAttr [] (T.pack "", T.pack "title")
+-- Para [Image ("",[],[]) [] ("","fig:title")]
+--
+--
+-- It can be used to pattern match
+-- >>> let img = Para [Image undefined undefined (undefined, T.pack "title")]
+-- >>> case img of { SimpleFigure _ _ _ -> True; _ -> False }
+-- False
+-- >>> let fig = Para [Image undefined undefined (undefined, T.pack "fig:title")]
+-- >>> case fig of { SimpleFigure _ _ tit -> snd tit; _ -> T.pack "" }
+-- "title"
+pattern SimpleFigure :: Attr -> [Inline] -> Target -> Block
+pattern SimpleFigure attr figureCaption tgt <-
+    Para [Image attr figureCaption
+        (isFigureTarget -> Just tgt)]  where
+  SimpleFigure attr figureCaption tgt =
+    Para [Image attr figureCaption (second ("fig:" <>) tgt)]
+
+
 -- | Type of math element (display or inline).
 data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic)
 

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

@@ -5,15 +5,16 @@ import Text.Pandoc.Definition
 import Text.Pandoc.Walk
 import Text.Pandoc.Builder (singleton, plain, text, simpleTable, table, emptyCell,
                             normalizeTableHead, normalizeTableBody, normalizeTableFoot,
-                            emptyCaption)
+                            emptyCaption, simpleFigureWith)
+import qualified Text.Pandoc.Builder as Builder
 import Data.Generics
 import Data.List (tails)
 import Test.HUnit (Assertion, assertEqual, assertFailure)
 import Data.Aeson (FromJSON, ToJSON, encode, decode)
 import Test.Framework
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 import Test.Framework.Providers.HUnit (testCase)
-import Test.QuickCheck (forAll, choose, Property, Arbitrary, Testable)
+import Test.QuickCheck (forAll, choose, Property, Arbitrary, Testable, arbitrary, Gen)
 import qualified Data.Map as M
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -335,7 +336,8 @@ t_row = (Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")])
         ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["",[],[]],{"t":"AlignRight"},2,3,[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]]]|])
 
 t_caption :: (Caption, ByteString)
-t_caption = (Caption (Just [Str "foo"]) [Para [Str "bar"]]
+t_caption = (Caption
+             (Just [Str "foo"]) [Para [Str "bar"]]
             ,[s|[[{"t":"Str","c":"foo"}],[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]|])
 
 t_tablehead :: (TableHead, ByteString)
@@ -429,13 +431,22 @@ t_table = ( Table
               ,tCell [Str "footleft"]
               ,tCell [Str "footcenter"]
               ,tCell [Str "footdefault"]]])
+
           ,[s|{"t":"Table","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[{"t":"Str","c":"short"}],[{"t":"Para","c":[{"t":"Str","c":"Demonstration"},{"t":"Space"},{"t":"Str","c":"of"},{"t":"Space"},{"t":"Str","c":"simple"},{"t":"Space"},{"t":"Str","c":"table"},{"t":"Space"},{"t":"Str","c":"syntax."}]}]],[[{"t":"AlignDefault"},{"t":"ColWidthDefault"}],[{"t":"AlignRight"},{"t":"ColWidthDefault"}],[{"t":"AlignLeft"},{"t":"ColWidthDefault"}],[{"t":"AlignCenter"},{"t":"ColWidthDefault"}],[{"t":"AlignDefault"},{"t":"ColWidthDefault"}]],[["idh",["klsh"],[["k1h","v1h"],["k2h","v2h"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Head"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Right"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Left"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Center"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Default"}]}]]]]]],[[["idb",["klsb"],[["k1b","v1b"],["k2b","v2b"]]],1,[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"ihead12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head12"}]}]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]]]]]],[["idf",["klsf"],[["k1f","v1f"],["k2f","v2f"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"foot"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footright"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footleft"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footcenter"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footdefault"}]}]]]]]]]}|]
               )
   where
     tCell i = Cell ("a", ["b"], [("c", "d"), ("e", "f")]) AlignDefault 1 1 [Plain i]
     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"}]}]]}|]
@@ -460,7 +471,7 @@ t_tableSan = testCase "table sanitisation" assertion
                    emptyRow = Row nullAttr $ replicate 2 emptyCell
                    expected = singleton (Table
                                           nullAttr
-                                          (Caption Nothing [])
+                                          emptyCaption
                                           [(AlignDefault,ColWidthDefault)
                                           ,(AlignDefault,ColWidthDefault)]
                                           (TableHead nullAttr
@@ -642,6 +653,17 @@ t_tableNormExample = testCase "table normalization example" assertion
                                  (tf finalHeads)
     generated = table emptyCaption spec (th initialHeads) [initialTB] (tf initialHeads)
 
+p_figureRepresentation :: Property
+p_figureRepresentation = forAll (arbitrary :: Gen [Inline]) (\figureCaption ->
+  simpleFigureWith
+      ("", [], [])
+      (Builder.fromList figureCaption)
+      "url"
+      "title" ==
+      Builder.fromList
+          [Para [Image ("", [], []) figureCaption ("url", "fig:title") ]]
+  )
+
 tests :: [Test]
 tests =
   [ testGroup "Walk"
@@ -715,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
         ]
@@ -744,6 +767,8 @@ tests =
     ]
   , t_tableSan
   , t_tableNormExample
+  , testGroup "Figure"
+    [ testProperty "p_figureRepresentation figure representation" p_figureRepresentation ]
   ]