diff options
| author | Alexander Biehl <alexbiehl@gmail.com> | 2018-06-14 15:28:52 +0200 |
|---|---|---|
| committer | GitHub <noreply@github.com> | 2018-06-14 15:28:52 +0200 |
| commit | 6247ec8b5a5bc8145ce851dce11eb617a380381c (patch) | |
| tree | 7856c0dd1ddd0c1f3eef0422b0cd8e8a5a6b71cb /haddock-library | |
| parent | 9a7f539d0c20654ff394f2ff99836412a6844df1 (diff) | |
| parent | 095fa970b32c818ed4c06cefc00ba98aaff756fa (diff) | |
Merge pull request #857 from sjakobi/ghc-head-update-3
Update ghc-head
Diffstat (limited to 'haddock-library')
48 files changed, 1204 insertions, 2765 deletions
diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index 53d17f5e..e41b8087 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,9 +1,20 @@ -## Changes in version 1.4.6 +## Changes in version 1.6.0 - * to be released + * `MetaDoc` stores package name for since annotations + +## Changes in version 1.5.0.1 + + * Support for parsing unicode operators (#458) + +## Changes in version 1.5.0 * Bifunctor, Bifoldable and Bitraversable instances for DocH and MetaDoc + * Support for grid tables + * added `DocTable` constructor to `DocH` + * added `Table`, `TableCell` and `TableRow` data types + * added `markupTable` to `DocMarkupH` data type + ## Changes in version 1.4.5 * Move markup related data types to haddock-library diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs new file mode 100644 index 00000000..a4e4321f --- /dev/null +++ b/haddock-library/fixtures/Fixtures.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main (main) where + +import Control.Applicative ((<|>)) +import Control.Exception (IOException, catch) +import Control.Monad (when) +import Data.Foldable (traverse_) +import Data.List (foldl') +import Data.Traversable (for) +import GHC.Generics (Generic) +import Prelude () +import Prelude.Compat +import System.Directory (getDirectoryContents) +import System.Exit (exitFailure) +import System.FilePath +import System.IO + +import Data.TreeDiff +import Data.TreeDiff.Golden + +import qualified Options.Applicative as O + +import Documentation.Haddock.Types +import qualified Documentation.Haddock.Parser as Parse + +type Doc id = DocH () id + +data Fixture = Fixture + { fixtureName :: FilePath + , fixtureOutput :: FilePath + } + deriving Show + +data Result = Result + { _resultSuccess :: !Int + , _resultTotal :: !Int + } + deriving Show + +combineResults :: Result -> Result -> Result +combineResults (Result s t) (Result s' t') = Result (s + s') (t + t') + +readFixtures :: IO [Fixture] +readFixtures = do + let dir = "fixtures/examples" + files <- getDirectoryContents dir + let inputs = filter (\fp -> takeExtension fp == ".input") files + return $ flip map inputs $ \fp -> Fixture + { fixtureName = dir </> fp + , fixtureOutput = dir </> fp -<.> "parsed" + } + +goldenFixture + :: String + -> IO Expr + -> IO Expr + -> (Expr -> Expr -> IO (Maybe String)) + -> (Expr -> IO ()) + -> IO Result +goldenFixture name expect actual cmp wrt = do + putStrLn $ "running " ++ name + a <- actual + e <- expect `catch` handler a + mres <- cmp e a + case mres of + Nothing -> return (Result 1 1) + Just str -> do + putStrLn str + return (Result 0 1) + where + handler :: Expr -> IOException -> IO Expr + handler a exc = do + putStrLn $ "Caught " ++ show exc + putStrLn "Accepting the test" + wrt a + return a + +runFixtures :: [Fixture] -> IO () +runFixtures fixtures = do + results <- for fixtures $ \(Fixture i o) -> do + let name = takeBaseName i + let readDoc = do + input <- readFile i + return (parseString input) + ediffGolden goldenFixture name o readDoc + case foldl' combineResults (Result 0 0) results of + Result s t -> do + putStrLn $ "Fixtures: success " ++ show s ++ "; total " ++ show t + when (s /= t) exitFailure + +listFixtures :: [Fixture] -> IO () +listFixtures = traverse_ $ \(Fixture i _) -> do + let name = takeBaseName i + putStrLn name + +acceptFixtures :: [Fixture] -> IO () +acceptFixtures = traverse_ $ \(Fixture i o) -> do + input <- readFile i + let doc = parseString input + let actual = show (prettyExpr $ toExpr doc) ++ "\n" + writeFile o actual + +parseString :: String -> Doc String +parseString = Parse.toRegular . _doc . Parse.parseParas Nothing + +data Cmd = CmdRun | CmdAccept | CmdList + +main :: IO () +main = do + hSetBuffering stdout NoBuffering -- For interleaved output when debugging + runCmd =<< O.execParser opts + where + opts = O.info (O.helper <*> cmdParser) O.fullDesc + + cmdParser :: O.Parser Cmd + cmdParser = cmdRun <|> cmdAccept <|> cmdList <|> pure CmdRun + + cmdRun = O.flag' CmdRun $ mconcat + [ O.long "run" + , O.help "Run parser fixtures" + ] + + cmdAccept = O.flag' CmdAccept $ mconcat + [ O.long "accept" + , O.help "Run & accept parser fixtures" + ] + + cmdList = O.flag' CmdList $ mconcat + [ O.long "list" + , O.help "List fixtures" + ] + +runCmd :: Cmd -> IO () +runCmd CmdRun = readFixtures >>= runFixtures +runCmd CmdList = readFixtures >>= listFixtures +runCmd CmdAccept = readFixtures >>= acceptFixtures + +------------------------------------------------------------------------------- +-- Orphans +------------------------------------------------------------------------------- + +deriving instance Generic (DocH mod id) +instance (ToExpr mod, ToExpr id) => ToExpr (DocH mod id) + +deriving instance Generic (Header id) +instance ToExpr id => ToExpr (Header id) + +deriving instance Generic Hyperlink +instance ToExpr Hyperlink + +deriving instance Generic Picture +instance ToExpr Picture + +deriving instance Generic Example +instance ToExpr Example + +deriving instance Generic (Table id) +instance ToExpr id => ToExpr (Table id) + +deriving instance Generic (TableRow id) +instance ToExpr id => ToExpr (TableRow id) + +deriving instance Generic (TableCell id) +instance ToExpr id => ToExpr (TableCell id) diff --git a/haddock-library/fixtures/examples/definitionList.input b/haddock-library/fixtures/examples/definitionList.input new file mode 100644 index 00000000..e1bffb21 --- /dev/null +++ b/haddock-library/fixtures/examples/definitionList.input @@ -0,0 +1 @@ +[foo]: bar diff --git a/haddock-library/fixtures/examples/definitionList.parsed b/haddock-library/fixtures/examples/definitionList.parsed new file mode 100644 index 00000000..048aa141 --- /dev/null +++ b/haddock-library/fixtures/examples/definitionList.parsed @@ -0,0 +1 @@ +DocDefList [_×_ (DocString "foo") (DocString "bar")] diff --git a/haddock-library/fixtures/examples/identifier.input b/haddock-library/fixtures/examples/identifier.input new file mode 100644 index 00000000..c2c4af01 --- /dev/null +++ b/haddock-library/fixtures/examples/identifier.input @@ -0,0 +1 @@ +'foo' diff --git a/haddock-library/fixtures/examples/identifier.parsed b/haddock-library/fixtures/examples/identifier.parsed new file mode 100644 index 00000000..3405a5c9 --- /dev/null +++ b/haddock-library/fixtures/examples/identifier.parsed @@ -0,0 +1 @@ +DocParagraph (DocIdentifier "foo") diff --git a/haddock-library/fixtures/examples/identifierBackticks.input b/haddock-library/fixtures/examples/identifierBackticks.input new file mode 100644 index 00000000..347253a0 --- /dev/null +++ b/haddock-library/fixtures/examples/identifierBackticks.input @@ -0,0 +1 @@ +`foo` diff --git a/haddock-library/fixtures/examples/identifierBackticks.parsed b/haddock-library/fixtures/examples/identifierBackticks.parsed new file mode 100644 index 00000000..3405a5c9 --- /dev/null +++ b/haddock-library/fixtures/examples/identifierBackticks.parsed @@ -0,0 +1 @@ +DocParagraph (DocIdentifier "foo") diff --git a/haddock-library/fixtures/examples/link.input b/haddock-library/fixtures/examples/link.input new file mode 100644 index 00000000..a55c05a6 --- /dev/null +++ b/haddock-library/fixtures/examples/link.input @@ -0,0 +1 @@ +[link](http://example.com) diff --git a/haddock-library/fixtures/examples/link.parsed b/haddock-library/fixtures/examples/link.parsed new file mode 100644 index 00000000..0e85338c --- /dev/null +++ b/haddock-library/fixtures/examples/link.parsed @@ -0,0 +1,5 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just "link", + hyperlinkUrl = "http://example.com"}) diff --git a/haddock-library/fixtures/examples/linkInline.input b/haddock-library/fixtures/examples/linkInline.input new file mode 100644 index 00000000..eeca5a07 --- /dev/null +++ b/haddock-library/fixtures/examples/linkInline.input @@ -0,0 +1 @@ +Bla [link](http://example.com) diff --git a/haddock-library/fixtures/examples/linkInline.parsed b/haddock-library/fixtures/examples/linkInline.parsed new file mode 100644 index 00000000..43470d7b --- /dev/null +++ b/haddock-library/fixtures/examples/linkInline.parsed @@ -0,0 +1,6 @@ +DocParagraph + (DocAppend + (DocString "Bla ") + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just "link", hyperlinkUrl = "http://example.com"})) diff --git a/haddock-library/fixtures/examples/table-simple.input b/haddock-library/fixtures/examples/table-simple.input new file mode 100644 index 00000000..d9c49f87 --- /dev/null +++ b/haddock-library/fixtures/examples/table-simple.input @@ -0,0 +1,7 @@ ++------+--------------+------------------------------------------+ +| code | message | description | ++======+==============+==========================================+ +| 200 | @OK@ | operation successful | ++------+--------------+------------------------------------------+ +| 204 | @No Content@ | operation successful, no body returned | ++------+--------------+------------------------------------------+ diff --git a/haddock-library/fixtures/examples/table-simple.parsed b/haddock-library/fixtures/examples/table-simple.parsed new file mode 100644 index 00000000..b5e62453 --- /dev/null +++ b/haddock-library/fixtures/examples/table-simple.parsed @@ -0,0 +1,52 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " 200 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocAppend + (DocString " ") + (DocAppend + (DocMonospaced (DocString "OK")) + (DocString " ")), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + " operation successful ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " 204 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocAppend + (DocString " ") + (DocAppend + (DocMonospaced (DocString "No Content")) + (DocString " ")), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + " operation successful, no body returned ", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " code ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " message ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + " description ", + tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table1.input b/haddock-library/fixtures/examples/table1.input new file mode 100644 index 00000000..a007020c --- /dev/null +++ b/haddock-library/fixtures/examples/table1.input @@ -0,0 +1,12 @@ ++------------------------+------------+----------+----------+ +| Header row, column 1 | Header 2 | Header 3 | Header 4 | +| (header rows optional) | | | | ++========================+============+==========+==========+ +| body row 1, column 1 | column 2 | column 3 | column 4 | ++------------------------+------------+----------+----------+ +| body row 2 | Cells may span columns. | ++------------------------+------------+---------------------+ +| body row 3 | Cells may | \[ | ++------------------------+ span rows. | f(n) = \sum_{i=1} | +| body row 4 | | \] | ++------------------------+------------+---------------------+ diff --git a/haddock-library/fixtures/examples/table1.parsed b/haddock-library/fixtures/examples/table1.parsed new file mode 100644 index 00000000..2fa58fd8 --- /dev/null +++ b/haddock-library/fixtures/examples/table1.parsed @@ -0,0 +1,81 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 1, column 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 3, + tableCellContents = DocString " Cells may span columns. ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" Cells may \n", + " span rows. \n", + " "]), + tableCellRowspan = 2}, + TableCell + {tableCellColspan = 2, + tableCellContents = DocAppend + (DocString " ") + (DocAppend + (DocMathDisplay + (concat + [" \n", + " f(n) = \\sum_{i=1} \n", + " "])) + (DocString " ")), + tableCellRowspan = 2}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " body row 4 ", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" Header row, column 1 \n", + " (header rows optional) "]), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat [" Header 2 \n", " "]), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat [" Header 3 \n", " "]), + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat [" Header 4 \n", " "]), + tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table2.input b/haddock-library/fixtures/examples/table2.input new file mode 100644 index 00000000..aa5d0862 --- /dev/null +++ b/haddock-library/fixtures/examples/table2.input @@ -0,0 +1,7 @@ ++--------------+----------+-----------+-----------+ +| row 1, col 1 | column 2 | column 3 | column 4 | ++--------------+----------+-----------+-----------+ +| row 2 | | ++--------------+----------+-----------+-----------+ +| row 3 | | | | ++--------------+----------+-----------+-----------+ diff --git a/haddock-library/fixtures/examples/table2.parsed b/haddock-library/fixtures/examples/table2.parsed new file mode 100644 index 00000000..e3dbf0b4 --- /dev/null +++ b/haddock-library/fixtures/examples/table2.parsed @@ -0,0 +1,46 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 1, col 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 3, + tableCellContents = DocString " ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}]], + tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table3.input b/haddock-library/fixtures/examples/table3.input new file mode 100644 index 00000000..a6ca84ca --- /dev/null +++ b/haddock-library/fixtures/examples/table3.input @@ -0,0 +1,7 @@ ++--------------+----------+-----------+-----------+ +| row 1, col 1 | column 2 | column 3 | column 4 | ++--------------+----------+-----------+-----------+ +| row 2 | Use the command ``ls | more``. | ++--------------+----------+-----------+-----------+ +| row 3 | | | | ++--------------+----------+-----------+-----------+ diff --git a/haddock-library/fixtures/examples/table3.parsed b/haddock-library/fixtures/examples/table3.parsed new file mode 100644 index 00000000..cabff9cb --- /dev/null +++ b/haddock-library/fixtures/examples/table3.parsed @@ -0,0 +1,50 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 1, col 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 2, + tableCellContents = DocString " Use the command ``ls ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " more``. ", + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}]], + tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table4.input b/haddock-library/fixtures/examples/table4.input new file mode 100644 index 00000000..2c5611c8 --- /dev/null +++ b/haddock-library/fixtures/examples/table4.input @@ -0,0 +1,17 @@ +Single outer cell: + ++-------------+ +| outer | +| | ++-------+ | +| inner | | ++-------+-----+ + +Broken (only inner cell is rendered): + ++-------+-----+ +| inner | | ++-------+ | +| | +| outer | ++-------------+ diff --git a/haddock-library/fixtures/examples/table4.parsed b/haddock-library/fixtures/examples/table4.parsed new file mode 100644 index 00000000..cfdd6f0f --- /dev/null +++ b/haddock-library/fixtures/examples/table4.parsed @@ -0,0 +1,26 @@ +DocAppend + (DocParagraph (DocString "Single outer cell:")) + (DocAppend + (DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" outer \n", + " \n", + "-------+ \n", + " inner | "]), + tableCellRowspan = 1}]], + tableHeaderRows = []}) + (DocAppend + (DocParagraph (DocString "Broken (only inner cell is rendered):")) + (DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " inner ", + tableCellRowspan = 1}]], + tableHeaderRows = []}))) diff --git a/haddock-library/fixtures/examples/table5.input b/haddock-library/fixtures/examples/table5.input new file mode 100644 index 00000000..7cf26512 --- /dev/null +++ b/haddock-library/fixtures/examples/table5.input @@ -0,0 +1,8 @@ ++--------------+----------+-----------+-----------+ +| row 1, col 1 | column 2 | column 3 | column 4 | ++==============+==========+===========+===========+ +| row 2 | Use the command @ls | more@. | +| | | +| +----------+-----------+-----------+ +| row 3 | | | | ++--------------+----------+-----------+-----------+ diff --git a/haddock-library/fixtures/examples/table5.parsed b/haddock-library/fixtures/examples/table5.parsed new file mode 100644 index 00000000..9a547ad3 --- /dev/null +++ b/haddock-library/fixtures/examples/table5.parsed @@ -0,0 +1,53 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString + (concat + [" row 2 \n", + " \n", + " \n", + " row 3 "]), + tableCellRowspan = 2}, + TableCell + {tableCellColspan = 3, + tableCellContents = DocAppend + (DocString " Use the command ") + (DocAppend + (DocMonospaced (DocString "ls | more")) + (DocString + (concat + [". \n", + " "]))), + tableCellRowspan = 1}], + TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " ", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString " row 1, col 1 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 2 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 3 ", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString " column 4 ", + tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/url.input b/haddock-library/fixtures/examples/url.input new file mode 100644 index 00000000..5bfed0a1 --- /dev/null +++ b/haddock-library/fixtures/examples/url.input @@ -0,0 +1 @@ +<http://example.com/> diff --git a/haddock-library/fixtures/examples/url.parsed b/haddock-library/fixtures/examples/url.parsed new file mode 100644 index 00000000..0fbbbb30 --- /dev/null +++ b/haddock-library/fixtures/examples/url.parsed @@ -0,0 +1,4 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Nothing, hyperlinkUrl = "http://example.com/"}) diff --git a/haddock-library/fixtures/examples/urlLabel.input b/haddock-library/fixtures/examples/urlLabel.input new file mode 100644 index 00000000..729812e8 --- /dev/null +++ b/haddock-library/fixtures/examples/urlLabel.input @@ -0,0 +1 @@ +<http://example.com/ some link> diff --git a/haddock-library/fixtures/examples/urlLabel.parsed b/haddock-library/fixtures/examples/urlLabel.parsed new file mode 100644 index 00000000..d7e3a76c --- /dev/null +++ b/haddock-library/fixtures/examples/urlLabel.parsed @@ -0,0 +1,5 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just "some link", + hyperlinkUrl = "http://example.com/"}) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 535cff0e..df2dbf93 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: haddock-library -version: 1.4.6 +version: 1.6.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 @@ -8,28 +9,27 @@ description: Haddock is a documentation-generation tool for Haskell project if you can't release often. For interacting with Haddock itself, see the ‘haddock’ package. license: BSD3 -license-file: LICENSE +license-files: LICENSE maintainer: 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 -cabal-version: >= 2.0 extra-source-files: CHANGES.md + library default-language: Haskell2010 build-depends: base >= 4.5 && < 4.13 , bytestring >= 0.9.2.1 && < 0.11 + , containers >= 0.4.2.1 && < 0.6 , transformers >= 0.3.0 && < 0.6 - - -- internal sub-lib - build-depends: attoparsec + , text >= 1.2.3.0 && < 1.3 + , parsec >= 3.1.13.0 && < 3.2 hs-source-dirs: src - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 exposed-modules: Documentation.Haddock.Doc @@ -42,44 +42,9 @@ library other-modules: 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.13 - , 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 - - other-modules: - Data.Attoparsec - Data.Attoparsec.ByteString.Buffer - Data.Attoparsec.ByteString.FastSet - Data.Attoparsec.ByteString.Internal - Data.Attoparsec.Combinator - 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 + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 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 test-suite spec @@ -106,23 +71,37 @@ test-suite spec Documentation.Haddock.Utf8Spec build-depends: - base-compat ^>= 0.9.3 + base >= 4.5 && < 4.12 + , base-compat >= 0.9.3 && < 0.11 + , bytestring >= 0.9.2.1 && < 0.11 + , containers >= 0.4.2.1 && < 0.6 , transformers >= 0.3.0 && < 0.6 - , hspec ^>= 2.4.4 - , QuickCheck ^>= 2.10 + , hspec >= 2.4.4 && < 2.6 + , QuickCheck ^>= 2.11 + , text >= 1.2.3.0 && < 1.3 + , parsec >= 3.1.13.0 && < 3.2 + , deepseq >= 1.3 && < 1.5 - -- internal sub-lib - build-depends: attoparsec + build-tool-depends: + hspec-discover:hspec-discover >= 2.4.4 && < 2.6 - -- Versions for the dependencies below are transitively pinned by - -- dependency on haddock-library:lib:attoparsec +test-suite fixtures + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Fixtures.hs + ghc-options: -Wall -O0 + hs-source-dirs: fixtures build-depends: - base - , bytestring - , deepseq - - build-tool-depends: - hspec-discover:hspec-discover ^>= 2.4.4 + base >= 4.5 && < 4.12 + , base-compat >= 0.9.3 && < 0.11 + , 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 source-repository head type: git diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs index 66bd1c97..297d30d6 100644 --- a/haddock-library/src/Documentation/Haddock/Doc.hs +++ b/haddock-library/src/Documentation/Haddock/Doc.hs @@ -27,16 +27,16 @@ metaDocAppend (MetaDoc { _meta = m, _doc = d }) (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) diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs index 1bf6c084..da8edcd4 100644 --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -30,6 +30,7 @@ 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) @@ -59,5 +60,6 @@ idMarkup = Markup { markupMathDisplay = DocMathDisplay, markupProperty = DocProperty, markupExample = DocExamples, - markupHeader = DocHeader + markupHeader = DocHeader, + markupTable = DocTable } diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 8dc2a801..d79da40b 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Documentation.Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013-2014, @@ -15,28 +16,63 @@ -- 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, isAsciiUpper) -import Data.List (stripPrefix, intercalate, unfoldr) -import Data.Maybe (fromMaybe) +import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) +import Data.List (intercalate, unfoldr, elemIndex, notElem) +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.Parser.Monad import Documentation.Haddock.Parser.Util import Documentation.Haddock.Types -import Documentation.Haddock.Utf8 import Prelude hiding (takeWhile) +import qualified Prelude as P + +import qualified Text.Parsec as Parsec +import Text.Parsec (try) + +import qualified Data.Text as T +import Data.Text (Text) + +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory (..), + generalCategory) +#endif -- $setup -- >>> :set -XOverloadedStrings +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> c `notElem` ("'\"" :: String) + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif + -- | Identifier string surrounded with opening and closing quotes/backticks. type Identifier = (Char, String, Char) @@ -79,47 +115,72 @@ overIdentifier f d = g d g (DocProperty x) = DocProperty x g (DocExamples x) = DocExamples x 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 + +-- | 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') -parseStringBS :: BS.ByteString -> DocH mod Identifier -parseStringBS = snd . parse p +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 + , hyperlink + , bold + , emphasis + , encodedChar + , string' + , skipSpecialChar + ]) -- | Parses and processes -- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references> @@ -143,7 +204,7 @@ specialChar = "_/<@\"&'`# " -- to ensure that we have already given a chance to more meaningful parsers -- before capturing their characers. 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 @@ -153,45 +214,45 @@ string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (notInClass specialC -- 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 <$> +anchor = DocAName . T.unpack <$> disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") -- | Monospaced strings. @@ -199,23 +260,22 @@ anchor = DocAName . decodeUtf8 <$> -- >>> parseString "@cruel@" -- DocMonospaced (DocString "cruel") monospace :: Parser (DocH mod Identifier) -monospace = DocMonospaced . parseStringBS +monospace = DocMonospaced . parseParagraph <$> ("@" *> takeWhile1_ (/= '@') <* "@") --- | Module names: we try our reasonable best to only allow valid --- Haskell module names, with caveat about not matching on technically --- valid unicode symbols. +-- | Module names. +-- +-- 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 <$> ("\"" *> modid <* "\"") where - modid = intercalate "." <$> conid `sepBy1` "." + modid = intercalate "." <$> conid `Parsec.sepBy1` "." conid = (:) - <$> satisfy isAsciiUpper - -- NOTE: According to Haskell 2010 we should actually only - -- accept {small | large | digit | ' } here. But as we can't - -- match on unicode characters, this is currently not possible. - -- Note that we allow ‘#’ to suport anchors. - <*> (decodeUtf8 <$> takeWhile (notInClass " .&[{}(=*)+]!|@/;,^?\"\n")) + <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) + <*> many (conChar <|> Parsec.oneOf "\\#") + + conChar = Parsec.alphaNum <|> Parsec.char '_' -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. @@ -225,7 +285,7 @@ moduleName = DocModule <$> (char '"' *> modid <* char '"') -- >>> 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 \\). @@ -233,7 +293,7 @@ picture = DocPic . makeLabeled Picture . decodeUtf8 -- >>> 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 \\]. @@ -241,7 +301,7 @@ mathInline = DocMathInline . decodeUtf8 -- >>> 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) @@ -251,25 +311,213 @@ markdownImage = fromHyperlink <$> ("!" *> linkParser) -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) -paragraph = examples <|> 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. +-- +-- Tables are composed by an optional header and body. The header is composed by +-- a single row. The body is composed by a non-empty list of rows. +-- +-- Example table with header: +-- +-- > +----------+----------+ +-- > | /32bit/ | 64bit | +-- > +==========+==========+ +-- > | 0x0000 | @0x0000@ | +-- > +----------+----------+ +-- +-- Algorithms loosely follows ideas in +-- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py +-- +table :: Parser (DocH mod Identifier) +table = do + -- first we parse the first row, which determines the width of the table + firstRow <- parseFirstRow + let len = T.length firstRow + + -- then we parse all consequtive rows starting and ending with + or |, + -- of the width `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 Text + parseFirstRow = do + skipHorizontalSpace + -- upper-left corner is + + c <- Parsec.char '+' + cs <- some (Parsec.char '-' <|> Parsec.char '+') + + -- upper right corner is + too + guard (last cs == '+') + + -- trailing space + skipHorizontalSpace + _ <- Parsec.newline + + return (T.cons c $ T.pack cs) + + parseRestRows :: Int -> Parser Text + parseRestRows l = do + skipHorizontalSpace + c <- Parsec.char '|' <|> Parsec.char '+' + bs <- scan predicate (l - 2) + c2 <- Parsec.char '|' <|> Parsec.char '+' + + -- trailing space + skipHorizontalSpace + _ <- Parsec.newline + + return (T.cons c (T.snoc bs c2)) + where + predicate n c + | n <= 0 = Nothing + | c == '\n' = Nothing + | otherwise = Just (n - 1) + +-- Second step searchs for row of '+' and '=' characters, records it's index +-- and changes to '=' to '-'. +tableStepTwo + :: Int -- ^ width + -> [Text] -- ^ rows + -> Parser (Table (DocH mod Identifier)) +tableStepTwo width = go 0 [] where + go _ left [] = tableStepThree width (reverse left) Nothing + go n left (r : rs) + | T.all (`elem` ['+', '=']) r = + tableStepThree width (reverse left ++ r' : rs) (Just n) + | otherwise = + go (n + 1) (r : left) rs + where + 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 + -> [Text] -- ^ rows + -> Maybe Int -- ^ index of header separator + -> Parser (Table (DocH mod Identifier)) +tableStepThree width rs hdrIndex = do + cells <- loop (Set.singleton (0, 0)) + tableStepFour rs hdrIndex cells + where + height = length rs + + loop :: Set.Set (Int, Int) -> Parser [TC] + loop queue = case Set.minView queue of + Nothing -> return [] + Just ((y, x), queue') + | y + 1 >= height || x + 1 >= width -> loop queue' + | otherwise -> case scanRight x y of + Nothing -> loop queue' + Just (x2, y2) -> do + let tc = TC y x y2 x2 + fmap (tc :) $ loop $ queue' `Set.union` Set.fromList + [(y, x2), (y2, x), (y2, x2)] + + -- scan right looking for +, then try scan down + -- + -- do we need to record + saw on the way left and down? + scanRight :: Int -> Int -> Maybe (Int, Int) + scanRight x y = go (x + 1) where + bs = rs !! y + 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" + | 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' -> 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' -> 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 + deriving Show + +tcXS :: TC -> [Int] +tcXS (TC _ x _ x2) = [x, x2] + +tcYS :: TC -> [Int] +tcYS (TC y _ y2 _) = [y, y2] + +-- | Fourth step. Given the locations of cells, forms 'Table' structure. +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 + Nothing -> return $ Table [] rowsDoc + Just i' -> return $ uncurry Table $ splitAt i' rowsDoc + where + xTabStops = sortNub $ concatMap tcXS cells + yTabStops = sortNub $ concatMap tcYS cells + + sortNub :: Ord a => [a] -> [a] + sortNub = Set.toList . Set.fromList + + init' :: [a] -> [a] + init' [] = [] + init' [_] = [] + init' (x : xs) = x : init' xs + + rowsDoc = (fmap . fmap) parseParagraph rows + + rows = map makeRow (init' yTabStops) + where + makeRow y = TableRow $ mapMaybe (makeCell y) cells + makeCell y (TC y' x y2 x2) + | y /= y' = Nothing + | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1)) + where + xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops + yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops + + -- extract cell contents given boundaries + extract :: Int -> Int -> Int -> Int -> Text + extract x y x2 y2 = T.intercalate "\n" + [ T.take (x2 - x + 1) $ T.drop x $ rs !! y' + | y' <- [y .. y2] + ] + +-- | Parse \@since annotations. 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. @@ -280,38 +528,39 @@ since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince -- 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 + let psers = map (string . flip T.replicate "=") [6, 5 .. 1] + pser = choice' psers + delim <- T.unpack <$> pser + line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText + rest <- try paragraph <|> return DocEmpty return $ DocHeader (Header (length delim) 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 @@ -323,104 +572,110 @@ orderedList indent = DocOrderedList <$> p -- 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 (Parsec.noneOf "\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: -- @@ -429,97 +684,98 @@ takeIndent = do -- >> 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). -- 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 (Parsec.noneOf "\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 (Parsec.noneOf "\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 @@ -527,10 +783,12 @@ codeblock = | otherwise = Just $ c == '\n' hyperlink :: Parser (DocH mod a) -hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8 - <$> disallowNewline ("<" *> takeUntil ">") - <|> autoUrl - <|> markdownLink +hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] + +angleBracketLink :: Parser (DocH mod a) +angleBracketLink = + DocHyperlink . makeLabeled Hyperlink + <$> disallowNewline ("<" *> takeUntil ">") markdownLink :: Parser (DocH mod a) markdownLink = DocHyperlink <$> linkParser @@ -539,7 +797,7 @@ linkParser :: Parser Hyperlink linkParser = flip Hyperlink <$> label <*> (whitespace *> url) where label :: Parser (Maybe String) - label = Just . strip . decode <$> ("[" *> takeUntil "]") + label = Just . decode . T.strip <$> ("[" *> takeUntil "]") whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) @@ -550,19 +808,25 @@ linkParser = flip Hyperlink <$> label <*> (whitespace *> url) 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 (Parsec.satisfy (not . isSpace)) + + mkLink :: Text -> DocH mod a + mkLink s = case T.unsnoc s of + Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x] + _ -> DocHyperlink (mkHyperlink s) + + mkHyperlink :: Text -> Hyperlink + mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing + + -- | Parses strings between identifier delimiters. Consumes all input that it -- deems to be valid in an identifier. Note that it simply blindly consumes @@ -570,26 +834,16 @@ autoUrl = mkLink <$> url parseValid :: Parser String parseValid = p some where - idChar = - satisfy (\c -> isAlpha_ascii c - || isDigit c - -- N.B. '-' is placed first otherwise attoparsec thinks - -- it belongs to a character class - || inClass "-_.!#$%&*+/<=>?@\\|~:^" c) + idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') p p' = do - vs' <- p' $ utf8String "⋆" <|> return <$> idChar - let vs = concat vs' + vs <- p' idChar c <- peekChar' case c of '`' -> return vs - '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> p many') <|> return vs + '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] _ -> fail "outofvalid" --- | Parses UTF8 strings from ByteString streams. -utf8String :: String -> Parser String -utf8String x = decodeUtf8 <$> string (encodeUtf8 x) - -- | Parses identifiers with help of 'parseValid'. Asks GHC for -- 'String' from the string it deems valid. identifier :: Parser (DocH mod Identifier) @@ -599,4 +853,4 @@ identifier = do e <- idDelim return $ DocIdentifier (o, vid, e) where - idDelim = satisfy (\c -> c == '\'' || c == '`') + idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 3f7d60f8..585c76bb 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -1,149 +1,91 @@ -{-# 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 - -import Control.Applicative -import Control.Monad -import Data.String -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LB -import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec -import Control.Monad.Trans.State -import qualified Control.Monad.Trans.Class as Trans -import Data.Word -import Data.Bits -import Data.Tuple - -import Documentation.Haddock.Types (Version) +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeSynonymInstances #-} -newtype ParserState = ParserState { - parserStateSince :: Maybe Version -} deriving (Eq, Show) +module Documentation.Haddock.Parser.Monad where -initialParserState :: ParserState -initialParserState = ParserState Nothing +import qualified Text.Parsec.Char as Parsec +import qualified Text.Parsec as Parsec -newtype Parser a = Parser (StateT ParserState Attoparsec.Parser a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus) +import qualified Data.Text as T +import Data.Text ( Text ) -instance (a ~ ByteString) => IsString (Parser a) where - fromString = lift . fromString +import Data.String ( IsString(..) ) +import Data.Bits ( Bits(..) ) +import Data.Char ( ord ) +import Data.List ( foldl' ) -parseOnly :: Parser a -> ByteString -> Either String (ParserState, a) -parseOnly (Parser p) = fmap swap . Attoparsec.parseOnly (runStateT p initialParserState) +import Documentation.Haddock.Types ( Version ) -lift :: Attoparsec.Parser a -> Parser a -lift = Parser . Trans.lift +newtype ParserState = ParserState { + parserStateSince :: Maybe Version +} deriving (Eq, Show) -setParserState :: ParserState -> Parser () -setParserState = Parser . put +initialParserState :: ParserState +initialParserState = ParserState Nothing 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 +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. peekChar :: Parser (Maybe Char) -peekChar = lift Attoparsec.peekChar +peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar +-- | Fails if at the end of input. Does not consume input. peekChar' :: Parser Char -peekChar' = lift Attoparsec.peekChar' - -digit :: Parser Char -digit = lift Attoparsec.digit - -letter_iso8859_15 :: Parser Char -letter_iso8859_15 = lift Attoparsec.letter_iso8859_15 - -letter_ascii :: Parser Char -letter_ascii = lift Attoparsec.letter_ascii - -space :: Parser Char -space = lift Attoparsec.space - -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 - +peekChar' = Parsec.lookAhead Parsec.anyChar + +-- | Parses the given string. Returns the parsed string. +string :: Text -> Parser Text +string t = Parsec.string (T.unpack t) *> pure t + +-- | Scan the input text, accumulating characters as long as the scanning +-- function returns true. +scan :: (s -> Char -> Maybe s) -- ^ scan function + -> s -- ^ initial state + -> Parser Text +scan f = fmap T.pack . go + where go s1 = do { cOpt <- peekChar + ; case cOpt >>= f s1 of + Nothing -> pure "" + Just s2 -> (:) <$> Parsec.anyChar <*> go s2 + } + +-- | Apply a parser for a character zero or more times and collect the result in +-- a string. +takeWhile :: Parser Char -> Parser Text +takeWhile = fmap T.pack . Parsec.many + +-- | Apply a parser for a character one or more times and collect the result in +-- a string. +takeWhile1 :: Parser Char -> Parser Text +takeWhile1 = fmap T.pack . Parsec.many1 + +-- | Parse a decimal number. decimal :: Integral a => Parser a -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 diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs index ab5e5e9e..ffa91b09 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -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 +import Data.Char (isSpace) --- | Remove all leading and trailing whitespace -strip :: String -> String -strip = (\f -> f . f) $ dropWhile isSpace . reverse - -isHorizontalSpace :: Char -> Bool -isHorizontalSpace = inClass " \t\f\v\r" +-- | Characters that count as horizontal space +horizontalSpace :: [Char] +horizontalSpace = " \t\f\v\r" +-- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser () -skipHorizontalSpace = skipWhile isHorizontalSpace +skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) -takeHorizontalSpace :: Parser BS.ByteString -takeHorizontalSpace = takeWhile isHorizontalSpace +-- | Take leading horizontal space +takeHorizontalSpace :: Parser Text +takeHorizontalSpace = takeWhile (Parsec.oneOf 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 @@ takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome (_, 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 diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 1e76c631..b5dea3d4 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -15,6 +15,7 @@ module Documentation.Haddock.Types where #if !MIN_VERSION_base(4,8,0) +import Control.Applicative import Data.Foldable import Data.Traversable #endif @@ -33,7 +34,9 @@ import Data.Bitraversable -- 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 @@ -60,6 +63,7 @@ overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d) type Version = [Int] +type Package = String data Hyperlink = Hyperlink { hyperlinkUrl :: String @@ -81,6 +85,21 @@ data Example = Example , exampleResult :: [String] } deriving (Eq, Show) +data TableCell id = TableCell + { tableCellColspan :: Int + , tableCellRowspan :: Int + , tableCellContents :: id + } deriving (Eq, Show, Functor, Foldable, Traversable) + +newtype TableRow id = TableRow + { tableRowCells :: [TableCell id] + } deriving (Eq, Show, Functor, Foldable, Traversable) + +data Table id = Table + { tableHeaderRows :: [TableRow id] + , tableBodyRows :: [TableRow id] + } deriving (Eq, Show, Functor, Foldable, Traversable) + data DocH mod id = DocEmpty | DocAppend (DocH mod id) (DocH mod id) @@ -88,8 +107,10 @@ data DocH mod id | DocParagraph (DocH mod id) | DocIdentifier id | DocIdentifierUnchecked mod + -- ^ A qualified identifier that couldn't be resolved. | DocModule String | DocWarning (DocH mod id) + -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) | DocMonospaced (DocH mod id) | DocBold (DocH mod id) @@ -102,9 +123,11 @@ data DocH mod id | DocMathInline String | DocMathDisplay String | DocAName String + -- ^ A (HTML) anchor. | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id)) + | DocTable (Table (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0) @@ -132,6 +155,7 @@ instance Bifunctor DocH where bimap _ _ (DocProperty s) = DocProperty s bimap _ _ (DocExamples examples) = DocExamples examples bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title)) + bimap f g (DocTable (Table header body)) = DocTable (Table (map (fmap (bimap f g)) header) (map (fmap (bimap f g)) body)) #endif #if MIN_VERSION_base(4,10,0) @@ -149,6 +173,7 @@ instance Bifoldable DocH where 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 instance Bitraversable DocH where @@ -175,6 +200,7 @@ instance Bitraversable DocH where bitraverse _ _ (DocProperty s) = pure (DocProperty s) bitraverse _ _ (DocExamples examples) = pure (DocExamples examples) bitraverse f g (DocHeader (Header level title)) = (DocHeader . Header level) <$> bitraverse f g title + 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 -- | 'DocMarkupH' is a set of instructions for marking up documentation. @@ -209,4 +235,5 @@ data DocMarkupH mod id a = Markup , markupProperty :: String -> a , markupExample :: [Example] -> a , markupHeader :: Header a -> a + , markupTable :: Table a -> a } diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index b63ece92..86ed3b35 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -10,6 +10,8 @@ import Documentation.Haddock.Doc (docAppend) import Test.Hspec import Test.QuickCheck +import Prelude hiding ((<>)) + infixr 6 <> (<>) :: Doc id -> Doc id -> Doc id (<>) = docAppend @@ -22,8 +24,15 @@ instance IsString (Doc String) where 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 @@ -373,17 +382,17 @@ spec = do 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" } @@ -393,7 +402,7 @@ spec = do "@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 } diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs deleted file mode 100644 index bd3c5592..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs +++ /dev/null @@ -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 diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs deleted file mode 100644 index 84e567d9..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs +++ /dev/null @@ -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" diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs deleted file mode 100644 index ac94dfcc..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs +++ /dev/null @@ -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 #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs deleted file mode 100644 index 7fafba40..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs +++ /dev/null @@ -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 - diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs deleted file mode 100644 index d15854c4..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs +++ /dev/null @@ -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 _ = "" diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs deleted file mode 100644 index 4938ea87..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs +++ /dev/null @@ -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 #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs deleted file mode 100644 index dde0c27a..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs +++ /dev/null @@ -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 #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs deleted file mode 100644 index ee758b26..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs +++ /dev/null @@ -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 #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs deleted file mode 100644 index 0e00ed2c..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs +++ /dev/null @@ -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 #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs deleted file mode 100644 index 96bc319e..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs +++ /dev/null @@ -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 #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs b/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs deleted file mode 100644 index d0970d90..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs +++ /dev/null @@ -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 #-} diff --git a/haddock-library/vendor/attoparsec-0.13.1.0/LICENSE b/haddock-library/vendor/attoparsec-0.13.1.0/LICENSE deleted file mode 100644 index 97392a62..00000000 --- a/haddock-library/vendor/attoparsec-0.13.1.0/LICENSE +++ /dev/null @@ -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. |