diff options
Diffstat (limited to 'haddock-library')
17 files changed, 594 insertions, 4 deletions
diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs index 3707e0a8..f75ff664 100644 --- a/haddock-library/fixtures/Fixtures.hs +++ b/haddock-library/fixtures/Fixtures.hs @@ -151,3 +151,12 @@ instance ToExpr Picture deriving instance Generic Example instance ToExpr Example + +deriving instance Generic (Table id) +instance ToExpr id => ToExpr (Table id) + +deriving instance Generic (TableRow id) +instance ToExpr id => ToExpr (TableRow id) + +deriving instance Generic (TableCell id) +instance ToExpr id => ToExpr (TableCell id) diff --git a/haddock-library/fixtures/examples/table-simple.input b/haddock-library/fixtures/examples/table-simple.input new file mode 100644 index 00000000..d9c49f87 --- /dev/null +++ b/haddock-library/fixtures/examples/table-simple.input @@ -0,0 +1,7 @@ ++------+--------------+------------------------------------------+ +| code | message | description | ++======+==============+==========================================+ +| 200 | @OK@ | operation successful | ++------+--------------+------------------------------------------+ +| 204 | @No Content@ | operation successful, no body returned | ++------+--------------+------------------------------------------+ diff --git a/haddock-library/fixtures/examples/table-simple.parsed b/haddock-library/fixtures/examples/table-simple.parsed new file mode 100644 index 00000000..b5e62453 --- /dev/null +++ b/haddock-library/fixtures/examples/table-simple.parsed @@ -0,0 +1,52 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " 200 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocAppend + (DocString " ") + (DocAppend + (DocMonospaced (DocString "OK")) + (DocString " ")), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + " operation successful ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " 204 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocAppend + (DocString " ") + (DocAppend + (DocMonospaced (DocString "No Content")) + (DocString " ")), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + " operation successful, no body returned ", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " code ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " message ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + " description ", + tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table1.input b/haddock-library/fixtures/examples/table1.input new file mode 100644 index 00000000..a007020c --- /dev/null +++ b/haddock-library/fixtures/examples/table1.input @@ -0,0 +1,12 @@ ++------------------------+------------+----------+----------+ +| Header row, column 1 | Header 2 | Header 3 | Header 4 | +| (header rows optional) | | | | ++========================+============+==========+==========+ +| body row 1, column 1 | column 2 | column 3 | column 4 | ++------------------------+------------+----------+----------+ +| body row 2 | Cells may span columns. | ++------------------------+------------+---------------------+ +| body row 3 | Cells may | \[ | ++------------------------+ span rows. | f(n) = \sum_{i=1} | +| body row 4 | | \] | ++------------------------+------------+---------------------+ diff --git a/haddock-library/fixtures/examples/table1.parsed b/haddock-library/fixtures/examples/table1.parsed new file mode 100644 index 00000000..2fa58fd8 --- /dev/null +++ b/haddock-library/fixtures/examples/table1.parsed @@ -0,0 +1,81 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 1, column 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 3, + tableCellContents = DocString " Cells may span columns. ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" Cells may \n", + " span rows. \n", + " "]), + tableCellRowspan = 2}, + TableCell + {tableCellColspan = 2, + tableCellContents = DocAppend + (DocString " ") + (DocAppend + (DocMathDisplay + (concat + [" \n", + " f(n) = \\sum_{i=1} \n", + " "])) + (DocString " ")), + tableCellRowspan = 2}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 4 ", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" Header row, column 1 \n", + " (header rows optional) "]), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat [" Header 2 \n", " "]), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat [" Header 3 \n", " "]), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat [" Header 4 \n", " "]), + tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table2.input b/haddock-library/fixtures/examples/table2.input new file mode 100644 index 00000000..aa5d0862 --- /dev/null +++ b/haddock-library/fixtures/examples/table2.input @@ -0,0 +1,7 @@ ++--------------+----------+-----------+-----------+ +| row 1, col 1 | column 2 | column 3 | column 4 | ++--------------+----------+-----------+-----------+ +| row 2 | | ++--------------+----------+-----------+-----------+ +| row 3 | | | | ++--------------+----------+-----------+-----------+ diff --git a/haddock-library/fixtures/examples/table2.parsed b/haddock-library/fixtures/examples/table2.parsed new file mode 100644 index 00000000..e3dbf0b4 --- /dev/null +++ b/haddock-library/fixtures/examples/table2.parsed @@ -0,0 +1,46 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 1, col 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 3, + tableCellContents = DocString " ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}]], + tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table3.input b/haddock-library/fixtures/examples/table3.input new file mode 100644 index 00000000..a6ca84ca --- /dev/null +++ b/haddock-library/fixtures/examples/table3.input @@ -0,0 +1,7 @@ ++--------------+----------+-----------+-----------+ +| row 1, col 1 | column 2 | column 3 | column 4 | ++--------------+----------+-----------+-----------+ +| row 2 | Use the command ``ls | more``. | ++--------------+----------+-----------+-----------+ +| row 3 | | | | ++--------------+----------+-----------+-----------+ diff --git a/haddock-library/fixtures/examples/table3.parsed b/haddock-library/fixtures/examples/table3.parsed new file mode 100644 index 00000000..cabff9cb --- /dev/null +++ b/haddock-library/fixtures/examples/table3.parsed @@ -0,0 +1,50 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 1, col 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 2, + tableCellContents = DocString " Use the command ``ls ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " more``. ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}]], + tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table4.input b/haddock-library/fixtures/examples/table4.input new file mode 100644 index 00000000..2c5611c8 --- /dev/null +++ b/haddock-library/fixtures/examples/table4.input @@ -0,0 +1,17 @@ +Single outer cell: + ++-------------+ +| outer | +| | ++-------+ | +| inner | | ++-------+-----+ + +Broken (only inner cell is rendered): + ++-------+-----+ +| inner | | ++-------+ | +| | +| outer | ++-------------+ diff --git a/haddock-library/fixtures/examples/table4.parsed b/haddock-library/fixtures/examples/table4.parsed new file mode 100644 index 00000000..cfdd6f0f --- /dev/null +++ b/haddock-library/fixtures/examples/table4.parsed @@ -0,0 +1,26 @@ +DocAppend + (DocParagraph (DocString "Single outer cell:")) + (DocAppend + (DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" outer \n", + " \n", + "-------+ \n", + " inner | "]), + tableCellRowspan = 1}]], + tableHeaderRows = []}) + (DocAppend + (DocParagraph (DocString "Broken (only inner cell is rendered):")) + (DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " inner ", + tableCellRowspan = 1}]], + tableHeaderRows = []}))) diff --git a/haddock-library/fixtures/examples/table5.input b/haddock-library/fixtures/examples/table5.input new file mode 100644 index 00000000..7cf26512 --- /dev/null +++ b/haddock-library/fixtures/examples/table5.input @@ -0,0 +1,8 @@ ++--------------+----------+-----------+-----------+ +| row 1, col 1 | column 2 | column 3 | column 4 | ++==============+==========+===========+===========+ +| row 2 | Use the command @ls | more@. | +| | | +| +----------+-----------+-----------+ +| row 3 | | | | ++--------------+----------+-----------+-----------+ diff --git a/haddock-library/fixtures/examples/table5.parsed b/haddock-library/fixtures/examples/table5.parsed new file mode 100644 index 00000000..9a547ad3 --- /dev/null +++ b/haddock-library/fixtures/examples/table5.parsed @@ -0,0 +1,53 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" row 2 \n", + " \n", + " \n", + " row 3 "]), + tableCellRowspan = 2}, + TableCell + {tableCellColspan = 3, + tableCellContents = DocAppend + (DocString " Use the command ") + (DocAppend + (DocMonospaced (DocString "ls | more")) + (DocString + (concat + [". \n", + " "]))), + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 1, col 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}]]} diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 2707a928..62df724b 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -18,12 +18,14 @@ build-type: Simple cabal-version: >= 2.0 extra-source-files: CHANGES.md + library default-language: Haskell2010 build-depends: base >= 4.5 && < 4.12 , bytestring >= 0.9.2.1 && < 0.11 + , containers >= 0.4.2.1 && < 0.6 , transformers >= 0.3.0 && < 0.6 -- internal sub-lib @@ -108,6 +110,7 @@ test-suite spec build-depends: base-compat ^>= 0.9.3 + , containers >= 0.4.2.1 && < 0.6 , transformers >= 0.3.0 && < 0.6 , hspec ^>= 2.4.4 , QuickCheck ^>= 2.10 diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs index 1bf6c084..da8edcd4 100644 --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -30,6 +30,7 @@ markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax markup m (DocProperty p) = markupProperty m p markup m (DocExamples e) = markupExample m e markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) +markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) @@ -59,5 +60,6 @@ idMarkup = Markup { markupMathDisplay = DocMathDisplay, markupProperty = DocProperty, markupExample = DocExamples, - markupHeader = DocHeader + markupHeader = DocHeader, + markupTable = DocTable } diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 4ea87db7..a1349c95 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -24,15 +24,17 @@ import Control.Arrow (first) import Control.Monad import qualified Data.ByteString.Char8 as BS import Data.Char (chr, isAsciiUpper) -import Data.List (stripPrefix, intercalate, unfoldr) -import Data.Maybe (fromMaybe) +import Data.List (stripPrefix, intercalate, unfoldr, elemIndex) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid +import qualified Data.Set as Set import Documentation.Haddock.Doc import Documentation.Haddock.Parser.Monad hiding (take, endOfLine) import Documentation.Haddock.Parser.Util import Documentation.Haddock.Types import Documentation.Haddock.Utf8 import Prelude hiding (takeWhile) +import qualified Prelude as P -- $setup -- >>> :set -XOverloadedStrings @@ -79,6 +81,7 @@ overIdentifier f d = g d g (DocProperty x) = DocProperty x g (DocExamples x) = DocExamples x g (DocHeader (Header l x)) = DocHeader . Header l $ g x + g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b)) parse :: Parser a -> BS.ByteString -> (ParserState, a) parse p = either err id . parseOnly (p <* endOfInput) @@ -251,7 +254,7 @@ markdownImage = fromHyperlink <$> ("!" *> linkParser) -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) -paragraph = examples <|> do +paragraph = examples <|> table <|> do indent <- takeIndent choice [ since @@ -266,6 +269,193 @@ paragraph = examples <|> do , docParagraph <$> textParagraph ] +-- | Provides support for grid tables. +-- +-- Tables are composed by an optional header and body. The header is composed by +-- a single row. The body is composed by a non-empty list of rows. +-- +-- Example table with header: +-- +-- > +----------+----------+ +-- > | /32bit/ | 64bit | +-- > +==========+==========+ +-- > | 0x0000 | @0x0000@ | +-- > +----------+----------+ +-- +-- Algorithms loosely follows ideas in +-- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py +-- +table :: Parser (DocH mod Identifier) +table = do + -- first we parse the first row, which determines the width of the table + firstRow <- parseFirstRow + let len = BS.length firstRow + + -- then we parse all consequtive rows starting and ending with + or |, + -- of the width `len`. + restRows <- many (parseRestRows len) + + -- Now we gathered the table block, the next step is to split the block + -- into cells. + DocTable <$> tableStepTwo len (firstRow : restRows) + where + parseFirstRow :: Parser BS.ByteString + parseFirstRow = do + skipHorizontalSpace + -- upper-left corner is + + c <- char '+' + cs <- many1 (char '-' <|> char '+') + + -- upper right corner is + too + guard (last cs == '+') + + -- trailing space + skipHorizontalSpace + _ <- char '\n' + + return (BS.cons c $ BS.pack cs) + + parseRestRows :: Int -> Parser BS.ByteString + parseRestRows l = do + skipHorizontalSpace + + c <- char '|' <|> char '+' + bs <- scan (l - 2) predicate + c2 <- char '|' <|> char '+' + + -- trailing space + skipHorizontalSpace + _ <- char '\n' + + return (BS.cons c (BS.snoc bs c2)) + where + predicate n c + | n <= 0 = Nothing + | c == '\n' = Nothing + | otherwise = Just (n - 1) + +-- Second step searchs for row of '+' and '=' characters, records it's index +-- and changes to '=' to '-'. +tableStepTwo + :: Int -- ^ width + -> [BS.ByteString] -- ^ rows + -> Parser (Table (DocH mod Identifier)) +tableStepTwo width = go 0 [] where + go _ left [] = tableStepThree width (reverse left) Nothing + go n left (r : rs) + | BS.all (`elem` ['+', '=']) r = + tableStepThree width (reverse left ++ r' : rs) (Just n) + | otherwise = + go (n + 1) (r : left) rs + where + r' = BS.map (\c -> if c == '=' then '-' else c) r + +-- Third step recognises cells in the table area, returning a list of TC, cells. +tableStepThree + :: Int -- ^ width + -> [BS.ByteString] -- ^ rows + -> Maybe Int -- ^ index of header separator + -> Parser (Table (DocH mod Identifier)) +tableStepThree width rs hdrIndex = do + cells <- loop (Set.singleton (0, 0)) + tableStepFour rs hdrIndex cells + where + height = length rs + + loop :: Set.Set (Int, Int) -> Parser [TC] + loop queue = case Set.minView queue of + Nothing -> return [] + Just ((y, x), queue') + | y + 1 >= height || x + 1 >= width -> loop queue' + | otherwise -> case scanRight x y of + Nothing -> loop queue' + Just (x2, y2) -> do + let tc = TC y x y2 x2 + fmap (tc :) $ loop $ queue' `Set.union` Set.fromList + [(y, x2), (y2, x), (y2, x2)] + + -- scan right looking for +, then try scan down + -- + -- do we need to record + saw on the way left and down? + scanRight :: Int -> Int -> Maybe (Int, Int) + scanRight x y = go (x + 1) where + bs = rs !! y + go x' | x' >= width = fail "overflow right " + | BS.index bs x' == '+' = scanDown x y x' <|> go (x' + 1) + | BS.index bs x' == '-' = go (x' + 1) + | otherwise = fail $ "not a border (right) " ++ show (x,y,x') + + -- scan down looking for + + scanDown :: Int -> Int -> Int -> Maybe (Int, Int) + scanDown x y x2 = go (y + 1) where + go y' | y' >= height = fail "overflow down" + | BS.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1) + | BS.index (rs !! y') x2 == '|' = go (y' + 1) + | otherwise = fail $ "not a border (down) " ++ show (x,y,x2,y') + + -- check that at y2 x..x2 characters are '+' or '-' + scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int) + scanLeft x y x2 y2 + | all (\x' -> BS.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2 + | otherwise = fail $ "not a border (left) " ++ show (x,y,x2,y2) + where + bs = rs !! y2 + + -- check that at y2 x..x2 characters are '+' or '-' + scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int) + scanUp x y x2 y2 + | all (\y' -> BS.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2) + | otherwise = fail $ "not a border (up) " ++ show (x,y,x2,y2) + +-- | table cell: top left bottom right +data TC = TC !Int !Int !Int !Int + deriving Show + +tcXS :: TC -> [Int] +tcXS (TC _ x _ x2) = [x, x2] + +tcYS :: TC -> [Int] +tcYS (TC y _ y2 _) = [y, y2] + +-- | Fourth step. Given the locations of cells, forms 'Table' structure. +tableStepFour :: [BS.ByteString] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier)) +tableStepFour rs hdrIndex cells = case hdrIndex of + Nothing -> return $ Table [] rowsDoc + Just i -> case elemIndex i yTabStops of + Nothing -> return $ Table [] rowsDoc + Just i' -> return $ uncurry Table $ splitAt i' rowsDoc + where + xTabStops = sortNub $ concatMap tcXS cells + yTabStops = sortNub $ concatMap tcYS cells + + sortNub :: Ord a => [a] -> [a] + sortNub = Set.toList . Set.fromList + + init' :: [a] -> [a] + init' [] = [] + init' [_] = [] + init' (x : xs) = x : init' xs + + rowsDoc = (fmap . fmap) parseStringBS rows + + rows = map makeRow (init' yTabStops) + where + makeRow y = TableRow $ mapMaybe (makeCell y) cells + makeCell y (TC y' x y2 x2) + | y /= y' = Nothing + | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1)) + where + xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops + yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops + + -- extract cell contents given boundaries + extract :: Int -> Int -> Int -> Int -> BS.ByteString + extract x y x2 y2 = BS.intercalate "\n" + [ BS.take (x2 - x + 1) $ BS.drop x $ rs !! y' + | y' <- [y .. y2] + ] + +-- | Parse \@since annotations. since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty where diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 1e76c631..96653864 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -81,6 +81,21 @@ data Example = Example , exampleResult :: [String] } deriving (Eq, Show) +data TableCell id = TableCell + { tableCellColspan :: Int + , tableCellRowspan :: Int + , tableCellContents :: id + } deriving (Eq, Show, Functor, Foldable, Traversable) + +newtype TableRow id = TableRow + { tableRowCells :: [TableCell id] + } deriving (Eq, Show, Functor, Foldable, Traversable) + +data Table id = Table + { tableHeaderRows :: [TableRow id] + , tableBodyRows :: [TableRow id] + } deriving (Eq, Show, Functor, Foldable, Traversable) + data DocH mod id = DocEmpty | DocAppend (DocH mod id) (DocH mod id) @@ -105,6 +120,7 @@ data DocH mod id | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id)) + | DocTable (Table (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0) @@ -132,6 +148,7 @@ instance Bifunctor DocH where bimap _ _ (DocProperty s) = DocProperty s bimap _ _ (DocExamples examples) = DocExamples examples bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title)) + bimap f g (DocTable (Table header body)) = DocTable (Table (map (fmap (bimap f g)) header) (map (fmap (bimap f g)) body)) #endif #if MIN_VERSION_base(4,10,0) @@ -149,6 +166,7 @@ instance Bifoldable DocH where bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title + bifoldr f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header bifoldr _ _ z _ = z instance Bitraversable DocH where @@ -175,6 +193,7 @@ instance Bitraversable DocH where bitraverse _ _ (DocProperty s) = pure (DocProperty s) bitraverse _ _ (DocExamples examples) = pure (DocExamples examples) bitraverse f g (DocHeader (Header level title)) = (DocHeader . Header level) <$> bitraverse f g title + bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body #endif -- | 'DocMarkupH' is a set of instructions for marking up documentation. @@ -209,4 +228,5 @@ data DocMarkupH mod id a = Markup , markupProperty :: String -> a , markupExample :: [Example] -> a , markupHeader :: Header a -> a + , markupTable :: Table a -> a } |