Add the SimpleFigure bidirectional pattern synonym.

Author: argent0

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
 
@@ -170,6 +171,8 @@ module Text.Pandoc.Builder ( module Text.Pandoc.Definition
                            , caption
                            , simpleCaption
                            , emptyCaption
+                           , simpleFigureWith
+                           , simpleFigure
                            , divWith
                            -- * Table processing
                            , normalizeTableHead
@@ -566,6 +569,13 @@ 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)
@@ -311,6 +313,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)
 

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
@@ -642,6 +643,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"
@@ -744,6 +756,8 @@ tests =
     ]
   , t_tableSan
   , t_tableNormExample
+  , testGroup "Figure"
+    [ testProperty "p_figureRepresentation figure representation" p_figureRepresentation ]
   ]