packages feed

haddock-library 1.7.0 → 1.8.0

raw patch · 44 files changed

+917/−276 lines, 44 filesdep ~QuickCheckdep ~basedep ~base-compatnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, base, base-compat, bytestring, containers, deepseq, hspec, optparse-applicative, parsec, text, transformers, tree-diff

API changes (from Hackage documentation)

- Documentation.Haddock.Parser: type Identifier = (Char, String, Char)
- Documentation.Haddock.Types: instance GHC.Classes.Eq Documentation.Haddock.Types.Hyperlink
- Documentation.Haddock.Types: instance GHC.Show.Show Documentation.Haddock.Types.Hyperlink
- Documentation.Haddock.Utf8: decodeUtf8 :: ByteString -> String
- Documentation.Haddock.Utf8: encodeUtf8 :: String -> ByteString
+ Documentation.Haddock.Markup: plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String
+ Documentation.Haddock.Parser: data Identifier
+ Documentation.Haddock.Types: None :: Namespace
+ Documentation.Haddock.Types: Type :: Namespace
+ Documentation.Haddock.Types: Value :: Namespace
+ Documentation.Haddock.Types: data Namespace
+ Documentation.Haddock.Types: instance Data.Foldable.Foldable Documentation.Haddock.Types.Hyperlink
+ Documentation.Haddock.Types: instance Data.Traversable.Traversable Documentation.Haddock.Types.Hyperlink
+ Documentation.Haddock.Types: instance GHC.Base.Functor Documentation.Haddock.Types.Hyperlink
+ Documentation.Haddock.Types: instance GHC.Classes.Eq Documentation.Haddock.Types.Namespace
+ Documentation.Haddock.Types: instance GHC.Classes.Eq id => GHC.Classes.Eq (Documentation.Haddock.Types.Hyperlink id)
+ Documentation.Haddock.Types: instance GHC.Classes.Ord Documentation.Haddock.Types.Namespace
+ Documentation.Haddock.Types: instance GHC.Enum.Enum Documentation.Haddock.Types.Namespace
+ Documentation.Haddock.Types: instance GHC.Show.Show Documentation.Haddock.Types.Namespace
+ Documentation.Haddock.Types: instance GHC.Show.Show id => GHC.Show.Show (Documentation.Haddock.Types.Hyperlink id)
+ Documentation.Haddock.Types: renderNs :: Namespace -> String
- Documentation.Haddock.Parser: overIdentifier :: (String -> Maybe a) -> DocH mod Identifier -> DocH mod a
+ Documentation.Haddock.Parser: overIdentifier :: (Namespace -> String -> Maybe a) -> DocH mod Identifier -> DocH mod a
- Documentation.Haddock.Types: DocAppend :: (DocH mod id) -> (DocH mod id) -> DocH mod id
+ Documentation.Haddock.Types: DocAppend :: DocH mod id -> DocH mod id -> DocH mod id
- Documentation.Haddock.Types: DocBold :: (DocH mod id) -> DocH mod id
+ Documentation.Haddock.Types: DocBold :: DocH mod id -> DocH mod id
- Documentation.Haddock.Types: DocCodeBlock :: (DocH mod id) -> DocH mod id
+ Documentation.Haddock.Types: DocCodeBlock :: DocH mod id -> DocH mod id
- Documentation.Haddock.Types: DocEmphasis :: (DocH mod id) -> DocH mod id
+ Documentation.Haddock.Types: DocEmphasis :: DocH mod id -> DocH mod id
- Documentation.Haddock.Types: DocHeader :: (Header (DocH mod id)) -> DocH mod id
+ Documentation.Haddock.Types: DocHeader :: Header (DocH mod id) -> DocH mod id
- Documentation.Haddock.Types: DocHyperlink :: Hyperlink -> DocH mod id
+ Documentation.Haddock.Types: DocHyperlink :: Hyperlink (DocH mod id) -> DocH mod id
- Documentation.Haddock.Types: DocMonospaced :: (DocH mod id) -> DocH mod id
+ Documentation.Haddock.Types: DocMonospaced :: DocH mod id -> DocH mod id
- Documentation.Haddock.Types: DocParagraph :: (DocH mod id) -> DocH mod id
+ Documentation.Haddock.Types: DocParagraph :: DocH mod id -> DocH mod id
- Documentation.Haddock.Types: DocTable :: (Table (DocH mod id)) -> DocH mod id
+ Documentation.Haddock.Types: DocTable :: Table (DocH mod id) -> DocH mod id
- Documentation.Haddock.Types: DocWarning :: (DocH mod id) -> DocH mod id
+ Documentation.Haddock.Types: DocWarning :: DocH mod id -> DocH mod id
- Documentation.Haddock.Types: Hyperlink :: String -> Maybe String -> Hyperlink
+ Documentation.Haddock.Types: Hyperlink :: String -> Maybe id -> Hyperlink id
- Documentation.Haddock.Types: Markup :: a -> String -> a -> a -> a -> a -> a -> a -> id -> a -> mod -> a -> String -> a -> a -> a -> a -> a -> a -> a -> a -> a -> [a] -> a -> [a] -> a -> [(a, a)] -> a -> a -> a -> Hyperlink -> a -> String -> a -> Picture -> a -> String -> a -> String -> a -> String -> a -> [Example] -> a -> Header a -> a -> Table a -> a -> DocMarkupH mod id a
+ Documentation.Haddock.Types: Markup :: a -> (String -> a) -> (a -> a) -> (a -> a -> a) -> (id -> a) -> (mod -> a) -> (String -> a) -> (a -> a) -> (a -> a) -> (a -> a) -> (a -> a) -> ([a] -> a) -> ([a] -> a) -> ([(a, a)] -> a) -> (a -> a) -> (Hyperlink a -> a) -> (String -> a) -> (Picture -> a) -> (String -> a) -> (String -> a) -> (String -> a) -> ([Example] -> a) -> (Header a -> a) -> (Table a -> a) -> DocMarkupH mod id a
- Documentation.Haddock.Types: [hyperlinkLabel] :: Hyperlink -> Maybe String
+ Documentation.Haddock.Types: [hyperlinkLabel] :: Hyperlink id -> Maybe id
- Documentation.Haddock.Types: [hyperlinkUrl] :: Hyperlink -> String
+ Documentation.Haddock.Types: [hyperlinkUrl] :: Hyperlink id -> String
- Documentation.Haddock.Types: [markupHyperlink] :: DocMarkupH mod id a -> Hyperlink -> a
+ Documentation.Haddock.Types: [markupHyperlink] :: DocMarkupH mod id a -> Hyperlink a -> a
- Documentation.Haddock.Types: data Hyperlink
+ Documentation.Haddock.Types: data Hyperlink id

Files

CHANGES.md view
@@ -1,3 +1,10 @@+## Changes in version 1.8.0++ * Support inline markup in markdown-style links (#875)++ * Remove now unused `Documentation.Haddock.Utf8` module.+   This module was anyways copied from the `utf8-string` package.+ ## Changes in version 1.7.0   * Make `Documentation.Haddock.Parser.Monad` an internal module
fixtures/Fixtures.hs view
@@ -146,8 +146,8 @@ deriving instance Generic (Header id) instance ToExpr id => ToExpr (Header id) -deriving instance Generic Hyperlink-instance ToExpr Hyperlink+deriving instance Generic (Hyperlink id)+instance ToExpr id => ToExpr (Hyperlink id)  deriving instance Generic Picture instance ToExpr Picture
+ fixtures/examples/definitionList.input view
@@ -0,0 +1,1 @@+[foo]: bar
+ fixtures/examples/definitionList.parsed view
@@ -0,0 +1,1 @@+DocDefList [_×_ (DocString "foo") (DocString "bar")]
+ fixtures/examples/identifier.input view
@@ -0,0 +1,1 @@+'foo'
+ fixtures/examples/identifier.parsed view
@@ -0,0 +1,1 @@+DocParagraph (DocIdentifier "foo")
+ fixtures/examples/identifierBackticks.input view
@@ -0,0 +1,1 @@+`foo`
+ fixtures/examples/identifierBackticks.parsed view
@@ -0,0 +1,1 @@+DocParagraph (DocIdentifier "foo")
+ fixtures/examples/link.input view
@@ -0,0 +1,1 @@+[link](http://example.com)
+ fixtures/examples/link.parsed view
@@ -0,0 +1,5 @@+DocParagraph+  (DocHyperlink+     Hyperlink+       {hyperlinkLabel = Just (DocString "link"),+        hyperlinkUrl = "http://example.com"})
+ fixtures/examples/linkInline.input view
@@ -0,0 +1,1 @@+Bla [link](http://example.com)
+ fixtures/examples/linkInline.parsed view
@@ -0,0 +1,7 @@+DocParagraph+  (DocAppend+     (DocString "Bla ")+     (DocHyperlink+        Hyperlink+          {hyperlinkLabel = Just (DocString "link"),+           hyperlinkUrl = "http://example.com"}))
+ fixtures/examples/linkInlineMarkup.input view
@@ -0,0 +1,1 @@+Bla [link /emphasized/](http://example.com)
+ fixtures/examples/linkInlineMarkup.parsed view
@@ -0,0 +1,8 @@+DocParagraph+  (DocAppend+     (DocString "Bla ")+     (DocHyperlink+        Hyperlink+          {hyperlinkLabel = Just (DocAppend (DocString "link ")+                                            (DocEmphasis (DocString "emphasized"))),+           hyperlinkUrl = "http://example.com"}))
+ fixtures/examples/list-blocks1.input view
@@ -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
+ fixtures/examples/list-blocks1.parsed view
@@ -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")]
+ fixtures/examples/list-blocks2.input view
@@ -0,0 +1,10 @@+=== Title++* List directly+* after the title++    @+    with some inline things+    @++* is parsed weirdly
+ fixtures/examples/list-blocks2.parsed view
@@ -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")])
+ fixtures/examples/table-simple.input view
@@ -0,0 +1,7 @@++------+--------------+------------------------------------------++| code | message      | description                              |++======+==============+==========================================++| 200  |   @OK@       | operation successful                     |++------+--------------+------------------------------------------++| 204  | @No Content@ | operation successful, no body returned   |++------+--------------+------------------------------------------+
+ fixtures/examples/table-simple.parsed view
@@ -0,0 +1,52 @@+DocTable+  Table+    {tableBodyRows = [TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " 200  ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocAppend+                                                  (DocString "   ")+                                                  (DocAppend+                                                     (DocMonospaced (DocString "OK"))+                                                     (DocString "       ")),+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString+                                                  " operation successful                     ",+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " 204  ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocAppend+                                                  (DocString " ")+                                                  (DocAppend+                                                     (DocMonospaced (DocString "No Content"))+                                                     (DocString " ")),+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString+                                                  " operation successful, no body returned   ",+                            tableCellRowspan = 1}]],+     tableHeaderRows = [TableRow+                          [TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString " code ",+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString " message      ",+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString+                                                    " description                              ",+                              tableCellRowspan = 1}]]}
+ fixtures/examples/table1.input view
@@ -0,0 +1,12 @@++------------------------+------------+----------+----------++| Header row, column 1   | Header 2   | Header 3 | Header 4 |+| (header rows optional) |            |          |          |++========================+============+==========+==========++| body row 1, column 1   | column 2   | column 3 | column 4 |++------------------------+------------+----------+----------++| body row 2             | Cells may span columns.          |++------------------------+------------+---------------------++| body row 3             | Cells may  | \[                  |++------------------------+ span rows. | f(n) = \sum_{i=1}   |+| body row 4             |            | \]                  |++------------------------+------------+---------------------+
+ fixtures/examples/table1.parsed view
@@ -0,0 +1,81 @@+DocTable+  Table+    {tableBodyRows = [TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " body row 1, column 1   ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 2   ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 3 ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 4 ",+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " body row 2             ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 3,+                            tableCellContents = DocString " Cells may span columns.          ",+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " body row 3             ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString+                                                  (concat+                                                     [" Cells may  \n",+                                                      " span rows. \n",+                                                      "            "]),+                            tableCellRowspan = 2},+                         TableCell+                           {tableCellColspan = 2,+                            tableCellContents = DocAppend+                                                  (DocString " ")+                                                  (DocAppend+                                                     (DocMathDisplay+                                                        (concat+                                                           ["                  \n",+                                                            " f(n) = \\sum_{i=1}   \n",+                                                            " "]))+                                                     (DocString "                  ")),+                            tableCellRowspan = 2}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " body row 4             ",+                            tableCellRowspan = 1}]],+     tableHeaderRows = [TableRow+                          [TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString+                                                    (concat+                                                       [" Header row, column 1   \n",+                                                        " (header rows optional) "]),+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString+                                                    (concat [" Header 2   \n", "            "]),+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString+                                                    (concat [" Header 3 \n", "          "]),+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString+                                                    (concat [" Header 4 \n", "          "]),+                              tableCellRowspan = 1}]]}
+ fixtures/examples/table2.input view
@@ -0,0 +1,7 @@++--------------+----------+-----------+-----------++| row 1, col 1 | column 2 | column 3  | column 4  |++--------------+----------+-----------+-----------++| row 2        |                                  |++--------------+----------+-----------+-----------++| row 3        |          |           |           |++--------------+----------+-----------+-----------+
+ fixtures/examples/table2.parsed view
@@ -0,0 +1,46 @@+DocTable+  Table+    {tableBodyRows = [TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " row 1, col 1 ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 2 ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 3  ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 4  ",+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " row 2        ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 3,+                            tableCellContents = DocString "                                  ",+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " row 3        ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "          ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "           ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "           ",+                            tableCellRowspan = 1}]],+     tableHeaderRows = []}
+ fixtures/examples/table3.input view
@@ -0,0 +1,7 @@++--------------+----------+-----------+-----------++| row 1, col 1 | column 2 | column 3  | column 4  |++--------------+----------+-----------+-----------++| row 2        | Use the command ``ls | more``.   |++--------------+----------+-----------+-----------++| row 3        |          |           |           |++--------------+----------+-----------+-----------+
+ fixtures/examples/table3.parsed view
@@ -0,0 +1,50 @@+DocTable+  Table+    {tableBodyRows = [TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " row 1, col 1 ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 2 ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 3  ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " column 4  ",+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " row 2        ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 2,+                            tableCellContents = DocString " Use the command ``ls ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " more``.   ",+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString " row 3        ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "          ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "           ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "           ",+                            tableCellRowspan = 1}]],+     tableHeaderRows = []}
+ fixtures/examples/table4.input view
@@ -0,0 +1,17 @@+Single outer cell:+++-------------++|   outer     |+|             |++-------+     |+| inner |     |++-------+-----+++Broken (only inner cell is rendered):+++-------+-----++| inner |     |++-------+     |+|             |+|   outer     |++-------------+
+ fixtures/examples/table4.parsed view
@@ -0,0 +1,26 @@+DocAppend+  (DocParagraph (DocString "Single outer cell:"))+  (DocAppend+     (DocTable+        Table+          {tableBodyRows = [TableRow+                              [TableCell+                                 {tableCellColspan = 1,+                                  tableCellContents = DocString+                                                        (concat+                                                           ["   outer     \n",+                                                            "             \n",+                                                            "-------+     \n",+                                                            " inner |     "]),+                                  tableCellRowspan = 1}]],+           tableHeaderRows = []})+     (DocAppend+        (DocParagraph (DocString "Broken (only inner cell is rendered):"))+        (DocTable+           Table+             {tableBodyRows = [TableRow+                                 [TableCell+                                    {tableCellColspan = 1,+                                     tableCellContents = DocString " inner ",+                                     tableCellRowspan = 1}]],+              tableHeaderRows = []})))
+ fixtures/examples/table5.input view
@@ -0,0 +1,8 @@++--------------+----------+-----------+-----------++| row 1, col 1 | column 2 | column 3  | column 4  |++==============+==========+===========+===========++| row 2        | Use the command  @ls | more@.    |+|              |                                  |+|              +----------+-----------+-----------++| row 3        |          |           |           |++--------------+----------+-----------+-----------+
+ fixtures/examples/table5.parsed view
@@ -0,0 +1,53 @@+DocTable+  Table+    {tableBodyRows = [TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString+                                                  (concat+                                                     [" row 2        \n",+                                                      "              \n",+                                                      "              \n",+                                                      " row 3        "]),+                            tableCellRowspan = 2},+                         TableCell+                           {tableCellColspan = 3,+                            tableCellContents = DocAppend+                                                  (DocString " Use the command  ")+                                                  (DocAppend+                                                     (DocMonospaced (DocString "ls | more"))+                                                     (DocString+                                                        (concat+                                                           [".    \n",+                                                            "                                  "]))),+                            tableCellRowspan = 1}],+                      TableRow+                        [TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "          ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "           ",+                            tableCellRowspan = 1},+                         TableCell+                           {tableCellColspan = 1,+                            tableCellContents = DocString "           ",+                            tableCellRowspan = 1}]],+     tableHeaderRows = [TableRow+                          [TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString " row 1, col 1 ",+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString " column 2 ",+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString " column 3  ",+                              tableCellRowspan = 1},+                           TableCell+                             {tableCellColspan = 1,+                              tableCellContents = DocString " column 4  ",+                              tableCellRowspan = 1}]]}
+ fixtures/examples/url.input view
@@ -0,0 +1,1 @@+<http://example.com/>
+ fixtures/examples/url.parsed view
@@ -0,0 +1,4 @@+DocParagraph+  (DocHyperlink+     Hyperlink+       {hyperlinkLabel = Nothing, hyperlinkUrl = "http://example.com/"})
+ fixtures/examples/urlLabel.input view
@@ -0,0 +1,1 @@+<http://example.com/ some link>
+ fixtures/examples/urlLabel.parsed view
@@ -0,0 +1,5 @@+DocParagraph+  (DocHyperlink+     Hyperlink+       {hyperlinkLabel = Just (DocString "some link"),+        hyperlinkUrl = "http://example.com/"})
haddock-library.cabal view
@@ -1,34 +1,45 @@-cabal-version:        2.0+cabal-version:        2.2 name:                 haddock-library-version:              1.7.0+version:              1.8.0 synopsis:             Library exposing some functionality of Haddock.+ description:          Haddock is a documentation-generation tool for Haskell-                      libraries. These modules expose some functionality of it-                      without pulling in the GHC dependency. Please note that the-                      API is likely to change so specify upper bounds in your-                      project. For interacting with Haddock+                      libraries. These modules expose some+                      functionality of it without pulling in the GHC+                      dependency. Please note that the API is likely+                      to change so be sure to specify upper bounds in+                      your projects. For interacting with Haddock                       itself, see the [haddock package](https://hackage.haskell.org/package/haddock).-license:              BSD3++license:              BSD-2-Clause license-files:        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-build-type:           Simple extra-source-files:   CHANGES.md+  fixtures/examples/*.input+  fixtures/examples/*.parsed -library-  default-language:     Haskell2010+common lib-defaults+  default-language: Haskell2010    build-depends:-      base         >= 4.5     && < 4.13-    , bytestring   >= 0.9.2.1 && < 0.11-    , containers   >= 0.4.2.1 && < 0.7-    , transformers >= 0.3.0   && < 0.6-    , text         >= 1.2.3.0  && < 1.3-    , parsec       >= 3.1.13.0 && < 3.2+    , base         >= 4.5     && < 4.14+    , bytestring   ^>= 0.9.2.1 || ^>= 0.10.0.0+    , containers   ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1+    , transformers ^>= 0.3.0.0 || ^>= 0.4.1.0 || ^>= 0.5.0.0+    , text         ^>= 1.2.3.0+    , parsec       ^>= 3.1.13.0 +  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances++library+  import: lib-defaults+   hs-source-dirs:       src    exposed-modules:@@ -36,73 +47,67 @@     Documentation.Haddock.Markup     Documentation.Haddock.Parser     Documentation.Haddock.Types-    Documentation.Haddock.Utf8    other-modules:     Documentation.Haddock.Parser.Util     Documentation.Haddock.Parser.Monad--  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs-  if impl(ghc >= 8.0)-    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances-+    Documentation.Haddock.Parser.Identifier  test-suite spec+  import: lib-defaults   type:             exitcode-stdio-1.0-  default-language: Haskell2010   main-is:          Spec.hs   hs-source-dirs:       test-    , src-  ghc-options: -Wall+      src    cpp-options:       -DTEST    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-      Documentation.Haddock.Utf8-      Documentation.Haddock.Utf8Spec+      Documentation.Haddock.Parser.Identifier    build-depends:-      base         >= 4.5     && < 4.13-    , base-compat  >= 0.9.3   && < 0.11-    , bytestring   >= 0.9.2.1 && < 0.11-    , containers   >= 0.4.2.1 && < 0.7-    , transformers   >= 0.3.0   && < 0.6-    , hspec        >= 2.4.4   && < 2.6-    , QuickCheck    ^>= 2.11-    , text         >= 1.2.3.0  && < 1.3-    , parsec       >= 3.1.13.0 && < 3.2-    , deepseq      >= 1.3     && < 1.5+    , base-compat  ^>= 0.9.3 || ^>= 0.11.0+    , QuickCheck   ^>= 2.11  || ^>= 2.13.2+    , deepseq      ^>= 1.3.0.0 || ^>= 1.4.0.0 +  -- NB: build-depends & build-tool-depends have independent+  --     install-plans, so it's best to limit to a single major+  --     version of `hspec` & `hspec-discover` to ensure+  --     intercompatibility+  build-depends:+    , hspec                          >= 2.4.4    && < 2.8+   build-tool-depends:-    hspec-discover:hspec-discover >= 2.4.4 && < 2.6+    , hspec-discover:hspec-discover  >= 2.4.4    && < 2.8  test-suite fixtures   type:             exitcode-stdio-1.0   default-language: Haskell2010   main-is:          Fixtures.hs-  ghc-options:      -Wall -O0+  ghc-options:      -Wall   hs-source-dirs:   fixtures-  buildable:        False   build-depends:-      base         >= 4.5     && < 4.13-    , base-compat  >= 0.9.3   && < 0.11+      -- intra-package dependency+    , haddock-library+      -- constraints inherited via lib:haddock-library component+    , base++      -- extra dependencies+    , base-compat           ^>= 0.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--  -- Depend on the library.-  build-depends:-    haddock-library+    , optparse-applicative  ^>= 0.15+    , tree-diff             ^>= 0.1  source-repository head   type:     git
src/Documentation/Haddock/Markup.hs view
@@ -2,35 +2,38 @@ module Documentation.Haddock.Markup (     markup   , idMarkup+  , plainMarkup   ) where  import Documentation.Haddock.Types +import Data.Maybe ( fromMaybe )+ markup :: DocMarkupH mod id a -> DocH mod id -> a-markup m DocEmpty                    = markupEmpty m-markup m (DocAppend d1 d2)           = markupAppend m (markup m d1) (markup m d2)-markup m (DocString s)               = markupString m s-markup m (DocParagraph d)            = markupParagraph m (markup m d)-markup m (DocIdentifier x)           = markupIdentifier m x-markup m (DocIdentifierUnchecked x)  = markupIdentifierUnchecked m x-markup m (DocModule mod0)            = markupModule m mod0-markup m (DocWarning d)              = markupWarning m (markup m d)-markup m (DocEmphasis d)             = markupEmphasis m (markup m d)-markup m (DocBold d)                 = markupBold m (markup m d)-markup m (DocMonospaced d)           = markupMonospaced m (markup m d)-markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)-markup m (DocOrderedList ds)         = markupOrderedList m (map (markup m) ds)-markup m (DocDefList ds)             = markupDefList m (map (markupPair m) ds)-markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)-markup m (DocHyperlink l)            = markupHyperlink m l-markup m (DocAName ref)              = markupAName m ref-markup m (DocPic img)                = markupPic m img-markup m (DocMathInline mathjax)     = markupMathInline m mathjax-markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax-markup m (DocProperty p)             = markupProperty m p-markup m (DocExamples e)             = markupExample m e-markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))-markup m (DocTable (Table h b))      = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))+markup m DocEmpty                       = markupEmpty m+markup m (DocAppend d1 d2)              = markupAppend m (markup m d1) (markup m d2)+markup m (DocString s)                  = markupString m s+markup m (DocParagraph d)               = markupParagraph m (markup m d)+markup m (DocIdentifier x)              = markupIdentifier m x+markup m (DocIdentifierUnchecked x)     = markupIdentifierUnchecked m x+markup m (DocModule mod0)               = markupModule m mod0+markup m (DocWarning d)                 = markupWarning m (markup m d)+markup m (DocEmphasis d)                = markupEmphasis m (markup m d)+markup m (DocBold d)                    = markupBold m (markup m d)+markup m (DocMonospaced d)              = markupMonospaced m (markup m d)+markup m (DocUnorderedList ds)          = markupUnorderedList m (map (markup m) ds)+markup m (DocOrderedList ds)            = markupOrderedList m (map (markup m) ds)+markup m (DocDefList ds)                = markupDefList m (map (markupPair m) ds)+markup m (DocCodeBlock d)               = markupCodeBlock m (markup m d)+markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))+markup m (DocAName ref)                 = markupAName m ref+markup m (DocPic img)                   = markupPic m img+markup m (DocMathInline mathjax)        = markupMathInline m mathjax+markup m (DocMathDisplay mathjax)       = markupMathDisplay m mathjax+markup m (DocProperty p)                = markupProperty m p+markup m (DocExamples e)                = markupExample m e+markup m (DocHeader (Header l t))       = markupHeader m (Header l (markup m t))+markup m (DocTable (Table h b))         = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))  markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b)@@ -62,4 +65,35 @@   markupExample              = DocExamples,   markupHeader               = DocHeader,   markupTable                = DocTable+  }++-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to+-- strip away any formatting while preserving as much of the actual text as+-- possible.+plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String+plainMarkup plainMod plainIdent = Markup {+  markupEmpty                = "",+  markupString               = id,+  markupParagraph            = id,+  markupAppend               = (++),+  markupIdentifier           = plainIdent,+  markupIdentifierUnchecked  = plainMod,+  markupModule               = id,+  markupWarning              = id,+  markupEmphasis             = id,+  markupBold                 = id,+  markupMonospaced           = id,+  markupUnorderedList        = const "",+  markupOrderedList          = const "",+  markupDefList              = const "",+  markupCodeBlock            = id,+  markupHyperlink            = \(Hyperlink url lbl) -> fromMaybe url lbl,+  markupAName                = id,+  markupPic                  = \(Picture uri title) -> fromMaybe uri title,+  markupMathInline           = id,+  markupMathDisplay          = id,+  markupProperty             = id,+  markupExample              = const "",+  markupHeader               = \(Header _ title) -> title,+  markupTable                = const ""   }
src/Documentation/Haddock/Parser.hs view
@@ -27,14 +27,16 @@ import           Control.Applicative import           Control.Arrow (first) import           Control.Monad-import           Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace)-import           Data.List (intercalate, unfoldr, elemIndex, notElem)+import           Data.Char (chr, isUpper, isAlpha, isSpace)+import           Data.List (intercalate, unfoldr, elemIndex) import           Data.Maybe (fromMaybe, mapMaybe) import           Data.Monoid import qualified Data.Set as Set import           Documentation.Haddock.Doc+import           Documentation.Haddock.Markup ( markup, plainMarkup ) import           Documentation.Haddock.Parser.Monad import           Documentation.Haddock.Parser.Util+import           Documentation.Haddock.Parser.Identifier import           Documentation.Haddock.Types import           Prelude hiding (takeWhile) import qualified Prelude as P@@ -45,53 +47,26 @@ 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')@@ -107,7 +82,7 @@     g (DocOrderedList x) = DocOrderedList $ fmap g x     g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x     g (DocCodeBlock x) = DocCodeBlock $ g x-    g (DocHyperlink x) = DocHyperlink x+    g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))     g (DocPic x) = DocPic x     g (DocMathInline x) = DocMathInline x     g (DocMathDisplay x) = DocMathDisplay x@@ -301,13 +276,20 @@ -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]" -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathDisplay :: Parser (DocH mod a)-mathDisplay = DocMathDisplay . T.unpack +mathDisplay = DocMathDisplay . T.unpack               <$> ("\\[" *> takeUntil "\\]") -markdownImage :: Parser (DocH mod a)-markdownImage = fromHyperlink <$> ("!" *> linkParser)+-- | Markdown image parser. As per the commonmark reference recommendation, the+-- description text for an image converted to its a plain string representation.+--+-- >>> parseString "![some /emphasis/ in a description](www.site.com)"+-- DocPic (Picture "www.site.com" (Just "some emphasis in a description"))+markdownImage :: Parser (DocH mod Identifier)+markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser)   where-    fromHyperlink (Hyperlink url label) = DocPic (Picture url label)+    fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l)+    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)@@ -360,32 +342,34 @@     parseFirstRow :: Parser Text     parseFirstRow = do         skipHorizontalSpace-        -- upper-left corner is +-        c <- Parsec.char '+'-        cs <- some (Parsec.char '-' <|> Parsec.char '+')+        cs <- takeWhile (\c -> c == '-' || c == '+') -        -- upper right corner is + too-        guard (last cs == '+')+        -- upper-left and upper-right corners are `+`+        guard (T.length cs >= 2 &&+               T.head cs == '+' &&+               T.last cs == '+')          -- trailing space         skipHorizontalSpace         _ <- Parsec.newline -        return (T.cons c $ T.pack cs)+        return cs      parseRestRows :: Int -> Parser Text     parseRestRows l = do         skipHorizontalSpace+        bs <- scan predicate l -        c <- Parsec.char '|' <|> Parsec.char '+'-        bs <- scan predicate (l - 2)-        c2 <- Parsec.char '|' <|> Parsec.char '+'+        -- Left and right edges are `|` or `+`+        guard (T.length bs >= 2 &&+               (T.head bs == '|' || T.head bs == '+') &&+               (T.last bs == '|' || T.last bs == '+'))          -- trailing space         skipHorizontalSpace         _ <- Parsec.newline -        return (T.cons c (T.snoc bs c2))+        return bs       where         predicate n c             | n <= 0    = Nothing@@ -662,7 +646,7 @@ --  Doesn't discard the trailing newline. takeNonEmptyLine :: Parser Text takeNonEmptyLine = do-    l <- takeWhile1 (Parsec.noneOf "\n") >>= nonSpace+    l <- takeWhile1 (/= '\n') >>= nonSpace     _ <- "\n"     pure (l <> "\n") @@ -732,7 +716,7 @@ nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine)  takeLine :: Parser Text-takeLine = try (takeWhile (Parsec.noneOf "\n") <* endOfLine)+takeLine = try (takeWhile (/= '\n') <* endOfLine)  endOfLine :: Parser () endOfLine = void "\n" <|> Parsec.eof @@ -742,7 +726,7 @@ -- >>> snd <$> parseOnly property "prop> hello world" -- Right (DocProperty "hello world") property :: Parser (DocH mod a)-property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (Parsec.noneOf "\n"))+property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (/= '\n'))  -- | -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed@@ -782,22 +766,22 @@           | isNewline && isSpace c = Just isNewline           | otherwise = Just $ c == '\n' -hyperlink :: Parser (DocH mod a)+hyperlink :: Parser (DocH mod Identifier) hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ]  angleBracketLink :: Parser (DocH mod a) angleBracketLink =-    DocHyperlink . makeLabeled Hyperlink +    DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)     <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod a)+markdownLink :: Parser (DocH mod Identifier) markdownLink = DocHyperlink <$> linkParser -linkParser :: Parser Hyperlink+linkParser :: Parser (Hyperlink (DocH mod Identifier)) linkParser = flip Hyperlink <$> label <*> (whitespace *> url)   where-    label :: Parser (Maybe String)-    label = Just . decode . T.strip <$> ("[" *> takeUntil "]")+    label :: Parser (Maybe (DocH mod Identifier))+    label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]")      whitespace :: Parser ()     whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)@@ -816,41 +800,17 @@ autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url   where-    url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (Parsec.satisfy (not . isSpace))+    url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (not . isSpace)          mkLink :: Text -> DocH mod a     mkLink s = case T.unsnoc s of       Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x]       _ -> DocHyperlink (mkHyperlink s) -    mkHyperlink :: Text -> Hyperlink+    mkHyperlink :: Text -> Hyperlink (DocH mod a)     mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing  ---- | Parses strings between identifier delimiters. Consumes all input that it--- deems to be valid in an identifier. Note that it simply blindly consumes--- characters and does no actual validation itself.-parseValid :: Parser String-parseValid = p some-  where-    idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_')--    p p' = do-      vs <- p' idChar-      c <- peekChar'-      case c of-        '`' -> return vs-        '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ]-        _ -> fail "outofvalid"---- | Parses identifiers with help of 'parseValid'. Asks GHC for--- 'String' from the string it deems valid.+-- | Parses identifiers with help of 'parseValid'. identifier :: Parser (DocH mod Identifier)-identifier = do-  o <- idDelim-  vid <- parseValid-  e <- idDelim-  return $ DocIdentifier (o, vid, e)-  where-    idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`')+identifier = DocIdentifier <$> parseValid
+ src/Documentation/Haddock/Parser/Identifier.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP          #-}+{-# 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.Functor (($>))+#if MIN_VERSION_base(4,9,0)+import           Text.Read.Lex                      (isSymbolChar)+#else+import           Data.Char                          (GeneralCategory (..),+                                                     generalCategory)+#endif++import Data.Maybe++-- | 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+++#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++-- | 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)
src/Documentation/Haddock/Parser/Monad.hs view
@@ -4,15 +4,32 @@ {-# 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  import qualified Text.Parsec.Char as Parsec import qualified Text.Parsec as Parsec+import           Text.Parsec.Pos             ( updatePosChar )+import           Text.Parsec                 ( State(..)+                                             , getParserState, setParserState )  import qualified Data.Text as T import           Data.Text                   ( Text ) +import           Control.Monad               ( mfilter )+import           Data.Functor                ( ($>) ) import           Data.String                 ( IsString(..) ) import           Data.Bits                   ( Bits(..) ) import           Data.Char                   ( ord )@@ -20,7 +37,11 @@ import           Control.Applicative as App  import           Documentation.Haddock.Types ( Version )+import           Prelude hiding (takeWhile) +-- | The only bit of information we really care about truding along with us+-- through parsing is the version attached to a @\@since@ annotation - if+-- the doc even contained one. newtype ParserState = ParserState {   parserStateSince :: Maybe Version } deriving (Eq, Show)@@ -29,7 +50,7 @@ initialParserState = ParserState Nothing  setSince :: Version -> Parser ()-setSince since = Parsec.modifyState (\st -> st {parserStateSince = Just since})+setSince since = Parsec.modifyState (\st -> st{ parserStateSince = Just since })  type Parser = Parsec.Parsec Text ParserState @@ -44,38 +65,74 @@  -- | Always succeeds, but returns 'Nothing' if at the end of input. Does not -- consume input.+--+-- Equivalent to @Parsec.optionMaybe . Parsec.lookAhead $ Parsec.anyChar@, but+-- more efficient. peekChar :: Parser (Maybe Char)-peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar+peekChar = headOpt . stateInput <$> getParserState+  where headOpt t | T.null t = Nothing+                  | otherwise = Just (T.head t)+{-# INLINE peekChar #-}  -- | Fails if at the end of input. Does not consume input.+--+-- Equivalent to @Parsec.lookAhead Parsec.anyChar@, but more efficient. peekChar' :: Parser Char-peekChar' = Parsec.lookAhead Parsec.anyChar +peekChar' = headFail . stateInput =<< getParserState+  where headFail t | T.null t = Parsec.parserFail "peekChar': reached EOF"+                   | otherwise = App.pure (T.head t)+{-# INLINE peekChar' #-}  -- | Parses the given string. Returns the parsed string.+--+-- Equivalent to @Parsec.string (T.unpack t) $> t@, but more efficient. string :: Text -> Parser Text-string t = Parsec.string (T.unpack t) *> App.pure t+string t = do+  s@State{ stateInput = inp, statePos = pos } <- getParserState+  case T.stripPrefix t inp of+    Nothing -> Parsec.parserFail "string: Failed to match the input string"+    Just inp' ->+      let pos' = T.foldl updatePosChar pos t+          s' = s{ stateInput = inp', statePos = pos' }+      in setParserState s' $> t +-- | Keep matching characters as long as the predicate function holds (and+-- return them).+--+-- Equivalent to @fmap T.pack . Parsec.many@, but more efficient.+takeWhile :: (Char -> Bool) -> Parser Text+takeWhile f = do+  s@State{ stateInput = inp, statePos = pos } <- getParserState+  let (t, inp') = T.span f inp+      pos' = T.foldl updatePosChar pos t+      s' = s{ stateInput = inp', statePos = pos' }+  setParserState s' $> t++-- | Like 'takeWhile', but fails if no characters matched.+--+-- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient.+takeWhile1 :: (Char -> Bool) -> Parser Text+takeWhile1 = mfilter (not . T.null) . takeWhile+ -- | Scan the input text, accumulating characters as long as the scanning -- function returns true. scan :: (s -> Char -> Maybe s) -- ^ scan function      -> s                      -- ^ initial state      -> Parser Text -scan f = fmap T.pack . go-  where go s1 = do { cOpt <- peekChar-                   ; case cOpt >>= f s1 of-                       Nothing -> pure ""-                       Just s2 -> (:) <$> Parsec.anyChar <*> go s2-                   }---- | Apply a parser for a character zero or more times and collect the result in--- a string.-takeWhile :: Parser Char -> Parser Text-takeWhile = fmap T.pack . Parsec.many+scan f st = do+  s@State{ stateInput = inp, statePos = pos } <- getParserState+  go inp st pos 0 $ \inp' pos' n ->+    let s' = s{ Parsec.stateInput = inp', Parsec.statePos = pos' }+    in setParserState s' $> T.take n inp+  where+    go inp s !pos !n cont+      = case T.uncons inp of+          Nothing -> cont inp pos n        -- ran out of input+          Just (c, inp') ->+             case f s c of+               Nothing -> cont inp pos n   -- scan function failed+               Just s' -> go inp' s' (updatePosChar pos c) (n+1) cont --- | Apply a parser for a character one or more times and collect the result in--- a string.-takeWhile1 :: Parser Char -> Parser Text-takeWhile1 =  fmap T.pack . Parsec.many1  -- | Parse a decimal number. decimal :: Integral a => Parser a
src/Documentation/Haddock/Parser/Util.hs view
@@ -40,7 +40,7 @@  -- | Take leading horizontal space takeHorizontalSpace :: Parser Text -takeHorizontalSpace = takeWhile (Parsec.oneOf horizontalSpace)+takeHorizontalSpace = takeWhile (`elem` horizontalSpace)  makeLabeled :: (String -> Maybe String -> a) -> Text -> a makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of
src/Documentation/Haddock/Types.hs view
@@ -65,10 +65,10 @@ type Version = [Int] type Package = String -data Hyperlink = Hyperlink+data Hyperlink id = Hyperlink   { hyperlinkUrl   :: String-  , hyperlinkLabel :: Maybe String-  } deriving (Eq, Show)+  , hyperlinkLabel :: Maybe id+  } deriving (Eq, Show, Functor, Foldable, Traversable)  data Picture = Picture   { pictureUri   :: String@@ -118,7 +118,7 @@   | DocOrderedList [DocH mod id]   | DocDefList [(DocH mod id, DocH mod id)]   | DocCodeBlock (DocH mod id)-  | DocHyperlink Hyperlink+  | DocHyperlink (Hyperlink (DocH mod id))   | DocPic Picture   | DocMathInline String   | DocMathDisplay String@@ -147,7 +147,7 @@   bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)   bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs)   bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)-  bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink+  bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl))   bimap _ _ (DocPic picture) = DocPic picture   bimap _ _ (DocMathInline s) = DocMathInline s   bimap _ _ (DocMathDisplay s) = DocMathDisplay s@@ -192,7 +192,7 @@   bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs   bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs   bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc-  bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink)+  bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl)   bitraverse _ _ (DocPic picture) = pure (DocPic picture)   bitraverse _ _ (DocMathInline s) = pure (DocMathInline s)   bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s)@@ -203,6 +203,16 @@   bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body #endif +-- | The namespace qualification for an identifier.+data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show)++-- | Render the a namespace into the same format it was initially parsed.+renderNs :: Namespace -> String+renderNs Value = "v"+renderNs Type = "t"+renderNs None = ""++ -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say).@@ -227,7 +237,7 @@   , markupOrderedList          :: [a] -> a   , markupDefList              :: [(a,a)] -> a   , markupCodeBlock            :: a -> a-  , markupHyperlink            :: Hyperlink -> a+  , markupHyperlink            :: Hyperlink a -> a   , markupAName                :: String -> a   , markupPic                  :: Picture -> a   , markupMathInline           :: String -> a
− src/Documentation/Haddock/Utf8.hs 
@@ -1,74 +0,0 @@-module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where-import           Data.Bits ((.|.), (.&.), shiftL, shiftR)-import qualified Data.ByteString as BS-import           Data.Char (chr, ord)-import           Data.Word (Word8)---- | Helper that encodes and packs a 'String' into a 'BS.ByteString'-encodeUtf8 :: String -> BS.ByteString-encodeUtf8 = BS.pack . encode---- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String'-decodeUtf8 :: BS.ByteString -> String-decodeUtf8 = decode . BS.unpack---- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding--- | Character to use when 'encode' or 'decode' fail for a byte.-replacementCharacter :: Char-replacementCharacter = '\xfffd'---- | Encode a Haskell String to a list of Word8 values, in UTF8 format.-encode :: String -> [Word8]-encode = concatMap (map fromIntegral . go . ord)- where-  go oc-   | oc <= 0x7f       = [oc]--   | oc <= 0x7ff      = [ 0xc0 + (oc `shiftR` 6)-                        , 0x80 + oc .&. 0x3f-                        ]--   | oc <= 0xffff     = [ 0xe0 + (oc `shiftR` 12)-                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)-                        , 0x80 + oc .&. 0x3f-                        ]-   | otherwise        = [ 0xf0 + (oc `shiftR` 18)-                        , 0x80 + ((oc `shiftR` 12) .&. 0x3f)-                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)-                        , 0x80 + oc .&. 0x3f-                        ]---- | Decode a UTF8 string packed into a list of Word8 values, directly to String-decode :: [Word8] -> String-decode [    ] = ""-decode (c:cs)-  | c < 0x80  = chr (fromEnum c) : decode cs-  | c < 0xc0  = replacementCharacter : decode cs-  | c < 0xe0  = multi1-  | c < 0xf0  = multi_byte 2 0xf  0x800-  | c < 0xf8  = multi_byte 3 0x7  0x10000-  | c < 0xfc  = multi_byte 4 0x3  0x200000-  | c < 0xfe  = multi_byte 5 0x1  0x4000000-  | otherwise = replacementCharacter : decode cs-  where-    multi1 = case cs of-      c1 : ds | c1 .&. 0xc0 == 0x80 ->-        let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|.  fromEnum (c1 .&. 0x3f)-        in if d >= 0x000080 then toEnum d : decode ds-                            else replacementCharacter : decode ds-      _ -> replacementCharacter : decode cs--    multi_byte :: Int -> Word8 -> Int -> String-    multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))-      where-        aux 0 rs acc-          | overlong <= acc && acc <= 0x10ffff &&-            (acc < 0xd800 || 0xdfff < acc)     &&-            (acc < 0xfffe || 0xffff < acc)      = chr acc : decode rs-          | otherwise = replacementCharacter : decode rs--        aux n (r:rs) acc-          | r .&. 0xc0 == 0x80 = aux (n-1) rs-                               $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)--        aux _ rs     _ = replacementCharacter : decode rs
test/Documentation/Haddock/ParserSpec.hs view
@@ -37,7 +37,7 @@ parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString -hyperlink :: String -> Maybe String -> Doc String+hyperlink :: String -> Maybe (Doc String) -> Doc String hyperlink url = DocHyperlink . Hyperlink url  main :: IO ()@@ -112,7 +112,7 @@         "``" `shouldParseTo` "``"        it "can parse an identifier in infix notation enclosed within backticks" $ do-        "``infix``" `shouldParseTo` "`" <> DocIdentifier "infix" <> "`"+        "``infix``" `shouldParseTo` DocIdentifier "`infix`"        it "can parse identifiers containing a single quote" $ do         "'don't'" `shouldParseTo` DocIdentifier "don't"@@ -132,6 +132,19 @@       it "can parse an identifier that starts with an underscore" $ do         "'_x'" `shouldParseTo` DocIdentifier "_x" +      it "can parse value-namespaced identifiers" $ do+        "v'foo'" `shouldParseTo` DocIdentifier "foo"++      it "can parse type-namespaced identifiers" $ do+        "t'foo'" `shouldParseTo` DocIdentifier "foo"++      it "can parse parenthesized operators and backticked identifiers" $ do+        "'(<|>)'" `shouldParseTo` DocIdentifier "(<|>)"+        "'`elem`'" `shouldParseTo` DocIdentifier "`elem`"++      it "can properly figure out the end of identifiers" $ do+        "'DbModule'/'DbUnitId'" `shouldParseTo` DocIdentifier "DbModule" <> "/" <> DocIdentifier "DbUnitId"+     context "when parsing operators" $ do       it "can parse an operator enclosed within single quotes" $ do         "'.='" `shouldParseTo` DocIdentifier ".="@@ -201,6 +214,10 @@         it "rejects whitespace in URL" $ do           "[some label]( url)" `shouldParseTo`             "[some label]( url)"++        it "allows inline markup in the label" $ do+          "[something /emphasized/](url)" `shouldParseTo`+            hyperlink "url" (Just ("something " <> DocEmphasis "emphasized"))          context "when URL is on a separate line" $ do           it "allows URL to be on a separate line" $ do
− test/Documentation/Haddock/Utf8Spec.hs 
@@ -1,14 +0,0 @@-module Documentation.Haddock.Utf8Spec (main, spec) where--import Test.Hspec-import Test.QuickCheck-import Documentation.Haddock.Utf8--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "decodeUtf8" $ do-    it "is inverse to encodeUtf8" $ do-      property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs