diff --git a/Text/Pandoc/Arbitrary.hs b/Text/Pandoc/Arbitrary.hs --- a/Text/Pandoc/Arbitrary.hs +++ b/Text/Pandoc/Arbitrary.hs @@ -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 diff --git a/Text/Pandoc/Builder.hs b/Text/Pandoc/Builder.hs --- a/Text/Pandoc/Builder.hs +++ b/Text/Pandoc/Builder.hs @@ -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 diff --git a/Text/Pandoc/Definition.hs b/Text/Pandoc/Definition.hs --- a/Text/Pandoc/Definition.hs +++ b/Text/Pandoc/Definition.hs @@ -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 diff --git a/Text/Pandoc/Legacy/Builder.hs b/Text/Pandoc/Legacy/Builder.hs deleted file mode 100644 --- a/Text/Pandoc/Legacy/Builder.hs +++ /dev/null @@ -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 diff --git a/Text/Pandoc/Legacy/Definition.hs b/Text/Pandoc/Legacy/Definition.hs deleted file mode 100644 --- a/Text/Pandoc/Legacy/Definition.hs +++ /dev/null @@ -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 diff --git a/Text/Pandoc/Walk.hs b/Text/Pandoc/Walk.hs --- a/Text/Pandoc/Walk.hs +++ b/Text/Pandoc/Walk.hs @@ -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, diff --git a/benchmark/bench.hs b/benchmark/bench.hs --- a/benchmark/bench.hs +++ b/benchmark/bench.hs @@ -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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 diff --git a/pandoc-types.cabal b/pandoc-types.cabal --- a/pandoc-types.cabal +++ b/pandoc-types.cabal @@ -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 diff --git a/test/test-pandoc-types.hs b/test/test-pandoc-types.hs --- a/test/test-pandoc-types.hs +++ b/test/test-pandoc-types.hs @@ -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 ]