diff --git a/pandoc-types.cabal b/pandoc-types.cabal index d846c5a..7878df3 100644 --- a/pandoc-types.cabal +++ b/pandoc-types.cabal @@ -43,12 +43,14 @@ Source-repository head Library hs-source-dirs: src Exposed-modules: Text.Pandoc.Definition + Text.Pandoc.Definition.Functors Text.Pandoc.Generic Text.Pandoc.Walk Text.Pandoc.Builder Text.Pandoc.JSON Text.Pandoc.Arbitrary Other-modules: Paths_pandoc_types + Text.Pandoc.Definition.Misc Autogen-modules: Paths_pandoc_types Build-depends: base >= 4.5 && < 5, containers >= 0.3, diff --git a/src/Text/Pandoc/Arbitrary.hs b/src/Text/Pandoc/Arbitrary.hs index 142baea..075f407 100644 --- a/src/Text/Pandoc/Arbitrary.hs +++ b/src/Text/Pandoc/Arbitrary.hs @@ -1,14 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-} -- provides Arbitrary instance for Pandoc types module Text.Pandoc.Arbitrary () where -import Test.QuickCheck +import Test.QuickCheck hiding (shrinkList) +import qualified Test.QuickCheck as QC import Control.Applicative (Applicative ((<*>), pure), (<$>)) import Control.Monad (forM) import Data.Text (Text) import qualified Data.Text as T import Text.Pandoc.Definition +import qualified Text.Pandoc.Definition.Functors as F import Text.Pandoc.Builder realString :: Gen Text @@ -100,47 +102,46 @@ instance Arbitrary Blocks where flattenRow (Row _ body) = concatMap flattenCell body flattenCell (Cell _ _ _ _ blks) = blks -shrinkInlineList :: [Inline] -> [[Inline]] -shrinkInlineList = fmap toList . shrink . fromList +shrinkList :: Arbitrary (Many a) => [a] -> [[a]] +shrinkList = fmap toList . shrink . fromList -shrinkInlinesList :: [[Inline]] -> [[[Inline]]] -shrinkInlinesList = fmap (fmap toList) . shrink . fmap fromList - -shrinkBlockList :: [Block] -> [[Block]] -shrinkBlockList = fmap toList . shrink . fromList - -shrinkBlocksList :: [[Block]] -> [[[Block]]] -shrinkBlocksList = fmap (fmap toList) . shrink . fmap fromList +shrinkLists :: Arbitrary (Many a) => [[a]] -> [[[a]]] +shrinkLists = fmap (fmap toList) . shrink . fmap fromList instance Arbitrary Inline where arbitrary = resize 3 $ arbInline 2 - shrink (Str s) = Str <$> shrinkText s - shrink (Emph ils) = Emph <$> shrinkInlineList ils - shrink (Underline ils) = Underline <$> shrinkInlineList ils - shrink (Strong ils) = Strong <$> shrinkInlineList ils - shrink (Strikeout ils) = Strikeout <$> shrinkInlineList ils - shrink (Superscript ils) = Superscript <$> shrinkInlineList ils - shrink (Subscript ils) = Subscript <$> shrinkInlineList ils - shrink (SmallCaps ils) = SmallCaps <$> shrinkInlineList ils - shrink (Quoted qtype ils) = Quoted qtype <$> shrinkInlineList ils - shrink (Cite cits ils) = (Cite cits <$> shrinkInlineList ils) - ++ (flip Cite ils <$> shrink cits) - shrink (Code attr s) = (Code attr <$> shrinkText s) - ++ (flip Code s <$> shrinkAttr attr) - shrink Space = [] - shrink SoftBreak = [] - shrink LineBreak = [] - shrink (Math mtype s) = Math mtype <$> shrinkText s - shrink (RawInline fmt s) = RawInline fmt <$> shrinkText s - shrink (Link attr ils target) = [Link attr ils' target | ils' <- shrinkInlineList ils] - ++ [Link attr ils target' | target' <- shrinkText2 target] - ++ [Link attr' ils target | attr' <- shrinkAttr attr] - shrink (Image attr ils target) = [Image attr ils' target | ils' <- shrinkInlineList ils] - ++ [Image attr ils target' | target' <- shrinkText2 target] - ++ [Image attr' ils target | attr' <- shrinkAttr attr] - shrink (Note blks) = Note <$> shrinkBlockList blks - shrink (Span attr s) = (Span attr <$> shrink s) - ++ (flip Span s <$> shrinkAttr attr) + shrink = fmap Inline . shrinkInline . unInline + +shrinkInline :: ( Arbitrary b, Arbitrary (Many b) + , Arbitrary i, Arbitrary (Many i)) + => F.Inline b i -> [F.Inline b i] +shrinkInline (F.Str s) = F.Str <$> shrinkText s +shrinkInline (F.Emph ils) = F.Emph <$> shrinkList ils +shrinkInline (F.Underline ils) = F.Underline <$> shrinkList ils +shrinkInline (F.Strong ils) = F.Strong <$> shrinkList ils +shrinkInline (F.Strikeout ils) = F.Strikeout <$> shrinkList ils +shrinkInline (F.Superscript ils) = F.Superscript <$> shrinkList ils +shrinkInline (F.Subscript ils) = F.Subscript <$> shrinkList ils +shrinkInline (F.SmallCaps ils) = F.SmallCaps <$> shrinkList ils +shrinkInline (F.Quoted qtype ils) = F.Quoted qtype <$> shrinkList ils +shrinkInline (F.Cite cits ils) = (F.Cite cits <$> shrinkList ils) + ++ (flip F.Cite ils <$> QC.shrinkList shrinkCitation cits) +shrinkInline (F.Code attr s) = (F.Code attr <$> shrinkText s) + ++ (flip F.Code s <$> shrinkAttr attr) +shrinkInline F.Space = [] +shrinkInline F.SoftBreak = [] +shrinkInline F.LineBreak = [] +shrinkInline (F.Math mtype s) = F.Math mtype <$> shrinkText s +shrinkInline (F.RawInline fmt s) = F.RawInline fmt <$> shrinkText s +shrinkInline (F.Link attr ils target) = [F.Link attr ils' target | ils' <- shrinkList ils] + ++ [F.Link attr ils target' | target' <- shrinkText2 target] + ++ [F.Link attr' ils target | attr' <- shrinkAttr attr] +shrinkInline (F.Image attr ils target) = [F.Image attr ils' target | ils' <- shrinkList ils] + ++ [F.Image attr ils target' | target' <- shrinkText2 target] + ++ [F.Image attr' ils target | attr' <- shrinkAttr attr] +shrinkInline (F.Note blks) = F.Note <$> shrinkList blks +shrinkInline (F.Span attr s) = (F.Span attr <$> shrink s) + ++ (flip F.Span s <$> shrinkAttr attr) arbInlines :: Int -> Gen [Inline] arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace) @@ -149,136 +150,169 @@ arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace) -- Note: no LineBreak, similarly to Text.Pandoc.Builder (trimInlines) startsWithSpace _ = False +arbInline :: Int -> Gen Inline +arbInline = fmap Inline . arbInline' arbBlock arbInlines + -- restrict to 3 levels of nesting max; otherwise we get -- bogged down in indefinitely large structures -arbInline :: Int -> Gen Inline -arbInline n = frequency $ [ (60, Str <$> realString) - , (40, pure Space) - , (10, pure SoftBreak) - , (10, pure LineBreak) - , (10, Code <$> arbAttr <*> realString) - , (5, elements [ RawInline (Format "html") "" - , RawInline (Format "latex") "\\my{command}" ]) +arbInline' :: Arbitrary inline + => (Int -> Gen block) -> (Int -> Gen [inline]) + -> Int -> Gen (F.Inline block inline) +arbInline' arbB arbIs n = frequency $ + [ (60, F.Str <$> realString) + , (40, pure F.Space) + , (10, pure F.SoftBreak) + , (10, pure F.LineBreak) + , (10, F.Code <$> arbAttr <*> realString) + , (5, elements [ F.RawInline (Format "html") "" + , F.RawInline (Format "latex") "\\my{command}" ]) ] ++ [ x | n > 1, x <- nesters] - where nesters = [ (10, Emph <$> arbInlines (n-1)) - , (10, Underline <$> arbInlines (n-1)) - , (10, Strong <$> arbInlines (n-1)) - , (10, Strikeout <$> arbInlines (n-1)) - , (10, Superscript <$> arbInlines (n-1)) - , (10, Subscript <$> arbInlines (n-1)) - , (10, SmallCaps <$> arbInlines (n-1)) - , (10, Span <$> arbAttr <*> arbInlines (n-1)) - , (10, Quoted <$> arbitrary <*> arbInlines (n-1)) - , (10, Math <$> arbitrary <*> realString) - , (10, Link <$> arbAttr <*> arbInlines (n-1) <*> ((,) <$> realString <*> realString)) - , (10, Image <$> arbAttr <*> arbInlines (n-1) <*> ((,) <$> realString <*> realString)) - , (2, Cite <$> arbitrary <*> arbInlines 1) - , (2, Note <$> resize 3 (listOf1 $ arbBlock (n-1))) + where nesters = [ (10, F.Emph <$> arbIs (n-1)) + , (10, F.Underline <$> arbIs (n-1)) + , (10, F.Strong <$> arbIs (n-1)) + , (10, F.Strikeout <$> arbIs (n-1)) + , (10, F.Superscript <$> arbIs (n-1)) + , (10, F.Subscript <$> arbIs (n-1)) + , (10, F.SmallCaps <$> arbIs (n-1)) + , (10, F.Span <$> arbAttr <*> arbIs (n-1)) + , (10, F.Quoted <$> arbitrary <*> arbIs (n-1)) + , (10, F.Math <$> arbitrary <*> realString) + , (10, F.Link <$> arbAttr <*> arbIs (n-1) <*> ((,) <$> realString <*> realString)) + , (10, F.Image <$> arbAttr <*> arbIs (n-1) <*> ((,) <$> realString <*> realString)) + , (2, F.Cite <$> listOf (arbitraryCitation $ arbIs 1) <*> arbIs 1) + , (2, F.Note <$> resize 3 (listOf1 $ arbB (n-1))) ] instance Arbitrary Block where arbitrary = resize 3 $ arbBlock 2 - shrink (Plain ils) = Plain <$> shrinkInlineList ils - shrink (Para ils) = Para <$> shrinkInlineList ils - shrink (LineBlock lns) = LineBlock <$> shrinkInlinesList lns - shrink (CodeBlock attr s) = (CodeBlock attr <$> shrinkText s) - ++ (flip CodeBlock s <$> shrinkAttr attr) - shrink (RawBlock fmt s) = RawBlock fmt <$> shrinkText s - shrink (BlockQuote blks) = BlockQuote <$> shrinkBlockList blks - shrink (OrderedList listAttrs blksList) = OrderedList listAttrs <$> shrinkBlocksList blksList - shrink (BulletList blksList) = BulletList <$> shrinkBlocksList blksList - shrink (DefinitionList defs) = DefinitionList <$> shrinkDefinitionList defs - where shrinkDefinition (ils, blksList) = [(ils', blksList) | ils' <- shrinkInlineList ils] - ++ [(ils, blksList') | blksList' <- shrinkBlocksList blksList] - shrinkDefinitionList (x:xs) = [xs] - ++ [x':xs | x' <- shrinkDefinition x] - ++ [x:xs' | xs' <- shrinkDefinitionList xs] - shrinkDefinitionList [] = [] - 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) = - -- 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] - shrink (Div attr blks) = (Div attr <$> shrinkBlockList blks) - ++ (flip Div blks <$> shrinkAttr attr) - shrink Null = [] + shrink = fmap Block . shrinkBlock . unBlock + +shrinkBlock :: ( Arbitrary b, Arbitrary (Many b) + , Arbitrary i, Arbitrary (Many i)) + => F.Block i b -> [F.Block i b] +shrinkBlock (F.Plain ils) = F.Plain <$> shrinkList ils +shrinkBlock (F.Para ils) = F.Para <$> shrinkList ils +shrinkBlock (F.LineBlock lns) = F.LineBlock <$> shrinkLists lns +shrinkBlock (F.CodeBlock attr s) = (F.CodeBlock attr <$> shrinkText s) + ++ (flip F.CodeBlock s <$> shrinkAttr attr) +shrinkBlock (F.RawBlock fmt s) = F.RawBlock fmt <$> shrinkText s +shrinkBlock (F.BlockQuote blks) = F.BlockQuote <$> shrinkList blks +shrinkBlock (F.OrderedList listAttrs blksList) = F.OrderedList listAttrs <$> shrinkLists blksList +shrinkBlock (F.BulletList blksList) = F.BulletList <$> shrinkLists blksList +shrinkBlock (F.DefinitionList defs) = F.DefinitionList <$> shrinkDefinitionList defs + where shrinkDefinition (ils, blksList) = [(ils', blksList) | ils' <- shrinkList ils] + ++ [(ils, blksList') | blksList' <- shrinkLists blksList] + shrinkDefinitionList (x:xs) = [xs] + ++ [x':xs | x' <- shrinkDefinition x] + ++ [x:xs' | xs' <- shrinkDefinitionList xs] + shrinkDefinitionList [] = [] +shrinkBlock (F.Header n attr ils) = (F.Header n attr <$> shrinkList ils) + ++ (flip (F.Header n) ils <$> shrinkAttr attr) +shrinkBlock F.HorizontalRule = [] +shrinkBlock (F.Table attr capt specs thead tbody tfoot) = + -- F.TODO: shrink number of columns + [F.Table attr' capt specs thead tbody tfoot | attr' <- shrinkAttr attr] ++ + [F.Table attr capt specs thead' tbody tfoot | thead' <- shrinkTableHead thead] ++ + [F.Table attr capt specs thead tbody' tfoot | tbody' <- QC.shrinkList shrinkTableBody tbody] ++ + [F.Table attr capt specs thead tbody tfoot' | tfoot' <- shrinkTableFoot tfoot] ++ + [F.Table attr capt' specs thead tbody tfoot | capt' <- shrinkCaption capt] +shrinkBlock (F.Div attr blks) = (F.Div attr <$> shrinkList blks) + ++ (flip F.Div blks <$> shrinkAttr attr) +shrinkBlock F.Null = [] arbBlock :: Int -> Gen Block -arbBlock n = frequency $ [ (10, Plain <$> arbInlines (n-1)) - , (15, Para <$> arbInlines (n-1)) - , (5, CodeBlock <$> arbAttr <*> realString) - , (3, LineBlock <$> - ((:) <$> - arbInlines ((n - 1) `mod` 3) <*> - forM [1..((n - 1) `div` 3)] (const (arbInlines 3)))) - , (2, elements [ RawBlock (Format "html") +arbBlock = fmap Block . arbBlock' arbInline arbInlines arbBlock + +arbBlock' :: (Int -> Gen inline) -> (Int -> Gen [inline]) + -> (Int -> Gen block) + -> Int -> Gen (F.Block inline block) +arbBlock' arbI arbIs arbB n = frequency $ + [ (10, F.Plain <$> arbIs (n-1)) + , (15, F.Para <$> arbIs (n-1)) + , (5, F.CodeBlock <$> arbAttr <*> realString) + , (3, F.LineBlock <$> + ((:) <$> + arbIs ((n - 1) `mod` 3) <*> + forM [1..((n - 1) `div` 3)] (const (arbIs 3)))) + , (2, elements [ F.RawBlock (F.Format "html") "
\n*&*\n
" - , RawBlock (Format "latex") + , F.RawBlock (F.Format "latex") "\\begin[opt]{env}\nhi\n{\\end{env}" ]) - , (5, Header <$> choose (1 :: Int, 6) - <*> pure nullAttr - <*> arbInlines (n-1)) - , (2, pure HorizontalRule) + , (5, F.Header <$> choose (1 :: Int, 6) + <*> pure nullAttr + <*> arbIs (n-1)) + , (2, pure F.HorizontalRule) ] ++ [x | n > 0, x <- nesters] - where nesters = [ (5, BlockQuote <$> listOf1 (arbBlock (n-1))) - , (5, OrderedList <$> ((,,) <$> (arbitrary `suchThat` (> 0)) - <*> arbitrary - <*> arbitrary) - <*> listOf1 (listOf1 $ arbBlock (n-1))) - , (5, BulletList <$> listOf1 (listOf1 $ arbBlock (n-1))) - , (5, DefinitionList <$> listOf1 ((,) <$> arbInlines (n-1) - <*> listOf1 (listOf1 $ arbBlock (n-1)))) - , (5, Div <$> arbAttr <*> listOf1 (arbBlock (n-1))) + where nesters = [ (5, F.BlockQuote <$> listOf1 (arbB (n-1))) + , (5, F.OrderedList <$> ((,,) <$> (arbitrary `suchThat` (> 0)) + <*> arbitrary + <*> arbitrary) + <*> listOf1 (listOf1 $ arbB (n-1))) + , (5, F.BulletList <$> listOf1 (listOf1 $ arbB (n-1))) + , (5, F.DefinitionList <$> listOf1 ((,) <$> arbIs (n-1) + <*> listOf1 (listOf1 $ arbB (n-1)))) + , (5, F.Div <$> arbAttr <*> listOf1 (arbB (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)) + F.Table <$> arbAttr + <*> arbitraryCaption' (sized arbI) (sized arbB) + <*> vectorOf cs ((,) <$> arbitrary + <*> elements [ F.ColWidthDefault + , F.ColWidth (1/3) + , F.ColWidth 0.25 ]) + <*> arbTableHead' arbB (n-1) + <*> vectorOf bs (arbTableBody' arbB (n-1)) + <*> arbTableFoot' arbB (n-1)) ] -arbRow :: Int -> Gen Row -arbRow n = do +arbRow :: Int -> Gen (F.Row Block) +arbRow = arbRow' arbBlock + +arbTableHead :: Int -> Gen (F.TableHead Block) +arbTableHead = arbTableHead' arbBlock + +arbTableBody :: Int -> Gen (F.TableBody Block) +arbTableBody = arbTableBody' arbBlock + +arbTableFoot :: Int -> Gen (F.TableFoot Block) +arbTableFoot = arbTableFoot' arbBlock + +arbCell :: Int -> Gen (F.Cell Block) +arbCell = arbCell' arbBlock + +arbRow' :: (Int -> Gen block) -> Int -> Gen (F.Row block) +arbRow' arbB n = do cs <- choose (0, 5) - Row <$> arbAttr <*> vectorOf cs (arbCell n) + Row <$> arbAttr <*> vectorOf cs (arbCell' arbB n) -arbTableHead :: Int -> Gen TableHead -arbTableHead n = do +arbTableHead' :: (Int -> Gen block) -> Int -> Gen (F.TableHead block) +arbTableHead' arbB n = do rs <- choose (0, 5) - TableHead <$> arbAttr <*> vectorOf rs (arbRow n) + TableHead <$> arbAttr <*> vectorOf rs (arbRow' arbB n) -arbTableBody :: Int -> Gen TableBody -arbTableBody n = do +arbTableBody' :: (Int -> Gen block) -> Int -> Gen (F.TableBody block) +arbTableBody' arbB n = do hrs <- choose (0 :: Int, 2) rs <- choose (0, 5) rhc <- choose (0, 5) TableBody <$> arbAttr <*> pure (RowHeadColumns rhc) - <*> vectorOf hrs (arbRow n) - <*> vectorOf rs (arbRow n) + <*> vectorOf hrs (arbRow' arbB n) + <*> vectorOf rs (arbRow' arbB n) -arbTableFoot :: Int -> Gen TableFoot -arbTableFoot n = do +arbTableFoot' :: (Int -> Gen block) -> Int -> Gen (F.TableFoot block) +arbTableFoot' arbB n = do rs <- choose (0, 5) - TableFoot <$> arbAttr <*> vectorOf rs (arbRow n) + TableFoot <$> arbAttr <*> vectorOf rs (arbRow' arbB n) -arbCell :: Int -> Gen Cell -arbCell n = Cell <$> arbAttr +arbCell' :: (Int -> Gen block) -> Int -> Gen (F.Cell block) +arbCell' arbB n = Cell + <$> arbAttr <*> arbitrary <*> (RowSpan <$> choose (1 :: Int, 2)) <*> (ColSpan <$> choose (1 :: Int, 2)) - <*> listOf (arbBlock n) + <*> listOf (arbB n) instance Arbitrary Pandoc where arbitrary = resize 8 (Pandoc <$> arbitrary <*> arbitrary) @@ -293,52 +327,81 @@ instance Arbitrary CitationMode where _ -> error "FATAL ERROR: Arbitrary instance, logic bug" instance Arbitrary Citation where - arbitrary + arbitrary = arbitraryCitation $ arbInlines 1 + shrink = shrinkCitation + +arbitraryCitation :: Gen [inline] -> Gen (F.Citation inline) +arbitraryCitation arbIs = Citation <$> fmap T.pack (listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_']) - <*> arbInlines 1 - <*> arbInlines 1 + <*> arbIs + <*> arbIs <*> arbitrary <*> arbitrary <*> arbitrary +shrinkCitation :: F.Citation inline -> [F.Citation inline] +shrinkCitation _ = [] + instance Arbitrary Row where arbitrary = resize 3 $ arbRow 2 - shrink (Row attr body) + shrink = shrinkRow + +shrinkRow :: Arbitrary (Many block) => F.Row block -> [F.Row block] +shrinkRow (Row attr body) = [Row attr' body | attr' <- shrinkAttr attr] ++ - [Row attr body' | body' <- shrink body] + [Row attr body' | body' <- QC.shrinkList shrinkCell body] instance Arbitrary TableHead where arbitrary = resize 3 $ arbTableHead 2 - shrink (TableHead attr body) + shrink = shrinkTableHead + +shrinkTableHead :: Arbitrary (Many b) => F.TableHead b -> [F.TableHead b] +shrinkTableHead (TableHead attr body) = [TableHead attr' body | attr' <- shrinkAttr attr] ++ - [TableHead attr body' | body' <- shrink body] + [TableHead attr body' | body' <- QC.shrinkList shrinkRow body] instance Arbitrary TableBody where arbitrary = resize 3 $ arbTableBody 2 - -- TODO: shrink rhc? - shrink (TableBody attr rhc hd bd) + shrink = shrinkTableBody + +-- TODO: shrink rhc? +shrinkTableBody :: Arbitrary (Many b) => F.TableBody b -> [F.TableBody b] +shrinkTableBody (TableBody attr rhc hd bd) = [TableBody attr' rhc hd bd | attr' <- shrinkAttr attr] ++ - [TableBody attr rhc hd' bd | hd' <- shrink hd] ++ - [TableBody attr rhc hd bd' | bd' <- shrink bd] + [TableBody attr rhc hd' bd | hd' <- QC.shrinkList shrinkRow hd] ++ + [TableBody attr rhc hd bd' | bd' <- QC.shrinkList shrinkRow bd] instance Arbitrary TableFoot where arbitrary = resize 3 $ arbTableFoot 2 - shrink (TableFoot attr body) + shrink = shrinkTableFoot + +shrinkTableFoot :: Arbitrary (Many b) => F.TableFoot b -> [F.TableFoot b] +shrinkTableFoot (TableFoot attr body) = [TableFoot attr' body | attr' <- shrinkAttr attr] ++ - [TableFoot attr body' | body' <- shrink body] + [TableFoot attr body' | body' <- QC.shrinkList shrinkRow body] instance Arbitrary Cell where arbitrary = resize 3 $ arbCell 2 - shrink (Cell attr malign h w body) - = [Cell attr malign h w body' | body' <- shrinkBlockList body] ++ + shrink = shrinkCell + +shrinkCell :: Arbitrary (Many b) => F.Cell b -> [F.Cell b] +shrinkCell (Cell attr malign h w body) + = [Cell attr malign h w body' | body' <- shrinkList body] ++ [Cell attr' malign h w body | attr' <- shrinkAttr attr] ++ [Cell attr malign' h w body | malign' <- shrink malign] instance Arbitrary Caption where - arbitrary = Caption <$> arbitrary <*> arbitrary - shrink (Caption mshort body) + arbitrary = arbitraryCaption' arbitrary arbitrary + shrink = shrinkCaption + +arbitraryCaption' :: Gen inline -> Gen block -> Gen (F.Caption inline block) +arbitraryCaption' arbI arbB = Caption <$> liftArbitrary (liftArbitrary arbI) <*> liftArbitrary arbB + +shrinkCaption :: (Arbitrary inline, Arbitrary (Many block)) + => F.Caption inline block -> [F.Caption inline block] +shrinkCaption (Caption mshort body) = [Caption mshort' body | mshort' <- shrink mshort] ++ - [Caption mshort body' | body' <- shrinkBlockList body] + [Caption mshort body' | body' <- shrinkList body] instance Arbitrary MathType where arbitrary diff --git a/src/Text/Pandoc/Definition.hs b/src/Text/Pandoc/Definition.hs index 5674089..c5daacc 100644 --- a/src/Text/Pandoc/Definition.hs +++ b/src/Text/Pandoc/Definition.hs @@ -49,45 +49,96 @@ of documents. -} module Text.Pandoc.Definition ( Pandoc(..) , Meta(..) - , MetaValue(..) + , MetaValue + ( .. + , MetaMap + , MetaList + , MetaBool + , MetaString + , MetaInlines + , MetaBlocks + ) , nullMeta , isNullMeta , lookupMeta , docTitle , docAuthors , docDate - , Block(..) + , Block + ( .. + , Plain + , Para + , LineBlock + , CodeBlock + , RawBlock + , BlockQuote + , OrderedList + , BulletList + , DefinitionList + , Header + , HorizontalRule + , Table + , Div + , Null + ) , pattern SimpleFigure - , Inline(..) + , Inline + ( .. + , Str + , Emph + , Underline + , Strong + , Strikeout + , Superscript + , Subscript + , SmallCaps + , Quoted + , Cite + , Code + , Space + , SoftBreak + , LineBreak + , Math + , RawInline + , Link + , Image + , Note + , Span + ) , ListAttributes , ListNumberStyle(..) , ListNumberDelim(..) , Format(..) , Attr , nullAttr - , Caption(..) + , Caption, pattern F.Caption , ShortCaption , RowHeadColumns(..) , Alignment(..) , ColWidth(..) , ColSpec - , Row(..) - , TableHead(..) - , TableBody(..) - , TableFoot(..) - , Cell(..) + , Row, pattern F.Row + , TableHead, pattern F.TableHead + , TableBody, pattern F.TableBody + , TableFoot, pattern F.TableFoot + , Cell, pattern F.Cell , RowSpan(..) , ColSpan(..) , QuoteType(..) , Target , MathType(..) - , Citation(..) + , Citation, pattern F.Citation + , F.citationId + , F.citationPrefix + , F.citationSuffix + , F.citationMode + , F.citationNoteNum + , F.citationHash , CitationMode(..) , pandocTypesVersion ) where import Data.Generics (Data, Typeable) -import Data.Ord (comparing) import Data.Aeson hiding (Null) import Data.Aeson.TH (deriveJSON) import qualified Data.Aeson.Types as Aeson @@ -95,13 +146,14 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) -import Data.String import Control.DeepSeq -import Paths_pandoc_types (version) -import Data.Version (Version, versionBranch) +import Data.Version (versionBranch) import Data.Semigroup (Semigroup(..)) import Control.Arrow (second) +import qualified Text.Pandoc.Definition.Functors as F +import Text.Pandoc.Definition.Misc + data Pandoc = Pandoc Meta [Block] deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) @@ -124,14 +176,36 @@ instance Monoid Meta where mempty = Meta M.empty mappend = (<>) -data MetaValue = MetaMap (M.Map Text MetaValue) - | MetaList [MetaValue] - | MetaBool Bool - | MetaString Text - | MetaInlines [Inline] - | MetaBlocks [Block] +newtype MetaValue = MetaValue + { unMetaValue :: F.MetaValue Inline Block MetaValue } deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +{-# COMPLETE MetaMap + , MetaList + , MetaBool + , MetaString + , MetaInlines + , MetaBlocks + :: MetaValue #-} + +pattern MetaMap :: M.Map Text MetaValue -> MetaValue +pattern MetaMap m = MetaValue (F.MetaMap m) + +pattern MetaList :: [MetaValue] -> MetaValue +pattern MetaList l = MetaValue (F.MetaList l) + +pattern MetaBool :: Bool -> MetaValue +pattern MetaBool b = MetaValue (F.MetaBool b) + +pattern MetaString :: Text -> MetaValue +pattern MetaString t = MetaValue (F.MetaString t) + +pattern MetaInlines :: [Inline] -> MetaValue +pattern MetaInlines is = MetaValue (F.MetaInlines is) + +pattern MetaBlocks :: [Block] -> MetaValue +pattern MetaBlocks bs = MetaValue (F.MetaBlocks bs) + nullMeta :: Meta nullMeta = Meta M.empty @@ -177,141 +251,109 @@ docDate meta = Just (MetaBlocks [Para ils]) -> ils _ -> [] --- | List attributes. The first element of the triple is the --- start number of the list. -type ListAttributes = (Int, ListNumberStyle, ListNumberDelim) - --- | Style of list numbers. -data ListNumberStyle = DefaultStyle - | Example - | Decimal - | LowerRoman - | UpperRoman - | LowerAlpha - | UpperAlpha deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) - --- | Delimiter of list numbers. -data ListNumberDelim = DefaultDelim - | Period - | OneParen - | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) - --- | Attributes: identifier, classes, key-value pairs -type Attr = (Text, [Text], [(Text, Text)]) - -nullAttr :: Attr -nullAttr = ("",[],[]) - --- | Formats for raw blocks -newtype Format = Format Text - deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON) - -instance IsString Format where - fromString f = Format $ T.toCaseFold $ T.pack f - -instance Eq Format where - Format x == Format y = T.toCaseFold x == T.toCaseFold y - -instance Ord Format where - compare (Format x) (Format y) = compare (T.toCaseFold x) (T.toCaseFold y) - --- | The number of columns taken up by the row head of each row of a --- 'TableBody'. The row body takes up the remaining columns. -newtype RowHeadColumns = RowHeadColumns Int - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) - --- | Alignment of a table column. -data Alignment = AlignLeft - | AlignRight - | AlignCenter - | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) - --- | The width of a table column, as a percentage of the text width. -data ColWidth = ColWidth Double - | ColWidthDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) - --- | The specification for a single table column. -type ColSpec = (Alignment, ColWidth) - -- | A table row. -data Row = Row Attr [Cell] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type Row = F.Row Block -- | The head of a table. -data TableHead = TableHead Attr [Row] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type TableHead = F.TableHead Block -- | A body of a table, with an intermediate head, intermediate body, -- and the specified number of row header columns in the intermediate -- body. -data TableBody = TableBody Attr RowHeadColumns [Row] [Row] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type TableBody = F.TableBody Block -- | The foot of a table. -data TableFoot = TableFoot Attr [Row] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type TableFoot = F.TableFoot Block -- | A short caption, for use in, for instance, lists of figures. -type ShortCaption = [Inline] +type ShortCaption = F.ShortCaption Inline -- | The caption of a table, with an optional short caption. -data Caption = Caption (Maybe ShortCaption) [Block] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type Caption = F.Caption Inline Block -- | A table cell. -data Cell = Cell Attr Alignment RowSpan ColSpan [Block] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) - --- | The number of rows occupied by a cell; the height of a cell. -newtype RowSpan = RowSpan Int - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) - --- | The number of columns occupied by a cell; the width of a cell. -newtype ColSpan = ColSpan Int - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) +type Cell = F.Cell Block -- | Block element. -data Block - -- | Plain text, not a paragraph - = Plain [Inline] - -- | Paragraph - | Para [Inline] - -- | Multiple non-breaking lines - | LineBlock [[Inline]] - -- | Code block (literal) with attributes - | CodeBlock Attr Text - -- | Raw block - | RawBlock Format Text - -- | Block quote (list of blocks) - | BlockQuote [Block] - -- | Ordered list (attributes and a list of items, each a list of - -- blocks) - | OrderedList ListAttributes [[Block]] - -- | Bullet list (list of items, each a list of blocks) - | BulletList [[Block]] - -- | Definition list. Each list item is a pair consisting of a - -- term (a list of inlines) and one or more definitions (each a - -- list of blocks) - | DefinitionList [([Inline],[[Block]])] - -- | Header - level (integer) and text (inlines) - | 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 - -- | Generic block container with attributes - | Div Attr [Block] - -- | Nothing - | Null +newtype Block = Block { unBlock :: F.Block Inline Block } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) --- | Type of quotation marks to use in Quoted inline. -data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) - --- | Link target (URL, title). -type Target = (Text, Text) +{-# COMPLETE Plain + , Para + , LineBlock + , CodeBlock + , RawBlock + , BlockQuote + , OrderedList + , BulletList + , DefinitionList + , Header + , HorizontalRule + , Table + , Div + , Null + :: Block #-} + +-- | Plain text, not a paragraph +pattern Plain :: [Inline] -> Block +pattern Plain is = Block (F.Plain is) + +-- | Paragraph +pattern Para :: [Inline] -> Block +pattern Para is = Block (F.Para is) + +-- | Multiple non-breaking lines +pattern LineBlock :: [[Inline]] -> Block +pattern LineBlock iss = Block (F.LineBlock iss) + +-- | Code block (literal) with attributes +pattern CodeBlock :: Attr -> Text -> Block +pattern CodeBlock a t = Block (F.CodeBlock a t) + +-- | Raw block +pattern RawBlock :: Format -> Text -> Block +pattern RawBlock f t = Block (F.RawBlock f t) + +-- | Block quote (list of blocks) +pattern BlockQuote :: [Block] -> Block +pattern BlockQuote bs = Block (F.BlockQuote bs) + +-- | Ordered list (attributes and a list of items, each a list of +-- blocks) +pattern OrderedList :: ListAttributes -> [[Block]] -> Block +pattern OrderedList as bs = Block (F.OrderedList as bs) + +-- | Bullet list (list of items, each a list of blocks) +pattern BulletList :: [[Block]] -> Block +pattern BulletList bss = Block (F.BulletList bss) + +-- | Definition list. Each list item is a pair consisting of a +-- term (a list of inlines) and one or more definitions (each a +-- list of blocks) +pattern DefinitionList :: [([Inline], [[Block]])] -> Block +pattern DefinitionList l = Block (F.DefinitionList l) + +-- | Header - level (integer) and text (inlines) +pattern Header :: Int -> Attr -> [Inline] -> Block +pattern Header i a is = Block (F.Header i a is) + +-- | Horizontal rule +pattern HorizontalRule :: Block +pattern HorizontalRule = Block F.HorizontalRule + +-- | Table, with attributes, caption, optional short caption, +-- column alignments and widths (required), table head, table +-- bodies, and table foot +pattern Table :: Attr -> Caption -> [ColSpec] -> TableHead -> [TableBody] -> TableFoot -> Block +pattern Table i c css th tbs tf = Block (F.Table i c css th tbs tf) + +-- | Generic block container with attributes +pattern Div :: Attr -> [Block] -> Block +pattern Div as bs = Block (F.Div as bs) + +-- | Nothing +pattern Null :: Block +pattern Null = Block F.Null isFigureTarget :: Target -> Maybe Target isFigureTarget tgt @@ -340,48 +382,114 @@ pattern SimpleFigure attr figureCaption tgt <- 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) +{-# COMPLETE Str + , Emph + , Underline + , Strong + , Strikeout + , Superscript + , Subscript + , SmallCaps + , Quoted + , Cite + , Code + , Space + , SoftBreak + , LineBreak + , Math + , RawInline + , Link + , Image + , Note + , Span + :: Inline #-} -- | Inline elements. -data Inline - = Str Text -- ^ Text (string) - | Emph [Inline] -- ^ Emphasized text (list of inlines) - | Underline [Inline] -- ^ Underlined text (list of inlines) - | Strong [Inline] -- ^ Strongly emphasized text (list of inlines) - | Strikeout [Inline] -- ^ Strikeout text (list of inlines) - | Superscript [Inline] -- ^ Superscripted text (list of inlines) - | Subscript [Inline] -- ^ Subscripted text (list of inlines) - | SmallCaps [Inline] -- ^ Small caps text (list of inlines) - | Quoted QuoteType [Inline] -- ^ Quoted text (list of inlines) - | Cite [Citation] [Inline] -- ^ Citation (list of inlines) - | Code Attr Text -- ^ Inline code (literal) - | Space -- ^ Inter-word space - | SoftBreak -- ^ Soft line break - | LineBreak -- ^ Hard line break - | Math MathType Text -- ^ TeX math (literal) - | RawInline Format Text -- ^ Raw inline - | Link Attr [Inline] Target -- ^ Hyperlink: alt text (list of inlines), target - | Image Attr [Inline] Target -- ^ Image: alt text (list of inlines), target - | Note [Block] -- ^ Footnote or endnote - | Span Attr [Inline] -- ^ Generic inline container with attributes +newtype Inline = Inline { unInline :: F.Inline Block Inline } deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) -data Citation = Citation { citationId :: Text - , citationPrefix :: [Inline] - , citationSuffix :: [Inline] - , citationMode :: CitationMode - , citationNoteNum :: Int - , citationHash :: Int - } - deriving (Show, Eq, Read, Typeable, Data, Generic) +-- | Text (string) +pattern Str :: Text -> Inline +pattern Str t = Inline (F.Str t) + +-- | Emphasized text (list of inlines) +pattern Emph :: [Inline] -> Inline +pattern Emph is = Inline (F.Emph is) + +-- | Underlined text (list of inlines) +pattern Underline :: [Inline] -> Inline +pattern Underline is = Inline (F.Underline is) + +-- | Strongly emphasized text (list of inlines) +pattern Strong :: [Inline] -> Inline +pattern Strong is = Inline (F.Strong is) + +-- | Strikeout text (list of inlines) +pattern Strikeout :: [Inline] -> Inline +pattern Strikeout is = Inline (F.Strikeout is) + +-- | Superscripted text (list of inlines) +pattern Superscript :: [Inline] -> Inline +pattern Superscript is = Inline (F.Superscript is) + +-- | Subscripted text (list of inlines) +pattern Subscript :: [Inline] -> Inline +pattern Subscript is = Inline (F.Subscript is) + +-- | Small caps text (list of inlines) +pattern SmallCaps :: [Inline] -> Inline +pattern SmallCaps is = Inline (F.SmallCaps is) + +-- | Quoted text (list of inlines) +pattern Quoted :: QuoteType -> [Inline] -> Inline +pattern Quoted qt is = Inline (F.Quoted qt is) + +-- | Citation (list of inlines) +pattern Cite :: [F.Citation Inline] -> [Inline] -> Inline +pattern Cite cs is = Inline (F.Cite cs is) + +-- | Inline code (literal) +pattern Code :: Attr -> Text -> Inline +pattern Code a is = Inline (F.Code a is) + +-- | Inter-word space +pattern Space :: Inline +pattern Space = Inline F.Space -instance Ord Citation where - compare = comparing citationHash +-- | Soft line break +pattern SoftBreak :: Inline +pattern SoftBreak = Inline F.SoftBreak -data CitationMode = AuthorInText | SuppressAuthor | NormalCitation - deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) +-- | Hard line break +pattern LineBreak :: Inline +pattern LineBreak = Inline F.LineBreak + +-- | TeX math (literal) +pattern Math :: MathType -> Text -> Inline +pattern Math mt t = Inline (F.Math mt t) + +-- | Raw inline +pattern RawInline :: Format -> Text -> Inline +pattern RawInline f t = Inline (F.RawInline f t) + +-- | Hyperlink: alt text (list of inlines), target +pattern Link :: Attr -> [Inline] -> Target -> Inline +pattern Link a is t = Inline (F.Link a is t) + +-- | Image: alt text (list of inlines), target +pattern Image :: Attr -> [Inline] -> Target -> Inline +pattern Image a is t = Inline (F.Image a is t) + +-- | Footnote or endnote +pattern Note :: [Block] -> Inline +pattern Note bs = Inline (F.Note bs) + +-- | Generic inline container with attributes +pattern Span :: Attr -> [Inline] -> Inline +pattern Span a is = Inline (F.Span a is) + + +type Citation = F.Citation Inline -- ToJSON/FromJSON instances. Some are defined by hand so that we have @@ -389,24 +497,11 @@ data CitationMode = AuthorInText | SuppressAuthor | NormalCitation $(let jsonOpts = defaultOptions { allNullaryToStringTag = False + , unwrapUnaryRecords = True , sumEncoding = TaggedObject { tagFieldName = "t", contentsFieldName = "c" } } in fmap concat $ traverse (deriveJSON jsonOpts) [ ''MetaValue - , ''CitationMode - , ''Citation - , ''QuoteType - , ''MathType - , ''ListNumberStyle - , ''ListNumberDelim - , ''Alignment - , ''ColWidth - , ''Row - , ''Caption - , ''TableHead - , ''TableBody - , ''TableFoot - , ''Cell , ''Inline , ''Block ]) @@ -448,29 +543,8 @@ instance ToJSON Pandoc where ] -- Instances for deepseq -instance NFData MetaValue instance NFData Meta -instance NFData Citation -instance NFData Alignment -instance NFData RowSpan -instance NFData ColSpan -instance NFData Cell -instance NFData Row -instance NFData TableHead -instance NFData TableBody -instance NFData TableFoot -instance NFData Caption +instance NFData MetaValue instance NFData Inline -instance NFData MathType -instance NFData Format -instance NFData CitationMode -instance NFData QuoteType -instance NFData ListNumberDelim -instance NFData ListNumberStyle -instance NFData ColWidth -instance NFData RowHeadColumns instance NFData Block instance NFData Pandoc - -pandocTypesVersion :: Version -pandocTypesVersion = version diff --git a/src/Text/Pandoc/Definition/Functors.hs b/src/Text/Pandoc/Definition/Functors.hs new file mode 100644 index 0000000..e849da9 --- /dev/null +++ b/src/Text/Pandoc/Definition/Functors.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric, + FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP, + TemplateHaskell , PatternSynonyms, ViewPatterns, StrictData, + DeriveTraversable + #-} + +{- +Copyright (c) 2006-2019, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +{- | + Module : Text.Pandoc.Definition + Copyright : Copyright (C) 2006-2019 John MacFarlane + License : BSD3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Definition of 'Pandoc' data structure for format-neutral representation +of documents. +-} +module Text.Pandoc.Definition.Functors + ( MetaValue(..) + , Block(..) + , Inline(..) + , ListAttributes + , ListNumberStyle(..) + , ListNumberDelim(..) + , Format(..) + , Attr + , nullAttr + , Caption(..) + , ShortCaption + , RowHeadColumns(..) + , Alignment(..) + , ColWidth(..) + , ColSpec + , Row(..) + , TableHead(..) + , TableBody(..) + , TableFoot(..) + , Cell(..) + , RowSpan(..) + , ColSpan(..) + , QuoteType(..) + , Target + , MathType(..) + , Citation(..) + , CitationMode(..) + , pandocTypesVersion + ) where + +import Data.Generics (Data, Typeable) +import Data.Ord (comparing) +import Data.Aeson hiding (Null) +import Data.Aeson.TH (deriveJSON) +import qualified Data.Map as M +import Data.Text (Text) +import GHC.Generics (Generic) +import Control.DeepSeq + +import Text.Pandoc.Definition.Misc + +data MetaValue inline block metaValue + = MetaMap (M.Map Text metaValue) + | MetaList [metaValue] + | MetaBool Bool + | MetaString Text + | MetaInlines [inline] + | MetaBlocks [block] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | A table row. +data Row block = Row Attr [Cell block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +-- | The head of a table. +data TableHead block = TableHead Attr [Row block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +-- | A body of a table, with an intermediate head, intermediate body, +-- and the specified number of row header columns in the intermediate +-- body. +data TableBody block = TableBody Attr RowHeadColumns [Row block] [Row block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +-- | The foot of a table. +data TableFoot block = TableFoot Attr [Row block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +-- | A short caption, for use in, for instance, lists of figures. +type ShortCaption inline = [inline] + +-- | The caption of a table, with an optional short caption. +data Caption inline block = Caption (Maybe (ShortCaption inline)) [block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +-- | A table cell. +data Cell block = Cell Attr Alignment RowSpan ColSpan [block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +-- | Block element +data Block inline block + -- | Plain text, not a paragraph + = Plain [inline] + -- | Paragraph + | Para [inline] + -- | Multiple non-breaking lines + | LineBlock [[inline]] + -- | Code block (literal) with attributes + | CodeBlock Attr Text + -- | Raw block + | RawBlock Format Text + -- | Block quote (list of blocks) + | BlockQuote [block] + -- | Ordered list (attributes and a list of items, each a list of + -- blocks) + | OrderedList ListAttributes [[block]] + -- | Bullet list (list of items, each a list of blocks) + | BulletList [[block]] + -- | Definition list. Each list item is a pair consisting of a + -- term (a list of inlines) and one or more definitions (each a + -- list of blocks) + | DefinitionList [([inline],[[block]])] + -- | Header - level (integer) and text (inlines) + | 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 inline block) [ColSpec] (TableHead block) [TableBody block] (TableFoot block) + -- | Generic block container with attributes + | Div Attr [block] + -- | Nothing + | Null + deriving ( Eq, Ord, Read, Show, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + + +-- | Inline elements. +data Inline block inline + = Str Text -- ^ Text (string) + | Emph [inline] -- ^ Emphasized text (list of inlines) + | Underline [inline] -- ^ Underlined text (list of inlines) + | Strong [inline] -- ^ Strongly emphasized text (list of inlines) + | Strikeout [inline] -- ^ Strikeout text (list of inlines) + | Superscript [inline] -- ^ Superscripted text (list of inlines) + | Subscript [inline] -- ^ Subscripted text (list of inlines) + | SmallCaps [inline] -- ^ Small caps text (list of inlines) + | Quoted QuoteType [inline] -- ^ Quoted text (list of inlines) + | Cite [Citation inline] [inline] -- ^ Citation (list of inlines) + | Code Attr Text -- ^ Inline code (literal) + | Space -- ^ Inter-word space + | SoftBreak -- ^ Soft line break + | LineBreak -- ^ Hard line break + | Math MathType Text -- ^ TeX math (literal) + | RawInline Format Text -- ^ Raw inline + | Link Attr [inline] Target -- ^ Hyperlink: alt text (list of inlines), target + | Image Attr [inline] Target -- ^ Image: alt text (list of inlines), target + | Note [block] -- ^ Footnote or endnote + | Span Attr [inline] -- ^ Generic inline container with attributes + deriving ( Show, Eq, Ord, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +data Citation inline = Citation + { citationId :: Text + , citationPrefix :: [inline] + , citationSuffix :: [inline] + , citationMode :: CitationMode + , citationNoteNum :: Int + , citationHash :: Int + } + deriving ( Show, Eq, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) + +instance Eq inline => Ord (Citation inline) where + compare = comparing citationHash + + +-- ToJSON/FromJSON instances. Some are defined by hand so that we have +-- more control over the format. + +$(let jsonOpts = defaultOptions + { allNullaryToStringTag = False + , sumEncoding = TaggedObject { tagFieldName = "t", contentsFieldName = "c" } + } + in fmap concat $ traverse (deriveJSON jsonOpts) + [ ''MetaValue + , ''Citation + , ''Row + , ''Caption + , ''TableHead + , ''TableBody + , ''TableFoot + , ''Cell + , ''Inline + , ''Block + ]) + +-- Instances for deepseq +instance (NFData block, NFData inline, NFData metaValue) => NFData (MetaValue inline block metaValue) +instance NFData inline => NFData (Citation inline) +instance NFData block => NFData (Cell block) +instance NFData block => NFData (Row block) +instance NFData block => NFData (TableHead block) +instance NFData block => NFData (TableBody block) +instance NFData block => NFData (TableFoot block) +instance (NFData block, NFData inline) => NFData (Caption block inline) +instance (NFData block, NFData inline) => NFData (Inline block inline) +instance (NFData inline, NFData block) => NFData (Block inline block) diff --git a/src/Text/Pandoc/Definition/Misc.hs b/src/Text/Pandoc/Definition/Misc.hs new file mode 100644 index 0000000..c7a0886 --- /dev/null +++ b/src/Text/Pandoc/Definition/Misc.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric, + FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP, + TemplateHaskell , PatternSynonyms, ViewPatterns, StrictData, + DeriveTraversable + #-} + +{- +Copyright (c) 2006-2019, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +{- | + Module : Text.Pandoc.Definition + Copyright : Copyright (C) 2006-2019 John MacFarlane + License : BSD3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Definition of 'Pandoc' data structure for format-neutral representation +of documents. +-} +module Text.Pandoc.Definition.Misc + ( ListAttributes + , ListNumberStyle(..) + , ListNumberDelim(..) + , Format(..) + , Attr + , nullAttr + , RowHeadColumns(..) + , Alignment(..) + , ColWidth(..) + , ColSpec + , RowSpan(..) + , ColSpan(..) + , QuoteType(..) + , Target + , MathType(..) + , CitationMode(..) + , pandocTypesVersion + ) where + +import Data.Generics (Data, Typeable) +import Data.Aeson hiding (Null) +import Data.Aeson.TH (deriveJSON) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Data.String +import Control.DeepSeq +import Paths_pandoc_types (version) +import Data.Version (Version) + +-- | List attributes. The first element of the triple is the +-- start number of the list. +type ListAttributes = (Int, ListNumberStyle, ListNumberDelim) + +-- | Style of list numbers. +data ListNumberStyle = DefaultStyle + | Example + | Decimal + | LowerRoman + | UpperRoman + | LowerAlpha + | UpperAlpha deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | Delimiter of list numbers. +data ListNumberDelim = DefaultDelim + | Period + | OneParen + | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | Attributes: identifier, classes, key-value pairs +type Attr = (Text, [Text], [(Text, Text)]) + +nullAttr :: Attr +nullAttr = ("",[],[]) + +-- | Formats for raw blocks +newtype Format = Format Text + deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON) + +instance IsString Format where + fromString f = Format $ T.toCaseFold $ T.pack f + +instance Eq Format where + Format x == Format y = T.toCaseFold x == T.toCaseFold y + +instance Ord Format where + compare (Format x) (Format y) = compare (T.toCaseFold x) (T.toCaseFold y) + +-- | The number of columns taken up by the row head of each row of a +-- 'TableBody'. The row body takes up the remaining columns. +newtype RowHeadColumns = RowHeadColumns Int + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) + +-- | Alignment of a table column. +data Alignment = AlignLeft + | AlignRight + | AlignCenter + | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | The width of a table column, as a percentage of the text width. +data ColWidth = ColWidth Double + | ColWidthDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | The specification for a single table column. +type ColSpec = (Alignment, ColWidth) + +-- | The number of rows occupied by a cell; the height of a cell. +newtype RowSpan = RowSpan Int + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) + +-- | The number of columns occupied by a cell; the width of a cell. +newtype ColSpan = ColSpan Int + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) + +-- | Type of quotation marks to use in Quoted inline. +data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +-- | Link target (URL, title). +type Target = (Text, Text) + + +-- | Type of math element (display or inline). +data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +data CitationMode = AuthorInText | SuppressAuthor | NormalCitation + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + + +-- ToJSON/FromJSON instances. Some are defined by hand so that we have +-- more control over the format. + +$(let jsonOpts = defaultOptions + { allNullaryToStringTag = False + , sumEncoding = TaggedObject { tagFieldName = "t", contentsFieldName = "c" } + } + in fmap concat $ traverse (deriveJSON jsonOpts) + [ ''CitationMode + , ''QuoteType + , ''MathType + , ''ListNumberStyle + , ''ListNumberDelim + , ''Alignment + , ''ColWidth + ]) + +-- Instances for deepseq +instance NFData Alignment +instance NFData RowSpan +instance NFData ColSpan +instance NFData MathType +instance NFData Format +instance NFData CitationMode +instance NFData QuoteType +instance NFData ListNumberDelim +instance NFData ListNumberStyle +instance NFData ColWidth +instance NFData RowHeadColumns + +pandocTypesVersion :: Version +pandocTypesVersion = version diff --git a/src/Text/Pandoc/Walk.hs b/src/Text/Pandoc/Walk.hs index 3dba0dd..45b6c2c 100644 --- a/src/Text/Pandoc/Walk.hs +++ b/src/Text/Pandoc/Walk.hs @@ -119,6 +119,7 @@ import Control.Monad ((>=>)) import Data.Functor.Identity (Identity (runIdentity)) import qualified Data.Map as M import Text.Pandoc.Definition +import qualified Text.Pandoc.Definition.Functors as F import qualified Data.Traversable as T import Data.Traversable (Traversable) import qualified Data.Foldable as F @@ -137,7 +138,8 @@ class Walkable a b where query :: Monoid c => (a -> c) -> b -> c {-# MINIMAL walkM, query #-} -instance (Foldable t, Traversable t, Walkable a b) => Walkable a (t b) where +instance {-# OVERLAPPABLE #-} + (Foldable t, Traversable t, Walkable a b) => Walkable a (t b) where walk f = T.fmapDefault (walk f) walkM f = T.mapM (walkM f) query f = F.foldMap (query f) @@ -151,6 +153,10 @@ instance OVERLAPS return (x',y') query f (x,y) = mappend (query f x) (query f y) +-- instance {-# OVERLAPPABLE #-} Walkable a a where +-- walkM f x = f x +-- query f x = f x + instance Walkable Inline Inline where walkM f x = walkInlineM f x >>= f query f x = f x <> queryInline f x @@ -416,52 +422,62 @@ instance Walkable [Block] Citation where walkInlineM :: (Walkable a Citation, Walkable a [Block], Walkable a [Inline], Monad m, Applicative m, Functor m) => (a -> m a) -> Inline -> m Inline -walkInlineM _ (Str xs) = return (Str xs) -walkInlineM f (Emph xs) = Emph <$> walkM f xs -walkInlineM f (Underline xs) = Underline <$> walkM f xs -walkInlineM f (Strong xs) = Strong <$> walkM f xs -walkInlineM f (Strikeout xs) = Strikeout <$> walkM f xs -walkInlineM f (Subscript xs) = Subscript <$> walkM f xs -walkInlineM f (Superscript xs) = Superscript <$> walkM f xs -walkInlineM f (SmallCaps xs) = SmallCaps <$> walkM f xs -walkInlineM f (Quoted qt xs) = Quoted qt <$> walkM f xs -walkInlineM f (Link atr xs t) = Link atr <$> walkM f xs <*> pure t -walkInlineM f (Image atr xs t) = Image atr <$> walkM f xs <*> pure t -walkInlineM f (Note bs) = Note <$> walkM f bs -walkInlineM f (Span attr xs) = Span attr <$> walkM f xs -walkInlineM f (Cite cs xs) = Cite <$> walkM f cs <*> walkM f xs -walkInlineM _ LineBreak = return LineBreak -walkInlineM _ SoftBreak = return SoftBreak -walkInlineM _ Space = return Space -walkInlineM _ x@Code {} = return x -walkInlineM _ x@Math {} = return x -walkInlineM _ x@RawInline {} = return x +walkInlineM f (Inline i) = Inline <$> walkInlineFM f i + +walkInlineFM :: (Walkable a (F.Citation inline), Walkable a [block], + Walkable a [inline], Monad m, Applicative m, Functor m) + => (a -> m a) -> F.Inline block inline -> m (F.Inline block inline) +walkInlineFM _ (F.Str xs) = return (F.Str xs) +walkInlineFM f (F.Emph xs) = F.Emph <$> walkM f xs +walkInlineFM f (F.Underline xs) = F.Underline <$> walkM f xs +walkInlineFM f (F.Strong xs) = F.Strong <$> walkM f xs +walkInlineFM f (F.Strikeout xs) = F.Strikeout <$> walkM f xs +walkInlineFM f (F.Subscript xs) = F.Subscript <$> walkM f xs +walkInlineFM f (F.Superscript xs) = F.Superscript <$> walkM f xs +walkInlineFM f (F.SmallCaps xs) = F.SmallCaps <$> walkM f xs +walkInlineFM f (F.Quoted qt xs) = F.Quoted qt <$> walkM f xs +walkInlineFM f (F.Link atr xs t) = F.Link atr <$> walkM f xs <*> pure t +walkInlineFM f (F.Image atr xs t) = F.Image atr <$> walkM f xs <*> pure t +walkInlineFM f (F.Note bs) = F.Note <$> walkM f bs +walkInlineFM f (F.Span attr xs) = F.Span attr <$> walkM f xs +walkInlineFM f (F.Cite cs xs) = F.Cite <$> walkM f cs <*> walkM f xs +walkInlineFM _ F.LineBreak = return F.LineBreak +walkInlineFM _ F.SoftBreak = return F.SoftBreak +walkInlineFM _ F.Space = return F.Space +walkInlineFM _ x@F.Code {} = return x +walkInlineFM _ x@F.Math {} = return x +walkInlineFM _ x@F.RawInline {} = return x -- | Perform a query on elements nested below an @'Inline'@ element by -- querying nested lists of @Inline@s, @Block@s, or @Citation@s. queryInline :: (Walkable a Citation, Walkable a [Block], Walkable a [Inline], Monoid c) => (a -> c) -> Inline -> c -queryInline _ (Str _) = mempty -queryInline f (Emph xs) = query f xs -queryInline f (Underline xs) = query f xs -queryInline f (Strong xs) = query f xs -queryInline f (Strikeout xs) = query f xs -queryInline f (Subscript xs) = query f xs -queryInline f (Superscript xs)= query f xs -queryInline f (SmallCaps xs) = query f xs -queryInline f (Quoted _ xs) = query f xs -queryInline f (Cite cs xs) = query f cs <> query f xs -queryInline _ (Code _ _) = mempty -queryInline _ Space = mempty -queryInline _ SoftBreak = mempty -queryInline _ LineBreak = mempty -queryInline _ (Math _ _) = mempty -queryInline _ (RawInline _ _) = mempty -queryInline f (Link _ xs _) = query f xs -queryInline f (Image _ xs _) = query f xs -queryInline f (Note bs) = query f bs -queryInline f (Span _ xs) = query f xs +queryInline f (Inline i) = queryInlineF f i + +queryInlineF :: (Walkable a (F.Citation inline), Walkable a [block], + Walkable a [inline], Monoid c) + => (a -> c) -> F.Inline block inline -> c +queryInlineF _ (F.Str _) = mempty +queryInlineF f (F.Emph xs) = query f xs +queryInlineF f (F.Underline xs) = query f xs +queryInlineF f (F.Strong xs) = query f xs +queryInlineF f (F.Strikeout xs) = query f xs +queryInlineF f (F.Subscript xs) = query f xs +queryInlineF f (F.Superscript xs)= query f xs +queryInlineF f (F.SmallCaps xs) = query f xs +queryInlineF f (F.Quoted _ xs) = query f xs +queryInlineF f (F.Cite cs xs) = query f cs <> query f xs +queryInlineF _ (F.Code _ _) = mempty +queryInlineF _ F.Space = mempty +queryInlineF _ F.SoftBreak = mempty +queryInlineF _ F.LineBreak = mempty +queryInlineF _ (F.Math _ _) = mempty +queryInlineF _ (F.RawInline _ _) = mempty +queryInlineF f (F.Link _ xs _) = query f xs +queryInlineF f (F.Image _ xs _) = query f xs +queryInlineF f (F.Note bs) = query f bs +queryInlineF f (F.Span _ xs) = query f xs -- | Helper method to walk to elements nested below @'Block'@ nodes. @@ -473,25 +489,32 @@ walkBlockM :: (Walkable a [Block], Walkable a [Inline], Walkable a Row, Walkable a Caption, Walkable a TableHead, Walkable a TableBody, Walkable a TableFoot, Monad m, Applicative m, Functor m) => (a -> m a) -> Block -> m Block -walkBlockM f (Para xs) = Para <$> walkM f xs -walkBlockM f (Plain xs) = Plain <$> walkM f xs -walkBlockM f (LineBlock xs) = LineBlock <$> walkM f xs -walkBlockM f (BlockQuote xs) = BlockQuote <$> walkM f xs -walkBlockM f (OrderedList a cs) = OrderedList a <$> walkM f cs -walkBlockM f (BulletList cs) = BulletList <$> walkM f cs -walkBlockM f (DefinitionList xs) = DefinitionList <$> walkM f xs -walkBlockM f (Header lev attr xs) = Header lev attr <$> walkM f xs -walkBlockM f (Div attr bs') = Div attr <$> walkM f bs' -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) +walkBlockM f (Block b) = Block <$> walkBlockFM f b + +walkBlockFM :: (Monad m, Walkable a (F.Caption inline block), + Walkable a [inline], Walkable a [block], + Walkable a (F.TableHead block), Walkable a (F.TableBody block), + Walkable a (F.TableFoot block)) + => (a -> m a) -> F.Block inline block -> m (F.Block inline block) +walkBlockFM f (F.Para xs) = F.Para <$> walkM f xs +walkBlockFM f (F.Plain xs) = F.Plain <$> walkM f xs +walkBlockFM f (F.LineBlock xs) = F.LineBlock <$> walkM f xs +walkBlockFM f (F.BlockQuote xs) = F.BlockQuote <$> walkM f xs +walkBlockFM f (F.OrderedList a cs) = F.OrderedList a <$> walkM f cs +walkBlockFM f (F.BulletList cs) = F.BulletList <$> walkM f cs +walkBlockFM f (F.DefinitionList xs) = F.DefinitionList <$> walkM f xs +walkBlockFM f (F.Header lev attr xs) = F.Header lev attr <$> walkM f xs +walkBlockFM f (F.Div attr bs') = F.Div attr <$> walkM f bs' +walkBlockFM _ x@F.CodeBlock {} = return x +walkBlockFM _ x@F.RawBlock {} = return x +walkBlockFM _ F.HorizontalRule = return F.HorizontalRule +walkBlockFM _ F.Null = return F.Null +walkBlockFM f (F.Table attr capt as hs bs fs) = do capt' <- walkM f capt hs' <- walkM f hs bs' <- walkM f bs fs' <- walkM f fs - return $ Table attr capt' as hs' bs' fs' + return $ F.Table attr capt' as hs' bs' fs' -- | Perform a query on elements nested below a @'Block'@ element by -- querying all directly nested lists of @Inline@s or @Block@s. @@ -499,24 +522,31 @@ queryBlock :: (Walkable a Citation, Walkable a [Block], Walkable a Row, Walkable a Caption, Walkable a TableHead, Walkable a TableBody, Walkable a TableFoot, Walkable a [Inline], Monoid c) => (a -> c) -> Block -> c -queryBlock f (Para xs) = query f xs -queryBlock f (Plain xs) = query f xs -queryBlock f (LineBlock xs) = query f xs -queryBlock _ (CodeBlock _ _) = mempty -queryBlock _ (RawBlock _ _) = mempty -queryBlock f (BlockQuote bs) = query f bs -queryBlock f (OrderedList _ cs) = query f cs -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) +queryBlock f (Block b) = queryBlockF f b + +queryBlockF :: (Monoid c, Walkable a (F.Caption inline block), + Walkable a [inline], Walkable a [block], + Walkable a (F.TableHead block), Walkable a (F.TableBody block), + Walkable a (F.TableFoot block)) + => (a -> c) -> F.Block inline block -> c +queryBlockF f (F.Para xs) = query f xs +queryBlockF f (F.Plain xs) = query f xs +queryBlockF f (F.LineBlock xs) = query f xs +queryBlockF _ (F.CodeBlock _ _) = mempty +queryBlockF _ (F.RawBlock _ _) = mempty +queryBlockF f (F.BlockQuote bs) = query f bs +queryBlockF f (F.OrderedList _ cs) = query f cs +queryBlockF f (F.BulletList cs) = query f cs +queryBlockF f (F.DefinitionList xs) = query f xs +queryBlockF f (F.Header _ _ xs) = query f xs +queryBlockF _ F.HorizontalRule = mempty +queryBlockF f (F.Table _ capt _ hs bs fs) = query f capt <> query f hs <> query f bs <> query f fs -queryBlock f (Div _ bs) = query f bs -queryBlock _ Null = mempty +queryBlockF f (F.Div _ bs) = query f bs +queryBlockF _ F.Null = mempty -- | Helper method to walk to elements nested below @'MetaValue'@ nodes. -- @@ -526,20 +556,33 @@ queryBlock _ Null = mempty walkMetaValueM :: (Walkable a MetaValue, Walkable a [Block], Walkable a [Inline], Monad f, Applicative f, Functor f) => (a -> f a) -> MetaValue -> f MetaValue -walkMetaValueM f (MetaList xs) = MetaList <$> walkM f xs -walkMetaValueM _ (MetaBool b) = return $ MetaBool b -walkMetaValueM _ (MetaString s) = return $ MetaString s -walkMetaValueM f (MetaInlines xs) = MetaInlines <$> walkM f xs -walkMetaValueM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs -walkMetaValueM f (MetaMap m) = MetaMap <$> walkM f m +walkMetaValueM f (MetaValue b) = MetaValue <$> walkMetaValueFM f b + +walkMetaValueFM :: (Monad f, Walkable a metaValue, + Walkable a [metaValue], Walkable a [inline], Walkable a [block]) + => (a -> f a) + -> F.MetaValue inline block metaValue + -> f (F.MetaValue inline block metaValue) +walkMetaValueFM f (F.MetaList xs) = F.MetaList <$> walkM f xs +walkMetaValueFM _ (F.MetaBool b) = return $ F.MetaBool b +walkMetaValueFM _ (F.MetaString s) = return $ F.MetaString s +walkMetaValueFM f (F.MetaInlines xs) = F.MetaInlines <$> walkM f xs +walkMetaValueFM f (F.MetaBlocks bs) = F.MetaBlocks <$> walkM f bs +walkMetaValueFM f (F.MetaMap m) = F.MetaMap <$> walkM f m -- | Helper method to walk @'MetaValue'@ nodes nested below @'MetaValue'@ nodes. walkMetaValueM' :: (Monad f, Applicative f, Functor f) => (MetaValue -> f MetaValue) -> MetaValue -> f MetaValue -walkMetaValueM' f (MetaMap m) = - MetaMap . M.fromAscList <$> mapM (\(k, v) -> (,) k <$> walkM f v) (M.toAscList m) -walkMetaValueM' f (MetaList xs) = MetaList <$> mapM (walkM f) xs -walkMetaValueM' _ x = return x +walkMetaValueM' f (MetaValue b) = MetaValue <$> walkMetaValueFM' f b + +walkMetaValueFM' :: (Monad f, Walkable a metaValue) + => (a -> f a) + -> F.MetaValue inline block metaValue + -> f (F.MetaValue inline block metaValue) +walkMetaValueFM' f (F.MetaMap m) = + F.MetaMap . M.fromAscList <$> mapM (\(k, v) -> (,) k <$> walkM f v) (M.toAscList m) +walkMetaValueFM' f (F.MetaList xs) = F.MetaList <$> mapM (walkM f) xs +walkMetaValueFM' _ x = return x -- | Perform a query on elements nested below a @'MetaValue'@ element by -- querying all directly nested lists of @Inline@s, list of @Block@s, or @@ -547,28 +590,37 @@ walkMetaValueM' _ x = return x queryMetaValue :: (Walkable a MetaValue, Walkable a [Block], Walkable a [Inline], Monoid c) => (a -> c) -> MetaValue -> c -queryMetaValue f (MetaList xs) = query f xs -queryMetaValue _ (MetaBool _) = mempty -queryMetaValue _ (MetaString _) = mempty -queryMetaValue f (MetaInlines xs) = query f xs -queryMetaValue f (MetaBlocks bs) = query f bs -queryMetaValue f (MetaMap m) = query f m +queryMetaValue f (MetaValue b) = queryMetaValueF f b + +queryMetaValueF :: (Monoid c, Walkable a metaValue, + Walkable a [metaValue], Walkable a [inline], Walkable a [block]) + => (a -> c) -> F.MetaValue inline block metaValue -> c +queryMetaValueF f (F.MetaList xs) = query f xs +queryMetaValueF _ (F.MetaBool _) = mempty +queryMetaValueF _ (F.MetaString _) = mempty +queryMetaValueF f (F.MetaInlines xs) = query f xs +queryMetaValueF f (F.MetaBlocks bs) = query f bs +queryMetaValueF f (F.MetaMap m) = query f m -- | Perform a query on @'MetaValue'@ elements nested below a @'MetaValue'@ -- element queryMetaValue' :: Monoid c => (MetaValue -> c) -> MetaValue -> c -queryMetaValue' f (MetaMap m) = M.foldMapWithKey (const $ query f) m -queryMetaValue' f (MetaList xs) = mconcat $ map (query f) xs -queryMetaValue' _ _ = mempty +queryMetaValue' f (MetaValue b) = queryMetaValue'F f b + +queryMetaValue'F :: (Monoid c, Walkable a b) + => (a -> c) -> F.MetaValue inline block b -> c +queryMetaValue'F f (F.MetaMap m) = M.foldMapWithKey (const $ query f) m +queryMetaValue'F f (F.MetaList xs) = mconcat $ map (query f) xs +queryMetaValue'F _ _ = mempty -- | Helper method to walk to elements nested below @'Citation'@ nodes. -- -- The non-inline contents of a citation will remain unchanged during traversal. -- Only the inline contents, viz. the citation's prefix and postfix, will be -- traversed further and can thus be changed during this operation. -walkCitationM :: (Walkable a [Inline], Monad m, Applicative m, Functor m) - => (a -> m a) -> Citation -> m Citation +walkCitationM :: (Walkable a [inline], Monad m, Applicative m, Functor m) + => (a -> m a) -> F.Citation inline -> m (F.Citation inline) walkCitationM f (Citation id' pref suff mode notenum hash) = do pref' <- walkM f pref suff' <- walkM f suff @@ -576,8 +628,8 @@ walkCitationM f (Citation id' pref suff mode notenum hash) = -- | Perform a query on elements nested below a @'Citation'@ element by -- querying the prefix and postfix @Inline@ lists. -queryCitation :: (Walkable a [Inline], Monoid c) - => (a -> c) -> Citation -> c +queryCitation :: (Walkable a [inline], Monoid c) + => (a -> c) -> F.Citation inline -> c queryCitation f (Citation _ pref suff _ _ _) = query f pref <> query f suff -- | Helper method to walk the elements nested below @'Row'@ nodes. The