From fdf6a1d13d9c481604d461307dac6bda6aa5ee76 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 19 May 2022 15:41:25 -0400 Subject: [PATCH] Recreate the AST with functors Fixes #98 See the issue for details of why this is useful --- src/Text/Pandoc/Arbitrary.hs | 344 ++++++++++++++++++++-------------- src/Text/Pandoc/Builder.hs | 112 +++++------ src/Text/Pandoc/Definition.hs | 209 +++++++++++++-------- src/Text/Pandoc/Walk.hs | 175 +++++++++-------- 4 files changed, 492 insertions(+), 348 deletions(-) diff --git a/src/Text/Pandoc/Arbitrary.hs b/src/Text/Pandoc/Arbitrary.hs index 142baea..3daafc2 100644 --- a/src/Text/Pandoc/Arbitrary.hs +++ b/src/Text/Pandoc/Arbitrary.hs @@ -1,9 +1,10 @@ {-# 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) @@ -38,10 +39,10 @@ instance Arbitrary Inlines where arbitrary = (fromList :: [Inline] -> Inlines) <$> arbitrary shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkInlines) . toList where flattenShrinkInlines (x:xs) = - let x' = flattenInline x + let x' = flattenInline $ unInline x in (if null x' then [] else [x' ++ xs]) ++ [x:xs' | xs' <- flattenShrinkInlines xs] flattenShrinkInlines [] = [] - flattenInline :: Inline -> [Inline] + flattenInline :: InlineF Block Inline -> [Inline] flattenInline (Str _) = [] flattenInline (Emph ils) = ils flattenInline (Underline ils) = ils @@ -67,20 +68,20 @@ instance Arbitrary Blocks where arbitrary = (fromList :: [Block] -> Blocks) <$> arbitrary shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkBlocks) . toList where flattenShrinkBlocks (x:xs) = - let x' = flattenBlock x + let x' = flattenBlock $ unBlock x in (if null x' then [] else [x' ++ xs]) ++ [x:xs' | xs' <- flattenShrinkBlocks xs] flattenShrinkBlocks [] = [] - flattenBlock :: Block -> [Block] + flattenBlock :: BlockF Inline Block -> [Block] flattenBlock Plain{} = [] flattenBlock Para{} = [] - flattenBlock (LineBlock lns) = [Para x | x <- lns] + flattenBlock (LineBlock lns) = [Block $ Para x | x <- lns] flattenBlock CodeBlock{} = [] flattenBlock RawBlock{} = [] flattenBlock (BlockQuote blks) = blks flattenBlock (OrderedList _ blksList) = concat blksList flattenBlock (BulletList blksList) = concat blksList - flattenBlock (DefinitionList defs) = concat [Para ils:concat blks | (ils, blks) <- defs] - flattenBlock (Header _ _ ils) = [Para ils] + flattenBlock (DefinitionList defs) = concat [Block (Para ils) : concat blks | (ils, blks) <- defs] + flattenBlock (Header _ _ ils) = [Block $ Para ils] flattenBlock HorizontalRule = [] flattenBlock (Table _ capt _ hd bd ft) = flattenCaption capt <> flattenTableHead hd <> @@ -90,7 +91,7 @@ instance Arbitrary Blocks where flattenBlock Null = [] flattenCaption (Caption Nothing body) = body - flattenCaption (Caption (Just ils) body) = Para ils : body + flattenCaption (Caption (Just ils) body) = Block (Para ils) : body flattenTableHead (TableHead _ body) = flattenRows body flattenTableBody (TableBody _ _ hd bd) = flattenRows hd <> flattenRows bd @@ -100,59 +101,64 @@ 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)) + => InlineF b i -> [InlineF b i] +shrinkInline (Str s) = Str <$> shrinkText s +shrinkInline (Emph ils) = Emph <$> shrinkList ils +shrinkInline (Underline ils) = Underline <$> shrinkList ils +shrinkInline (Strong ils) = Strong <$> shrinkList ils +shrinkInline (Strikeout ils) = Strikeout <$> shrinkList ils +shrinkInline (Superscript ils) = Superscript <$> shrinkList ils +shrinkInline (Subscript ils) = Subscript <$> shrinkList ils +shrinkInline (SmallCaps ils) = SmallCaps <$> shrinkList ils +shrinkInline (Quoted qtype ils) = Quoted qtype <$> shrinkList ils +shrinkInline (Cite cits ils) = (Cite cits <$> shrinkList ils) + ++ (flip Cite ils <$> QC.shrinkList shrinkCitation cits) +shrinkInline (Code attr s) = (Code attr <$> shrinkText s) + ++ (flip Code s <$> shrinkAttr attr) +shrinkInline Space = [] +shrinkInline SoftBreak = [] +shrinkInline LineBreak = [] +shrinkInline (Math mtype s) = Math mtype <$> shrinkText s +shrinkInline (RawInline fmt s) = RawInline fmt <$> shrinkText s +shrinkInline (Link attr ils target) = [Link attr ils' target | ils' <- shrinkList ils] + ++ [Link attr ils target' | target' <- shrinkText2 target] + ++ [Link attr' ils target | attr' <- shrinkAttr attr] +shrinkInline (Image attr ils target) = [Image attr ils' target | ils' <- shrinkList ils] + ++ [Image attr ils target' | target' <- shrinkText2 target] + ++ [Image attr' ils target | attr' <- shrinkAttr attr] +shrinkInline (Note blks) = Note <$> shrinkList blks +shrinkInline (Span attr s) = (Span attr <$> shrink s) + ++ (flip Span s <$> shrinkAttr attr) arbInlines :: Int -> Gen [Inline] -arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace) +arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace . fmap unInline) where startsWithSpace (Space:_) = True startsWithSpace (SoftBreak:_) = True -- 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) +arbInline' :: Arbitrary inline + => (Int -> Gen block) -> (Int -> Gen [inline]) + -> Int -> Gen (InlineF block inline) +arbInline' arbB arbIs n = frequency $ + [ (60, Str <$> realString) , (40, pure Space) , (10, pure SoftBreak) , (10, pure LineBreak) @@ -160,62 +166,73 @@ arbInline n = frequency $ [ (60, Str <$> realString) , (5, elements [ RawInline (Format "html") "" , 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)) + where nesters = [ (10, Emph <$> arbIs (n-1)) + , (10, Underline <$> arbIs (n-1)) + , (10, Strong <$> arbIs (n-1)) + , (10, Strikeout <$> arbIs (n-1)) + , (10, Superscript <$> arbIs (n-1)) + , (10, Subscript <$> arbIs (n-1)) + , (10, SmallCaps <$> arbIs (n-1)) + , (10, Span <$> arbAttr <*> arbIs (n-1)) + , (10, Quoted <$> arbitrary <*> arbIs (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))) + , (10, Link <$> arbAttr <*> arbIs (n-1) <*> ((,) <$> realString <*> realString)) + , (10, Image <$> arbAttr <*> arbIs (n-1) <*> ((,) <$> realString <*> realString)) + , (2, Cite <$> listOf (arbitraryCitation $ arbIs 1) <*> arbIs 1) + , (2, 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)) + => BlockF i b -> [BlockF i b] +shrinkBlock (Plain ils) = Plain <$> shrinkList ils +shrinkBlock (Para ils) = Para <$> shrinkList ils +shrinkBlock (LineBlock lns) = LineBlock <$> shrinkLists lns +shrinkBlock (CodeBlock attr s) = (CodeBlock attr <$> shrinkText s) + ++ (flip CodeBlock s <$> shrinkAttr attr) +shrinkBlock (RawBlock fmt s) = RawBlock fmt <$> shrinkText s +shrinkBlock (BlockQuote blks) = BlockQuote <$> shrinkList blks +shrinkBlock (OrderedList listAttrs blksList) = OrderedList listAttrs <$> shrinkLists blksList +shrinkBlock (BulletList blksList) = BulletList <$> shrinkLists blksList +shrinkBlock (DefinitionList defs) = 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 (Header n attr ils) = (Header n attr <$> shrinkList ils) + ++ (flip (Header n) ils <$> shrinkAttr attr) +shrinkBlock HorizontalRule = [] +shrinkBlock (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' <- shrinkTableHead thead] ++ + [Table attr capt specs thead tbody' tfoot | tbody' <- QC.shrinkList shrinkTableBody tbody] ++ + [Table attr capt specs thead tbody tfoot' | tfoot' <- shrinkTableFoot tfoot] ++ + [Table attr capt' specs thead tbody tfoot | capt' <- shrinkCaption capt] +shrinkBlock (Div attr blks) = (Div attr <$> shrinkList blks) + ++ (flip Div blks <$> shrinkAttr attr) +shrinkBlock Null = [] arbBlock :: Int -> Gen Block -arbBlock n = frequency $ [ (10, Plain <$> arbInlines (n-1)) - , (15, Para <$> arbInlines (n-1)) +arbBlock = fmap Block . arbBlock' arbInline arbInlines arbBlock + +arbBlock' :: (Int -> Gen inline) -> (Int -> Gen [inline]) + -> (Int -> Gen block) + -> Int -> Gen (BlockF inline block) +arbBlock' arbI arbIs arbB n = frequency $ + [ (10, Plain <$> arbIs (n-1)) + , (15, Para <$> arbIs (n-1)) , (5, CodeBlock <$> arbAttr <*> realString) , (3, LineBlock <$> ((:) <$> - arbInlines ((n - 1) `mod` 3) <*> - forM [1..((n - 1) `div` 3)] (const (arbInlines 3)))) + arbIs ((n - 1) `mod` 3) <*> + forM [1..((n - 1) `div` 3)] (const (arbIs 3)))) , (2, elements [ RawBlock (Format "html") "
\n*&*\n
" , RawBlock (Format "latex") @@ -223,62 +240,78 @@ arbBlock n = frequency $ [ (10, Plain <$> arbInlines (n-1)) ]) , (5, Header <$> choose (1 :: Int, 6) <*> pure nullAttr - <*> arbInlines (n-1)) + <*> arbIs (n-1)) , (2, pure HorizontalRule) ] ++ [x | n > 0, x <- nesters] - where nesters = [ (5, BlockQuote <$> listOf1 (arbBlock (n-1))) + where nesters = [ (5, BlockQuote <$> listOf1 (arbB (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))) + <*> listOf1 (listOf1 $ arbB (n-1))) + , (5, BulletList <$> listOf1 (listOf1 $ arbB (n-1))) + , (5, DefinitionList <$> listOf1 ((,) <$> arbIs (n-1) + <*> listOf1 (listOf1 $ arbB (n-1)))) + , (5, Div <$> arbAttr <*> listOf1 (arbB (n-1))) , (2, do cs <- choose (1 :: Int, 6) bs <- choose (0 :: Int, 2) Table <$> arbAttr - <*> arbitrary + <*> arbitraryCaption' (sized arbI) (sized arbB) <*> vectorOf cs ((,) <$> arbitrary <*> elements [ ColWidthDefault , ColWidth (1/3) , ColWidth 0.25 ]) - <*> arbTableHead (n-1) - <*> vectorOf bs (arbTableBody (n-1)) - <*> arbTableFoot (n-1)) + <*> arbTableHead' arbB (n-1) + <*> vectorOf bs (arbTableBody' arbB (n-1)) + <*> arbTableFoot' arbB (n-1)) ] -arbRow :: Int -> Gen Row -arbRow n = do +arbRow :: Int -> Gen (RowF Block) +arbRow = arbRow' arbBlock + +arbTableHead :: Int -> Gen (TableHeadF Block) +arbTableHead = arbTableHead' arbBlock + +arbTableBody :: Int -> Gen (TableBodyF Block) +arbTableBody = arbTableBody' arbBlock + +arbTableFoot :: Int -> Gen (TableFootF Block) +arbTableFoot = arbTableFoot' arbBlock + +arbCell :: Int -> Gen (CellF Block) +arbCell = arbCell' arbBlock + +arbRow' :: (Int -> Gen block) -> Int -> Gen (RowF 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 (TableHeadF 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 (TableBodyF 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 (TableFootF 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 (CellF 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 +326,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 (CitationF inline) +arbitraryCitation arbIs = Citation <$> fmap T.pack (listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_']) - <*> arbInlines 1 - <*> arbInlines 1 + <*> arbIs + <*> arbIs <*> arbitrary <*> arbitrary <*> arbitrary +shrinkCitation :: CitationF inline -> [CitationF inline] +shrinkCitation _ = [] + instance Arbitrary Row where arbitrary = resize 3 $ arbRow 2 - shrink (Row attr body) + shrink = shrinkRow + +shrinkRow :: Arbitrary (Many block) => RowF block -> [RowF 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) => TableHeadF b -> [TableHeadF 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) => TableBodyF b -> [TableBodyF 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) => TableFootF b -> [TableFootF 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) => CellF b -> [CellF 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 (CaptionF inline block) +arbitraryCaption' arbI arbB = Caption <$> liftArbitrary (liftArbitrary arbI) <*> liftArbitrary arbB + +shrinkCaption :: (Arbitrary inline, Arbitrary (Many block)) + => CaptionF inline block -> [CaptionF 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/Builder.hs b/src/Text/Pandoc/Builder.hs index ce61ef8..0f5f45a 100644 --- a/src/Text/Pandoc/Builder.hs +++ b/src/Text/Pandoc/Builder.hs @@ -226,24 +226,24 @@ instance Semigroup Inlines where case (viewr xs, viewl ys) of (EmptyR, _) -> Many ys (_, EmptyL) -> Many xs - (xs' :> x, y :< ys') -> Many (meld <> ys') + (xs' :> Inline x, Inline y :< ys') -> Many (meld <> ys') where meld = case (x, y) of - (Space, Space) -> xs' |> Space - (Space, SoftBreak) -> xs' |> SoftBreak - (SoftBreak, Space) -> xs' |> SoftBreak - (Str t1, Str t2) -> xs' |> Str (t1 <> t2) - (Emph i1, Emph i2) -> xs' |> Emph (i1 <> i2) - (Underline i1, Underline i2) -> xs' |> Underline (i1 <> i2) - (Strong i1, Strong i2) -> xs' |> Strong (i1 <> i2) - (Subscript i1, Subscript i2) -> xs' |> Subscript (i1 <> i2) - (Superscript i1, Superscript i2) -> xs' |> Superscript (i1 <> i2) - (Strikeout i1, Strikeout i2) -> xs' |> Strikeout (i1 <> i2) - (Space, LineBreak) -> xs' |> LineBreak - (LineBreak, Space) -> xs' |> LineBreak - (SoftBreak, LineBreak) -> xs' |> LineBreak - (LineBreak, SoftBreak) -> xs' |> LineBreak - (SoftBreak, SoftBreak) -> xs' |> SoftBreak - _ -> xs' |> x |> y + (Space, Space) -> xs' |> Inline Space + (Space, SoftBreak) -> xs' |> Inline SoftBreak + (SoftBreak, Space) -> xs' |> Inline SoftBreak + (Str t1, Str t2) -> xs' |> Inline (Str (t1 <> t2)) + (Emph i1, Emph i2) -> xs' |> Inline (Emph (i1 <> i2)) + (Underline i1, Underline i2) -> xs' |> Inline (Underline (i1 <> i2)) + (Strong i1, Strong i2) -> xs' |> Inline (Strong (i1 <> i2)) + (Subscript i1, Subscript i2) -> xs' |> Inline (Subscript (i1 <> i2)) + (Superscript i1, Superscript i2) -> xs' |> Inline (Superscript (i1 <> i2)) + (Strikeout i1, Strikeout i2) -> xs' |> Inline (Strikeout (i1 <> i2)) + (Space, LineBreak) -> xs' |> Inline LineBreak + (LineBreak, Space) -> xs' |> Inline LineBreak + (SoftBreak, LineBreak) -> xs' |> Inline LineBreak + (LineBreak, SoftBreak) -> xs' |> Inline LineBreak + (SoftBreak, SoftBreak) -> xs' |> Inline SoftBreak + _ -> xs' |> Inline x |> Inline y instance Monoid Inlines where mempty = Many mempty mappend = (<>) @@ -263,9 +263,10 @@ trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $ Seq.reverse $ Seq.dropWhileL isSp $ Seq.reverse ils #endif - where isSp Space = True - isSp SoftBreak = True - isSp _ = False + where isSp = isSp' . unInline + isSp' Space = True + isSp' SoftBreak = True + isSp' _ = False -- Document builders @@ -334,10 +335,11 @@ text = fromList . map conv . breakBySpaces where breakBySpaces = T.groupBy sameCategory sameCategory x y = is_space x == is_space y conv xs | T.all is_space xs = + Inline $ if T.any is_newline xs then SoftBreak else Space - conv xs = Str xs + conv xs = Inline $ Str xs is_space ' ' = True is_space '\r' = True is_space '\n' = True @@ -348,28 +350,28 @@ text = fromList . map conv . breakBySpaces is_newline _ = False str :: Text -> Inlines -str = singleton . Str +str = singleton . Inline . Str emph :: Inlines -> Inlines -emph = singleton . Emph . toList +emph = singleton . Inline . Emph . toList underline :: Inlines -> Inlines -underline = singleton . Underline . toList +underline = singleton . Inline . Underline . toList strong :: Inlines -> Inlines -strong = singleton . Strong . toList +strong = singleton . Inline . Strong . toList strikeout :: Inlines -> Inlines -strikeout = singleton . Strikeout . toList +strikeout = singleton . Inline . Strikeout . toList superscript :: Inlines -> Inlines -superscript = singleton . Superscript . toList +superscript = singleton . Inline . Superscript . toList subscript :: Inlines -> Inlines -subscript = singleton . Subscript . toList +subscript = singleton . Inline . Subscript . toList smallcaps :: Inlines -> Inlines -smallcaps = singleton . SmallCaps . toList +smallcaps = singleton . Inline . SmallCaps . toList singleQuoted :: Inlines -> Inlines singleQuoted = quoted SingleQuote @@ -378,38 +380,38 @@ doubleQuoted :: Inlines -> Inlines doubleQuoted = quoted DoubleQuote quoted :: QuoteType -> Inlines -> Inlines -quoted qt = singleton . Quoted qt . toList +quoted qt = singleton . Inline . Quoted qt . toList cite :: [Citation] -> Inlines -> Inlines -cite cts = singleton . Cite cts . toList +cite cts = singleton . Inline . Cite cts . toList -- | Inline code with attributes. codeWith :: Attr -> Text -> Inlines -codeWith attrs = singleton . Code attrs +codeWith attrs = singleton . Inline . Code attrs -- | Plain inline code. code :: Text -> Inlines code = codeWith nullAttr space :: Inlines -space = singleton Space +space = singleton $ Inline Space softbreak :: Inlines -softbreak = singleton SoftBreak +softbreak = singleton $ Inline SoftBreak linebreak :: Inlines -linebreak = singleton LineBreak +linebreak = singleton $ Inline LineBreak -- | Inline math math :: Text -> Inlines -math = singleton . Math InlineMath +math = singleton . Inline . Math InlineMath -- | Display math displayMath :: Text -> Inlines -displayMath = singleton . Math DisplayMath +displayMath = singleton . Inline . Math DisplayMath rawInline :: Text -> Text -> Inlines -rawInline format = singleton . RawInline (Format format) +rawInline format = singleton . Inline . RawInline (Format format) link :: Text -- ^ URL -> Text -- ^ Title @@ -422,7 +424,7 @@ linkWith :: Attr -- ^ Attributes -> Text -- ^ Title -> Inlines -- ^ Label -> Inlines -linkWith attr url title x = singleton $ Link attr (toList x) (url, title) +linkWith attr url title x = singleton $ Inline $ Link attr (toList x) (url, title) image :: Text -- ^ URL -> Text -- ^ Title @@ -435,54 +437,54 @@ imageWith :: Attr -- ^ Attributes -> Text -- ^ Title -> Inlines -- ^ Alt text -> Inlines -imageWith attr url title x = singleton $ Image attr (toList x) (url, title) +imageWith attr url title x = singleton $ Inline $ Image attr (toList x) (url, title) note :: Blocks -> Inlines -note = singleton . Note . toList +note = singleton . Inline . Note . toList spanWith :: Attr -> Inlines -> Inlines -spanWith attr = singleton . Span attr . toList +spanWith attr = singleton . Inline . Span attr . toList -- Block list builders para :: Inlines -> Blocks -para = singleton . Para . toList +para = singleton . Block . Para . toList plain :: Inlines -> Blocks plain ils = if isNull ils then mempty - else singleton . Plain . toList $ ils + else singleton . Block . Plain . toList $ ils lineBlock :: [Inlines] -> Blocks -lineBlock = singleton . LineBlock . map toList +lineBlock = singleton . Block . LineBlock . map toList -- | A code block with attributes. codeBlockWith :: Attr -> Text -> Blocks -codeBlockWith attrs = singleton . CodeBlock attrs +codeBlockWith attrs = singleton . Block . CodeBlock attrs -- | A plain code block. codeBlock :: Text -> Blocks codeBlock = codeBlockWith nullAttr rawBlock :: Text -> Text -> Blocks -rawBlock format = singleton . RawBlock (Format format) +rawBlock format = singleton . Block . RawBlock (Format format) blockQuote :: Blocks -> Blocks -blockQuote = singleton . BlockQuote . toList +blockQuote = singleton . Block . BlockQuote . toList -- | Ordered list with attributes. orderedListWith :: ListAttributes -> [Blocks] -> Blocks -orderedListWith attrs = singleton . OrderedList attrs . map toList +orderedListWith attrs = singleton . Block . OrderedList attrs . map toList -- | Ordered list with default attributes. orderedList :: [Blocks] -> Blocks orderedList = orderedListWith (1, DefaultStyle, DefaultDelim) bulletList :: [Blocks] -> Blocks -bulletList = singleton . BulletList . map toList +bulletList = singleton . Block . BulletList . map toList definitionList :: [(Inlines, [Blocks])] -> Blocks -definitionList = singleton . DefinitionList . map (toList *** map toList) +definitionList = singleton . Block . DefinitionList . map (toList *** map toList) header :: Int -- ^ Level -> Inlines @@ -490,10 +492,10 @@ header :: Int -- ^ Level header = headerWith nullAttr headerWith :: Attr -> Int -> Inlines -> Blocks -headerWith attr level = singleton . Header level attr . toList +headerWith attr level = singleton . Block . Header level attr . toList horizontalRule :: Blocks -horizontalRule = singleton HorizontalRule +horizontalRule = singleton $ Block HorizontalRule cellWith :: Attr -> Alignment @@ -537,7 +539,7 @@ tableWith :: Attr -> TableFoot -> Blocks tableWith attr capt specs th tbs tf - = singleton $ Table attr capt specs th' tbs' tf' + = singleton $ Block $ Table attr capt specs th' tbs' tf' where twidth = length specs th' = normalizeTableHead twidth th @@ -577,7 +579,7 @@ simpleFigure :: Inlines -> Text -> Text -> Blocks simpleFigure = simpleFigureWith nullAttr divWith :: Attr -> Blocks -> Blocks -divWith attr = singleton . Div attr . toList +divWith attr = singleton . Block . Div attr . toList -- | Normalize the 'TableHead' with 'clipRows' and 'placeRowSection' -- so that when placed on a grid with the given width and a height diff --git a/src/Text/Pandoc/Definition.hs b/src/Text/Pandoc/Definition.hs index 5674089..b00771e 100644 --- a/src/Text/Pandoc/Definition.hs +++ b/src/Text/Pandoc/Definition.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric, FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP, - TemplateHaskell , PatternSynonyms, ViewPatterns, StrictData #-} + TemplateHaskell , PatternSynonyms, ViewPatterns, StrictData, + DeriveTraversable + #-} {- Copyright (c) 2006-2019, John MacFarlane @@ -57,31 +59,41 @@ module Text.Pandoc.Definition ( Pandoc(..) , docAuthors , docDate , Block(..) + , BlockF(..) , pattern SimpleFigure , Inline(..) + , InlineF(..) , ListAttributes , ListNumberStyle(..) , ListNumberDelim(..) , Format(..) , Attr , nullAttr - , Caption(..) + , Caption + , CaptionF(..) , ShortCaption + , ShortCaptionF , RowHeadColumns(..) , Alignment(..) , ColWidth(..) , ColSpec - , Row(..) - , TableHead(..) - , TableBody(..) - , TableFoot(..) - , Cell(..) + , Row + , RowF(..) + , TableHead + , TableHeadF(..) + , TableBody + , TableBodyF(..) + , TableFoot + , TableFootF(..) + , Cell + , CellF(..) , RowSpan(..) , ColSpan(..) , QuoteType(..) , Target , MathType(..) - , Citation(..) + , Citation + , CitationF(..) , CitationMode(..) , pandocTypesVersion ) where @@ -148,10 +160,10 @@ lookupMeta key (Meta m) = M.lookup key m docTitle :: Meta -> [Inline] docTitle meta = case lookupMeta "title" meta of - Just (MetaString s) -> [Str s] + Just (MetaString s) -> [Inline $ Str s] Just (MetaInlines ils) -> ils - Just (MetaBlocks [Plain ils]) -> ils - Just (MetaBlocks [Para ils]) -> ils + Just (MetaBlocks [Block (Plain ils)]) -> ils + Just (MetaBlocks [Block (Para ils)]) -> ils _ -> [] -- | Extract document authors from metadata; works just like the old @@ -159,22 +171,22 @@ docTitle meta = docAuthors :: Meta -> [[Inline]] docAuthors meta = case lookupMeta "author" meta of - Just (MetaString s) -> [[Str s]] + Just (MetaString s) -> [[Inline $ Str s]] Just (MetaInlines ils) -> [ils] Just (MetaList ms) -> [ils | MetaInlines ils <- ms] ++ - [ils | MetaBlocks [Plain ils] <- ms] ++ - [ils | MetaBlocks [Para ils] <- ms] ++ - [[Str x] | MetaString x <- ms] + [ils | MetaBlocks [Block (Plain ils)] <- ms] ++ + [ils | MetaBlocks [Block (Para ils)] <- ms] ++ + [[Inline $ Str x] | MetaString x <- ms] _ -> [] -- | Extract date from metadata; works just like the old @docDate@. docDate :: Meta -> [Inline] docDate meta = case lookupMeta "date" meta of - Just (MetaString s) -> [Str s] + Just (MetaString s) -> [Inline $ Str s] Just (MetaInlines ils) -> ils - Just (MetaBlocks [Plain ils]) -> ils - Just (MetaBlocks [Para ils]) -> ils + Just (MetaBlocks [Block (Plain ils)]) -> ils + Just (MetaBlocks [Block (Para ils)]) -> ils _ -> [] -- | List attributes. The first element of the triple is the @@ -234,33 +246,52 @@ data ColWidth = ColWidth Double type ColSpec = (Alignment, ColWidth) -- | A table row. -data Row = Row Attr [Cell] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type Row = RowF Block +data RowF block = Row Attr [CellF block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) -- | The head of a table. -data TableHead = TableHead Attr [Row] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type TableHead = TableHeadF Block +data TableHeadF block = TableHead Attr [RowF 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 = TableBody Attr RowHeadColumns [Row] [Row] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type TableBody = TableBodyF Block +data TableBodyF block = TableBody Attr RowHeadColumns [RowF block] [RowF block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) -- | The foot of a table. -data TableFoot = TableFoot Attr [Row] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type TableFoot = TableFootF Block +data TableFootF block = TableFoot Attr [RowF 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] +type ShortCaptionF inline = [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 = CaptionF Inline Block +data CaptionF inline block = Caption (Maybe (ShortCaptionF inline)) [block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) -- | A table cell. -data Cell = Cell Attr Alignment RowSpan ColSpan [Block] - deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type Cell = CellF Block +data CellF block = Cell Attr Alignment RowSpan ColSpan [block] + deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) -- | The number of rows occupied by a cell; the height of a cell. newtype RowSpan = RowSpan Int @@ -271,41 +302,47 @@ newtype ColSpan = ColSpan Int deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) -- | Block element. -data Block +newtype Block = Block { unBlock :: BlockF Inline Block } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | Block element functor +data BlockF inline block -- | Plain text, not a paragraph - = Plain [Inline] + = Plain [inline] -- | Paragraph - | Para [Inline] + | Para [inline] -- | Multiple non-breaking lines - | LineBlock [[Inline]] + | LineBlock [[inline]] -- | Code block (literal) with attributes | CodeBlock Attr Text -- | Raw block | RawBlock Format Text -- | Block quote (list of blocks) - | BlockQuote [Block] + | BlockQuote [block] -- | Ordered list (attributes and a list of items, each a list of -- blocks) - | OrderedList ListAttributes [[Block]] + | OrderedList ListAttributes [[block]] -- | Bullet list (list of items, each a list of blocks) - | BulletList [[Block]] + | 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]])] + | DefinitionList [([inline],[[block]])] -- | Header - level (integer) and text (inlines) - | Header Int Attr [Inline] + | 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 Attr (CaptionF inline block) [ColSpec] (TableHeadF block) [TableBodyF block] (TableFootF block) -- | Generic block container with attributes - | Div Attr [Block] + | Div Attr [block] -- | Nothing | Null - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + deriving ( Eq, Ord, Read, Show, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) -- | Type of quotation marks to use in Quoted inline. data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) @@ -333,9 +370,9 @@ isFigureTarget tgt -- >>> 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 -> [inline] -> Target -> BlockF (InlineF block inline) block pattern SimpleFigure attr figureCaption tgt <- - Para [Image attr figureCaption + Para [Image attr figureCaption (isFigureTarget -> Just tgt)] where SimpleFigure attr figureCaption tgt = Para [Image attr figureCaption (second ("fig:" <>) tgt)] @@ -345,39 +382,49 @@ pattern SimpleFigure attr figureCaption tgt <- data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) -- | Inline elements. -data Inline +newtype Inline = Inline { unInline :: InlineF Block Inline } + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +data InlineF 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] -- ^ Citation (list of inlines) + | 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 [CitationF 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) - -data Citation = Citation { citationId :: Text - , citationPrefix :: [Inline] - , citationSuffix :: [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 + ) + +type Citation = CitationF Inline + +data CitationF inline = Citation + { citationId :: Text + , citationPrefix :: [inline] + , citationSuffix :: [inline] , citationMode :: CitationMode , citationNoteNum :: Int , citationHash :: Int } - deriving (Show, Eq, Read, Typeable, Data, Generic) + deriving ( Show, Eq, Read, Typeable, Data, Generic + , Functor, Foldable, Traversable + ) -instance Ord Citation where +instance Eq inline => Ord (CitationF inline) where compare = comparing citationHash data CitationMode = AuthorInText | SuppressAuthor | NormalCitation @@ -394,20 +441,22 @@ $(let jsonOpts = defaultOptions in fmap concat $ traverse (deriveJSON jsonOpts) [ ''MetaValue , ''CitationMode - , ''Citation + , ''CitationF , ''QuoteType , ''MathType , ''ListNumberStyle , ''ListNumberDelim , ''Alignment , ''ColWidth - , ''Row - , ''Caption - , ''TableHead - , ''TableBody - , ''TableFoot - , ''Cell + , ''RowF + , ''CaptionF + , ''TableHeadF + , ''TableBodyF + , ''TableFootF + , ''CellF + , ''InlineF , ''Inline + , ''BlockF , ''Block ]) @@ -450,16 +499,17 @@ instance ToJSON Pandoc where -- Instances for deepseq instance NFData MetaValue instance NFData Meta -instance NFData Citation +instance NFData inline => NFData (CitationF inline) 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 block => NFData (CellF block) +instance NFData block => NFData (RowF block) +instance NFData block => NFData (TableHeadF block) +instance NFData block => NFData (TableBodyF block) +instance NFData block => NFData (TableFootF block) +instance (NFData block, NFData inline) => NFData (CaptionF block inline) +instance (NFData block, NFData inline) => NFData (InlineF block inline) instance NFData Inline instance NFData MathType instance NFData Format @@ -469,6 +519,7 @@ instance NFData ListNumberDelim instance NFData ListNumberStyle instance NFData ColWidth instance NFData RowHeadColumns +instance (NFData inline, NFData block) => NFData (BlockF inline block) instance NFData Block instance NFData Pandoc diff --git a/src/Text/Pandoc/Walk.hs b/src/Text/Pandoc/Walk.hs index 3dba0dd..1faaf4b 100644 --- a/src/Text/Pandoc/Walk.hs +++ b/src/Text/Pandoc/Walk.hs @@ -137,7 +137,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 +152,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 +421,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 (CitationF inline), Walkable a [block], + Walkable a [inline], Monad m, Applicative m, Functor m) + => (a -> m a) -> InlineF block inline -> m (InlineF block inline) +walkInlineFM _ (Str xs) = return (Str xs) +walkInlineFM f (Emph xs) = Emph <$> walkM f xs +walkInlineFM f (Underline xs) = Underline <$> walkM f xs +walkInlineFM f (Strong xs) = Strong <$> walkM f xs +walkInlineFM f (Strikeout xs) = Strikeout <$> walkM f xs +walkInlineFM f (Subscript xs) = Subscript <$> walkM f xs +walkInlineFM f (Superscript xs) = Superscript <$> walkM f xs +walkInlineFM f (SmallCaps xs) = SmallCaps <$> walkM f xs +walkInlineFM f (Quoted qt xs) = Quoted qt <$> walkM f xs +walkInlineFM f (Link atr xs t) = Link atr <$> walkM f xs <*> pure t +walkInlineFM f (Image atr xs t) = Image atr <$> walkM f xs <*> pure t +walkInlineFM f (Note bs) = Note <$> walkM f bs +walkInlineFM f (Span attr xs) = Span attr <$> walkM f xs +walkInlineFM f (Cite cs xs) = Cite <$> walkM f cs <*> walkM f xs +walkInlineFM _ LineBreak = return LineBreak +walkInlineFM _ SoftBreak = return SoftBreak +walkInlineFM _ Space = return Space +walkInlineFM _ x@Code {} = return x +walkInlineFM _ x@Math {} = return x +walkInlineFM _ x@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 (CitationF inline), Walkable a [block], + Walkable a [inline], Monoid c) + => (a -> c) -> InlineF block inline -> c +queryInlineF _ (Str _) = mempty +queryInlineF f (Emph xs) = query f xs +queryInlineF f (Underline xs) = query f xs +queryInlineF f (Strong xs) = query f xs +queryInlineF f (Strikeout xs) = query f xs +queryInlineF f (Subscript xs) = query f xs +queryInlineF f (Superscript xs)= query f xs +queryInlineF f (SmallCaps xs) = query f xs +queryInlineF f (Quoted _ xs) = query f xs +queryInlineF f (Cite cs xs) = query f cs <> query f xs +queryInlineF _ (Code _ _) = mempty +queryInlineF _ Space = mempty +queryInlineF _ SoftBreak = mempty +queryInlineF _ LineBreak = mempty +queryInlineF _ (Math _ _) = mempty +queryInlineF _ (RawInline _ _) = mempty +queryInlineF f (Link _ xs _) = query f xs +queryInlineF f (Image _ xs _) = query f xs +queryInlineF f (Note bs) = query f bs +queryInlineF f (Span _ xs) = query f xs -- | Helper method to walk to elements nested below @'Block'@ nodes. @@ -473,20 +488,27 @@ 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 (CaptionF inline block), + Walkable a [inline], Walkable a [block], + Walkable a (TableHeadF block), Walkable a (TableBodyF block), + Walkable a (TableFootF block)) + => (a -> m a) -> BlockF inline block -> m (BlockF inline block) +walkBlockFM f (Para xs) = Para <$> walkM f xs +walkBlockFM f (Plain xs) = Plain <$> walkM f xs +walkBlockFM f (LineBlock xs) = LineBlock <$> walkM f xs +walkBlockFM f (BlockQuote xs) = BlockQuote <$> walkM f xs +walkBlockFM f (OrderedList a cs) = OrderedList a <$> walkM f cs +walkBlockFM f (BulletList cs) = BulletList <$> walkM f cs +walkBlockFM f (DefinitionList xs) = DefinitionList <$> walkM f xs +walkBlockFM f (Header lev attr xs) = Header lev attr <$> walkM f xs +walkBlockFM f (Div attr bs') = Div attr <$> walkM f bs' +walkBlockFM _ x@CodeBlock {} = return x +walkBlockFM _ x@RawBlock {} = return x +walkBlockFM _ HorizontalRule = return HorizontalRule +walkBlockFM _ Null = return Null +walkBlockFM f (Table attr capt as hs bs fs) = do capt' <- walkM f capt hs' <- walkM f hs bs' <- walkM f bs @@ -499,24 +521,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 (CaptionF inline block), + Walkable a [inline], Walkable a [block], + Walkable a (TableHeadF block), Walkable a (TableBodyF block), + Walkable a (TableFootF block)) + => (a -> c) -> BlockF inline block -> c +queryBlockF f (Para xs) = query f xs +queryBlockF f (Plain xs) = query f xs +queryBlockF f (LineBlock xs) = query f xs +queryBlockF _ (CodeBlock _ _) = mempty +queryBlockF _ (RawBlock _ _) = mempty +queryBlockF f (BlockQuote bs) = query f bs +queryBlockF f (OrderedList _ cs) = query f cs +queryBlockF f (BulletList cs) = query f cs +queryBlockF f (DefinitionList xs) = query f xs +queryBlockF f (Header _ _ xs) = query f xs +queryBlockF _ HorizontalRule = mempty +queryBlockF 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 (Div _ bs) = query f bs +queryBlockF _ Null = mempty -- | Helper method to walk to elements nested below @'MetaValue'@ nodes. -- @@ -567,8 +596,8 @@ queryMetaValue' _ _ = mempty -- 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) -> CitationF inline -> m (CitationF inline) walkCitationM f (Citation id' pref suff mode notenum hash) = do pref' <- walkM f pref suff' <- walkM f suff @@ -576,8 +605,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) -> CitationF inline -> c queryCitation f (Citation _ pref suff _ _ _) = query f pref <> query f suff -- | Helper method to walk the elements nested below @'Row'@ nodes. The