diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2021-02-06 18:30:35 -0500 | 
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2021-02-06 18:30:35 -0500 | 
| commit | b995bfe84f9766e23ff78d7ccd520ec7d8cdbebc (patch) | |
| tree | 3e7f15ac3b0abe417797ec89275aa1209f6ca297 /haddock-library | |
| parent | 9f597b6647a53624eaf501a34bfb4d8d15425929 (diff) | |
| parent | 010f0320dff64e3f86091ba4691bc69ce6999647 (diff) | |
Merge branch 'wip/ghc-head-merge' into ghc-head
Diffstat (limited to 'haddock-library')
22 files changed, 498 insertions, 207 deletions
| diff --git a/haddock-library/.ghci b/haddock-library/.ghci deleted file mode 100644 index 78950a5b..00000000 --- a/haddock-library/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -isrc -ivendor/attoparsec-0.12.1.1 -itest -idist/build -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index 265579ca..5b400d7c 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,3 +1,9 @@ +## 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) diff --git a/haddock-library/fixtures/examples/list-blocks1.input b/haddock-library/fixtures/examples/list-blocks1.input new file mode 100644 index 00000000..72a0640b --- /dev/null +++ b/haddock-library/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/haddock-library/fixtures/examples/list-blocks1.parsed b/haddock-library/fixtures/examples/list-blocks1.parsed new file mode 100644 index 00000000..9fc4f0ba --- /dev/null +++ b/haddock-library/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/haddock-library/fixtures/examples/list-blocks2.input b/haddock-library/fixtures/examples/list-blocks2.input new file mode 100644 index 00000000..91492adb --- /dev/null +++ b/haddock-library/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/haddock-library/fixtures/examples/list-blocks2.parsed b/haddock-library/fixtures/examples/list-blocks2.parsed new file mode 100644 index 00000000..169677b7 --- /dev/null +++ b/haddock-library/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/haddock-library/fixtures/examples/table-cell-strip-whitespaces.input b/haddock-library/fixtures/examples/table-cell-strip-whitespaces.input new file mode 100644 index 00000000..f5e3756d --- /dev/null +++ b/haddock-library/fixtures/examples/table-cell-strip-whitespaces.input @@ -0,0 +1,5 @@ ++------+--------------+-------------------------------------------------+ +| C1   |     C2       |         C3                                      | ++======+==============+=================================================+ +| row  | 'test'       | 'test table cell with  .. whitepspace '         | ++------+--------------+-------------------------------------------------+ diff --git a/haddock-library/fixtures/examples/table-cell-strip-whitespaces.parsed b/haddock-library/fixtures/examples/table-cell-strip-whitespaces.parsed new file mode 100644 index 00000000..19002369 --- /dev/null +++ b/haddock-library/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/haddock-library/fixtures/examples/table-simple.parsed b/haddock-library/fixtures/examples/table-simple.parsed index b5e62453..d027c75d 100644 --- a/haddock-library/fixtures/examples/table-simple.parsed +++ b/haddock-library/fixtures/examples/table-simple.parsed @@ -3,50 +3,40 @@ DocTable      {tableBodyRows = [TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " 200  ", +                            tableCellContents = DocString "200",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocAppend -                                                  (DocString "   ") -                                                  (DocAppend -                                                     (DocMonospaced (DocString "OK")) -                                                     (DocString "       ")), +                            tableCellContents = DocMonospaced (DocString "OK"),                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString -                                                  " operation successful                     ", +                            tableCellContents = DocString "operation successful",                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " 204  ", +                            tableCellContents = DocString "204",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocAppend -                                                  (DocString " ") -                                                  (DocAppend -                                                     (DocMonospaced (DocString "No Content")) -                                                     (DocString " ")), +                            tableCellContents = DocMonospaced (DocString "No Content"),                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1,                              tableCellContents = DocString -                                                  " operation successful, no body returned   ", +                                                  "operation successful, no body returned",                              tableCellRowspan = 1}]],       tableHeaderRows = [TableRow                            [TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString " code ", +                              tableCellContents = DocString "code",                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString " message      ", +                              tableCellContents = DocString "message",                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString -                                                    " description                              ", +                              tableCellContents = DocString "description",                                tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table1.parsed b/haddock-library/fixtures/examples/table1.parsed index 2fa58fd8..8b8908f4 100644 --- a/haddock-library/fixtures/examples/table1.parsed +++ b/haddock-library/fixtures/examples/table1.parsed @@ -3,79 +3,66 @@ DocTable      {tableBodyRows = [TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " body row 1, column 1   ", +                            tableCellContents = DocString "body row 1, column 1",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 2   ", +                            tableCellContents = DocString "column 2",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 3 ", +                            tableCellContents = DocString "column 3",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 4 ", +                            tableCellContents = DocString "column 4",                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " body row 2             ", +                            tableCellContents = DocString "body row 2",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 3, -                            tableCellContents = DocString " Cells may span columns.          ", +                            tableCellContents = DocString "Cells may span columns.",                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " body row 3             ", +                            tableCellContents = DocString "body row 3",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1,                              tableCellContents = DocString -                                                  (concat -                                                     [" Cells may  \n", -                                                      " span rows. \n", -                                                      "            "]), +                                                  (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 "                  ")), +                            tableCellContents = DocMathDisplay +                                                  (concat ["\n", "f(n) = \\sum_{i=1}\n"]),                              tableCellRowspan = 2}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " body row 4             ", +                            tableCellContents = DocString "body row 4",                              tableCellRowspan = 1}]],       tableHeaderRows = [TableRow                            [TableCell                               {tableCellColspan = 1,                                tableCellContents = DocString                                                      (concat -                                                       [" Header row, column 1   \n", -                                                        " (header rows optional) "]), +                                                       ["Header row, column 1\n", +                                                        "(header rows optional)"]),                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString -                                                    (concat [" Header 2   \n", "            "]), +                              tableCellContents = DocString "Header 2\n",                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString -                                                    (concat [" Header 3 \n", "          "]), +                              tableCellContents = DocString "Header 3\n",                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString -                                                    (concat [" Header 4 \n", "          "]), +                              tableCellContents = DocString "Header 4\n",                                tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table2.parsed b/haddock-library/fixtures/examples/table2.parsed index e3dbf0b4..44cc813b 100644 --- a/haddock-library/fixtures/examples/table2.parsed +++ b/haddock-library/fixtures/examples/table2.parsed @@ -3,44 +3,44 @@ DocTable      {tableBodyRows = [TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " row 1, col 1 ", +                            tableCellContents = DocString "row 1, col 1",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 2 ", +                            tableCellContents = DocString "column 2",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 3  ", +                            tableCellContents = DocString "column 3",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 4  ", +                            tableCellContents = DocString "column 4",                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " row 2        ", +                            tableCellContents = DocString "row 2",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 3, -                            tableCellContents = DocString "                                  ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " row 3        ", +                            tableCellContents = DocString "row 3",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "          ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "           ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "           ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1}]],       tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table3.parsed b/haddock-library/fixtures/examples/table3.parsed index cabff9cb..c978b50f 100644 --- a/haddock-library/fixtures/examples/table3.parsed +++ b/haddock-library/fixtures/examples/table3.parsed @@ -3,48 +3,48 @@ DocTable      {tableBodyRows = [TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " row 1, col 1 ", +                            tableCellContents = DocString "row 1, col 1",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 2 ", +                            tableCellContents = DocString "column 2",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 3  ", +                            tableCellContents = DocString "column 3",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " column 4  ", +                            tableCellContents = DocString "column 4",                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " row 2        ", +                            tableCellContents = DocString "row 2",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 2, -                            tableCellContents = DocString " Use the command ``ls ", +                            tableCellContents = DocString "Use the command ``ls",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " more``.   ", +                            tableCellContents = DocString "more``.",                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString " row 3        ", +                            tableCellContents = DocString "row 3",                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "          ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "           ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "           ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1}]],       tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table4.parsed b/haddock-library/fixtures/examples/table4.parsed index cfdd6f0f..c4dabb0d 100644 --- a/haddock-library/fixtures/examples/table4.parsed +++ b/haddock-library/fixtures/examples/table4.parsed @@ -8,10 +8,10 @@ DocAppend                                   {tableCellColspan = 1,                                    tableCellContents = DocString                                                          (concat -                                                           ["   outer     \n", -                                                            "             \n", -                                                            "-------+     \n", -                                                            " inner |     "]), +                                                           ["outer\n", +                                                            "\n", +                                                            "-------+\n", +                                                            "inner |"]),                                    tableCellRowspan = 1}]],             tableHeaderRows = []})       (DocAppend @@ -21,6 +21,6 @@ DocAppend               {tableBodyRows = [TableRow                                   [TableCell                                      {tableCellColspan = 1, -                                     tableCellContents = DocString " inner ", +                                     tableCellContents = DocString "inner",                                       tableCellRowspan = 1}]],                tableHeaderRows = []}))) diff --git a/haddock-library/fixtures/examples/table5.parsed b/haddock-library/fixtures/examples/table5.parsed index 9a547ad3..f9a387bb 100644 --- a/haddock-library/fixtures/examples/table5.parsed +++ b/haddock-library/fixtures/examples/table5.parsed @@ -4,50 +4,43 @@ DocTable                          [TableCell                             {tableCellColspan = 1,                              tableCellContents = DocString -                                                  (concat -                                                     [" row 2        \n", -                                                      "              \n", -                                                      "              \n", -                                                      " row 3        "]), +                                                  (concat ["row 2\n", "\n", "\n", "row 3"]),                              tableCellRowspan = 2},                           TableCell                             {tableCellColspan = 3,                              tableCellContents = DocAppend -                                                  (DocString " Use the command  ") +                                                  (DocString "Use the command  ")                                                    (DocAppend                                                       (DocMonospaced (DocString "ls | more")) -                                                     (DocString -                                                        (concat -                                                           [".    \n", -                                                            "                                  "]))), +                                                     (DocString ".\n")),                              tableCellRowspan = 1}],                        TableRow                          [TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "          ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "           ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1},                           TableCell                             {tableCellColspan = 1, -                            tableCellContents = DocString "           ", +                            tableCellContents = DocEmpty,                              tableCellRowspan = 1}]],       tableHeaderRows = [TableRow                            [TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString " row 1, col 1 ", +                              tableCellContents = DocString "row 1, col 1",                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString " column 2 ", +                              tableCellContents = DocString "column 2",                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString " column 3  ", +                              tableCellContents = DocString "column 3",                                tableCellRowspan = 1},                             TableCell                               {tableCellColspan = 1, -                              tableCellContents = DocString " column 4  ", +                              tableCellContents = DocString "column 4",                                tableCellRowspan = 1}]]} diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index ef802a64..490dff10 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,6 +1,6 @@  cabal-version:        2.2  name:                 haddock-library -version:              1.8.0 +version:              1.9.0  synopsis:             Library exposing some functionality of Haddock.  description:          Haddock is a documentation-generation tool for Haskell @@ -12,15 +12,27 @@ description:          Haddock is a documentation-generation tool for Haskell                        itself, see the [haddock package](https://hackage.haskell.org/package/haddock).  license:              BSD-2-Clause -license-files:        LICENSE +license-file:         LICENSE  maintainer:           Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>  homepage:             http://www.haskell.org/haddock/  bug-reports:          https://github.com/haskell/haddock/issues  category:             Documentation -tested-with:          GHC==8.12.*, GHC==8.10.*, GHC==8.8.1 +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  extra-source-files:    CHANGES.md +  fixtures/examples/*.input +  fixtures/examples/*.parsed  common lib-defaults    default-language: Haskell2010 @@ -33,9 +45,9 @@ common lib-defaults      , text         ^>= 1.2.3.0      , parsec       ^>= 3.1.13.0 -  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs +  ghc-options: -funbox-strict-fields -Wall    if impl(ghc >= 8.0) -    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances +    ghc-options: -Wcompat -Wnoncanonical-monad-instances  library    import: lib-defaults @@ -49,33 +61,34 @@ library      Documentation.Haddock.Types    other-modules: +    CompatPrelude      Documentation.Haddock.Parser.Util      Documentation.Haddock.Parser.Monad +    Documentation.Haddock.Parser.Identifier  test-suite spec    import: lib-defaults    type:             exitcode-stdio-1.0    main-is:          Spec.hs    hs-source-dirs: -      test -      src - -  cpp-options: -      -DTEST +    test +    src    other-modules: -      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 +    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-compat  ^>= 0.9.3 || ^>= 0.10.0 -    , QuickCheck   ^>= 2.11.3 +    , base-compat  ^>= 0.9.3 || ^>= 0.11.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 @@ -83,10 +96,10 @@ test-suite spec    --     version of `hspec` & `hspec-discover` to ensure    --     intercompatibility    build-depends: -    , hspec                         ^>= 2.5.5 +    , hspec                          >= 2.4.4    && < 2.8    build-tool-depends: -    , hspec-discover:hspec-discover ^>= 2.5.5 +    , hspec-discover:hspec-discover  >= 2.4.4    && < 2.8  test-suite fixtures    type:             exitcode-stdio-1.0 @@ -94,7 +107,6 @@ test-suite fixtures    main-is:          Fixtures.hs    ghc-options:      -Wall    hs-source-dirs:   fixtures -  buildable:        False    build-depends:        -- intra-package dependency      , haddock-library @@ -102,11 +114,11 @@ test-suite fixtures      , base        -- extra dependencies -    , base-compat  >= 0.9.3   && < 0.11 +    , base-compat           ^>= 0.9.3 || ^>= 0.11.0      , directory             ^>= 1.3.0.2      , filepath              ^>= 1.4.1.2 -    , optparse-applicative  ^>= 0.14.0.0 -    , tree-diff             ^>= 0.0.0.1 +    , optparse-applicative  ^>= 0.15 +    , tree-diff             ^>= 0.1  source-repository head    type:     git diff --git a/haddock-library/src/CompatPrelude.hs b/haddock-library/src/CompatPrelude.hs new file mode 100644 index 00000000..60fa94d9 --- /dev/null +++ b/haddock-library/src/CompatPrelude.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +#if !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/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 82d65a0a..a3bba38a 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP               #-}  {-# LANGUAGE OverloadedStrings #-}  {-# LANGUAGE ViewPatterns      #-}  -- | @@ -27,7 +26,7 @@ module Documentation.Haddock.Parser (  import           Control.Applicative  import           Control.Arrow (first)  import           Control.Monad -import           Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) +import           Data.Char (chr, isUpper, isAlpha, isSpace)  import           Data.List (intercalate, unfoldr, elemIndex)  import           Data.Maybe (fromMaybe, mapMaybe)  import           Data.Monoid @@ -36,6 +35,7 @@ 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 @@ -46,53 +46,26 @@ 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 -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') @@ -254,7 +227,7 @@ takeWhile1_ = mfilter (not . T.null) . takeWhile_  -- DocAName "Hello world"  anchor :: Parser (DocH mod a)  anchor = DocAName . T.unpack <$> -         disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") +         ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#")  -- | Monospaced strings.  -- @@ -269,12 +242,18 @@ monospace = DocMonospaced . parseParagraph  -- 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 <$> ("\"" *> (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 = (:)        <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) -      <*> many (conChar <|> Parsec.oneOf "\\#") +      <*> many conChar      conChar = Parsec.alphaNum <|> Parsec.char '_' @@ -294,7 +273,7 @@ picture = DocPic . makeLabeled Picture  -- >>> 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 \\]. @@ -314,7 +293,8 @@ markdownImage :: Parser (DocH mod Identifier)  markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser)    where      fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) -    stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r]) +    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) @@ -518,7 +498,7 @@ tableStepFour rs hdrIndex cells =  case hdrIndex of      -- 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]          ] @@ -538,11 +518,11 @@ since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince  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 @@ -605,7 +585,7 @@ definitionList indent = DocDefList <$> p          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'. @@ -679,7 +659,7 @@ takeNonEmptyLine = do  --  -- 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 @@ -737,14 +717,14 @@ examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go)          substituteBlankLine "<BLANKLINE>" = ""          substituteBlankLine xs = xs -nonEmptyLine :: Parser Text  +nonEmptyLine :: Parser Text  nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine)  takeLine :: Parser Text  takeLine = try (takeWhile (/= '\n') <* endOfLine)  endOfLine :: Parser () -endOfLine = void "\n" <|> Parsec.eof  +endOfLine = void "\n" <|> Parsec.eof  -- | Property parser.  -- @@ -826,7 +806,7 @@ autoUrl :: Parser (DocH mod a)  autoUrl = mkLink <$> url    where      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] @@ -836,30 +816,6 @@ autoUrl = mkLink <$> url      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/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs new file mode 100644 index 00000000..b8afb951 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- 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 == '\'' +    quotes :: Text -> (Int, Text) +    quotes t = let !n = T.length (T.takeWhile (== '\'') 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/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 8f5bd217..7c73a168 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -4,6 +4,18 @@  {-# LANGUAGE TypeFamilies #-}  {-# 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 @@ -17,7 +29,6 @@ import qualified Data.Text as T  import           Data.Text                   ( Text )  import           Control.Monad               ( mfilter ) -import           Data.Functor                ( ($>) )  import           Data.String                 ( IsString(..) )  import           Data.Bits                   ( Bits(..) )  import           Data.Char                   ( ord ) @@ -25,7 +36,9 @@ import           Data.List                   ( foldl' )  import           Control.Applicative as App  import           Documentation.Haddock.Types ( Version ) +  import           Prelude hiding (takeWhile) +import           CompatPrelude  -- | The only bit of information we really care about truding along with us  -- through parsing is the version attached to a @\@since@ annotation - if @@ -96,7 +109,6 @@ takeWhile f = do        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. diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs index 98570c22..eef744d8 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -31,16 +31,16 @@ import           Prelude hiding (takeWhile)  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 (`elem` 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 @@ removeEscapes = T.unfoldr go  -- | 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/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index f8f7d353..12ccd28d 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -44,14 +44,17 @@ data MetaDoc mod id =            } 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 @@ -76,7 +79,7 @@ data Picture = Picture    } deriving (Eq, Show)  data Header id = Header -  { headerLevel :: Int +  { headerLevel :: Int  -- ^ between 1 and 6 inclusive    , headerTitle :: id    } deriving (Eq, Show, Functor, Foldable, Traversable) @@ -123,7 +126,7 @@ data DocH mod id    | 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 +134,7 @@ data DocH mod id    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) @@ -159,6 +163,7 @@ instance Bifunctor DocH where  #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 @@ -176,6 +181,7 @@ instance Bifoldable DocH where    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 @@ -203,6 +209,16 @@ instance Bitraversable DocH where    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). diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 6269184a..1724c664 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/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 @@ -112,7 +113,7 @@ spec = do          "``" `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" @@ -132,6 +133,19 @@ spec = do        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 ".=" @@ -275,8 +289,10 @@ spec = do        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 "灼眼のシャナ" @@ -291,6 +307,9 @@ spec = do        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" @@ -417,6 +436,9 @@ spec = do        it "accepts anchor reference syntax as DocModule" $ do          "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar" +      it "accepts anchor with hyphen as DocModule" $ do +        "\"Foo#bar-baz\"" `shouldParseTo` DocModule "Foo#bar-baz" +        it "accepts old anchor reference syntax as DocModule" $ do          "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" @@ -429,6 +451,10 @@ spec = do        property $ \xs ->          (length . show . parseParas) xs `shouldSatisfy` (> 0) +    -- See <https://github.com/haskell/haddock/issues/1142> +    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` @@ -457,7 +483,8 @@ spec = do      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 | 
