diff options
author | alexbiehl-gc <72160047+alexbiehl-gc@users.noreply.github.com> | 2021-02-07 18:14:46 +0100 |
---|---|---|
committer | GitHub <noreply@github.com> | 2021-02-07 18:14:46 +0100 |
commit | 0f7ff041fb824653a7930e1292b81f34df1e967d (patch) | |
tree | 3e7f15ac3b0abe417797ec89275aa1209f6ca297 /haddock-library | |
parent | 9f597b6647a53624eaf501a34bfb4d8d15425929 (diff) | |
parent | 010f0320dff64e3f86091ba4691bc69ce6999647 (diff) |
Merge pull request #1317 from bgamari/wip/ghc-head-merge
Merge ghc-8.10 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 |