haddock-library 1.5.0.1 → 1.11.0
raw patch · 62 files changed
Files
- CHANGES.md +32/−0
- LICENSE +21/−18
- fixtures/Fixtures.hs +12/−7
- fixtures/examples/definitionList.input +1/−0
- fixtures/examples/definitionList.parsed +1/−0
- fixtures/examples/identifier.input +1/−0
- fixtures/examples/identifier.parsed +1/−0
- fixtures/examples/identifierBackticks.input +1/−0
- fixtures/examples/identifierBackticks.parsed +1/−0
- fixtures/examples/link.input +1/−0
- fixtures/examples/link.parsed +5/−0
- fixtures/examples/linkInline.input +1/−0
- fixtures/examples/linkInline.parsed +7/−0
- fixtures/examples/linkInlineMarkup.input +1/−0
- fixtures/examples/linkInlineMarkup.parsed +8/−0
- fixtures/examples/list-blocks1.input +15/−0
- fixtures/examples/list-blocks1.parsed +12/−0
- fixtures/examples/list-blocks2.input +10/−0
- fixtures/examples/list-blocks2.parsed +10/−0
- fixtures/examples/table-cell-strip-whitespaces.input +5/−0
- fixtures/examples/table-cell-strip-whitespaces.parsed +29/−0
- fixtures/examples/table-simple.input +7/−0
- fixtures/examples/table-simple.parsed +42/−0
- fixtures/examples/table1.input +12/−0
- fixtures/examples/table1.parsed +68/−0
- fixtures/examples/table2.input +7/−0
- fixtures/examples/table2.parsed +46/−0
- fixtures/examples/table3.input +7/−0
- fixtures/examples/table3.parsed +50/−0
- fixtures/examples/table4.input +17/−0
- fixtures/examples/table4.parsed +26/−0
- fixtures/examples/table5.input +8/−0
- fixtures/examples/table5.parsed +46/−0
- fixtures/examples/url.input +1/−0
- fixtures/examples/url.parsed +4/−0
- fixtures/examples/urlLabel.input +1/−0
- fixtures/examples/urlLabel.parsed +5/−0
- haddock-library.cabal +74/−105
- src/CompatPrelude.hs +53/−0
- src/Documentation/Haddock/Doc.hs +4/−4
- src/Documentation/Haddock/Markup.hs +58/−24
- src/Documentation/Haddock/Parser.hs +323/−271
- src/Documentation/Haddock/Parser/Identifier.hs +159/−0
- src/Documentation/Haddock/Parser/Monad.hs +122/−143
- src/Documentation/Haddock/Parser/Util.hs +39/−43
- src/Documentation/Haddock/Types.hs +48/−19
- src/Documentation/Haddock/Utf8.hs +0/−74
- test/Documentation/Haddock/Parser/UtilSpec.hs +4/−1
- test/Documentation/Haddock/ParserSpec.hs +218/−55
- test/Documentation/Haddock/Utf8Spec.hs +0/−14
- vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs +0/−23
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs +0/−230
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs +0/−156
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs +0/−464
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs +0/−115
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs +0/−536
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs +0/−233
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs +0/−157
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs +0/−18
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs +0/−243
- vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs +0/−137
- vendor/attoparsec-0.13.1.0/LICENSE +0/−30
CHANGES.md view
@@ -1,3 +1,35 @@+## Changes in version 1.11.0++ * Add support for linking identifiers with a quote between backticks (#1408)++## Changes in version 1.10.0++ * Add support for labeled module references (#1360)+## Changes in version 1.9.0++ * Fix build-time regression for `base < 4.7` (#1119)++ * Update parsing to strip whitespace from table cells (#1074)++## Changes in version 1.8.0++ * Support inline markup in markdown-style links (#875)++ * Remove now unused `Documentation.Haddock.Utf8` module.+ This module was anyways copied from the `utf8-string` package.++## Changes in version 1.7.0++ * Make `Documentation.Haddock.Parser.Monad` an internal module++## Changes in version 1.6.1++ * Replace `attoparsec` with `parsec` (#799)++## Changes in version 1.6.0++ * `MetaDoc` stores package name for since annotations+ ## Changes in version 1.5.0.1 * Support for parsing unicode operators (#458)
LICENSE view
@@ -1,23 +1,26 @@-Copyright 2002-2010, Simon Marlow. All rights reserved.+Copyright (c) 2002-2010, Simon Marlow+All rights reserved. Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+modification, are permitted provided that the following conditions are+met: -- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer. -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR-BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,-WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN-IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
fixtures/Fixtures.hs view
@@ -9,11 +9,11 @@ import Data.List (foldl') import Data.Traversable (for) import GHC.Generics (Generic)-import Prelude ()-import Prelude.Compat+import Prelude import System.Directory (getDirectoryContents) import System.Exit (exitFailure) import System.FilePath+import System.IO import Data.TreeDiff import Data.TreeDiff.Golden@@ -65,7 +65,7 @@ case mres of Nothing -> return (Result 1 1) Just str -> do- putStr str+ putStrLn str return (Result 0 1) where handler :: Expr -> IOException -> IO Expr@@ -101,12 +101,14 @@ writeFile o actual parseString :: String -> Doc String-parseString = Parse.toRegular . _doc . Parse.parseParas+parseString = Parse.toRegular . _doc . Parse.parseParas Nothing data Cmd = CmdRun | CmdAccept | CmdList main :: IO ()-main = runCmd =<< O.execParser opts+main = do+ hSetBuffering stdout NoBuffering -- For interleaved output when debugging+ runCmd =<< O.execParser opts where opts = O.info (O.helper <*> cmdParser) O.fullDesc @@ -143,8 +145,11 @@ deriving instance Generic (Header id) instance ToExpr id => ToExpr (Header id) -deriving instance Generic Hyperlink-instance ToExpr Hyperlink+deriving instance Generic (Hyperlink id)+instance ToExpr id => ToExpr (Hyperlink id)++deriving instance Generic (ModLink id)+instance ToExpr id => ToExpr (ModLink id) deriving instance Generic Picture instance ToExpr Picture
+ 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-cell-strip-whitespaces.input view
@@ -0,0 +1,5 @@++------+--------------+-------------------------------------------------++| C1 | C2 | C3 |++======+==============+=================================================++| row | 'test' | 'test table cell with .. whitepspace ' |++------+--------------+-------------------------------------------------+
+ fixtures/examples/table-cell-strip-whitespaces.parsed view
@@ -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}]]}
+ 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,42 @@+DocTable+ Table+ {tableBodyRows = [TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "200",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocMonospaced (DocString "OK"),+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "operation successful",+ tableCellRowspan = 1}],+ TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "204",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocMonospaced (DocString "No Content"),+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString+ "operation successful, no body returned",+ tableCellRowspan = 1}]],+ tableHeaderRows = [TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "code",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "message",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "description",+ tableCellRowspan = 1}]]}
+ 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,68 @@+DocTable+ Table+ {tableBodyRows = [TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "body row 1, column 1",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "column 2",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "column 3",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "column 4",+ tableCellRowspan = 1}],+ TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "body row 2",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 3,+ tableCellContents = DocString "Cells may span columns.",+ tableCellRowspan = 1}],+ TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "body row 3",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString+ (concat ["Cells may\n", "span rows.\n"]),+ tableCellRowspan = 2},+ TableCell+ {tableCellColspan = 2,+ tableCellContents = DocMathDisplay+ (concat ["\n", "f(n) = \\sum_{i=1}\n"]),+ tableCellRowspan = 2}],+ TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "body row 4",+ tableCellRowspan = 1}]],+ tableHeaderRows = [TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString+ (concat+ ["Header row, column 1\n",+ "(header rows optional)"]),+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "Header 2\n",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "Header 3\n",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "Header 4\n",+ tableCellRowspan = 1}]]}
+ 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 = DocEmpty,+ tableCellRowspan = 1}],+ TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "row 3",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ tableCellRowspan = 1}]],+ tableHeaderRows = []}
+ 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 = DocEmpty,+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ 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,46 @@+DocTable+ Table+ {tableBodyRows = [TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString+ (concat ["row 2\n", "\n", "\n", "row 3"]),+ tableCellRowspan = 2},+ TableCell+ {tableCellColspan = 3,+ tableCellContents = DocAppend+ (DocString "Use the command ")+ (DocAppend+ (DocMonospaced (DocString "ls | more"))+ (DocString ".\n")),+ tableCellRowspan = 1}],+ TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocEmpty,+ tableCellRowspan = 1}]],+ tableHeaderRows = [TableRow+ [TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "row 1, col 1",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "column 2",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "column 3",+ tableCellRowspan = 1},+ TableCell+ {tableCellColspan = 1,+ tableCellContents = DocString "column 4",+ tableCellRowspan = 1}]]}
+ 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,132 +1,104 @@-cabal-version: 2.0+cabal-version: 3.0 name: haddock-library-version: 1.5.0.1+version: 1.11.0 synopsis: Library exposing some functionality of Haddock.+ description: Haddock is a documentation-generation tool for Haskell- libraries. These modules expose some functionality of it- without pulling in the GHC dependency. Please note that the- API is likely to change so specify upper bounds in your- project if you can't release often. For interacting with Haddock- itself, see the ‘haddock’ package.-license: BSD3-license-files: LICENSE- vendor/attoparsec-0.13.1.0/LICENSE-maintainer: Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>+ 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: BSD-2-Clause+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-build-type: Simple+tested-with: GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.3+ , GHC == 8.10.1+ , GHC == 9.0.1+ , GHC == 9.2.0+ extra-source-files: CHANGES.md+ fixtures/examples/*.input+ fixtures/examples/*.parsed -library- default-language: Haskell2010+common lib-defaults+ default-language: Haskell2010 build-depends:- base >= 4.5 && < 4.12- , bytestring >= 0.9.2.1 && < 0.11- , containers >= 0.4.2.1 && < 0.6- , transformers >= 0.3.0 && < 0.6+ , base >= 4.5 && < 4.17+ , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1+ , text ^>= 1.2.3.0 || ^>= 2.0+ , parsec ^>= 3.1.13.0 - -- internal sub-lib- build-depends: attoparsec+ ghc-options: -funbox-strict-fields -Wall+ if impl(ghc >= 8.0)+ ghc-options: -Wcompat -Wnoncanonical-monad-instances +library+ import: lib-defaults+ hs-source-dirs: src- ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 exposed-modules: Documentation.Haddock.Doc Documentation.Haddock.Markup Documentation.Haddock.Parser- Documentation.Haddock.Parser.Monad Documentation.Haddock.Types- Documentation.Haddock.Utf8 other-modules:+ CompatPrelude Documentation.Haddock.Parser.Util-- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances--library attoparsec- default-language: Haskell2010-- build-depends:- base >= 4.5 && < 4.12- , bytestring >= 0.9.2.1 && < 0.11- , deepseq >= 1.3 && < 1.5-- hs-source-dirs: vendor/attoparsec-0.13.1.0-- -- NB: haddock-library needs only small part of lib:attoparsec- -- internally, so we only bundle that subset here- exposed-modules:- Data.Attoparsec.ByteString- Data.Attoparsec.ByteString.Char8- Data.Attoparsec.Combinator-- other-modules:- Data.Attoparsec- Data.Attoparsec.ByteString.Buffer- Data.Attoparsec.ByteString.FastSet- Data.Attoparsec.ByteString.Internal- Data.Attoparsec.Internal- Data.Attoparsec.Internal.Fhthagn- Data.Attoparsec.Internal.Types- Data.Attoparsec.Number-- ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2-- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances- else- build-depends: semigroups ^>= 0.18.3, fail ^>= 4.9.0.0-+ Documentation.Haddock.Parser.Monad+ Documentation.Haddock.Parser.Identifier test-suite spec+ import: lib-defaults type: exitcode-stdio-1.0- default-language: Haskell2010 main-is: Spec.hs hs-source-dirs:- test- , src- ghc-options: -Wall-- cpp-options:- -DTEST+ test+ src other-modules:- Documentation.Haddock.Doc- Documentation.Haddock.Parser- Documentation.Haddock.Parser.Monad- Documentation.Haddock.Parser.Util- Documentation.Haddock.Parser.UtilSpec- Documentation.Haddock.ParserSpec- Documentation.Haddock.Types- Documentation.Haddock.Utf8- Documentation.Haddock.Utf8Spec+ CompatPrelude+ Documentation.Haddock.Doc+ Documentation.Haddock.Markup+ Documentation.Haddock.Parser+ Documentation.Haddock.Parser.Monad+ Documentation.Haddock.Parser.Util+ Documentation.Haddock.Parser.UtilSpec+ Documentation.Haddock.ParserSpec+ Documentation.Haddock.Types+ Documentation.Haddock.Parser.Identifier build-depends:- base-compat ^>= 0.9.3- , containers >= 0.4.2.1 && < 0.6- , transformers >= 0.3.0 && < 0.6- , hspec ^>= 2.4.4- , QuickCheck ^>= 2.11-- -- internal sub-lib- build-depends: attoparsec+ , base-compat ^>= 0.12.0+ , QuickCheck ^>= 2.11 || ^>= 2.13.2 || ^>= 2.14 + , deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0 - -- Versions for the dependencies below are transitively pinned by- -- dependency on haddock-library:lib:attoparsec+ -- 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:- base- , bytestring- , deepseq+ , hspec >= 2.4.4 && < 2.10 build-tool-depends:- hspec-discover:hspec-discover ^>= 2.4.4+ , hspec-discover:hspec-discover >= 2.4.4 && < 2.10 test-suite fixtures type: exitcode-stdio-1.0@@ -135,20 +107,17 @@ ghc-options: -Wall hs-source-dirs: fixtures build-depends:- base-compat ^>= 0.9.3+ -- intra-package dependency+ , haddock-library+ -- constraints inherited via lib:haddock-library component+ , base++ -- extra dependencies+ , base-compat ^>= 0.12.0 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2- , optparse-applicative ^>= 0.14.0.0- , tree-diff ^>= 0.0.0.1-- -- Depend on the library.- build-depends:- haddock-library-- -- Versions for the dependencies below are transitively pinned by- -- dependency on haddock-library:lib:attoparsec- build-depends:- base+ , optparse-applicative ^>= 0.15+ , tree-diff ^>= 0.2 source-repository head type: git
+ src/CompatPrelude.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}++#ifdef __HLINT__+#elif !MIN_VERSION_base(4,5,0)+# error This module doesn't provide compat-shims for versions prior to base-4.5+#endif++-- | Bridge impedance mismatch of different @base@ versions back till @base-4.5@ (GHC 7.4.2)+module CompatPrelude+ ( ($>)+ , isSymbolChar+ ) where++#if MIN_VERSION_base(4,7,0)+import Data.Functor ( ($>) )+#else+import Data.Functor ( (<$) )+#endif++#if MIN_VERSION_base(4,9,0)+import Text.Read.Lex (isSymbolChar)+#else+import Data.Char (GeneralCategory(..), generalCategory)+#endif+++#if !MIN_VERSION_base(4,7,0)+infixl 4 $>++-- | Flipped version of '<$'.+--+-- @since 4.7.0.0+($>) :: Functor f => f a -> b -> f b+($>) = flip (<$)+#endif++#if !MIN_VERSION_base(4,9,0)+-- inlined from base-4.10.0.0+isSymbolChar :: Char -> Bool+isSymbolChar c = not (isPuncChar c) && case generalCategory c of+ MathSymbol -> True+ CurrencySymbol -> True+ ModifierSymbol -> True+ OtherSymbol -> True+ DashPunctuation -> True+ OtherPunctuation -> c `notElem` "'\""+ ConnectorPunctuation -> c /= '_'+ _ -> False+ where+ -- | The @special@ character class as defined in the Haskell Report.+ isPuncChar :: Char -> Bool+ isPuncChar = (`elem` (",;()[]{}`" :: String))+#endif
src/Documentation/Haddock/Doc.hs view
@@ -27,16 +27,16 @@ (MetaDoc { _meta = m', _doc = d' }) = MetaDoc { _meta = m' `metaAppend` m, _doc = d `docAppend` d' } --- | This is not a monoidal append, it uses '<|>' for the '_version'.+-- | This is not a monoidal append, it uses '<|>' for the '_version' and+-- '_package'. metaAppend :: Meta -> Meta -> Meta-metaAppend (Meta { _version = v }) (Meta { _version = v' }) =- Meta { _version = v <|> v' }+metaAppend (Meta v1 p1) (Meta v2 p2) = Meta (v1 <|> v2) (p1 <|> p2) emptyMetaDoc :: MetaDoc mod id emptyMetaDoc = MetaDoc { _meta = emptyMeta, _doc = DocEmpty } emptyMeta :: Meta-emptyMeta = Meta { _version = empty }+emptyMeta = Meta empty empty docAppend :: DocH mod id -> DocH mod id -> DocH mod id docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)
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 (ModLink mo l)) = markupModule m (ModLink mo (fmap (markup m) l))+markup m (DocWarning d) = markupWarning m (markup m d)+markup m (DocEmphasis d) = markupEmphasis m (markup m d)+markup m (DocBold d) = markupBold m (markup m d)+markup m (DocMonospaced d) = markupMonospaced m (markup m d)+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)+markup m (DocOrderedList ds) = markupOrderedList m (map (\(index, a) -> (index, markup m a)) ds)+markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)+markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))+markup m (DocAName ref) = markupAName m ref+markup m (DocPic img) = markupPic m img+markup m (DocMathInline mathjax) = markupMathInline m mathjax+markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax+markup m (DocProperty p) = markupProperty m p+markup m (DocExamples e) = markupExample m e+markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))+markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b)@@ -62,4 +65,35 @@ markupExample = DocExamples, markupHeader = DocHeader, markupTable = DocTable+ }++-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to+-- strip away any formatting while preserving as much of the actual text as+-- possible.+plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String+plainMarkup plainMod plainIdent = Markup {+ markupEmpty = "",+ markupString = id,+ markupParagraph = id,+ markupAppend = (++),+ markupIdentifier = plainIdent,+ markupIdentifierUnchecked = plainMod,+ markupModule = \(ModLink m lbl) -> fromMaybe m lbl,+ markupWarning = id,+ markupEmphasis = id,+ markupBold = id,+ markupMonospaced = id,+ markupUnorderedList = const "",+ markupOrderedList = const "",+ markupDefList = const "",+ markupCodeBlock = id,+ markupHyperlink = \(Hyperlink url lbl) -> fromMaybe url lbl,+ markupAName = id,+ markupPic = \(Picture uri title) -> fromMaybe uri title,+ markupMathInline = id,+ markupMathDisplay = id,+ markupProperty = id,+ markupExample = const "",+ markupHeader = \(Header _ title) -> title,+ markupTable = const "" }
src/Documentation/Haddock/Parser.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- |@@ -16,90 +15,73 @@ -- to be -- -- @'toRegular' . '_doc' . 'parseParas'@-module Documentation.Haddock.Parser ( parseString, parseParas- , overIdentifier, toRegular, Identifier- ) where+module Documentation.Haddock.Parser (+ parseString,+ parseParas,+ overIdentifier,+ toRegular,+ Identifier+) where import Control.Applicative import Control.Arrow (first) import Control.Monad-import qualified Data.ByteString.Char8 as BS-import Data.Char (chr, isUpper, isAlpha, isAlphaNum)-import Data.List (stripPrefix, intercalate, unfoldr, elemIndex)+import Data.Char (chr, isUpper, isAlpha, 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.Parser.Monad hiding (take, endOfLine)+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 Documentation.Haddock.Utf8 import Prelude hiding (takeWhile) import qualified Prelude as P -#if MIN_VERSION_base(4,9,0)-import Text.Read.Lex (isSymbolChar)-#else-import Data.Char (GeneralCategory (..),- generalCategory)-#endif+import qualified Text.Parsec as Parsec+import Text.Parsec (try) --- $setup--- >>> :set -XOverloadedStrings+import qualified Data.Text as T+import Data.Text (Text) -#if !MIN_VERSION_base(4,9,0)--- inlined from base-4.10.0.0-isSymbolChar :: Char -> Bool-isSymbolChar c = not (isPuncChar c) && case generalCategory c of- MathSymbol -> True- CurrencySymbol -> True- ModifierSymbol -> True- OtherSymbol -> True- DashPunctuation -> True- OtherPunctuation -> not (c `elem` ("'\"" :: String))- ConnectorPunctuation -> c /= '_'- _ -> False- where- -- | The @special@ character class as defined in the Haskell Report.- isPuncChar :: Char -> Bool- isPuncChar = (`elem` (",;()[]{}`" :: String))-#endif --- | Identifier string surrounded with opening and closing quotes/backticks.-type Identifier = (Char, String, Char)+-- $setup+-- >>> :set -XOverloadedStrings -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String-toRegular = fmap (\(_, x, _) -> x)+toRegular = fmap (\(Identifier _ _ x _) -> x) -- | Maps over 'DocIdentifier's over 'String' with potentially failing -- conversion using user-supplied function. If the conversion fails, -- the identifier is deemed to not be valid and is treated as a -- regular string.-overIdentifier :: (String -> Maybe a)+overIdentifier :: (Namespace -> String -> Maybe a) -> DocH mod Identifier -> DocH mod a overIdentifier f d = g d where- g (DocIdentifier (o, x, e)) = case f x of- Nothing -> DocString $ o : x ++ [e]+ g (DocIdentifier (Identifier ns o x e)) = case f ns x of+ Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e] Just x' -> DocIdentifier x' g DocEmpty = DocEmpty g (DocAppend x x') = DocAppend (g x) (g x') g (DocString x) = DocString x g (DocParagraph x) = DocParagraph $ g x g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x- g (DocModule x) = DocModule x+ g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x)) g (DocWarning x) = DocWarning $ g x g (DocEmphasis x) = DocEmphasis $ g x g (DocMonospaced x) = DocMonospaced $ g x g (DocBold x) = DocBold $ g x g (DocUnorderedList x) = DocUnorderedList $ fmap g x- g (DocOrderedList x) = DocOrderedList $ fmap g x+ g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x g (DocCodeBlock x) = DocCodeBlock $ g x- g (DocHyperlink x) = DocHyperlink x+ g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x)) g (DocPic x) = DocPic x g (DocMathInline x) = DocMathInline x g (DocMathDisplay x) = DocMathDisplay x@@ -109,46 +91,71 @@ g (DocHeader (Header l x)) = DocHeader . Header l $ g x g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b)) -parse :: Parser a -> BS.ByteString -> (ParserState, a)-parse p = either err id . parseOnly (p <* endOfInput)++choice' :: [Parser a] -> Parser a+choice' [] = empty+choice' [p] = p+choice' (p : ps) = try p <|> choice' ps++parse :: Parser a -> Text -> (ParserState, a)+parse p = either err id . parseOnly (p <* Parsec.eof) where err = error . ("Haddock.Parser.parse: " ++) -- | Main entry point to the parser. Appends the newline character -- to the input string.-parseParas :: String -- ^ String to parse+parseParas :: Maybe Package+ -> String -- ^ String to parse -> MetaDoc mod Identifier-parseParas input = case parseParasState input of- (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state }+parseParas pkg input = case parseParasState input of+ (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state+ , _package = pkg+ } , _doc = a } parseParasState :: String -> (ParserState, DocH mod Identifier)-parseParasState =- parse (p <* skipSpace) . encodeUtf8 . (++ "\n") . filter (/= '\r')+parseParasState = parse (emptyLines *> p) . T.pack . (++ "\n") . filter (/= '\r') where p :: Parser (DocH mod Identifier)- p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n")+ p = docConcat <$> many (paragraph <* emptyLines) + emptyLines :: Parser ()+ emptyLines = void $ many (try (skipHorizontalSpace *> "\n"))+ parseParagraphs :: String -> Parser (DocH mod Identifier) parseParagraphs input = case parseParasState input of- (state, a) -> setParserState state >> return a+ (state, a) -> Parsec.putState state *> pure a --- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which--- drops leading whitespace and encodes the string to UTF8 first.+-- | Variant of 'parseText' for 'String' instead of 'Text' parseString :: String -> DocH mod Identifier-parseString = parseStringBS . encodeUtf8 . dropWhile isSpace . filter (/= '\r')+parseString = parseText . T.pack -parseStringBS :: BS.ByteString -> DocH mod Identifier-parseStringBS = snd . parse p+-- | Parse a text paragraph. Actually just a wrapper over 'parseParagraph' which+-- drops leading whitespace.+parseText :: Text -> DocH mod Identifier+parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r')++parseParagraph :: Text -> DocH mod Identifier+parseParagraph = snd . parse p where p :: Parser (DocH mod Identifier)- p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName- <|> picture <|> mathDisplay <|> mathInline- <|> markdownImage- <|> hyperlink <|> bold- <|> emphasis <|> encodedChar <|> string'- <|> skipSpecialChar)+ p = docConcat <$> many (choice' [ monospace+ , anchor+ , identifier+ , moduleName+ , picture+ , mathDisplay+ , mathInline+ , markdownImage+ , markdownLink+ , hyperlink+ , bold+ , emphasis+ , encodedChar+ , string'+ , skipSpecialChar+ ]) -- | Parses and processes -- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references>@@ -166,13 +173,13 @@ -- Once we have checked for any of these and tried to parse the -- relevant markup, we can assume they are used as regular text. specialChar :: [Char]-specialChar = "_/<@\"&'`# "+specialChar = "_/<@\"&'`#[ " -- | Plain, regular parser for text. Called as one of the last parsers -- to ensure that we have already given a chance to more meaningful parsers--- before capturing their characers.+-- before capturing their characters. string' :: Parser (DocH mod a)-string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (notInClass specialChar)+string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar) where unescape "" = "" unescape ('\\':x:xs) = x : unescape xs@@ -182,53 +189,53 @@ -- This is done to skip over any special characters belonging to other -- elements but which were not deemed meaningful at their positions. skipSpecialChar :: Parser (DocH mod a)-skipSpecialChar = DocString . return <$> satisfy (inClass specialChar)+skipSpecialChar = DocString . return <$> Parsec.oneOf specialChar -- | Emphasis parser. -- -- >>> parseString "/Hello world/" -- DocEmphasis (DocString "Hello world") emphasis :: Parser (DocH mod Identifier)-emphasis = DocEmphasis . parseStringBS <$>- mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/")+emphasis = DocEmphasis . parseParagraph <$>+ disallowNewline ("/" *> takeWhile1_ (/= '/') <* "/") -- | Bold parser. -- -- >>> parseString "__Hello world__" -- DocBold (DocString "Hello world") bold :: Parser (DocH mod Identifier)-bold = DocBold . parseStringBS <$> disallowNewline ("__" *> takeUntil "__")+bold = DocBold . parseParagraph <$> disallowNewline ("__" *> takeUntil "__") -disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString-disallowNewline = mfilter ('\n' `BS.notElem`)+disallowNewline :: Parser Text -> Parser Text+disallowNewline = mfilter (T.all (/= '\n')) -- | Like `takeWhile`, but unconditionally take escaped characters.-takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString-takeWhile_ p = scan False p_+takeWhile_ :: (Char -> Bool) -> Parser Text+takeWhile_ p = scan p_ False where p_ escaped c | escaped = Just False | not $ p c = Nothing | otherwise = Just (c == '\\') --- | Like `takeWhile1`, but unconditionally take escaped characters.-takeWhile1_ :: (Char -> Bool) -> Parser BS.ByteString-takeWhile1_ = mfilter (not . BS.null) . takeWhile_+-- | Like 'takeWhile1', but unconditionally take escaped characters.+takeWhile1_ :: (Char -> Bool) -> Parser Text+takeWhile1_ = mfilter (not . T.null) . takeWhile_ -- | Text anchors to allow for jumping around the generated documentation. -- -- >>> parseString "#Hello world#" -- DocAName "Hello world" anchor :: Parser (DocH mod a)-anchor = DocAName . decodeUtf8 <$>- disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")+anchor = DocAName . T.unpack <$>+ ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#") -- | Monospaced strings. -- -- >>> parseString "@cruel@" -- DocMonospaced (DocString "cruel") monospace :: Parser (DocH mod Identifier)-monospace = DocMonospaced . parseStringBS+monospace = DocMonospaced . parseParagraph <$> ("@" *> takeWhile1_ (/= '@') <* "@") -- | Module names.@@ -236,15 +243,43 @@ -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a)-moduleName = DocModule <$> (char '"' *> modid <* char '"')+moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"")++-- | A module name, optionally with an anchor+--+moduleNameString :: Parser String+moduleNameString = modid `maybeFollowedBy` anchor_ where- modid = intercalate "." <$> conid `sepBy1` "."+ modid = intercalate "." <$> conid `Parsec.sepBy1` "."+ anchor_ = (++)+ <$> (Parsec.string "#" <|> Parsec.string "\\#")+ <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c)))++ maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf+ conid :: Parser String conid = (:)- <$> satisfyUnicode (\c -> isAlpha c && isUpper c)- <*> many (satisfyUnicode conChar <|> char '\\' <|> char '#')+ <$> Parsec.satisfy (\c -> isAlpha c && isUpper c)+ <*> many conChar - conChar c = isAlphaNum c || c == '_'+ conChar = Parsec.alphaNum <|> Parsec.char '_' +-- | A labeled link to an indentifier, module or url using markdown+-- syntax.+markdownLink :: Parser (DocH mod Identifier)+markdownLink = do+ lbl <- markdownLinkText+ choice' [ markdownModuleName lbl, markdownURL lbl ]+ where+ markdownModuleName lbl = do+ mn <- "(" *> skipHorizontalSpace *>+ "\"" *> moduleNameString <* "\""+ <* skipHorizontalSpace <* ")"+ pure $ DocModule (ModLink mn (Just lbl))++ markdownURL lbl = do+ target <- markdownLinkTarget+ pure $ DocHyperlink $ Hyperlink target (Just lbl)+ -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. --@@ -253,7 +288,7 @@ -- >>> parseString "<<hello.png world>>" -- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"}) picture :: Parser (DocH mod a)-picture = DocPic . makeLabeled Picture . decodeUtf8+picture = DocPic . makeLabeled Picture <$> disallowNewline ("<<" *> takeUntil ">>") -- | Inline math parser, surrounded by \\( and \\).@@ -261,7 +296,7 @@ -- >>> parseString "\\(\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\)" -- DocMathInline "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathInline :: Parser (DocH mod a)-mathInline = DocMathInline . decodeUtf8+mathInline = DocMathInline . T.unpack <$> disallowNewline ("\\(" *> takeUntil "\\)") -- | Display math parser, surrounded by \\[ and \\].@@ -269,30 +304,40 @@ -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]" -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathDisplay :: Parser (DocH mod a)-mathDisplay = DocMathDisplay . decodeUtf8+mathDisplay = DocMathDisplay . T.unpack <$> ("\\[" *> takeUntil "\\]") -markdownImage :: Parser (DocH mod a)-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 ""+-- DocPic (Picture "www.site.com" (Just "some emphasis in a description"))+markdownImage :: Parser (DocH mod Identifier)+markdownImage = do+ text <- markup stringMarkup <$> ("!" *> markdownLinkText)+ url <- markdownLinkTarget+ pure $ DocPic (Picture url (Just text)) where- fromHyperlink (Hyperlink url label) = DocPic (Picture url label)+ stringMarkup = plainMarkup (const "") renderIdent+ renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier)-paragraph = examples <|> table <|> do- indent <- takeIndent- choice- [ since- , unorderedList indent- , orderedList indent- , birdtracks- , codeblock- , property- , header- , textParagraphThatStartsWithMarkdownLink- , definitionList indent- , docParagraph <$> textParagraph- ]+paragraph = choice' [ examples+ , table+ , do indent <- takeIndent+ choice' [ since+ , unorderedList indent+ , orderedList indent+ , birdtracks+ , codeblock+ , property+ , header+ , textParagraphThatStartsWithMarkdownLink+ , definitionList indent+ , docParagraph <$> textParagraph+ ]+ ] -- | Provides support for grid tables. --@@ -314,45 +359,47 @@ table = do -- first we parse the first row, which determines the width of the table firstRow <- parseFirstRow- let len = BS.length firstRow+ let len = T.length firstRow - -- then we parse all consequtive rows starting and ending with + or |,+ -- then we parse all consecutive rows starting and ending with + or |, -- of the width `len`.- restRows <- many (parseRestRows len)+ restRows <- many (try (parseRestRows len)) -- Now we gathered the table block, the next step is to split the block -- into cells. DocTable <$> tableStepTwo len (firstRow : restRows) where- parseFirstRow :: Parser BS.ByteString+ parseFirstRow :: Parser Text parseFirstRow = do skipHorizontalSpace- -- upper-left corner is +- c <- char '+'- cs <- many1 (char '-' <|> char '+')+ 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- _ <- char '\n'+ _ <- Parsec.newline - return (BS.cons c $ BS.pack cs)+ return cs - parseRestRows :: Int -> Parser BS.ByteString+ parseRestRows :: Int -> Parser Text parseRestRows l = do skipHorizontalSpace+ bs <- scan predicate l - c <- char '|' <|> char '+'- bs <- scan (l - 2) predicate- c2 <- char '|' <|> 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- _ <- char '\n'+ _ <- Parsec.newline - return (BS.cons c (BS.snoc bs c2))+ return bs where predicate n c | n <= 0 = Nothing@@ -363,22 +410,22 @@ -- and changes to '=' to '-'. tableStepTwo :: Int -- ^ width- -> [BS.ByteString] -- ^ rows+ -> [Text] -- ^ rows -> Parser (Table (DocH mod Identifier)) tableStepTwo width = go 0 [] where go _ left [] = tableStepThree width (reverse left) Nothing go n left (r : rs)- | BS.all (`elem` ['+', '=']) r =+ | T.all (`elem` ['+', '=']) r = tableStepThree width (reverse left ++ r' : rs) (Just n) | otherwise = go (n + 1) (r : left) rs where- r' = BS.map (\c -> if c == '=' then '-' else c) r+ r' = T.map (\c -> if c == '=' then '-' else c) r -- Third step recognises cells in the table area, returning a list of TC, cells. tableStepThree :: Int -- ^ width- -> [BS.ByteString] -- ^ rows+ -> [Text] -- ^ rows -> Maybe Int -- ^ index of header separator -> Parser (Table (DocH mod Identifier)) tableStepThree width rs hdrIndex = do@@ -405,32 +452,32 @@ scanRight :: Int -> Int -> Maybe (Int, Int) scanRight x y = go (x + 1) where bs = rs !! y- go x' | x' >= width = fail "overflow right "- | BS.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)- | BS.index bs x' == '-' = go (x' + 1)- | otherwise = fail $ "not a border (right) " ++ show (x,y,x')+ go x' | x' >= width = fail "overflow right "+ | T.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)+ | T.index bs x' == '-' = go (x' + 1)+ | otherwise = fail $ "not a border (right) " ++ show (x,y,x') -- scan down looking for + scanDown :: Int -> Int -> Int -> Maybe (Int, Int) scanDown x y x2 = go (y + 1) where- go y' | y' >= height = fail "overflow down"- | BS.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)- | BS.index (rs !! y') x2 == '|' = go (y' + 1)- | otherwise = fail $ "not a border (down) " ++ show (x,y,x2,y')+ go y' | y' >= height = fail "overflow down"+ | T.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)+ | T.index (rs !! y') x2 == '|' = go (y' + 1)+ | otherwise = fail $ "not a border (down) " ++ show (x,y,x2,y') -- check that at y2 x..x2 characters are '+' or '-' scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int) scanLeft x y x2 y2- | all (\x' -> BS.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2- | otherwise = fail $ "not a border (left) " ++ show (x,y,x2,y2)+ | all (\x' -> T.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2+ | otherwise = fail $ "not a border (left) " ++ show (x,y,x2,y2) where bs = rs !! y2 -- check that at y2 x..x2 characters are '+' or '-' scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int) scanUp x y x2 y2- | all (\y' -> BS.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2)- | otherwise = fail $ "not a border (up) " ++ show (x,y,x2,y2)+ | all (\y' -> T.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2)+ | otherwise = fail $ "not a border (up) " ++ show (x,y,x2,y2) -- | table cell: top left bottom right data TC = TC !Int !Int !Int !Int@@ -443,7 +490,7 @@ tcYS (TC y _ y2 _) = [y, y2] -- | Fourth step. Given the locations of cells, forms 'Table' structure.-tableStepFour :: [BS.ByteString] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier))+tableStepFour :: [Text] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier)) tableStepFour rs hdrIndex cells = case hdrIndex of Nothing -> return $ Table [] rowsDoc Just i -> case elemIndex i yTabStops of@@ -461,7 +508,7 @@ init' [_] = [] init' (x : xs) = x : init' xs - rowsDoc = (fmap . fmap) parseStringBS rows+ rowsDoc = (fmap . fmap) parseParagraph rows rows = map makeRow (init' yTabStops) where@@ -474,9 +521,9 @@ yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops -- extract cell contents given boundaries- extract :: Int -> Int -> Int -> Int -> BS.ByteString- extract x y x2 y2 = BS.intercalate "\n"- [ BS.take (x2 - x + 1) $ BS.drop x $ rs !! y'+ extract :: Int -> Int -> Int -> Int -> Text+ extract x y x2 y2 = T.intercalate "\n"+ [ T.stripEnd $ T.stripStart $ T.take (x2 - x + 1) $ T.drop x $ rs !! y' | y' <- [y .. y2] ] @@ -484,7 +531,7 @@ since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty where- version = decimal `sepBy1'` "."+ version = decimal `Parsec.sepBy1` "." -- | Headers inside the comment denoted with @=@ signs, up to 6 levels -- deep.@@ -495,147 +542,168 @@ -- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"})) header :: Parser (DocH mod Identifier) header = do- let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1]- pser = foldl1 (<|>) psers- delim <- decodeUtf8 <$> pser- line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString- rest <- paragraph <|> return DocEmpty- return $ DocHeader (Header (length delim) line) `docAppend` rest+ let psers = map (string . flip T.replicate "=") [6, 5 .. 1]+ pser = Parsec.choice psers+ depth <- T.length <$> pser+ line <- parseText <$> (skipHorizontalSpace *> nonEmptyLine)+ rest <- try paragraph <|> return DocEmpty+ return $ DocHeader (Header depth line) `docAppend` rest textParagraph :: Parser (DocH mod Identifier)-textParagraph = parseString . intercalate "\n" <$> many1 nonEmptyLine+textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine textParagraphThatStartsWithMarkdownLink :: Parser (DocH mod Identifier) textParagraphThatStartsWithMarkdownLink = docParagraph <$> (docAppend <$> markdownLink <*> optionalTextParagraph) where optionalTextParagraph :: Parser (DocH mod Identifier)- optionalTextParagraph = (docAppend <$> whitespace <*> textParagraph) <|> pure DocEmpty+ optionalTextParagraph = choice' [ docAppend <$> whitespace <*> textParagraph+ , pure DocEmpty ] whitespace :: Parser (DocH mod a) whitespace = DocString <$> (f <$> takeHorizontalSpace <*> optional "\n") where- f :: BS.ByteString -> Maybe BS.ByteString -> String+ f :: Text -> Maybe Text -> String f xs (fromMaybe "" -> x)- | BS.null (xs <> x) = ""+ | T.null (xs <> x) = "" | otherwise = " " -- | Parses unordered (bullet) lists.-unorderedList :: BS.ByteString -> Parser (DocH mod Identifier)+unorderedList :: Text -> Parser (DocH mod Identifier) unorderedList indent = DocUnorderedList <$> p where p = ("*" <|> "-") *> innerList indent p -- | Parses ordered lists (numbered or dashed).-orderedList :: BS.ByteString -> Parser (DocH mod Identifier)+orderedList :: Text -> Parser (DocH mod Identifier) orderedList indent = DocOrderedList <$> p where- p = (paren <|> dot) *> innerList indent p+ p = do+ index <- paren <|> dot+ innerList' indent p index dot = (decimal :: Parser Int) <* "." paren = "(" *> decimal <* ")" +-- | Like 'innerList' but takes the parsed index of the list item+innerList' :: Text -> Parser [(Int, DocH mod Identifier)]+ -> Int+ -> Parser [(Int, DocH mod Identifier)]+innerList' indent item index = do+ c <- takeLine+ (cs, items) <- more indent item+ let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs+ return $ case items of+ Left p -> [(index, contents `docAppend` p)]+ Right i -> (index, contents) : i+ -- | Generic function collecting any further lines belonging to the -- list entry and recursively collecting any further lists in the -- same paragraph. Usually used as -- -- > someListFunction = listBeginning *> innerList someListFunction-innerList :: BS.ByteString -> Parser [DocH mod Identifier]+innerList :: Text -> Parser [DocH mod Identifier] -> Parser [DocH mod Identifier] innerList indent item = do c <- takeLine (cs, items) <- more indent item- let contents = docParagraph . parseString . dropNLs . unlines $ c : cs+ let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs return $ case items of Left p -> [contents `docAppend` p] Right i -> contents : i -- | Parses definition lists.-definitionList :: BS.ByteString -> Parser (DocH mod Identifier)+definitionList :: Text -> Parser (DocH mod Identifier) definitionList indent = DocDefList <$> p where p = do- label <- "[" *> (parseStringBS <$> takeWhile1_ (notInClass "]\n")) <* ("]" <* optional ":")+ label <- "[" *> (parseParagraph <$> takeWhile1_ (`notElem` ("]\n" :: String))) <* ("]" <* optional ":") c <- takeLine (cs, items) <- more indent p- let contents = parseString . dropNLs . unlines $ c : cs+ let contents = parseText . dropNLs . T.unlines $ c : cs return $ case items of Left x -> [(label, contents `docAppend` x)] Right i -> (label, contents) : i -- | Drops all trailing newlines.-dropNLs :: String -> String-dropNLs = reverse . dropWhile (== '\n') . reverse+dropNLs :: Text -> Text+dropNLs = T.dropWhileEnd (== '\n') -- | Main worker for 'innerList' and 'definitionList'. -- We need the 'Either' here to be able to tell in the respective functions -- whether we're dealing with the next list or a nested paragraph.-more :: Monoid a => BS.ByteString -> Parser a- -> Parser ([String], Either (DocH mod Identifier) a)-more indent item = innerParagraphs indent- <|> moreListItems indent item- <|> moreContent indent item- <|> pure ([], Right mempty)+more :: Monoid a => Text -> Parser a+ -> Parser ([Text], Either (DocH mod Identifier) a)+more indent item = choice' [ innerParagraphs indent+ , moreListItems indent item+ , moreContent indent item+ , pure ([], Right mempty)+ ] -- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs.-innerParagraphs :: BS.ByteString- -> Parser ([String], Either (DocH mod Identifier) a)+innerParagraphs :: Text+ -> Parser ([Text], Either (DocH mod Identifier) a) innerParagraphs indent = (,) [] . Left <$> ("\n" *> indentedParagraphs indent) -- | Attempts to fetch the next list if possibly. Used by 'innerList' and -- 'definitionList' to recursively grab lists that aren't separated by a whole -- paragraph.-moreListItems :: BS.ByteString -> Parser a- -> Parser ([String], Either (DocH mod Identifier) a)+moreListItems :: Text -> Parser a+ -> Parser ([Text], Either (DocH mod Identifier) a) moreListItems indent item = (,) [] . Right <$> indentedItem where- indentedItem = string indent *> skipSpace *> item+ indentedItem = string indent *> Parsec.spaces *> item -- | Helper for 'innerList' and 'definitionList' which simply takes -- a line of text and attempts to parse more list content with 'more'.-moreContent :: Monoid a => BS.ByteString -> Parser a- -> Parser ([String], Either (DocH mod Identifier) a)+moreContent :: Monoid a => Text -> Parser a+ -> Parser ([Text], Either (DocH mod Identifier) a) moreContent indent item = first . (:) <$> nonEmptyLine <*> more indent item -- | Parses an indented paragraph. -- The indentation is 4 spaces.-indentedParagraphs :: BS.ByteString -> Parser (DocH mod Identifier)+indentedParagraphs :: Text -> Parser (DocH mod Identifier) indentedParagraphs indent =- (concat <$> dropFrontOfPara indent') >>= parseParagraphs+ (T.unpack . T.concat <$> dropFrontOfPara indent') >>= parseParagraphs where- indent' = string $ BS.append indent " "+ indent' = string $ indent <> " " -- | Grab as many fully indented paragraphs as we can.-dropFrontOfPara :: Parser BS.ByteString -> Parser [String]+dropFrontOfPara :: Parser Text -> Parser [Text] dropFrontOfPara sp = do- currentParagraph <- some (sp *> takeNonEmptyLine)+ currentParagraph <- some (try (sp *> takeNonEmptyLine)) followingParagraphs <-- skipHorizontalSpace *> nextPar -- we have more paragraphs to take- <|> skipHorizontalSpace *> nlList -- end of the ride, remember the newline- <|> endOfInput *> return [] -- nothing more to take at all+ choice' [ skipHorizontalSpace *> nextPar -- we have more paragraphs to take+ , skipHorizontalSpace *> nlList -- end of the ride, remember the newline+ , Parsec.eof *> return [] -- nothing more to take at all+ ] return (currentParagraph ++ followingParagraphs) where nextPar = (++) <$> nlList <*> dropFrontOfPara sp nlList = "\n" *> return ["\n"] -nonSpace :: BS.ByteString -> Parser BS.ByteString+nonSpace :: Text -> Parser Text nonSpace xs- | not $ any (not . isSpace) $ decodeUtf8 xs = fail "empty line"+ | T.all isSpace xs = fail "empty line" | otherwise = return xs -- | Takes a non-empty, not fully whitespace line. -- -- Doesn't discard the trailing newline.-takeNonEmptyLine :: Parser String+takeNonEmptyLine :: Parser Text takeNonEmptyLine = do- (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n"+ l <- takeWhile1 (/= '\n') >>= nonSpace+ _ <- "\n"+ pure (l <> "\n") -- | Takes indentation of first non-empty line. -- -- More precisely: skips all whitespace-only lines and returns indentation -- (horizontal space, might be empty) of that non-empty line.-takeIndent :: Parser BS.ByteString+takeIndent :: Parser Text takeIndent = do indent <- takeHorizontalSpace- "\n" *> takeIndent <|> return indent+ choice' [ "\n" *> takeIndent+ , return indent+ ] -- | Blocks of text of the form: --@@ -644,118 +712,120 @@ -- >> baz -- birdtracks :: Parser (DocH mod a)-birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line+birdtracks = DocCodeBlock . DocString . T.unpack . T.intercalate "\n" . stripSpace <$> some line where- line = skipHorizontalSpace *> ">" *> takeLine+ line = try (skipHorizontalSpace *> ">" *> takeLine) -stripSpace :: [String] -> [String]+stripSpace :: [Text] -> [Text] stripSpace = fromMaybe <*> mapM strip' where- strip' (' ':xs') = Just xs'- strip' "" = Just ""- strip' _ = Nothing+ strip' t = case T.uncons t of+ Nothing -> Just ""+ Just (' ',t') -> Just t'+ _ -> Nothing --- | Parses examples. Examples are a paragraph level entitity (separated by an empty line).+-- | Parses examples. Examples are a paragraph level entity (separated by an empty line). -- Consecutive examples are accepted. examples :: Parser (DocH mod a)-examples = DocExamples <$> (many (skipHorizontalSpace *> "\n") *> go)+examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go) where go :: Parser [Example] go = do- prefix <- decodeUtf8 <$> takeHorizontalSpace <* ">>>"+ prefix <- takeHorizontalSpace <* ">>>" expr <- takeLine (rs, es) <- resultAndMoreExamples return (makeExample prefix expr rs : es) where- resultAndMoreExamples :: Parser ([String], [Example])- resultAndMoreExamples = moreExamples <|> result <|> pure ([], [])+ resultAndMoreExamples :: Parser ([Text], [Example])+ resultAndMoreExamples = choice' [ moreExamples, result, pure ([], []) ] where- moreExamples :: Parser ([String], [Example])+ moreExamples :: Parser ([Text], [Example]) moreExamples = (,) [] <$> go - result :: Parser ([String], [Example])+ result :: Parser ([Text], [Example]) result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples - makeExample :: String -> String -> [String] -> Example+ makeExample :: Text -> Text -> [Text] -> Example makeExample prefix expression res =- Example (strip expression) result+ Example (T.unpack (T.strip expression)) result where- result = map (substituteBlankLine . tryStripPrefix) res+ result = map (T.unpack . substituteBlankLine . tryStripPrefix) res - tryStripPrefix xs = fromMaybe xs (stripPrefix prefix xs)+ tryStripPrefix xs = fromMaybe xs (T.stripPrefix prefix xs) substituteBlankLine "<BLANKLINE>" = "" substituteBlankLine xs = xs -nonEmptyLine :: Parser String-nonEmptyLine = mfilter (any (not . isSpace)) takeLine+nonEmptyLine :: Parser Text+nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine) -takeLine :: Parser String-takeLine = decodeUtf8 <$> takeWhile (/= '\n') <* endOfLine+takeLine :: Parser Text+takeLine = try (takeWhile (/= '\n') <* endOfLine) endOfLine :: Parser ()-endOfLine = void "\n" <|> endOfInput+endOfLine = void "\n" <|> Parsec.eof -- | Property parser. -- -- >>> snd <$> parseOnly property "prop> hello world" -- Right (DocProperty "hello world") property :: Parser (DocH mod a)-property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n'))+property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (/= '\n')) -- | -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed -- for markup. codeblock :: Parser (DocH mod Identifier) codeblock =- DocCodeBlock . parseStringBS . dropSpaces+ DocCodeBlock . parseParagraph . dropSpaces <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where dropSpaces xs =- let rs = decodeUtf8 xs- in case splitByNl rs of+ case splitByNl xs of [] -> xs- ys -> case last ys of- ' ':_ -> case mapM dropSpace ys of- Nothing -> xs- Just zs -> encodeUtf8 $ intercalate "\n" zs+ ys -> case T.uncons (last ys) of+ Just (' ',_) -> case mapM dropSpace ys of+ Nothing -> xs+ Just zs -> T.intercalate "\n" zs _ -> xs -- This is necessary because ‘lines’ swallows up a trailing newline -- and we lose information about whether the last line belongs to @ or to -- text which we need to decide whether we actually want to be dropping -- anything at all.- splitByNl = unfoldr (\x -> case x of- '\n':s -> Just (span (/= '\n') s)- _ -> Nothing)- . ('\n' :)+ splitByNl = unfoldr (\x -> case T.uncons x of+ Just ('\n',x') -> Just (T.span (/= '\n') x')+ _ -> Nothing)+ . ("\n" <>) - dropSpace "" = Just ""- dropSpace (' ':xs) = Just xs- dropSpace _ = Nothing+ dropSpace t = case T.uncons t of+ Nothing -> Just ""+ Just (' ',t') -> Just t'+ _ -> Nothing - block' = scan False p+ block' = scan p False where p isNewline c | isNewline && c == '@' = Nothing | isNewline && isSpace c = Just isNewline | otherwise = Just $ c == '\n' -hyperlink :: Parser (DocH mod a)-hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8- <$> disallowNewline ("<" *> takeUntil ">")- <|> autoUrl- <|> markdownLink+hyperlink :: Parser (DocH mod Identifier)+hyperlink = choice' [ angleBracketLink, autoUrl ] -markdownLink :: Parser (DocH mod a)-markdownLink = DocHyperlink <$> linkParser+angleBracketLink :: Parser (DocH mod a)+angleBracketLink =+ DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)+ <$> disallowNewline ("<" *> takeUntil ">") -linkParser :: Parser Hyperlink-linkParser = flip Hyperlink <$> label <*> (whitespace *> url)- where- label :: Parser (Maybe String)- label = Just . strip . decode <$> ("[" *> takeUntil "]")+-- | The text for a markdown link, enclosed in square brackets.+markdownLinkText :: Parser (DocH mod Identifier)+markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]") +-- | The target for a markdown link, enclosed in parenthesis.+markdownLinkTarget :: Parser String+markdownLinkTarget = whitespace *> url+ where whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) @@ -765,43 +835,25 @@ rejectWhitespace :: MonadPlus m => m String -> m String rejectWhitespace = mfilter (all (not . isSpace)) - decode :: BS.ByteString -> String- decode = removeEscapes . decodeUtf8+ decode :: Text -> String+ decode = T.unpack . removeEscapes -- | Looks for URL-like things to automatically hyperlink even if they -- weren't marked as links. autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url where- url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace)- mkLink :: BS.ByteString -> DocH mod a- mkLink s = case unsnoc s of- Just (xs, x) | inClass ",.!?" x -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x]- _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing)+ url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (not . isSpace) --- | 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 = satisfyUnicode (\c -> isAlphaNum c || isSymbolChar c || c == '_')+ 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) - p p' = do- vs <- p' idChar- c <- peekChar'- case c of- '`' -> return vs- '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> p many') <|> return vs- _ -> fail "outofvalid"+ mkHyperlink :: Text -> Hyperlink (DocH mod a)+ mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing --- | 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 = satisfy (\c -> c == '\'' || c == '`')+identifier = DocIdentifier <$> parseValid
+ src/Documentation/Haddock/Parser/Identifier.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module : Documentation.Haddock.Parser.Identifier+-- Copyright : (c) Alec Theriault 2019,+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Functionality for parsing identifiers and operators++module Documentation.Haddock.Parser.Identifier (+ Identifier(..),+ parseValid,+) where++import Documentation.Haddock.Types ( Namespace(..) )+import Documentation.Haddock.Parser.Monad+import qualified Text.Parsec as Parsec+import Text.Parsec.Pos ( updatePosChar )+import Text.Parsec ( State(..)+ , getParserState, setParserState )++import Data.Text (Text)+import qualified Data.Text as T++import Data.Char (isAlpha, isAlphaNum)+import Control.Monad (guard)+import Data.Maybe+import CompatPrelude++-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks.+data Identifier = Identifier !Namespace !Char String !Char+ deriving (Show, Eq)++parseValid :: Parser Identifier+parseValid = do+ s@State{ stateInput = inp, statePos = pos } <- getParserState++ case takeIdentifier inp of+ Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier"+ Just (ns, op, ident, cl, inp') ->+ let posOp = updatePosChar pos op+ posIdent = T.foldl updatePosChar posOp ident+ posCl = updatePosChar posIdent cl+ s' = s{ stateInput = inp', statePos = posCl }+ in setParserState s' $> Identifier ns op (T.unpack ident) cl+++-- | Try to parse a delimited identifier off the front of the given input.+--+-- This tries to match as many valid Haskell identifiers/operators as possible,+-- to the point of sometimes accepting invalid things (ex: keywords). Some+-- considerations:+--+-- - operators and identifiers can have module qualifications+-- - operators can be wrapped in parens (for prefix)+-- - identifiers can be wrapped in backticks (for infix)+-- - delimiters are backticks or regular ticks+-- - since regular ticks are also valid in identifiers, we opt for the+-- longest successful parse+--+-- This function should make /O(1)/ allocations+takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text)+takeIdentifier input = listToMaybe $ do++ -- Optional namespace+ let (ns, input') = case T.uncons input of+ Just ('v', i) -> (Value, i)+ Just ('t', i) -> (Type, i)+ _ -> (None, input)++ -- Opening tick+ (op, input'') <- maybeToList (T.uncons input')+ guard (op == '\'' || op == '`')++ -- Identifier/operator+ (ident, input''') <- wrapped input''++ -- Closing tick+ (cl, input'''') <- maybeToList (T.uncons input''')+ guard (cl == '\'' || cl == '`')++ return (ns, op, ident, cl, input'''')++ where++ -- | Parse out a wrapped, possibly qualified, operator or identifier+ wrapped t = do+ (c, t' ) <- maybeToList (T.uncons t)+ -- Tuples+ case c of+ '(' | Just (c', _) <- T.uncons t'+ , c' == ',' || c' == ')'+ -> do let (commas, t'') = T.span (== ',') t'+ (')', t''') <- maybeToList (T.uncons t'')+ return (T.take (T.length commas + 2) t, t''')++ -- Parenthesized+ '(' -> do (n, t'' ) <- general False 0 [] t'+ (')', t''') <- maybeToList (T.uncons t'')+ return (T.take (n + 2) t, t''')++ -- Backticked+ '`' -> do (n, t'' ) <- general False 0 [] t'+ ('`', t''') <- maybeToList (T.uncons t'')+ return (T.take (n + 2) t, t''')++ -- Unadorned+ _ -> do (n, t'' ) <- general False 0 [] t+ return (T.take n t, t'')++ -- | Parse out a possibly qualified operator or identifier+ general :: Bool -- ^ refuse inputs starting with operators+ -> Int -- ^ total characters \"consumed\" so far+ -> [(Int, Text)] -- ^ accumulated results+ -> Text -- ^ current input+ -> [(Int, Text)] -- ^ total characters parsed & what remains+ general !identOnly !i acc t+ -- Starts with an identifier (either just an identifier, or a module qual)+ | Just (n, rest) <- identLike t+ = if T.null rest+ then acc+ else case T.head rest of+ '`' -> (n + i, rest) : acc+ ')' -> (n + i, rest) : acc+ '.' -> general False (n + i + 1) acc (T.tail rest)+ '\'' -> let (m, rest') = quotes rest+ in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest')+ _ -> acc++ -- An operator+ | Just (n, rest) <- optr t+ , not identOnly+ = (n + i, rest) : acc++ -- Anything else+ | otherwise+ = acc++ -- | Parse an identifier off the front of the input+ identLike t+ | T.null t = Nothing+ | isAlpha (T.head t) || '_' == T.head t+ = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t+ !(octos, rest') = T.span (== '#') rest+ in Just (T.length idt + T.length octos, rest')+ | otherwise = Nothing++ -- | Parse all but the last quote off the front of the input+ -- PRECONDITION: T.head t `elem` ['\'', '`']+ quotes :: Text -> (Int, Text)+ quotes t = let !n = T.length (T.takeWhile (`elem` ['\'', '`']) t) - 1+ in (n, T.drop n t)++ -- | Parse an operator off the front of the input+ optr t = let !(op, rest) = T.span isSymbolChar t+ in if T.null op then Nothing else Just (T.length op, rest)
src/Documentation/Haddock/Parser/Monad.hs view
@@ -1,49 +1,47 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}-module Documentation.Haddock.Parser.Monad (- module Documentation.Haddock.Parser.Monad-, Attoparsec.isDigit-, Attoparsec.isDigit_w8-, Attoparsec.isAlpha_iso8859_15-, Attoparsec.isAlpha_ascii-, Attoparsec.isSpace-, Attoparsec.isSpace_w8-, Attoparsec.inClass-, Attoparsec.notInClass-, Attoparsec.isEndOfLine-, Attoparsec.isHorizontalSpace-, Attoparsec.choice-, Attoparsec.count-, Attoparsec.option-, Attoparsec.many'-, Attoparsec.many1-, Attoparsec.many1'-, Attoparsec.manyTill-, Attoparsec.manyTill'-, Attoparsec.sepBy-, Attoparsec.sepBy'-, Attoparsec.sepBy1-, Attoparsec.sepBy1'-, Attoparsec.skipMany-, Attoparsec.skipMany1-, Attoparsec.eitherP-) where+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BangPatterns #-}+-- |+-- 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'). -import Control.Applicative-import Control.Monad-import Data.String-import Data.ByteString (ByteString, length)-import qualified Data.ByteString.Lazy as LB-import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec-import qualified Data.Attoparsec.Combinator as Attoparsec-import Control.Monad.Trans.State-import qualified Control.Monad.Trans.Class as Trans-import Data.Word-import Data.Bits-import Data.Tuple+module Documentation.Haddock.Parser.Monad where -import Documentation.Haddock.Types (Version)-import Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8)+import qualified Text.Parsec.Char as Parsec+import qualified Text.Parsec as Parsec+import Text.Parsec.Pos ( updatePosChar )+import Text.Parsec ( State(..)+ , getParserState, setParserState ) +import qualified Data.Text as T+import Data.Text ( Text )++import Control.Monad ( mfilter )+import Data.String ( IsString(..) )+import Data.Bits ( Bits(..) )+import Data.Char ( ord )+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 trudging along with us+-- through parsing is the version attached to a @\@since@ annotation - if+-- the doc even contained one. newtype ParserState = ParserState { parserStateSince :: Maybe Version } deriving (Eq, Show)@@ -51,120 +49,101 @@ initialParserState :: ParserState initialParserState = ParserState Nothing -newtype Parser a = Parser (StateT ParserState Attoparsec.Parser a)- deriving (Functor, Applicative, Alternative, Monad, MonadPlus)--instance (a ~ ByteString) => IsString (Parser a) where- fromString = lift . fromString--parseOnly :: Parser a -> ByteString -> Either String (ParserState, a)-parseOnly (Parser p) = fmap swap . Attoparsec.parseOnly (runStateT p initialParserState)--lift :: Attoparsec.Parser a -> Parser a-lift = Parser . Trans.lift--setParserState :: ParserState -> Parser ()-setParserState = Parser . put- setSince :: Version -> Parser ()-setSince since = Parser $ modify (\st -> st {parserStateSince = Just since})--char :: Char -> Parser Char-char = lift . Attoparsec.char--char8 :: Char -> Parser Word8-char8 = lift . Attoparsec.char8---- | Peek a unicode character and return the number of bytes that it took up-peekUnicode :: Parser (Char, Int)-peekUnicode = lift $ Attoparsec.lookAhead $ do- - -- attoparsec's take fails on shorter inputs rather than truncate- bs <- Attoparsec.choice (map Attoparsec.take [4,3,2,1])- - let c = head . decodeUtf8 $ bs- n = Data.ByteString.length . encodeUtf8 $ [c]- pure (c, fromIntegral n)---- | Like 'satisfy', but consuming a unicode character-satisfyUnicode :: (Char -> Bool) -> Parser Char-satisfyUnicode predicate = do- (c,n) <- peekUnicode- if predicate c- then Documentation.Haddock.Parser.Monad.take n *> pure c- else fail "satsifyUnicode"+setSince since = Parsec.modifyState (\st -> st{ parserStateSince = Just since }) -anyChar :: Parser Char-anyChar = lift Attoparsec.anyChar+type Parser = Parsec.Parsec Text ParserState -notChar :: Char -> Parser Char-notChar = lift . Attoparsec.notChar+instance (a ~ Text) => IsString (Parser a) where+ fromString = fmap T.pack . Parsec.string -satisfy :: (Char -> Bool) -> Parser Char-satisfy = lift . Attoparsec.satisfy+parseOnly :: Parser a -> Text -> Either String (ParserState, a)+parseOnly p t = case Parsec.runParser p' initialParserState "<haddock>" t of+ Left e -> Left (show e)+ Right (x,s) -> Right (s,x)+ where p' = (,) <$> p <*> Parsec.getState +-- | Always succeeds, but returns 'Nothing' if at the end of input. Does not+-- consume input.+--+-- Equivalent to @Parsec.optionMaybe . Parsec.lookAhead $ Parsec.anyChar@, but+-- more efficient. peekChar :: Parser (Maybe Char)-peekChar = lift Attoparsec.peekChar+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' = lift Attoparsec.peekChar'+peekChar' = headFail . stateInput =<< getParserState+ where headFail t | T.null t = Parsec.parserFail "peekChar': reached EOF"+ | otherwise = App.pure (T.head t)+{-# INLINE peekChar' #-} -digit :: Parser Char-digit = lift Attoparsec.digit+-- | 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 = 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 -letter_iso8859_15 :: Parser Char-letter_iso8859_15 = lift Attoparsec.letter_iso8859_15+-- | 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 -letter_ascii :: Parser Char-letter_ascii = lift Attoparsec.letter_ascii+-- | 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 -space :: Parser Char-space = lift Attoparsec.space+-- | 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 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 -string :: ByteString -> Parser ByteString-string = lift . Attoparsec.string -stringCI :: ByteString -> Parser ByteString-stringCI = lift . Attoparsec.stringCI--skipSpace :: Parser ()-skipSpace = lift Attoparsec.skipSpace--skipWhile :: (Char -> Bool) -> Parser ()-skipWhile = lift . Attoparsec.skipWhile--take :: Int -> Parser ByteString-take = lift . Attoparsec.take--scan :: s -> (s -> Char -> Maybe s) -> Parser ByteString-scan s = lift . Attoparsec.scan s--takeWhile :: (Char -> Bool) -> Parser ByteString-takeWhile = lift . Attoparsec.takeWhile--takeWhile1 :: (Char -> Bool) -> Parser ByteString-takeWhile1 = lift . Attoparsec.takeWhile1--takeTill :: (Char -> Bool) -> Parser ByteString-takeTill = lift . Attoparsec.takeTill--takeByteString :: Parser ByteString-takeByteString = lift Attoparsec.takeByteString--takeLazyByteString :: Parser LB.ByteString-takeLazyByteString = lift Attoparsec.takeLazyByteString--endOfLine :: Parser ()-endOfLine = lift Attoparsec.endOfLine-+-- | Parse a decimal number. decimal :: Integral a => Parser a-decimal = lift Attoparsec.decimal+decimal = foldl' step 0 `fmap` Parsec.many1 Parsec.digit+ where step a c = a * 10 + fromIntegral (ord c - 48) +-- | Parse a hexadecimal number. hexadecimal :: (Integral a, Bits a) => Parser a-hexadecimal = lift Attoparsec.hexadecimal--endOfInput :: Parser ()-endOfInput = lift Attoparsec.endOfInput--atEnd :: Parser Bool-atEnd = lift Attoparsec.atEnd+hexadecimal = foldl' step 0 `fmap` Parsec.many1 Parsec.hexDigit + where+ step a c | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48)+ | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87)+ | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55)+ where w = ord c
src/Documentation/Haddock/Parser/Util.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Documentation.Haddock.Parser.Util -- Copyright : (c) Mateusz Kowalczyk 2013-2014,@@ -11,62 +11,59 @@ -- -- Various utility functions used by the parser. module Documentation.Haddock.Parser.Util (- unsnoc-, strip-, takeUntil-, removeEscapes-, makeLabeled-, takeHorizontalSpace-, skipHorizontalSpace+ takeUntil,+ removeEscapes,+ makeLabeled,+ takeHorizontalSpace,+ skipHorizontalSpace, ) where +import qualified Text.Parsec as Parsec++import qualified Data.Text as T+import Data.Text (Text)+ import Control.Applicative import Control.Monad (mfilter)-import Documentation.Haddock.Parser.Monad hiding (isHorizontalSpace)-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS+import Documentation.Haddock.Parser.Monad import Prelude hiding (takeWhile) -#if MIN_VERSION_bytestring(0,10,2)-import Data.ByteString.Char8 (unsnoc)-#else-unsnoc :: ByteString -> Maybe (ByteString, Char)-unsnoc bs- | BS.null bs = Nothing- | otherwise = Just (BS.init bs, BS.last bs)-#endif---- | Remove all leading and trailing whitespace-strip :: String -> String-strip = (\f -> f . f) $ dropWhile isSpace . reverse+import Data.Char (isSpace) -isHorizontalSpace :: Char -> Bool-isHorizontalSpace = inClass " \t\f\v\r"+-- | Characters that count as horizontal space+horizontalSpace :: Char -> Bool+horizontalSpace c = isSpace c && c /= '\n' +-- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser ()-skipHorizontalSpace = skipWhile isHorizontalSpace+skipHorizontalSpace = Parsec.skipMany (Parsec.satisfy horizontalSpace) -takeHorizontalSpace :: Parser BS.ByteString-takeHorizontalSpace = takeWhile isHorizontalSpace+-- | Take leading horizontal space+takeHorizontalSpace :: Parser Text+takeHorizontalSpace = takeWhile horizontalSpace -makeLabeled :: (String -> Maybe String -> a) -> String -> a-makeLabeled f input = case break isSpace $ removeEscapes $ strip input of- (uri, "") -> f uri Nothing- (uri, label) -> f uri (Just $ dropWhile isSpace label)+makeLabeled :: (String -> Maybe String -> a) -> Text -> a+makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of+ (uri, "") -> f (T.unpack uri) Nothing+ (uri, label) -> f (T.unpack uri) (Just . T.unpack $ T.stripStart label) -- | Remove escapes from given string. -- -- Only do this if you do not process (read: parse) the input any further.-removeEscapes :: String -> String-removeEscapes "" = ""-removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs-removeEscapes ('\\':xs) = removeEscapes xs-removeEscapes (x:xs) = x : removeEscapes xs+removeEscapes :: Text -> Text+removeEscapes = T.unfoldr go+ where+ go :: Text -> Maybe (Char, Text)+ go xs = case T.uncons xs of+ Just ('\\',ys) -> T.uncons ys+ unconsed -> unconsed -takeUntil :: ByteString -> Parser ByteString-takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome+-- | Consume characters from the input up to and including the given pattern.+-- Return everything consumed except for the end pattern itself.+takeUntil :: Text -> Parser Text+takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome where- end = BS.unpack end_+ end = T.unpack end_ p :: (Bool, String) -> Char -> Maybe (Bool, String) p acc c = case acc of@@ -75,9 +72,8 @@ (_, x:xs) | x == c -> Just (False, xs) _ -> Just (c == '\\', end) - dropEnd = BS.reverse . BS.drop (length end) . BS.reverse- requireEnd = mfilter (BS.isSuffixOf end_)+ requireEnd = mfilter (T.isSuffixOf end_) gotSome xs- | BS.null xs = fail "didn't get any content"+ | T.null xs = fail "didn't get any content" | otherwise = return xs
src/Documentation/Haddock/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE CPP, DeriveTraversable #-} -- | -- Module : Documentation.Haddock.Types@@ -34,7 +34,9 @@ -- meta-data to comments. We make a structure for this ahead of time -- so we don't have to gut half the core each time we want to add such -- info.-newtype Meta = Meta { _version :: Maybe Version } deriving (Eq, Show)+data Meta = Meta { _version :: Maybe Version+ , _package :: Maybe Package+ } deriving (Eq, Show) data MetaDoc mod id = MetaDoc { _meta :: Meta@@ -42,14 +44,17 @@ } deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0)+-- | __NOTE__: Only defined for @base >= 4.8.0@ instance Bifunctor MetaDoc where bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d) #endif #if MIN_VERSION_base(4,10,0)+-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bifoldable MetaDoc where bifoldr f g z d = bifoldr f g z (_doc d) +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bitraversable MetaDoc where bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d #endif@@ -61,19 +66,25 @@ overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d) type Version = [Int]+type Package = String -data Hyperlink = Hyperlink+data Hyperlink id = Hyperlink { hyperlinkUrl :: String- , hyperlinkLabel :: Maybe String- } deriving (Eq, Show)+ , hyperlinkLabel :: Maybe id+ } deriving (Eq, Show, Functor, Foldable, Traversable) +data ModLink id = ModLink+ { modLinkName :: String+ , modLinkLabel :: Maybe id+ } deriving (Eq, Show, Functor, Foldable, Traversable)+ data Picture = Picture { pictureUri :: String , pictureTitle :: Maybe String } deriving (Eq, Show) data Header id = Header- { headerLevel :: Int+ { headerLevel :: Int -- ^ between 1 and 6 inclusive , headerTitle :: id } deriving (Eq, Show, Functor, Foldable, Traversable) @@ -104,20 +115,24 @@ | DocParagraph (DocH mod id) | DocIdentifier id | DocIdentifierUnchecked mod- | DocModule String+ -- ^ A qualified identifier that couldn't be resolved.+ | DocModule (ModLink (DocH mod id))+ -- ^ A link to a module, with an optional label. | DocWarning (DocH mod id)+ -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) | DocMonospaced (DocH mod id) | DocBold (DocH mod id) | DocUnorderedList [DocH mod id]- | DocOrderedList [DocH mod id]+ | DocOrderedList [(Int, DocH mod id)] | DocDefList [(DocH mod id, DocH mod id)] | DocCodeBlock (DocH mod id)- | DocHyperlink Hyperlink+ | DocHyperlink (Hyperlink (DocH mod id)) | DocPic Picture | DocMathInline String | DocMathDisplay String | DocAName String+ -- ^ A (HTML) anchor. It must not contain any spaces. | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id))@@ -125,6 +140,7 @@ deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0)+-- | __NOTE__: Only defined for @base >= 4.8.0@ instance Bifunctor DocH where bimap _ _ DocEmpty = DocEmpty bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB)@@ -132,16 +148,16 @@ bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) bimap _ g (DocIdentifier i) = DocIdentifier (g i) bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m)- bimap _ _ (DocModule s) = DocModule s+ bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl)) bimap f g (DocWarning doc) = DocWarning (bimap f g doc) bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) bimap f g (DocBold doc) = DocBold (bimap f g doc) bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)- bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)+ bimap f g (DocOrderedList docs) = DocOrderedList (map (\(index, a) -> (index, bimap f g a)) docs) bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)- bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink+ bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl)) bimap _ _ (DocPic picture) = DocPic picture bimap _ _ (DocMathInline s) = DocMathInline s bimap _ _ (DocMathDisplay s) = DocMathDisplay s@@ -153,6 +169,7 @@ #endif #if MIN_VERSION_base(4,10,0)+-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bifoldable DocH where bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB bifoldr f g z (DocParagraph doc) = bifoldr f g z doc@@ -163,13 +180,14 @@ bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc bifoldr f g z (DocBold doc) = bifoldr f g z doc bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs- bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs+ bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z (map snd docs) bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title bifoldr f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header bifoldr _ _ z _ = z +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bitraversable DocH where bitraverse _ _ DocEmpty = pure DocEmpty bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB@@ -177,16 +195,17 @@ bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m- bitraverse _ _ (DocModule s) = pure (DocModule s)+ bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl) bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs- bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs+ bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverseSnd (bitraverse f g) docs+ where traverseSnd f' = traverse (\(x, a) -> (\b -> (x, b)) <$> f' a) bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc- bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink)+ bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl) bitraverse _ _ (DocPic picture) = pure (DocPic picture) bitraverse _ _ (DocMathInline s) = pure (DocMathInline s) bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s)@@ -197,6 +216,16 @@ bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body #endif +-- | The namespace qualification for an identifier.+data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show)++-- | Render the a namespace into the same format it was initially parsed.+renderNs :: Namespace -> String+renderNs Value = "v"+renderNs Type = "t"+renderNs None = ""++ -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say).@@ -212,16 +241,16 @@ , markupAppend :: a -> a -> a , markupIdentifier :: id -> a , markupIdentifierUnchecked :: mod -> a- , markupModule :: String -> a+ , markupModule :: ModLink a -> a , markupWarning :: a -> a , markupEmphasis :: a -> a , markupBold :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a- , markupOrderedList :: [a] -> a+ , markupOrderedList :: [(Int,a)] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a- , markupHyperlink :: Hyperlink -> a+ , markupHyperlink :: Hyperlink a -> a , markupAName :: String -> a , markupPic :: Picture -> a , markupMathInline :: String -> a
− 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/Parser/UtilSpec.hs view
@@ -1,11 +1,14 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Documentation.Haddock.Parser.UtilSpec (main, spec) where import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util-import Data.Either.Compat (isLeft)+import Data.Either (isLeft) import Test.Hspec+#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative+#endif main :: IO () main = hspec spec
test/Documentation/Haddock/ParserSpec.hs view
@@ -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@@ -24,13 +25,20 @@ instance IsString a => IsString (Maybe a) where fromString = Just . fromString +emptyMeta :: Meta+emptyMeta =+ Meta {+ _version = Nothing+ , _package = Nothing+ }+ parseParas :: String -> MetaDoc () String-parseParas = overDoc Parse.toRegular . Parse.parseParas+parseParas = overDoc Parse.toRegular . Parse.parseParas Nothing parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString -hyperlink :: String -> Maybe String -> Doc String+hyperlink :: String -> Maybe (Doc String) -> Doc String hyperlink url = DocHyperlink . Hyperlink url main :: IO ()@@ -79,6 +87,18 @@ it "parses identifiers enclosed within backticks" $ do "`foo`" `shouldParseTo` DocIdentifier "foo" + it "parses identifiers preceded by a backtick and followed by a single quote" $ do+ "`foo'" `shouldParseTo` DocIdentifier "foo"++ it "parses identifiers preceded by a single quote and followed by a backtick" $ do+ "'foo`" `shouldParseTo` DocIdentifier "foo"++ it "can parse a constructor identifier" $ do+ "'Foo'" `shouldParseTo` DocIdentifier "Foo"++ it "can parse a qualified identifier" $ do+ "'Foo.bar'" `shouldParseTo` DocIdentifier "Foo.bar"+ it "parses a word with an one of the delimiters in it as DocString" $ do "don't" `shouldParseTo` "don't" @@ -92,9 +112,59 @@ it "doesn't parse empty identifiers" $ do "``" `shouldParseTo` "``" - it "can parse infix identifiers" $ do- "``infix``" `shouldParseTo` "`" <> DocIdentifier "infix" <> "`"+ it "can parse an identifier in infix notation enclosed within backticks" $ do+ "``infix``" `shouldParseTo` DocIdentifier "`infix`" + it "can parse identifiers containing a single quote" $ do+ "'don't'" `shouldParseTo` DocIdentifier "don't"++ it "can parse identifiers ending with a single quote" $ do+ "'foo''" `shouldParseTo` DocIdentifier "foo'"++ it "can parse identifiers in backticks ending with a single quote" $ do+ "`foo'`" `shouldParseTo` DocIdentifier "foo'"++ it "can parse an identifier containing a digit" $ do+ "'f0'" `shouldParseTo` DocIdentifier "f0"++ it "can parse an identifier containing unicode characters" $ do+ "'λ'" `shouldParseTo` DocIdentifier "λ"++ it "can parse a single quote followed by an identifier" $ do+ "''foo'" `shouldParseTo` "'" <> DocIdentifier "foo"++ 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 ".="++ it "can parse a qualified operator" $ do+ "'F..'" `shouldParseTo` DocIdentifier "F.."++ it "can parse a constructor operator" $ do+ "':='" `shouldParseTo` DocIdentifier ":="++ it "can parse a qualified constructor operator" $ do+ "'F.:='" `shouldParseTo` DocIdentifier "F.:="++ it "can parse a unicode operator" $ do+ "'∧'" `shouldParseTo` DocIdentifier "∧"+ context "when parsing URLs" $ do it "parses a URL" $ do "<http://example.com/>" `shouldParseTo` hyperlink "http://example.com/" Nothing@@ -149,6 +219,10 @@ "[some label]( url)" `shouldParseTo` "[some label]( url)" + it "allows inline markup in the label" $ do+ "[something /emphasized/](url)" `shouldParseTo`+ hyperlink "url" (Just ("something " <> DocEmphasis "emphasized"))+ context "when URL is on a separate line" $ do it "allows URL to be on a separate line" $ do "[some label]\n(url)" `shouldParseTo`@@ -218,8 +292,10 @@ it "parses a single word anchor" $ do "#foo#" `shouldParseTo` DocAName "foo" - it "parses a multi word anchor" $ do- "#foo bar#" `shouldParseTo` DocAName "foo bar"+ -- Spaces are not allowed:+ -- https://www.w3.org/TR/html51/dom.html#the-id-attribute+ it "doesn't parse a multi word anchor" $ do+ "#foo bar#" `shouldParseTo` "#foo bar#" it "parses a unicode anchor" $ do "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ"@@ -234,6 +310,9 @@ it "does not accept empty anchors" $ do "##" `shouldParseTo` "##" + it "does not accept anchors containing spaces" $ do+ "{-# LANGUAGE GADTs #-}" `shouldParseTo` "{-# LANGUAGE GADTs #-}"+ context "when parsing emphasised text" $ do it "emphasises a word on its own" $ do "/foo/" `shouldParseTo` DocEmphasis "foo"@@ -327,20 +406,20 @@ context "when parsing module strings" $ do it "should parse a module on its own" $ do "\"Module\"" `shouldParseTo`- DocModule "Module"+ DocModule (ModLink "Module" Nothing) it "should parse a module inline" $ do "This is a \"Module\"." `shouldParseTo`- "This is a " <> DocModule "Module" <> "."+ "This is a " <> DocModule (ModLink "Module" Nothing) <> "." it "can accept a simple module name" $ do- "\"Hello\"" `shouldParseTo` DocModule "Hello"+ "\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing) it "can accept a module name with dots" $ do- "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World"+ "\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing) it "can accept a module name with unicode" $ do- "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ"+ "\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing) it "parses a module name with a trailing dot as regular quoted string" $ do "\"Hello.\"" `shouldParseTo` "\"Hello.\""@@ -352,17 +431,86 @@ "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\"" it "accepts a module name with unicode" $ do- "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ"+ "\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing) it "treats empty module name as regular double quotes" $ do "\"\"" `shouldParseTo` "\"\"" it "accepts anchor reference syntax as DocModule" $ do- "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar"+ "\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing) + it "accepts anchor with hyphen as DocModule" $ do+ "\"Foo#bar-baz\"" `shouldParseTo` DocModule (ModLink "Foo#bar-baz" Nothing)+ it "accepts old anchor reference syntax as DocModule" $ do- "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar"+ "\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing) + context "when parsing labeled module links" $ do+ it "parses a simple labeled module link" $ do+ "[some label](\"Some.Module\")" `shouldParseTo`+ DocModule (ModLink "Some.Module" (Just "some label"))++ it "allows escaping in label" $ do+ "[some\\] label](\"Some.Module\")" `shouldParseTo`+ DocModule (ModLink "Some.Module" (Just "some] label"))++ it "strips leading and trailing whitespace from label" $ do+ "[ some label ](\"Some.Module\")" `shouldParseTo`+ DocModule (ModLink "Some.Module" (Just "some label"))++ it "allows whitespace in module name link" $ do+ "[some label]( \"Some.Module\"\t )" `shouldParseTo`+ DocModule (ModLink "Some.Module" (Just "some label"))++ it "allows inline markup in the label" $ do+ "[something /emphasized/](\"Some.Module\")" `shouldParseTo`+ DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized")))++ it "should parse a labeled module on its own" $ do+ "[label](\"Module\")" `shouldParseTo`+ DocModule (ModLink "Module" (Just "label"))++ it "should parse a labeled module inline" $ do+ "This is a [label](\"Module\")." `shouldParseTo`+ "This is a " <> DocModule (ModLink "Module" (Just "label")) <> "."++ it "can accept a labeled module name with dots" $ do+ "[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label"))++ it "can accept a labeled module name with unicode" $ do+ "[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label"))++ it "parses a labeled module name with a trailing dot as a hyperlink" $ do+ "[label](\"Hello.\")" `shouldParseTo`+ hyperlink "\"Hello.\"" (Just "label")++ it "parses a labeled module name with a space as a regular string" $ do+ "[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")"++ it "parses a module name with invalid characters as a hyperlink" $ do+ "[label](\"Hello&[{}(=*+]!\")" `shouldParseTo`+ hyperlink "\"Hello&[{}(=*+]!\"" (Just "label")++ it "accepts a labeled module name with unicode" $ do+ "[label](\"Foo.Barλ\")" `shouldParseTo`+ DocModule (ModLink "Foo.Barλ" (Just "label"))++ it "treats empty labeled module name as empty hyperlink" $ do+ "[label](\"\")" `shouldParseTo`+ hyperlink "\"\"" (Just "label")++ it "accepts anchor reference syntax for labeled module name" $ do+ "[label](\"Foo#bar\")" `shouldParseTo`+ DocModule (ModLink "Foo#bar" (Just "label"))++ it "accepts old anchor reference syntax for labeled module name" $ do+ "[label](\"Foo\\#bar\")" `shouldParseTo`+ DocModule (ModLink "Foo\\#bar" (Just "label"))++ it "interprets empty label as a unlabeled module name" $ do+ "[](\"Module.Name\")" `shouldParseTo`+ "[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")"+ describe "parseParas" $ do let infix 1 `shouldParseTo` shouldParseTo :: String -> Doc String -> Expectation@@ -372,20 +520,24 @@ 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`- MetaDoc { _meta = Meta { _version = Just [0,5,0] }+ MetaDoc { _meta = emptyMeta { _version = Just [0,5,0] } , _doc = DocEmpty } it "ignores trailing whitespace" $ do parseParas "@since 0.5.0 \t " `shouldBe`- MetaDoc { _meta = Meta { _version = Just [0,5,0] }+ MetaDoc { _meta = emptyMeta { _version = Just [0,5,0] } , _doc = DocEmpty } it "does not allow trailing input" $ do parseParas "@since 0.5.0 foo" `shouldBe`- MetaDoc { _meta = Meta { _version = Nothing }+ MetaDoc { _meta = emptyMeta { _version = Nothing } , _doc = DocParagraph "@since 0.5.0 foo" } @@ -395,12 +547,13 @@ "@since 0.5.0" , "@since 0.6.0" , "@since 0.7.0"- ] `shouldBe` MetaDoc { _meta = Meta { _version = Just [0,7,0] }+ ] `shouldBe` MetaDoc { _meta = emptyMeta { _version = Just [0,7,0] } , _doc = DocEmpty } 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@@ -426,28 +579,38 @@ it "turns it into a code block" $ do "@foo@" `shouldParseTo` DocCodeBlock "foo" - context "when a paragraph starts with a markdown link" $ do- it "correctly parses it as a text paragraph (not a definition list)" $ do- "[label](url)" `shouldParseTo`- DocParagraph (hyperlink "url" "label")+ context "when a paragraph contains a markdown link" $ do+ it "correctly parses the link" $ do+ "Blah [label](url)" `shouldParseTo`+ DocParagraph ("Blah " <> hyperlink "url" "label") - it "can be followed by an other paragraph" $ do- "[label](url)\n\nfoobar" `shouldParseTo`- DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar"+ context "when the paragraph starts with the markdown link" $ do+ it "correctly parses it as a text paragraph (not a definition list)" $ do+ "[label](url)" `shouldParseTo`+ DocParagraph (hyperlink "url" "label") - context "when paragraph contains additional text" $ do- it "accepts more text after the link" $ do- "[label](url) foo bar baz" `shouldParseTo`- DocParagraph (hyperlink "url" "label" <> " foo bar baz")+ it "can be followed by an other paragraph" $ do+ "[label](url)\n\nfoobar" `shouldParseTo`+ DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar" - it "accepts a newline right after the markdown link" $ do- "[label](url)\nfoo bar baz" `shouldParseTo`- DocParagraph (hyperlink "url" "label" <> " foo bar baz")+ context "when paragraph contains additional text" $ do+ it "accepts more text after the link" $ do+ "[label](url) foo bar baz" `shouldParseTo`+ DocParagraph (hyperlink "url" "label" <> " foo bar baz") - it "can be followed by an other paragraph" $ do- "[label](url)foo\n\nbar" `shouldParseTo`- DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar"+ it "accepts a newline right after the markdown link" $ do+ "[label](url)\nfoo bar baz" `shouldParseTo`+ DocParagraph (hyperlink "url" "label" <> " foo bar baz") + it "can be followed by an other paragraph" $ do+ "[label](url)foo\n\nbar" `shouldParseTo`+ DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar"++ context "when the link starts on a new line not at the beginning of the paragraph" $ do+ it "correctly parses the link" $ do+ "Bla\n[label](url)" `shouldParseTo`+ DocParagraph ("Bla\n" <> hyperlink "url" "label")+ context "when parsing birdtracks" $ do it "parses them as a code block" $ do unlines [@@ -660,7 +823,7 @@ it "can nest another type of list inside" $ do "* foo\n\n 1. bar" `shouldParseTo` DocUnorderedList [ DocParagraph "foo"- <> DocOrderedList [DocParagraph "bar"]]+ <> DocOrderedList [(1, DocParagraph "bar")]] it "can nest a code block inside" $ do "* foo\n\n @foo bar baz@" `shouldParseTo`@@ -699,7 +862,7 @@ DocUnorderedList [ DocParagraph "foo" <> DocUnorderedList [ DocParagraph "bar" ] ]- <> DocOrderedList [ DocParagraph "baz" ]+ <> DocOrderedList [ (1, DocParagraph "baz") ] it "allows arbitrary initial indent of a list" $ do unlines@@ -723,20 +886,20 @@ DocDefList [ ("foo", "foov" <> DocDefList [ ("bar", "barv") ]) ]- <> DocOrderedList [ DocParagraph "baz" ]+ <> DocOrderedList [ (1, DocParagraph "baz") ] it "list order is preserved in presence of nesting + extra text" $ do "1. Foo\n\n > Some code\n\n2. Bar\n\nSome text" `shouldParseTo`- DocOrderedList [ DocParagraph "Foo" <> DocCodeBlock "Some code"- , DocParagraph "Bar"+ DocOrderedList [ (1, DocParagraph "Foo" <> DocCodeBlock "Some code")+ , (2, DocParagraph "Bar") ] <> DocParagraph (DocString "Some text") "1. Foo\n\n2. Bar\n\nSome text" `shouldParseTo`- DocOrderedList [ DocParagraph "Foo"- , DocParagraph "Bar"+ DocOrderedList [ (1, DocParagraph "Foo")+ , (2, DocParagraph "Bar") ] <> DocParagraph (DocString "Some text") @@ -820,9 +983,9 @@ , " 3. three" ] `shouldParseTo` DocOrderedList [- DocParagraph "one"- , DocParagraph "two"- , DocParagraph "three"+ (1, DocParagraph "one")+ , (1, DocParagraph "two")+ , (3, DocParagraph "three") ] it "ignores empty lines between list items" $ do@@ -832,12 +995,12 @@ , "2. two" ] `shouldParseTo` DocOrderedList [- DocParagraph "one"- , DocParagraph "two"+ (1, DocParagraph "one")+ , (2, DocParagraph "two") ] it "accepts an empty list item" $ do- "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty]+ "1." `shouldParseTo` DocOrderedList [(1, DocParagraph DocEmpty)] it "accepts multi-line list items" $ do unlines [@@ -847,12 +1010,12 @@ , "more two" ] `shouldParseTo` DocOrderedList [- DocParagraph "point one\n more one"- , DocParagraph "point two\nmore two"+ (1, DocParagraph "point one\n more one")+ , (1, DocParagraph "point two\nmore two") ] it "accepts markup in list items" $ do- "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")]+ "1. /foo/" `shouldParseTo` DocOrderedList [(1, DocParagraph (DocEmphasis "foo"))] it "requires empty lines between list and other paragraphs" $ do unlines [@@ -862,7 +1025,7 @@ , "" , "baz" ]- `shouldParseTo` DocParagraph "foo" <> DocOrderedList [DocParagraph "bar"] <> DocParagraph "baz"+ `shouldParseTo` DocParagraph "foo" <> DocOrderedList [(1, DocParagraph "bar")] <> DocParagraph "baz" context "when parsing definition lists" $ do it "parses a simple list" $ do@@ -949,8 +1112,8 @@ ] `shouldParseTo` DocUnorderedList [ DocParagraph "bullet" , DocParagraph "different bullet"]- <> DocOrderedList [ DocParagraph "ordered"- , DocParagraph "different bullet"+ <> DocOrderedList [ (1, DocParagraph "ordered")+ , (2, DocParagraph "different bullet") ] <> DocDefList [ ("cat", "kitten") , ("pineapple", "fruit")
− 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
− vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs
@@ -1,23 +0,0 @@--- |--- Module : Data.Attoparsec--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Simple, efficient combinator parsing for--- 'Data.ByteString.ByteString' strings, loosely based on the Parsec--- library.------ This module is deprecated. Use "Data.Attoparsec.ByteString"--- instead.--module Data.Attoparsec- {-# DEPRECATED "This module will be removed in the next major release." #-}- (- module Data.Attoparsec.ByteString- ) where--import Data.Attoparsec.ByteString
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs
@@ -1,230 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--- |--- Module : Data.Attoparsec.ByteString--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Simple, efficient combinator parsing for 'B.ByteString' strings,--- loosely based on the Parsec library.--module Data.Attoparsec.ByteString- (- -- * Differences from Parsec- -- $parsec-- -- * Incremental input- -- $incremental-- -- * Performance considerations- -- $performance-- -- * Parser types- I.Parser- , Result- , T.IResult(..)- , I.compareResults-- -- * Running parsers- , parse- , feed- , I.parseOnly- , parseWith- , parseTest-- -- ** Result conversion- , maybeResult- , eitherResult-- -- * Parsing individual bytes- , I.word8- , I.anyWord8- , I.notWord8- , I.satisfy- , I.satisfyWith- , I.skip-- -- ** Lookahead- , I.peekWord8- , I.peekWord8'-- -- ** Byte classes- , I.inClass- , I.notInClass-- -- * Efficient string handling- , I.string- , I.skipWhile- , I.take- , I.scan- , I.runScanner- , I.takeWhile- , I.takeWhile1- , I.takeTill-- -- ** Consume all remaining input- , I.takeByteString- , I.takeLazyByteString-- -- * Combinators- , try- , (<?>)- , choice- , count- , option- , many'- , many1- , many1'- , manyTill- , manyTill'- , sepBy- , sepBy'- , sepBy1- , sepBy1'- , skipMany- , skipMany1- , eitherP- , I.match- -- * State observation and manipulation functions- , I.endOfInput- , I.atEnd- ) where--import Data.Attoparsec.Combinator-import Data.List (intercalate)-import qualified Data.Attoparsec.ByteString.Internal as I-import qualified Data.Attoparsec.Internal as I-import qualified Data.ByteString as B-import Data.Attoparsec.ByteString.Internal (Result, parse)-import qualified Data.Attoparsec.Internal.Types as T---- $parsec------ Compared to Parsec 3, attoparsec makes several tradeoffs. It is--- not intended for, or ideal for, all possible uses.------ * While attoparsec can consume input incrementally, Parsec cannot.--- Incremental input is a huge deal for efficient and secure network--- and system programming, since it gives much more control to users--- of the library over matters such as resource usage and the I/O--- model to use.------ * Much of the performance advantage of attoparsec is gained via--- high-performance parsers such as 'I.takeWhile' and 'I.string'.--- If you use complicated combinators that return lists of bytes or--- characters, there is less performance difference between the two--- libraries.------ * Unlike Parsec 3, attoparsec does not support being used as a--- monad transformer.------ * attoparsec is specialised to deal only with strict 'B.ByteString'--- input. Efficiency concerns rule out both lists and lazy--- bytestrings. The usual use for lazy bytestrings would be to--- allow consumption of very large input without a large footprint.--- For this need, attoparsec's incremental input provides an--- excellent substitute, with much more control over when input--- takes place. If you must use lazy bytestrings, see the--- "Data.Attoparsec.ByteString.Lazy" module, which feeds lazy chunks--- to a regular parser.------ * Parsec parsers can produce more helpful error messages than--- attoparsec parsers. This is a matter of focus: attoparsec avoids--- the extra book-keeping in favour of higher performance.---- $incremental------ attoparsec supports incremental input, meaning that you can feed it--- a bytestring that represents only part of the expected total amount--- of data to parse. If your parser reaches the end of a fragment of--- input and could consume more input, it will suspend parsing and--- return a 'T.Partial' continuation.------ Supplying the 'T.Partial' continuation with a bytestring will--- resume parsing at the point where it was suspended, with the--- bytestring you supplied used as new input at the end of the--- existing input. You must be prepared for the result of the resumed--- parse to be another 'T.Partial' continuation.------ To indicate that you have no more input, supply the 'T.Partial'--- continuation with an empty bytestring.------ Remember that some parsing combinators will not return a result--- until they reach the end of input. They may thus cause 'T.Partial'--- results to be returned.------ If you do not need support for incremental input, consider using--- the 'I.parseOnly' function to run your parser. It will never--- prompt for more input.------ /Note/: incremental input does /not/ imply that attoparsec will--- release portions of its internal state for garbage collection as it--- proceeds. Its internal representation is equivalent to a single--- 'ByteString': if you feed incremental input to a parser, it will--- require memory proportional to the amount of input you supply.--- (This is necessary to support arbitrary backtracking.)---- $performance------ If you write an attoparsec-based parser carefully, it can be--- realistic to expect it to perform similarly to a hand-rolled C--- parser (measuring megabytes parsed per second).------ To actually achieve high performance, there are a few guidelines--- that it is useful to follow.------ Use the 'B.ByteString'-oriented parsers whenever possible,--- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'. There is--- about a factor of 100 difference in performance between the two--- kinds of parser.------ For very simple byte-testing predicates, write them by hand instead--- of using 'I.inClass' or 'I.notInClass'. For instance, both of--- these predicates test for an end-of-line byte, but the first is--- much faster than the second:------ >endOfLine_fast w = w == 13 || w == 10--- >endOfLine_slow = inClass "\r\n"------ Make active use of benchmarking and profiling tools to measure,--- find the problems with, and improve the performance of your parser.---- | Run a parser and print its result to standard output.-parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO ()-parseTest p s = print (parse p s)---- | Run a parser with an initial input string, and a monadic action--- that can supply more input if needed.-parseWith :: Monad m =>- (m B.ByteString)- -- ^ An action that will be executed to provide the parser- -- with more input, if necessary. The action must return an- -- 'B.empty' string when there is no more input available.- -> I.Parser a- -> B.ByteString- -- ^ Initial input for the parser.- -> m (Result a)-parseWith refill p s = step $ parse p s- where step (T.Partial k) = (step . k) =<< refill- step r = return r-{-# INLINE parseWith #-}---- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result--- is treated as failure.-maybeResult :: Result r -> Maybe r-maybeResult (T.Done _ r) = Just r-maybeResult _ = Nothing---- | Convert a 'Result' value to an 'Either' value. A 'T.Partial'--- result is treated as failure.-eitherResult :: Result r -> Either String r-eitherResult (T.Done _ r) = Right r-eitherResult (T.Fail _ [] msg) = Left msg-eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)-eitherResult _ = Left "Result: incomplete input"
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE BangPatterns #-}--- |--- Module : Data.Attoparsec.ByteString.Buffer--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : GHC------ An "immutable" buffer that supports cheap appends.------ A Buffer is divided into an immutable read-only zone, followed by a--- mutable area that we've preallocated, but not yet written to.------ We overallocate at the end of a Buffer so that we can cheaply--- append. Since a user of an existing Buffer cannot see past the end--- of its immutable zone into the data that will change during an--- append, this is safe.------ Once we run out of space at the end of a Buffer, we do the usual--- doubling of the buffer size.------ The fact of having a mutable buffer really helps with performance,--- but it does have a consequence: if someone misuses the Partial API--- that attoparsec uses by calling the same continuation repeatedly--- (which never makes sense in practice), they could overwrite data.------ Since the API *looks* pure, it should *act* pure, too, so we use--- two generation counters (one mutable, one immutable) to track the--- number of appends to a mutable buffer. If the counters ever get out--- of sync, someone is appending twice to a mutable buffer, so we--- duplicate the entire buffer in order to preserve the immutability--- of its older self.------ While we could go a step further and gain protection against API--- abuse on a multicore system, by use of an atomic increment--- instruction to bump the mutable generation counter, that would be--- very expensive, and feels like it would also be in the realm of the--- ridiculous. Clients should never call a continuation more than--- once; we lack a linear type system that could enforce this; and--- there's only so far we should go to accommodate broken uses.--module Data.Attoparsec.ByteString.Buffer- (- Buffer- , buffer- , unbuffer- , pappend- , length- , unsafeIndex- , substring- , unsafeDrop- ) where--import Control.Exception (assert)-import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr)-import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)-import Data.List (foldl1')-import Data.Monoid as Mon (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Data.Word (Word8)-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import Foreign.Ptr (castPtr, plusPtr)-import Foreign.Storable (peek, peekByteOff, poke, sizeOf)-import GHC.ForeignPtr (mallocPlainForeignPtrBytes)-import Prelude hiding (length)---- If _cap is zero, this buffer is empty.-data Buffer = Buf {- _fp :: {-# UNPACK #-} !(ForeignPtr Word8)- , _off :: {-# UNPACK #-} !Int- , _len :: {-# UNPACK #-} !Int- , _cap :: {-# UNPACK #-} !Int- , _gen :: {-# UNPACK #-} !Int- }--instance Show Buffer where- showsPrec p = showsPrec p . unbuffer---- | The initial 'Buffer' has no mutable zone, so we can avoid all--- copies in the (hopefully) common case of no further input being fed--- to us.-buffer :: ByteString -> Buffer-buffer (PS fp off len) = Buf fp off len len 0--unbuffer :: Buffer -> ByteString-unbuffer (Buf fp off len _ _) = PS fp off len--instance Semigroup Buffer where- (Buf _ _ _ 0 _) <> b = b- a <> (Buf _ _ _ 0 _) = a- buf <> (Buf fp off len _ _) = append buf fp off len--instance Monoid Buffer where- mempty = Buf nullForeignPtr 0 0 0 0-- mappend = (<>)-- mconcat [] = Mon.mempty- mconcat xs = foldl1' mappend xs--pappend :: Buffer -> ByteString -> Buffer-pappend (Buf _ _ _ 0 _) bs = buffer bs-pappend buf (PS fp off len) = append buf fp off len--append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer-append (Buf fp0 off0 len0 cap0 gen0) !fp1 !off1 !len1 =- inlinePerformIO . withForeignPtr fp0 $ \ptr0 ->- withForeignPtr fp1 $ \ptr1 -> do- let genSize = sizeOf (0::Int)- newlen = len0 + len1- gen <- if gen0 == 0- then return 0- else peek (castPtr ptr0)- if gen == gen0 && newlen <= cap0- then do- let newgen = gen + 1- poke (castPtr ptr0) newgen- memcpy (ptr0 `plusPtr` (off0+len0))- (ptr1 `plusPtr` off1)- (fromIntegral len1)- return (Buf fp0 off0 newlen cap0 newgen)- else do- let newcap = newlen * 2- fp <- mallocPlainForeignPtrBytes (newcap + genSize)- withForeignPtr fp $ \ptr_ -> do- let ptr = ptr_ `plusPtr` genSize- newgen = 1- poke (castPtr ptr_) newgen- memcpy ptr (ptr0 `plusPtr` off0) (fromIntegral len0)- memcpy (ptr `plusPtr` len0) (ptr1 `plusPtr` off1)- (fromIntegral len1)- return (Buf fp genSize newlen newcap newgen)--length :: Buffer -> Int-length (Buf _ _ len _ _) = len-{-# INLINE length #-}--unsafeIndex :: Buffer -> Int -> Word8-unsafeIndex (Buf fp off len _ _) i = assert (i >= 0 && i < len) .- inlinePerformIO . withForeignPtr fp $ flip peekByteOff (off+i)-{-# INLINE unsafeIndex #-}--substring :: Int -> Int -> Buffer -> ByteString-substring s l (Buf fp off len _ _) =- assert (s >= 0 && s <= len) .- assert (l >= 0 && l <= len-s) $- PS fp (off+s) l-{-# INLINE substring #-}--unsafeDrop :: Int -> Buffer -> ByteString-unsafeDrop s (Buf fp off len _ _) =- assert (s >= 0 && s <= len) $- PS fp (off+s) (len-s)-{-# INLINE unsafeDrop #-}
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs
@@ -1,464 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, TypeFamilies,- TypeSynonymInstances, GADTs #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-} -- Imports internal modules-#endif-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-}---- |--- Module : Data.Attoparsec.ByteString.Char8--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Simple, efficient, character-oriented combinator parsing for--- 'B.ByteString' strings, loosely based on the Parsec library.--module Data.Attoparsec.ByteString.Char8- (- -- * Character encodings- -- $encodings-- -- * Parser types- Parser- , A.Result- , A.IResult(..)- , I.compareResults-- -- * Running parsers- , A.parse- , A.feed- , A.parseOnly- , A.parseWith- , A.parseTest-- -- ** Result conversion- , A.maybeResult- , A.eitherResult-- -- * Parsing individual characters- , char- , char8- , anyChar- , notChar- , satisfy-- -- ** Lookahead- , peekChar- , peekChar'-- -- ** Special character parsers- , digit- , letter_iso8859_15- , letter_ascii- , space-- -- ** Fast predicates- , isDigit- , isDigit_w8- , isAlpha_iso8859_15- , isAlpha_ascii- , isSpace- , isSpace_w8-- -- *** Character classes- , inClass- , notInClass-- -- * Efficient string handling- , I.string- , I.stringCI- , skipSpace- , skipWhile- , I.take- , scan- , takeWhile- , takeWhile1- , takeTill-- -- ** String combinators- -- $specalt- , (.*>)- , (<*.)-- -- ** Consume all remaining input- , I.takeByteString- , I.takeLazyByteString-- -- * Text parsing- , I.endOfLine- , isEndOfLine- , isHorizontalSpace-- -- * Numeric parsers- , decimal- , hexadecimal- , signed-- -- * Combinators- , try- , (<?>)- , choice- , count- , option- , many'- , many1- , many1'- , manyTill- , manyTill'- , sepBy- , sepBy'- , sepBy1- , sepBy1'- , skipMany- , skipMany1- , eitherP- , I.match- -- * State observation and manipulation functions- , I.endOfInput- , I.atEnd- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (pure, (*>), (<*), (<$>))-import Data.Word (Word)-#endif-import Control.Applicative ((<|>))-import Data.Attoparsec.ByteString.FastSet (charClass, memberChar)-import Data.Attoparsec.ByteString.Internal (Parser)-import Data.Attoparsec.Combinator-import Data.Bits (Bits, (.|.), shiftL)-import Data.ByteString.Internal (c2w, w2c)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.String (IsString(..))-import Data.Word (Word8, Word16, Word32, Word64)-import Prelude hiding (takeWhile)-import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.ByteString.Internal as I-import qualified Data.Attoparsec.Internal as I-import qualified Data.ByteString as B8-import qualified Data.ByteString.Char8 as B--instance (a ~ B.ByteString) => IsString (Parser a) where- fromString = I.string . B.pack---- $encodings------ This module is intended for parsing text that is--- represented using an 8-bit character set, e.g. ASCII or--- ISO-8859-15. It /does not/ make any attempt to deal with character--- encodings, multibyte characters, or wide characters. In--- particular, all attempts to use characters above code point U+00FF--- will give wrong answers.------ Code points below U+0100 are simply translated to and from their--- numeric values, so e.g. the code point U+00A4 becomes the byte--- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic--- currency sign in ISO-8859-1). Haskell 'Char' values above U+00FF--- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@.---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser requires the predicate to succeed on at least one byte--- of input: it will fail if the predicate never returns 'True' or if--- there is no input left.-takeWhile1 :: (Char -> Bool) -> Parser B.ByteString-takeWhile1 p = I.takeWhile1 (p . w2c)-{-# INLINE takeWhile1 #-}---- | The parser @satisfy p@ succeeds for any byte for which the--- predicate @p@ returns 'True'. Returns the byte that is actually--- parsed.------ >digit = satisfy isDigit--- > where isDigit c = c >= '0' && c <= '9'-satisfy :: (Char -> Bool) -> Parser Char-satisfy = I.satisfyWith w2c-{-# INLINE satisfy #-}---- | Match a letter, in the ISO-8859-15 encoding.-letter_iso8859_15 :: Parser Char-letter_iso8859_15 = satisfy isAlpha_iso8859_15 <?> "letter_iso8859_15"-{-# INLINE letter_iso8859_15 #-}---- | Match a letter, in the ASCII encoding.-letter_ascii :: Parser Char-letter_ascii = satisfy isAlpha_ascii <?> "letter_ascii"-{-# INLINE letter_ascii #-}---- | A fast alphabetic predicate for the ISO-8859-15 encoding------ /Note/: For all character encodings other than ISO-8859-15, and--- almost all Unicode code points above U+00A3, this predicate gives--- /wrong answers/.-isAlpha_iso8859_15 :: Char -> Bool-isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||- (c >= '\166' && moby c)- where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247"- {-# NOINLINE moby #-}-{-# INLINE isAlpha_iso8859_15 #-}---- | A fast alphabetic predicate for the ASCII encoding------ /Note/: For all character encodings other than ASCII, and--- almost all Unicode code points above U+007F, this predicate gives--- /wrong answers/.-isAlpha_ascii :: Char -> Bool-isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')-{-# INLINE isAlpha_ascii #-}---- | Parse a single digit.-digit :: Parser Char-digit = satisfy isDigit <?> "digit"-{-# INLINE digit #-}---- | A fast digit predicate.-isDigit :: Char -> Bool-isDigit c = c >= '0' && c <= '9'-{-# INLINE isDigit #-}---- | A fast digit predicate.-isDigit_w8 :: Word8 -> Bool-isDigit_w8 w = w - 48 <= 9-{-# INLINE isDigit_w8 #-}---- | Match any character.-anyChar :: Parser Char-anyChar = satisfy $ const True-{-# INLINE anyChar #-}---- | Match any character, to perform lookahead. Returns 'Nothing' if--- end of input has been reached. Does not consume any input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs. Careless use will thus result in an infinite loop.-peekChar :: Parser (Maybe Char)-peekChar = (fmap w2c) `fmap` I.peekWord8-{-# INLINE peekChar #-}---- | Match any character, to perform lookahead. Does not consume any--- input, but will fail if end of input has been reached.-peekChar' :: Parser Char-peekChar' = w2c `fmap` I.peekWord8'-{-# INLINE peekChar' #-}---- | Fast predicate for matching ASCII space characters.------ /Note/: This predicate only gives correct answers for the ASCII--- encoding. For instance, it does not recognise U+00A0 (non-breaking--- space) as a space character, even though it is a valid ISO-8859-15--- byte. For a Unicode-aware and only slightly slower predicate,--- use 'Data.Char.isSpace'-isSpace :: Char -> Bool-isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')-{-# INLINE isSpace #-}---- | Fast 'Word8' predicate for matching ASCII space characters.-isSpace_w8 :: Word8 -> Bool-isSpace_w8 w = w == 32 || w - 9 <= 4-{-# INLINE isSpace_w8 #-}----- | Parse a space character.------ /Note/: This parser only gives correct answers for the ASCII--- encoding. For instance, it does not recognise U+00A0 (non-breaking--- space) as a space character, even though it is a valid ISO-8859-15--- byte.-space :: Parser Char-space = satisfy isSpace <?> "space"-{-# INLINE space #-}---- | Match a specific character.-char :: Char -> Parser Char-char c = satisfy (== c) <?> [c]-{-# INLINE char #-}---- | Match a specific character, but return its 'Word8' value.-char8 :: Char -> Parser Word8-char8 c = I.satisfy (== c2w c) <?> [c]-{-# INLINE char8 #-}---- | Match any character except the given one.-notChar :: Char -> Parser Char-notChar c = satisfy (/= c) <?> "not " ++ [c]-{-# INLINE notChar #-}---- | Match any character in a set.------ >vowel = inClass "aeiou"------ Range notation is supported.------ >halfAlphabet = inClass "a-nA-N"------ To add a literal \'-\' to a set, place it at the beginning or end--- of the string.-inClass :: String -> Char -> Bool-inClass s = (`memberChar` mySet)- where mySet = charClass s-{-# INLINE inClass #-}---- | Match any character not in a set.-notInClass :: String -> Char -> Bool-notInClass s = not . inClass s-{-# INLINE notInClass #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser does not fail. It will return an empty string if the--- predicate returns 'False' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs. Careless use will thus result in an infinite loop.-takeWhile :: (Char -> Bool) -> Parser B.ByteString-takeWhile p = I.takeWhile (p . w2c)-{-# INLINE takeWhile #-}---- | A stateful scanner. The predicate consumes and transforms a--- state argument, and each transformed state is passed to successive--- invocations of the predicate on each byte of the input until one--- returns 'Nothing' or the input ends.------ This parser does not fail. It will return an empty string if the--- predicate returns 'Nothing' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs. Careless use will thus result in an infinite loop.-scan :: s -> (s -> Char -> Maybe s) -> Parser B.ByteString-scan s0 p = I.scan s0 (\s -> p s . w2c)-{-# INLINE scan #-}---- | Consume input as long as the predicate returns 'False'--- (i.e. until it returns 'True'), and return the consumed input.------ This parser does not fail. It will return an empty string if the--- predicate returns 'True' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs. Careless use will thus result in an infinite loop.-takeTill :: (Char -> Bool) -> Parser B.ByteString-takeTill p = I.takeTill (p . w2c)-{-# INLINE takeTill #-}---- | Skip past input for as long as the predicate returns 'True'.-skipWhile :: (Char -> Bool) -> Parser ()-skipWhile p = I.skipWhile (p . w2c)-{-# INLINE skipWhile #-}---- | Skip over white space.-skipSpace :: Parser ()-skipSpace = I.skipWhile isSpace_w8-{-# INLINE skipSpace #-}---- $specalt------ If you enable the @OverloadedStrings@ language extension, you can--- use the '*>' and '<*' combinators to simplify the common task of--- matching a statically known string, then immediately parsing--- something else.------ Instead of writing something like this:------ @---'I.string' \"foo\" '*>' wibble--- @------ Using @OverloadedStrings@, you can omit the explicit use of--- 'I.string', and write a more compact version:------ @--- \"foo\" '*>' wibble--- @------ (Note: the '.*>' and '<*.' combinators that were originally--- provided for this purpose are obsolete and unnecessary, and will be--- removed in the next major version.)---- | /Obsolete/. A type-specialized version of '*>' for--- 'B.ByteString'. Use '*>' instead.-(.*>) :: B.ByteString -> Parser a -> Parser a-s .*> f = I.string s *> f-{-# DEPRECATED (.*>) "This is no longer necessary, and will be removed. Use '*>' instead." #-}---- | /Obsolete/. A type-specialized version of '<*' for--- 'B.ByteString'. Use '<*' instead.-(<*.) :: Parser a -> B.ByteString -> Parser a-f <*. s = f <* I.string s-{-# DEPRECATED (<*.) "This is no longer necessary, and will be removed. Use '<*' instead." #-}---- | A predicate that matches either a carriage return @\'\\r\'@ or--- newline @\'\\n\'@ character.-isEndOfLine :: Word8 -> Bool-isEndOfLine w = w == 13 || w == 10-{-# INLINE isEndOfLine #-}---- | A predicate that matches either a space @\' \'@ or horizontal tab--- @\'\\t\'@ character.-isHorizontalSpace :: Word8 -> Bool-isHorizontalSpace w = w == 32 || w == 9-{-# INLINE isHorizontalSpace #-}---- | Parse and decode an unsigned hexadecimal number. The hex digits--- @\'a\'@ through @\'f\'@ may be upper or lower case.------ This parser does not accept a leading @\"0x\"@ string.-hexadecimal :: (Integral a, Bits a) => Parser a-hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit- where- isHexDigit w = (w >= 48 && w <= 57) ||- (w >= 97 && w <= 102) ||- (w >= 65 && w <= 70)- step a w | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48)- | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87)- | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55)-{-# SPECIALISE hexadecimal :: Parser Int #-}-{-# SPECIALISE hexadecimal :: Parser Int8 #-}-{-# SPECIALISE hexadecimal :: Parser Int16 #-}-{-# SPECIALISE hexadecimal :: Parser Int32 #-}-{-# SPECIALISE hexadecimal :: Parser Int64 #-}-{-# SPECIALISE hexadecimal :: Parser Integer #-}-{-# SPECIALISE hexadecimal :: Parser Word #-}-{-# SPECIALISE hexadecimal :: Parser Word8 #-}-{-# SPECIALISE hexadecimal :: Parser Word16 #-}-{-# SPECIALISE hexadecimal :: Parser Word32 #-}-{-# SPECIALISE hexadecimal :: Parser Word64 #-}---- | Parse and decode an unsigned decimal number.-decimal :: Integral a => Parser a-decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDigit_w8- where step a w = a * 10 + fromIntegral (w - 48)-{-# SPECIALISE decimal :: Parser Int #-}-{-# SPECIALISE decimal :: Parser Int8 #-}-{-# SPECIALISE decimal :: Parser Int16 #-}-{-# SPECIALISE decimal :: Parser Int32 #-}-{-# SPECIALISE decimal :: Parser Int64 #-}-{-# SPECIALISE decimal :: Parser Integer #-}-{-# SPECIALISE decimal :: Parser Word #-}-{-# SPECIALISE decimal :: Parser Word8 #-}-{-# SPECIALISE decimal :: Parser Word16 #-}-{-# SPECIALISE decimal :: Parser Word32 #-}-{-# SPECIALISE decimal :: Parser Word64 #-}---- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign--- character.-signed :: Num a => Parser a -> Parser a-{-# SPECIALISE signed :: Parser Int -> Parser Int #-}-{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-}-{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-}-{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-}-{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-}-{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-}-signed p = (negate <$> (char8 '-' *> p))- <|> (char8 '+' *> p)- <|> p-
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash #-}---------------------------------------------------------------------------------- |--- Module : Data.Attoparsec.ByteString.FastSet--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Fast set membership tests for 'Word8' and 8-bit 'Char' values. The--- set representation is unboxed for efficiency. For small sets, we--- test for membership using a binary search. For larger sets, we use--- a lookup table.----------------------------------------------------------------------------------module Data.Attoparsec.ByteString.FastSet- (- -- * Data type- FastSet- -- * Construction- , fromList- , set- -- * Lookup- , memberChar- , memberWord8- -- * Debugging- , fromSet- -- * Handy interface- , charClass- ) where--import Data.Bits ((.&.), (.|.))-import Foreign.Storable (peekByteOff, pokeByteOff)-import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#)-import GHC.Word (Word8(W8#))-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as I-import qualified Data.ByteString.Unsafe as U--data FastSet = Sorted { fromSet :: !B.ByteString }- | Table { fromSet :: !B.ByteString }- deriving (Eq, Ord)--instance Show FastSet where- show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s)- show (Table _) = "FastSet Table"---- | The lower bound on the size of a lookup table. We choose this to--- balance table density against performance.-tableCutoff :: Int-tableCutoff = 8---- | Create a set.-set :: B.ByteString -> FastSet-set s | B.length s < tableCutoff = Sorted . B.sort $ s- | otherwise = Table . mkTable $ s--fromList :: [Word8] -> FastSet-fromList = set . B.pack--data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8--shiftR :: Int -> Int -> Int-shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)--shiftL :: Word8 -> Int -> Word8-shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))--index :: Int -> I-index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7))-{-# INLINE index #-}---- | Check the set for membership.-memberWord8 :: Word8 -> FastSet -> Bool-memberWord8 w (Table t) =- let I byte bit = index (fromIntegral w)- in U.unsafeIndex t byte .&. bit /= 0-memberWord8 w (Sorted s) = search 0 (B.length s - 1)- where search lo hi- | hi < lo = False- | otherwise =- let mid = (lo + hi) `quot` 2- in case compare w (U.unsafeIndex s mid) of- GT -> search (mid + 1) hi- LT -> search lo (mid - 1)- _ -> True---- | Check the set for membership. Only works with 8-bit characters:--- characters above code point 255 will give wrong answers.-memberChar :: Char -> FastSet -> Bool-memberChar c = memberWord8 (I.c2w c)-{-# INLINE memberChar #-}--mkTable :: B.ByteString -> B.ByteString-mkTable s = I.unsafeCreate 32 $ \t -> do- _ <- I.memset t 0 32- U.unsafeUseAsCStringLen s $ \(p, l) ->- let loop n | n == l = return ()- | otherwise = do- c <- peekByteOff p n :: IO Word8- let I byte bit = index (fromIntegral c)- prev <- peekByteOff t byte :: IO Word8- pokeByteOff t byte (prev .|. bit)- loop (n + 1)- in loop 0--charClass :: String -> FastSet-charClass = set . B8.pack . go- where go (a:'-':b:xs) = [a..b] ++ go xs- go (x:xs) = x : go xs- go _ = ""
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs
@@ -1,536 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, GADTs, OverloadedStrings, RankNTypes,- RecordWildCards #-}--- |--- Module : Data.Attoparsec.ByteString.Internal--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Simple, efficient parser combinators for 'ByteString' strings,--- loosely based on the Parsec library.--module Data.Attoparsec.ByteString.Internal- (- -- * Parser types- Parser- , Result-- -- * Running parsers- , parse- , parseOnly-- -- * Combinators- , module Data.Attoparsec.Combinator-- -- * Parsing individual bytes- , satisfy- , satisfyWith- , anyWord8- , skip- , word8- , notWord8-- -- ** Lookahead- , peekWord8- , peekWord8'-- -- ** Byte classes- , inClass- , notInClass-- -- * Parsing more complicated structures- , storable-- -- * Efficient string handling- , skipWhile- , string- , stringCI- , take- , scan- , runScanner- , takeWhile- , takeWhile1- , takeTill-- -- ** Consume all remaining input- , takeByteString- , takeLazyByteString-- -- * Utilities- , endOfLine- , endOfInput- , match- , atEnd- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Applicative ((<|>))-import Control.Monad (when)-import Data.Attoparsec.ByteString.Buffer (Buffer, buffer)-import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8)-import Data.Attoparsec.Combinator ((<?>))-import Data.Attoparsec.Internal-import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)-import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)-import Data.ByteString (ByteString)-import Data.List (intercalate)-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (castPtr, minusPtr, plusPtr)-import Foreign.Storable (Storable(peek, sizeOf))-import Prelude hiding (getChar, succ, take, takeWhile)-import qualified Data.Attoparsec.ByteString.Buffer as Buf-import qualified Data.Attoparsec.Internal.Types as T-import qualified Data.ByteString as B8-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Unsafe as B--type Parser = T.Parser ByteString-type Result = IResult ByteString-type Failure r = T.Failure ByteString Buffer r-type Success a r = T.Success ByteString Buffer a r---- | The parser @satisfy p@ succeeds for any byte for which the--- predicate @p@ returns 'True'. Returns the byte that is actually--- parsed.------ >digit = satisfy isDigit--- > where isDigit w = w >= 48 && w <= 57-satisfy :: (Word8 -> Bool) -> Parser Word8-satisfy p = do- h <- peekWord8'- if p h- then advance 1 >> return h- else fail "satisfy"-{-# INLINE satisfy #-}---- | The parser @skip p@ succeeds for any byte for which the predicate--- @p@ returns 'True'.------ >skipDigit = skip isDigit--- > where isDigit w = w >= 48 && w <= 57-skip :: (Word8 -> Bool) -> Parser ()-skip p = do- h <- peekWord8'- if p h- then advance 1- else fail "skip"---- | The parser @satisfyWith f p@ transforms a byte, and succeeds if--- the predicate @p@ returns 'True' on the transformed value. The--- parser returns the transformed byte that was parsed.-satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a-satisfyWith f p = do- h <- peekWord8'- let c = f h- if p c- then advance 1 >> return c- else fail "satisfyWith"-{-# INLINE satisfyWith #-}--storable :: Storable a => Parser a-storable = hack undefined- where- hack :: Storable b => b -> Parser b- hack dummy = do- (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy)- return . inlinePerformIO . withForeignPtr fp $ \p ->- peek (castPtr $ p `plusPtr` o)---- | Consume exactly @n@ bytes of input.-take :: Int -> Parser ByteString-take n0 = do- let n = max n0 0- s <- ensure n- advance n >> return s-{-# INLINE take #-}---- | @string s@ parses a sequence of bytes that identically match--- @s@. Returns the parsed string (i.e. @s@). This parser consumes no--- input if it fails (even if a partial match).------ /Note/: The behaviour of this parser is different to that of the--- similarly-named parser in Parsec, as this one is all-or-nothing.--- To illustrate the difference, the following parser will fail under--- Parsec given an input of @\"for\"@:------ >string "foo" <|> string "for"------ The reason for its failure is that the first branch is a--- partial match, and will consume the letters @\'f\'@ and @\'o\'@--- before failing. In attoparsec, the above parser will /succeed/ on--- that input, because the failed first branch will consume nothing.-string :: ByteString -> Parser ByteString-string s = string_ (stringSuspended id) id s-{-# INLINE string #-}---- ASCII-specific but fast, oh yes.-toLower :: Word8 -> Word8-toLower w | w >= 65 && w <= 90 = w + 32- | otherwise = w---- | Satisfy a literal string, ignoring case.-stringCI :: ByteString -> Parser ByteString-stringCI s = string_ (stringSuspended lower) lower s- where lower = B8.map toLower-{-# INLINE stringCI #-}--string_ :: (forall r. ByteString -> ByteString -> Buffer -> Pos -> More- -> Failure r -> Success ByteString r -> Result r)- -> (ByteString -> ByteString)- -> ByteString -> Parser ByteString-string_ suspended f s0 = T.Parser $ \t pos more lose succ ->- let n = B.length s- s = f s0- in if lengthAtLeast pos n t- then let t' = substring pos (Pos n) t- in if s == f t'- then succ t (pos + Pos n) more t'- else lose t pos more [] "string"- else let t' = Buf.unsafeDrop (fromPos pos) t- in if f t' `B.isPrefixOf` s- then suspended s (B.drop (B.length t') s) t pos more lose succ- else lose t pos more [] "string"-{-# INLINE string_ #-}--stringSuspended :: (ByteString -> ByteString)- -> ByteString -> ByteString -> Buffer -> Pos -> More- -> Failure r- -> Success ByteString r- -> Result r-stringSuspended f s0 s t pos more lose succ =- runParser (demandInput_ >>= go) t pos more lose succ- where go s'0 = T.Parser $ \t' pos' more' lose' succ' ->- let m = B.length s- s' = f s'0- n = B.length s'- in if n >= m- then if B.unsafeTake m s' == s- then let o = Pos (B.length s0)- in succ' t' (pos' + o) more'- (substring pos' o t')- else lose' t' pos' more' [] "string"- else if s' == B.unsafeTake n s- then stringSuspended f s0 (B.unsafeDrop n s)- t' pos' more' lose' succ'- else lose' t' pos' more' [] "string"---- | Skip past input for as long as the predicate returns 'True'.-skipWhile :: (Word8 -> Bool) -> Parser ()-skipWhile p = go- where- go = do- t <- B8.takeWhile p <$> get- continue <- inputSpansChunks (B.length t)- when continue go-{-# INLINE skipWhile #-}---- | Consume input as long as the predicate returns 'False'--- (i.e. until it returns 'True'), and return the consumed input.------ This parser does not fail. It will return an empty string if the--- predicate returns 'True' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs. Careless use will thus result--- in an infinite loop.-takeTill :: (Word8 -> Bool) -> Parser ByteString-takeTill p = takeWhile (not . p)-{-# INLINE takeTill #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser does not fail. It will return an empty string if the--- predicate returns 'False' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs. Careless use will thus result--- in an infinite loop.-takeWhile :: (Word8 -> Bool) -> Parser ByteString-takeWhile p = do- s <- B8.takeWhile p <$> get- continue <- inputSpansChunks (B.length s)- if continue- then takeWhileAcc p [s]- else return s-{-# INLINE takeWhile #-}--takeWhileAcc :: (Word8 -> Bool) -> [ByteString] -> Parser ByteString-takeWhileAcc p = go- where- go acc = do- s <- B8.takeWhile p <$> get- continue <- inputSpansChunks (B.length s)- if continue- then go (s:acc)- else return $ concatReverse (s:acc)-{-# INLINE takeWhileAcc #-}--takeRest :: Parser [ByteString]-takeRest = go []- where- go acc = do- input <- wantInput- if input- then do- s <- get- advance (B.length s)- go (s:acc)- else return (reverse acc)---- | Consume all remaining input and return it as a single string.-takeByteString :: Parser ByteString-takeByteString = B.concat `fmap` takeRest---- | Consume all remaining input and return it as a single string.-takeLazyByteString :: Parser L.ByteString-takeLazyByteString = L.fromChunks `fmap` takeRest--data T s = T {-# UNPACK #-} !Int s--scan_ :: (s -> [ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s)- -> Parser r-scan_ f s0 p = go [] s0- where- go acc s1 = do- let scanner (B.PS fp off len) =- withForeignPtr fp $ \ptr0 -> do- let start = ptr0 `plusPtr` off- end = start `plusPtr` len- inner ptr !s- | ptr < end = do- w <- peek ptr- case p s w of- Just s' -> inner (ptr `plusPtr` 1) s'- _ -> done (ptr `minusPtr` start) s- | otherwise = done (ptr `minusPtr` start) s- done !i !s = return (T i s)- inner start s1- bs <- get- let T i s' = inlinePerformIO $ scanner bs- !h = B.unsafeTake i bs- continue <- inputSpansChunks i- if continue- then go (h:acc) s'- else f s' (h:acc)-{-# INLINE scan_ #-}---- | A stateful scanner. The predicate consumes and transforms a--- state argument, and each transformed state is passed to successive--- invocations of the predicate on each byte of the input until one--- returns 'Nothing' or the input ends.------ This parser does not fail. It will return an empty string if the--- predicate returns 'Nothing' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs. Careless use will thus result--- in an infinite loop.-scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString-scan = scan_ $ \_ chunks -> return $! concatReverse chunks-{-# INLINE scan #-}---- | Like 'scan', but generalized to return the final state of the--- scanner.-runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s)-runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)-{-# INLINE runScanner #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser requires the predicate to succeed on at least one byte--- of input: it will fail if the predicate never returns 'True' or if--- there is no input left.-takeWhile1 :: (Word8 -> Bool) -> Parser ByteString-takeWhile1 p = do- (`when` demandInput) =<< endOfChunk- s <- B8.takeWhile p <$> get- let len = B.length s- if len == 0- then fail "takeWhile1"- else do- advance len- eoc <- endOfChunk- if eoc- then takeWhileAcc p [s]- else return s-{-# INLINE takeWhile1 #-}---- | Match any byte in a set.------ >vowel = inClass "aeiou"------ Range notation is supported.------ >halfAlphabet = inClass "a-nA-N"------ To add a literal @\'-\'@ to a set, place it at the beginning or end--- of the string.-inClass :: String -> Word8 -> Bool-inClass s = (`memberWord8` mySet)- where mySet = charClass s- {-# NOINLINE mySet #-}-{-# INLINE inClass #-}---- | Match any byte not in a set.-notInClass :: String -> Word8 -> Bool-notInClass s = not . inClass s-{-# INLINE notInClass #-}---- | Match any byte.-anyWord8 :: Parser Word8-anyWord8 = satisfy $ const True-{-# INLINE anyWord8 #-}---- | Match a specific byte.-word8 :: Word8 -> Parser Word8-word8 c = satisfy (== c) <?> show c-{-# INLINE word8 #-}---- | Match any byte except the given one.-notWord8 :: Word8 -> Parser Word8-notWord8 c = satisfy (/= c) <?> "not " ++ show c-{-# INLINE notWord8 #-}---- | Match any byte, to perform lookahead. Returns 'Nothing' if end of--- input has been reached. Does not consume any input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs. Careless use will thus result--- in an infinite loop.-peekWord8 :: Parser (Maybe Word8)-peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ ->- case () of- _| pos_ < Buf.length t ->- let !w = Buf.unsafeIndex t pos_- in succ t pos more (Just w)- | more == Complete ->- succ t pos more Nothing- | otherwise ->- let succ' t' pos' more' = let !w = Buf.unsafeIndex t' pos_- in succ t' pos' more' (Just w)- lose' t' pos' more' = succ t' pos' more' Nothing- in prompt t pos more lose' succ'-{-# INLINE peekWord8 #-}---- | Match any byte, to perform lookahead. Does not consume any--- input, but will fail if end of input has been reached.-peekWord8' :: Parser Word8-peekWord8' = T.Parser $ \t pos more lose succ ->- if lengthAtLeast pos 1 t- then succ t pos more (Buf.unsafeIndex t (fromPos pos))- else let succ' t' pos' more' bs' = succ t' pos' more' $! B.unsafeHead bs'- in ensureSuspended 1 t pos more lose succ'-{-# INLINE peekWord8' #-}---- | Match either a single newline character @\'\\n\'@, or a carriage--- return followed by a newline character @\"\\r\\n\"@.-endOfLine :: Parser ()-endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ())---- | Terminal failure continuation.-failK :: Failure a-failK t (Pos pos) _more stack msg = Fail (Buf.unsafeDrop pos t) stack msg-{-# INLINE failK #-}---- | Terminal success continuation.-successK :: Success a a-successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a-{-# INLINE successK #-}---- | Run a parser.-parse :: Parser a -> ByteString -> Result a-parse m s = T.runParser m (buffer s) (Pos 0) Incomplete failK successK-{-# INLINE parse #-}---- | Run a parser that cannot be resupplied via a 'Partial' result.------ This function does not force a parser to consume all of its input.--- Instead, any residual input will be discarded. To force a parser--- to consume all of its input, use something like this:------ @---'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput')--- @-parseOnly :: Parser a -> ByteString -> Either String a-parseOnly m s = case T.runParser m (buffer s) (Pos 0) Complete failK successK of- Fail _ [] err -> Left err- Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)- Done _ a -> Right a- _ -> error "parseOnly: impossible error!"-{-# INLINE parseOnly #-}--get :: Parser ByteString-get = T.Parser $ \t pos more _lose succ ->- succ t pos more (Buf.unsafeDrop (fromPos pos) t)-{-# INLINE get #-}--endOfChunk :: Parser Bool-endOfChunk = T.Parser $ \t pos more _lose succ ->- succ t pos more (fromPos pos == Buf.length t)-{-# INLINE endOfChunk #-}--inputSpansChunks :: Int -> Parser Bool-inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->- let pos = pos_ + Pos i- in if fromPos pos < Buf.length t || more == Complete- then succ t pos more False- else let lose' t' pos' more' = succ t' pos' more' False- succ' t' pos' more' = succ t' pos' more' True- in prompt t pos more lose' succ'-{-# INLINE inputSpansChunks #-}--advance :: Int -> Parser ()-advance n = T.Parser $ \t pos more _lose succ ->- succ t (pos + Pos n) more ()-{-# INLINE advance #-}--ensureSuspended :: Int -> Buffer -> Pos -> More- -> Failure r- -> Success ByteString r- -> Result r-ensureSuspended n t pos more lose succ =- runParser (demandInput >> go) t pos more lose succ- where go = T.Parser $ \t' pos' more' lose' succ' ->- if lengthAtLeast pos' n t'- then succ' t' pos' more' (substring pos (Pos n) t')- else runParser (demandInput >> go) t' pos' more' lose' succ'---- | If at least @n@ elements of input are available, return the--- current input, otherwise fail.-ensure :: Int -> Parser ByteString-ensure n = T.Parser $ \t pos more lose succ ->- if lengthAtLeast pos n t- then succ t pos more (substring pos (Pos n) t)- -- The uncommon case is kept out-of-line to reduce code size:- else ensureSuspended n t pos more lose succ-{-# INLINE ensure #-}---- | Return both the result of a parse and the portion of the input--- that was consumed while it was being parsed.-match :: Parser a -> Parser (ByteString, a)-match p = T.Parser $ \t pos more lose succ ->- let succ' t' pos' more' a =- succ t' pos' more' (substring pos (pos'-pos) t', a)- in runParser p t pos more lose succ'--lengthAtLeast :: Pos -> Int -> Buffer -> Bool-lengthAtLeast (Pos pos) n bs = Buf.length bs >= pos + n-{-# INLINE lengthAtLeast #-}--substring :: Pos -> Pos -> Buffer -> ByteString-substring (Pos pos) (Pos n) = Buf.substring pos n-{-# INLINE substring #-}
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs
@@ -1,233 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-} -- Imports internal modules-#endif--- |--- Module : Data.Attoparsec.Combinator--- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : portable------ Useful parser combinators, similar to those provided by Parsec.-module Data.Attoparsec.Combinator- (- -- * Combinators- try- , (<?>)- , choice- , count- , option- , many'- , many1- , many1'- , manyTill- , manyTill'- , sepBy- , sepBy'- , sepBy1- , sepBy1'- , skipMany- , skipMany1- , eitherP- , feed- , satisfyElem- , endOfInput- , atEnd- , lookAhead- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative(..), (<$>))-import Data.Monoid (Monoid(mappend))-#endif-import Control.Applicative (Alternative(..), empty, liftA2, many, (<|>))-import Control.Monad (MonadPlus(..))-import Data.Attoparsec.Internal.Types (Parser(..), IResult(..))-import Data.Attoparsec.Internal (endOfInput, atEnd, satisfyElem)-import Data.ByteString (ByteString)-import Prelude hiding (succ)---- | Attempt a parse, and if it fails, rewind the input so that no--- input appears to have been consumed.------ This combinator is provided for compatibility with Parsec.--- attoparsec parsers always backtrack on failure.-try :: Parser i a -> Parser i a-try p = p-{-# INLINE try #-}---- | Name the parser, in case failure occurs.-(<?>) :: Parser i a- -> String -- ^ the name to use if parsing fails- -> Parser i a-p <?> msg0 = Parser $ \t pos more lose succ ->- let lose' t' pos' more' strs msg = lose t' pos' more' (msg0:strs) msg- in runParser p t pos more lose' succ-{-# INLINE (<?>) #-}-infix 0 <?>---- | @choice ps@ tries to apply the actions in the list @ps@ in order,--- until one of them succeeds. Returns the value of the succeeding--- action.-choice :: Alternative f => [f a] -> f a-choice = foldr (<|>) empty-{-# SPECIALIZE choice :: [Parser ByteString a]- -> Parser ByteString a #-}---- | @option x p@ tries to apply action @p@. If @p@ fails without--- consuming input, it returns the value @x@, otherwise the value--- returned by @p@.------ > priority = option 0 (digitToInt <$> digit)-option :: Alternative f => a -> f a -> f a-option x p = p <|> pure x-{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-}---- | A version of 'liftM2' that is strict in the result of its first--- action.-liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c-liftM2' f a b = do- !x <- a- y <- b- return (f x y)-{-# INLINE liftM2' #-}---- | @many' p@ applies the action @p@ /zero/ or more times. Returns a--- list of the returned values of @p@. The value returned by @p@ is--- forced to WHNF.------ > word = many' letter-many' :: (MonadPlus m) => m a -> m [a]-many' p = many_p- where many_p = some_p `mplus` return []- some_p = liftM2' (:) p many_p-{-# INLINE many' #-}---- | @many1 p@ applies the action @p@ /one/ or more times. Returns a--- list of the returned values of @p@.------ > word = many1 letter-many1 :: Alternative f => f a -> f [a]-many1 p = liftA2 (:) p (many p)-{-# INLINE many1 #-}---- | @many1' p@ applies the action @p@ /one/ or more times. Returns a--- list of the returned values of @p@. The value returned by @p@ is--- forced to WHNF.------ > word = many1' letter-many1' :: (MonadPlus m) => m a -> m [a]-many1' p = liftM2' (:) p (many' p)-{-# INLINE many1' #-}---- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@.------ > commaSep p = p `sepBy` (char ',')-sepBy :: Alternative f => f a -> f s -> f [a]-sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []-{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s- -> Parser ByteString [a] #-}---- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@. The value--- returned by @p@ is forced to WHNF.------ > commaSep p = p `sepBy'` (char ',')-sepBy' :: (MonadPlus m) => m a -> m s -> m [a]-sepBy' p s = scan `mplus` return []- where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return [])-{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s- -> Parser ByteString [a] #-}---- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@.------ > commaSep p = p `sepBy1` (char ',')-sepBy1 :: Alternative f => f a -> f s -> f [a]-sepBy1 p s = scan- where scan = liftA2 (:) p ((s *> scan) <|> pure [])-{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s- -> Parser ByteString [a] #-}---- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@. The value--- returned by @p@ is forced to WHNF.------ > commaSep p = p `sepBy1'` (char ',')-sepBy1' :: (MonadPlus m) => m a -> m s -> m [a]-sepBy1' p s = scan- where scan = liftM2' (:) p ((s >> scan) `mplus` return [])-{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s- -> Parser ByteString [a] #-}---- | @manyTill p end@ applies action @p@ /zero/ or more times until--- action @end@ succeeds, and returns the list of values returned by--- @p@. This can be used to scan comments:------ > simpleComment = string "<!--" *> manyTill anyChar (string "-->")------ (Note the overlapping parsers @anyChar@ and @string \"-->\"@.--- While this will work, it is not very efficient, as it will cause a--- lot of backtracking.)-manyTill :: Alternative f => f a -> f b -> f [a]-manyTill p end = scan- where scan = (end *> pure []) <|> liftA2 (:) p scan-{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b- -> Parser ByteString [a] #-}---- | @manyTill' p end@ applies action @p@ /zero/ or more times until--- action @end@ succeeds, and returns the list of values returned by--- @p@. This can be used to scan comments:------ > simpleComment = string "<!--" *> manyTill' anyChar (string "-->")------ (Note the overlapping parsers @anyChar@ and @string \"-->\"@.--- While this will work, it is not very efficient, as it will cause a--- lot of backtracking.)------ The value returned by @p@ is forced to WHNF.-manyTill' :: (MonadPlus m) => m a -> m b -> m [a]-manyTill' p end = scan- where scan = (end >> return []) `mplus` liftM2' (:) p scan-{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b- -> Parser ByteString [a] #-}---- | Skip zero or more instances of an action.-skipMany :: Alternative f => f a -> f ()-skipMany p = scan- where scan = (p *> scan) <|> pure ()-{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-}---- | Skip one or more instances of an action.-skipMany1 :: Alternative f => f a -> f ()-skipMany1 p = p *> skipMany p-{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-}---- | Apply the given action repeatedly, returning every result.-count :: Monad m => Int -> m a -> m [a]-count n p = sequence (replicate n p)-{-# INLINE count #-}---- | Combine two alternatives.-eitherP :: (Alternative f) => f a -> f b -> f (Either a b)-eitherP a b = (Left <$> a) <|> (Right <$> b)-{-# INLINE eitherP #-}---- | If a parser has returned a 'T.Partial' result, supply it with more--- input.-feed :: Monoid i => IResult i r -> i -> IResult i r-feed (Fail t ctxs msg) d = Fail (mappend t d) ctxs msg-feed (Partial k) d = k d-feed (Done t r) d = Done (mappend t d) r-{-# INLINE feed #-}---- | Apply a parser without consuming any input.-lookAhead :: Parser i a -> Parser i a-lookAhead p = Parser $ \t pos more lose succ ->- let succ' t' _pos' more' = succ t' pos more'- in runParser p t pos more lose succ'-{-# INLINE lookAhead #-}
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs
@@ -1,157 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}--- |--- Module : Data.Attoparsec.Internal--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Simple, efficient parser combinators, loosely based on the Parsec--- library.--module Data.Attoparsec.Internal- ( compareResults- , prompt- , demandInput- , demandInput_- , wantInput- , endOfInput- , atEnd- , satisfyElem- , concatReverse- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Monoid (Monoid, mconcat)-#endif-import Data.Attoparsec.Internal.Types-import Data.ByteString (ByteString)-import Prelude hiding (succ)---- | Compare two 'IResult' values for equality.------ If both 'IResult's are 'Partial', the result will be 'Nothing', as--- they are incomplete and hence their equality cannot be known.--- (This is why there is no 'Eq' instance for 'IResult'.)-compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool-compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) =- Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1)-compareResults (Done t0 r0) (Done t1 r1) =- Just (t0 == t1 && r0 == r1)-compareResults (Partial _) (Partial _) = Nothing-compareResults _ _ = Just False---- | Ask for input. If we receive any, pass the augmented input to a--- success continuation, otherwise to a failure continuation.-prompt :: Chunk t- => State t -> Pos -> More- -> (State t -> Pos -> More -> IResult t r)- -> (State t -> Pos -> More -> IResult t r)- -> IResult t r-prompt t pos _more lose succ = Partial $ \s ->- if nullChunk s- then lose t pos Complete- else succ (pappendChunk t s) pos Incomplete-{-# SPECIALIZE prompt :: State ByteString -> Pos -> More- -> (State ByteString -> Pos -> More- -> IResult ByteString r)- -> (State ByteString -> Pos -> More- -> IResult ByteString r)- -> IResult ByteString r #-}---- | Immediately demand more input via a 'Partial' continuation--- result.-demandInput :: Chunk t => Parser t ()-demandInput = Parser $ \t pos more lose succ ->- case more of- Complete -> lose t pos more [] "not enough input"- _ -> let lose' _ pos' more' = lose t pos' more' [] "not enough input"- succ' t' pos' more' = succ t' pos' more' ()- in prompt t pos more lose' succ'-{-# SPECIALIZE demandInput :: Parser ByteString () #-}---- | Immediately demand more input via a 'Partial' continuation--- result. Return the new input.-demandInput_ :: Chunk t => Parser t t-demandInput_ = Parser $ \t pos more lose succ ->- case more of- Complete -> lose t pos more [] "not enough input"- _ -> Partial $ \s ->- if nullChunk s- then lose t pos Complete [] "not enough input"- else succ (pappendChunk t s) pos more s-{-# SPECIALIZE demandInput_ :: Parser ByteString ByteString #-}---- | This parser always succeeds. It returns 'True' if any input is--- available either immediately or on demand, and 'False' if the end--- of all input has been reached.-wantInput :: forall t . Chunk t => Parser t Bool-wantInput = Parser $ \t pos more _lose succ ->- case () of- _ | pos < atBufferEnd (undefined :: t) t -> succ t pos more True- | more == Complete -> succ t pos more False- | otherwise -> let lose' t' pos' more' = succ t' pos' more' False- succ' t' pos' more' = succ t' pos' more' True- in prompt t pos more lose' succ'-{-# INLINE wantInput #-}---- | Match only if all input has been consumed.-endOfInput :: forall t . Chunk t => Parser t ()-endOfInput = Parser $ \t pos more lose succ ->- case () of- _| pos < atBufferEnd (undefined :: t) t -> lose t pos more [] "endOfInput"- | more == Complete -> succ t pos more ()- | otherwise ->- let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()- succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"- in runParser demandInput t pos more lose' succ'-{-# SPECIALIZE endOfInput :: Parser ByteString () #-}---- | Return an indication of whether the end of input has been--- reached.-atEnd :: Chunk t => Parser t Bool-atEnd = not <$> wantInput-{-# INLINE atEnd #-}--satisfySuspended :: forall t r . Chunk t- => (ChunkElem t -> Bool)- -> State t -> Pos -> More- -> Failure t (State t) r- -> Success t (State t) (ChunkElem t) r- -> IResult t r-satisfySuspended p t pos more lose succ =- runParser (demandInput >> go) t pos more lose succ- where go = Parser $ \t' pos' more' lose' succ' ->- case bufferElemAt (undefined :: t) pos' t' of- Just (e, l) | p e -> succ' t' (pos' + Pos l) more' e- | otherwise -> lose' t' pos' more' [] "satisfyElem"- Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ'-{-# SPECIALIZE satisfySuspended :: (ChunkElem ByteString -> Bool)- -> State ByteString -> Pos -> More- -> Failure ByteString (State ByteString) r- -> Success ByteString (State ByteString)- (ChunkElem ByteString) r- -> IResult ByteString r #-}---- | The parser @satisfyElem p@ succeeds for any chunk element for which the--- predicate @p@ returns 'True'. Returns the element that is--- actually parsed.-satisfyElem :: forall t . Chunk t- => (ChunkElem t -> Bool) -> Parser t (ChunkElem t)-satisfyElem p = Parser $ \t pos more lose succ ->- case bufferElemAt (undefined :: t) pos t of- Just (e, l) | p e -> succ t (pos + Pos l) more e- | otherwise -> lose t pos more [] "satisfyElem"- Nothing -> satisfySuspended p t pos more lose succ-{-# INLINE satisfyElem #-}---- | Concatenate a monoid after reversing its elements. Used to--- glue together a series of textual chunks that have been accumulated--- \"backwards\".-concatReverse :: Monoid m => [m] -> m-concatReverse [x] = x-concatReverse xs = mconcat (reverse xs)-{-# INLINE concatReverse #-}
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings,- RecordWildCards, MagicHash, UnboxedTuples #-}--module Data.Attoparsec.Internal.Fhthagn- (- inlinePerformIO- ) where--import GHC.Base (realWorld#)-import GHC.IO (IO(IO))---- | Just like unsafePerformIO, but we inline it. Big performance gains as--- it exposes lots of things to further inlining. /Very unsafe/. In--- particular, you should do no memory allocation inside an--- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.-inlinePerformIO :: IO a -> a-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-{-# INLINE inlinePerformIO #-}
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs
@@ -1,243 +0,0 @@-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,- Rank2Types, RecordWildCards, TypeFamilies #-}--- |--- Module : Data.Attoparsec.Internal.Types--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Simple, efficient parser combinators, loosely based on the Parsec--- library.--module Data.Attoparsec.Internal.Types- (- Parser(..)- , State- , Failure- , Success- , Pos(..)- , IResult(..)- , More(..)- , (<>)- , Chunk(..)- ) where--import Control.Applicative as App (Applicative(..), (<$>))-import Control.Applicative (Alternative(..))-import Control.DeepSeq (NFData(rnf))-import Control.Monad (MonadPlus(..))-import qualified Control.Monad.Fail as Fail (MonadFail(..))-import Data.Monoid as Mon (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Data.Word (Word8)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.ByteString.Internal (w2c)-import Prelude hiding (getChar, succ)-import qualified Data.Attoparsec.ByteString.Buffer as B--newtype Pos = Pos { fromPos :: Int }- deriving (Eq, Ord, Show, Num)---- | The result of a parse. This is parameterised over the type @i@--- of string that was processed.------ This type is an instance of 'Functor', where 'fmap' transforms the--- value in a 'Done' result.-data IResult i r =- Fail i [String] String- -- ^ The parse failed. The @i@ parameter is the input that had- -- not yet been consumed when the failure occurred. The- -- @[@'String'@]@ is a list of contexts in which the error- -- occurred. The 'String' is the message describing the error, if- -- any.- | Partial (i -> IResult i r)- -- ^ Supply this continuation with more input so that the parser- -- can resume. To indicate that no more input is available, pass- -- an empty string to the continuation.- --- -- __Note__: if you get a 'Partial' result, do not call its- -- continuation more than once.- | Done i r- -- ^ The parse succeeded. The @i@ parameter is the input that had- -- not yet been consumed (if any) when the parse succeeded.--instance (Show i, Show r) => Show (IResult i r) where- showsPrec d ir = showParen (d > 10) $- case ir of- (Fail t stk msg) -> showString "Fail" . f t . f stk . f msg- (Partial _) -> showString "Partial _"- (Done t r) -> showString "Done" . f t . f r- where f :: Show a => a -> ShowS- f x = showChar ' ' . showsPrec 11 x--instance (NFData i, NFData r) => NFData (IResult i r) where- rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg- rnf (Partial _) = ()- rnf (Done t r) = rnf t `seq` rnf r- {-# INLINE rnf #-}--instance Functor (IResult i) where- fmap _ (Fail t stk msg) = Fail t stk msg- fmap f (Partial k) = Partial (fmap f . k)- fmap f (Done t r) = Done t (f r)---- | The core parser type. This is parameterised over the type @i@--- of string being processed.------ This type is an instance of the following classes:------ * 'Monad', where 'fail' throws an exception (i.e. fails) with an--- error message.------ * 'Functor' and 'Applicative', which follow the usual definitions.------ * 'MonadPlus', where 'mzero' fails (with no error message) and--- 'mplus' executes the right-hand parser if the left-hand one--- fails. When the parser on the right executes, the input is reset--- to the same state as the parser on the left started with. (In--- other words, attoparsec is a backtracking parser that supports--- arbitrary lookahead.)------ * 'Alternative', which follows 'MonadPlus'.-newtype Parser i a = Parser {- runParser :: forall r.- State i -> Pos -> More- -> Failure i (State i) r- -> Success i (State i) a r- -> IResult i r- }--type family State i-type instance State ByteString = B.Buffer--type Failure i t r = t -> Pos -> More -> [String] -> String- -> IResult i r-type Success i t a r = t -> Pos -> More -> a -> IResult i r---- | Have we read all available input?-data More = Complete | Incomplete- deriving (Eq, Show)--instance Semigroup More where- c@Complete <> _ = c- _ <> m = m--instance Mon.Monoid More where- mappend = (<>)- mempty = Incomplete--instance Monad (Parser i) where- fail = Fail.fail- {-# INLINE fail #-}-- return = App.pure- {-# INLINE return #-}-- m >>= k = Parser $ \t !pos more lose succ ->- let succ' t' !pos' more' a = runParser (k a) t' pos' more' lose succ- in runParser m t pos more lose succ'- {-# INLINE (>>=) #-}-- (>>) = (*>)- {-# INLINE (>>) #-}---instance Fail.MonadFail (Parser i) where- fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg- where msg = "Failed reading: " ++ err- {-# INLINE fail #-}--plus :: Parser i a -> Parser i a -> Parser i a-plus f g = Parser $ \t pos more lose succ ->- let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ- in runParser f t pos more lose' succ--instance MonadPlus (Parser i) where- mzero = fail "mzero"- {-# INLINE mzero #-}- mplus = plus--instance Functor (Parser i) where- fmap f p = Parser $ \t pos more lose succ ->- let succ' t' pos' more' a = succ t' pos' more' (f a)- in runParser p t pos more lose succ'- {-# INLINE fmap #-}--apP :: Parser i (a -> b) -> Parser i a -> Parser i b-apP d e = do- b <- d- a <- e- return (b a)-{-# INLINE apP #-}--instance Applicative (Parser i) where- pure v = Parser $ \t pos more _lose succ -> succ t pos more v- {-# INLINE pure #-}- (<*>) = apP- {-# INLINE (<*>) #-}- m *> k = m >>= \_ -> k- {-# INLINE (*>) #-}- x <* y = x >>= \a -> y >> pure a- {-# INLINE (<*) #-}--instance Semigroup (Parser i a) where- (<>) = plus- {-# INLINE (<>) #-}--instance Monoid (Parser i a) where- mempty = fail "mempty"- {-# INLINE mempty #-}- mappend = (<>)- {-# INLINE mappend #-}--instance Alternative (Parser i) where- empty = fail "empty"- {-# INLINE empty #-}-- (<|>) = plus- {-# INLINE (<|>) #-}-- many v = many_v- where many_v = some_v <|> pure []- some_v = (:) App.<$> v <*> many_v- {-# INLINE many #-}-- some v = some_v- where- many_v = some_v <|> pure []- some_v = (:) <$> v <*> many_v- {-# INLINE some #-}---- | A common interface for input chunks.-class Monoid c => Chunk c where- type ChunkElem c- -- | Test if the chunk is empty.- nullChunk :: c -> Bool- -- | Append chunk to a buffer.- pappendChunk :: State c -> c -> State c- -- | Position at the end of a buffer. The first argument is ignored.- atBufferEnd :: c -> State c -> Pos- -- | Return the buffer element at the given position along with its length.- bufferElemAt :: c -> Pos -> State c -> Maybe (ChunkElem c, Int)- -- | Map an element to the corresponding character.- -- The first argument is ignored.- chunkElemToChar :: c -> ChunkElem c -> Char--instance Chunk ByteString where- type ChunkElem ByteString = Word8- nullChunk = BS.null- {-# INLINE nullChunk #-}- pappendChunk = B.pappend- {-# INLINE pappendChunk #-}- atBufferEnd _ = Pos . B.length- {-# INLINE atBufferEnd #-}- bufferElemAt _ (Pos i) buf- | i < B.length buf = Just (B.unsafeIndex buf i, 1)- | otherwise = Nothing- {-# INLINE bufferElemAt #-}- chunkElemToChar _ = w2c- {-# INLINE chunkElemToChar #-}
− vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs
@@ -1,137 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--- |--- Module : Data.Attoparsec.Number--- Copyright : Bryan O'Sullivan 2007-2015--- License : BSD3------ Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ This module is deprecated, and both the module and 'Number' type--- will be removed in the next major release. Use the--- <http://hackage.haskell.org/package/scientific scientific> package--- and the 'Data.Scientific.Scientific' type instead.------ A simple number type, useful for parsing both exact and inexact--- quantities without losing much precision.-module Data.Attoparsec.Number- {-# DEPRECATED "This module will be removed in the next major release." #-}- (- Number(..)- ) where--import Control.DeepSeq (NFData(rnf))-import Data.Data (Data)-import Data.Function (on)-import Data.Typeable (Typeable)---- | A numeric type that can represent integers accurately, and--- floating point numbers to the precision of a 'Double'.------ /Note/: this type is deprecated, and will be removed in the next--- major release. Use the 'Data.Scientific.Scientific' type instead.-data Number = I !Integer- | D {-# UNPACK #-} !Double- deriving (Typeable, Data)-{-# DEPRECATED Number "Use Scientific instead." #-}--instance Show Number where- show (I a) = show a- show (D a) = show a--instance NFData Number where- rnf (I _) = ()- rnf (D _) = ()- {-# INLINE rnf #-}--binop :: (Integer -> Integer -> a) -> (Double -> Double -> a)- -> Number -> Number -> a-binop _ d (D a) (D b) = d a b-binop i _ (I a) (I b) = i a b-binop _ d (D a) (I b) = d a (fromIntegral b)-binop _ d (I a) (D b) = d (fromIntegral a) b-{-# INLINE binop #-}--instance Eq Number where- (==) = binop (==) (==)- {-# INLINE (==) #-}-- (/=) = binop (/=) (/=)- {-# INLINE (/=) #-}--instance Ord Number where- (<) = binop (<) (<)- {-# INLINE (<) #-}-- (<=) = binop (<=) (<=)- {-# INLINE (<=) #-}-- (>) = binop (>) (>)- {-# INLINE (>) #-}-- (>=) = binop (>=) (>=)- {-# INLINE (>=) #-}-- compare = binop compare compare- {-# INLINE compare #-}--instance Num Number where- (+) = binop (((I$!).) . (+)) (((D$!).) . (+))- {-# INLINE (+) #-}-- (-) = binop (((I$!).) . (-)) (((D$!).) . (-))- {-# INLINE (-) #-}-- (*) = binop (((I$!).) . (*)) (((D$!).) . (*))- {-# INLINE (*) #-}-- abs (I a) = I $! abs a- abs (D a) = D $! abs a- {-# INLINE abs #-}-- negate (I a) = I $! negate a- negate (D a) = D $! negate a- {-# INLINE negate #-}-- signum (I a) = I $! signum a- signum (D a) = D $! signum a- {-# INLINE signum #-}-- fromInteger = (I$!) . fromInteger- {-# INLINE fromInteger #-}--instance Real Number where- toRational (I a) = fromIntegral a- toRational (D a) = toRational a- {-# INLINE toRational #-}--instance Fractional Number where- fromRational = (D$!) . fromRational- {-# INLINE fromRational #-}-- (/) = binop (((D$!).) . (/) `on` fromIntegral)- (((D$!).) . (/))- {-# INLINE (/) #-}-- recip (I a) = D $! recip (fromIntegral a)- recip (D a) = D $! recip a- {-# INLINE recip #-}--instance RealFrac Number where- properFraction (I a) = (fromIntegral a,0)- properFraction (D a) = case properFraction a of- (i,d) -> (i,D d)- {-# INLINE properFraction #-}- truncate (I a) = fromIntegral a- truncate (D a) = truncate a- {-# INLINE truncate #-}- round (I a) = fromIntegral a- round (D a) = round a- {-# INLINE round #-}- ceiling (I a) = fromIntegral a- ceiling (D a) = ceiling a- {-# INLINE ceiling #-}- floor (I a) = fromIntegral a- floor (D a) = floor a- {-# INLINE floor #-}
− vendor/attoparsec-0.13.1.0/LICENSE
@@ -1,30 +0,0 @@-Copyright (c) Lennart Kolmodin--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS-OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,-STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN-ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.