pandoc-types 1.20 → 1.21
raw patch · 10 files changed
+1114/−513 lines, 10 filesdep ~QuickCheckdep ~aeson
Dependency ranges changed: QuickCheck, aeson
Files
- Text/Pandoc/Arbitrary.hs +106/−25
- Text/Pandoc/Builder.hs +250/−16
- Text/Pandoc/Definition.hs +225/−38
- Text/Pandoc/Legacy/Builder.hs +0/−162
- Text/Pandoc/Legacy/Definition.hs +0/−208
- Text/Pandoc/Walk.hs +215/−11
- benchmark/bench.hs +0/−1
- changelog +38/−0
- pandoc-types.cabal +12/−10
- test/test-pandoc-types.hs +268/−42
Text/Pandoc/Arbitrary.hs view
@@ -44,6 +44,7 @@ flattenInline :: Inline -> [Inline] flattenInline (Str _) = [] flattenInline (Emph ils) = ils+ flattenInline (Underline ils) = ils flattenInline (Strong ils) = ils flattenInline (Strikeout ils) = ils flattenInline (Superscript ils) = ils@@ -81,10 +82,24 @@ flattenBlock (DefinitionList defs) = concat [Para ils:concat blks | (ils, blks) <- defs] flattenBlock (Header _ _ ils) = [Para ils] flattenBlock HorizontalRule = []- flattenBlock (Table caption _ _ cells rows) = Para caption : concat (concat $ cells:rows)+ flattenBlock (Table _ capt _ hd bd ft) = flattenCaption capt <>+ flattenTableHead hd <>+ concatMap flattenTableBody bd <>+ flattenTableFoot ft flattenBlock (Div _ blks) = blks flattenBlock Null = [] + flattenCaption (Caption Nothing body) = body+ flattenCaption (Caption (Just ils) body) = Para ils : body++ flattenTableHead (TableHead _ body) = flattenRows body+ flattenTableBody (TableBody _ _ hd bd) = flattenRows hd <> flattenRows bd+ flattenTableFoot (TableFoot _ body) = flattenRows body++ flattenRows = concatMap flattenRow+ flattenRow (Row _ body) = concatMap flattenCell body+ flattenCell (Cell _ _ _ _ blks) = blks+ shrinkInlineList :: [Inline] -> [[Inline]] shrinkInlineList = fmap toList . shrink . fromList @@ -101,6 +116,7 @@ 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@@ -145,6 +161,7 @@ , 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))@@ -180,24 +197,13 @@ shrink (Header n attr ils) = (Header n attr <$> shrinkInlineList ils) ++ (flip (Header n) ils <$> shrinkAttr attr) shrink HorizontalRule = []- shrink (Table caption aligns widths cells rows) =+ shrink (Table attr capt specs thead tbody tfoot) = -- TODO: shrink number of columns- -- Shrink header contents- [Table caption aligns widths cells' rows | cells' <- shrinkRow cells] ++- -- Shrink number of rows and row contents- [Table caption aligns widths cells rows' | rows' <- shrinkRows rows] ++- -- Shrink caption- [Table caption' aligns widths cells rows | caption' <- shrinkInlineList caption]- where -- Shrink row contents without reducing the number of columns- shrinkRow :: [TableCell] -> [[TableCell]]- shrinkRow (x:xs) = [x':xs | x' <- shrinkBlockList x]- ++ [x:xs' | xs' <- shrinkRow xs]- shrinkRow [] = []- shrinkRows :: [[TableCell]] -> [[[TableCell]]]- shrinkRows (x:xs) = [xs] -- Shrink number of rows- ++ [x':xs | x' <- shrinkRow x] -- Shrink row contents- ++ [x:xs' | xs' <- shrinkRows xs]- shrinkRows [] = []+ [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 = []@@ -229,15 +235,51 @@ , (5, DefinitionList <$> listOf1 ((,) <$> arbInlines (n-1) <*> listOf1 (listOf1 $ arbBlock (n-1)))) , (5, Div <$> arbAttr <*> listOf1 (arbBlock (n-1)))- , (2, do rs <- choose (1 :: Int, 4)- cs <- choose (1 :: Int, 4)- Table <$> arbInlines (n-1)- <*> vector cs- <*> vectorOf cs (elements [0, 0.25])- <*> vectorOf cs (listOf $ arbBlock (n-1))- <*> vectorOf rs (vectorOf cs $ listOf $ arbBlock (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)) ] +arbRow :: Int -> Gen Row+arbRow n = do+ cs <- choose (0, 5)+ Row <$> arbAttr <*> vectorOf cs (arbCell n)++arbTableHead :: Int -> Gen TableHead+arbTableHead n = do+ rs <- choose (0, 5)+ TableHead <$> arbAttr <*> vectorOf rs (arbRow n)++arbTableBody :: Int -> Gen TableBody+arbTableBody 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)++arbTableFoot :: Int -> Gen TableFoot+arbTableFoot n = do+ rs <- choose (0, 5)+ TableFoot <$> arbAttr <*> vectorOf rs (arbRow n)++arbCell :: Int -> Gen Cell+arbCell n = Cell <$> arbAttr+ <*> arbitrary+ <*> (RowSpan <$> choose (1 :: Int, 2))+ <*> (ColSpan <$> choose (1 :: Int, 2))+ <*> listOf (arbBlock n)+ instance Arbitrary Pandoc where arbitrary = resize 8 (Pandoc <$> arbitrary <*> arbitrary) @@ -258,6 +300,45 @@ <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary Row where+ arbitrary = resize 3 $ arbRow 2+ shrink (Row attr body)+ = [Row attr' body | attr' <- shrinkAttr attr] +++ [Row attr body' | body' <- shrink body]++instance Arbitrary TableHead where+ arbitrary = resize 3 $ arbTableHead 2+ shrink (TableHead attr body)+ = [TableHead attr' body | attr' <- shrinkAttr attr] +++ [TableHead attr body' | body' <- shrink body]++instance Arbitrary TableBody where+ arbitrary = resize 3 $ arbTableBody 2+ -- TODO: shrink rhc?+ shrink (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]++instance Arbitrary TableFoot where+ arbitrary = resize 3 $ arbTableFoot 2+ shrink (TableFoot attr body)+ = [TableFoot attr' body | attr' <- shrinkAttr attr] +++ [TableFoot attr body' | body' <- shrink 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] +++ [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)+ = [Caption mshort' body | mshort' <- shrink mshort] +++ [Caption mshort body' | body' <- shrinkBlockList body] instance Arbitrary MathType where arbitrary
Text/Pandoc/Builder.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,- DeriveTraversable, OverloadedStrings #-}+ DeriveTraversable, OverloadedStrings, PatternGuards #-} {- Copyright (C) 2010-2019 John MacFarlane @@ -121,6 +121,7 @@ , text , str , emph+ , underline , strong , strikeout , superscript@@ -159,9 +160,23 @@ , header , headerWith , horizontalRule+ , cell+ , simpleCell+ , emptyCell+ , cellWith , table , simpleTable+ , tableWith+ , caption+ , simpleCaption+ , emptyCaption , divWith+ -- * Table processing+ , normalizeTableHead+ , normalizeTableBody+ , normalizeTableFoot+ , placeRowSection+ , clipRows ) where import Text.Pandoc.Definition@@ -214,6 +229,7 @@ (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)@@ -307,7 +323,7 @@ -- Inline list builders --- | Convert a 'String' to 'Inlines', treating interword spaces as 'Space's+-- | Convert a 'Text' to 'Inlines', treating interword spaces as 'Space's -- or 'SoftBreak's. If you want a 'Str' with literal spaces, use 'str'. text :: Text -> Inlines text = fromList . map conv . breakBySpaces@@ -333,6 +349,9 @@ emph :: Inlines -> Inlines emph = singleton . Emph . toList +underline :: Inlines -> Inlines+underline = singleton . Underline . toList+ strong :: Inlines -> Inlines strong = singleton . Strong . toList @@ -472,30 +491,245 @@ horizontalRule :: Blocks horizontalRule = singleton HorizontalRule --- | Table builder. Rows and headers will be padded or truncated to the size of--- @cellspecs@-table :: Inlines -- ^ Caption- -> [(Alignment, Double)] -- ^ Column alignments and fractional widths- -> [Blocks] -- ^ Headers- -> [[Blocks]] -- ^ Rows+cellWith :: Attr+ -> Alignment+ -> RowSpan+ -> ColSpan+ -> Blocks+ -> Cell+cellWith at a r c = Cell at a r c . toList++cell :: Alignment+ -> RowSpan+ -> ColSpan+ -> Blocks+ -> Cell+cell = cellWith nullAttr++-- | A 1×1 cell with default alignment.+simpleCell :: Blocks -> Cell+simpleCell = cell AlignDefault 1 1++-- | A 1×1 empty cell.+emptyCell :: Cell+emptyCell = simpleCell mempty++-- | Table builder. Performs normalization with 'normalizeTableHead',+-- 'normalizeTableBody', and 'normalizeTableFoot'. The number of table+-- columns is given by the length of @['ColSpec']@.+table :: Caption+ -> [ColSpec]+ -> TableHead+ -> [TableBody]+ -> TableFoot -> Blocks-table caption cellspecs headers rows = singleton $- Table (toList caption) aligns widths (sanitise headers) (map sanitise rows)- where (aligns, widths) = unzip cellspecs- sanitise = map toList . pad mempty numcols- numcols = length cellspecs- pad element upTo list = take upTo (list ++ repeat element)+table = tableWith nullAttr +tableWith :: Attr+ -> Caption+ -> [ColSpec]+ -> TableHead+ -> [TableBody]+ -> TableFoot+ -> Blocks+tableWith attr capt specs th tbs tf+ = singleton $ Table attr capt specs th' tbs' tf'+ where+ twidth = length specs+ th' = normalizeTableHead twidth th+ tbs' = map (normalizeTableBody twidth) tbs+ tf' = normalizeTableFoot twidth tf+ -- | A simple table without a caption. simpleTable :: [Blocks] -- ^ Headers -> [[Blocks]] -- ^ Rows -> Blocks simpleTable headers rows =- table mempty (replicate numcols defaults) headers rows- where defaults = (AlignDefault, 0)+ table emptyCaption (replicate numcols defaults) th [tb] tf+ where defaults = (AlignDefault, ColWidthDefault) numcols = case headers:rows of [] -> 0 xs -> maximum (map length xs)+ toRow = Row nullAttr . map simpleCell+ toHeaderRow l+ | null l = []+ | otherwise = [toRow headers]+ th = TableHead nullAttr (toHeaderRow headers)+ tb = TableBody nullAttr 0 [] $ map toRow rows+ tf = TableFoot nullAttr [] +caption :: Maybe ShortCaption -> Blocks -> Caption+caption x = Caption x . toList++simpleCaption :: Blocks -> Caption+simpleCaption = caption Nothing++emptyCaption :: Caption+emptyCaption = simpleCaption mempty+ divWith :: Attr -> Blocks -> Blocks divWith attr = singleton . Div attr . toList++-- | Normalize the 'TableHead' with 'clipRows' and 'placeRowSection'+-- so that when placed on a grid with the given width and a height+-- equal to the number of rows in the initial 'TableHead', there will+-- be no empty spaces or overlapping cells, and the cells will not+-- protrude beyond the grid.+normalizeTableHead :: Int -> TableHead -> TableHead+normalizeTableHead twidth (TableHead attr rows)+ = TableHead attr $ normalizeHeaderSection twidth rows++-- | Normalize the intermediate head and body section of a+-- 'TableBody', as in 'normalizeTableHead', but additionally ensure+-- that row head cells do not go beyond the row head.+normalizeTableBody :: Int -> TableBody -> TableBody+normalizeTableBody twidth (TableBody attr rhc th tb)+ = TableBody attr rhc' (normBody th) (normBody tb)+ where+ rhc' = max 0 $ min (RowHeadColumns twidth) rhc+ normBody = normalizeBodySection twidth rhc'++-- | Normalize the 'TableFoot', as in 'normalizeTableHead'.+normalizeTableFoot :: Int -> TableFoot -> TableFoot+normalizeTableFoot twidth (TableFoot attr rows)+ = TableFoot attr $ normalizeHeaderSection twidth rows++normalizeHeaderSection :: Int -- ^ The desired width of the table+ -> [Row]+ -> [Row]+normalizeHeaderSection twidth rows+ = normalizeRows' (replicate twidth 1) $ clipRows rows+ where+ normalizeRows' oldHang (Row attr cells:rs)+ = let (newHang, cells', _) = placeRowSection oldHang $ cells <> repeat emptyCell+ rs' = normalizeRows' newHang rs+ in Row attr cells' : rs'+ normalizeRows' _ [] = []++normalizeBodySection :: Int -- ^ The desired width of the table+ -> RowHeadColumns -- ^ The width of the row head,+ -- between 0 and the table+ -- width+ -> [Row]+ -> [Row]+normalizeBodySection twidth (RowHeadColumns rhc) rows+ = normalizeRows' (replicate rhc 1) (replicate rbc 1) $ clipRows rows+ where+ rbc = twidth - rhc++ normalizeRows' headHang bodyHang (Row attr cells:rs)+ = let (headHang', rowHead, cells') = placeRowSection headHang $ cells <> repeat emptyCell+ (bodyHang', rowBody, _) = placeRowSection bodyHang cells'+ rs' = normalizeRows' headHang' bodyHang' rs+ in Row attr (rowHead <> rowBody) : rs'+ normalizeRows' _ _ [] = []++-- | Normalize the given list of cells so that they fit on a single+-- grid row. The 'RowSpan' values of the cells are assumed to be valid+-- (clamped to lie between 1 and the remaining grid height). The cells+-- in the list are also assumed to be able to fill the entire grid+-- row. These conditions can be met by appending @repeat 'emptyCell'@+-- to the @['Cell']@ list and using 'clipRows' on the entire table+-- section beforehand.+--+-- Normalization follows the principle that cells are placed on a grid+-- row in order, each at the first available grid position from the+-- left, having their 'ColSpan' reduced if they would overlap with a+-- previous cell, stopping once the row is filled. Only the dimensions+-- of cells are changed, and only of those cells that fit on the row.+--+-- Possible overlap is detected using the given @['RowSpan']@, which+-- is the "overhang" of the previous grid row, a list of the heights+-- of cells that descend through the previous row, reckoned+-- /only from the previous row/.+-- Its length should be the width (number of columns) of the current+-- grid row.+--+-- For example, the numbers in the following headerless grid table+-- represent the overhang at each grid position for that table:+--+-- @+-- 1 1 1 1+-- +---+---+---+---++-- | 1 | 2 2 | 3 |+-- +---+ + ++-- | 1 | 1 1 | 2 |+-- +---+---+---+ ++-- | 1 1 | 1 | 1 |+-- +---+---+---+---++-- @+--+-- In any table, the row before the first has an overhang of+-- @replicate tableWidth 1@, since there are no cells to descend into+-- the table from there. The overhang of the first row in the example+-- is @[1, 2, 2, 3]@.+--+-- So if after 'clipRows' the unnormalized second row of that example+-- table were+--+-- > r = [("a", 1, 2),("b", 2, 3)] -- the cells displayed as (label, RowSpan, ColSpan) only+--+-- a correct invocation of 'placeRowSection' to normalize it would be+--+-- >>> placeRowSection [1, 2, 2, 3] $ r ++ repeat emptyCell+-- ([1, 1, 1, 2], [("a", 1, 1)], [("b", 2, 3)] ++ repeat emptyCell) -- wouldn't stop printing, of course+--+-- and if the third row were only @[("c", 1, 2)]@, then the expression+-- would be+--+-- >>> placeRowSection [1, 1, 1, 2] $ [("c", 1, 2)] ++ repeat emptyCell+-- ([1, 1, 1, 1], [("c", 1, 2), emptyCell], repeat emptyCell)+placeRowSection :: [RowSpan] -- ^ The overhang of the previous grid+ -- row+ -> [Cell] -- ^ The cells to lay on the grid row+ -> ([RowSpan], [Cell], [Cell]) -- ^ The overhang of+ -- the current grid+ -- row, the normalized+ -- cells that fit on+ -- the current row, and+ -- the remaining+ -- unmodified cells+placeRowSection oldHang cellStream+ -- If the grid has overhang at our position, try to re-lay in+ -- the next position.+ | o:os <- oldHang+ , o > 1 = let (newHang, newCell, cellStream') = placeRowSection os cellStream+ in (o - 1 : newHang, newCell, cellStream')+ -- Otherwise if there is any available width, place the cell and+ -- continue.+ | c:cellStream' <- cellStream+ , (h, w) <- getDim c+ , w' <- max 1 w+ , (n, oldHang') <- dropAtMostWhile (== 1) (getColSpan w') oldHang+ , n > 0+ = let w'' = min (ColSpan n) w'+ c' = setW w'' c+ (newHang, newCell, remainCell) = placeRowSection oldHang' cellStream'+ in (replicate (getColSpan w'') h <> newHang, c' : newCell, remainCell)+ -- Otherwise there is no room in the section, or not enough cells+ -- were given.+ | otherwise = ([], [], cellStream)+ where+ getColSpan (ColSpan w) = w+ getDim (Cell _ _ h w _) = (h, w)+ setW w (Cell a ma h _ b) = Cell a ma h w b++ dropAtMostWhile :: (a -> Bool) -> Int -> [a] -> (Int, [a])+ dropAtMostWhile p n = go 0+ where+ go acc (l:ls) | p l && acc < n = go (acc+1) ls+ go acc l = (acc, l)++-- | Ensure that the height of each cell in a table section lies+-- between 1 and the distance from its row to the end of the+-- section. So if there were four rows in the input list, the cells in+-- the second row would have their height clamped between 1 and 3.+clipRows :: [Row] -> [Row]+clipRows rows+ = let totalHeight = RowSpan $ length rows+ in zipWith clipRowH [totalHeight, totalHeight - 1..1] rows+ where+ getH (Cell _ _ h _ _) = h+ setH h (Cell a ma _ w body) = Cell a ma h w body+ clipH low high c = let h = getH c in setH (min high $ max low h) c+ clipRowH high (Row attr cells) = Row attr $ map (clipH 1 high) cells
Text/Pandoc/Definition.hs view
@@ -57,14 +57,25 @@ , docDate , Block(..) , Inline(..)- , Alignment(..) , ListAttributes , ListNumberStyle(..) , ListNumberDelim(..) , Format(..) , Attr , nullAttr- , TableCell+ , Caption(..)+ , ShortCaption+ , RowHeadColumns(..)+ , Alignment(..)+ , ColWidth(..)+ , ColSpec+ , Row(..)+ , TableHead(..)+ , TableBody(..)+ , TableFoot(..)+ , Cell(..)+ , RowSpan(..)+ , ColSpan(..) , QuoteType(..) , Target , MathType(..)@@ -162,12 +173,6 @@ Just (MetaBlocks [Para ils]) -> ils _ -> [] --- | Alignment of a table column.-data Alignment = AlignLeft- | AlignRight- | AlignCenter- | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)- -- | List attributes. The first element of the triple is the -- start number of the list. type ListAttributes = (Int, ListNumberStyle, ListNumberDelim)@@ -193,9 +198,6 @@ nullAttr :: Attr nullAttr = ("",[],[]) --- | Table cells are list of Blocks-type TableCell = [Block]- -- | Formats for raw blocks newtype Format = Format Text deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON)@@ -209,31 +211,96 @@ 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)++-- | 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 fraction of the total table+-- 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)++-- | The head of a table.+data TableHead = TableHead Attr [Row]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | A body of a table, with an intermediate head and the specified+-- number of row header columns.+data TableBody = TableBody Attr RowHeadColumns [Row] [Row]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | The foot of a table.+data TableFoot = TableFoot Attr [Row]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | A short caption, for use in, for instance, lists of figures.+type ShortCaption = [Inline]++-- | The caption of a table, with an optional short caption.+data Caption = Caption (Maybe ShortCaption) [Block]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | 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)++-- | 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)+ -- | Block element. data Block- = Plain [Inline] -- ^ Plain text, not a paragraph- | Para [Inline] -- ^ Paragraph- | LineBlock [[Inline]] -- ^ Multiple non-breaking lines- | CodeBlock Attr Text -- ^ Code block (literal) with attributes- | RawBlock Format Text -- ^ Raw block- | BlockQuote [Block] -- ^ Block quote (list of blocks)- | OrderedList ListAttributes [[Block]] -- ^ Ordered list (attributes- -- and a list of items, each a list of blocks)- | BulletList [[Block]] -- ^ Bullet list (list of items, each- -- a list of blocks)- | DefinitionList [([Inline],[[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)- | Header Int Attr [Inline] -- ^ Header - level (integer) and text (inlines)- | HorizontalRule -- ^ Horizontal rule- | Table [Inline] [Alignment] [Double] [TableCell] [[TableCell]] -- ^ Table,- -- with caption, column alignments (required),- -- relative column widths (0 = default),- -- column headers (each a list of blocks), and- -- rows (each a list of lists of blocks)- | Div Attr [Block] -- ^ Generic block container with attributes- | Null -- ^ Nothing+ -- | 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 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | Type of quotation marks to use in Quoted inline.@@ -249,6 +316,7 @@ 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)@@ -450,13 +518,121 @@ AlignCenter -> "AlignCenter" AlignDefault -> "AlignDefault" +instance FromJSON ColWidth where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "ColWidth" -> ColWidth <$> v .: "c"+ "ColWidthDefault" -> return ColWidthDefault+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON ColWidth where+ toJSON (ColWidth ils) = tagged "ColWidth" ils+ toJSON ColWidthDefault = taggedNoContent "ColWidthDefault" +instance FromJSON Row where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "Row" -> do (attr, body) <- v .: "c"+ return $ Row attr body+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON Row where+ toJSON (Row attr body) = tagged "Row" (attr, body)++instance FromJSON Caption where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "Caption" -> do (mshort, body) <- v .: "c"+ return $ Caption mshort body+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON Caption where+ toJSON (Caption mshort body) = tagged "Caption" (mshort, body)++instance FromJSON RowSpan where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "RowSpan" -> RowSpan <$> v .: "c"+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON RowSpan where+ toJSON (RowSpan h) = tagged "RowSpan" h++instance FromJSON ColSpan where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "ColSpan" -> ColSpan <$> v .: "c"+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON ColSpan where+ toJSON (ColSpan w) = tagged "ColSpan" w++instance FromJSON RowHeadColumns where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "RowHeadColumns" -> RowHeadColumns <$> v .: "c"+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON RowHeadColumns where+ toJSON (RowHeadColumns w) = tagged "RowHeadColumns" w++instance FromJSON TableHead where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "TableHead" -> do (attr, body) <- v .: "c"+ return $ TableHead attr body+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON TableHead where+ toJSON (TableHead attr body) = tagged "TableHead" (attr, body)++instance FromJSON TableBody where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "TableBody" -> do (attr, rhc, hd, body) <- v .: "c"+ return $ TableBody attr rhc hd body+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON TableBody where+ toJSON (TableBody attr rhc hd body) = tagged "TableBody" (attr, rhc, hd, body)++instance FromJSON TableFoot where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "TableFoot" -> do (attr, body) <- v .: "c"+ return $ TableFoot attr body+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON TableFoot where+ toJSON (TableFoot attr body) = tagged "TableFoot" (attr, body)++instance FromJSON Cell where+ parseJSON (Object v) = do+ t <- v .: "t" :: Aeson.Parser Value+ case t of+ "Cell" -> do (attr, malign, rs, cs, body) <- v .: "c"+ return $ Cell attr malign rs cs body+ _ -> mempty+ parseJSON _ = mempty+instance ToJSON Cell where+ toJSON (Cell attr malign rs cs body) = tagged "Cell" (attr, malign, rs, cs, body)+ instance FromJSON Inline where parseJSON (Object v) = do t <- v .: "t" :: Aeson.Parser Value case t of "Str" -> Str <$> v .: "c" "Emph" -> Emph <$> v .: "c"+ "Underline" -> Underline <$> v .: "c" "Strong" -> Strong <$> v .: "c" "Strikeout" -> Strikeout <$> v .: "c" "Superscript" -> Superscript <$> v .: "c"@@ -488,6 +664,7 @@ instance ToJSON Inline where toJSON (Str s) = tagged "Str" s toJSON (Emph ils) = tagged "Emph" ils+ toJSON (Underline ils) = tagged "Underline" ils toJSON (Strong ils) = tagged "Strong" ils toJSON (Strikeout ils) = tagged "Strikeout" ils toJSON (Superscript ils) = tagged "Superscript" ils@@ -525,8 +702,8 @@ "Header" -> do (n, attr, ils) <- v .: "c" return $ Header n attr ils "HorizontalRule" -> return HorizontalRule- "Table" -> do (cpt, align, wdths, hdr, rows) <- v .: "c"- return $ Table cpt align wdths hdr rows+ "Table" -> do (attr, cpt, align, hdr, body, foot) <- v .: "c"+ return $ Table attr cpt align hdr body foot "Div" -> do (attr, blks) <- v .: "c" return $ Div attr blks "Null" -> return Null@@ -544,8 +721,8 @@ toJSON (DefinitionList defs) = tagged "DefinitionList" defs toJSON (Header n attr ils) = tagged "Header" (n, attr, ils) toJSON HorizontalRule = taggedNoContent "HorizontalRule"- toJSON (Table caption aligns widths cells rows) =- tagged "Table" (caption, aligns, widths, cells, rows)+ toJSON (Table attr caption aligns hd body foot) =+ tagged "Table" (attr, caption, aligns, hd, body, foot) toJSON (Div attr blks) = tagged "Div" (attr, blks) toJSON Null = taggedNoContent "Null" @@ -579,6 +756,14 @@ 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 Inline instance NFData MathType instance NFData Format@@ -586,6 +771,8 @@ instance NFData QuoteType instance NFData ListNumberDelim instance NFData ListNumberStyle+instance NFData ColWidth+instance NFData RowHeadColumns instance NFData Block instance NFData Pandoc
− Text/Pandoc/Legacy/Builder.hs
@@ -1,162 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Text.Pandoc.Legacy.Builder- ( module Text.Pandoc.Legacy.Definition- , B.Many(..)- , B.Inlines- , B.Blocks- , (<>)- , B.singleton- , B.toList- , B.fromList- , B.isNull- , B.doc- , ToMetaValue(..)- , HasMeta(..)- , B.setTitle- , B.setAuthors- , B.setDate- , text- , str- , B.emph- , B.strong- , B.strikeout- , B.superscript- , B.subscript- , B.smallcaps- , B.singleQuoted- , B.doubleQuoted- , B.cite- , codeWith- , code- , B.space- , B.softbreak- , B.linebreak- , math- , displayMath- , rawInline- , link- , linkWith- , image- , imageWith- , B.note- , spanWith- , B.trimInlines- , B.para- , B.plain- , B.lineBlock- , codeBlockWith- , codeBlock- , rawBlock- , B.blockQuote- , B.bulletList- , B.orderedListWith- , B.orderedList- , B.definitionList- , B.header- , headerWith- , B.horizontalRule- , B.table- , B.simpleTable- , divWith- ) where--import qualified Data.Map as M-import qualified Data.Text as T-import qualified Text.Pandoc.Builder as B-import Text.Pandoc.Legacy.Definition-import Data.Semigroup (Semigroup(..))--fromLegacyAttr :: Attr -> B.Attr-fromLegacyAttr (a, b, c) = (T.pack a, map T.pack b, map pack2 c)- where- pack2 (x, y) = (T.pack x, T.pack y)--class ToMetaValue a where- toMetaValue :: a -> B.MetaValue--instance ToMetaValue B.MetaValue where- toMetaValue = id--instance ToMetaValue B.Blocks where- toMetaValue = B.MetaBlocks . B.toList--instance ToMetaValue B.Inlines where- toMetaValue = MetaInlines . B.toList--instance ToMetaValue Bool where- toMetaValue = MetaBool--instance {-# OVERLAPPING #-} ToMetaValue String where- toMetaValue = MetaString--instance ToMetaValue a => ToMetaValue [a] where- toMetaValue = MetaList . map toMetaValue--instance ToMetaValue a => ToMetaValue (M.Map String a) where- toMetaValue = MetaMap . M.map toMetaValue--class HasMeta a where- setMeta :: ToMetaValue b => String -> b -> a -> a- deleteMeta :: String -> a -> a--instance HasMeta Meta where- setMeta key val (B.Meta ms) = B.Meta $ M.insert (T.pack key) (toMetaValue val) ms- deleteMeta key (B.Meta ms) = B.Meta $ M.delete (T.pack key) ms--instance HasMeta Pandoc where- setMeta key val (Pandoc (B.Meta ms) bs) =- Pandoc (B.Meta $ M.insert (T.pack key) (toMetaValue val) ms) bs- deleteMeta key (Pandoc (B.Meta ms) bs) =- Pandoc (B.Meta $ M.delete (T.pack key) ms) bs--text :: String -> B.Inlines-text = B.text . T.pack--str :: String -> B.Inlines-str = B.str . T.pack--codeWith :: Attr -> String -> B.Inlines-codeWith a = B.codeWith (fromLegacyAttr a) . T.pack--code :: String -> B.Inlines-code = B.code . T.pack--math :: String -> B.Inlines-math = B.math . T.pack--displayMath :: String -> B.Inlines-displayMath = B.displayMath . T.pack--rawInline :: String -> String -> B.Inlines-rawInline s = B.rawInline (T.pack s) . T.pack--link :: String -> String -> B.Inlines -> B.Inlines-link s = B.link (T.pack s) . T.pack--linkWith :: Attr -> String -> String -> B.Inlines -> B.Inlines-linkWith a s = B.linkWith (fromLegacyAttr a) (T.pack s) . T.pack--image :: String -> String -> B.Inlines -> B.Inlines-image s = B.image (T.pack s) . T.pack--imageWith :: Attr -> String -> String -> B.Inlines -> B.Inlines-imageWith a s = B.imageWith (fromLegacyAttr a) (T.pack s) . T.pack--spanWith :: Attr -> B.Inlines -> B.Inlines-spanWith = B.spanWith . fromLegacyAttr--codeBlockWith :: Attr -> String -> B.Blocks-codeBlockWith a = B.codeBlockWith (fromLegacyAttr a) . T.pack--codeBlock :: String -> B.Blocks-codeBlock = B.codeBlock . T.pack--rawBlock :: String -> String -> B.Blocks-rawBlock s = B.rawBlock (T.pack s) . T.pack--headerWith :: Attr -> Int -> B.Inlines -> B.Blocks-headerWith = B.headerWith . fromLegacyAttr--divWith :: Attr -> B.Blocks -> B.Blocks-divWith = B.divWith . fromLegacyAttr
− Text/Pandoc/Legacy/Definition.hs
@@ -1,208 +0,0 @@-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}--module Text.Pandoc.Legacy.Definition- ( D.Pandoc(..)- , D.Meta- , pattern Meta- , unMeta- , D.MetaValue ( D.MetaList- , D.MetaBool- , D.MetaInlines- , D.MetaBlocks- )- , pattern MetaMap- , pattern MetaString- , D.nullMeta- , D.isNullMeta- , lookupMeta- , D.docTitle- , D.docAuthors- , D.docDate- , D.Block ( D.Plain- , D.Para- , D.LineBlock- , D.BlockQuote- , D.OrderedList- , D.BulletList- , D.DefinitionList- , D.HorizontalRule- , D.Table- , D.Null- )- , pattern CodeBlock- , pattern RawBlock- , pattern Header- , pattern Div- , D.Inline ( D.Emph- , D.Strong- , D.Strikeout- , D.Superscript- , D.Subscript- , D.SmallCaps- , D.Quoted- , D.Cite- , D.Space- , D.SoftBreak- , D.LineBreak- , D.Note- )- , pattern Str- , pattern Code- , pattern Math- , pattern RawInline- , pattern Link- , pattern Image- , pattern Span- , D.Alignment(..)- , D.ListAttributes- , D.ListNumberStyle(..)- , D.ListNumberDelim(..)- , D.Format- , pattern Format- , Attr- , nullAttr- , D.TableCell- , D.QuoteType(..)- , Target- , D.MathType(..)- , D.Citation- , pattern Citation- , citationId- , citationPrefix- , citationSuffix- , citationMode- , citationNoteNum- , citationHash- , D.CitationMode(..)- , D.pandocTypesVersion- ) where--import qualified Text.Pandoc.Definition as D-import qualified Data.Map as M-import qualified Data.Text as T--unpack2 :: (T.Text, T.Text) -> (String, String)-unpack2 (x, y) = (T.unpack x, T.unpack y)--pack2 :: (String, String) -> (T.Text, T.Text)-pack2 (x, y) = (T.pack x, T.pack y)--toLegacyMap :: M.Map T.Text a -> M.Map String a-toLegacyMap = M.mapKeys T.unpack--fromLegacyMap :: M.Map String a -> M.Map T.Text a-fromLegacyMap = M.mapKeys T.pack--toLegacyAttr :: D.Attr -> Attr-toLegacyAttr (a, b, c) = (T.unpack a, map T.unpack b, map unpack2 c)--fromLegacyAttr :: Attr -> D.Attr-fromLegacyAttr (a, b, c) = (T.pack a, map T.pack b, map pack2 c)--pattern Meta :: M.Map String D.MetaValue -> D.Meta-pattern Meta {unMeta} <- D.Meta (toLegacyMap -> unMeta)- where- Meta = D.Meta . fromLegacyMap--pattern MetaMap :: M.Map String D.MetaValue -> D.MetaValue-pattern MetaMap x <- D.MetaMap (toLegacyMap -> x)- where- MetaMap = D.MetaMap . fromLegacyMap--pattern MetaString :: String -> D.MetaValue-pattern MetaString x <- D.MetaString (T.unpack -> x)- where- MetaString = D.MetaString . T.pack--lookupMeta :: String -> D.Meta -> Maybe D.MetaValue-lookupMeta = D.lookupMeta . T.pack--pattern CodeBlock :: Attr -> String -> D.Block-pattern CodeBlock a s <- D.CodeBlock (toLegacyAttr -> a) (T.unpack -> s)- where- CodeBlock a = D.CodeBlock (fromLegacyAttr a) . T.pack--pattern RawBlock :: D.Format -> String -> D.Block-pattern RawBlock f s <- D.RawBlock f (T.unpack -> s)- where- RawBlock f = D.RawBlock f . T.pack--pattern Header :: Int -> Attr -> [D.Inline] -> D.Block-pattern Header n a i <- D.Header n (toLegacyAttr -> a) i- where- Header n = D.Header n . fromLegacyAttr--pattern Div :: Attr -> [D.Block] -> D.Block-pattern Div a b <- D.Div (toLegacyAttr -> a) b- where- Div = D.Div . fromLegacyAttr--pattern Str :: String -> D.Inline-pattern Str s <- D.Str (T.unpack -> s)- where- Str = D.Str . T.pack--pattern Code :: Attr -> String -> D.Inline-pattern Code a s <- D.Code (toLegacyAttr -> a) (T.unpack -> s)- where- Code a = D.Code (fromLegacyAttr a) . T.pack--pattern Math :: D.MathType -> String -> D.Inline-pattern Math m s <- D.Math m (T.unpack -> s)- where- Math m = D.Math m . T.pack--pattern RawInline :: D.Format -> String -> D.Inline-pattern RawInline f s <- D.RawInline f (T.unpack -> s)- where- RawInline f = D.RawInline f . T.pack--pattern Link :: Attr -> [D.Inline] -> Target -> D.Inline-pattern Link a i t <- D.Link (toLegacyAttr -> a) i (unpack2 -> t)- where- Link a i = D.Link (fromLegacyAttr a) i . pack2--pattern Image :: Attr -> [D.Inline] -> Target -> D.Inline-pattern Image a i t <- D.Image (toLegacyAttr -> a) i (unpack2 -> t)- where- Image a i = D.Image (fromLegacyAttr a) i . pack2--pattern Span :: Attr -> [D.Inline] -> D.Inline-pattern Span a i <- D.Span (toLegacyAttr -> a) i- where- Span = D.Span . fromLegacyAttr--pattern Format :: String -> D.Format-pattern Format x <- D.Format (T.unpack -> x)- where- Format x = D.Format $ T.pack x--type Attr = (String, [String], [(String, String)])--nullAttr :: Attr-nullAttr = ("", [], [])--type Target = (String, String)--pattern Citation- :: String- -> [D.Inline]- -> [D.Inline]- -> D.CitationMode- -> Int- -> Int- -> D.Citation-pattern Citation- { citationId- , citationPrefix- , citationSuffix- , citationMode- , citationNoteNum- , citationHash } <- D.Citation (T.unpack -> citationId)- citationPrefix- citationSuffix- citationMode- citationNoteNum- citationHash- where- Citation = D.Citation . T.pack
Text/Pandoc/Walk.hs view
@@ -76,12 +76,12 @@ 'query' can be used, for example, to compile a list of URLs linked to in a document: -> extractURL :: Inline -> [String]+> extractURL :: Inline -> [Text] > extractURL (Link _ _ (u,_)) = [u] > extractURL (Image _ _ (u,_)) = [u] > extractURL _ = [] >-> extractURLs :: Pandoc -> [String]+> extractURLs :: Pandoc -> [Text] > extractURLs = query extractURL -} @@ -89,11 +89,23 @@ module Text.Pandoc.Walk ( Walkable(..) , queryBlock+ , queryCaption+ , queryRow+ , queryTableHead+ , queryTableBody+ , queryTableFoot+ , queryCell , queryCitation , queryInline , queryMetaValue , queryPandoc , walkBlockM+ , walkCaptionM+ , walkRowM+ , walkTableHeadM+ , walkTableBodyM+ , walkTableFootM+ , walkCellM , walkCitationM , walkInlineM , walkMetaValueM@@ -244,6 +256,120 @@ query = queryMetaValue --+-- Walk Row+--+instance Walkable Inline Row where+ walkM = walkRowM+ query = queryRow++instance Walkable [Inline] Row where+ walkM = walkRowM+ query = queryRow++instance Walkable Block Row where+ walkM = walkRowM+ query = queryRow++instance Walkable [Block] Row where+ walkM = walkRowM+ query = queryRow++--+-- Walk TableHead+--+instance Walkable Inline TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++instance Walkable [Inline] TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++instance Walkable Block TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++instance Walkable [Block] TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++--+-- Walk TableBody+--+instance Walkable Inline TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++instance Walkable [Inline] TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++instance Walkable Block TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++instance Walkable [Block] TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++--+-- Walk TableFoot+--+instance Walkable Inline TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++instance Walkable [Inline] TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++instance Walkable Block TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++instance Walkable [Block] TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++--+-- Walk Caption+--+instance Walkable Inline Caption where+ walkM = walkCaptionM+ query = queryCaption++instance Walkable [Inline] Caption where+ walkM = walkCaptionM+ query = queryCaption++instance Walkable Block Caption where+ walkM = walkCaptionM+ query = queryCaption++instance Walkable [Block] Caption where+ walkM = walkCaptionM+ query = queryCaption++--+-- Walk Cell+--+instance Walkable Inline Cell where+ walkM = walkCellM+ query = queryCell++instance Walkable [Inline] Cell where+ walkM = walkCellM+ query = queryCell++instance Walkable Block Cell where+ walkM = walkCellM+ query = queryCell++instance Walkable [Block] Cell where+ walkM = walkCellM+ query = queryCell++-- -- Walk Citation -- instance Walkable Inline Citation where@@ -272,6 +398,7 @@ => (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@@ -297,6 +424,7 @@ => (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@@ -321,8 +449,9 @@ -- When walking a block with this function, only the contents of the traversed -- block element may change. The element itself, i.e. its constructor, its @'Attr'@, -- and its raw text value, will remain unchanged.-walkBlockM :: (Walkable a [Block], Walkable a [Inline], Monad m,- Applicative m, Functor m)+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@@ -337,15 +466,18 @@ walkBlockM _ x@RawBlock {} = return x walkBlockM _ HorizontalRule = return HorizontalRule walkBlockM _ Null = return Null-walkBlockM f (Table capt as ws hs rs) = do capt' <- walkM f capt- hs' <- walkM f hs- rs' <- walkM f rs- return $ Table capt' as ws hs' rs'+walkBlockM 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' -- | Perform a query on elements nested below a @'Block'@ element by -- querying all directly nested lists of @Inline@s or @Block@s.-queryBlock :: (Walkable a Citation, Walkable a [Block],- Walkable a [Inline], Monoid c)+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@@ -358,7 +490,11 @@ queryBlock f (DefinitionList xs) = query f xs queryBlock f (Header _ _ xs) = query f xs queryBlock _ HorizontalRule = mempty-queryBlock f (Table capt _ _ hs rs) = query f capt <> query f hs <> query f rs+queryBlock 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 @@ -407,6 +543,74 @@ queryCitation :: (Walkable a [Inline], Monoid c) => (a -> c) -> Citation -> c queryCitation f (Citation _ pref suff _ _ _) = query f pref <> query f suff++-- | Helper method to walk the elements nested below @'Row'@ nodes. The+-- @'Attr'@ component is not changed by this operation.+walkRowM :: (Walkable a Cell, Monad m)+ => (a -> m a) -> Row -> m Row+walkRowM f (Row attr bd) = Row attr <$> walkM f bd++-- | Query the elements below a 'Row' element.+queryRow :: (Walkable a Cell, Monoid c)+ => (a -> c) -> Row -> c+queryRow f (Row _ bd) = query f bd++-- | Helper method to walk the elements nested below @'TableHead'@ nodes. The+-- @'Attr'@ component is not changed by this operation.+walkTableHeadM :: (Walkable a Row, Monad m)+ => (a -> m a) -> TableHead -> m TableHead+walkTableHeadM f (TableHead attr body) = TableHead attr <$> walkM f body++-- | Query the elements below a 'TableHead' element.+queryTableHead :: (Walkable a Row, Monoid c)+ => (a -> c) -> TableHead -> c+queryTableHead f (TableHead _ body) = query f body++-- | Helper method to walk the elements nested below @'TableBody'@+-- nodes. The @'Attr'@ and @'RowHeadColumns'@ components are not+-- changed by this operation.+walkTableBodyM :: (Walkable a Row, Monad m)+ => (a -> m a) -> TableBody -> m TableBody+walkTableBodyM f (TableBody attr rhc hd bd) = TableBody attr rhc <$> walkM f hd <*> walkM f bd++-- | Query the elements below a 'TableBody' element.+queryTableBody :: (Walkable a Row, Monoid c)+ => (a -> c) -> TableBody -> c+queryTableBody f (TableBody _ _ hd bd) = query f hd <> query f bd++-- | Helper method to walk the elements nested below @'TableFoot'@ nodes. The+-- @'Attr'@ component is not changed by this operation.+walkTableFootM :: (Walkable a Row, Monad m)+ => (a -> m a) -> TableFoot -> m TableFoot+walkTableFootM f (TableFoot attr body) = TableFoot attr <$> walkM f body++-- | Query the elements below a 'TableFoot' element.+queryTableFoot :: (Walkable a Row, Monoid c)+ => (a -> c) -> TableFoot -> c+queryTableFoot f (TableFoot _ body) = query f body++-- | Helper method to walk the elements nested below 'Cell'+-- nodes. Only the @['Block']@ cell content is changed by this+-- operation.+walkCellM :: (Walkable a [Block], Monad m)+ => (a -> m a) -> Cell -> m Cell+walkCellM f (Cell attr ma rs cs content) = Cell attr ma rs cs <$> walkM f content++-- | Query the elements below a 'Cell' element.+queryCell :: (Walkable a [Block], Monoid c)+ => (a -> c) -> Cell -> c+queryCell f (Cell _ _ _ _ content) = query f content++-- | Helper method to walk the elements nested below 'Caption'+-- nodes.+walkCaptionM :: (Walkable a [Block], Walkable a [Inline], Monad m, Walkable a ShortCaption)+ => (a -> m a) -> Caption -> m Caption+walkCaptionM f (Caption mshort body) = Caption <$> walkM f mshort <*> walkM f body++-- | Query the elements below a 'Cell' element.+queryCaption :: (Walkable a [Block], Walkable a [Inline], Walkable a ShortCaption, Monoid c)+ => (a -> c) -> Caption -> c+queryCaption f (Caption mshort body) = query f mshort <> query f body -- | Helper method to walk the components of a Pandoc element. walkPandocM :: (Walkable a Meta, Walkable a [Block], Monad m,
benchmark/bench.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} import Criterion.Main (bench, defaultMain, nf)-import Text.Pandoc.Definition (Pandoc, Inline (Str)) import Text.Pandoc.Walk (walk) import Text.Pandoc.Builder import qualified Data.Text as T
changelog view
@@ -1,3 +1,41 @@+[1.21]++ * Add Underline constructor (#68, Vaibhav Sagar).++ * Improve table types to allow col, rowspans and more (#65, Christian+ Despres). The additions include modification of the Block type, some+ newtypes related to tables, and changes to the table builders. The table+ builder is now aware of the new Table constructor, and normalizes the+ input table appropriately, so that when laid onto a grid the resulting+ table has no empty spaces, overlapping cells, or cells that extend beyond+ their section boundary.++ Three properties of normalization are checked:++ - Normalization is idempotent.+ - Each row of a normalized table is an initial segment of the+ corresponding row in the unnormalized table, modulo changed cell+ dimensions, dropped cells, and padding with empty cells. This is only+ checked for the first row of the TableBody, however, due to row head+ difficulties.+ - The sum of the cell lengths in the first row of every+ normalized table section is always equal to the total table width.++ `simpleTable` has been changed so that a null header list becomes a+ TableHead with a null body, not a TableHead with a single empty row.++ * Bump QuickCheck upper bound.++ * Change lower bound for QuickCheck to 2.10 (needed for `liftShrink2`).++ * Small code quality improvements (Joseph C. Sible, #69).++ * Allow aeson 1.5 (#72, Felix Yan).++ * Fixed documentation typo (Merlin Göttlinger).++ * Add COMPLETE pragmas to the pattern definitions (Christian Despres).+ [1.20] * Change all uses of String in type definitions to strict Text
pandoc-types.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.0 Name: pandoc-types-Version: 1.20+version: 1.21 Synopsis: Types for representing a structured document Description: @Text.Pandoc.Definition@ defines the 'Pandoc' data structure, which is used by pandoc to represent@@ -31,9 +32,8 @@ Copyright: (c) 2006-2019 John MacFarlane Category: Text Build-type: Simple-Cabal-version: >=1.8-Tested-With: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.2,- GHC == 8.6.5+Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2,+ GHC == 8.6.5, GHC == 8.8.1 Extra-Source-Files: changelog Source-repository head type: git@@ -46,9 +46,8 @@ Text.Pandoc.Builder Text.Pandoc.JSON Text.Pandoc.Arbitrary- Text.Pandoc.Legacy.Builder- Text.Pandoc.Legacy.Definition Other-modules: Paths_pandoc_types+ Autogen-modules: Paths_pandoc_types Build-depends: base >= 4.5 && < 5, containers >= 0.3, text,@@ -56,12 +55,13 @@ syb >= 0.1 && < 0.8, ghc-prim >= 0.2, bytestring >= 0.9 && < 0.11,- aeson >= 0.6.2 && < 1.5,+ aeson >= 0.6.2 && < 1.6, transformers >= 0.2 && < 0.6,- QuickCheck >= 2.4 && < 2.14+ QuickCheck >= 2.10 && < 2.15 if !impl(ghc >= 8.0) Build-depends: semigroups == 0.18.* ghc-options: -Wall+ default-language: Haskell2010 test-suite test-pandoc-types type: exitcode-stdio-1.0@@ -70,17 +70,18 @@ build-depends: base, pandoc-types, syb,- aeson >= 0.6.2 && < 1.5,+ aeson >= 0.6.2 && < 1.6, containers >= 0.3, text, bytestring >= 0.9 && < 0.11, test-framework >= 0.3 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2.9 && < 0.4,- QuickCheck >= 2.4 && < 2.14,+ QuickCheck >= 2.4 && < 2.15, HUnit >= 1.2 && < 1.7, string-qq >= 0.0.2 && < 0.1 ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2+ default-language: Haskell2010 benchmark benchmark-pandoc-types type: exitcode-stdio-1.0@@ -91,3 +92,4 @@ text, criterion >= 1.0 && < 1.6 ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -O2+ default-language: Haskell2010
test/test-pandoc-types.hs view
@@ -3,7 +3,9 @@ import Text.Pandoc.Arbitrary () import Text.Pandoc.Definition import Text.Pandoc.Walk-import Text.Pandoc.Builder (singleton, plain, text, simpleTable)+import Text.Pandoc.Builder (singleton, plain, text, simpleTable, table, emptyCell,+ normalizeTableHead, normalizeTableBody, normalizeTableFoot,+ emptyCaption) import Data.Generics import Data.List (tails) import Test.HUnit (Assertion, assertEqual, assertFailure)@@ -11,6 +13,7 @@ import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit (testCase)+import Test.QuickCheck (forAll, choose, Property, Arbitrary, Testable) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T@@ -170,6 +173,11 @@ , [s|{"t":"Emph","c":[{"t":"Str","c":"Hello"}]}|] ) +t_underline :: (Inline, ByteString)+t_underline = ( Underline [Str "Hello"]+ , [s|{"t":"Underline","c":[{"t":"Str","c":"Hello"}]}|]+ )+ t_strong :: (Inline, ByteString) t_strong = ( Strong [Str "Hello"] , [s|{"t":"Strong","c":[{"t":"Str","c":"Hello"}]}|]@@ -317,40 +325,69 @@ ) t_table :: (Block, ByteString)-t_table = ( Table- [Str "Demonstration"- ,Space- ,Str "of"- ,Space- ,Str "simple"- ,Space- ,Str "table"- ,Space- ,Str "syntax."]- [AlignRight- ,AlignLeft- ,AlignCenter- ,AlignDefault]- [0.0,0.0,0.0,0.0]- [[Plain [Str "Right"]]- ,[Plain [Str "Left"]]- ,[Plain [Str "Center"]]- ,[Plain [Str "Default"]]]- [[[Plain [Str "12"]]- ,[Plain [Str "12"]]- ,[Plain [Str "12"]]- ,[Plain [Str "12"]]]- ,[[Plain [Str "123"]]- ,[Plain [Str "123"]]- ,[Plain [Str "123"]]- ,[Plain [Str "123"]]]- ,[[Plain [Str "1"]]- ,[Plain [Str "1"]]- ,[Plain [Str "1"]]- ,[Plain [Str "1"]]]]- ,- [s|{"t":"Table","c":[[{"t":"Str","c":"Demonstration"},{"t":"Space"},{"t":"Str","c":"of"},{"t":"Space"},{"t":"Str","c":"simple"},{"t":"Space"},{"t":"Str","c":"table"},{"t":"Space"},{"t":"Str","c":"syntax."}],[{"t":"AlignRight"},{"t":"AlignLeft"},{"t":"AlignCenter"},{"t":"AlignDefault"}],[0,0,0,0],[[{"t":"Plain","c":[{"t":"Str","c":"Right"}]}],[{"t":"Plain","c":[{"t":"Str","c":"Left"}]}],[{"t":"Plain","c":[{"t":"Str","c":"Center"}]}],[{"t":"Plain","c":[{"t":"Str","c":"Default"}]}]],[[[{"t":"Plain","c":[{"t":"Str","c":"12"}]}],[{"t":"Plain","c":[{"t":"Str","c":"12"}]}],[{"t":"Plain","c":[{"t":"Str","c":"12"}]}],[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[[{"t":"Plain","c":[{"t":"Str","c":"123"}]}],[{"t":"Plain","c":[{"t":"Str","c":"123"}]}],[{"t":"Plain","c":[{"t":"Str","c":"123"}]}],[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[[{"t":"Plain","c":[{"t":"Str","c":"1"}]}],[{"t":"Plain","c":[{"t":"Str","c":"1"}]}],[{"t":"Plain","c":[{"t":"Str","c":"1"}]}],[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]]]}|]+t_table = ( Table+ ("id", ["kls"], [("k1", "v1"), ("k2", "v2")])+ (Caption+ (Just [Str "short"])+ [Para [Str "Demonstration"+ ,Space+ ,Str "of"+ ,Space+ ,Str "simple"+ ,Space+ ,Str "table"+ ,Space+ ,Str "syntax."]])+ [(AlignDefault,ColWidthDefault)+ ,(AlignRight,ColWidthDefault)+ ,(AlignLeft,ColWidthDefault)+ ,(AlignCenter,ColWidthDefault)+ ,(AlignDefault,ColWidthDefault)]+ (TableHead ("idh", ["klsh"], [("k1h", "v1h"), ("k2h", "v2h")])+ [tRow+ [tCell [Str "Head"]+ ,tCell [Str "Right"]+ ,tCell [Str "Left"]+ ,tCell [Str "Center"]+ ,tCell [Str "Default"]]])+ [TableBody ("idb", ["klsb"], [("k1b", "v1b"), ("k2b", "v2b")]) 1+ [tRow+ [tCell [Str "ihead12"]+ ,tCell [Str "i12"]+ ,tCell [Str "i12"]+ ,tCell [Str "i12"]+ ,tCell [Str "i12"]]]+ [tRow+ [tCell [Str "head12"]+ ,tCell' [Str "12"]+ ,tCell [Str "12"]+ ,tCell' [Str "12"]+ ,tCell [Str "12"]]+ ,tRow+ [tCell [Str "head123"]+ ,tCell [Str "123"]+ ,tCell [Str "123"]+ ,tCell [Str "123"]+ ,tCell [Str "123"]]+ ,tRow+ [tCell [Str "head1"]+ ,tCell [Str "1"]+ ,tCell [Str "1"]+ ,tCell [Str "1"]+ ,tCell [Str "1"]]]]+ (TableFoot ("idf", ["klsf"], [("k1f", "v1f"), ("k2f", "v2f")])+ [tRow+ [tCell [Str "foot"]+ ,tCell [Str "footright"]+ ,tCell [Str "footleft"]+ ,tCell [Str "footcenter"]+ ,tCell [Str "footdefault"]]])+ ,[s|{"t":"Table","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"Caption","c":[[{"t":"Str","c":"short"}],[{"t":"Para","c":[{"t":"Str","c":"Demonstration"},{"t":"Space"},{"t":"Str","c":"of"},{"t":"Space"},{"t":"Str","c":"simple"},{"t":"Space"},{"t":"Str","c":"table"},{"t":"Space"},{"t":"Str","c":"syntax."}]}]]},[[{"t":"AlignDefault"},{"t":"ColWidthDefault"}],[{"t":"AlignRight"},{"t":"ColWidthDefault"}],[{"t":"AlignLeft"},{"t":"ColWidthDefault"}],[{"t":"AlignCenter"},{"t":"ColWidthDefault"}],[{"t":"AlignDefault"},{"t":"ColWidthDefault"}]],{"t":"TableHead","c":[["idh",["klsh"],[["k1h","v1h"],["k2h","v2h"]]],[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Head"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Right"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Left"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Center"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Default"}]}]]}]]}]]},[{"t":"TableBody","c":[["idb",["klsb"],[["k1b","v1b"],["k2b","v2b"]]],{"t":"RowHeadColumns","c":1},[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"ihead12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]}]]}],[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"head12"}]}]]},{"t":"Cell","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]},{"t":"Cell","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]}]]},{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"head123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]}]]},{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"head1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]}]]}]]}],{"t":"TableFoot","c":[["idf",["klsf"],[["k1f","v1f"],["k2f","v2f"]]],[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"foot"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"footright"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"footleft"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"footcenter"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"footdefault"}]}]]}]]}]]}]}|] )+ where+ tCell i = Cell ("a", ["b"], [("c", "d"), ("e", "f")]) AlignDefault 1 1 [Plain i]+ tCell' i = Cell ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) AlignDefault 1 1 [Plain i]+ tRow = Row ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) t_div :: (Block, ByteString) t_div = ( Div ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) [Para [Str "Hello"]]@@ -363,6 +400,7 @@ -- headers and rows are padded to a consistent number of -- cells in order to avoid syntax errors after conversion, see -- jgm/pandoc#4059.+-- This may change as the table representation changes. t_tableSan :: Test t_tableSan = testCase "table sanitisation" assertion where assertion = assertEqual err expected generated@@ -371,15 +409,190 @@ [plain (text "foo"), plain (text "bar")] [[mempty] ,[]]+ tCell i = Cell nullAttr AlignDefault 1 1 [Plain [Str i]]+ emptyRow = Row nullAttr $ replicate 2 emptyCell expected = singleton (Table- []- [AlignDefault, AlignDefault]- [0.0, 0.0]- [[Plain [Str "foo"]],- [Plain [Str "bar"]]]- [[[], []], [[], []]])+ nullAttr+ (Caption Nothing [])+ [(AlignDefault,ColWidthDefault)+ ,(AlignDefault,ColWidthDefault)]+ (TableHead nullAttr+ [Row nullAttr+ [tCell "foo"+ ,tCell "bar"]])+ [TableBody nullAttr 0+ []+ [emptyRow+ ,emptyRow]]+ (TableFoot nullAttr+ [])) +withWidth :: Testable prop => (Int -> prop) -> Property+withWidth = forAll $ choose (2 :: Int, 16) +widthNormIsIdempotent :: (Arbitrary a, Show a, Eq a)+ => (Int -> a -> a) -> Property+widthNormIsIdempotent f = withWidth $+ \n a -> let a' = f n a in f n a' == a'++p_tableNormHeadIdempotent :: Property+p_tableNormHeadIdempotent = widthNormIsIdempotent normalizeTableHead++p_tableNormBodyIdempotent :: Property+p_tableNormBodyIdempotent = widthNormIsIdempotent normalizeTableBody++p_tableNormFootIdempotent :: Property+p_tableNormFootIdempotent = widthNormIsIdempotent normalizeTableFoot++cellSubset :: Cell -> Cell -> Bool+cellSubset (Cell attr1 align1 rs1 cs1 body1) (Cell attr2 align2 rs2 cs2 body2)+ = and [ attr1 == attr2+ , align1 == align2+ , dimValid rs1 rs2+ , dimValid cs1 cs2+ , body1 == body2 ]+ where+ dimValid x y = (y < 1 && x == 1) || (x >= 1 && x <= y)++-- True when the first list is an initial segment of the second,+-- modulo cell subsetting and the appending of padding cells onto the+-- second.+cellsSubsetPad :: [Cell] -> [Cell] -> Bool+cellsSubsetPad (x:xs) (y:ys) = cellSubset x y && cellsSubsetPad xs ys+cellsSubsetPad xs _ = all isPadCell xs+ where+ isPadCell = (== emptyCell)++-- Only valid for the TableHead and TableFoot. See also+-- p_tableNormBodyIsSubset.+rowSubset :: Row -> Row -> Bool+rowSubset (Row a1 x1) (Row a2 x2) = a1 == a2 && cellsSubsetPad x1 x2++normIsSubset :: (Arbitrary a, Show a, Eq a)+ => (Int -> a -> a)+ -> (a -> [Row])+ -> Property+normIsSubset f proj = withWidth $+ \n a -> let a' = f n a in proj a' `rowsSubset` proj a+ where+ rowsSubset (x:xs) (y:ys) = rowSubset x y && rowsSubset xs ys+ rowsSubset [] _ = True+ rowsSubset (_:_) [] = False++p_tableNormHeadIsSubset :: Property+p_tableNormHeadIsSubset = normIsSubset normalizeTableHead thproj+ where+ thproj (TableHead _ r) = r++-- Checking that each row is a subset of its unnormalized version is a+-- little onerous in the TableBody (because of the row head/row body+-- distinction), so we settle for testing it only for the first row.+p_tableNormBodyIsSubset :: Property+p_tableNormBodyIsSubset = withWidth $+ \n tb -> checkBody n (normalizeTableBody n tb) tb+ where+ cellLength (Cell _ _ _ (ColSpan w) _) = w+ cellLengths = sum . map cellLength+ gatherLen n = gatherLen' n 0+ gatherLen' n count (c:cs) | count < n+ = let (beg, end) = gatherLen' n (count + cellLength c) cs+ in (c : beg, end)+ gatherLen' _ _ cs = ([], cs)+ -- Gather as much of the head as we can from the new and old rows,+ -- then make sure the dimensions line up and the subsetting is+ -- correct.+ checkRow n rhc (Row _ r') (Row _ r)+ = let (rhead', rbody') = gatherLen rhc r'+ (rhead, rbody) = gatherLen rhc r+ in and [ cellLengths rhead' == rhc+ , rhc + cellLengths rbody' == n+ , cellsSubsetPad rhead' rhead+ , cellsSubsetPad rbody' rbody ]+ checkRows n rhc (r':_) (r:_) = checkRow n rhc r' r+ checkRows _ _ [] [] = True+ checkRows _ _ _ _ = False+ checkBody n (TableBody _ (RowHeadColumns rhc) th' tb') (TableBody _ _ th tb)+ = checkRows n rhc th' th && checkRows n rhc tb' tb++p_tableNormFootIsSubset :: Property+p_tableNormFootIsSubset = normIsSubset normalizeTableFoot tfproj+ where+ tfproj (TableFoot _ r) = r++-- True when the first row in a section (table head, table foot,+-- intermediate header, body of table body) has the correct+-- width. Only with the first row is it easy to check.+firstRowCorrectWidth :: Int -> [Row] -> [Row] -> Bool+firstRowCorrectWidth n (Row _ cs:_) (_:_) = n == sum (map cellLength cs)+ where cellLength (Cell _ _ _ (ColSpan w) _) = w+firstRowCorrectWidth _ [] [] = True+firstRowCorrectWidth _ _ _ = False++testRowCorrectWidth :: (Arbitrary a, Show a, Eq a)+ => (Int -> a -> a)+ -> (a -> [Row])+ -> Property+testRowCorrectWidth f proj = withWidth $+ \n a -> let a' = f n a in firstRowCorrectWidth n (proj a') (proj a)++p_tableNormHeadRowWidth :: Property+p_tableNormHeadRowWidth = testRowCorrectWidth normalizeTableHead thproj+ where+ thproj (TableHead _ r) = r++p_tableNormBodyRowWidth :: Property+p_tableNormBodyRowWidth = withWidth $+ \n tb -> compBody n tb $ normalizeTableBody n tb+ where+ compBody n (TableBody _ _ th tb) (TableBody _ _ th' tb')+ = firstRowCorrectWidth n th' th && firstRowCorrectWidth n tb' tb++p_tableNormFootRowWidth :: Property+p_tableNormFootRowWidth = testRowCorrectWidth normalizeTableFoot tfproj+ where+ tfproj (TableFoot _ r) = r++t_tableNormExample :: Test+t_tableNormExample = testCase "table normalization example" assertion+ where+ assertion = assertEqual "normalization error" expected generated+ cl a h w = Cell (a, [], []) AlignDefault h w []+ rws = map $ Row nullAttr+ th = TableHead nullAttr . rws+ tb n x y = TableBody nullAttr n (rws x) (rws y)+ tf = TableFoot nullAttr . rws+ initialHeads =+ [[cl "a" 1 1,cl "b" 3 2]+ ,[cl "c" 2 2 ,cl "d" 1 1]+ ]+ finalHeads =+ [[cl "a" 1 1, cl "b" 2 2]+ ,[cl "c" 1 1]+ ]+ initialTB = tb 1+ [[cl "e" 4 3,cl "f" 4 3]+ ,[]+ ,[emptyCell]+ ]+ [[]+ ,[cl "g" (-7) 0]]+ finalTB = tb 1+ [[cl "e" 3 1,cl "f" 3 2]+ ,[]+ ,[]+ ]+ [[emptyCell,emptyCell,emptyCell]+ ,[cl "g" 1 1,emptyCell,emptyCell]+ ]+ spec = replicate 3 (AlignDefault, ColWidthDefault)+ expected = singleton $ Table nullAttr+ emptyCaption+ spec+ (th finalHeads)+ [finalTB]+ (tf finalHeads)+ generated = table emptyCaption spec (th initialHeads) [initialTB] (tf initialHeads)+ tests :: [Test] tests = [ testGroup "Walk"@@ -422,6 +635,7 @@ , testGroup "Inline" [ testEncodeDecode "Str" t_str , testEncodeDecode "Emph" t_emph+ , testEncodeDecode "Underline" t_underline , testEncodeDecode "Strong" t_strong , testEncodeDecode "Strikeout" t_strikeout , testEncodeDecode "Superscript" t_superscript@@ -455,8 +669,20 @@ , testEncodeDecode "Null" t_null ] ]- ],- t_tableSan+ ]+ , testGroup "Table normalization"+ [ testProperty "p_tableNormHeadIdempotent" p_tableNormHeadIdempotent+ , testProperty "p_tableNormBodyIdempotent" p_tableNormBodyIdempotent+ , testProperty "p_tableNormFootIdempotent" p_tableNormFootIdempotent+ , testProperty "p_tableNormHeadIsSubset" p_tableNormHeadIsSubset+ , testProperty "p_tableNormBodyIsSubset" p_tableNormBodyIsSubset+ , testProperty "p_tableNormFootIsSubset" p_tableNormFootIsSubset+ , testProperty "p_tableNormHeadRowWidth" p_tableNormHeadRowWidth+ , testProperty "p_tableNormBodyRowWidth" p_tableNormBodyRowWidth+ , testProperty "p_tableNormFootRowWidth" p_tableNormFootRowWidth+ ]+ , t_tableSan+ , t_tableNormExample ]