diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,23 @@ +## Changes in version 1.11.0 + + * Add support for linking identifiers with a quote between backticks (#1408) + +## Changes in version 1.10.0 + + * Add support for labeled module references (#1360) +## Changes in version 1.9.0 + + * Fix build-time regression for `base < 4.7` (#1119) + + * Update parsing to strip whitespace from table cells (#1074) + +## Changes in version 1.8.0 + + * Support inline markup in markdown-style links (#875) + + * Remove now unused `Documentation.Haddock.Utf8` module. + This module was anyways copied from the `utf8-string` package. + ## Changes in version 1.7.0 * Make `Documentation.Haddock.Parser.Monad` an internal module diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,23 +1,26 @@ -Copyright 2002-2010, Simon Marlow. All rights reserved. +Copyright (c) 2002-2010, Simon Marlow +All rights reserved. Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +modification, are permitted provided that the following conditions are +met: -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. -- 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. +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. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 COPYRIGHT HOLDERS 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. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT +OWNER 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/fixtures/Fixtures.hs b/fixtures/Fixtures.hs --- a/fixtures/Fixtures.hs +++ b/fixtures/Fixtures.hs @@ -9,8 +9,7 @@ import Data.List (foldl') import Data.Traversable (for) import GHC.Generics (Generic) -import Prelude () -import Prelude.Compat +import Prelude import System.Directory (getDirectoryContents) import System.Exit (exitFailure) import System.FilePath @@ -146,8 +145,11 @@ deriving instance Generic (Header id) instance ToExpr id => ToExpr (Header id) -deriving instance Generic Hyperlink -instance ToExpr Hyperlink +deriving instance Generic (Hyperlink id) +instance ToExpr id => ToExpr (Hyperlink id) + +deriving instance Generic (ModLink id) +instance ToExpr id => ToExpr (ModLink id) deriving instance Generic Picture instance ToExpr Picture diff --git a/fixtures/examples/definitionList.input b/fixtures/examples/definitionList.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/definitionList.input @@ -0,0 +1,1 @@ +[foo]: bar diff --git a/fixtures/examples/definitionList.parsed b/fixtures/examples/definitionList.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/definitionList.parsed @@ -0,0 +1,1 @@ +DocDefList [_×_ (DocString "foo") (DocString "bar")] diff --git a/fixtures/examples/identifier.input b/fixtures/examples/identifier.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/identifier.input @@ -0,0 +1,1 @@ +'foo' diff --git a/fixtures/examples/identifier.parsed b/fixtures/examples/identifier.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/identifier.parsed @@ -0,0 +1,1 @@ +DocParagraph (DocIdentifier "foo") diff --git a/fixtures/examples/identifierBackticks.input b/fixtures/examples/identifierBackticks.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/identifierBackticks.input @@ -0,0 +1,1 @@ +`foo` diff --git a/fixtures/examples/identifierBackticks.parsed b/fixtures/examples/identifierBackticks.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/identifierBackticks.parsed @@ -0,0 +1,1 @@ +DocParagraph (DocIdentifier "foo") diff --git a/fixtures/examples/link.input b/fixtures/examples/link.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/link.input @@ -0,0 +1,1 @@ +[link](http://example.com) diff --git a/fixtures/examples/link.parsed b/fixtures/examples/link.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/link.parsed @@ -0,0 +1,5 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just (DocString "link"), + hyperlinkUrl = "http://example.com"}) diff --git a/fixtures/examples/linkInline.input b/fixtures/examples/linkInline.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/linkInline.input @@ -0,0 +1,1 @@ +Bla [link](http://example.com) diff --git a/fixtures/examples/linkInline.parsed b/fixtures/examples/linkInline.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/linkInline.parsed @@ -0,0 +1,7 @@ +DocParagraph + (DocAppend + (DocString "Bla ") + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just (DocString "link"), + hyperlinkUrl = "http://example.com"})) diff --git a/fixtures/examples/linkInlineMarkup.input b/fixtures/examples/linkInlineMarkup.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/linkInlineMarkup.input @@ -0,0 +1,1 @@ +Bla [link /emphasized/](http://example.com) diff --git a/fixtures/examples/linkInlineMarkup.parsed b/fixtures/examples/linkInlineMarkup.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/linkInlineMarkup.parsed @@ -0,0 +1,8 @@ +DocParagraph + (DocAppend + (DocString "Bla ") + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just (DocAppend (DocString "link ") + (DocEmphasis (DocString "emphasized"))), + hyperlinkUrl = "http://example.com"})) diff --git a/fixtures/examples/list-blocks1.input b/fixtures/examples/list-blocks1.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/list-blocks1.input @@ -0,0 +1,15 @@ +* Something about foo + + @ + foo :: a -> b -> c + foo a b = bar c b + @ + +* Something about bar + + @ + bar :: a -> b -> c + bar a b = foo b a + @ + +* And then we continue diff --git a/fixtures/examples/list-blocks1.parsed b/fixtures/examples/list-blocks1.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/list-blocks1.parsed @@ -0,0 +1,12 @@ +DocUnorderedList + [DocAppend + (DocParagraph (DocString "Something about foo")) + (DocCodeBlock + (DocString + (concat ["foo :: a -> b -> c\n", "foo a b = bar c b\n"]))), + DocAppend + (DocParagraph (DocString "Something about bar")) + (DocCodeBlock + (DocString + (concat ["bar :: a -> b -> c\n", "bar a b = foo b a\n"]))), + DocParagraph (DocString "And then we continue")] diff --git a/fixtures/examples/list-blocks2.input b/fixtures/examples/list-blocks2.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/list-blocks2.input @@ -0,0 +1,10 @@ +=== Title + +* List directly +* after the title + + @ + with some inline things + @ + +* is parsed weirdly diff --git a/fixtures/examples/list-blocks2.parsed b/fixtures/examples/list-blocks2.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/list-blocks2.parsed @@ -0,0 +1,10 @@ +DocAppend + (DocAppend + (DocHeader + Header {headerLevel = 3, headerTitle = DocString "Title"}) + (DocUnorderedList + [DocParagraph (DocString "List directly"), + DocAppend + (DocParagraph (DocString "after the title")) + (DocCodeBlock (DocString "with some inline things\n"))])) + (DocUnorderedList [DocParagraph (DocString "is parsed weirdly")]) diff --git a/fixtures/examples/table-cell-strip-whitespaces.input b/fixtures/examples/table-cell-strip-whitespaces.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/table-cell-strip-whitespaces.input @@ -0,0 +1,5 @@ ++------+--------------+-------------------------------------------------+ +| C1 | C2 | C3 | ++======+==============+=================================================+ +| row | 'test' | 'test table cell with .. whitepspace ' | ++------+--------------+-------------------------------------------------+ diff --git a/fixtures/examples/table-cell-strip-whitespaces.parsed b/fixtures/examples/table-cell-strip-whitespaces.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/table-cell-strip-whitespaces.parsed @@ -0,0 +1,29 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString "row", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocIdentifier "test", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + "'test table cell with .. whitepspace '", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString "C1", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString "C2", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString "C3", + tableCellRowspan = 1}]]} diff --git a/fixtures/examples/table-simple.input b/fixtures/examples/table-simple.input new file mode 100644 --- /dev/null +++ b/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/fixtures/examples/table-simple.parsed b/fixtures/examples/table-simple.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/table-simple.parsed @@ -0,0 +1,42 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString "200", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocMonospaced (DocString "OK"), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString "operation successful", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString "204", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocMonospaced (DocString "No Content"), + 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/fixtures/examples/table1.input b/fixtures/examples/table1.input new file mode 100644 --- /dev/null +++ b/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/fixtures/examples/table1.parsed b/fixtures/examples/table1.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/table1.parsed @@ -0,0 +1,68 @@ +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 = DocMathDisplay + (concat ["\n", "f(n) = \\sum_{i=1}\n"]), + 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 "Header 2\n", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString "Header 3\n", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString "Header 4\n", + tableCellRowspan = 1}]]} diff --git a/fixtures/examples/table2.input b/fixtures/examples/table2.input new file mode 100644 --- /dev/null +++ b/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/fixtures/examples/table2.parsed b/fixtures/examples/table2.parsed new file mode 100644 --- /dev/null +++ b/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 = DocEmpty, + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString "row 3", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + tableCellRowspan = 1}]], + tableHeaderRows = []} diff --git a/fixtures/examples/table3.input b/fixtures/examples/table3.input new file mode 100644 --- /dev/null +++ b/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/fixtures/examples/table3.parsed b/fixtures/examples/table3.parsed new file mode 100644 --- /dev/null +++ b/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 = DocEmpty, + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + tableCellRowspan = 1}]], + tableHeaderRows = []} diff --git a/fixtures/examples/table4.input b/fixtures/examples/table4.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/table4.input @@ -0,0 +1,17 @@ +Single outer cell: + ++-------------+ +| outer | +| | ++-------+ | +| inner | | ++-------+-----+ + +Broken (only inner cell is rendered): + ++-------+-----+ +| inner | | ++-------+ | +| | +| outer | ++-------------+ diff --git a/fixtures/examples/table4.parsed b/fixtures/examples/table4.parsed new file mode 100644 --- /dev/null +++ b/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/fixtures/examples/table5.input b/fixtures/examples/table5.input new file mode 100644 --- /dev/null +++ b/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/fixtures/examples/table5.parsed b/fixtures/examples/table5.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/table5.parsed @@ -0,0 +1,46 @@ +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 ".\n")), + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocEmpty, + 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/fixtures/examples/url.input b/fixtures/examples/url.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/url.input @@ -0,0 +1,1 @@ + diff --git a/fixtures/examples/url.parsed b/fixtures/examples/url.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/url.parsed @@ -0,0 +1,4 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Nothing, hyperlinkUrl = "http://example.com/"}) diff --git a/fixtures/examples/urlLabel.input b/fixtures/examples/urlLabel.input new file mode 100644 --- /dev/null +++ b/fixtures/examples/urlLabel.input @@ -0,0 +1,1 @@ + diff --git a/fixtures/examples/urlLabel.parsed b/fixtures/examples/urlLabel.parsed new file mode 100644 --- /dev/null +++ b/fixtures/examples/urlLabel.parsed @@ -0,0 +1,5 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just (DocString "some link"), + hyperlinkUrl = "http://example.com/"}) diff --git a/haddock-library.cabal b/haddock-library.cabal --- a/haddock-library.cabal +++ b/haddock-library.cabal @@ -1,34 +1,56 @@ -cabal-version: 2.0 +cabal-version: 3.0 name: haddock-library -version: 1.7.0 +version: 1.11.0 synopsis: Library exposing some functionality of Haddock. + description: Haddock is a documentation-generation tool for Haskell - libraries. These modules expose some functionality of it - without pulling in the GHC dependency. Please note that the - API is likely to change so specify upper bounds in your - project. For interacting with Haddock + libraries. These modules expose some + functionality of it without pulling in the GHC + dependency. Please note that the API is likely + to change so be sure to specify upper bounds in + your projects. For interacting with Haddock itself, see the [haddock package](https://hackage.haskell.org/package/haddock). -license: BSD3 -license-files: LICENSE + +license: BSD-2-Clause +license-file: LICENSE maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues category: Documentation -build-type: Simple +tested-with: GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.3 + , GHC == 8.10.1 + , GHC == 9.0.1 + , GHC == 9.2.0 + extra-source-files: CHANGES.md + fixtures/examples/*.input + fixtures/examples/*.parsed -library - default-language: Haskell2010 +common lib-defaults + default-language: Haskell2010 build-depends: - base >= 4.5 && < 4.13 - , bytestring >= 0.9.2.1 && < 0.11 - , containers >= 0.4.2.1 && < 0.7 - , transformers >= 0.3.0 && < 0.6 - , text >= 1.2.3.0 && < 1.3 - , parsec >= 3.1.13.0 && < 3.2 + , base >= 4.5 && < 4.17 + , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1 + , text ^>= 1.2.3.0 || ^>= 2.0 + , parsec ^>= 3.1.13.0 + ghc-options: -funbox-strict-fields -Wall + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + +library + import: lib-defaults + hs-source-dirs: src exposed-modules: @@ -36,73 +58,66 @@ Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Types - Documentation.Haddock.Utf8 other-modules: + CompatPrelude Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad - - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - + Documentation.Haddock.Parser.Identifier test-suite spec + import: lib-defaults type: exitcode-stdio-1.0 - default-language: Haskell2010 main-is: Spec.hs hs-source-dirs: - test - , src - ghc-options: -Wall - - cpp-options: - -DTEST + test + src other-modules: - Documentation.Haddock.Doc - Documentation.Haddock.Parser - Documentation.Haddock.Parser.Monad - Documentation.Haddock.Parser.Util - Documentation.Haddock.Parser.UtilSpec - Documentation.Haddock.ParserSpec - Documentation.Haddock.Types - Documentation.Haddock.Utf8 - Documentation.Haddock.Utf8Spec + CompatPrelude + Documentation.Haddock.Doc + Documentation.Haddock.Markup + Documentation.Haddock.Parser + Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Util + Documentation.Haddock.Parser.UtilSpec + Documentation.Haddock.ParserSpec + Documentation.Haddock.Types + Documentation.Haddock.Parser.Identifier build-depends: - base >= 4.5 && < 4.13 - , base-compat >= 0.9.3 && < 0.11 - , bytestring >= 0.9.2.1 && < 0.11 - , containers >= 0.4.2.1 && < 0.7 - , transformers >= 0.3.0 && < 0.6 - , hspec >= 2.4.4 && < 2.6 - , QuickCheck ^>= 2.11 - , text >= 1.2.3.0 && < 1.3 - , parsec >= 3.1.13.0 && < 3.2 - , deepseq >= 1.3 && < 1.5 + , base-compat ^>= 0.12.0 + , QuickCheck ^>= 2.11 || ^>= 2.13.2 || ^>= 2.14 + , deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0 + -- NB: build-depends & build-tool-depends have independent + -- install-plans, so it's best to limit to a single major + -- version of `hspec` & `hspec-discover` to ensure + -- intercompatibility + build-depends: + , hspec >= 2.4.4 && < 2.10 + build-tool-depends: - hspec-discover:hspec-discover >= 2.4.4 && < 2.6 + , hspec-discover:hspec-discover >= 2.4.4 && < 2.10 test-suite fixtures type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: Fixtures.hs - ghc-options: -Wall -O0 + ghc-options: -Wall hs-source-dirs: fixtures - buildable: False build-depends: - base >= 4.5 && < 4.13 - , base-compat >= 0.9.3 && < 0.11 + -- intra-package dependency + , haddock-library + -- constraints inherited via lib:haddock-library component + , base + + -- extra dependencies + , base-compat ^>= 0.12.0 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 - , optparse-applicative ^>= 0.14.0.0 - , tree-diff ^>= 0.0.0.1 - - -- Depend on the library. - build-depends: - haddock-library + , optparse-applicative ^>= 0.15 + , tree-diff ^>= 0.2 source-repository head type: git diff --git a/src/CompatPrelude.hs b/src/CompatPrelude.hs new file mode 100644 --- /dev/null +++ b/src/CompatPrelude.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} + +#ifdef __HLINT__ +#elif !MIN_VERSION_base(4,5,0) +# error This module doesn't provide compat-shims for versions prior to base-4.5 +#endif + +-- | Bridge impedance mismatch of different @base@ versions back till @base-4.5@ (GHC 7.4.2) +module CompatPrelude + ( ($>) + , isSymbolChar + ) where + +#if MIN_VERSION_base(4,7,0) +import Data.Functor ( ($>) ) +#else +import Data.Functor ( (<$) ) +#endif + +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory(..), generalCategory) +#endif + + +#if !MIN_VERSION_base(4,7,0) +infixl 4 $> + +-- | Flipped version of '<$'. +-- +-- @since 4.7.0.0 +($>) :: Functor f => f a -> b -> f b +($>) = flip (<$) +#endif + +#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 -> c `notElem` "'\"" + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif diff --git a/src/Documentation/Haddock/Markup.hs b/src/Documentation/Haddock/Markup.hs --- a/src/Documentation/Haddock/Markup.hs +++ b/src/Documentation/Haddock/Markup.hs @@ -2,35 +2,38 @@ module Documentation.Haddock.Markup ( markup , idMarkup + , plainMarkup ) where import Documentation.Haddock.Types +import Data.Maybe ( fromMaybe ) + markup :: DocMarkupH mod id a -> DocH mod id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -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)) +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule (ModLink mo l)) = markupModule m (ModLink mo (fmap (markup m) l)) +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (\(index, a) -> (index, markup m a)) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l)) +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocMathInline mathjax) = markupMathInline m mathjax +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) @@ -62,4 +65,35 @@ markupExample = DocExamples, markupHeader = DocHeader, markupTable = DocTable + } + +-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to +-- strip away any formatting while preserving as much of the actual text as +-- possible. +plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String +plainMarkup plainMod plainIdent = Markup { + markupEmpty = "", + markupString = id, + markupParagraph = id, + markupAppend = (++), + markupIdentifier = plainIdent, + markupIdentifierUnchecked = plainMod, + markupModule = \(ModLink m lbl) -> fromMaybe m lbl, + markupWarning = id, + markupEmphasis = id, + markupBold = id, + markupMonospaced = id, + markupUnorderedList = const "", + markupOrderedList = const "", + markupDefList = const "", + markupCodeBlock = id, + markupHyperlink = \(Hyperlink url lbl) -> fromMaybe url lbl, + markupAName = id, + markupPic = \(Picture uri title) -> fromMaybe uri title, + markupMathInline = id, + markupMathDisplay = id, + markupProperty = id, + markupExample = const "", + markupHeader = \(Header _ title) -> title, + markupTable = const "" } diff --git a/src/Documentation/Haddock/Parser.hs b/src/Documentation/Haddock/Parser.hs --- a/src/Documentation/Haddock/Parser.hs +++ b/src/Documentation/Haddock/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | @@ -27,14 +26,16 @@ import Control.Applicative import Control.Arrow (first) import Control.Monad -import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) -import Data.List (intercalate, unfoldr, elemIndex, notElem) +import Data.Char (chr, isUpper, isAlpha, isSpace) +import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set import Documentation.Haddock.Doc +import Documentation.Haddock.Markup ( markup, plainMarkup ) import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util +import Documentation.Haddock.Parser.Identifier import Documentation.Haddock.Types import Prelude hiding (takeWhile) import qualified Prelude as P @@ -45,69 +46,42 @@ import qualified Data.Text as T import Data.Text (Text) -#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 -> c `notElem` ("'\"" :: 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) - -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String -toRegular = fmap (\(_, x, _) -> x) +toRegular = fmap (\(Identifier _ _ x _) -> x) -- | Maps over 'DocIdentifier's over 'String' with potentially failing -- conversion using user-supplied function. If the conversion fails, -- the identifier is deemed to not be valid and is treated as a -- regular string. -overIdentifier :: (String -> Maybe a) +overIdentifier :: (Namespace -> String -> Maybe a) -> DocH mod Identifier -> DocH mod a overIdentifier f d = g d where - g (DocIdentifier (o, x, e)) = case f x of - Nothing -> DocString $ o : x ++ [e] + g (DocIdentifier (Identifier ns o x e)) = case f ns x of + Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e] Just x' -> DocIdentifier x' g DocEmpty = DocEmpty g (DocAppend x x') = DocAppend (g x) (g x') g (DocString x) = DocString x g (DocParagraph x) = DocParagraph $ g x g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x - g (DocModule x) = DocModule x + g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x)) g (DocWarning x) = DocWarning $ g x g (DocEmphasis x) = DocEmphasis $ g x g (DocMonospaced x) = DocMonospaced $ g x g (DocBold x) = DocBold $ g x g (DocUnorderedList x) = DocUnorderedList $ fmap g x - g (DocOrderedList x) = DocOrderedList $ fmap g x + g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x g (DocCodeBlock x) = DocCodeBlock $ g x - g (DocHyperlink x) = DocHyperlink x + g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x)) g (DocPic x) = DocPic x g (DocMathInline x) = DocMathInline x g (DocMathDisplay x) = DocMathDisplay x @@ -174,6 +148,7 @@ , mathDisplay , mathInline , markdownImage + , markdownLink , hyperlink , bold , emphasis @@ -198,11 +173,11 @@ -- Once we have checked for any of these and tried to parse the -- relevant markup, we can assume they are used as regular text. specialChar :: [Char] -specialChar = "_/<@\"&'`# " +specialChar = "_/<@\"&'`#[ " -- | Plain, regular parser for text. Called as one of the last parsers -- to ensure that we have already given a chance to more meaningful parsers --- before capturing their characers. +-- before capturing their characters. string' :: Parser (DocH mod a) string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar) where @@ -253,7 +228,7 @@ -- DocAName "Hello world" anchor :: Parser (DocH mod a) anchor = DocAName . T.unpack <$> - disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") + ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#") -- | Monospaced strings. -- @@ -268,15 +243,43 @@ -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) -moduleName = DocModule <$> ("\"" *> modid <* "\"") +moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"") + +-- | A module name, optionally with an anchor +-- +moduleNameString :: Parser String +moduleNameString = modid `maybeFollowedBy` anchor_ where modid = intercalate "." <$> conid `Parsec.sepBy1` "." + anchor_ = (++) + <$> (Parsec.string "#" <|> Parsec.string "\\#") + <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c))) + + maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf + conid :: Parser String conid = (:) <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) - <*> many (conChar <|> Parsec.oneOf "\\#") + <*> many conChar conChar = Parsec.alphaNum <|> Parsec.char '_' +-- | A labeled link to an indentifier, module or url using markdown +-- syntax. +markdownLink :: Parser (DocH mod Identifier) +markdownLink = do + lbl <- markdownLinkText + choice' [ markdownModuleName lbl, markdownURL lbl ] + where + markdownModuleName lbl = do + mn <- "(" *> skipHorizontalSpace *> + "\"" *> moduleNameString <* "\"" + <* skipHorizontalSpace <* ")" + pure $ DocModule (ModLink mn (Just lbl)) + + markdownURL lbl = do + target <- markdownLinkTarget + pure $ DocHyperlink $ Hyperlink target (Just lbl) + -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. -- @@ -293,7 +296,7 @@ -- >>> 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 . T.unpack +mathInline = DocMathInline . T.unpack <$> disallowNewline ("\\(" *> takeUntil "\\)") -- | Display math parser, surrounded by \\[ and \\]. @@ -301,13 +304,22 @@ -- >>> 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 . T.unpack +mathDisplay = DocMathDisplay . T.unpack <$> ("\\[" *> takeUntil "\\]") -markdownImage :: Parser (DocH mod a) -markdownImage = fromHyperlink <$> ("!" *> linkParser) +-- | Markdown image parser. As per the commonmark reference recommendation, the +-- description text for an image converted to its a plain string representation. +-- +-- >>> parseString "![some /emphasis/ in a description](www.site.com)" +-- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) +markdownImage :: Parser (DocH mod Identifier) +markdownImage = do + text <- markup stringMarkup <$> ("!" *> markdownLinkText) + url <- markdownLinkTarget + pure $ DocPic (Picture url (Just text)) where - fromHyperlink (Hyperlink url label) = DocPic (Picture url label) + stringMarkup = plainMarkup (const "") renderIdent + renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) @@ -349,7 +361,7 @@ firstRow <- parseFirstRow let len = T.length firstRow - -- then we parse all consequtive rows starting and ending with + or |, + -- then we parse all consecutive rows starting and ending with + or |, -- of the width `len`. restRows <- many (try (parseRestRows len)) @@ -360,32 +372,34 @@ parseFirstRow :: Parser Text parseFirstRow = do skipHorizontalSpace - -- upper-left corner is + - c <- Parsec.char '+' - cs <- some (Parsec.char '-' <|> Parsec.char '+') + cs <- takeWhile (\c -> c == '-' || c == '+') - -- upper right corner is + too - guard (last cs == '+') + -- upper-left and upper-right corners are `+` + guard (T.length cs >= 2 && + T.head cs == '+' && + T.last cs == '+') -- trailing space skipHorizontalSpace _ <- Parsec.newline - return (T.cons c $ T.pack cs) + return cs parseRestRows :: Int -> Parser Text parseRestRows l = do skipHorizontalSpace + bs <- scan predicate l - c <- Parsec.char '|' <|> Parsec.char '+' - bs <- scan predicate (l - 2) - c2 <- Parsec.char '|' <|> Parsec.char '+' + -- Left and right edges are `|` or `+` + guard (T.length bs >= 2 && + (T.head bs == '|' || T.head bs == '+') && + (T.last bs == '|' || T.last bs == '+')) -- trailing space skipHorizontalSpace _ <- Parsec.newline - return (T.cons c (T.snoc bs c2)) + return bs where predicate n c | n <= 0 = Nothing @@ -509,7 +523,7 @@ -- extract cell contents given boundaries extract :: Int -> Int -> Int -> Int -> Text extract x y x2 y2 = T.intercalate "\n" - [ T.take (x2 - x + 1) $ T.drop x $ rs !! y' + [ T.stripEnd $ T.stripStart $ T.take (x2 - x + 1) $ T.drop x $ rs !! y' | y' <- [y .. y2] ] @@ -529,11 +543,11 @@ header :: Parser (DocH mod Identifier) header = do let psers = map (string . flip T.replicate "=") [6, 5 .. 1] - pser = choice' psers - delim <- T.unpack <$> pser - line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText + pser = Parsec.choice psers + depth <- T.length <$> pser + line <- parseText <$> (skipHorizontalSpace *> nonEmptyLine) rest <- try paragraph <|> return DocEmpty - return $ DocHeader (Header (length delim) line) `docAppend` rest + return $ DocHeader (Header depth line) `docAppend` rest textParagraph :: Parser (DocH mod Identifier) textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine @@ -563,10 +577,24 @@ orderedList :: Text -> Parser (DocH mod Identifier) orderedList indent = DocOrderedList <$> p where - p = (paren <|> dot) *> innerList indent p + p = do + index <- paren <|> dot + innerList' indent p index dot = (decimal :: Parser Int) <* "." paren = "(" *> decimal <* ")" +-- | Like 'innerList' but takes the parsed index of the list item +innerList' :: Text -> Parser [(Int, DocH mod Identifier)] + -> Int + -> Parser [(Int, DocH mod Identifier)] +innerList' indent item index = do + c <- takeLine + (cs, items) <- more indent item + let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs + return $ case items of + Left p -> [(index, contents `docAppend` p)] + Right i -> (index, contents) : i + -- | Generic function collecting any further lines belonging to the -- list entry and recursively collecting any further lists in the -- same paragraph. Usually used as @@ -596,7 +624,7 @@ Right i -> (label, contents) : i -- | Drops all trailing newlines. -dropNLs :: Text -> Text +dropNLs :: Text -> Text dropNLs = T.dropWhileEnd (== '\n') -- | Main worker for 'innerList' and 'definitionList'. @@ -662,7 +690,7 @@ -- Doesn't discard the trailing newline. takeNonEmptyLine :: Parser Text takeNonEmptyLine = do - l <- takeWhile1 (Parsec.noneOf "\n") >>= nonSpace + l <- takeWhile1 (/= '\n') >>= nonSpace _ <- "\n" pure (l <> "\n") @@ -670,7 +698,7 @@ -- -- More precisely: skips all whitespace-only lines and returns indentation -- (horizontal space, might be empty) of that non-empty line. -takeIndent :: Parser Text +takeIndent :: Parser Text takeIndent = do indent <- takeHorizontalSpace choice' [ "\n" *> takeIndent @@ -696,7 +724,7 @@ Just (' ',t') -> Just t' _ -> Nothing --- | Parses examples. Examples are a paragraph level entitity (separated by an empty line). +-- | Parses examples. Examples are a paragraph level entity (separated by an empty line). -- Consecutive examples are accepted. examples :: Parser (DocH mod a) examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go) @@ -728,21 +756,21 @@ substituteBlankLine "" = "" substituteBlankLine xs = xs -nonEmptyLine :: Parser Text +nonEmptyLine :: Parser Text nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine) takeLine :: Parser Text -takeLine = try (takeWhile (Parsec.noneOf "\n") <* endOfLine) +takeLine = try (takeWhile (/= '\n') <* endOfLine) endOfLine :: Parser () -endOfLine = void "\n" <|> Parsec.eof +endOfLine = void "\n" <|> Parsec.eof -- | Property parser. -- -- >>> snd <$> parseOnly property "prop> hello world" -- Right (DocProperty "hello world") property :: Parser (DocH mod a) -property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (Parsec.noneOf "\n")) +property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (/= '\n')) -- | -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed @@ -782,23 +810,22 @@ | isNewline && isSpace c = Just isNewline | otherwise = Just $ c == '\n' -hyperlink :: Parser (DocH mod a) -hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] +hyperlink :: Parser (DocH mod Identifier) +hyperlink = choice' [ angleBracketLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = - DocHyperlink . makeLabeled Hyperlink + DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString) <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod a) -markdownLink = DocHyperlink <$> linkParser +-- | The text for a markdown link, enclosed in square brackets. +markdownLinkText :: Parser (DocH mod Identifier) +markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]") -linkParser :: Parser Hyperlink -linkParser = flip Hyperlink <$> label <*> (whitespace *> url) +-- | The target for a markdown link, enclosed in parenthesis. +markdownLinkTarget :: Parser String +markdownLinkTarget = whitespace *> url where - label :: Parser (Maybe String) - label = Just . decode . T.strip <$> ("[" *> takeUntil "]") - whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) @@ -816,41 +843,17 @@ autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url where - url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (Parsec.satisfy (not . isSpace)) - + url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (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 :: Text -> Hyperlink (DocH mod a) 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 --- characters and does no actual validation itself. -parseValid :: Parser String -parseValid = p some - where - idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') - - p p' = do - vs <- p' idChar - c <- peekChar' - case c of - '`' -> return vs - '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] - _ -> fail "outofvalid" - --- | Parses identifiers with help of 'parseValid'. Asks GHC for --- 'String' from the string it deems valid. +-- | Parses identifiers with help of 'parseValid'. identifier :: Parser (DocH mod Identifier) -identifier = do - o <- idDelim - vid <- parseValid - e <- idDelim - return $ DocIdentifier (o, vid, e) - where - idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') +identifier = DocIdentifier <$> parseValid diff --git a/src/Documentation/Haddock/Parser/Identifier.hs b/src/Documentation/Haddock/Parser/Identifier.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/Haddock/Parser/Identifier.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Documentation.Haddock.Parser.Identifier +-- Copyright : (c) Alec Theriault 2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Functionality for parsing identifiers and operators + +module Documentation.Haddock.Parser.Identifier ( + Identifier(..), + parseValid, +) where + +import Documentation.Haddock.Types ( Namespace(..) ) +import Documentation.Haddock.Parser.Monad +import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) + +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Char (isAlpha, isAlphaNum) +import Control.Monad (guard) +import Data.Maybe +import CompatPrelude + +-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks. +data Identifier = Identifier !Namespace !Char String !Char + deriving (Show, Eq) + +parseValid :: Parser Identifier +parseValid = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + + case takeIdentifier inp of + Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier" + Just (ns, op, ident, cl, inp') -> + let posOp = updatePosChar pos op + posIdent = T.foldl updatePosChar posOp ident + posCl = updatePosChar posIdent cl + s' = s{ stateInput = inp', statePos = posCl } + in setParserState s' $> Identifier ns op (T.unpack ident) cl + + +-- | Try to parse a delimited identifier off the front of the given input. +-- +-- This tries to match as many valid Haskell identifiers/operators as possible, +-- to the point of sometimes accepting invalid things (ex: keywords). Some +-- considerations: +-- +-- - operators and identifiers can have module qualifications +-- - operators can be wrapped in parens (for prefix) +-- - identifiers can be wrapped in backticks (for infix) +-- - delimiters are backticks or regular ticks +-- - since regular ticks are also valid in identifiers, we opt for the +-- longest successful parse +-- +-- This function should make /O(1)/ allocations +takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text) +takeIdentifier input = listToMaybe $ do + + -- Optional namespace + let (ns, input') = case T.uncons input of + Just ('v', i) -> (Value, i) + Just ('t', i) -> (Type, i) + _ -> (None, input) + + -- Opening tick + (op, input'') <- maybeToList (T.uncons input') + guard (op == '\'' || op == '`') + + -- Identifier/operator + (ident, input''') <- wrapped input'' + + -- Closing tick + (cl, input'''') <- maybeToList (T.uncons input''') + guard (cl == '\'' || cl == '`') + + return (ns, op, ident, cl, input'''') + + where + + -- | Parse out a wrapped, possibly qualified, operator or identifier + wrapped t = do + (c, t' ) <- maybeToList (T.uncons t) + -- Tuples + case c of + '(' | Just (c', _) <- T.uncons t' + , c' == ',' || c' == ')' + -> do let (commas, t'') = T.span (== ',') t' + (')', t''') <- maybeToList (T.uncons t'') + return (T.take (T.length commas + 2) t, t''') + + -- Parenthesized + '(' -> do (n, t'' ) <- general False 0 [] t' + (')', t''') <- maybeToList (T.uncons t'') + return (T.take (n + 2) t, t''') + + -- Backticked + '`' -> do (n, t'' ) <- general False 0 [] t' + ('`', t''') <- maybeToList (T.uncons t'') + return (T.take (n + 2) t, t''') + + -- Unadorned + _ -> do (n, t'' ) <- general False 0 [] t + return (T.take n t, t'') + + -- | Parse out a possibly qualified operator or identifier + general :: Bool -- ^ refuse inputs starting with operators + -> Int -- ^ total characters \"consumed\" so far + -> [(Int, Text)] -- ^ accumulated results + -> Text -- ^ current input + -> [(Int, Text)] -- ^ total characters parsed & what remains + general !identOnly !i acc t + -- Starts with an identifier (either just an identifier, or a module qual) + | Just (n, rest) <- identLike t + = if T.null rest + then acc + else case T.head rest of + '`' -> (n + i, rest) : acc + ')' -> (n + i, rest) : acc + '.' -> general False (n + i + 1) acc (T.tail rest) + '\'' -> let (m, rest') = quotes rest + in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest') + _ -> acc + + -- An operator + | Just (n, rest) <- optr t + , not identOnly + = (n + i, rest) : acc + + -- Anything else + | otherwise + = acc + + -- | Parse an identifier off the front of the input + identLike t + | T.null t = Nothing + | isAlpha (T.head t) || '_' == T.head t + = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t + !(octos, rest') = T.span (== '#') rest + in Just (T.length idt + T.length octos, rest') + | otherwise = Nothing + + -- | Parse all but the last quote off the front of the input + -- PRECONDITION: T.head t `elem` ['\'', '`'] + quotes :: Text -> (Int, Text) + quotes t = let !n = T.length (T.takeWhile (`elem` ['\'', '`']) t) - 1 + in (n, T.drop n t) + + -- | Parse an operator off the front of the input + optr t = let !(op, rest) = T.span isSymbolChar t + in if T.null op then Nothing else Just (T.length op, rest) diff --git a/src/Documentation/Haddock/Parser/Monad.hs b/src/Documentation/Haddock/Parser/Monad.hs --- a/src/Documentation/Haddock/Parser/Monad.hs +++ b/src/Documentation/Haddock/Parser/Monad.hs @@ -1,18 +1,33 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Documentation.Haddock.Parser.Monad +-- Copyright : (c) Alec Theriault 2018-2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Defines the Parsec monad over which all parsing is done and also provides +-- more efficient versions of the usual parsec combinator functions (but +-- specialized to 'Text'). module Documentation.Haddock.Parser.Monad where import qualified Text.Parsec.Char as Parsec import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) import qualified Data.Text as T import Data.Text ( Text ) +import Control.Monad ( mfilter ) import Data.String ( IsString(..) ) import Data.Bits ( Bits(..) ) import Data.Char ( ord ) @@ -21,6 +36,12 @@ import Documentation.Haddock.Types ( Version ) +import Prelude hiding (takeWhile) +import CompatPrelude + +-- | The only bit of information we really care about trudging along with us +-- through parsing is the version attached to a @\@since@ annotation - if +-- the doc even contained one. newtype ParserState = ParserState { parserStateSince :: Maybe Version } deriving (Eq, Show) @@ -29,7 +50,7 @@ initialParserState = ParserState Nothing setSince :: Version -> Parser () -setSince since = Parsec.modifyState (\st -> st {parserStateSince = Just since}) +setSince since = Parsec.modifyState (\st -> st{ parserStateSince = Just since }) type Parser = Parsec.Parsec Text ParserState @@ -44,38 +65,74 @@ -- | Always succeeds, but returns 'Nothing' if at the end of input. Does not -- consume input. +-- +-- Equivalent to @Parsec.optionMaybe . Parsec.lookAhead $ Parsec.anyChar@, but +-- more efficient. peekChar :: Parser (Maybe Char) -peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar +peekChar = headOpt . stateInput <$> getParserState + where headOpt t | T.null t = Nothing + | otherwise = Just (T.head t) +{-# INLINE peekChar #-} -- | Fails if at the end of input. Does not consume input. +-- +-- Equivalent to @Parsec.lookAhead Parsec.anyChar@, but more efficient. peekChar' :: Parser Char -peekChar' = Parsec.lookAhead Parsec.anyChar +peekChar' = headFail . stateInput =<< getParserState + where headFail t | T.null t = Parsec.parserFail "peekChar': reached EOF" + | otherwise = App.pure (T.head t) +{-# INLINE peekChar' #-} -- | Parses the given string. Returns the parsed string. +-- +-- Equivalent to @Parsec.string (T.unpack t) $> t@, but more efficient. string :: Text -> Parser Text -string t = Parsec.string (T.unpack t) *> App.pure t +string t = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + case T.stripPrefix t inp of + Nothing -> Parsec.parserFail "string: Failed to match the input string" + Just inp' -> + let pos' = T.foldl updatePosChar pos t + s' = s{ stateInput = inp', statePos = pos' } + in setParserState s' $> t +-- | Keep matching characters as long as the predicate function holds (and +-- return them). +-- +-- Equivalent to @fmap T.pack . Parsec.many@, but more efficient. +takeWhile :: (Char -> Bool) -> Parser Text +takeWhile f = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + let (t, inp') = T.span f inp + pos' = T.foldl updatePosChar pos t + s' = s{ stateInput = inp', statePos = pos' } + setParserState s' $> t + +-- | Like 'takeWhile', but fails if no characters matched. +-- +-- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient. +takeWhile1 :: (Char -> Bool) -> Parser Text +takeWhile1 = mfilter (not . T.null) . takeWhile + -- | 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 +scan f st = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + go inp st pos 0 $ \inp' pos' n -> + let s' = s{ Parsec.stateInput = inp', Parsec.statePos = pos' } + in setParserState s' $> T.take n inp + where + go inp s !pos !n cont + = case T.uncons inp of + Nothing -> cont inp pos n -- ran out of input + Just (c, inp') -> + case f s c of + Nothing -> cont inp pos n -- scan function failed + Just s' -> go inp' s' (updatePosChar pos c) (n+1) cont --- | 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 diff --git a/src/Documentation/Haddock/Parser/Util.hs b/src/Documentation/Haddock/Parser/Util.hs --- a/src/Documentation/Haddock/Parser/Util.hs +++ b/src/Documentation/Haddock/Parser/Util.hs @@ -31,16 +31,16 @@ import Data.Char (isSpace) -- | Characters that count as horizontal space -horizontalSpace :: [Char] -horizontalSpace = " \t\f\v\r" +horizontalSpace :: Char -> Bool +horizontalSpace c = isSpace c && c /= '\n' -- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser () -skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) +skipHorizontalSpace = Parsec.skipMany (Parsec.satisfy horizontalSpace) -- | Take leading horizontal space -takeHorizontalSpace :: Parser Text -takeHorizontalSpace = takeWhile (Parsec.oneOf horizontalSpace) +takeHorizontalSpace :: Parser Text +takeHorizontalSpace = takeWhile horizontalSpace makeLabeled :: (String -> Maybe String -> a) -> Text -> a makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of @@ -60,10 +60,10 @@ -- | 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 :: Text -> Parser Text takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome where - end = T.unpack end_ + end = T.unpack end_ p :: (Bool, String) -> Char -> Maybe (Bool, String) p acc c = case acc of diff --git a/src/Documentation/Haddock/Types.hs b/src/Documentation/Haddock/Types.hs --- a/src/Documentation/Haddock/Types.hs +++ b/src/Documentation/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP, DeriveTraversable #-} -- | -- Module : Documentation.Haddock.Types @@ -44,14 +44,17 @@ } deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0) +-- | __NOTE__: Only defined for @base >= 4.8.0@ instance Bifunctor MetaDoc where bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d) #endif #if MIN_VERSION_base(4,10,0) +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bifoldable MetaDoc where bifoldr f g z d = bifoldr f g z (_doc d) +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bitraversable MetaDoc where bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d #endif @@ -65,18 +68,23 @@ type Version = [Int] type Package = String -data Hyperlink = Hyperlink +data Hyperlink id = Hyperlink { hyperlinkUrl :: String - , hyperlinkLabel :: Maybe String - } deriving (Eq, Show) + , hyperlinkLabel :: Maybe id + } deriving (Eq, Show, Functor, Foldable, Traversable) +data ModLink id = ModLink + { modLinkName :: String + , modLinkLabel :: Maybe id + } deriving (Eq, Show, Functor, Foldable, Traversable) + data Picture = Picture { pictureUri :: String , pictureTitle :: Maybe String } deriving (Eq, Show) data Header id = Header - { headerLevel :: Int + { headerLevel :: Int -- ^ between 1 and 6 inclusive , headerTitle :: id } deriving (Eq, Show, Functor, Foldable, Traversable) @@ -108,22 +116,23 @@ | DocIdentifier id | DocIdentifierUnchecked mod -- ^ A qualified identifier that couldn't be resolved. - | DocModule String + | DocModule (ModLink (DocH mod id)) + -- ^ A link to a module, with an optional label. | DocWarning (DocH mod id) -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) | DocMonospaced (DocH mod id) | DocBold (DocH mod id) | DocUnorderedList [DocH mod id] - | DocOrderedList [DocH mod id] + | DocOrderedList [(Int, DocH mod id)] | DocDefList [(DocH mod id, DocH mod id)] | DocCodeBlock (DocH mod id) - | DocHyperlink Hyperlink + | DocHyperlink (Hyperlink (DocH mod id)) | DocPic Picture | DocMathInline String | DocMathDisplay String | DocAName String - -- ^ A (HTML) anchor. + -- ^ A (HTML) anchor. It must not contain any spaces. | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id)) @@ -131,6 +140,7 @@ deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0) +-- | __NOTE__: Only defined for @base >= 4.8.0@ instance Bifunctor DocH where bimap _ _ DocEmpty = DocEmpty bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB) @@ -138,16 +148,16 @@ bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) bimap _ g (DocIdentifier i) = DocIdentifier (g i) bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m) - bimap _ _ (DocModule s) = DocModule s + bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl)) bimap f g (DocWarning doc) = DocWarning (bimap f g doc) bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) bimap f g (DocBold doc) = DocBold (bimap f g doc) bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs) - bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs) + bimap f g (DocOrderedList docs) = DocOrderedList (map (\(index, a) -> (index, bimap f g a)) docs) bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc) - bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink + bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl)) bimap _ _ (DocPic picture) = DocPic picture bimap _ _ (DocMathInline s) = DocMathInline s bimap _ _ (DocMathDisplay s) = DocMathDisplay s @@ -159,6 +169,7 @@ #endif #if MIN_VERSION_base(4,10,0) +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bifoldable DocH where bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB bifoldr f g z (DocParagraph doc) = bifoldr f g z doc @@ -169,13 +180,14 @@ bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc bifoldr f g z (DocBold doc) = bifoldr f g z doc bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs - bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs + bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z (map snd docs) 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 +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bitraversable DocH where bitraverse _ _ DocEmpty = pure DocEmpty bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB @@ -183,16 +195,17 @@ bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m - bitraverse _ _ (DocModule s) = pure (DocModule s) + bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl) bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs - bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs + bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverseSnd (bitraverse f g) docs + where traverseSnd f' = traverse (\(x, a) -> (\b -> (x, b)) <$> f' a) bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc - bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink) + bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl) bitraverse _ _ (DocPic picture) = pure (DocPic picture) bitraverse _ _ (DocMathInline s) = pure (DocMathInline s) bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s) @@ -203,6 +216,16 @@ 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 +-- | The namespace qualification for an identifier. +data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show) + +-- | Render the a namespace into the same format it was initially parsed. +renderNs :: Namespace -> String +renderNs Value = "v" +renderNs Type = "t" +renderNs None = "" + + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). @@ -218,16 +241,16 @@ , markupAppend :: a -> a -> a , markupIdentifier :: id -> a , markupIdentifierUnchecked :: mod -> a - , markupModule :: String -> a + , markupModule :: ModLink a -> a , markupWarning :: a -> a , markupEmphasis :: a -> a , markupBold :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a + , markupOrderedList :: [(Int,a)] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a + , markupHyperlink :: Hyperlink a -> a , markupAName :: String -> a , markupPic :: Picture -> a , markupMathInline :: String -> a diff --git a/src/Documentation/Haddock/Utf8.hs b/src/Documentation/Haddock/Utf8.hs deleted file mode 100644 --- a/src/Documentation/Haddock/Utf8.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where -import Data.Bits ((.|.), (.&.), shiftL, shiftR) -import qualified Data.ByteString as BS -import Data.Char (chr, ord) -import Data.Word (Word8) - --- | Helper that encodes and packs a 'String' into a 'BS.ByteString' -encodeUtf8 :: String -> BS.ByteString -encodeUtf8 = BS.pack . encode - --- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String' -decodeUtf8 :: BS.ByteString -> String -decodeUtf8 = decode . BS.unpack - --- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding --- | Character to use when 'encode' or 'decode' fail for a byte. -replacementCharacter :: Char -replacementCharacter = '\xfffd' - --- | Encode a Haskell String to a list of Word8 values, in UTF8 format. -encode :: String -> [Word8] -encode = concatMap (map fromIntegral . go . ord) - where - go oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- | Decode a UTF8 string packed into a list of Word8 values, directly to String -decode :: [Word8] -> String -decode [ ] = "" -decode (c:cs) - | c < 0x80 = chr (fromEnum c) : decode cs - | c < 0xc0 = replacementCharacter : decode cs - | c < 0xe0 = multi1 - | c < 0xf0 = multi_byte 2 0xf 0x800 - | c < 0xf8 = multi_byte 3 0x7 0x10000 - | c < 0xfc = multi_byte 4 0x3 0x200000 - | c < 0xfe = multi_byte 5 0x1 0x4000000 - | otherwise = replacementCharacter : decode cs - where - multi1 = case cs of - c1 : ds | c1 .&. 0xc0 == 0x80 -> - let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) - in if d >= 0x000080 then toEnum d : decode ds - else replacementCharacter : decode ds - _ -> replacementCharacter : decode cs - - multi_byte :: Int -> Word8 -> Int -> String - multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) - where - aux 0 rs acc - | overlong <= acc && acc <= 0x10ffff && - (acc < 0xd800 || 0xdfff < acc) && - (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs - | otherwise = replacementCharacter : decode rs - - aux n (r:rs) acc - | r .&. 0xc0 == 0x80 = aux (n-1) rs - $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) - - aux _ rs _ = replacementCharacter : decode rs diff --git a/test/Documentation/Haddock/Parser/UtilSpec.hs b/test/Documentation/Haddock/Parser/UtilSpec.hs --- a/test/Documentation/Haddock/Parser/UtilSpec.hs +++ b/test/Documentation/Haddock/Parser/UtilSpec.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Documentation.Haddock.Parser.UtilSpec (main, spec) where import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util -import Data.Either.Compat (isLeft) +import Data.Either (isLeft) import Test.Hspec +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative +#endif main :: IO () main = hspec spec diff --git a/test/Documentation/Haddock/ParserSpec.hs b/test/Documentation/Haddock/ParserSpec.hs --- a/test/Documentation/Haddock/ParserSpec.hs +++ b/test/Documentation/Haddock/ParserSpec.hs @@ -3,6 +3,7 @@ module Documentation.Haddock.ParserSpec (main, spec) where +import Data.Char (isSpace) import Data.String import qualified Documentation.Haddock.Parser as Parse import Documentation.Haddock.Types @@ -37,7 +38,7 @@ parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString -hyperlink :: String -> Maybe String -> Doc String +hyperlink :: String -> Maybe (Doc String) -> Doc String hyperlink url = DocHyperlink . Hyperlink url main :: IO () @@ -112,7 +113,7 @@ "``" `shouldParseTo` "``" it "can parse an identifier in infix notation enclosed within backticks" $ do - "``infix``" `shouldParseTo` "`" <> DocIdentifier "infix" <> "`" + "``infix``" `shouldParseTo` DocIdentifier "`infix`" it "can parse identifiers containing a single quote" $ do "'don't'" `shouldParseTo` DocIdentifier "don't" @@ -120,6 +121,9 @@ it "can parse identifiers ending with a single quote" $ do "'foo''" `shouldParseTo` DocIdentifier "foo'" + it "can parse identifiers in backticks ending with a single quote" $ do + "`foo'`" `shouldParseTo` DocIdentifier "foo'" + it "can parse an identifier containing a digit" $ do "'f0'" `shouldParseTo` DocIdentifier "f0" @@ -132,6 +136,19 @@ it "can parse an identifier that starts with an underscore" $ do "'_x'" `shouldParseTo` DocIdentifier "_x" + it "can parse value-namespaced identifiers" $ do + "v'foo'" `shouldParseTo` DocIdentifier "foo" + + it "can parse type-namespaced identifiers" $ do + "t'foo'" `shouldParseTo` DocIdentifier "foo" + + it "can parse parenthesized operators and backticked identifiers" $ do + "'(<|>)'" `shouldParseTo` DocIdentifier "(<|>)" + "'`elem`'" `shouldParseTo` DocIdentifier "`elem`" + + it "can properly figure out the end of identifiers" $ do + "'DbModule'/'DbUnitId'" `shouldParseTo` DocIdentifier "DbModule" <> "/" <> DocIdentifier "DbUnitId" + context "when parsing operators" $ do it "can parse an operator enclosed within single quotes" $ do "'.='" `shouldParseTo` DocIdentifier ".=" @@ -202,6 +219,10 @@ "[some label]( url)" `shouldParseTo` "[some label]( url)" + it "allows inline markup in the label" $ do + "[something /emphasized/](url)" `shouldParseTo` + hyperlink "url" (Just ("something " <> DocEmphasis "emphasized")) + context "when URL is on a separate line" $ do it "allows URL to be on a separate line" $ do "[some label]\n(url)" `shouldParseTo` @@ -271,8 +292,10 @@ it "parses a single word anchor" $ do "#foo#" `shouldParseTo` DocAName "foo" - it "parses a multi word anchor" $ do - "#foo bar#" `shouldParseTo` DocAName "foo bar" + -- Spaces are not allowed: + -- https://www.w3.org/TR/html51/dom.html#the-id-attribute + it "doesn't parse a multi word anchor" $ do + "#foo bar#" `shouldParseTo` "#foo bar#" it "parses a unicode anchor" $ do "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ" @@ -287,6 +310,9 @@ it "does not accept empty anchors" $ do "##" `shouldParseTo` "##" + it "does not accept anchors containing spaces" $ do + "{-# LANGUAGE GADTs #-}" `shouldParseTo` "{-# LANGUAGE GADTs #-}" + context "when parsing emphasised text" $ do it "emphasises a word on its own" $ do "/foo/" `shouldParseTo` DocEmphasis "foo" @@ -380,20 +406,20 @@ context "when parsing module strings" $ do it "should parse a module on its own" $ do "\"Module\"" `shouldParseTo` - DocModule "Module" + DocModule (ModLink "Module" Nothing) it "should parse a module inline" $ do "This is a \"Module\"." `shouldParseTo` - "This is a " <> DocModule "Module" <> "." + "This is a " <> DocModule (ModLink "Module" Nothing) <> "." it "can accept a simple module name" $ do - "\"Hello\"" `shouldParseTo` DocModule "Hello" + "\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing) it "can accept a module name with dots" $ do - "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World" + "\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing) it "can accept a module name with unicode" $ do - "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ" + "\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing) it "parses a module name with a trailing dot as regular quoted string" $ do "\"Hello.\"" `shouldParseTo` "\"Hello.\"" @@ -405,17 +431,86 @@ "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\"" it "accepts a module name with unicode" $ do - "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ" + "\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing) it "treats empty module name as regular double quotes" $ do "\"\"" `shouldParseTo` "\"\"" it "accepts anchor reference syntax as DocModule" $ do - "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar" + "\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing) + it "accepts anchor with hyphen as DocModule" $ do + "\"Foo#bar-baz\"" `shouldParseTo` DocModule (ModLink "Foo#bar-baz" Nothing) + it "accepts old anchor reference syntax as DocModule" $ do - "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" + "\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing) + context "when parsing labeled module links" $ do + it "parses a simple labeled module link" $ do + "[some label](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows escaping in label" $ do + "[some\\] label](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some] label")) + + it "strips leading and trailing whitespace from label" $ do + "[ some label ](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows whitespace in module name link" $ do + "[some label]( \"Some.Module\"\t )" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows inline markup in the label" $ do + "[something /emphasized/](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized"))) + + it "should parse a labeled module on its own" $ do + "[label](\"Module\")" `shouldParseTo` + DocModule (ModLink "Module" (Just "label")) + + it "should parse a labeled module inline" $ do + "This is a [label](\"Module\")." `shouldParseTo` + "This is a " <> DocModule (ModLink "Module" (Just "label")) <> "." + + it "can accept a labeled module name with dots" $ do + "[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label")) + + it "can accept a labeled module name with unicode" $ do + "[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label")) + + it "parses a labeled module name with a trailing dot as a hyperlink" $ do + "[label](\"Hello.\")" `shouldParseTo` + hyperlink "\"Hello.\"" (Just "label") + + it "parses a labeled module name with a space as a regular string" $ do + "[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")" + + it "parses a module name with invalid characters as a hyperlink" $ do + "[label](\"Hello&[{}(=*+]!\")" `shouldParseTo` + hyperlink "\"Hello&[{}(=*+]!\"" (Just "label") + + it "accepts a labeled module name with unicode" $ do + "[label](\"Foo.Barλ\")" `shouldParseTo` + DocModule (ModLink "Foo.Barλ" (Just "label")) + + it "treats empty labeled module name as empty hyperlink" $ do + "[label](\"\")" `shouldParseTo` + hyperlink "\"\"" (Just "label") + + it "accepts anchor reference syntax for labeled module name" $ do + "[label](\"Foo#bar\")" `shouldParseTo` + DocModule (ModLink "Foo#bar" (Just "label")) + + it "accepts old anchor reference syntax for labeled module name" $ do + "[label](\"Foo\\#bar\")" `shouldParseTo` + DocModule (ModLink "Foo\\#bar" (Just "label")) + + it "interprets empty label as a unlabeled module name" $ do + "[](\"Module.Name\")" `shouldParseTo` + "[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")" + describe "parseParas" $ do let infix 1 `shouldParseTo` shouldParseTo :: String -> Doc String -> Expectation @@ -425,6 +520,10 @@ property $ \xs -> (length . show . parseParas) xs `shouldSatisfy` (> 0) + -- See + it "doesn't crash on unicode whitespace" $ do + "\8197" `shouldParseTo` DocEmpty + context "when parsing @since" $ do it "adds specified version to the result" $ do parseParas "@since 0.5.0" `shouldBe` @@ -453,7 +552,8 @@ context "when parsing text paragraphs" $ do - let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) + let isSpecial c = isSpace c || c `elem` (".(=#-[*`\\\"'_/@<>" :: String) + filterSpecial = filter (not . isSpecial) it "parses an empty paragraph" $ do "" `shouldParseTo` DocEmpty @@ -479,28 +579,38 @@ it "turns it into a code block" $ do "@foo@" `shouldParseTo` DocCodeBlock "foo" - context "when a paragraph starts with a markdown link" $ do - it "correctly parses it as a text paragraph (not a definition list)" $ do - "[label](url)" `shouldParseTo` - DocParagraph (hyperlink "url" "label") + context "when a paragraph contains a markdown link" $ do + it "correctly parses the link" $ do + "Blah [label](url)" `shouldParseTo` + DocParagraph ("Blah " <> hyperlink "url" "label") - it "can be followed by an other paragraph" $ do - "[label](url)\n\nfoobar" `shouldParseTo` - DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar" + context "when the paragraph starts with the markdown link" $ do + it "correctly parses it as a text paragraph (not a definition list)" $ do + "[label](url)" `shouldParseTo` + DocParagraph (hyperlink "url" "label") - context "when paragraph contains additional text" $ do - it "accepts more text after the link" $ do - "[label](url) foo bar baz" `shouldParseTo` - DocParagraph (hyperlink "url" "label" <> " foo bar baz") + it "can be followed by an other paragraph" $ do + "[label](url)\n\nfoobar" `shouldParseTo` + DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar" - it "accepts a newline right after the markdown link" $ do - "[label](url)\nfoo bar baz" `shouldParseTo` - DocParagraph (hyperlink "url" "label" <> " foo bar baz") + context "when paragraph contains additional text" $ do + it "accepts more text after the link" $ do + "[label](url) foo bar baz" `shouldParseTo` + DocParagraph (hyperlink "url" "label" <> " foo bar baz") - it "can be followed by an other paragraph" $ do - "[label](url)foo\n\nbar" `shouldParseTo` - DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar" + it "accepts a newline right after the markdown link" $ do + "[label](url)\nfoo bar baz" `shouldParseTo` + DocParagraph (hyperlink "url" "label" <> " foo bar baz") + it "can be followed by an other paragraph" $ do + "[label](url)foo\n\nbar" `shouldParseTo` + DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar" + + context "when the link starts on a new line not at the beginning of the paragraph" $ do + it "correctly parses the link" $ do + "Bla\n[label](url)" `shouldParseTo` + DocParagraph ("Bla\n" <> hyperlink "url" "label") + context "when parsing birdtracks" $ do it "parses them as a code block" $ do unlines [ @@ -713,7 +823,7 @@ it "can nest another type of list inside" $ do "* foo\n\n 1. bar" `shouldParseTo` DocUnorderedList [ DocParagraph "foo" - <> DocOrderedList [DocParagraph "bar"]] + <> DocOrderedList [(1, DocParagraph "bar")]] it "can nest a code block inside" $ do "* foo\n\n @foo bar baz@" `shouldParseTo` @@ -752,7 +862,7 @@ DocUnorderedList [ DocParagraph "foo" <> DocUnorderedList [ DocParagraph "bar" ] ] - <> DocOrderedList [ DocParagraph "baz" ] + <> DocOrderedList [ (1, DocParagraph "baz") ] it "allows arbitrary initial indent of a list" $ do unlines @@ -776,20 +886,20 @@ DocDefList [ ("foo", "foov" <> DocDefList [ ("bar", "barv") ]) ] - <> DocOrderedList [ DocParagraph "baz" ] + <> DocOrderedList [ (1, DocParagraph "baz") ] it "list order is preserved in presence of nesting + extra text" $ do "1. Foo\n\n > Some code\n\n2. Bar\n\nSome text" `shouldParseTo` - DocOrderedList [ DocParagraph "Foo" <> DocCodeBlock "Some code" - , DocParagraph "Bar" + DocOrderedList [ (1, DocParagraph "Foo" <> DocCodeBlock "Some code") + , (2, DocParagraph "Bar") ] <> DocParagraph (DocString "Some text") "1. Foo\n\n2. Bar\n\nSome text" `shouldParseTo` - DocOrderedList [ DocParagraph "Foo" - , DocParagraph "Bar" + DocOrderedList [ (1, DocParagraph "Foo") + , (2, DocParagraph "Bar") ] <> DocParagraph (DocString "Some text") @@ -873,9 +983,9 @@ , " 3. three" ] `shouldParseTo` DocOrderedList [ - DocParagraph "one" - , DocParagraph "two" - , DocParagraph "three" + (1, DocParagraph "one") + , (1, DocParagraph "two") + , (3, DocParagraph "three") ] it "ignores empty lines between list items" $ do @@ -885,12 +995,12 @@ , "2. two" ] `shouldParseTo` DocOrderedList [ - DocParagraph "one" - , DocParagraph "two" + (1, DocParagraph "one") + , (2, DocParagraph "two") ] it "accepts an empty list item" $ do - "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty] + "1." `shouldParseTo` DocOrderedList [(1, DocParagraph DocEmpty)] it "accepts multi-line list items" $ do unlines [ @@ -900,12 +1010,12 @@ , "more two" ] `shouldParseTo` DocOrderedList [ - DocParagraph "point one\n more one" - , DocParagraph "point two\nmore two" + (1, DocParagraph "point one\n more one") + , (1, DocParagraph "point two\nmore two") ] it "accepts markup in list items" $ do - "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")] + "1. /foo/" `shouldParseTo` DocOrderedList [(1, DocParagraph (DocEmphasis "foo"))] it "requires empty lines between list and other paragraphs" $ do unlines [ @@ -915,7 +1025,7 @@ , "" , "baz" ] - `shouldParseTo` DocParagraph "foo" <> DocOrderedList [DocParagraph "bar"] <> DocParagraph "baz" + `shouldParseTo` DocParagraph "foo" <> DocOrderedList [(1, DocParagraph "bar")] <> DocParagraph "baz" context "when parsing definition lists" $ do it "parses a simple list" $ do @@ -1002,8 +1112,8 @@ ] `shouldParseTo` DocUnorderedList [ DocParagraph "bullet" , DocParagraph "different bullet"] - <> DocOrderedList [ DocParagraph "ordered" - , DocParagraph "different bullet" + <> DocOrderedList [ (1, DocParagraph "ordered") + , (2, DocParagraph "different bullet") ] <> DocDefList [ ("cat", "kitten") , ("pineapple", "fruit") diff --git a/test/Documentation/Haddock/Utf8Spec.hs b/test/Documentation/Haddock/Utf8Spec.hs deleted file mode 100644 --- a/test/Documentation/Haddock/Utf8Spec.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Documentation.Haddock.Utf8Spec (main, spec) where - -import Test.Hspec -import Test.QuickCheck -import Documentation.Haddock.Utf8 - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "decodeUtf8" $ do - it "is inverse to encodeUtf8" $ do - property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs