From 56c0e317093d2e25412cfa7dd10099c1fe729640 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Sun, 17 Dec 2017 11:40:03 +0100 Subject: Treat escaped \] better in definition lists (#717) This fixes #546. --- haddock-library/src/Documentation/Haddock/Parser.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 8dc2a801..dd1044cb 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -338,7 +338,7 @@ definitionList :: BS.ByteString -> Parser (DocH mod Identifier) definitionList indent = DocDefList <$> p where p = do - label <- "[" *> (parseStringBS <$> takeWhile1 (notInClass "]\n")) <* ("]" <* optional ":") + label <- "[" *> (parseStringBS <$> scan False accept) <* ("]" <* optional ":") c <- takeLine (cs, items) <- more indent p let contents = parseString . dropNLs . unlines $ c : cs @@ -346,6 +346,19 @@ definitionList indent = DocDefList <$> p Left x -> [(label, contents `docAppend` x)] Right i -> (label, contents) : i + -- handle '\]' escapes + accept True ']' = Just False + + -- stop on ']' or '\n' + accept _ ']' = Nothing + accept _ '\n' = Nothing + + -- starting an escape sequence + accept _ '\\' = Just True + + -- anything else + accept _ _ = Just False + -- | Drops all trailing newlines. dropNLs :: String -> String dropNLs = reverse . dropWhile (== '\n') . reverse -- cgit v1.2.3 From ce30e3449f723cd1ba28d30455dd500e06397168 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Sun, 17 Dec 2017 11:50:27 +0100 Subject: Remove scanner, takeWhile1_ already takes care of escaping --- haddock-library/src/Documentation/Haddock/Parser.hs | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index dd1044cb..fcd26f83 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -338,7 +338,7 @@ definitionList :: BS.ByteString -> Parser (DocH mod Identifier) definitionList indent = DocDefList <$> p where p = do - label <- "[" *> (parseStringBS <$> scan False accept) <* ("]" <* optional ":") + label <- "[" *> (parseStringBS <$> takeWhile1_ (/= ']')) <* ("]" <* optional ":") c <- takeLine (cs, items) <- more indent p let contents = parseString . dropNLs . unlines $ c : cs @@ -346,19 +346,6 @@ definitionList indent = DocDefList <$> p Left x -> [(label, contents `docAppend` x)] Right i -> (label, contents) : i - -- handle '\]' escapes - accept True ']' = Just False - - -- stop on ']' or '\n' - accept _ ']' = Nothing - accept _ '\n' = Nothing - - -- starting an escape sequence - accept _ '\\' = Just True - - -- anything else - accept _ _ = Just False - -- | Drops all trailing newlines. dropNLs :: String -> String dropNLs = reverse . dropWhile (== '\n') . reverse -- cgit v1.2.3 From 2cdf1413564b49dcdf63b39d6871155c69b53974 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Sun, 17 Dec 2017 11:53:59 +0100 Subject: Take until line feed --- haddock-library/src/Documentation/Haddock/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index fcd26f83..4ea87db7 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -338,7 +338,7 @@ definitionList :: BS.ByteString -> Parser (DocH mod Identifier) definitionList indent = DocDefList <$> p where p = do - label <- "[" *> (parseStringBS <$> takeWhile1_ (/= ']')) <* ("]" <* optional ":") + label <- "[" *> (parseStringBS <$> takeWhile1_ (notInClass "]\n")) <* ("]" <* optional ":") c <- takeLine (cs, items) <- more indent p let contents = parseString . dropNLs . unlines $ c : cs -- cgit v1.2.3 From 088b1993fb6c6ed014a95e93d7c07f68218c7777 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 26 Dec 2017 17:13:14 +0200 Subject: Grid Tables (#718) * Add table examples * Add table types and adopt simple parser Simple parser is done by Giovanni Cappellotto (@potomak) in https://github.com/haskell/haddock/pull/577 It seems to support single fine full tables, so far from full RST-grid tables, but it's good start. Table type support row- and colspans, but obviously parser is lacking. Still TODO: - Latex backend. Should we use multirow package https://ctan.org/pkg/multirow?lang=en? - Hoogle backend: ? * Implement grid-tables * Refactor table parser * Add two ill-examples * Update CHANGES.md * Basic documentation for tables * Fix documentation example --- CHANGES.md | 2 + doc/markup.rst | 20 ++ .../resources/html/Classic.theme/xhaddock.css | 14 ++ .../resources/html/Ocean.std-theme/ocean.css | 15 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 5 +- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 19 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 1 + haddock-api/src/Haddock/InterfaceFile.hs | 32 +++ haddock-api/src/Haddock/Types.hs | 9 + haddock-library/fixtures/Fixtures.hs | 9 + .../fixtures/examples/table-simple.input | 7 + .../fixtures/examples/table-simple.parsed | 52 +++++ haddock-library/fixtures/examples/table1.input | 12 ++ haddock-library/fixtures/examples/table1.parsed | 81 +++++++ haddock-library/fixtures/examples/table2.input | 7 + haddock-library/fixtures/examples/table2.parsed | 46 ++++ haddock-library/fixtures/examples/table3.input | 7 + haddock-library/fixtures/examples/table3.parsed | 50 +++++ haddock-library/fixtures/examples/table4.input | 17 ++ haddock-library/fixtures/examples/table4.parsed | 26 +++ haddock-library/fixtures/examples/table5.input | 8 + haddock-library/fixtures/examples/table5.parsed | 53 +++++ haddock-library/haddock-library.cabal | 3 + .../src/Documentation/Haddock/Markup.hs | 4 +- .../src/Documentation/Haddock/Parser.hs | 196 ++++++++++++++++- haddock-library/src/Documentation/Haddock/Types.hs | 20 ++ html-test/ref/Table.html | 238 +++++++++++++++++++++ html-test/src/Table.hs | 47 ++++ 29 files changed, 996 insertions(+), 7 deletions(-) create mode 100644 haddock-library/fixtures/examples/table-simple.input create mode 100644 haddock-library/fixtures/examples/table-simple.parsed create mode 100644 haddock-library/fixtures/examples/table1.input create mode 100644 haddock-library/fixtures/examples/table1.parsed create mode 100644 haddock-library/fixtures/examples/table2.input create mode 100644 haddock-library/fixtures/examples/table2.parsed create mode 100644 haddock-library/fixtures/examples/table3.input create mode 100644 haddock-library/fixtures/examples/table3.parsed create mode 100644 haddock-library/fixtures/examples/table4.input create mode 100644 haddock-library/fixtures/examples/table4.parsed create mode 100644 haddock-library/fixtures/examples/table5.input create mode 100644 haddock-library/fixtures/examples/table5.parsed create mode 100644 html-test/ref/Table.html create mode 100644 html-test/src/Table.hs (limited to 'haddock-library/src/Documentation') diff --git a/CHANGES.md b/CHANGES.md index b4d69ce4..7127df79 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ * to be released + * Haddock now supports tables in documentation inspired by reSTs grid tables + * A --reexport flag, which can be used to add extra modules to the top-level module tree diff --git a/doc/markup.rst b/doc/markup.rst index d0b9392d..acabaa28 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -1078,6 +1078,26 @@ If the output format supports it, the mathematics will be rendered inside the documentation. For example, the HTML backend will display the mathematics via `MathJax `__. +Grid Tables +~~~~~~~~~~~ + +Inspired by reSTs grid tables Haddock supports a complete table representation via a grid-like "ASCII art". Grid tables are described with a visual grid made up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for horizontal lines (row separators). The equals sign ("=") may be used to separate optional header rows from the table body. The vertical bar ("|") is used for vertical lines (column separators). The plus sign ("+") is used for intersections of horizontal and vertical lines. :: + + -- | This is a grid table: + -- + -- +------------------------+------------+----------+----------+ + -- | 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 | | \] | + -- +------------------------+------------+---------------------+ + Anchors ~~~~~~~ diff --git a/haddock-api/resources/html/Classic.theme/xhaddock.css b/haddock-api/resources/html/Classic.theme/xhaddock.css index 1bf668e9..b8164815 100644 --- a/haddock-api/resources/html/Classic.theme/xhaddock.css +++ b/haddock-api/resources/html/Classic.theme/xhaddock.css @@ -392,6 +392,20 @@ td.rdoc p { } +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} #footer { background-color: #000099; diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 0852dea5..ba6af9ca 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -443,6 +443,21 @@ div#style-menu-holder { margin-top: 0.8em; } +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} + .clearfix:after { clear: both; content: " "; diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f1d8ddb2..fc71d4b5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -328,7 +328,8 @@ markupTag dflags = Markup { markupAName = const $ str "", markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString, - markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h + markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h, + markupTable = \(Table _ _) -> str "TODO: table" } diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d79e0e6c..3ac3b405 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1140,7 +1140,8 @@ parLatexMarkup ppId = Markup { markupAName = \_ _ -> empty, markupProperty = \p _ -> quote $ verb $ text p, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p) + markupHeader = \(Header l h) p -> header l (h p), + markupTable = \(Table h b) p -> table h b p } where header 1 d = text "\\section*" <> braces d @@ -1149,6 +1150,8 @@ parLatexMarkup ppId = Markup { | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d header l _ = error $ "impossible header level in LaTeX generation: " ++ show l + table _ _ _ = text "{TODO: Table}" + fixString Plain s = latexFilter s fixString Verb s = s fixString Mono s = latexMonoFilter s diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index e63667b0..2990e1e4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -73,7 +73,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, markupExample = examplesToHtml, - markupHeader = \(Header l t) -> makeHeader l t + markupHeader = \(Header l t) -> makeHeader l t, + markupTable = \(Table h r) -> makeTable h r } where makeHeader :: Int -> Html -> Html @@ -85,6 +86,22 @@ parHtmlMarkup qual insertAnchors ppId = Markup { makeHeader 6 mkup = h6 mkup makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + makeTable :: [TableRow Html] -> [TableRow Html] -> Html + makeTable hs bs = table (concatHtml (hs' ++ bs')) + where + hs' | null hs = [] + | otherwise = [thead (concatHtml (map (makeTableRow th) hs))] + + bs' = [tbody (concatHtml (map (makeTableRow td) bs))] + + makeTableRow :: (Html -> Html) -> TableRow Html -> Html + makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs)) + + makeTableCell :: (Html -> Html) -> TableCell Html -> Html + makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j') + where + i' = if i == 1 then [] else [ colspan i ] + j' = if j == 1 then [] else [ rowspan j ] examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 75b2f223..311301ee 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -144,6 +144,7 @@ rename dflags gre = rn DocEmpty -> pure (DocEmpty) DocString str -> pure (DocString str) DocHeader (Header l t) -> DocHeader . Header l <$> rn t + DocTable t -> DocTable <$> traverse rn t -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 76bcb4ae..bbd8d04e 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -459,6 +459,32 @@ instance Binary a => Binary (Header a) where t <- get bh return (Header l t) +instance Binary a => Binary (Table a) where + put_ bh (Table h b) = do + put_ bh h + put_ bh b + get bh = do + h <- get bh + b <- get bh + return (Table h b) + +instance Binary a => Binary (TableRow a) where + put_ bh (TableRow cs) = put_ bh cs + get bh = do + cs <- get bh + return (TableRow cs) + +instance Binary a => Binary (TableCell a) where + put_ bh (TableCell i j c) = do + put_ bh i + put_ bh j + put_ bh c + get bh = do + i <- get bh + j <- get bh + c <- get bh + return (TableCell i j c) + instance Binary Meta where put_ bh Meta { _version = v } = put_ bh v get bh = (\v -> Meta { _version = v }) <$> get bh @@ -542,6 +568,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh (DocMathDisplay x) = do putByte bh 22 put_ bh x + put_ bh (DocTable x) = do + putByte bh 23 + put_ bh x get bh = do h <- getByte bh @@ -615,6 +644,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where 22 -> do x <- get bh return (DocMathDisplay x) + 23 -> do + x <- get bh + return (DocTable x) _ -> error "invalid binary data found in the interface file" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b4cdc343..725606b2 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -454,6 +454,7 @@ instance (NFData a, NFData mod) DocProperty a -> a `deepseq` () DocExamples a -> a `deepseq` () DocHeader a -> a `deepseq` () + DocTable a -> a `deepseq` () #if !MIN_VERSION_ghc(8,0,2) -- These were added to GHC itself in 8.0.2 @@ -474,6 +475,14 @@ instance NFData Picture where instance NFData Example where rnf (Example a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (Table id) where + rnf (Table h b) = h `deepseq` b `deepseq` () + +instance NFData id => NFData (TableRow id) where + rnf (TableRow cs) = cs `deepseq` () + +instance NFData id => NFData (TableCell id) where + rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` () exampleToString :: Example -> String exampleToString (Example expression result) = 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 } diff --git a/html-test/ref/Table.html b/html-test/ref/Table.html new file mode 100644 index 00000000..959f18b2 --- /dev/null +++ b/html-test/ref/Table.html @@ -0,0 +1,238 @@ +Table
Safe HaskellSafe

Table

Description

This tests the table markup

Synopsis

Documentation

tableWithHeader :: a -> a #

Table with header.

code message description
200 OK operation successful
204 No Content operation successful, no body returned

tableWithoutHeader :: a -> a #

Table without header.

200 OK operation successful
204 No Content operation successful, no body returned
404 Not Found resource not found

fancyTable :: a -> a #

Fancy table.

Header row, column 1 + (header rows optional) Header 2 + Header 3 + Header 4 +
body row 1, column 1 column 2 column 3 column 4
tableWithHeader Cells may span columns.
body row 3 Cells may + span rows. + \[ + f(n) = \sum_{i=1} + \]
body row 4
\ No newline at end of file diff --git a/html-test/src/Table.hs b/html-test/src/Table.hs new file mode 100644 index 00000000..2cf0c662 --- /dev/null +++ b/html-test/src/Table.hs @@ -0,0 +1,47 @@ +-- | This tests the table markup +module Table + ( tableWithHeader + , tableWithoutHeader + , fancyTable + ) where + +-- | Table with header. +-- +-- +------+--------------+------------------------------------------+ +-- | code | message | description | +-- +======+==============+==========================================+ +-- | 200 | @OK@ | operation successful | +-- +------+--------------+------------------------------------------+ +-- | 204 | @No Content@ | operation successful, no body returned | +-- +------+--------------+------------------------------------------+ +tableWithHeader :: a -> a +tableWithHeader a = a + +-- | Table without header. +-- +-- +------+--------------+------------------------------------------+ +-- | 200 | @OK@ | operation successful | +-- +------+--------------+------------------------------------------+ +-- | 204 | @No Content@ | operation successful, no body returned | +-- +------+--------------+------------------------------------------+ +-- | 404 | @Not Found@ | resource not found | +-- +------+--------------+------------------------------------------+ +tableWithoutHeader :: a -> a +tableWithoutHeader a = a + +-- | Fancy table. +-- +-- +------------------------+------------+----------+----------+ +-- | Header row, column 1 | Header 2 | Header 3 | Header 4 | +-- | (header rows optional) | | | | +-- +========================+============+==========+==========+ +-- | body row 1, column 1 | column 2 | column 3 | column 4 | +-- +------------------------+------------+----------+----------+ +-- | 'tableWithHeader' | Cells may span columns. | +-- +------------------------+------------+---------------------+ +-- | body row 3 | Cells may | \[ | +-- +------------------------+ span rows. | f(n) = \sum_{i=1} | +-- | body row 4 | | \] | +-- +------------------------+------------+---------------------+ +fancyTable :: a -> a +fancyTable x = x -- cgit v1.2.3 From 44b1d87503a62181b4079962632cd61f1e158d79 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 5 Feb 2018 18:14:32 -0800 Subject: Support unicode operators, proper modules Unicode operators are a pretty big thing in Haskell, so supporting linking them seems like it outweighs the cost of the extra machinery to force Attoparsec to look for unicode. Fixes #458. --- haddock-library/haddock-library.cabal | 2 +- .../src/Documentation/Haddock/Parser.hs | 34 ++++----- .../src/Documentation/Haddock/Parser/Monad.hs | 25 ++++++- html-test/ref/Bug458.html | 80 ++++++++++++++++++++++ html-test/src/Bug458.hs | 6 ++ 5 files changed, 122 insertions(+), 25 deletions(-) create mode 100644 html-test/ref/Bug458.html create mode 100644 html-test/src/Bug458.hs (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 3d069f07..d7935747 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -64,13 +64,13 @@ library attoparsec exposed-modules: Data.Attoparsec.ByteString Data.Attoparsec.ByteString.Char8 + Data.Attoparsec.Combinator other-modules: Data.Attoparsec Data.Attoparsec.ByteString.Buffer Data.Attoparsec.ByteString.FastSet Data.Attoparsec.ByteString.Internal - Data.Attoparsec.Combinator Data.Attoparsec.Internal Data.Attoparsec.Internal.Fhthagn Data.Attoparsec.Internal.Types diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index a1349c95..82515ab4 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -23,7 +23,7 @@ import Control.Applicative import Control.Arrow (first) import Control.Monad import qualified Data.ByteString.Char8 as BS -import Data.Char (chr, isAsciiUpper) +import Data.Char (chr, isUpper, isAlpha, isAlphaNum) import Data.List (stripPrefix, intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -35,6 +35,7 @@ import Documentation.Haddock.Types import Documentation.Haddock.Utf8 import Prelude hiding (takeWhile) import qualified Prelude as P +import Text.Read.Lex (isSymbolChar) -- $setup -- >>> :set -XOverloadedStrings @@ -205,20 +206,19 @@ monospace :: Parser (DocH mod Identifier) monospace = DocMonospaced . parseStringBS <$> ("@" *> takeWhile1_ (/= '@') <* "@") --- | Module names: we try our reasonable best to only allow valid --- Haskell module names, with caveat about not matching on technically --- valid unicode symbols. +-- | Module names. +-- +-- Note that we allow '#' and '\' to support anchors (old style anchors are of +-- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) moduleName = DocModule <$> (char '"' *> modid <* char '"') where modid = intercalate "." <$> conid `sepBy1` "." conid = (:) - <$> satisfy isAsciiUpper - -- NOTE: According to Haskell 2010 we should actually only - -- accept {small | large | digit | ' } here. But as we can't - -- match on unicode characters, this is currently not possible. - -- Note that we allow ‘#’ to suport anchors. - <*> (decodeUtf8 <$> takeWhile (notInClass " .&[{}(=*)+]!|@/;,^?\"\n")) + <$> satisfyUnicode (\c -> isAlpha c && isUpper c) + <*> many (satisfyUnicode conChar <|> char '\\' <|> char '#') + + conChar c = isAlphaNum c || c == '_' -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. @@ -760,26 +760,16 @@ autoUrl = mkLink <$> url parseValid :: Parser String parseValid = p some where - idChar = - satisfy (\c -> isAlpha_ascii c - || isDigit c - -- N.B. '-' is placed first otherwise attoparsec thinks - -- it belongs to a character class - || inClass "-_.!#$%&*+/<=>?@\\|~:^" c) + idChar = satisfyUnicode (\c -> isAlphaNum c || isSymbolChar c || c == '_') p p' = do - vs' <- p' $ utf8String "⋆" <|> return <$> idChar - let vs = concat vs' + vs <- p' idChar c <- peekChar' case c of '`' -> return vs '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> p many') <|> return vs _ -> fail "outofvalid" --- | Parses UTF8 strings from ByteString streams. -utf8String :: String -> Parser String -utf8String x = decodeUtf8 <$> string (encodeUtf8 x) - -- | Parses identifiers with help of 'parseValid'. Asks GHC for -- 'String' from the string it deems valid. identifier :: Parser (DocH mod Identifier) diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 3f7d60f8..3430ef8a 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, BangPatterns #-} module Documentation.Haddock.Parser.Monad ( module Documentation.Haddock.Parser.Monad , Attoparsec.isDigit @@ -31,9 +31,10 @@ module Documentation.Haddock.Parser.Monad ( import Control.Applicative import Control.Monad import Data.String -import Data.ByteString (ByteString) +import Data.ByteString (ByteString, length) import qualified Data.ByteString.Lazy as LB import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified Data.Attoparsec.Combinator as Attoparsec import Control.Monad.Trans.State import qualified Control.Monad.Trans.Class as Trans import Data.Word @@ -41,6 +42,7 @@ import Data.Bits import Data.Tuple import Documentation.Haddock.Types (Version) +import Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) newtype ParserState = ParserState { parserStateSince :: Maybe Version @@ -73,6 +75,25 @@ char = lift . Attoparsec.char char8 :: Char -> Parser Word8 char8 = lift . Attoparsec.char8 +-- | Peek a unicode character and return the number of bytes that it took up +peekUnicode :: Parser (Char, Int) +peekUnicode = lift $ Attoparsec.lookAhead $ do + + -- attoparsec's take fails on shorter inputs rather than truncate + bs <- Attoparsec.choice (map Attoparsec.take [4,3,2,1]) + + let !c = head . decodeUtf8 $ bs + !n = Data.ByteString.length . encodeUtf8 $ [c] + pure (c, fromIntegral n) + +-- | Like 'satisfy', but consuming a unicode character +satisfyUnicode :: (Char -> Bool) -> Parser Char +satisfyUnicode predicate = do + (c,n) <- peekUnicode + if predicate c + then Documentation.Haddock.Parser.Monad.take n *> pure c + else fail "satsifyUnicode" + anyChar :: Parser Char anyChar = lift Attoparsec.anyChar diff --git a/html-test/ref/Bug458.html b/html-test/ref/Bug458.html new file mode 100644 index 00000000..aa99e719 --- /dev/null +++ b/html-test/ref/Bug458.html @@ -0,0 +1,80 @@ +Bug458
Safe HaskellSafe

Bug458

Synopsis

Documentation

(⊆) :: () -> () -> () #

See the defn of ⊆.

\ No newline at end of file diff --git a/html-test/src/Bug458.hs b/html-test/src/Bug458.hs new file mode 100644 index 00000000..6a3ac9a4 --- /dev/null +++ b/html-test/src/Bug458.hs @@ -0,0 +1,6 @@ +module Bug458 where + +-- | See the defn of @'⊆'@. +(⊆) :: () -> () -> () +_ ⊆ _ = () + -- cgit v1.2.3 From 785818fe3e7dbb47b6942b896bbf6120e8f95ddb Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 5 Feb 2018 23:02:29 -0800 Subject: Remove bang pattern --- haddock-library/src/Documentation/Haddock/Parser/Monad.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 3430ef8a..ff6101da 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Documentation.Haddock.Parser.Monad ( module Documentation.Haddock.Parser.Monad , Attoparsec.isDigit @@ -82,8 +82,8 @@ peekUnicode = lift $ Attoparsec.lookAhead $ do -- attoparsec's take fails on shorter inputs rather than truncate bs <- Attoparsec.choice (map Attoparsec.take [4,3,2,1]) - let !c = head . decodeUtf8 $ bs - !n = Data.ByteString.length . encodeUtf8 $ [c] + let c = head . decodeUtf8 $ bs + n = Data.ByteString.length . encodeUtf8 $ [c] pure (c, fromIntegral n) -- | Like 'satisfy', but consuming a unicode character -- cgit v1.2.3 From 333aab8827b4a98ed68108751cf930012f79567c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Thu, 8 Mar 2018 10:39:37 +0100 Subject: Restore backward-compat with base-4.5 through base-4.8 --- .../src/Documentation/Haddock/Parser.hs | 29 ++++++++++++++++++++-- haddock-library/src/Documentation/Haddock/Types.hs | 1 + 2 files changed, 28 insertions(+), 2 deletions(-) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 82515ab4..250b7f0d 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Documentation.Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013-2014, @@ -35,11 +36,35 @@ import Documentation.Haddock.Types import Documentation.Haddock.Utf8 import Prelude hiding (takeWhile) import qualified Prelude as P -import Text.Read.Lex (isSymbolChar) + +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory (..), + generalCategory) +#endif -- $setup -- >>> :set -XOverloadedStrings +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> not (c `elem` ("'\"" :: String)) + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif + -- | Identifier string surrounded with opening and closing quotes/backticks. type Identifier = (Char, String, Char) diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 96653864..209f26e8 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -15,6 +15,7 @@ module Documentation.Haddock.Types where #if !MIN_VERSION_base(4,8,0) +import Control.Applicative import Data.Foldable import Data.Traversable #endif -- cgit v1.2.3 From e787b5712157bb0acbb8d886ef793cda5dc1b821 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Wed, 14 Mar 2018 14:21:18 +0100 Subject: Make a proper definition for the parser --- haddock-library/src/Documentation/Haddock/Parser.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 250b7f0d..6cbc3922 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -742,10 +742,12 @@ codeblock = | otherwise = Just $ c == '\n' hyperlink :: Parser (DocH mod a) -hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8 - <$> disallowNewline ("<" *> takeUntil ">") - <|> autoUrl - <|> markdownLink +hyperlink = angleBracketLink <|> markdownLink <|> autoUrl + +angleBracketLink :: Parser (DocH mod a) +angleBracketLink = + DocHyperlink . makeLabeled Hyperlink . decodeUtf8 + <$> disallowNewline ("<" *> takeUntil ">") markdownLink :: Parser (DocH mod a) markdownLink = DocHyperlink <$> linkParser -- cgit v1.2.3 From 978dbc859df09eb991d9ccc0911276cc9655b783 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 26 Mar 2018 23:35:59 -0700 Subject: @since includes package name (#749) * Metadoc stores a package name This means that '@since' annotations can be package aware. * Get the package name the right way This should extract the package name for `@since` annotations the right way. I had to move `modulePackageInfo` around to do this and, in the process, I took the liberty to update it. Since it appears that finding the package name is something that can fail, I added a warning for this case. * Silence warnings * Hide package for local 'since' annotations As discussed, this is still the usual case (and we should avoid being noisy for it). Although this commit is large, it is basically only about threading a 'Maybe Package' from 'Haddock.render' all the way to 'Haddock.Backends.Xhtml.DocMarkup.renderMeta'. * Bump binary interface version * Add a '--since-qual' option This controls when to qualify since annotations with the package they come from. The default is always, but I've left an 'external' variant where only those annotations coming from outside of the current package are qualified. * Make ParserSpec work * Make Fixtures work * Use package name even if package version is not available The @since stuff needs only the package name passed in, so it makes sense to not be forced to pass in a version too. --- haddock-api/src/Haddock.hs | 72 ++++------ haddock-api/src/Haddock/Backends/Xhtml.hs | 110 +++++++-------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 147 +++++++++++---------- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 50 ++++--- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 57 ++++---- haddock-api/src/Haddock/Interface/Create.hs | 48 ++++--- haddock-api/src/Haddock/Interface/LexParseRn.hs | 21 +-- .../src/Haddock/Interface/ParseModuleHeader.hs | 6 +- haddock-api/src/Haddock/InterfaceFile.hs | 11 +- haddock-api/src/Haddock/Options.hs | 39 +++++- haddock-api/src/Haddock/Parser.hs | 4 +- haddock-api/src/Haddock/Types.hs | 6 + haddock-library/fixtures/Fixtures.hs | 2 +- haddock-library/src/Documentation/Haddock/Doc.hs | 8 +- .../src/Documentation/Haddock/Parser.hs | 9 +- haddock-library/src/Documentation/Haddock/Types.hs | 5 +- .../test/Documentation/Haddock/ParserSpec.hs | 17 ++- 17 files changed, 346 insertions(+), 266 deletions(-) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index dc903e08..00eb50f6 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -25,7 +25,6 @@ module Haddock ( withGhc ) where -import Data.Version import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes) @@ -42,7 +41,6 @@ import Haddock.Options import Haddock.Utils import Control.Monad hiding (forM_) -import Control.Applicative import Data.Foldable (forM_, foldl') import Data.Traversable (for) import Data.List (isPrefixOf) @@ -151,7 +149,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do -- or which exits with an error or help message. (flags, files) <- parseHaddockOpts args shortcutFlags flags - qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} + qual <- rightOrThrowE (qualification flags) + sinceQual <- rightOrThrowE (sinceQualification flags) -- inject dynamic-too into flags before we proceed flags' <- ghc flags $ do @@ -184,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags flags qual packages ifaces + liftIO $ renderStep dflags flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -194,7 +193,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags qual packages [] + liftIO $ renderStep dflags flags sinceQual qual packages [] -- | Create warnings about potential misuse of -optghc warnings :: [String] -> [String] @@ -228,8 +227,9 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags qual pkgs interfaces = do +renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption + -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep dflags flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs @@ -238,12 +238,12 @@ renderStep dflags flags qual pkgs interfaces = do ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - - render dflags flags qual interfaces installedIfaces extSrcMap + render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags flags qual ifaces installedIfaces extSrcMap = do +render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface] + -> [InstalledInterface] -> Map Module FilePath -> IO () +render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -270,6 +270,10 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do pkgKey = moduleUnitId pkgMod pkgStr = Just (unitIdString pkgKey) pkgNameVer = modulePackageInfo dflags flags pkgMod + pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) + sincePkg = case sinceQual of + External -> pkgName + Always -> Nothing (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags @@ -338,7 +342,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ppHtmlContents dflags' odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty - (makeContentsQual qual) + sincePkg (makeContentsQual qual) return () copyHtmlBits odir libDir themes withQuickjump @@ -348,7 +352,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode qual + opt_contents_url opt_index_url unicode sincePkg qual pretty withQuickjump return () copyHtmlBits odir libDir themes withQuickjump @@ -358,7 +362,12 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do case pkgNameVer of - Nothing -> putStrLn . unlines $ + (Just (PackageName pkgNameFS), Just pkgVer) -> + let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title + | otherwise = unpackFS pkgNameFS + in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) + visibleIfaces odir + _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." , "" @@ -366,14 +375,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ++ " using the --package-name" , " and --package-version arguments." ] - Just (PackageName pkgNameFS, pkgVer) -> - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title - | otherwise = unpackFS pkgNameFS - in withTiming (pure dflags') "ppHoogle" (const ()) $ do - _ <- {-# SCC ppHoogle #-} - ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) - visibleIfaces odir - return () when (Flag_LaTeX `elem` flags) $ do withTiming (pure dflags') "ppLatex" (const ()) $ do @@ -388,26 +389,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces return () --- | From GHC 7.10, this function has a potential to crash with a --- nasty message such as @expectJust getPackageDetails@ because --- package name and versions can no longer reliably be extracted in --- all cases: if the package is not installed yet then this info is no --- longer available. The @--package-name@ and @--package-version@ --- Haddock flags allow the user to specify this information and it is --- returned here if present: if it is not present, the error will --- occur. Nasty but that's how it is for now. Potential TODO. -modulePackageInfo :: DynFlags - -> [Flag] -- ^ Haddock flags are checked as they may - -- contain the package name or version - -- provided by the user which we - -- prioritise - -> Module -> Maybe (PackageName, Data.Version.Version) -modulePackageInfo dflags flags modu = - cmdline <|> pkgDb - where - cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags - pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu) - ------------------------------------------------------------------------------- -- * Reading and dumping interface files @@ -628,10 +609,15 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! parseParas dflags str + return . Just $! parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" +rightOrThrowE :: Either String b -> IO b +rightOrThrowE (Left msg) = throwE msg +rightOrThrowE (Right x) = pure x + + #ifdef IN_GHC_TREE getInTreeDir :: IO String diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index d03cf0ba..c9a262a4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -70,6 +70,7 @@ ppHtml :: DynFlags -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) + -> Maybe String -- ^ Package name -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> Bool -- ^ Also write Quickjump index @@ -78,7 +79,7 @@ ppHtml :: DynFlags ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode - qual debug withQuickjump = do + pkg qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i @@ -88,7 +89,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents - prologue debug (makeContentsQual qual) + prologue debug pkg (makeContentsQual qual) when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package @@ -96,12 +97,12 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug when withQuickjump $ - ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual visible_ifaces mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces + maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () @@ -258,11 +259,12 @@ ppHtmlContents -> WikiURLs -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool + -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents dflags odir doctitle _maybe_package themes mathjax_url maybe_index_url - maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do + maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do let tree = mkModuleTree dflags showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces @@ -276,41 +278,41 @@ ppHtmlContents dflags odir doctitle _maybe_package bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ - ppPrologue qual doctitle prologue, - ppSignatureTree qual sig_tree, - ppModuleTree qual tree + ppPrologue pkg qual doctitle prologue, + ppSignatureTree pkg qual sig_tree, + ppModuleTree pkg qual tree ] createDirectoryIfMissing True odir writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) -ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html -ppPrologue _ _ Nothing = noHtml -ppPrologue qual title (Just doc) = - divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) +ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html +ppPrologue _ _ _ Nothing = noHtml +ppPrologue pkg qual title (Just doc) = + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) -ppSignatureTree :: Qualification -> [ModuleTree] -> Html -ppSignatureTree qual ts = - divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts) +ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html +ppSignatureTree pkg qual ts = + divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) -ppModuleTree :: Qualification -> [ModuleTree] -> Html -ppModuleTree _ [] = mempty -ppModuleTree qual ts = - divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) +ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html +ppModuleTree _ _ [] = mempty +ppModuleTree pkg qual ts = + divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts) -mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html -mkNodeList qual ss p ts = case ts of +mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html +mkNodeList pkg qual ss p ts = case ts of [] -> noHtml - _ -> unordList (zipWith (mkNode qual ss) ps ts) + _ -> unordList (zipWith (mkNode pkg qual ss) ps ts) where ps = [ p ++ '.' : show i | i <- [(1::Int)..]] -mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf _pkg srcPkg short ts) = +mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html +mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of @@ -330,14 +332,14 @@ mkNode qual ss p (Node s leaf _pkg srcPkg short ts) = Nothing -> toHtml s ) - shortDescr = maybe noHtml (origDocToHtml qual) short + shortDescr = maybe noHtml (origDocToHtml pkg qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg subtree = if null ts then noHtml else collapseDetails p DetailsOpen ( thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++ - mkNodeList qual (s:ss) p ts + mkNodeList pkg qual (s:ss) p ts ) @@ -350,10 +352,11 @@ ppJsonIndex :: FilePath -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) -> Bool + -> Maybe Package -> QualOption -> [Interface] -> IO () -ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do createDirectoryIfMissing True odir IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do Builder.hPutBuilder h (encodeToBuilder modules) @@ -371,7 +374,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] goExport mdl qual item - | Just item_html <- processExport True links_info unicode qual item + | Just item_html <- processExport True links_info unicode pkg qual item = [ Object [ "display_html" .= String (showHtmlFragment item_html) , "name" .= String (intercalate " " (map nameString names)) @@ -529,11 +532,11 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes -> Maybe String -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool -> QualOption + -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug iface = do + maybe_contents_url maybe_index_url unicode pkg qual debug iface = do let mdl = ifaceMod iface aliases = ifaceModuleAliases iface @@ -555,7 +558,7 @@ ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), - ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual ] createDirectoryIfMissing True odir @@ -565,9 +568,9 @@ signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html -ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual - = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual + = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++ description +++ synopsis +++ divInterface (maybe_doc_hdr +++ bdy +++ orphans) @@ -585,7 +588,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual description | isNoHtml doc = doc | otherwise = divDescription $ sectionName << "Description" +++ doc - where doc = docSection Nothing qual (ifaceRnDoc iface) + where doc = docSection Nothing pkg qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis @@ -595,7 +598,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual collapseDetails "syn" DetailsClosed ( thesummary << "Synopsis" +++ shortDeclList ( - mapMaybe (processExport True linksInfo unicode qual) exports + mapMaybe (processExport True linksInfo unicode pkg qual) exports ) ! collapseToggle "syn" "" ) @@ -609,19 +612,20 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual bdy = foldr (+++) noHtml $ - mapMaybe (processExport False linksInfo unicode qual) exports + mapMaybe (processExport False linksInfo unicode pkg qual) exports orphans = - ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual + ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual linksInfo = (maybe_source_url, maybe_wiki_url) -ppModuleContents :: Qualification +ppModuleContents :: Maybe Package -- ^ This package + -> Qualification -> [ExportItem DocNameI] - -> Bool -- ^ Orphans sections + -> Bool -- ^ Orphans sections -> Html -ppModuleContents qual exports orphan +ppModuleContents pkg qual exports orphan | null sections && not orphan = noHtml | otherwise = contentsDiv where @@ -641,7 +645,7 @@ ppModuleContents qual exports orphan | otherwise = ( html:secs, rest2 ) where html = linkedAnchor (groupId id0) - << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs + << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest (secs, rest2) = process n rest1 process n (_ : rest) = process n rest @@ -661,22 +665,22 @@ numberSectionHeadings = go 1 = other : go n es -processExport :: Bool -> LinksInfo -> Bool -> Qualification +processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances -processExport summary _ _ qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) -processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice) - = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual -processExport summary _ _ qual (ExportNoDecl y []) +processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport summary _ _ pkg qual (ExportGroup lev id0 doc) + = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) +processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) + = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual +processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y -processExport summary _ _ qual (ExportNoDecl y subs) +processExport summary _ _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ ppDocName qual Prefix True y +++ parenList (map (ppDocName qual Prefix True) subs) -processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection_ Nothing qual doc -processExport summary _ _ _ (ExportModule mdl) +processExport summary _ _ pkg qual (ExportDoc doc) + = nothingIf summary $ docSection_ Nothing pkg qual doc +processExport summary _ _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d92bdd3a..815ecee9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -43,17 +43,18 @@ import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI -> [(HsDecl DocNameI, DocForDecl DocName)] -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] - -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html -ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode + -> Maybe Package -> Qualification -> Html +ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigWcType lty) fixities splice unicode qual + (hsSigWcType lty) fixities splice unicode pkg qual SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - ty fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + ty fixities splice unicode pkg qual + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ -> noHtml DerivD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -61,28 +62,29 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc doc (map unLoc lnames) lty fixities - splice unicode qual + splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode qual = + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) - splice unicode qual HideEmptyContexts + splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice + unicode pkg qual | summary = pref1 | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) - +++ docSection Nothing qual doc + +++ docSection Nothing pkg qual doc where pref1 = hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames @@ -92,15 +94,15 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> - Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html + Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual emptyCtxts = + splice unicode pkg qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) - splice unicode qual emptyCtxts + splice unicode pkg qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html @@ -110,12 +112,14 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI -> DocForDecl DocName -> (Html, Html, Html) - -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts + -> Splice -> Unicode -> Maybe Package -> Qualification + -> HideEmptyContexts -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) + splice unicode pkg qual emptyCtxts | summary = pref1 - | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc + | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc + subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc where curName = getName <$> listToMaybe docnames argDoc n = Map.lookup n argDocs @@ -181,23 +185,23 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities - splice unicode qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual -ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" + splice unicode pkg qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual +ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) - splice unicode qual + splice unicode pkg qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual ShowEmptyToplevelContexts + splice unicode pkg qual ShowEmptyToplevelContexts where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) @@ -206,7 +210,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars fixs | summary = noHtml | otherwise = ppFixities fixities qual -ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" +ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html @@ -297,11 +301,13 @@ ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html -ppTyFam summary associated links instances fixities loc doc decl splice unicode qual + FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package -> + Qualification -> Html +ppTyFam summary associated links instances fixities loc doc decl splice unicode + pkg qual | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit + | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit where docname = unLoc $ fdLName decl @@ -312,10 +318,10 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode instancesBit | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary - = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns + = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise - = ppInstances links (OriginFamily docname) instances splice unicode qual + = ppInstances links (OriginFamily docname) instances splice unicode pkg qual -- Individual equation of a closed type family ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl @@ -343,9 +349,10 @@ ppPseudoFamilyDecl links splice unicode qual ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI - -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppAssocType summ links doc (L loc decl) fixities splice unicode qual = - ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual + -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package + -> Qualification -> Html +ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = + ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual -------------------------------------------------------------------------------- @@ -454,22 +461,22 @@ ppFds fds unicode qual = ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan -> [(DocName, DocForDecl DocName)] - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc - subdocs splice unicode qual = + subdocs splice unicode pkg qual = if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False ( - [ ppAssocType summary links doc at [] splice unicode qual | at <- ats + [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults [ ppFunSig summary links loc doc names (hsSigWcType typ) - [] splice unicode qual + [] splice unicode pkg qual | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] @@ -480,20 +487,20 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual nm = unLoc lname -ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) - splice unicode qual - | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual - | otherwise = classheader +++ docSection Nothing qual d + splice unicode pkg qual + | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual + | otherwise = classheader +++ docSection Nothing pkg qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where sigs = map unLoc lsigs @@ -510,14 +517,14 @@ ppClassDecl summary links instances fixities loc d subdocs hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual + atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual | at <- ats , let n = unL . fdLName $ unL at doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) - subfixs splice unicode qual + subfixs splice unicode pkg qual | L _ (ClassOpSig _ lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs @@ -551,17 +558,17 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Parens x) = ppMinimal p (unLoc x) instancesBit = ppInstances links (OriginClass nm) instances - splice unicode qual + splice unicode pkg qual -ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: LinksInfo -> InstOrigin DocName -> [DocInstance DocNameI] - -> Splice -> Unicode -> Qualification + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppInstances links origin instances splice unicode qual - = subInstances qual instName links True (zipWith instDecl [1..] instances) +ppInstances links origin instances splice unicode pkg qual + = subInstances pkg qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString origin @@ -572,10 +579,10 @@ ppInstances links origin instances splice unicode qual ppOrphanInstances :: LinksInfo -> [DocInstance DocNameI] - -> Splice -> Unicode -> Qualification + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppOrphanInstances links instances splice unicode qual - = subOrphanInstances qual links True (zipWith instDecl [1..] instances) +ppOrphanInstances links instances splice unicode pkg qual + = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances) where instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) @@ -713,12 +720,12 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] [(DocName, DocForDecl DocName)] -> SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> [(HsDecl DocNameI, DocForDecl DocName)] -> - Splice -> Unicode -> Qualification -> Html + Splice -> Unicode -> Maybe Package -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats - splice unicode qual + splice unicode pkg qual | summary = ppShortDataDecl summary False dataDecl pats unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit + | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl @@ -738,14 +745,14 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats | null cons = keyword "where" | otherwise = if isH98 then noHtml else keyword "where" - constrBit = subConstructors qual - [ ppSideBySideConstr subdocs subfixs unicode qual c + constrBit = subConstructors pkg qual + [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc (getConNames (unLoc c)))) fixities ] - patternBit = subPatterns qual + patternBit = subPatterns pkg qual [ (hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode @@ -757,7 +764,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats ] instancesBit = ppInstances links (OriginData docname) instances - splice unicode qual + splice unicode pkg qual @@ -824,8 +831,8 @@ ppConstrHdr forall_ tvs ctxt unicode qual | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) + -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl +ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) = (decl, mbDoc, fieldPart) where decl = case con of @@ -851,7 +858,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) RecCon (L _ fields) -> [doRecordFields fields] _ -> [] - doRecordFields fields = subFields qual + doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) doGADTCon :: Located (HsType DocNameI) -> Html diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 2990e1e4..ed323a90 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -171,10 +171,10 @@ flatten x = [x] -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. -hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html -hackMarkup fmt' h' = +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' - in html +++ renderMeta fmt' (metaConcat ms) + in html +++ renderMeta fmt' currPkg (metaConcat ms) where hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> (Html, [Meta]) @@ -193,45 +193,50 @@ hackMarkup fmt' h' = (y, m') = hackMarkup' fmt d' in (markupAppend fmt x y, m ++ m') -renderMeta :: DocMarkup id Html -> Meta -> Html -renderMeta fmt (Meta { _version = Just x }) = +renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html +renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) = markupParagraph fmt . markupEmphasis fmt . toHtml $ - "Since: " ++ formatVersion x + "Since: " ++ formatPkgMaybe pkg ++ formatVersion x where formatVersion v = concat . intersperse "." $ map show v -renderMeta _ _ = noHtml + formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-" + formatPkgMaybe _ = "" +renderMeta _ _ _ = noHtml -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. markupHacked :: DocMarkup id Html + -> Maybe Package -- this package -> Maybe String -> MDoc id -> Html -markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten +markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten -- If the doc is a single paragraph, don't surround it with

(this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply? -docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See - -- comments on 'toHack' for details. +docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See + -- comments on 'toHack' for details. + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docToHtml n qual = markupHacked fmt n . cleanup +docToHtml n pkg qual = markupHacked fmt pkg n . cleanup where fmt = parHtmlMarkup qual True (ppDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. -docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' +docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup +docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) -origDocToHtml :: Qualification -> MDoc Name -> Html -origDocToHtml qual = markupHacked fmt Nothing . cleanup +origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html +origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) -rdrDocToHtml :: Qualification -> MDoc RdrName -> Html -rdrDocToHtml qual = markupHacked fmt Nothing . cleanup +rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html +rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup where fmt = parHtmlMarkup qual True (const ppRdrName) @@ -243,14 +248,17 @@ docElement el content_ = docSection :: Maybe Name -- ^ Name of the thing this doc is for + -> Maybe Package -- ^ Current package -> Qualification -> Documentation DocName -> Html -docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation +docSection n pkg qual = + maybe noHtml (docSection_ n pkg qual) . combineDocumentation -docSection_ :: Maybe Name -- ^ Name of the thing this doc is for +docSection_ :: Maybe Name -- ^ Name of the thing this doc is for + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docSection_ n qual = - (docElement thediv <<) . docToHtml (getOccString <$> n) qual +docSection_ n pkg qual = + (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual cleanup :: MDoc a -> MDoc a diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 217ca2af..501caa4b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -128,38 +128,39 @@ divSubDecls cssClass captionName = maybe noHtml wrap subCaption = paragraph ! [theclass "caption"] << captionName -subDlist :: Qualification -> [SubDecl] -> Maybe Html -subDlist _ [] = Nothing -subDlist qual decls = Just $ ulist << map subEntry decls +subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html +subDlist _ _ [] = Nothing +subDlist pkg qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) = li << (define ! [theclass "src"] << decl +++ - docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs)) + docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs)) -subTable :: Qualification -> [SubDecl] -> Maybe Html -subTable _ [] = Nothing -subTable qual decls = Just $ table << aboves (concatMap subRow decls) +subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html +subTable _ _ [] = Nothing +subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls) where subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <-> - docElement td << fmap (docToHtml Nothing qual) mdoc) + docElement td << fmap (docToHtml Nothing pkg qual) mdoc) : map (cell . (td <<)) subs -- | Sub table with source information (optional). -subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html -subTableSrc _ _ _ [] = Nothing -subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) +subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Maybe Html +subTableSrc _ _ _ _ [] = Nothing +subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where subRow ((decl, mdoc, subs),L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) <+> linkHtml loc dn <-> - docElement td << fmap (docToHtml Nothing qual) mdoc + docElement td << fmap (docToHtml Nothing pkg qual) mdoc ) : map (cell . (td <<)) subs linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn @@ -170,49 +171,49 @@ subBlock [] = Nothing subBlock hs = Just $ toHtml hs -subArguments :: Qualification -> [SubDecl] -> Html -subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual +subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html +subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual subAssociatedTypes :: [Html] -> Html subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock -subConstructors :: Qualification -> [SubDecl] -> Html -subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual +subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html +subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual -subPatterns :: Qualification -> [SubDecl] -> Html -subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual +subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html +subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual -subFields :: Qualification -> [SubDecl] -> Html -subFields qual = divSubDecls "fields" "Fields" . subDlist qual +subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html +subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual -subEquations :: Qualification -> [SubDecl] -> Html -subEquations qual = divSubDecls "equations" "Equations" . subTable qual +subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html +subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual -- | Generate sub table for instance declarations, with source -subInstances :: Qualification +subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Html -subInstances qual nm lnks splice = maybe noHtml wrap . instTable +subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) - instTable = subTableSrc qual lnks splice + instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] summary = thesummary << "Instances" id_ = makeAnchorId $ "i:" ++ nm -subOrphanInstances :: Qualification +subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Html -subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable +subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice + instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice id_ = makeAnchorId $ "orphans" diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index deef7ad3..a35e2053 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -46,7 +46,6 @@ import Data.Traversable import Avail hiding (avail) import qualified Avail -import qualified Packages import qualified Module import qualified SrcLoc import ConLike (ConLike(..)) @@ -55,13 +54,14 @@ import HscTypes import Name import NameSet import NameEnv +import Packages ( lookupModuleInAllPackages, PackageName(..) ) import Bag import RdrName import TcRnTypes -import FastString (concatFS) +import FastString ( concatFS, unpackFS ) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O -import HsDecls ( getConDetails ) +import HsDecls ( getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -85,12 +85,22 @@ createInterface tm flags modMap instIfaceMap = do !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExportsWithSelectors mi + (pkgNameFS, _) = modulePackageInfo dflags flags mdl + pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings , tcg_exports = all_exports }, md) = tm_internals_ tm + -- The 'pkgName' is necessary to decide what package to mention in "@since" + -- annotations. Not having it is not fatal though. + -- + -- Cabal can be trusted to pass the right flags, so this warning should be + -- mostly encountered when running Haddock outside of Cabal. + when (isNothing pkgName) $ + liftErrMsg $ tell [ "Warning: Package name is not available." ] + -- The renamed source should always be available to us, but it's best -- to be on the safe side. (group_, imports, mayExports, mayDocHeader) <- @@ -103,7 +113,7 @@ createInterface tm flags modMap instIfaceMap = do opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl -- Process the top-level module header documentation. - (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader + (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader let declsWithDocs = topDecls group_ @@ -130,13 +140,13 @@ createInterface tm flags modMap instIfaceMap = do warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) maps@(!docMap, !argMap, !declMap, _) <- - liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) + liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre + exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre exportedNames decls maps fixMap unrestrictedImportedMods splices exports all_exports instIfaceMap dflags @@ -190,6 +200,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceTokenizedSrc = tokenizedSrc } + -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This @@ -266,7 +277,7 @@ lookupModuleDyn :: lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = - case Packages.lookupModuleInAllPackages dflags mdlName of + case lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainUnitId mdlName @@ -346,11 +357,12 @@ type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap) -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. mkMaps :: DynFlags + -> Maybe Package -- this package -> GlobalRdrEnv -> [Name] -> [(LHsDecl GhcRn, [HsDocString])] -> ErrMsgM Maps -mkMaps dflags gre instances decls = do +mkMaps dflags pkgName gre instances decls = do (a, b, c) <- unzip3 <$> traverse mappings decls pure ( f' (map (nubByName fst) a) , f (filterMapping (not . M.null) b) @@ -377,8 +389,8 @@ mkMaps dflags gre instances decls = do declDoc :: [HsDocString] -> Map Int HsDocString -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = do - doc' <- processDocStrings dflags gre strs - m' <- traverse (processDocStringParas dflags gre) m + doc' <- processDocStrings dflags pkgName gre strs + m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') (doc, args) <- declDoc docStrs (typeDocs decl) @@ -605,12 +617,13 @@ collectDocs = go Nothing [] mkExportItems :: Bool -- is it a signature -> IfaceMap + -> Maybe Package -- this package -> Module -- this module -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl GhcRn] -- renamed source declarations + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps -> FixMap -> M.Map ModuleName [ModuleName] @@ -621,12 +634,12 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem GhcRn] mkExportItems - is_sig modMap thisMod semMod warnings gre exportedNames decls + is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap unrestricted_imp_mods splices exportList allExports instIfaceMap dflags = case exportList of Nothing -> - fullModuleContents is_sig modMap thisMod semMod warnings gre + fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports @@ -636,14 +649,14 @@ mkExportItems return [ExportGroup lev "" doc] lookupExport (IEDoc docStr, _) = liftErrMsg $ do - doc <- processDocStringParas dflags gre docStr + doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] lookupExport (IEDocNamed str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do - doc <- processDocStringParas dflags gre docStr + doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] lookupExport (IEModuleContents (L _ mod_name), _) @@ -962,6 +975,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = fullModuleContents :: Bool -- is it a signature -> IfaceMap + -> Maybe Package -- this package -> Module -- this module -> Module -- semantic module -> WarningMap @@ -975,7 +989,7 @@ fullModuleContents :: Bool -- is it a signature -> DynFlags -> Avails -> ErrMsgGhc [ExportItem GhcRn] -fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames +fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do let availEnv = availsToNameEnv (nubAvails avails) (concat . concat) `fmap` (for decls $ \decl -> do @@ -984,7 +998,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames doc <- liftErrMsg (processDocString dflags gre docStr) return [[ExportGroup lev "" doc]] (L _ (DocD (DocCommentNamed _ docStr))) -> do - doc <- liftErrMsg (processDocStringParas dflags gre docStr) + doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] (L _ (ValD valDecl)) | name:_ <- collectHsBindBinders valDecl diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 1269df3f..9a978f9f 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -33,34 +33,35 @@ import RdrName import EnumSet import RnEnv (dataTcOccs) -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] +processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) -processDocStrings dflags gre strs = do - mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs +processDocStrings dflags pkg gre strs = do + mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing + MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) -processDocStringParas dflags gre (HsDocString fs) = - overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) +processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString + -> ErrMsgM (MDoc Name) +processDocStringParas dflags pkg gre (HsDocString fs) = + overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) = rename dflags gre $ parseString dflags (unpackFS fs) -processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString +processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) -processModuleHeader dflags gre safety mayStr = do +processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs - (hmi, doc) = parseModuleHeader dflags str + (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr Nothing -> pure Nothing diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 6690c22d..050901b6 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -24,8 +24,8 @@ import RdrName -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName) -parseModuleHeader dflags str0 = +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +parseModuleHeader dflags pkgName str0 = let getKey :: String -> String -> (Maybe String,String) getKey key str = case parseKey key str of @@ -52,7 +52,7 @@ parseModuleHeader dflags str0 = hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags str9) + }, parseParas dflags pkgName str9) -- | This function is how we read keys. -- diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index bbd8d04e..d5bbce2c 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) -binaryInterfaceVersion = 32 +binaryInterfaceVersion = 33 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -486,8 +486,13 @@ instance Binary a => Binary (TableCell a) where return (TableCell i j c) instance Binary Meta where - put_ bh Meta { _version = v } = put_ bh v - get bh = (\v -> Meta { _version = v }) <$> get bh + put_ bh (Meta v p) = do + put_ bh v + put_ bh p + get bh = do + v <- get bh + p <- get bh + return (Meta v p) instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where put_ bh MetaDoc { _meta = m, _doc = d } = do diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 0609aa63..b5e987d8 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -29,19 +29,23 @@ module Haddock.Options ( optLaTeXStyle, optMathjax, qualification, + sinceQualification, verbosity, ghcFlags, reexportFlags, readIfaceArgs, optPackageName, - optPackageVersion + optPackageVersion, + modulePackageInfo ) where import qualified Data.Char as Char import Data.Version +import Control.Applicative import Distribution.Verbosity import FastString +import GHC ( DynFlags, Module, moduleUnitId ) import Haddock.Types import Haddock.Utils import Packages @@ -103,6 +107,7 @@ data Flag | Flag_PackageName String | Flag_PackageVersion String | Flag_Reexport String + | Flag_SinceQualification String deriving (Eq, Show) @@ -210,7 +215,9 @@ options backwardsCompat = Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") "name of the package being documented", Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") - "version of the package being documented in usual x.y.z.w format" + "version of the package being documented in usual x.y.z.w format", + Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL") + "package qualification of @since, one of\n'always' (default) or 'only-external'" ] @@ -310,6 +317,14 @@ qualification flags = [arg] -> Left $ "unknown qualification type " ++ show arg _:_ -> Left "qualification option given multiple times" +sinceQualification :: [Flag] -> Either String SinceQual +sinceQualification flags = + case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of + [] -> Right Always + ["always"] -> Right Always + ["external"] -> Right External + [arg] -> Left $ "unknown since-qualification type " ++ show arg + _:_ -> Left "since-qualification option given multiple times" verbosity :: [Flag] -> Verbosity verbosity flags = @@ -344,3 +359,23 @@ readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] optLast :: [a] -> Maybe a optLast [] = Nothing optLast xs = Just (last xs) + + +-- | This function has a potential to return 'Nothing' because package name and +-- versions can no longer reliably be extracted in all cases: if the package is +-- not installed yet then this info is no longer available. +-- +-- The @--package-name@ and @--package-version@ Haddock flags allow the user to +-- specify this information manually and it is returned here if present. +modulePackageInfo :: DynFlags + -> [Flag] -- ^ Haddock flags are checked as they may contain + -- the package name or version provided by the user + -- which we prioritise + -> Module + -> (Maybe PackageName, Maybe Data.Version.Version) +modulePackageInfo dflags flags modu = + ( optPackageName flags <|> fmap packageName pkgDb + , optPackageVersion flags <|> fmap packageVersion pkgDb + ) + where + pkgDb = lookupPackage dflags (moduleUnitId modu) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 47bf814b..58500f1b 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -28,8 +28,8 @@ import RdrName (RdrName) import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) -parseParas :: DynFlags -> String -> MetaDoc mod RdrName -parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName +parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p parseString :: DynFlags -> String -> DocH mod RdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 2810862f..36ed7baf 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -578,6 +578,12 @@ data HideEmptyContexts = HideEmptyContexts | ShowEmptyToplevelContexts +-- | When to qualify @since@ annotations with their package +data SinceQual + = Always + | External -- ^ only qualify when the thing being annotated is from + -- an external package + ----------------------------------------------------------------------------- -- * Error handling ----------------------------------------------------------------------------- diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs index 282fd10d..a4e4321f 100644 --- a/haddock-library/fixtures/Fixtures.hs +++ b/haddock-library/fixtures/Fixtures.hs @@ -102,7 +102,7 @@ acceptFixtures = traverse_ $ \(Fixture i o) -> do writeFile o actual parseString :: String -> Doc String -parseString = Parse.toRegular . _doc . Parse.parseParas +parseString = Parse.toRegular . _doc . Parse.parseParas Nothing data Cmd = CmdRun | CmdAccept | CmdList diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs index 66bd1c97..297d30d6 100644 --- a/haddock-library/src/Documentation/Haddock/Doc.hs +++ b/haddock-library/src/Documentation/Haddock/Doc.hs @@ -27,16 +27,16 @@ metaDocAppend (MetaDoc { _meta = m, _doc = d }) (MetaDoc { _meta = m', _doc = d' }) = MetaDoc { _meta = m' `metaAppend` m, _doc = d `docAppend` d' } --- | This is not a monoidal append, it uses '<|>' for the '_version'. +-- | This is not a monoidal append, it uses '<|>' for the '_version' and +-- '_package'. metaAppend :: Meta -> Meta -> Meta -metaAppend (Meta { _version = v }) (Meta { _version = v' }) = - Meta { _version = v <|> v' } +metaAppend (Meta v1 p1) (Meta v2 p2) = Meta (v1 <|> v2) (p1 <|> p2) emptyMetaDoc :: MetaDoc mod id emptyMetaDoc = MetaDoc { _meta = emptyMeta, _doc = DocEmpty } emptyMeta :: Meta -emptyMeta = Meta { _version = empty } +emptyMeta = Meta empty empty docAppend :: DocH mod id -> DocH mod id -> DocH mod id docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 6cbc3922..4921b3a7 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -116,10 +116,13 @@ parse p = either err id . parseOnly (p <* endOfInput) -- | Main entry point to the parser. Appends the newline character -- to the input string. -parseParas :: String -- ^ String to parse +parseParas :: Maybe Package + -> String -- ^ String to parse -> MetaDoc mod Identifier -parseParas input = case parseParasState input of - (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state } +parseParas pkg input = case parseParasState input of + (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state + , _package = pkg + } , _doc = a } diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 209f26e8..005ec186 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -34,7 +34,9 @@ import Data.Bitraversable -- meta-data to comments. We make a structure for this ahead of time -- so we don't have to gut half the core each time we want to add such -- info. -newtype Meta = Meta { _version :: Maybe Version } deriving (Eq, Show) +data Meta = Meta { _version :: Maybe Version + , _package :: Maybe Package + } deriving (Eq, Show) data MetaDoc mod id = MetaDoc { _meta :: Meta @@ -61,6 +63,7 @@ overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d) type Version = [Int] +type Package = String data Hyperlink = Hyperlink { hyperlinkUrl :: String diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index c605e2c2..86ed3b35 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -24,8 +24,15 @@ instance IsString (Doc String) where instance IsString a => IsString (Maybe a) where fromString = Just . fromString +emptyMeta :: Meta +emptyMeta = + Meta { + _version = Nothing + , _package = Nothing + } + parseParas :: String -> MetaDoc () String -parseParas = overDoc Parse.toRegular . Parse.parseParas +parseParas = overDoc Parse.toRegular . Parse.parseParas Nothing parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString @@ -375,17 +382,17 @@ spec = do context "when parsing @since" $ do it "adds specified version to the result" $ do parseParas "@since 0.5.0" `shouldBe` - MetaDoc { _meta = Meta { _version = Just [0,5,0] } + MetaDoc { _meta = emptyMeta { _version = Just [0,5,0] } , _doc = DocEmpty } it "ignores trailing whitespace" $ do parseParas "@since 0.5.0 \t " `shouldBe` - MetaDoc { _meta = Meta { _version = Just [0,5,0] } + MetaDoc { _meta = emptyMeta { _version = Just [0,5,0] } , _doc = DocEmpty } it "does not allow trailing input" $ do parseParas "@since 0.5.0 foo" `shouldBe` - MetaDoc { _meta = Meta { _version = Nothing } + MetaDoc { _meta = emptyMeta { _version = Nothing } , _doc = DocParagraph "@since 0.5.0 foo" } @@ -395,7 +402,7 @@ spec = do "@since 0.5.0" , "@since 0.6.0" , "@since 0.7.0" - ] `shouldBe` MetaDoc { _meta = Meta { _version = Just [0,7,0] } + ] `shouldBe` MetaDoc { _meta = emptyMeta { _version = Just [0,7,0] } , _doc = DocEmpty } -- cgit v1.2.3 From 79c7159101c03bbbc7350e07963896ca2bb97c02 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 25 Apr 2018 11:24:07 -0700 Subject: Replace 'attoparsec' with 'parsec' (#799) * Remove attoparsec with parsec and start fixing failed parses * Make tests pass * Fix encoding issues The Haddock parser no longer needs to worry about bytestrings. All the internal parsing work in haddock-library happens over 'Text'. * Remove attoparsec vendor * Fix stuff broken in 'attoparsec' -> 'parsec' * hyperlinks * codeblocks * examples Pretty much all issues are due to attoparsec's backtracking failure behaviour vs. parsec's non-backtracking failure behaviour. * Fix small TODOs * Missing quote + Haddocks * Better handle spaces before/after paragraphs * Address review comments --- haddock-library/haddock-library.cabal | 64 +-- .../src/Documentation/Haddock/Parser.hs | 428 ++++++++-------- .../src/Documentation/Haddock/Parser/Monad.hs | 225 +++------ .../src/Documentation/Haddock/Parser/Util.hs | 82 ++-- .../vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs | 23 - .../Data/Attoparsec/ByteString.hs | 230 --------- .../Data/Attoparsec/ByteString/Buffer.hs | 156 ------ .../Data/Attoparsec/ByteString/Char8.hs | 464 ------------------ .../Data/Attoparsec/ByteString/FastSet.hs | 115 ----- .../Data/Attoparsec/ByteString/Internal.hs | 536 --------------------- .../Data/Attoparsec/Combinator.hs | 233 --------- .../Data/Attoparsec/Internal.hs | 157 ------ .../Data/Attoparsec/Internal/Fhthagn.hs | 18 - .../Data/Attoparsec/Internal/Types.hs | 243 ---------- .../attoparsec-0.13.1.0/Data/Attoparsec/Number.hs | 137 ------ haddock-library/vendor/attoparsec-0.13.1.0/LICENSE | 30 -- haddock.cabal | 18 +- 17 files changed, 363 insertions(+), 2796 deletions(-) delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs delete mode 100644 haddock-library/vendor/attoparsec-0.13.1.0/LICENSE (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index deeaa98d..49ec826c 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -10,7 +10,6 @@ description: Haddock is a documentation-generation tool for Haskell itself, see the ‘haddock’ package. license: BSD3 license-files: LICENSE - vendor/attoparsec-0.13.1.0/LICENSE maintainer: Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues @@ -27,9 +26,8 @@ library , bytestring >= 0.9.2.1 && < 0.11 , containers >= 0.4.2.1 && < 0.6 , transformers >= 0.3.0 && < 0.6 - - -- internal sub-lib - build-depends: attoparsec + , text >= 1.2.3.0 && < 1.3 + , parsec >= 3.1.13.0 && < 3.2 hs-source-dirs: src @@ -48,39 +46,6 @@ library if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -library attoparsec - default-language: Haskell2010 - - build-depends: - base >= 4.5 && < 4.12 - , bytestring >= 0.9.2.1 && < 0.11 - , deepseq >= 1.3 && < 1.5 - - hs-source-dirs: vendor/attoparsec-0.13.1.0 - - -- NB: haddock-library needs only small part of lib:attoparsec - -- internally, so we only bundle that subset here - exposed-modules: - Data.Attoparsec.ByteString - Data.Attoparsec.ByteString.Char8 - Data.Attoparsec.Combinator - - other-modules: - Data.Attoparsec - Data.Attoparsec.ByteString.Buffer - Data.Attoparsec.ByteString.FastSet - Data.Attoparsec.ByteString.Internal - Data.Attoparsec.Internal - Data.Attoparsec.Internal.Fhthagn - Data.Attoparsec.Internal.Types - Data.Attoparsec.Number - - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - else - build-depends: semigroups ^>= 0.18.3, fail ^>= 4.9.0.0 - test-suite spec type: exitcode-stdio-1.0 @@ -106,21 +71,16 @@ test-suite spec Documentation.Haddock.Utf8Spec build-depends: - base-compat ^>= 0.9.3 + base >= 4.5 && < 4.12 + , base-compat ^>= 0.9.3 + , bytestring >= 0.9.2.1 && < 0.11 , containers >= 0.4.2.1 && < 0.6 , transformers >= 0.3.0 && < 0.6 , hspec ^>= 2.4.4 , QuickCheck ^>= 2.11 - - -- internal sub-lib - build-depends: attoparsec - - -- Versions for the dependencies below are transitively pinned by - -- dependency on haddock-library:lib:attoparsec - build-depends: - base - , bytestring - , deepseq + , text >= 1.2.3.0 && < 1.3 + , parsec >= 3.1.13.0 && < 3.2 + , deepseq >= 1.3 && < 1.5 build-tool-depends: hspec-discover:hspec-discover ^>= 2.4.4 @@ -132,7 +92,8 @@ test-suite fixtures ghc-options: -Wall -O0 hs-source-dirs: fixtures build-depends: - base-compat ^>= 0.9.3 + base >= 4.5 && < 4.12 + , base-compat ^>= 0.9.3 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 , optparse-applicative ^>= 0.14.0.0 @@ -142,11 +103,6 @@ test-suite fixtures build-depends: haddock-library - -- Versions for the dependencies below are transitively pinned by - -- dependency on haddock-library:lib:attoparsec - build-depends: - base - source-repository head type: git subdir: haddock-library diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 4921b3a7..d79da40b 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -16,27 +16,35 @@ -- to be -- -- @'toRegular' . '_doc' . 'parseParas'@ -module Documentation.Haddock.Parser ( parseString, parseParas - , overIdentifier, toRegular, Identifier - ) where +module Documentation.Haddock.Parser ( + parseString, + parseParas, + overIdentifier, + toRegular, + Identifier +) where import Control.Applicative import Control.Arrow (first) import Control.Monad -import qualified Data.ByteString.Char8 as BS -import Data.Char (chr, isUpper, isAlpha, isAlphaNum) -import Data.List (stripPrefix, intercalate, unfoldr, elemIndex) +import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) +import Data.List (intercalate, unfoldr, elemIndex, notElem) 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.Monad import Documentation.Haddock.Parser.Util import Documentation.Haddock.Types -import Documentation.Haddock.Utf8 import Prelude hiding (takeWhile) import qualified Prelude as P +import qualified Text.Parsec as Parsec +import Text.Parsec (try) + +import qualified Data.Text as T +import Data.Text (Text) + #if MIN_VERSION_base(4,9,0) import Text.Read.Lex (isSymbolChar) #else @@ -56,7 +64,7 @@ isSymbolChar c = not (isPuncChar c) && case generalCategory c of ModifierSymbol -> True OtherSymbol -> True DashPunctuation -> True - OtherPunctuation -> not (c `elem` ("'\"" :: String)) + OtherPunctuation -> c `notElem` ("'\"" :: String) ConnectorPunctuation -> c /= '_' _ -> False where @@ -109,8 +117,14 @@ overIdentifier f d = g d 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) + +choice' :: [Parser a] -> Parser a +choice' [] = empty +choice' [p] = p +choice' (p : ps) = try p <|> choice' ps + +parse :: Parser a -> Text -> (ParserState, a) +parse p = either err id . parseOnly (p <* Parsec.eof) where err = error . ("Haddock.Parser.parse: " ++) @@ -127,31 +141,46 @@ parseParas pkg input = case parseParasState input of } parseParasState :: String -> (ParserState, DocH mod Identifier) -parseParasState = - parse (p <* skipSpace) . encodeUtf8 . (++ "\n") . filter (/= '\r') +parseParasState = parse (emptyLines *> p) . T.pack . (++ "\n") . filter (/= '\r') where p :: Parser (DocH mod Identifier) - p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n") + p = docConcat <$> many (paragraph <* emptyLines) + + emptyLines :: Parser () + emptyLines = void $ many (try (skipHorizontalSpace *> "\n")) parseParagraphs :: String -> Parser (DocH mod Identifier) parseParagraphs input = case parseParasState input of - (state, a) -> setParserState state >> return a + (state, a) -> Parsec.putState state *> pure a --- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which --- drops leading whitespace and encodes the string to UTF8 first. +-- | Variant of 'parseText' for 'String' instead of 'Text' parseString :: String -> DocH mod Identifier -parseString = parseStringBS . encodeUtf8 . dropWhile isSpace . filter (/= '\r') +parseString = parseText . T.pack -parseStringBS :: BS.ByteString -> DocH mod Identifier -parseStringBS = snd . parse p +-- | Parse a text paragraph. Actually just a wrapper over 'parseParagraph' which +-- drops leading whitespace. +parseText :: Text -> DocH mod Identifier +parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r') + +parseParagraph :: Text -> DocH mod Identifier +parseParagraph = snd . parse p where p :: Parser (DocH mod Identifier) - p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName - <|> picture <|> mathDisplay <|> mathInline - <|> markdownImage - <|> hyperlink <|> bold - <|> emphasis <|> encodedChar <|> string' - <|> skipSpecialChar) + p = docConcat <$> many (choice' [ monospace + , anchor + , identifier + , moduleName + , picture + , mathDisplay + , mathInline + , markdownImage + , hyperlink + , bold + , emphasis + , encodedChar + , string' + , skipSpecialChar + ]) -- | Parses and processes -- @@ -175,7 +204,7 @@ specialChar = "_/<@\"&'`# " -- to ensure that we have already given a chance to more meaningful parsers -- before capturing their characers. string' :: Parser (DocH mod a) -string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (notInClass specialChar) +string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar) where unescape "" = "" unescape ('\\':x:xs) = x : unescape xs @@ -185,45 +214,45 @@ string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (notInClass specialC -- This is done to skip over any special characters belonging to other -- elements but which were not deemed meaningful at their positions. skipSpecialChar :: Parser (DocH mod a) -skipSpecialChar = DocString . return <$> satisfy (inClass specialChar) +skipSpecialChar = DocString . return <$> Parsec.oneOf specialChar -- | Emphasis parser. -- -- >>> parseString "/Hello world/" -- DocEmphasis (DocString "Hello world") emphasis :: Parser (DocH mod Identifier) -emphasis = DocEmphasis . parseStringBS <$> - mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/") +emphasis = DocEmphasis . parseParagraph <$> + disallowNewline ("/" *> takeWhile1_ (/= '/') <* "/") -- | Bold parser. -- -- >>> parseString "__Hello world__" -- DocBold (DocString "Hello world") bold :: Parser (DocH mod Identifier) -bold = DocBold . parseStringBS <$> disallowNewline ("__" *> takeUntil "__") +bold = DocBold . parseParagraph <$> disallowNewline ("__" *> takeUntil "__") -disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString -disallowNewline = mfilter ('\n' `BS.notElem`) +disallowNewline :: Parser Text -> Parser Text +disallowNewline = mfilter (T.all (/= '\n')) -- | Like `takeWhile`, but unconditionally take escaped characters. -takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString -takeWhile_ p = scan False p_ +takeWhile_ :: (Char -> Bool) -> Parser Text +takeWhile_ p = scan p_ False where p_ escaped c | escaped = Just False | not $ p c = Nothing | otherwise = Just (c == '\\') --- | Like `takeWhile1`, but unconditionally take escaped characters. -takeWhile1_ :: (Char -> Bool) -> Parser BS.ByteString -takeWhile1_ = mfilter (not . BS.null) . takeWhile_ +-- | Like 'takeWhile1', but unconditionally take escaped characters. +takeWhile1_ :: (Char -> Bool) -> Parser Text +takeWhile1_ = mfilter (not . T.null) . takeWhile_ -- | Text anchors to allow for jumping around the generated documentation. -- -- >>> parseString "#Hello world#" -- DocAName "Hello world" anchor :: Parser (DocH mod a) -anchor = DocAName . decodeUtf8 <$> +anchor = DocAName . T.unpack <$> disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") -- | Monospaced strings. @@ -231,7 +260,7 @@ anchor = DocAName . decodeUtf8 <$> -- >>> parseString "@cruel@" -- DocMonospaced (DocString "cruel") monospace :: Parser (DocH mod Identifier) -monospace = DocMonospaced . parseStringBS +monospace = DocMonospaced . parseParagraph <$> ("@" *> takeWhile1_ (/= '@') <* "@") -- | Module names. @@ -239,14 +268,14 @@ monospace = DocMonospaced . parseStringBS -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) -moduleName = DocModule <$> (char '"' *> modid <* char '"') +moduleName = DocModule <$> ("\"" *> modid <* "\"") where - modid = intercalate "." <$> conid `sepBy1` "." + modid = intercalate "." <$> conid `Parsec.sepBy1` "." conid = (:) - <$> satisfyUnicode (\c -> isAlpha c && isUpper c) - <*> many (satisfyUnicode conChar <|> char '\\' <|> char '#') + <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) + <*> many (conChar <|> Parsec.oneOf "\\#") - conChar c = isAlphaNum c || c == '_' + conChar = Parsec.alphaNum <|> Parsec.char '_' -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. @@ -256,7 +285,7 @@ moduleName = DocModule <$> (char '"' *> modid <* char '"') -- >>> parseString "<>" -- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"}) picture :: Parser (DocH mod a) -picture = DocPic . makeLabeled Picture . decodeUtf8 +picture = DocPic . makeLabeled Picture <$> disallowNewline ("<<" *> takeUntil ">>") -- | Inline math parser, surrounded by \\( and \\). @@ -264,7 +293,7 @@ picture = DocPic . makeLabeled Picture . decodeUtf8 -- >>> parseString "\\(\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\)" -- DocMathInline "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathInline :: Parser (DocH mod a) -mathInline = DocMathInline . decodeUtf8 +mathInline = DocMathInline . T.unpack <$> disallowNewline ("\\(" *> takeUntil "\\)") -- | Display math parser, surrounded by \\[ and \\]. @@ -272,7 +301,7 @@ mathInline = DocMathInline . decodeUtf8 -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]" -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathDisplay :: Parser (DocH mod a) -mathDisplay = DocMathDisplay . decodeUtf8 +mathDisplay = DocMathDisplay . T.unpack <$> ("\\[" *> takeUntil "\\]") markdownImage :: Parser (DocH mod a) @@ -282,20 +311,21 @@ markdownImage = fromHyperlink <$> ("!" *> linkParser) -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) -paragraph = examples <|> table <|> do - indent <- takeIndent - choice - [ since - , unorderedList indent - , orderedList indent - , birdtracks - , codeblock - , property - , header - , textParagraphThatStartsWithMarkdownLink - , definitionList indent - , docParagraph <$> textParagraph - ] +paragraph = choice' [ examples + , table + , do indent <- takeIndent + choice' [ since + , unorderedList indent + , orderedList indent + , birdtracks + , codeblock + , property + , header + , textParagraphThatStartsWithMarkdownLink + , definitionList indent + , docParagraph <$> textParagraph + ] + ] -- | Provides support for grid tables. -- @@ -317,45 +347,45 @@ 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 + let len = T.length firstRow -- then we parse all consequtive rows starting and ending with + or |, -- of the width `len`. - restRows <- many (parseRestRows len) + restRows <- many (try (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 :: Parser Text parseFirstRow = do skipHorizontalSpace -- upper-left corner is + - c <- char '+' - cs <- many1 (char '-' <|> char '+') + c <- Parsec.char '+' + cs <- some (Parsec.char '-' <|> Parsec.char '+') -- upper right corner is + too guard (last cs == '+') -- trailing space skipHorizontalSpace - _ <- char '\n' + _ <- Parsec.newline - return (BS.cons c $ BS.pack cs) + return (T.cons c $ T.pack cs) - parseRestRows :: Int -> Parser BS.ByteString + parseRestRows :: Int -> Parser Text parseRestRows l = do skipHorizontalSpace - c <- char '|' <|> char '+' - bs <- scan (l - 2) predicate - c2 <- char '|' <|> char '+' + c <- Parsec.char '|' <|> Parsec.char '+' + bs <- scan predicate (l - 2) + c2 <- Parsec.char '|' <|> Parsec.char '+' -- trailing space skipHorizontalSpace - _ <- char '\n' + _ <- Parsec.newline - return (BS.cons c (BS.snoc bs c2)) + return (T.cons c (T.snoc bs c2)) where predicate n c | n <= 0 = Nothing @@ -366,22 +396,22 @@ table = do -- and changes to '=' to '-'. tableStepTwo :: Int -- ^ width - -> [BS.ByteString] -- ^ rows + -> [Text] -- ^ 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 = + | T.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 + r' = T.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 + -> [Text] -- ^ rows -> Maybe Int -- ^ index of header separator -> Parser (Table (DocH mod Identifier)) tableStepThree width rs hdrIndex = do @@ -408,32 +438,32 @@ tableStepThree width rs hdrIndex = do 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') + go x' | x' >= width = fail "overflow right " + | T.index bs x' == '+' = scanDown x y x' <|> go (x' + 1) + | T.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') + go y' | y' >= height = fail "overflow down" + | T.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1) + | T.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) + | all (\x' -> T.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) + | all (\y' -> T.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 @@ -446,7 +476,7 @@ 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 :: [Text] -> 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 @@ -464,7 +494,7 @@ tableStepFour rs hdrIndex cells = case hdrIndex of init' [_] = [] init' (x : xs) = x : init' xs - rowsDoc = (fmap . fmap) parseStringBS rows + rowsDoc = (fmap . fmap) parseParagraph rows rows = map makeRow (init' yTabStops) where @@ -477,9 +507,9 @@ tableStepFour rs hdrIndex cells = case hdrIndex of 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' + extract :: Int -> Int -> Int -> Int -> Text + extract x y x2 y2 = T.intercalate "\n" + [ T.take (x2 - x + 1) $ T.drop x $ rs !! y' | y' <- [y .. y2] ] @@ -487,7 +517,7 @@ tableStepFour rs hdrIndex cells = case hdrIndex of since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty where - version = decimal `sepBy1'` "." + version = decimal `Parsec.sepBy1` "." -- | Headers inside the comment denoted with @=@ signs, up to 6 levels -- deep. @@ -498,38 +528,39 @@ since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince -- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"})) header :: Parser (DocH mod Identifier) header = do - let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1] - pser = foldl1 (<|>) psers - delim <- decodeUtf8 <$> pser - line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString - rest <- paragraph <|> return DocEmpty + let psers = map (string . flip T.replicate "=") [6, 5 .. 1] + pser = choice' psers + delim <- T.unpack <$> pser + line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText + rest <- try paragraph <|> return DocEmpty return $ DocHeader (Header (length delim) line) `docAppend` rest textParagraph :: Parser (DocH mod Identifier) -textParagraph = parseString . intercalate "\n" <$> many1 nonEmptyLine +textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine textParagraphThatStartsWithMarkdownLink :: Parser (DocH mod Identifier) textParagraphThatStartsWithMarkdownLink = docParagraph <$> (docAppend <$> markdownLink <*> optionalTextParagraph) where optionalTextParagraph :: Parser (DocH mod Identifier) - optionalTextParagraph = (docAppend <$> whitespace <*> textParagraph) <|> pure DocEmpty + optionalTextParagraph = choice' [ docAppend <$> whitespace <*> textParagraph + , pure DocEmpty ] whitespace :: Parser (DocH mod a) whitespace = DocString <$> (f <$> takeHorizontalSpace <*> optional "\n") where - f :: BS.ByteString -> Maybe BS.ByteString -> String + f :: Text -> Maybe Text -> String f xs (fromMaybe "" -> x) - | BS.null (xs <> x) = "" + | T.null (xs <> x) = "" | otherwise = " " -- | Parses unordered (bullet) lists. -unorderedList :: BS.ByteString -> Parser (DocH mod Identifier) +unorderedList :: Text -> Parser (DocH mod Identifier) unorderedList indent = DocUnorderedList <$> p where p = ("*" <|> "-") *> innerList indent p -- | Parses ordered lists (numbered or dashed). -orderedList :: BS.ByteString -> Parser (DocH mod Identifier) +orderedList :: Text -> Parser (DocH mod Identifier) orderedList indent = DocOrderedList <$> p where p = (paren <|> dot) *> innerList indent p @@ -541,104 +572,110 @@ orderedList indent = DocOrderedList <$> p -- same paragraph. Usually used as -- -- > someListFunction = listBeginning *> innerList someListFunction -innerList :: BS.ByteString -> Parser [DocH mod Identifier] +innerList :: Text -> Parser [DocH mod Identifier] -> Parser [DocH mod Identifier] innerList indent item = do c <- takeLine (cs, items) <- more indent item - let contents = docParagraph . parseString . dropNLs . unlines $ c : cs + let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs return $ case items of Left p -> [contents `docAppend` p] Right i -> contents : i -- | Parses definition lists. -definitionList :: BS.ByteString -> Parser (DocH mod Identifier) +definitionList :: Text -> Parser (DocH mod Identifier) definitionList indent = DocDefList <$> p where p = do - label <- "[" *> (parseStringBS <$> takeWhile1_ (notInClass "]\n")) <* ("]" <* optional ":") + label <- "[" *> (parseParagraph <$> takeWhile1_ (`notElem` ("]\n" :: String))) <* ("]" <* optional ":") c <- takeLine (cs, items) <- more indent p - let contents = parseString . dropNLs . unlines $ c : cs + let contents = parseText . dropNLs . T.unlines $ c : cs return $ case items of Left x -> [(label, contents `docAppend` x)] Right i -> (label, contents) : i -- | Drops all trailing newlines. -dropNLs :: String -> String -dropNLs = reverse . dropWhile (== '\n') . reverse +dropNLs :: Text -> Text +dropNLs = T.dropWhileEnd (== '\n') -- | Main worker for 'innerList' and 'definitionList'. -- We need the 'Either' here to be able to tell in the respective functions -- whether we're dealing with the next list or a nested paragraph. -more :: Monoid a => BS.ByteString -> Parser a - -> Parser ([String], Either (DocH mod Identifier) a) -more indent item = innerParagraphs indent - <|> moreListItems indent item - <|> moreContent indent item - <|> pure ([], Right mempty) +more :: Monoid a => Text -> Parser a + -> Parser ([Text], Either (DocH mod Identifier) a) +more indent item = choice' [ innerParagraphs indent + , moreListItems indent item + , moreContent indent item + , pure ([], Right mempty) + ] -- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs. -innerParagraphs :: BS.ByteString - -> Parser ([String], Either (DocH mod Identifier) a) +innerParagraphs :: Text + -> Parser ([Text], Either (DocH mod Identifier) a) innerParagraphs indent = (,) [] . Left <$> ("\n" *> indentedParagraphs indent) -- | Attempts to fetch the next list if possibly. Used by 'innerList' and -- 'definitionList' to recursively grab lists that aren't separated by a whole -- paragraph. -moreListItems :: BS.ByteString -> Parser a - -> Parser ([String], Either (DocH mod Identifier) a) +moreListItems :: Text -> Parser a + -> Parser ([Text], Either (DocH mod Identifier) a) moreListItems indent item = (,) [] . Right <$> indentedItem where - indentedItem = string indent *> skipSpace *> item + indentedItem = string indent *> Parsec.spaces *> item -- | Helper for 'innerList' and 'definitionList' which simply takes -- a line of text and attempts to parse more list content with 'more'. -moreContent :: Monoid a => BS.ByteString -> Parser a - -> Parser ([String], Either (DocH mod Identifier) a) +moreContent :: Monoid a => Text -> Parser a + -> Parser ([Text], Either (DocH mod Identifier) a) moreContent indent item = first . (:) <$> nonEmptyLine <*> more indent item -- | Parses an indented paragraph. -- The indentation is 4 spaces. -indentedParagraphs :: BS.ByteString -> Parser (DocH mod Identifier) +indentedParagraphs :: Text -> Parser (DocH mod Identifier) indentedParagraphs indent = - (concat <$> dropFrontOfPara indent') >>= parseParagraphs + (T.unpack . T.concat <$> dropFrontOfPara indent') >>= parseParagraphs where - indent' = string $ BS.append indent " " + indent' = string $ indent <> " " -- | Grab as many fully indented paragraphs as we can. -dropFrontOfPara :: Parser BS.ByteString -> Parser [String] +dropFrontOfPara :: Parser Text -> Parser [Text] dropFrontOfPara sp = do - currentParagraph <- some (sp *> takeNonEmptyLine) + currentParagraph <- some (try (sp *> takeNonEmptyLine)) followingParagraphs <- - skipHorizontalSpace *> nextPar -- we have more paragraphs to take - <|> skipHorizontalSpace *> nlList -- end of the ride, remember the newline - <|> endOfInput *> return [] -- nothing more to take at all + choice' [ skipHorizontalSpace *> nextPar -- we have more paragraphs to take + , skipHorizontalSpace *> nlList -- end of the ride, remember the newline + , Parsec.eof *> return [] -- nothing more to take at all + ] return (currentParagraph ++ followingParagraphs) where nextPar = (++) <$> nlList <*> dropFrontOfPara sp nlList = "\n" *> return ["\n"] -nonSpace :: BS.ByteString -> Parser BS.ByteString +nonSpace :: Text -> Parser Text nonSpace xs - | not $ any (not . isSpace) $ decodeUtf8 xs = fail "empty line" + | T.all isSpace xs = fail "empty line" | otherwise = return xs -- | Takes a non-empty, not fully whitespace line. -- -- Doesn't discard the trailing newline. -takeNonEmptyLine :: Parser String +takeNonEmptyLine :: Parser Text takeNonEmptyLine = do - (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n" + l <- takeWhile1 (Parsec.noneOf "\n") >>= nonSpace + _ <- "\n" + pure (l <> "\n") -- | Takes indentation of first non-empty line. -- -- More precisely: skips all whitespace-only lines and returns indentation -- (horizontal space, might be empty) of that non-empty line. -takeIndent :: Parser BS.ByteString +takeIndent :: Parser Text takeIndent = do indent <- takeHorizontalSpace - "\n" *> takeIndent <|> return indent + choice' [ "\n" *> takeIndent + , return indent + ] -- | Blocks of text of the form: -- @@ -647,97 +684,98 @@ takeIndent = do -- >> baz -- birdtracks :: Parser (DocH mod a) -birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line +birdtracks = DocCodeBlock . DocString . T.unpack . T.intercalate "\n" . stripSpace <$> some line where - line = skipHorizontalSpace *> ">" *> takeLine + line = try (skipHorizontalSpace *> ">" *> takeLine) -stripSpace :: [String] -> [String] +stripSpace :: [Text] -> [Text] stripSpace = fromMaybe <*> mapM strip' where - strip' (' ':xs') = Just xs' - strip' "" = Just "" - strip' _ = Nothing + strip' t = case T.uncons t of + Nothing -> Just "" + Just (' ',t') -> Just t' + _ -> Nothing -- | Parses examples. Examples are a paragraph level entitity (separated by an empty line). -- Consecutive examples are accepted. examples :: Parser (DocH mod a) -examples = DocExamples <$> (many (skipHorizontalSpace *> "\n") *> go) +examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go) where go :: Parser [Example] go = do - prefix <- decodeUtf8 <$> takeHorizontalSpace <* ">>>" + prefix <- takeHorizontalSpace <* ">>>" expr <- takeLine (rs, es) <- resultAndMoreExamples return (makeExample prefix expr rs : es) where - resultAndMoreExamples :: Parser ([String], [Example]) - resultAndMoreExamples = moreExamples <|> result <|> pure ([], []) + resultAndMoreExamples :: Parser ([Text], [Example]) + resultAndMoreExamples = choice' [ moreExamples, result, pure ([], []) ] where - moreExamples :: Parser ([String], [Example]) + moreExamples :: Parser ([Text], [Example]) moreExamples = (,) [] <$> go - result :: Parser ([String], [Example]) + result :: Parser ([Text], [Example]) result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples - makeExample :: String -> String -> [String] -> Example + makeExample :: Text -> Text -> [Text] -> Example makeExample prefix expression res = - Example (strip expression) result + Example (T.unpack (T.strip expression)) result where - result = map (substituteBlankLine . tryStripPrefix) res + result = map (T.unpack . substituteBlankLine . tryStripPrefix) res - tryStripPrefix xs = fromMaybe xs (stripPrefix prefix xs) + tryStripPrefix xs = fromMaybe xs (T.stripPrefix prefix xs) substituteBlankLine "" = "" substituteBlankLine xs = xs -nonEmptyLine :: Parser String -nonEmptyLine = mfilter (any (not . isSpace)) takeLine +nonEmptyLine :: Parser Text +nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine) -takeLine :: Parser String -takeLine = decodeUtf8 <$> takeWhile (/= '\n') <* endOfLine +takeLine :: Parser Text +takeLine = try (takeWhile (Parsec.noneOf "\n") <* endOfLine) endOfLine :: Parser () -endOfLine = void "\n" <|> endOfInput +endOfLine = void "\n" <|> Parsec.eof -- | Property parser. -- -- >>> snd <$> parseOnly property "prop> hello world" -- Right (DocProperty "hello world") property :: Parser (DocH mod a) -property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n')) +property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (Parsec.noneOf "\n")) -- | -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed -- for markup. codeblock :: Parser (DocH mod Identifier) codeblock = - DocCodeBlock . parseStringBS . dropSpaces + DocCodeBlock . parseParagraph . dropSpaces <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where dropSpaces xs = - let rs = decodeUtf8 xs - in case splitByNl rs of + case splitByNl xs of [] -> xs - ys -> case last ys of - ' ':_ -> case mapM dropSpace ys of - Nothing -> xs - Just zs -> encodeUtf8 $ intercalate "\n" zs + ys -> case T.uncons (last ys) of + Just (' ',_) -> case mapM dropSpace ys of + Nothing -> xs + Just zs -> T.intercalate "\n" zs _ -> xs -- This is necessary because ‘lines’ swallows up a trailing newline -- and we lose information about whether the last line belongs to @ or to -- text which we need to decide whether we actually want to be dropping -- anything at all. - splitByNl = unfoldr (\x -> case x of - '\n':s -> Just (span (/= '\n') s) - _ -> Nothing) - . ('\n' :) + splitByNl = unfoldr (\x -> case T.uncons x of + Just ('\n',x') -> Just (T.span (/= '\n') x') + _ -> Nothing) + . ("\n" <>) - dropSpace "" = Just "" - dropSpace (' ':xs) = Just xs - dropSpace _ = Nothing + dropSpace t = case T.uncons t of + Nothing -> Just "" + Just (' ',t') -> Just t' + _ -> Nothing - block' = scan False p + block' = scan p False where p isNewline c | isNewline && c == '@' = Nothing @@ -745,11 +783,11 @@ codeblock = | otherwise = Just $ c == '\n' hyperlink :: Parser (DocH mod a) -hyperlink = angleBracketLink <|> markdownLink <|> autoUrl +hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = - DocHyperlink . makeLabeled Hyperlink . decodeUtf8 + DocHyperlink . makeLabeled Hyperlink <$> disallowNewline ("<" *> takeUntil ">") markdownLink :: Parser (DocH mod a) @@ -759,7 +797,7 @@ linkParser :: Parser Hyperlink linkParser = flip Hyperlink <$> label <*> (whitespace *> url) where label :: Parser (Maybe String) - label = Just . strip . decode <$> ("[" *> takeUntil "]") + label = Just . decode . T.strip <$> ("[" *> takeUntil "]") whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) @@ -770,19 +808,25 @@ linkParser = flip Hyperlink <$> label <*> (whitespace *> url) rejectWhitespace :: MonadPlus m => m String -> m String rejectWhitespace = mfilter (all (not . isSpace)) - decode :: BS.ByteString -> String - decode = removeEscapes . decodeUtf8 + decode :: Text -> String + decode = T.unpack . removeEscapes -- | Looks for URL-like things to automatically hyperlink even if they -- weren't marked as links. autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url where - url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace) - mkLink :: BS.ByteString -> DocH mod a - mkLink s = case unsnoc s of - Just (xs, x) | inClass ",.!?" x -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x] - _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing) + url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (Parsec.satisfy (not . isSpace)) + + mkLink :: Text -> DocH mod a + mkLink s = case T.unsnoc s of + Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x] + _ -> DocHyperlink (mkHyperlink s) + + mkHyperlink :: Text -> Hyperlink + mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing + + -- | Parses strings between identifier delimiters. Consumes all input that it -- deems to be valid in an identifier. Note that it simply blindly consumes @@ -790,14 +834,14 @@ autoUrl = mkLink <$> url parseValid :: Parser String parseValid = p some where - idChar = satisfyUnicode (\c -> isAlphaNum c || isSymbolChar c || c == '_') + idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') p p' = do vs <- p' idChar c <- peekChar' case c of '`' -> return vs - '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> p many') <|> return vs + '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] _ -> fail "outofvalid" -- | Parses identifiers with help of 'parseValid'. Asks GHC for @@ -809,4 +853,4 @@ identifier = do e <- idDelim return $ DocIdentifier (o, vid, e) where - idDelim = satisfy (\c -> c == '\'' || c == '`') + idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index ff6101da..585c76bb 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -1,48 +1,24 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} -module Documentation.Haddock.Parser.Monad ( - module Documentation.Haddock.Parser.Monad -, Attoparsec.isDigit -, Attoparsec.isDigit_w8 -, Attoparsec.isAlpha_iso8859_15 -, Attoparsec.isAlpha_ascii -, Attoparsec.isSpace -, Attoparsec.isSpace_w8 -, Attoparsec.inClass -, Attoparsec.notInClass -, Attoparsec.isEndOfLine -, Attoparsec.isHorizontalSpace -, Attoparsec.choice -, Attoparsec.count -, Attoparsec.option -, Attoparsec.many' -, Attoparsec.many1 -, Attoparsec.many1' -, Attoparsec.manyTill -, Attoparsec.manyTill' -, Attoparsec.sepBy -, Attoparsec.sepBy' -, Attoparsec.sepBy1 -, Attoparsec.sepBy1' -, Attoparsec.skipMany -, Attoparsec.skipMany1 -, Attoparsec.eitherP -) where - -import Control.Applicative -import Control.Monad -import Data.String -import Data.ByteString (ByteString, length) -import qualified Data.ByteString.Lazy as LB -import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec -import qualified Data.Attoparsec.Combinator as Attoparsec -import Control.Monad.Trans.State -import qualified Control.Monad.Trans.Class as Trans -import Data.Word -import Data.Bits -import Data.Tuple - -import Documentation.Haddock.Types (Version) -import Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Documentation.Haddock.Parser.Monad where + +import qualified Text.Parsec.Char as Parsec +import qualified Text.Parsec as Parsec + +import qualified Data.Text as T +import Data.Text ( Text ) + +import Data.String ( IsString(..) ) +import Data.Bits ( Bits(..) ) +import Data.Char ( ord ) +import Data.List ( foldl' ) + +import Documentation.Haddock.Types ( Version ) newtype ParserState = ParserState { parserStateSince :: Maybe Version @@ -51,120 +27,65 @@ newtype ParserState = ParserState { initialParserState :: ParserState initialParserState = ParserState Nothing -newtype Parser a = Parser (StateT ParserState Attoparsec.Parser a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus) - -instance (a ~ ByteString) => IsString (Parser a) where - fromString = lift . fromString - -parseOnly :: Parser a -> ByteString -> Either String (ParserState, a) -parseOnly (Parser p) = fmap swap . Attoparsec.parseOnly (runStateT p initialParserState) +setSince :: Version -> Parser () +setSince since = Parsec.modifyState (\st -> st {parserStateSince = Just since}) -lift :: Attoparsec.Parser a -> Parser a -lift = Parser . Trans.lift +type Parser = Parsec.Parsec Text ParserState -setParserState :: ParserState -> Parser () -setParserState = Parser . put +instance (a ~ Text) => IsString (Parser a) where + fromString = fmap T.pack . Parsec.string -setSince :: Version -> Parser () -setSince since = Parser $ modify (\st -> st {parserStateSince = Just since}) - -char :: Char -> Parser Char -char = lift . Attoparsec.char - -char8 :: Char -> Parser Word8 -char8 = lift . Attoparsec.char8 - --- | Peek a unicode character and return the number of bytes that it took up -peekUnicode :: Parser (Char, Int) -peekUnicode = lift $ Attoparsec.lookAhead $ do - - -- attoparsec's take fails on shorter inputs rather than truncate - bs <- Attoparsec.choice (map Attoparsec.take [4,3,2,1]) - - let c = head . decodeUtf8 $ bs - n = Data.ByteString.length . encodeUtf8 $ [c] - pure (c, fromIntegral n) - --- | Like 'satisfy', but consuming a unicode character -satisfyUnicode :: (Char -> Bool) -> Parser Char -satisfyUnicode predicate = do - (c,n) <- peekUnicode - if predicate c - then Documentation.Haddock.Parser.Monad.take n *> pure c - else fail "satsifyUnicode" - -anyChar :: Parser Char -anyChar = lift Attoparsec.anyChar - -notChar :: Char -> Parser Char -notChar = lift . Attoparsec.notChar - -satisfy :: (Char -> Bool) -> Parser Char -satisfy = lift . Attoparsec.satisfy +parseOnly :: Parser a -> Text -> Either String (ParserState, a) +parseOnly p t = case Parsec.runParser p' initialParserState "" t of + Left e -> Left (show e) + Right (x,s) -> Right (s,x) + where p' = (,) <$> p <*> Parsec.getState +-- | Always succeeds, but returns 'Nothing' if at the end of input. Does not +-- consume input. peekChar :: Parser (Maybe Char) -peekChar = lift Attoparsec.peekChar +peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar +-- | Fails if at the end of input. Does not consume input. peekChar' :: Parser Char -peekChar' = lift Attoparsec.peekChar' - -digit :: Parser Char -digit = lift Attoparsec.digit - -letter_iso8859_15 :: Parser Char -letter_iso8859_15 = lift Attoparsec.letter_iso8859_15 - -letter_ascii :: Parser Char -letter_ascii = lift Attoparsec.letter_ascii - -space :: Parser Char -space = lift Attoparsec.space - -string :: ByteString -> Parser ByteString -string = lift . Attoparsec.string - -stringCI :: ByteString -> Parser ByteString -stringCI = lift . Attoparsec.stringCI - -skipSpace :: Parser () -skipSpace = lift Attoparsec.skipSpace - -skipWhile :: (Char -> Bool) -> Parser () -skipWhile = lift . Attoparsec.skipWhile - -take :: Int -> Parser ByteString -take = lift . Attoparsec.take - -scan :: s -> (s -> Char -> Maybe s) -> Parser ByteString -scan s = lift . Attoparsec.scan s - -takeWhile :: (Char -> Bool) -> Parser ByteString -takeWhile = lift . Attoparsec.takeWhile - -takeWhile1 :: (Char -> Bool) -> Parser ByteString -takeWhile1 = lift . Attoparsec.takeWhile1 - -takeTill :: (Char -> Bool) -> Parser ByteString -takeTill = lift . Attoparsec.takeTill - -takeByteString :: Parser ByteString -takeByteString = lift Attoparsec.takeByteString - -takeLazyByteString :: Parser LB.ByteString -takeLazyByteString = lift Attoparsec.takeLazyByteString - -endOfLine :: Parser () -endOfLine = lift Attoparsec.endOfLine - +peekChar' = Parsec.lookAhead Parsec.anyChar + +-- | Parses the given string. Returns the parsed string. +string :: Text -> Parser Text +string t = Parsec.string (T.unpack t) *> pure t + +-- | Scan the input text, accumulating characters as long as the scanning +-- function returns true. +scan :: (s -> Char -> Maybe s) -- ^ scan function + -> s -- ^ initial state + -> Parser Text +scan f = fmap T.pack . go + where go s1 = do { cOpt <- peekChar + ; case cOpt >>= f s1 of + Nothing -> pure "" + Just s2 -> (:) <$> Parsec.anyChar <*> go s2 + } + +-- | Apply a parser for a character zero or more times and collect the result in +-- a string. +takeWhile :: Parser Char -> Parser Text +takeWhile = fmap T.pack . Parsec.many + +-- | Apply a parser for a character one or more times and collect the result in +-- a string. +takeWhile1 :: Parser Char -> Parser Text +takeWhile1 = fmap T.pack . Parsec.many1 + +-- | Parse a decimal number. decimal :: Integral a => Parser a -decimal = lift Attoparsec.decimal +decimal = foldl' step 0 `fmap` Parsec.many1 Parsec.digit + where step a c = a * 10 + fromIntegral (ord c - 48) +-- | Parse a hexadecimal number. hexadecimal :: (Integral a, Bits a) => Parser a -hexadecimal = lift Attoparsec.hexadecimal - -endOfInput :: Parser () -endOfInput = lift Attoparsec.endOfInput - -atEnd :: Parser Bool -atEnd = lift Attoparsec.atEnd +hexadecimal = foldl' step 0 `fmap` Parsec.many1 Parsec.hexDigit + where + step a c | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48) + | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87) + | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55) + where w = ord c diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs index ab5e5e9e..ffa91b09 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Documentation.Haddock.Parser.Util -- Copyright : (c) Mateusz Kowalczyk 2013-2014, @@ -11,62 +11,59 @@ -- -- Various utility functions used by the parser. module Documentation.Haddock.Parser.Util ( - unsnoc -, strip -, takeUntil -, removeEscapes -, makeLabeled -, takeHorizontalSpace -, skipHorizontalSpace + takeUntil, + removeEscapes, + makeLabeled, + takeHorizontalSpace, + skipHorizontalSpace, ) where +import qualified Text.Parsec as Parsec + +import qualified Data.Text as T +import Data.Text (Text) + import Control.Applicative import Control.Monad (mfilter) -import Documentation.Haddock.Parser.Monad hiding (isHorizontalSpace) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS +import Documentation.Haddock.Parser.Monad import Prelude hiding (takeWhile) -#if MIN_VERSION_bytestring(0,10,2) -import Data.ByteString.Char8 (unsnoc) -#else -unsnoc :: ByteString -> Maybe (ByteString, Char) -unsnoc bs - | BS.null bs = Nothing - | otherwise = Just (BS.init bs, BS.last bs) -#endif +import Data.Char (isSpace) --- | Remove all leading and trailing whitespace -strip :: String -> String -strip = (\f -> f . f) $ dropWhile isSpace . reverse - -isHorizontalSpace :: Char -> Bool -isHorizontalSpace = inClass " \t\f\v\r" +-- | Characters that count as horizontal space +horizontalSpace :: [Char] +horizontalSpace = " \t\f\v\r" +-- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser () -skipHorizontalSpace = skipWhile isHorizontalSpace +skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) -takeHorizontalSpace :: Parser BS.ByteString -takeHorizontalSpace = takeWhile isHorizontalSpace +-- | Take leading horizontal space +takeHorizontalSpace :: Parser Text +takeHorizontalSpace = takeWhile (Parsec.oneOf horizontalSpace) -makeLabeled :: (String -> Maybe String -> a) -> String -> a -makeLabeled f input = case break isSpace $ removeEscapes $ strip input of - (uri, "") -> f uri Nothing - (uri, label) -> f uri (Just $ dropWhile isSpace label) +makeLabeled :: (String -> Maybe String -> a) -> Text -> a +makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of + (uri, "") -> f (T.unpack uri) Nothing + (uri, label) -> f (T.unpack uri) (Just . T.unpack $ T.stripStart label) -- | Remove escapes from given string. -- -- Only do this if you do not process (read: parse) the input any further. -removeEscapes :: String -> String -removeEscapes "" = "" -removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs -removeEscapes ('\\':xs) = removeEscapes xs -removeEscapes (x:xs) = x : removeEscapes xs +removeEscapes :: Text -> Text +removeEscapes = T.unfoldr go + where + go :: Text -> Maybe (Char, Text) + go xs = case T.uncons xs of + Just ('\\',ys) -> T.uncons ys + unconsed -> unconsed -takeUntil :: ByteString -> Parser ByteString -takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome +-- | Consume characters from the input up to and including the given pattern. +-- Return everything consumed except for the end pattern itself. +takeUntil :: Text -> Parser Text +takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome where - end = BS.unpack end_ + end = T.unpack end_ p :: (Bool, String) -> Char -> Maybe (Bool, String) p acc c = case acc of @@ -75,9 +72,8 @@ takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome (_, x:xs) | x == c -> Just (False, xs) _ -> Just (c == '\\', end) - dropEnd = BS.reverse . BS.drop (length end) . BS.reverse - requireEnd = mfilter (BS.isSuffixOf end_) + requireEnd = mfilter (T.isSuffixOf end_) gotSome xs - | BS.null xs = fail "didn't get any content" + | T.null xs = fail "didn't get any content" | otherwise = return xs diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs deleted file mode 100644 index bd3c5592..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | --- Module : Data.Attoparsec --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient combinator parsing for --- 'Data.ByteString.ByteString' strings, loosely based on the Parsec --- library. --- --- This module is deprecated. Use "Data.Attoparsec.ByteString" --- instead. - -module Data.Attoparsec - {-# DEPRECATED "This module will be removed in the next major release." #-} - ( - module Data.Attoparsec.ByteString - ) where - -import Data.Attoparsec.ByteString diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs deleted file mode 100644 index 84e567d9..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif --- | --- Module : Data.Attoparsec.ByteString --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient combinator parsing for 'B.ByteString' strings, --- loosely based on the Parsec library. - -module Data.Attoparsec.ByteString - ( - -- * Differences from Parsec - -- $parsec - - -- * Incremental input - -- $incremental - - -- * Performance considerations - -- $performance - - -- * Parser types - I.Parser - , Result - , T.IResult(..) - , I.compareResults - - -- * Running parsers - , parse - , feed - , I.parseOnly - , parseWith - , parseTest - - -- ** Result conversion - , maybeResult - , eitherResult - - -- * Parsing individual bytes - , I.word8 - , I.anyWord8 - , I.notWord8 - , I.satisfy - , I.satisfyWith - , I.skip - - -- ** Lookahead - , I.peekWord8 - , I.peekWord8' - - -- ** Byte classes - , I.inClass - , I.notInClass - - -- * Efficient string handling - , I.string - , I.skipWhile - , I.take - , I.scan - , I.runScanner - , I.takeWhile - , I.takeWhile1 - , I.takeTill - - -- ** Consume all remaining input - , I.takeByteString - , I.takeLazyByteString - - -- * Combinators - , try - , () - , choice - , count - , option - , many' - , many1 - , many1' - , manyTill - , manyTill' - , sepBy - , sepBy' - , sepBy1 - , sepBy1' - , skipMany - , skipMany1 - , eitherP - , I.match - -- * State observation and manipulation functions - , I.endOfInput - , I.atEnd - ) where - -import Data.Attoparsec.Combinator -import Data.List (intercalate) -import qualified Data.Attoparsec.ByteString.Internal as I -import qualified Data.Attoparsec.Internal as I -import qualified Data.ByteString as B -import Data.Attoparsec.ByteString.Internal (Result, parse) -import qualified Data.Attoparsec.Internal.Types as T - --- $parsec --- --- Compared to Parsec 3, attoparsec makes several tradeoffs. It is --- not intended for, or ideal for, all possible uses. --- --- * While attoparsec can consume input incrementally, Parsec cannot. --- Incremental input is a huge deal for efficient and secure network --- and system programming, since it gives much more control to users --- of the library over matters such as resource usage and the I/O --- model to use. --- --- * Much of the performance advantage of attoparsec is gained via --- high-performance parsers such as 'I.takeWhile' and 'I.string'. --- If you use complicated combinators that return lists of bytes or --- characters, there is less performance difference between the two --- libraries. --- --- * Unlike Parsec 3, attoparsec does not support being used as a --- monad transformer. --- --- * attoparsec is specialised to deal only with strict 'B.ByteString' --- input. Efficiency concerns rule out both lists and lazy --- bytestrings. The usual use for lazy bytestrings would be to --- allow consumption of very large input without a large footprint. --- For this need, attoparsec's incremental input provides an --- excellent substitute, with much more control over when input --- takes place. If you must use lazy bytestrings, see the --- "Data.Attoparsec.ByteString.Lazy" module, which feeds lazy chunks --- to a regular parser. --- --- * Parsec parsers can produce more helpful error messages than --- attoparsec parsers. This is a matter of focus: attoparsec avoids --- the extra book-keeping in favour of higher performance. - --- $incremental --- --- attoparsec supports incremental input, meaning that you can feed it --- a bytestring that represents only part of the expected total amount --- of data to parse. If your parser reaches the end of a fragment of --- input and could consume more input, it will suspend parsing and --- return a 'T.Partial' continuation. --- --- Supplying the 'T.Partial' continuation with a bytestring will --- resume parsing at the point where it was suspended, with the --- bytestring you supplied used as new input at the end of the --- existing input. You must be prepared for the result of the resumed --- parse to be another 'T.Partial' continuation. --- --- To indicate that you have no more input, supply the 'T.Partial' --- continuation with an empty bytestring. --- --- Remember that some parsing combinators will not return a result --- until they reach the end of input. They may thus cause 'T.Partial' --- results to be returned. --- --- If you do not need support for incremental input, consider using --- the 'I.parseOnly' function to run your parser. It will never --- prompt for more input. --- --- /Note/: incremental input does /not/ imply that attoparsec will --- release portions of its internal state for garbage collection as it --- proceeds. Its internal representation is equivalent to a single --- 'ByteString': if you feed incremental input to a parser, it will --- require memory proportional to the amount of input you supply. --- (This is necessary to support arbitrary backtracking.) - --- $performance --- --- If you write an attoparsec-based parser carefully, it can be --- realistic to expect it to perform similarly to a hand-rolled C --- parser (measuring megabytes parsed per second). --- --- To actually achieve high performance, there are a few guidelines --- that it is useful to follow. --- --- Use the 'B.ByteString'-oriented parsers whenever possible, --- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'. There is --- about a factor of 100 difference in performance between the two --- kinds of parser. --- --- For very simple byte-testing predicates, write them by hand instead --- of using 'I.inClass' or 'I.notInClass'. For instance, both of --- these predicates test for an end-of-line byte, but the first is --- much faster than the second: --- --- >endOfLine_fast w = w == 13 || w == 10 --- >endOfLine_slow = inClass "\r\n" --- --- Make active use of benchmarking and profiling tools to measure, --- find the problems with, and improve the performance of your parser. - --- | Run a parser and print its result to standard output. -parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO () -parseTest p s = print (parse p s) - --- | Run a parser with an initial input string, and a monadic action --- that can supply more input if needed. -parseWith :: Monad m => - (m B.ByteString) - -- ^ An action that will be executed to provide the parser - -- with more input, if necessary. The action must return an - -- 'B.empty' string when there is no more input available. - -> I.Parser a - -> B.ByteString - -- ^ Initial input for the parser. - -> m (Result a) -parseWith refill p s = step $ parse p s - where step (T.Partial k) = (step . k) =<< refill - step r = return r -{-# INLINE parseWith #-} - --- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result --- is treated as failure. -maybeResult :: Result r -> Maybe r -maybeResult (T.Done _ r) = Just r -maybeResult _ = Nothing - --- | Convert a 'Result' value to an 'Either' value. A 'T.Partial' --- result is treated as failure. -eitherResult :: Result r -> Either String r -eitherResult (T.Done _ r) = Right r -eitherResult (T.Fail _ [] msg) = Left msg -eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg) -eitherResult _ = Left "Result: incomplete input" diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs deleted file mode 100644 index ac94dfcc..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- | --- Module : Data.Attoparsec.ByteString.Buffer --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC --- --- An "immutable" buffer that supports cheap appends. --- --- A Buffer is divided into an immutable read-only zone, followed by a --- mutable area that we've preallocated, but not yet written to. --- --- We overallocate at the end of a Buffer so that we can cheaply --- append. Since a user of an existing Buffer cannot see past the end --- of its immutable zone into the data that will change during an --- append, this is safe. --- --- Once we run out of space at the end of a Buffer, we do the usual --- doubling of the buffer size. --- --- The fact of having a mutable buffer really helps with performance, --- but it does have a consequence: if someone misuses the Partial API --- that attoparsec uses by calling the same continuation repeatedly --- (which never makes sense in practice), they could overwrite data. --- --- Since the API *looks* pure, it should *act* pure, too, so we use --- two generation counters (one mutable, one immutable) to track the --- number of appends to a mutable buffer. If the counters ever get out --- of sync, someone is appending twice to a mutable buffer, so we --- duplicate the entire buffer in order to preserve the immutability --- of its older self. --- --- While we could go a step further and gain protection against API --- abuse on a multicore system, by use of an atomic increment --- instruction to bump the mutable generation counter, that would be --- very expensive, and feels like it would also be in the realm of the --- ridiculous. Clients should never call a continuation more than --- once; we lack a linear type system that could enforce this; and --- there's only so far we should go to accommodate broken uses. - -module Data.Attoparsec.ByteString.Buffer - ( - Buffer - , buffer - , unbuffer - , pappend - , length - , unsafeIndex - , substring - , unsafeDrop - ) where - -import Control.Exception (assert) -import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr) -import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO) -import Data.List (foldl1') -import Data.Monoid as Mon (Monoid(..)) -import Data.Semigroup (Semigroup(..)) -import Data.Word (Word8) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (castPtr, plusPtr) -import Foreign.Storable (peek, peekByteOff, poke, sizeOf) -import GHC.ForeignPtr (mallocPlainForeignPtrBytes) -import Prelude hiding (length) - --- If _cap is zero, this buffer is empty. -data Buffer = Buf { - _fp :: {-# UNPACK #-} !(ForeignPtr Word8) - , _off :: {-# UNPACK #-} !Int - , _len :: {-# UNPACK #-} !Int - , _cap :: {-# UNPACK #-} !Int - , _gen :: {-# UNPACK #-} !Int - } - -instance Show Buffer where - showsPrec p = showsPrec p . unbuffer - --- | The initial 'Buffer' has no mutable zone, so we can avoid all --- copies in the (hopefully) common case of no further input being fed --- to us. -buffer :: ByteString -> Buffer -buffer (PS fp off len) = Buf fp off len len 0 - -unbuffer :: Buffer -> ByteString -unbuffer (Buf fp off len _ _) = PS fp off len - -instance Semigroup Buffer where - (Buf _ _ _ 0 _) <> b = b - a <> (Buf _ _ _ 0 _) = a - buf <> (Buf fp off len _ _) = append buf fp off len - -instance Monoid Buffer where - mempty = Buf nullForeignPtr 0 0 0 0 - - mappend = (<>) - - mconcat [] = Mon.mempty - mconcat xs = foldl1' mappend xs - -pappend :: Buffer -> ByteString -> Buffer -pappend (Buf _ _ _ 0 _) bs = buffer bs -pappend buf (PS fp off len) = append buf fp off len - -append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer -append (Buf fp0 off0 len0 cap0 gen0) !fp1 !off1 !len1 = - inlinePerformIO . withForeignPtr fp0 $ \ptr0 -> - withForeignPtr fp1 $ \ptr1 -> do - let genSize = sizeOf (0::Int) - newlen = len0 + len1 - gen <- if gen0 == 0 - then return 0 - else peek (castPtr ptr0) - if gen == gen0 && newlen <= cap0 - then do - let newgen = gen + 1 - poke (castPtr ptr0) newgen - memcpy (ptr0 `plusPtr` (off0+len0)) - (ptr1 `plusPtr` off1) - (fromIntegral len1) - return (Buf fp0 off0 newlen cap0 newgen) - else do - let newcap = newlen * 2 - fp <- mallocPlainForeignPtrBytes (newcap + genSize) - withForeignPtr fp $ \ptr_ -> do - let ptr = ptr_ `plusPtr` genSize - newgen = 1 - poke (castPtr ptr_) newgen - memcpy ptr (ptr0 `plusPtr` off0) (fromIntegral len0) - memcpy (ptr `plusPtr` len0) (ptr1 `plusPtr` off1) - (fromIntegral len1) - return (Buf fp genSize newlen newcap newgen) - -length :: Buffer -> Int -length (Buf _ _ len _ _) = len -{-# INLINE length #-} - -unsafeIndex :: Buffer -> Int -> Word8 -unsafeIndex (Buf fp off len _ _) i = assert (i >= 0 && i < len) . - inlinePerformIO . withForeignPtr fp $ flip peekByteOff (off+i) -{-# INLINE unsafeIndex #-} - -substring :: Int -> Int -> Buffer -> ByteString -substring s l (Buf fp off len _ _) = - assert (s >= 0 && s <= len) . - assert (l >= 0 && l <= len-s) $ - PS fp (off+s) l -{-# INLINE substring #-} - -unsafeDrop :: Int -> Buffer -> ByteString -unsafeDrop s (Buf fp off len _ _) = - assert (s >= 0 && s <= len) $ - PS fp (off+s) (len-s) -{-# INLINE unsafeDrop #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs deleted file mode 100644 index 7fafba40..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, TypeFamilies, - TypeSynonymInstances, GADTs #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -- Imports internal modules -#endif -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} - --- | --- Module : Data.Attoparsec.ByteString.Char8 --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient, character-oriented combinator parsing for --- 'B.ByteString' strings, loosely based on the Parsec library. - -module Data.Attoparsec.ByteString.Char8 - ( - -- * Character encodings - -- $encodings - - -- * Parser types - Parser - , A.Result - , A.IResult(..) - , I.compareResults - - -- * Running parsers - , A.parse - , A.feed - , A.parseOnly - , A.parseWith - , A.parseTest - - -- ** Result conversion - , A.maybeResult - , A.eitherResult - - -- * Parsing individual characters - , char - , char8 - , anyChar - , notChar - , satisfy - - -- ** Lookahead - , peekChar - , peekChar' - - -- ** Special character parsers - , digit - , letter_iso8859_15 - , letter_ascii - , space - - -- ** Fast predicates - , isDigit - , isDigit_w8 - , isAlpha_iso8859_15 - , isAlpha_ascii - , isSpace - , isSpace_w8 - - -- *** Character classes - , inClass - , notInClass - - -- * Efficient string handling - , I.string - , I.stringCI - , skipSpace - , skipWhile - , I.take - , scan - , takeWhile - , takeWhile1 - , takeTill - - -- ** String combinators - -- $specalt - , (.*>) - , (<*.) - - -- ** Consume all remaining input - , I.takeByteString - , I.takeLazyByteString - - -- * Text parsing - , I.endOfLine - , isEndOfLine - , isHorizontalSpace - - -- * Numeric parsers - , decimal - , hexadecimal - , signed - - -- * Combinators - , try - , () - , choice - , count - , option - , many' - , many1 - , many1' - , manyTill - , manyTill' - , sepBy - , sepBy' - , sepBy1 - , sepBy1' - , skipMany - , skipMany1 - , eitherP - , I.match - -- * State observation and manipulation functions - , I.endOfInput - , I.atEnd - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (*>), (<*), (<$>)) -import Data.Word (Word) -#endif -import Control.Applicative ((<|>)) -import Data.Attoparsec.ByteString.FastSet (charClass, memberChar) -import Data.Attoparsec.ByteString.Internal (Parser) -import Data.Attoparsec.Combinator -import Data.Bits (Bits, (.|.), shiftL) -import Data.ByteString.Internal (c2w, w2c) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.String (IsString(..)) -import Data.Word (Word8, Word16, Word32, Word64) -import Prelude hiding (takeWhile) -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString.Internal as I -import qualified Data.Attoparsec.Internal as I -import qualified Data.ByteString as B8 -import qualified Data.ByteString.Char8 as B - -instance (a ~ B.ByteString) => IsString (Parser a) where - fromString = I.string . B.pack - --- $encodings --- --- This module is intended for parsing text that is --- represented using an 8-bit character set, e.g. ASCII or --- ISO-8859-15. It /does not/ make any attempt to deal with character --- encodings, multibyte characters, or wide characters. In --- particular, all attempts to use characters above code point U+00FF --- will give wrong answers. --- --- Code points below U+0100 are simply translated to and from their --- numeric values, so e.g. the code point U+00A4 becomes the byte --- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic --- currency sign in ISO-8859-1). Haskell 'Char' values above U+00FF --- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@. - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser requires the predicate to succeed on at least one byte --- of input: it will fail if the predicate never returns 'True' or if --- there is no input left. -takeWhile1 :: (Char -> Bool) -> Parser B.ByteString -takeWhile1 p = I.takeWhile1 (p . w2c) -{-# INLINE takeWhile1 #-} - --- | The parser @satisfy p@ succeeds for any byte for which the --- predicate @p@ returns 'True'. Returns the byte that is actually --- parsed. --- --- >digit = satisfy isDigit --- > where isDigit c = c >= '0' && c <= '9' -satisfy :: (Char -> Bool) -> Parser Char -satisfy = I.satisfyWith w2c -{-# INLINE satisfy #-} - --- | Match a letter, in the ISO-8859-15 encoding. -letter_iso8859_15 :: Parser Char -letter_iso8859_15 = satisfy isAlpha_iso8859_15 "letter_iso8859_15" -{-# INLINE letter_iso8859_15 #-} - --- | Match a letter, in the ASCII encoding. -letter_ascii :: Parser Char -letter_ascii = satisfy isAlpha_ascii "letter_ascii" -{-# INLINE letter_ascii #-} - --- | A fast alphabetic predicate for the ISO-8859-15 encoding --- --- /Note/: For all character encodings other than ISO-8859-15, and --- almost all Unicode code points above U+00A3, this predicate gives --- /wrong answers/. -isAlpha_iso8859_15 :: Char -> Bool -isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || - (c >= '\166' && moby c) - where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247" - {-# NOINLINE moby #-} -{-# INLINE isAlpha_iso8859_15 #-} - --- | A fast alphabetic predicate for the ASCII encoding --- --- /Note/: For all character encodings other than ASCII, and --- almost all Unicode code points above U+007F, this predicate gives --- /wrong answers/. -isAlpha_ascii :: Char -> Bool -isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') -{-# INLINE isAlpha_ascii #-} - --- | Parse a single digit. -digit :: Parser Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - --- | A fast digit predicate. -isDigit :: Char -> Bool -isDigit c = c >= '0' && c <= '9' -{-# INLINE isDigit #-} - --- | A fast digit predicate. -isDigit_w8 :: Word8 -> Bool -isDigit_w8 w = w - 48 <= 9 -{-# INLINE isDigit_w8 #-} - --- | Match any character. -anyChar :: Parser Char -anyChar = satisfy $ const True -{-# INLINE anyChar #-} - --- | Match any character, to perform lookahead. Returns 'Nothing' if --- end of input has been reached. Does not consume any input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -peekChar :: Parser (Maybe Char) -peekChar = (fmap w2c) `fmap` I.peekWord8 -{-# INLINE peekChar #-} - --- | Match any character, to perform lookahead. Does not consume any --- input, but will fail if end of input has been reached. -peekChar' :: Parser Char -peekChar' = w2c `fmap` I.peekWord8' -{-# INLINE peekChar' #-} - --- | Fast predicate for matching ASCII space characters. --- --- /Note/: This predicate only gives correct answers for the ASCII --- encoding. For instance, it does not recognise U+00A0 (non-breaking --- space) as a space character, even though it is a valid ISO-8859-15 --- byte. For a Unicode-aware and only slightly slower predicate, --- use 'Data.Char.isSpace' -isSpace :: Char -> Bool -isSpace c = (c == ' ') || ('\t' <= c && c <= '\r') -{-# INLINE isSpace #-} - --- | Fast 'Word8' predicate for matching ASCII space characters. -isSpace_w8 :: Word8 -> Bool -isSpace_w8 w = w == 32 || w - 9 <= 4 -{-# INLINE isSpace_w8 #-} - - --- | Parse a space character. --- --- /Note/: This parser only gives correct answers for the ASCII --- encoding. For instance, it does not recognise U+00A0 (non-breaking --- space) as a space character, even though it is a valid ISO-8859-15 --- byte. -space :: Parser Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Match a specific character. -char :: Char -> Parser Char -char c = satisfy (== c) [c] -{-# INLINE char #-} - --- | Match a specific character, but return its 'Word8' value. -char8 :: Char -> Parser Word8 -char8 c = I.satisfy (== c2w c) [c] -{-# INLINE char8 #-} - --- | Match any character except the given one. -notChar :: Char -> Parser Char -notChar c = satisfy (/= c) "not " ++ [c] -{-# INLINE notChar #-} - --- | Match any character in a set. --- --- >vowel = inClass "aeiou" --- --- Range notation is supported. --- --- >halfAlphabet = inClass "a-nA-N" --- --- To add a literal \'-\' to a set, place it at the beginning or end --- of the string. -inClass :: String -> Char -> Bool -inClass s = (`memberChar` mySet) - where mySet = charClass s -{-# INLINE inClass #-} - --- | Match any character not in a set. -notInClass :: String -> Char -> Bool -notInClass s = not . inClass s -{-# INLINE notInClass #-} - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'False' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -takeWhile :: (Char -> Bool) -> Parser B.ByteString -takeWhile p = I.takeWhile (p . w2c) -{-# INLINE takeWhile #-} - --- | A stateful scanner. The predicate consumes and transforms a --- state argument, and each transformed state is passed to successive --- invocations of the predicate on each byte of the input until one --- returns 'Nothing' or the input ends. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'Nothing' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -scan :: s -> (s -> Char -> Maybe s) -> Parser B.ByteString -scan s0 p = I.scan s0 (\s -> p s . w2c) -{-# INLINE scan #-} - --- | Consume input as long as the predicate returns 'False' --- (i.e. until it returns 'True'), and return the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'True' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -takeTill :: (Char -> Bool) -> Parser B.ByteString -takeTill p = I.takeTill (p . w2c) -{-# INLINE takeTill #-} - --- | Skip past input for as long as the predicate returns 'True'. -skipWhile :: (Char -> Bool) -> Parser () -skipWhile p = I.skipWhile (p . w2c) -{-# INLINE skipWhile #-} - --- | Skip over white space. -skipSpace :: Parser () -skipSpace = I.skipWhile isSpace_w8 -{-# INLINE skipSpace #-} - --- $specalt --- --- If you enable the @OverloadedStrings@ language extension, you can --- use the '*>' and '<*' combinators to simplify the common task of --- matching a statically known string, then immediately parsing --- something else. --- --- Instead of writing something like this: --- --- @ ---'I.string' \"foo\" '*>' wibble --- @ --- --- Using @OverloadedStrings@, you can omit the explicit use of --- 'I.string', and write a more compact version: --- --- @ --- \"foo\" '*>' wibble --- @ --- --- (Note: the '.*>' and '<*.' combinators that were originally --- provided for this purpose are obsolete and unnecessary, and will be --- removed in the next major version.) - --- | /Obsolete/. A type-specialized version of '*>' for --- 'B.ByteString'. Use '*>' instead. -(.*>) :: B.ByteString -> Parser a -> Parser a -s .*> f = I.string s *> f -{-# DEPRECATED (.*>) "This is no longer necessary, and will be removed. Use '*>' instead." #-} - --- | /Obsolete/. A type-specialized version of '<*' for --- 'B.ByteString'. Use '<*' instead. -(<*.) :: Parser a -> B.ByteString -> Parser a -f <*. s = f <* I.string s -{-# DEPRECATED (<*.) "This is no longer necessary, and will be removed. Use '<*' instead." #-} - --- | A predicate that matches either a carriage return @\'\\r\'@ or --- newline @\'\\n\'@ character. -isEndOfLine :: Word8 -> Bool -isEndOfLine w = w == 13 || w == 10 -{-# INLINE isEndOfLine #-} - --- | A predicate that matches either a space @\' \'@ or horizontal tab --- @\'\\t\'@ character. -isHorizontalSpace :: Word8 -> Bool -isHorizontalSpace w = w == 32 || w == 9 -{-# INLINE isHorizontalSpace #-} - --- | Parse and decode an unsigned hexadecimal number. The hex digits --- @\'a\'@ through @\'f\'@ may be upper or lower case. --- --- This parser does not accept a leading @\"0x\"@ string. -hexadecimal :: (Integral a, Bits a) => Parser a -hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit - where - isHexDigit w = (w >= 48 && w <= 57) || - (w >= 97 && w <= 102) || - (w >= 65 && w <= 70) - step a w | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48) - | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87) - | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55) -{-# SPECIALISE hexadecimal :: Parser Int #-} -{-# SPECIALISE hexadecimal :: Parser Int8 #-} -{-# SPECIALISE hexadecimal :: Parser Int16 #-} -{-# SPECIALISE hexadecimal :: Parser Int32 #-} -{-# SPECIALISE hexadecimal :: Parser Int64 #-} -{-# SPECIALISE hexadecimal :: Parser Integer #-} -{-# SPECIALISE hexadecimal :: Parser Word #-} -{-# SPECIALISE hexadecimal :: Parser Word8 #-} -{-# SPECIALISE hexadecimal :: Parser Word16 #-} -{-# SPECIALISE hexadecimal :: Parser Word32 #-} -{-# SPECIALISE hexadecimal :: Parser Word64 #-} - --- | Parse and decode an unsigned decimal number. -decimal :: Integral a => Parser a -decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDigit_w8 - where step a w = a * 10 + fromIntegral (w - 48) -{-# SPECIALISE decimal :: Parser Int #-} -{-# SPECIALISE decimal :: Parser Int8 #-} -{-# SPECIALISE decimal :: Parser Int16 #-} -{-# SPECIALISE decimal :: Parser Int32 #-} -{-# SPECIALISE decimal :: Parser Int64 #-} -{-# SPECIALISE decimal :: Parser Integer #-} -{-# SPECIALISE decimal :: Parser Word #-} -{-# SPECIALISE decimal :: Parser Word8 #-} -{-# SPECIALISE decimal :: Parser Word16 #-} -{-# SPECIALISE decimal :: Parser Word32 #-} -{-# SPECIALISE decimal :: Parser Word64 #-} - --- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign --- character. -signed :: Num a => Parser a -> Parser a -{-# SPECIALISE signed :: Parser Int -> Parser Int #-} -{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-} -{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-} -{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-} -{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-} -{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-} -signed p = (negate <$> (char8 '-' *> p)) - <|> (char8 '+' *> p) - <|> p - diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs deleted file mode 100644 index d15854c4..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Attoparsec.ByteString.FastSet --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Fast set membership tests for 'Word8' and 8-bit 'Char' values. The --- set representation is unboxed for efficiency. For small sets, we --- test for membership using a binary search. For larger sets, we use --- a lookup table. --- ------------------------------------------------------------------------------ -module Data.Attoparsec.ByteString.FastSet - ( - -- * Data type - FastSet - -- * Construction - , fromList - , set - -- * Lookup - , memberChar - , memberWord8 - -- * Debugging - , fromSet - -- * Handy interface - , charClass - ) where - -import Data.Bits ((.&.), (.|.)) -import Foreign.Storable (peekByteOff, pokeByteOff) -import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#) -import GHC.Word (Word8(W8#)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Internal as I -import qualified Data.ByteString.Unsafe as U - -data FastSet = Sorted { fromSet :: !B.ByteString } - | Table { fromSet :: !B.ByteString } - deriving (Eq, Ord) - -instance Show FastSet where - show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s) - show (Table _) = "FastSet Table" - --- | The lower bound on the size of a lookup table. We choose this to --- balance table density against performance. -tableCutoff :: Int -tableCutoff = 8 - --- | Create a set. -set :: B.ByteString -> FastSet -set s | B.length s < tableCutoff = Sorted . B.sort $ s - | otherwise = Table . mkTable $ s - -fromList :: [Word8] -> FastSet -fromList = set . B.pack - -data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8 - -shiftR :: Int -> Int -> Int -shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#) - -shiftL :: Word8 -> Int -> Word8 -shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#)) - -index :: Int -> I -index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7)) -{-# INLINE index #-} - --- | Check the set for membership. -memberWord8 :: Word8 -> FastSet -> Bool -memberWord8 w (Table t) = - let I byte bit = index (fromIntegral w) - in U.unsafeIndex t byte .&. bit /= 0 -memberWord8 w (Sorted s) = search 0 (B.length s - 1) - where search lo hi - | hi < lo = False - | otherwise = - let mid = (lo + hi) `quot` 2 - in case compare w (U.unsafeIndex s mid) of - GT -> search (mid + 1) hi - LT -> search lo (mid - 1) - _ -> True - --- | Check the set for membership. Only works with 8-bit characters: --- characters above code point 255 will give wrong answers. -memberChar :: Char -> FastSet -> Bool -memberChar c = memberWord8 (I.c2w c) -{-# INLINE memberChar #-} - -mkTable :: B.ByteString -> B.ByteString -mkTable s = I.unsafeCreate 32 $ \t -> do - _ <- I.memset t 0 32 - U.unsafeUseAsCStringLen s $ \(p, l) -> - let loop n | n == l = return () - | otherwise = do - c <- peekByteOff p n :: IO Word8 - let I byte bit = index (fromIntegral c) - prev <- peekByteOff t byte :: IO Word8 - pokeByteOff t byte (prev .|. bit) - loop (n + 1) - in loop 0 - -charClass :: String -> FastSet -charClass = set . B8.pack . go - where go (a:'-':b:xs) = [a..b] ++ go xs - go (x:xs) = x : go xs - go _ = "" diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs deleted file mode 100644 index 4938ea87..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs +++ /dev/null @@ -1,536 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, GADTs, OverloadedStrings, RankNTypes, - RecordWildCards #-} --- | --- Module : Data.Attoparsec.ByteString.Internal --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient parser combinators for 'ByteString' strings, --- loosely based on the Parsec library. - -module Data.Attoparsec.ByteString.Internal - ( - -- * Parser types - Parser - , Result - - -- * Running parsers - , parse - , parseOnly - - -- * Combinators - , module Data.Attoparsec.Combinator - - -- * Parsing individual bytes - , satisfy - , satisfyWith - , anyWord8 - , skip - , word8 - , notWord8 - - -- ** Lookahead - , peekWord8 - , peekWord8' - - -- ** Byte classes - , inClass - , notInClass - - -- * Parsing more complicated structures - , storable - - -- * Efficient string handling - , skipWhile - , string - , stringCI - , take - , scan - , runScanner - , takeWhile - , takeWhile1 - , takeTill - - -- ** Consume all remaining input - , takeByteString - , takeLazyByteString - - -- * Utilities - , endOfLine - , endOfInput - , match - , atEnd - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Data.Attoparsec.ByteString.Buffer (Buffer, buffer) -import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8) -import Data.Attoparsec.Combinator (()) -import Data.Attoparsec.Internal -import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO) -import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success) -import Data.ByteString (ByteString) -import Data.List (intercalate) -import Data.Word (Word8) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (castPtr, minusPtr, plusPtr) -import Foreign.Storable (Storable(peek, sizeOf)) -import Prelude hiding (getChar, succ, take, takeWhile) -import qualified Data.Attoparsec.ByteString.Buffer as Buf -import qualified Data.Attoparsec.Internal.Types as T -import qualified Data.ByteString as B8 -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Unsafe as B - -type Parser = T.Parser ByteString -type Result = IResult ByteString -type Failure r = T.Failure ByteString Buffer r -type Success a r = T.Success ByteString Buffer a r - --- | The parser @satisfy p@ succeeds for any byte for which the --- predicate @p@ returns 'True'. Returns the byte that is actually --- parsed. --- --- >digit = satisfy isDigit --- > where isDigit w = w >= 48 && w <= 57 -satisfy :: (Word8 -> Bool) -> Parser Word8 -satisfy p = do - h <- peekWord8' - if p h - then advance 1 >> return h - else fail "satisfy" -{-# INLINE satisfy #-} - --- | The parser @skip p@ succeeds for any byte for which the predicate --- @p@ returns 'True'. --- --- >skipDigit = skip isDigit --- > where isDigit w = w >= 48 && w <= 57 -skip :: (Word8 -> Bool) -> Parser () -skip p = do - h <- peekWord8' - if p h - then advance 1 - else fail "skip" - --- | The parser @satisfyWith f p@ transforms a byte, and succeeds if --- the predicate @p@ returns 'True' on the transformed value. The --- parser returns the transformed byte that was parsed. -satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a -satisfyWith f p = do - h <- peekWord8' - let c = f h - if p c - then advance 1 >> return c - else fail "satisfyWith" -{-# INLINE satisfyWith #-} - -storable :: Storable a => Parser a -storable = hack undefined - where - hack :: Storable b => b -> Parser b - hack dummy = do - (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy) - return . inlinePerformIO . withForeignPtr fp $ \p -> - peek (castPtr $ p `plusPtr` o) - --- | Consume exactly @n@ bytes of input. -take :: Int -> Parser ByteString -take n0 = do - let n = max n0 0 - s <- ensure n - advance n >> return s -{-# INLINE take #-} - --- | @string s@ parses a sequence of bytes that identically match --- @s@. Returns the parsed string (i.e. @s@). This parser consumes no --- input if it fails (even if a partial match). --- --- /Note/: The behaviour of this parser is different to that of the --- similarly-named parser in Parsec, as this one is all-or-nothing. --- To illustrate the difference, the following parser will fail under --- Parsec given an input of @\"for\"@: --- --- >string "foo" <|> string "for" --- --- The reason for its failure is that the first branch is a --- partial match, and will consume the letters @\'f\'@ and @\'o\'@ --- before failing. In attoparsec, the above parser will /succeed/ on --- that input, because the failed first branch will consume nothing. -string :: ByteString -> Parser ByteString -string s = string_ (stringSuspended id) id s -{-# INLINE string #-} - --- ASCII-specific but fast, oh yes. -toLower :: Word8 -> Word8 -toLower w | w >= 65 && w <= 90 = w + 32 - | otherwise = w - --- | Satisfy a literal string, ignoring case. -stringCI :: ByteString -> Parser ByteString -stringCI s = string_ (stringSuspended lower) lower s - where lower = B8.map toLower -{-# INLINE stringCI #-} - -string_ :: (forall r. ByteString -> ByteString -> Buffer -> Pos -> More - -> Failure r -> Success ByteString r -> Result r) - -> (ByteString -> ByteString) - -> ByteString -> Parser ByteString -string_ suspended f s0 = T.Parser $ \t pos more lose succ -> - let n = B.length s - s = f s0 - in if lengthAtLeast pos n t - then let t' = substring pos (Pos n) t - in if s == f t' - then succ t (pos + Pos n) more t' - else lose t pos more [] "string" - else let t' = Buf.unsafeDrop (fromPos pos) t - in if f t' `B.isPrefixOf` s - then suspended s (B.drop (B.length t') s) t pos more lose succ - else lose t pos more [] "string" -{-# INLINE string_ #-} - -stringSuspended :: (ByteString -> ByteString) - -> ByteString -> ByteString -> Buffer -> Pos -> More - -> Failure r - -> Success ByteString r - -> Result r -stringSuspended f s0 s t pos more lose succ = - runParser (demandInput_ >>= go) t pos more lose succ - where go s'0 = T.Parser $ \t' pos' more' lose' succ' -> - let m = B.length s - s' = f s'0 - n = B.length s' - in if n >= m - then if B.unsafeTake m s' == s - then let o = Pos (B.length s0) - in succ' t' (pos' + o) more' - (substring pos' o t') - else lose' t' pos' more' [] "string" - else if s' == B.unsafeTake n s - then stringSuspended f s0 (B.unsafeDrop n s) - t' pos' more' lose' succ' - else lose' t' pos' more' [] "string" - --- | Skip past input for as long as the predicate returns 'True'. -skipWhile :: (Word8 -> Bool) -> Parser () -skipWhile p = go - where - go = do - t <- B8.takeWhile p <$> get - continue <- inputSpansChunks (B.length t) - when continue go -{-# INLINE skipWhile #-} - --- | Consume input as long as the predicate returns 'False' --- (i.e. until it returns 'True'), and return the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'True' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'Control.Applicative.many', because such --- parsers loop until a failure occurs. Careless use will thus result --- in an infinite loop. -takeTill :: (Word8 -> Bool) -> Parser ByteString -takeTill p = takeWhile (not . p) -{-# INLINE takeTill #-} - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'False' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'Control.Applicative.many', because such --- parsers loop until a failure occurs. Careless use will thus result --- in an infinite loop. -takeWhile :: (Word8 -> Bool) -> Parser ByteString -takeWhile p = do - s <- B8.takeWhile p <$> get - continue <- inputSpansChunks (B.length s) - if continue - then takeWhileAcc p [s] - else return s -{-# INLINE takeWhile #-} - -takeWhileAcc :: (Word8 -> Bool) -> [ByteString] -> Parser ByteString -takeWhileAcc p = go - where - go acc = do - s <- B8.takeWhile p <$> get - continue <- inputSpansChunks (B.length s) - if continue - then go (s:acc) - else return $ concatReverse (s:acc) -{-# INLINE takeWhileAcc #-} - -takeRest :: Parser [ByteString] -takeRest = go [] - where - go acc = do - input <- wantInput - if input - then do - s <- get - advance (B.length s) - go (s:acc) - else return (reverse acc) - --- | Consume all remaining input and return it as a single string. -takeByteString :: Parser ByteString -takeByteString = B.concat `fmap` takeRest - --- | Consume all remaining input and return it as a single string. -takeLazyByteString :: Parser L.ByteString -takeLazyByteString = L.fromChunks `fmap` takeRest - -data T s = T {-# UNPACK #-} !Int s - -scan_ :: (s -> [ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s) - -> Parser r -scan_ f s0 p = go [] s0 - where - go acc s1 = do - let scanner (B.PS fp off len) = - withForeignPtr fp $ \ptr0 -> do - let start = ptr0 `plusPtr` off - end = start `plusPtr` len - inner ptr !s - | ptr < end = do - w <- peek ptr - case p s w of - Just s' -> inner (ptr `plusPtr` 1) s' - _ -> done (ptr `minusPtr` start) s - | otherwise = done (ptr `minusPtr` start) s - done !i !s = return (T i s) - inner start s1 - bs <- get - let T i s' = inlinePerformIO $ scanner bs - !h = B.unsafeTake i bs - continue <- inputSpansChunks i - if continue - then go (h:acc) s' - else f s' (h:acc) -{-# INLINE scan_ #-} - --- | A stateful scanner. The predicate consumes and transforms a --- state argument, and each transformed state is passed to successive --- invocations of the predicate on each byte of the input until one --- returns 'Nothing' or the input ends. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'Nothing' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'Control.Applicative.many', because such --- parsers loop until a failure occurs. Careless use will thus result --- in an infinite loop. -scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString -scan = scan_ $ \_ chunks -> return $! concatReverse chunks -{-# INLINE scan #-} - --- | Like 'scan', but generalized to return the final state of the --- scanner. -runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s) -runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s) -{-# INLINE runScanner #-} - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser requires the predicate to succeed on at least one byte --- of input: it will fail if the predicate never returns 'True' or if --- there is no input left. -takeWhile1 :: (Word8 -> Bool) -> Parser ByteString -takeWhile1 p = do - (`when` demandInput) =<< endOfChunk - s <- B8.takeWhile p <$> get - let len = B.length s - if len == 0 - then fail "takeWhile1" - else do - advance len - eoc <- endOfChunk - if eoc - then takeWhileAcc p [s] - else return s -{-# INLINE takeWhile1 #-} - --- | Match any byte in a set. --- --- >vowel = inClass "aeiou" --- --- Range notation is supported. --- --- >halfAlphabet = inClass "a-nA-N" --- --- To add a literal @\'-\'@ to a set, place it at the beginning or end --- of the string. -inClass :: String -> Word8 -> Bool -inClass s = (`memberWord8` mySet) - where mySet = charClass s - {-# NOINLINE mySet #-} -{-# INLINE inClass #-} - --- | Match any byte not in a set. -notInClass :: String -> Word8 -> Bool -notInClass s = not . inClass s -{-# INLINE notInClass #-} - --- | Match any byte. -anyWord8 :: Parser Word8 -anyWord8 = satisfy $ const True -{-# INLINE anyWord8 #-} - --- | Match a specific byte. -word8 :: Word8 -> Parser Word8 -word8 c = satisfy (== c) show c -{-# INLINE word8 #-} - --- | Match any byte except the given one. -notWord8 :: Word8 -> Parser Word8 -notWord8 c = satisfy (/= c) "not " ++ show c -{-# INLINE notWord8 #-} - --- | Match any byte, to perform lookahead. Returns 'Nothing' if end of --- input has been reached. Does not consume any input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'Control.Applicative.many', because such --- parsers loop until a failure occurs. Careless use will thus result --- in an infinite loop. -peekWord8 :: Parser (Maybe Word8) -peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ -> - case () of - _| pos_ < Buf.length t -> - let !w = Buf.unsafeIndex t pos_ - in succ t pos more (Just w) - | more == Complete -> - succ t pos more Nothing - | otherwise -> - let succ' t' pos' more' = let !w = Buf.unsafeIndex t' pos_ - in succ t' pos' more' (Just w) - lose' t' pos' more' = succ t' pos' more' Nothing - in prompt t pos more lose' succ' -{-# INLINE peekWord8 #-} - --- | Match any byte, to perform lookahead. Does not consume any --- input, but will fail if end of input has been reached. -peekWord8' :: Parser Word8 -peekWord8' = T.Parser $ \t pos more lose succ -> - if lengthAtLeast pos 1 t - then succ t pos more (Buf.unsafeIndex t (fromPos pos)) - else let succ' t' pos' more' bs' = succ t' pos' more' $! B.unsafeHead bs' - in ensureSuspended 1 t pos more lose succ' -{-# INLINE peekWord8' #-} - --- | Match either a single newline character @\'\\n\'@, or a carriage --- return followed by a newline character @\"\\r\\n\"@. -endOfLine :: Parser () -endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ()) - --- | Terminal failure continuation. -failK :: Failure a -failK t (Pos pos) _more stack msg = Fail (Buf.unsafeDrop pos t) stack msg -{-# INLINE failK #-} - --- | Terminal success continuation. -successK :: Success a a -successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a -{-# INLINE successK #-} - --- | Run a parser. -parse :: Parser a -> ByteString -> Result a -parse m s = T.runParser m (buffer s) (Pos 0) Incomplete failK successK -{-# INLINE parse #-} - --- | Run a parser that cannot be resupplied via a 'Partial' result. --- --- This function does not force a parser to consume all of its input. --- Instead, any residual input will be discarded. To force a parser --- to consume all of its input, use something like this: --- --- @ ---'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput') --- @ -parseOnly :: Parser a -> ByteString -> Either String a -parseOnly m s = case T.runParser m (buffer s) (Pos 0) Complete failK successK of - Fail _ [] err -> Left err - Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err) - Done _ a -> Right a - _ -> error "parseOnly: impossible error!" -{-# INLINE parseOnly #-} - -get :: Parser ByteString -get = T.Parser $ \t pos more _lose succ -> - succ t pos more (Buf.unsafeDrop (fromPos pos) t) -{-# INLINE get #-} - -endOfChunk :: Parser Bool -endOfChunk = T.Parser $ \t pos more _lose succ -> - succ t pos more (fromPos pos == Buf.length t) -{-# INLINE endOfChunk #-} - -inputSpansChunks :: Int -> Parser Bool -inputSpansChunks i = T.Parser $ \t pos_ more _lose succ -> - let pos = pos_ + Pos i - in if fromPos pos < Buf.length t || more == Complete - then succ t pos more False - else let lose' t' pos' more' = succ t' pos' more' False - succ' t' pos' more' = succ t' pos' more' True - in prompt t pos more lose' succ' -{-# INLINE inputSpansChunks #-} - -advance :: Int -> Parser () -advance n = T.Parser $ \t pos more _lose succ -> - succ t (pos + Pos n) more () -{-# INLINE advance #-} - -ensureSuspended :: Int -> Buffer -> Pos -> More - -> Failure r - -> Success ByteString r - -> Result r -ensureSuspended n t pos more lose succ = - runParser (demandInput >> go) t pos more lose succ - where go = T.Parser $ \t' pos' more' lose' succ' -> - if lengthAtLeast pos' n t' - then succ' t' pos' more' (substring pos (Pos n) t') - else runParser (demandInput >> go) t' pos' more' lose' succ' - --- | If at least @n@ elements of input are available, return the --- current input, otherwise fail. -ensure :: Int -> Parser ByteString -ensure n = T.Parser $ \t pos more lose succ -> - if lengthAtLeast pos n t - then succ t pos more (substring pos (Pos n) t) - -- The uncommon case is kept out-of-line to reduce code size: - else ensureSuspended n t pos more lose succ -{-# INLINE ensure #-} - --- | Return both the result of a parse and the portion of the input --- that was consumed while it was being parsed. -match :: Parser a -> Parser (ByteString, a) -match p = T.Parser $ \t pos more lose succ -> - let succ' t' pos' more' a = - succ t' pos' more' (substring pos (pos'-pos) t', a) - in runParser p t pos more lose succ' - -lengthAtLeast :: Pos -> Int -> Buffer -> Bool -lengthAtLeast (Pos pos) n bs = Buf.length bs >= pos + n -{-# INLINE lengthAtLeast #-} - -substring :: Pos -> Pos -> Buffer -> ByteString -substring (Pos pos) (Pos n) = Buf.substring pos n -{-# INLINE substring #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs deleted file mode 100644 index dde0c27a..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -- Imports internal modules -#endif --- | --- Module : Data.Attoparsec.Combinator --- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : portable --- --- Useful parser combinators, similar to those provided by Parsec. -module Data.Attoparsec.Combinator - ( - -- * Combinators - try - , () - , choice - , count - , option - , many' - , many1 - , many1' - , manyTill - , manyTill' - , sepBy - , sepBy' - , sepBy1 - , sepBy1' - , skipMany - , skipMany1 - , eitherP - , feed - , satisfyElem - , endOfInput - , atEnd - , lookAhead - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative(..), (<$>)) -import Data.Monoid (Monoid(mappend)) -#endif -import Control.Applicative (Alternative(..), empty, liftA2, many, (<|>)) -import Control.Monad (MonadPlus(..)) -import Data.Attoparsec.Internal.Types (Parser(..), IResult(..)) -import Data.Attoparsec.Internal (endOfInput, atEnd, satisfyElem) -import Data.ByteString (ByteString) -import Prelude hiding (succ) - --- | Attempt a parse, and if it fails, rewind the input so that no --- input appears to have been consumed. --- --- This combinator is provided for compatibility with Parsec. --- attoparsec parsers always backtrack on failure. -try :: Parser i a -> Parser i a -try p = p -{-# INLINE try #-} - --- | Name the parser, in case failure occurs. -() :: Parser i a - -> String -- ^ the name to use if parsing fails - -> Parser i a -p msg0 = Parser $ \t pos more lose succ -> - let lose' t' pos' more' strs msg = lose t' pos' more' (msg0:strs) msg - in runParser p t pos more lose' succ -{-# INLINE () #-} -infix 0 - --- | @choice ps@ tries to apply the actions in the list @ps@ in order, --- until one of them succeeds. Returns the value of the succeeding --- action. -choice :: Alternative f => [f a] -> f a -choice = foldr (<|>) empty -{-# SPECIALIZE choice :: [Parser ByteString a] - -> Parser ByteString a #-} - --- | @option x p@ tries to apply action @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value --- returned by @p@. --- --- > priority = option 0 (digitToInt <$> digit) -option :: Alternative f => a -> f a -> f a -option x p = p <|> pure x -{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-} - --- | A version of 'liftM2' that is strict in the result of its first --- action. -liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c -liftM2' f a b = do - !x <- a - y <- b - return (f x y) -{-# INLINE liftM2' #-} - --- | @many' p@ applies the action @p@ /zero/ or more times. Returns a --- list of the returned values of @p@. The value returned by @p@ is --- forced to WHNF. --- --- > word = many' letter -many' :: (MonadPlus m) => m a -> m [a] -many' p = many_p - where many_p = some_p `mplus` return [] - some_p = liftM2' (:) p many_p -{-# INLINE many' #-} - --- | @many1 p@ applies the action @p@ /one/ or more times. Returns a --- list of the returned values of @p@. --- --- > word = many1 letter -many1 :: Alternative f => f a -> f [a] -many1 p = liftA2 (:) p (many p) -{-# INLINE many1 #-} - --- | @many1' p@ applies the action @p@ /one/ or more times. Returns a --- list of the returned values of @p@. The value returned by @p@ is --- forced to WHNF. --- --- > word = many1' letter -many1' :: (MonadPlus m) => m a -> m [a] -many1' p = liftM2' (:) p (many' p) -{-# INLINE many1' #-} - --- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. --- --- > commaSep p = p `sepBy` (char ',') -sepBy :: Alternative f => f a -> f s -> f [a] -sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure [] -{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} - --- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. The value --- returned by @p@ is forced to WHNF. --- --- > commaSep p = p `sepBy'` (char ',') -sepBy' :: (MonadPlus m) => m a -> m s -> m [a] -sepBy' p s = scan `mplus` return [] - where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return []) -{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} - --- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. --- --- > commaSep p = p `sepBy1` (char ',') -sepBy1 :: Alternative f => f a -> f s -> f [a] -sepBy1 p s = scan - where scan = liftA2 (:) p ((s *> scan) <|> pure []) -{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} - --- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. The value --- returned by @p@ is forced to WHNF. --- --- > commaSep p = p `sepBy1'` (char ',') -sepBy1' :: (MonadPlus m) => m a -> m s -> m [a] -sepBy1' p s = scan - where scan = liftM2' (:) p ((s >> scan) `mplus` return []) -{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} - --- | @manyTill p end@ applies action @p@ /zero/ or more times until --- action @end@ succeeds, and returns the list of values returned by --- @p@. This can be used to scan comments: --- --- > simpleComment = string "") --- --- (Note the overlapping parsers @anyChar@ and @string \"-->\"@. --- While this will work, it is not very efficient, as it will cause a --- lot of backtracking.) -manyTill :: Alternative f => f a -> f b -> f [a] -manyTill p end = scan - where scan = (end *> pure []) <|> liftA2 (:) p scan -{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b - -> Parser ByteString [a] #-} - --- | @manyTill' p end@ applies action @p@ /zero/ or more times until --- action @end@ succeeds, and returns the list of values returned by --- @p@. This can be used to scan comments: --- --- > simpleComment = string "") --- --- (Note the overlapping parsers @anyChar@ and @string \"-->\"@. --- While this will work, it is not very efficient, as it will cause a --- lot of backtracking.) --- --- The value returned by @p@ is forced to WHNF. -manyTill' :: (MonadPlus m) => m a -> m b -> m [a] -manyTill' p end = scan - where scan = (end >> return []) `mplus` liftM2' (:) p scan -{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b - -> Parser ByteString [a] #-} - --- | Skip zero or more instances of an action. -skipMany :: Alternative f => f a -> f () -skipMany p = scan - where scan = (p *> scan) <|> pure () -{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-} - --- | Skip one or more instances of an action. -skipMany1 :: Alternative f => f a -> f () -skipMany1 p = p *> skipMany p -{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-} - --- | Apply the given action repeatedly, returning every result. -count :: Monad m => Int -> m a -> m [a] -count n p = sequence (replicate n p) -{-# INLINE count #-} - --- | Combine two alternatives. -eitherP :: (Alternative f) => f a -> f b -> f (Either a b) -eitherP a b = (Left <$> a) <|> (Right <$> b) -{-# INLINE eitherP #-} - --- | If a parser has returned a 'T.Partial' result, supply it with more --- input. -feed :: Monoid i => IResult i r -> i -> IResult i r -feed (Fail t ctxs msg) d = Fail (mappend t d) ctxs msg -feed (Partial k) d = k d -feed (Done t r) d = Done (mappend t d) r -{-# INLINE feed #-} - --- | Apply a parser without consuming any input. -lookAhead :: Parser i a -> Parser i a -lookAhead p = Parser $ \t pos more lose succ -> - let succ' t' _pos' more' = succ t' pos more' - in runParser p t pos more lose succ' -{-# INLINE lookAhead #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs deleted file mode 100644 index ee758b26..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} --- | --- Module : Data.Attoparsec.Internal --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient parser combinators, loosely based on the Parsec --- library. - -module Data.Attoparsec.Internal - ( compareResults - , prompt - , demandInput - , demandInput_ - , wantInput - , endOfInput - , atEnd - , satisfyElem - , concatReverse - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -import Data.Monoid (Monoid, mconcat) -#endif -import Data.Attoparsec.Internal.Types -import Data.ByteString (ByteString) -import Prelude hiding (succ) - --- | Compare two 'IResult' values for equality. --- --- If both 'IResult's are 'Partial', the result will be 'Nothing', as --- they are incomplete and hence their equality cannot be known. --- (This is why there is no 'Eq' instance for 'IResult'.) -compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool -compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) = - Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1) -compareResults (Done t0 r0) (Done t1 r1) = - Just (t0 == t1 && r0 == r1) -compareResults (Partial _) (Partial _) = Nothing -compareResults _ _ = Just False - --- | Ask for input. If we receive any, pass the augmented input to a --- success continuation, otherwise to a failure continuation. -prompt :: Chunk t - => State t -> Pos -> More - -> (State t -> Pos -> More -> IResult t r) - -> (State t -> Pos -> More -> IResult t r) - -> IResult t r -prompt t pos _more lose succ = Partial $ \s -> - if nullChunk s - then lose t pos Complete - else succ (pappendChunk t s) pos Incomplete -{-# SPECIALIZE prompt :: State ByteString -> Pos -> More - -> (State ByteString -> Pos -> More - -> IResult ByteString r) - -> (State ByteString -> Pos -> More - -> IResult ByteString r) - -> IResult ByteString r #-} - --- | Immediately demand more input via a 'Partial' continuation --- result. -demandInput :: Chunk t => Parser t () -demandInput = Parser $ \t pos more lose succ -> - case more of - Complete -> lose t pos more [] "not enough input" - _ -> let lose' _ pos' more' = lose t pos' more' [] "not enough input" - succ' t' pos' more' = succ t' pos' more' () - in prompt t pos more lose' succ' -{-# SPECIALIZE demandInput :: Parser ByteString () #-} - --- | Immediately demand more input via a 'Partial' continuation --- result. Return the new input. -demandInput_ :: Chunk t => Parser t t -demandInput_ = Parser $ \t pos more lose succ -> - case more of - Complete -> lose t pos more [] "not enough input" - _ -> Partial $ \s -> - if nullChunk s - then lose t pos Complete [] "not enough input" - else succ (pappendChunk t s) pos more s -{-# SPECIALIZE demandInput_ :: Parser ByteString ByteString #-} - --- | This parser always succeeds. It returns 'True' if any input is --- available either immediately or on demand, and 'False' if the end --- of all input has been reached. -wantInput :: forall t . Chunk t => Parser t Bool -wantInput = Parser $ \t pos more _lose succ -> - case () of - _ | pos < atBufferEnd (undefined :: t) t -> succ t pos more True - | more == Complete -> succ t pos more False - | otherwise -> let lose' t' pos' more' = succ t' pos' more' False - succ' t' pos' more' = succ t' pos' more' True - in prompt t pos more lose' succ' -{-# INLINE wantInput #-} - --- | Match only if all input has been consumed. -endOfInput :: forall t . Chunk t => Parser t () -endOfInput = Parser $ \t pos more lose succ -> - case () of - _| pos < atBufferEnd (undefined :: t) t -> lose t pos more [] "endOfInput" - | more == Complete -> succ t pos more () - | otherwise -> - let lose' t' pos' more' _ctx _msg = succ t' pos' more' () - succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput" - in runParser demandInput t pos more lose' succ' -{-# SPECIALIZE endOfInput :: Parser ByteString () #-} - --- | Return an indication of whether the end of input has been --- reached. -atEnd :: Chunk t => Parser t Bool -atEnd = not <$> wantInput -{-# INLINE atEnd #-} - -satisfySuspended :: forall t r . Chunk t - => (ChunkElem t -> Bool) - -> State t -> Pos -> More - -> Failure t (State t) r - -> Success t (State t) (ChunkElem t) r - -> IResult t r -satisfySuspended p t pos more lose succ = - runParser (demandInput >> go) t pos more lose succ - where go = Parser $ \t' pos' more' lose' succ' -> - case bufferElemAt (undefined :: t) pos' t' of - Just (e, l) | p e -> succ' t' (pos' + Pos l) more' e - | otherwise -> lose' t' pos' more' [] "satisfyElem" - Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ' -{-# SPECIALIZE satisfySuspended :: (ChunkElem ByteString -> Bool) - -> State ByteString -> Pos -> More - -> Failure ByteString (State ByteString) r - -> Success ByteString (State ByteString) - (ChunkElem ByteString) r - -> IResult ByteString r #-} - --- | The parser @satisfyElem p@ succeeds for any chunk element for which the --- predicate @p@ returns 'True'. Returns the element that is --- actually parsed. -satisfyElem :: forall t . Chunk t - => (ChunkElem t -> Bool) -> Parser t (ChunkElem t) -satisfyElem p = Parser $ \t pos more lose succ -> - case bufferElemAt (undefined :: t) pos t of - Just (e, l) | p e -> succ t (pos + Pos l) more e - | otherwise -> lose t pos more [] "satisfyElem" - Nothing -> satisfySuspended p t pos more lose succ -{-# INLINE satisfyElem #-} - --- | Concatenate a monoid after reversing its elements. Used to --- glue together a series of textual chunks that have been accumulated --- \"backwards\". -concatReverse :: Monoid m => [m] -> m -concatReverse [x] = x -concatReverse xs = mconcat (reverse xs) -{-# INLINE concatReverse #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs deleted file mode 100644 index 0e00ed2c..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, - RecordWildCards, MagicHash, UnboxedTuples #-} - -module Data.Attoparsec.Internal.Fhthagn - ( - inlinePerformIO - ) where - -import GHC.Base (realWorld#) -import GHC.IO (IO(IO)) - --- | Just like unsafePerformIO, but we inline it. Big performance gains as --- it exposes lots of things to further inlining. /Very unsafe/. In --- particular, you should do no memory allocation inside an --- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. -inlinePerformIO :: IO a -> a -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -{-# INLINE inlinePerformIO #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs deleted file mode 100644 index 96bc319e..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings, - Rank2Types, RecordWildCards, TypeFamilies #-} --- | --- Module : Data.Attoparsec.Internal.Types --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient parser combinators, loosely based on the Parsec --- library. - -module Data.Attoparsec.Internal.Types - ( - Parser(..) - , State - , Failure - , Success - , Pos(..) - , IResult(..) - , More(..) - , (<>) - , Chunk(..) - ) where - -import Control.Applicative as App (Applicative(..), (<$>)) -import Control.Applicative (Alternative(..)) -import Control.DeepSeq (NFData(rnf)) -import Control.Monad (MonadPlus(..)) -import qualified Control.Monad.Fail as Fail (MonadFail(..)) -import Data.Monoid as Mon (Monoid(..)) -import Data.Semigroup (Semigroup(..)) -import Data.Word (Word8) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Internal (w2c) -import Prelude hiding (getChar, succ) -import qualified Data.Attoparsec.ByteString.Buffer as B - -newtype Pos = Pos { fromPos :: Int } - deriving (Eq, Ord, Show, Num) - --- | The result of a parse. This is parameterised over the type @i@ --- of string that was processed. --- --- This type is an instance of 'Functor', where 'fmap' transforms the --- value in a 'Done' result. -data IResult i r = - Fail i [String] String - -- ^ The parse failed. The @i@ parameter is the input that had - -- not yet been consumed when the failure occurred. The - -- @[@'String'@]@ is a list of contexts in which the error - -- occurred. The 'String' is the message describing the error, if - -- any. - | Partial (i -> IResult i r) - -- ^ Supply this continuation with more input so that the parser - -- can resume. To indicate that no more input is available, pass - -- an empty string to the continuation. - -- - -- __Note__: if you get a 'Partial' result, do not call its - -- continuation more than once. - | Done i r - -- ^ The parse succeeded. The @i@ parameter is the input that had - -- not yet been consumed (if any) when the parse succeeded. - -instance (Show i, Show r) => Show (IResult i r) where - showsPrec d ir = showParen (d > 10) $ - case ir of - (Fail t stk msg) -> showString "Fail" . f t . f stk . f msg - (Partial _) -> showString "Partial _" - (Done t r) -> showString "Done" . f t . f r - where f :: Show a => a -> ShowS - f x = showChar ' ' . showsPrec 11 x - -instance (NFData i, NFData r) => NFData (IResult i r) where - rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg - rnf (Partial _) = () - rnf (Done t r) = rnf t `seq` rnf r - {-# INLINE rnf #-} - -instance Functor (IResult i) where - fmap _ (Fail t stk msg) = Fail t stk msg - fmap f (Partial k) = Partial (fmap f . k) - fmap f (Done t r) = Done t (f r) - --- | The core parser type. This is parameterised over the type @i@ --- of string being processed. --- --- This type is an instance of the following classes: --- --- * 'Monad', where 'fail' throws an exception (i.e. fails) with an --- error message. --- --- * 'Functor' and 'Applicative', which follow the usual definitions. --- --- * 'MonadPlus', where 'mzero' fails (with no error message) and --- 'mplus' executes the right-hand parser if the left-hand one --- fails. When the parser on the right executes, the input is reset --- to the same state as the parser on the left started with. (In --- other words, attoparsec is a backtracking parser that supports --- arbitrary lookahead.) --- --- * 'Alternative', which follows 'MonadPlus'. -newtype Parser i a = Parser { - runParser :: forall r. - State i -> Pos -> More - -> Failure i (State i) r - -> Success i (State i) a r - -> IResult i r - } - -type family State i -type instance State ByteString = B.Buffer - -type Failure i t r = t -> Pos -> More -> [String] -> String - -> IResult i r -type Success i t a r = t -> Pos -> More -> a -> IResult i r - --- | Have we read all available input? -data More = Complete | Incomplete - deriving (Eq, Show) - -instance Semigroup More where - c@Complete <> _ = c - _ <> m = m - -instance Mon.Monoid More where - mappend = (<>) - mempty = Incomplete - -instance Monad (Parser i) where - fail = Fail.fail - {-# INLINE fail #-} - - return = App.pure - {-# INLINE return #-} - - m >>= k = Parser $ \t !pos more lose succ -> - let succ' t' !pos' more' a = runParser (k a) t' pos' more' lose succ - in runParser m t pos more lose succ' - {-# INLINE (>>=) #-} - - (>>) = (*>) - {-# INLINE (>>) #-} - - -instance Fail.MonadFail (Parser i) where - fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg - where msg = "Failed reading: " ++ err - {-# INLINE fail #-} - -plus :: Parser i a -> Parser i a -> Parser i a -plus f g = Parser $ \t pos more lose succ -> - let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ - in runParser f t pos more lose' succ - -instance MonadPlus (Parser i) where - mzero = fail "mzero" - {-# INLINE mzero #-} - mplus = plus - -instance Functor (Parser i) where - fmap f p = Parser $ \t pos more lose succ -> - let succ' t' pos' more' a = succ t' pos' more' (f a) - in runParser p t pos more lose succ' - {-# INLINE fmap #-} - -apP :: Parser i (a -> b) -> Parser i a -> Parser i b -apP d e = do - b <- d - a <- e - return (b a) -{-# INLINE apP #-} - -instance Applicative (Parser i) where - pure v = Parser $ \t pos more _lose succ -> succ t pos more v - {-# INLINE pure #-} - (<*>) = apP - {-# INLINE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - x <* y = x >>= \a -> y >> pure a - {-# INLINE (<*) #-} - -instance Semigroup (Parser i a) where - (<>) = plus - {-# INLINE (<>) #-} - -instance Monoid (Parser i a) where - mempty = fail "mempty" - {-# INLINE mempty #-} - mappend = (<>) - {-# INLINE mappend #-} - -instance Alternative (Parser i) where - empty = fail "empty" - {-# INLINE empty #-} - - (<|>) = plus - {-# INLINE (<|>) #-} - - many v = many_v - where many_v = some_v <|> pure [] - some_v = (:) App.<$> v <*> many_v - {-# INLINE many #-} - - some v = some_v - where - many_v = some_v <|> pure [] - some_v = (:) <$> v <*> many_v - {-# INLINE some #-} - --- | A common interface for input chunks. -class Monoid c => Chunk c where - type ChunkElem c - -- | Test if the chunk is empty. - nullChunk :: c -> Bool - -- | Append chunk to a buffer. - pappendChunk :: State c -> c -> State c - -- | Position at the end of a buffer. The first argument is ignored. - atBufferEnd :: c -> State c -> Pos - -- | Return the buffer element at the given position along with its length. - bufferElemAt :: c -> Pos -> State c -> Maybe (ChunkElem c, Int) - -- | Map an element to the corresponding character. - -- The first argument is ignored. - chunkElemToChar :: c -> ChunkElem c -> Char - -instance Chunk ByteString where - type ChunkElem ByteString = Word8 - nullChunk = BS.null - {-# INLINE nullChunk #-} - pappendChunk = B.pappend - {-# INLINE pappendChunk #-} - atBufferEnd _ = Pos . B.length - {-# INLINE atBufferEnd #-} - bufferElemAt _ (Pos i) buf - | i < B.length buf = Just (B.unsafeIndex buf i, 1) - | otherwise = Nothing - {-# INLINE bufferElemAt #-} - chunkElemToChar _ = w2c - {-# INLINE chunkElemToChar #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs deleted file mode 100644 index d0970d90..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} --- | --- Module : Data.Attoparsec.Number --- Copyright : Bryan O'Sullivan 2007-2015 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- This module is deprecated, and both the module and 'Number' type --- will be removed in the next major release. Use the --- package --- and the 'Data.Scientific.Scientific' type instead. --- --- A simple number type, useful for parsing both exact and inexact --- quantities without losing much precision. -module Data.Attoparsec.Number - {-# DEPRECATED "This module will be removed in the next major release." #-} - ( - Number(..) - ) where - -import Control.DeepSeq (NFData(rnf)) -import Data.Data (Data) -import Data.Function (on) -import Data.Typeable (Typeable) - --- | A numeric type that can represent integers accurately, and --- floating point numbers to the precision of a 'Double'. --- --- /Note/: this type is deprecated, and will be removed in the next --- major release. Use the 'Data.Scientific.Scientific' type instead. -data Number = I !Integer - | D {-# UNPACK #-} !Double - deriving (Typeable, Data) -{-# DEPRECATED Number "Use Scientific instead." #-} - -instance Show Number where - show (I a) = show a - show (D a) = show a - -instance NFData Number where - rnf (I _) = () - rnf (D _) = () - {-# INLINE rnf #-} - -binop :: (Integer -> Integer -> a) -> (Double -> Double -> a) - -> Number -> Number -> a -binop _ d (D a) (D b) = d a b -binop i _ (I a) (I b) = i a b -binop _ d (D a) (I b) = d a (fromIntegral b) -binop _ d (I a) (D b) = d (fromIntegral a) b -{-# INLINE binop #-} - -instance Eq Number where - (==) = binop (==) (==) - {-# INLINE (==) #-} - - (/=) = binop (/=) (/=) - {-# INLINE (/=) #-} - -instance Ord Number where - (<) = binop (<) (<) - {-# INLINE (<) #-} - - (<=) = binop (<=) (<=) - {-# INLINE (<=) #-} - - (>) = binop (>) (>) - {-# INLINE (>) #-} - - (>=) = binop (>=) (>=) - {-# INLINE (>=) #-} - - compare = binop compare compare - {-# INLINE compare #-} - -instance Num Number where - (+) = binop (((I$!).) . (+)) (((D$!).) . (+)) - {-# INLINE (+) #-} - - (-) = binop (((I$!).) . (-)) (((D$!).) . (-)) - {-# INLINE (-) #-} - - (*) = binop (((I$!).) . (*)) (((D$!).) . (*)) - {-# INLINE (*) #-} - - abs (I a) = I $! abs a - abs (D a) = D $! abs a - {-# INLINE abs #-} - - negate (I a) = I $! negate a - negate (D a) = D $! negate a - {-# INLINE negate #-} - - signum (I a) = I $! signum a - signum (D a) = D $! signum a - {-# INLINE signum #-} - - fromInteger = (I$!) . fromInteger - {-# INLINE fromInteger #-} - -instance Real Number where - toRational (I a) = fromIntegral a - toRational (D a) = toRational a - {-# INLINE toRational #-} - -instance Fractional Number where - fromRational = (D$!) . fromRational - {-# INLINE fromRational #-} - - (/) = binop (((D$!).) . (/) `on` fromIntegral) - (((D$!).) . (/)) - {-# INLINE (/) #-} - - recip (I a) = D $! recip (fromIntegral a) - recip (D a) = D $! recip a - {-# INLINE recip #-} - -instance RealFrac Number where - properFraction (I a) = (fromIntegral a,0) - properFraction (D a) = case properFraction a of - (i,d) -> (i,D d) - {-# INLINE properFraction #-} - truncate (I a) = fromIntegral a - truncate (D a) = truncate a - {-# INLINE truncate #-} - round (I a) = fromIntegral a - round (D a) = round a - {-# INLINE round #-} - ceiling (I a) = fromIntegral a - ceiling (D a) = ceiling a - {-# INLINE ceiling #-} - floor (I a) = fromIntegral a - floor (D a) = floor a - {-# INLINE floor #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/LICENSE b/haddock-library/vendor/attoparsec-0.13.1.0/LICENSE deleted file mode 100644 index 97392a62..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) Lennart Kolmodin - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS -OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. diff --git a/haddock.cabal b/haddock.cabal index 7ae252c2..7401cdc7 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -63,11 +63,12 @@ executable haddock hs-source-dirs: driver ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded - -- haddock typically only supports a single GHC major version + -- haddock typically only supports a single GHC major version build-depends: base ^>= 4.11.0 + if flag(in-ghc-tree) - hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.13.1.0, haddock-library/src + hs-source-dirs: haddock-api/src, haddock-library/src cpp-options: -DIN_GHC_TREE build-depends: filepath, @@ -80,6 +81,8 @@ executable haddock ghc-boot, ghc == 8.4.*, bytestring, + parsec, + text, transformers other-modules: @@ -89,17 +92,6 @@ executable haddock Documentation.Haddock.Parser.Monad Documentation.Haddock.Types Documentation.Haddock.Doc - Data.Attoparsec - Data.Attoparsec.ByteString - Data.Attoparsec.ByteString.Buffer - Data.Attoparsec.ByteString.Char8 - Data.Attoparsec.ByteString.FastSet - Data.Attoparsec.ByteString.Internal - Data.Attoparsec.Combinator - Data.Attoparsec.Internal - Data.Attoparsec.Internal.Fhthagn - Data.Attoparsec.Internal.Types - Data.Attoparsec.Number Documentation.Haddock.Utf8 Documentation.Haddock.Parser.Util Documentation.Haddock.Markup -- cgit v1.2.3 From 00c401b965e1468aee71caa4cffd049cadd515d8 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 8 May 2018 04:00:18 +0200 Subject: Add docs for some DocH constructors (#814) --- haddock-library/src/Documentation/Haddock/Types.hs | 3 +++ 1 file changed, 3 insertions(+) (limited to 'haddock-library/src/Documentation') diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 005ec186..b5dea3d4 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -107,8 +107,10 @@ data DocH mod id | DocParagraph (DocH mod id) | DocIdentifier id | DocIdentifierUnchecked mod + -- ^ A qualified identifier that couldn't be resolved. | DocModule String | DocWarning (DocH mod id) + -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) | DocMonospaced (DocH mod id) | DocBold (DocH mod id) @@ -121,6 +123,7 @@ data DocH mod id | DocMathInline String | DocMathDisplay String | DocAName String + -- ^ A (HTML) anchor. | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id)) -- cgit v1.2.3