haddock-library-1.11.0/ 0000755 0000000 0000000 00000000000 07346545000 013022 5 ustar 00 0000000 0000000 haddock-library-1.11.0/CHANGES.md 0000644 0000000 0000000 00000002346 07346545000 014421 0 ustar 00 0000000 0000000 ## Changes in version 1.11.0
* Add support for linking identifiers with a quote between backticks (#1408)
## Changes in version 1.10.0
* Add support for labeled module references (#1360)
## Changes in version 1.9.0
* Fix build-time regression for `base < 4.7` (#1119)
* Update parsing to strip whitespace from table cells (#1074)
## Changes in version 1.8.0
* Support inline markup in markdown-style links (#875)
* Remove now unused `Documentation.Haddock.Utf8` module.
This module was anyways copied from the `utf8-string` package.
## Changes in version 1.7.0
* Make `Documentation.Haddock.Parser.Monad` an internal module
## Changes in version 1.6.1
* Replace `attoparsec` with `parsec` (#799)
## Changes in version 1.6.0
* `MetaDoc` stores package name for since annotations
## Changes in version 1.5.0.1
* Support for parsing unicode operators (#458)
## 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
haddock-library-1.11.0/LICENSE 0000644 0000000 0000000 00000002433 07346545000 014031 0 ustar 00 0000000 0000000 Copyright (c) 2002-2010, Simon Marlow
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
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.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
haddock-library-1.11.0/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 014457 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
haddock-library-1.11.0/fixtures/ 0000755 0000000 0000000 00000000000 07346545000 014673 5 ustar 00 0000000 0000000 haddock-library-1.11.0/fixtures/Fixtures.hs 0000644 0000000 0000000 00000011070 07346545000 017037 0 ustar 00 0000000 0000000 {-# 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 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 id)
instance ToExpr id => ToExpr (Hyperlink id)
deriving instance Generic (ModLink id)
instance ToExpr id => ToExpr (ModLink id)
deriving instance Generic Picture
instance ToExpr Picture
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)
haddock-library-1.11.0/fixtures/examples/ 0000755 0000000 0000000 00000000000 07346545000 016511 5 ustar 00 0000000 0000000 haddock-library-1.11.0/fixtures/examples/definitionList.input 0000644 0000000 0000000 00000000013 07346545000 022550 0 ustar 00 0000000 0000000 [foo]: bar
haddock-library-1.11.0/fixtures/examples/definitionList.parsed 0000644 0000000 0000000 00000000066 07346545000 022677 0 ustar 00 0000000 0000000 DocDefList [_×_ (DocString "foo") (DocString "bar")]
haddock-library-1.11.0/fixtures/examples/identifier.input 0000644 0000000 0000000 00000000006 07346545000 021710 0 ustar 00 0000000 0000000 'foo'
haddock-library-1.11.0/fixtures/examples/identifier.parsed 0000644 0000000 0000000 00000000043 07346545000 022030 0 ustar 00 0000000 0000000 DocParagraph (DocIdentifier "foo")
haddock-library-1.11.0/fixtures/examples/identifierBackticks.input 0000644 0000000 0000000 00000000006 07346545000 023527 0 ustar 00 0000000 0000000 `foo`
haddock-library-1.11.0/fixtures/examples/identifierBackticks.parsed 0000644 0000000 0000000 00000000043 07346545000 023647 0 ustar 00 0000000 0000000 DocParagraph (DocIdentifier "foo")
haddock-library-1.11.0/fixtures/examples/link.input 0000644 0000000 0000000 00000000033 07346545000 020523 0 ustar 00 0000000 0000000 [link](http://example.com)
haddock-library-1.11.0/fixtures/examples/link.parsed 0000644 0000000 0000000 00000000214 07346545000 020643 0 ustar 00 0000000 0000000 DocParagraph
(DocHyperlink
Hyperlink
{hyperlinkLabel = Just (DocString "link"),
hyperlinkUrl = "http://example.com"})
haddock-library-1.11.0/fixtures/examples/linkInline.input 0000644 0000000 0000000 00000000037 07346545000 021666 0 ustar 00 0000000 0000000 Bla [link](http://example.com)
haddock-library-1.11.0/fixtures/examples/linkInline.parsed 0000644 0000000 0000000 00000000276 07346545000 022012 0 ustar 00 0000000 0000000 DocParagraph
(DocAppend
(DocString "Bla ")
(DocHyperlink
Hyperlink
{hyperlinkLabel = Just (DocString "link"),
hyperlinkUrl = "http://example.com"}))
haddock-library-1.11.0/fixtures/examples/linkInlineMarkup.input 0000644 0000000 0000000 00000000054 07346545000 023045 0 ustar 00 0000000 0000000 Bla [link /emphasized/](http://example.com)
haddock-library-1.11.0/fixtures/examples/linkInlineMarkup.parsed 0000644 0000000 0000000 00000000436 07346545000 023170 0 ustar 00 0000000 0000000 DocParagraph
(DocAppend
(DocString "Bla ")
(DocHyperlink
Hyperlink
{hyperlinkLabel = Just (DocAppend (DocString "link ")
(DocEmphasis (DocString "emphasized"))),
hyperlinkUrl = "http://example.com"}))
haddock-library-1.11.0/fixtures/examples/list-blocks1.input 0000644 0000000 0000000 00000000271 07346545000 022101 0 ustar 00 0000000 0000000 * Something about foo
@
foo :: a -> b -> c
foo a b = bar c b
@
* Something about bar
@
bar :: a -> b -> c
bar a b = foo b a
@
* And then we continue
haddock-library-1.11.0/fixtures/examples/list-blocks1.parsed 0000644 0000000 0000000 00000000645 07346545000 022225 0 ustar 00 0000000 0000000 DocUnorderedList
[DocAppend
(DocParagraph (DocString "Something about foo"))
(DocCodeBlock
(DocString
(concat ["foo :: a -> b -> c\n", "foo a b = bar c b\n"]))),
DocAppend
(DocParagraph (DocString "Something about bar"))
(DocCodeBlock
(DocString
(concat ["bar :: a -> b -> c\n", "bar a b = foo b a\n"]))),
DocParagraph (DocString "And then we continue")]
haddock-library-1.11.0/fixtures/examples/list-blocks2.input 0000644 0000000 0000000 00000000153 07346545000 022101 0 ustar 00 0000000 0000000 === Title
* List directly
* after the title
@
with some inline things
@
* is parsed weirdly
haddock-library-1.11.0/fixtures/examples/list-blocks2.parsed 0000644 0000000 0000000 00000000610 07346545000 022216 0 ustar 00 0000000 0000000 DocAppend
(DocAppend
(DocHeader
Header {headerLevel = 3, headerTitle = DocString "Title"})
(DocUnorderedList
[DocParagraph (DocString "List directly"),
DocAppend
(DocParagraph (DocString "after the title"))
(DocCodeBlock (DocString "with some inline things\n"))]))
(DocUnorderedList [DocParagraph (DocString "is parsed weirdly")])
haddock-library-1.11.0/fixtures/examples/table-cell-strip-whitespaces.input 0000644 0000000 0000000 00000000562 07346545000 025255 0 ustar 00 0000000 0000000 +------+--------------+-------------------------------------------------+
| C1 | C2 | C3 |
+======+==============+=================================================+
| row | 'test' | 'test table cell with .. whitepspace ' |
+------+--------------+-------------------------------------------------+
haddock-library-1.11.0/fixtures/examples/table-cell-strip-whitespaces.parsed 0000644 0000000 0000000 00000002573 07346545000 025400 0 ustar 00 0000000 0000000 DocTable
Table
{tableBodyRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocIdentifier "test",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString
"'test table cell with .. whitepspace '",
tableCellRowspan = 1}]],
tableHeaderRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "C1",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "C2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "C3",
tableCellRowspan = 1}]]}
haddock-library-1.11.0/fixtures/examples/table-simple.input 0000644 0000000 0000000 00000000725 07346545000 022154 0 ustar 00 0000000 0000000 +------+--------------+------------------------------------------+
| code | message | description |
+======+==============+==========================================+
| 200 | @OK@ | operation successful |
+------+--------------+------------------------------------------+
| 204 | @No Content@ | operation successful, no body returned |
+------+--------------+------------------------------------------+
haddock-library-1.11.0/fixtures/examples/table-simple.parsed 0000644 0000000 0000000 00000004067 07346545000 022276 0 ustar 00 0000000 0000000 DocTable
Table
{tableBodyRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "200",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocMonospaced (DocString "OK"),
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "operation successful",
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "204",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocMonospaced (DocString "No Content"),
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString
"operation successful, no body returned",
tableCellRowspan = 1}]],
tableHeaderRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "code",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "message",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "description",
tableCellRowspan = 1}]]}
haddock-library-1.11.0/fixtures/examples/table1.input 0000644 0000000 0000000 00000001350 07346545000 020741 0 ustar 00 0000000 0000000 +------------------------+------------+----------+----------+
| 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 | | \] |
+------------------------+------------+---------------------+
haddock-library-1.11.0/fixtures/examples/table1.parsed 0000644 0000000 0000000 00000006672 07346545000 021074 0 ustar 00 0000000 0000000 DocTable
Table
{tableBodyRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "body row 1, column 1",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 3",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 4",
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "body row 2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 3,
tableCellContents = DocString "Cells may span columns.",
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "body row 3",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString
(concat ["Cells may\n", "span rows.\n"]),
tableCellRowspan = 2},
TableCell
{tableCellColspan = 2,
tableCellContents = DocMathDisplay
(concat ["\n", "f(n) = \\sum_{i=1}\n"]),
tableCellRowspan = 2}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "body row 4",
tableCellRowspan = 1}]],
tableHeaderRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString
(concat
["Header row, column 1\n",
"(header rows optional)"]),
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "Header 2\n",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "Header 3\n",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "Header 4\n",
tableCellRowspan = 1}]]}
haddock-library-1.11.0/fixtures/examples/table2.input 0000644 0000000 0000000 00000000554 07346545000 020747 0 ustar 00 0000000 0000000 +--------------+----------+-----------+-----------+
| row 1, col 1 | column 2 | column 3 | column 4 |
+--------------+----------+-----------+-----------+
| row 2 | |
+--------------+----------+-----------+-----------+
| row 3 | | | |
+--------------+----------+-----------+-----------+
haddock-library-1.11.0/fixtures/examples/table2.parsed 0000644 0000000 0000000 00000004147 07346545000 021070 0 ustar 00 0000000 0000000 DocTable
Table
{tableBodyRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row 1, col 1",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 3",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 4",
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row 2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 3,
tableCellContents = DocEmpty,
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row 3",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1}]],
tableHeaderRows = []}
haddock-library-1.11.0/fixtures/examples/table3.input 0000644 0000000 0000000 00000000554 07346545000 020750 0 ustar 00 0000000 0000000 +--------------+----------+-----------+-----------+
| row 1, col 1 | column 2 | column 3 | column 4 |
+--------------+----------+-----------+-----------+
| row 2 | Use the command ``ls | more``. |
+--------------+----------+-----------+-----------+
| row 3 | | | |
+--------------+----------+-----------+-----------+
haddock-library-1.11.0/fixtures/examples/table3.parsed 0000644 0000000 0000000 00000004514 07346545000 021067 0 ustar 00 0000000 0000000 DocTable
Table
{tableBodyRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row 1, col 1",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 3",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 4",
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row 2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 2,
tableCellContents = DocString "Use the command ``ls",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "more``.",
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row 3",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1}]],
tableHeaderRows = []}
haddock-library-1.11.0/fixtures/examples/table4.input 0000644 0000000 0000000 00000000374 07346545000 020751 0 ustar 00 0000000 0000000 Single outer cell:
+-------------+
| outer |
| |
+-------+ |
| inner | |
+-------+-----+
Broken (only inner cell is rendered):
+-------+-----+
| inner | |
+-------+ |
| |
| outer |
+-------------+
haddock-library-1.11.0/fixtures/examples/table4.parsed 0000644 0000000 0000000 00000002243 07346545000 021065 0 ustar 00 0000000 0000000 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 = []})))
haddock-library-1.11.0/fixtures/examples/table5.input 0000644 0000000 0000000 00000000640 07346545000 020746 0 ustar 00 0000000 0000000 +--------------+----------+-----------+-----------+
| row 1, col 1 | column 2 | column 3 | column 4 |
+==============+==========+===========+===========+
| row 2 | Use the command @ls | more@. |
| | |
| +----------+-----------+-----------+
| row 3 | | | |
+--------------+----------+-----------+-----------+
haddock-library-1.11.0/fixtures/examples/table5.parsed 0000644 0000000 0000000 00000004455 07346545000 021075 0 ustar 00 0000000 0000000 DocTable
Table
{tableBodyRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString
(concat ["row 2\n", "\n", "\n", "row 3"]),
tableCellRowspan = 2},
TableCell
{tableCellColspan = 3,
tableCellContents = DocAppend
(DocString "Use the command ")
(DocAppend
(DocMonospaced (DocString "ls | more"))
(DocString ".\n")),
tableCellRowspan = 1}],
TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocEmpty,
tableCellRowspan = 1}]],
tableHeaderRows = [TableRow
[TableCell
{tableCellColspan = 1,
tableCellContents = DocString "row 1, col 1",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 2",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 3",
tableCellRowspan = 1},
TableCell
{tableCellColspan = 1,
tableCellContents = DocString "column 4",
tableCellRowspan = 1}]]}
haddock-library-1.11.0/fixtures/examples/url.input 0000644 0000000 0000000 00000000026 07346545000 020372 0 ustar 00 0000000 0000000
haddock-library-1.11.0/fixtures/examples/url.parsed 0000644 0000000 0000000 00000000165 07346545000 020515 0 ustar 00 0000000 0000000 DocParagraph
(DocHyperlink
Hyperlink
{hyperlinkLabel = Nothing, hyperlinkUrl = "http://example.com/"})
haddock-library-1.11.0/fixtures/examples/urlLabel.input 0000644 0000000 0000000 00000000040 07346545000 021326 0 ustar 00 0000000 0000000
haddock-library-1.11.0/fixtures/examples/urlLabel.parsed 0000644 0000000 0000000 00000000222 07346545000 021447 0 ustar 00 0000000 0000000 DocParagraph
(DocHyperlink
Hyperlink
{hyperlinkLabel = Just (DocString "some link"),
hyperlinkUrl = "http://example.com/"})
haddock-library-1.11.0/haddock-library.cabal 0000644 0000000 0000000 00000007654 07346545000 017061 0 ustar 00 0000000 0000000 cabal-version: 3.0
name: haddock-library
version: 1.11.0
synopsis: Library exposing some functionality of Haddock.
description: Haddock is a documentation-generation tool for Haskell
libraries. These modules expose some
functionality of it without pulling in the GHC
dependency. Please note that the API is likely
to change so be sure to specify upper bounds in
your projects. For interacting with Haddock
itself, see the [haddock package](https://hackage.haskell.org/package/haddock).
license: BSD-2-Clause
license-file: LICENSE
maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk
homepage: http://www.haskell.org/haddock/
bug-reports: https://github.com/haskell/haddock/issues
category: Documentation
tested-with: GHC == 7.4.2
, GHC == 7.6.3
, GHC == 7.8.4
, GHC == 7.10.3
, GHC == 8.0.2
, GHC == 8.2.2
, GHC == 8.4.4
, GHC == 8.6.5
, GHC == 8.8.3
, GHC == 8.10.1
, GHC == 9.0.1
, GHC == 9.2.0
extra-source-files:
CHANGES.md
fixtures/examples/*.input
fixtures/examples/*.parsed
common lib-defaults
default-language: Haskell2010
build-depends:
, base >= 4.5 && < 4.17
, containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1
, text ^>= 1.2.3.0 || ^>= 2.0
, parsec ^>= 3.1.13.0
ghc-options: -funbox-strict-fields -Wall
if impl(ghc >= 8.0)
ghc-options: -Wcompat -Wnoncanonical-monad-instances
library
import: lib-defaults
hs-source-dirs: src
exposed-modules:
Documentation.Haddock.Doc
Documentation.Haddock.Markup
Documentation.Haddock.Parser
Documentation.Haddock.Types
other-modules:
CompatPrelude
Documentation.Haddock.Parser.Util
Documentation.Haddock.Parser.Monad
Documentation.Haddock.Parser.Identifier
test-suite spec
import: lib-defaults
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs:
test
src
other-modules:
CompatPrelude
Documentation.Haddock.Doc
Documentation.Haddock.Markup
Documentation.Haddock.Parser
Documentation.Haddock.Parser.Monad
Documentation.Haddock.Parser.Util
Documentation.Haddock.Parser.UtilSpec
Documentation.Haddock.ParserSpec
Documentation.Haddock.Types
Documentation.Haddock.Parser.Identifier
build-depends:
, base-compat ^>= 0.12.0
, QuickCheck ^>= 2.11 || ^>= 2.13.2 || ^>= 2.14
, deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0
-- NB: build-depends & build-tool-depends have independent
-- install-plans, so it's best to limit to a single major
-- version of `hspec` & `hspec-discover` to ensure
-- intercompatibility
build-depends:
, hspec >= 2.4.4 && < 2.10
build-tool-depends:
, hspec-discover:hspec-discover >= 2.4.4 && < 2.10
test-suite fixtures
type: exitcode-stdio-1.0
default-language: Haskell2010
main-is: Fixtures.hs
ghc-options: -Wall
hs-source-dirs: fixtures
build-depends:
-- intra-package dependency
, haddock-library
-- constraints inherited via lib:haddock-library component
, base
-- extra dependencies
, base-compat ^>= 0.12.0
, directory ^>= 1.3.0.2
, filepath ^>= 1.4.1.2
, optparse-applicative ^>= 0.15
, tree-diff ^>= 0.2
source-repository head
type: git
subdir: haddock-library
location: https://github.com/haskell/haddock.git
haddock-library-1.11.0/src/ 0000755 0000000 0000000 00000000000 07346545000 013611 5 ustar 00 0000000 0000000 haddock-library-1.11.0/src/CompatPrelude.hs 0000644 0000000 0000000 00000002570 07346545000 016715 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
#ifdef __HLINT__
#elif !MIN_VERSION_base(4,5,0)
# error This module doesn't provide compat-shims for versions prior to base-4.5
#endif
-- | Bridge impedance mismatch of different @base@ versions back till @base-4.5@ (GHC 7.4.2)
module CompatPrelude
( ($>)
, isSymbolChar
) where
#if MIN_VERSION_base(4,7,0)
import Data.Functor ( ($>) )
#else
import Data.Functor ( (<$) )
#endif
#if MIN_VERSION_base(4,9,0)
import Text.Read.Lex (isSymbolChar)
#else
import Data.Char (GeneralCategory(..), generalCategory)
#endif
#if !MIN_VERSION_base(4,7,0)
infixl 4 $>
-- | Flipped version of '<$'.
--
-- @since 4.7.0.0
($>) :: Functor f => f a -> b -> f b
($>) = flip (<$)
#endif
#if !MIN_VERSION_base(4,9,0)
-- inlined from base-4.10.0.0
isSymbolChar :: Char -> Bool
isSymbolChar c = not (isPuncChar c) && case generalCategory c of
MathSymbol -> True
CurrencySymbol -> True
ModifierSymbol -> True
OtherSymbol -> True
DashPunctuation -> True
OtherPunctuation -> c `notElem` "'\""
ConnectorPunctuation -> c /= '_'
_ -> False
where
-- | The @special@ character class as defined in the Haskell Report.
isPuncChar :: Char -> Bool
isPuncChar = (`elem` (",;()[]{}`" :: String))
#endif
haddock-library-1.11.0/src/Documentation/Haddock/ 0000755 0000000 0000000 00000000000 07346545000 017757 5 ustar 00 0000000 0000000 haddock-library-1.11.0/src/Documentation/Haddock/Doc.hs 0000644 0000000 0000000 00000007007 07346545000 021024 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-orphans #-}
module Documentation.Haddock.Doc (docParagraph, docAppend,
docConcat, metaDocConcat,
metaDocAppend, emptyMetaDoc,
metaAppend, metaConcat) where
import Control.Applicative ((<|>), empty)
import Documentation.Haddock.Types
import Data.Char (isSpace)
docConcat :: [DocH mod id] -> DocH mod id
docConcat = foldr docAppend DocEmpty
-- | Concat using 'metaAppend'.
metaConcat :: [Meta] -> Meta
metaConcat = foldr metaAppend emptyMeta
-- | Like 'docConcat' but also joins the 'Meta' info.
metaDocConcat :: [MetaDoc mod id] -> MetaDoc mod id
metaDocConcat = foldr metaDocAppend emptyMetaDoc
-- | We do something perhaps unexpected here and join the meta info
-- in ‘reverse’: this results in the metadata from the ‘latest’
-- paragraphs taking precedence.
metaDocAppend :: MetaDoc mod id -> MetaDoc mod id -> MetaDoc mod id
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' and
-- '_package'.
metaAppend :: Meta -> Meta -> Meta
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 empty empty
docAppend :: DocH mod id -> DocH mod id -> DocH mod id
docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)
docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d
docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2)
docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) = DocAppend (DocOrderedList (ds1++ds2)) d
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) = DocAppend (DocUnorderedList (ds1++ds2)) d
docAppend DocEmpty d = d
docAppend d DocEmpty = d
docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2)
docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2))
docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d
docAppend d1 d2 = DocAppend d1 d2
-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
docParagraph :: DocH mod id -> DocH mod id
docParagraph (DocMonospaced p)
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
| all isSpace s1
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1)
(DocAppend (DocMonospaced p) (DocString s2)))
| all isSpace s1 && all isSpace s2
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocMonospaced p) (DocString s2))
| all isSpace s2
= DocCodeBlock (docCodeBlock p)
docParagraph p
= DocParagraph p
-- Drop trailing whitespace from @..@ code blocks. Otherwise this:
--
-- -- @
-- -- foo
-- -- @
--
-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
-- gives an extra vertical space after the code block. The single space
-- on the final line seems to trigger the extra vertical space.
--
docCodeBlock :: DocH mod id -> DocH mod id
docCodeBlock (DocString s)
= DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
docCodeBlock (DocAppend l r)
= DocAppend l (docCodeBlock r)
docCodeBlock d = d
haddock-library-1.11.0/src/Documentation/Haddock/Markup.hs 0000644 0000000 0000000 00000011004 07346545000 021546 0 ustar 00 0000000 0000000 -- | @since 1.4.5
module Documentation.Haddock.Markup (
markup
, idMarkup
, plainMarkup
) where
import Documentation.Haddock.Types
import Data.Maybe ( fromMaybe )
markup :: DocMarkupH mod id a -> DocH mod id -> a
markup m DocEmpty = markupEmpty m
markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
markup m (DocString s) = markupString m s
markup m (DocParagraph d) = markupParagraph m (markup m d)
markup m (DocIdentifier x) = markupIdentifier m x
markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
markup m (DocModule (ModLink mo l)) = markupModule m (ModLink mo (fmap (markup m) l))
markup m (DocWarning d) = markupWarning m (markup m d)
markup m (DocEmphasis d) = markupEmphasis m (markup m d)
markup m (DocBold d) = markupBold m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
markup m (DocOrderedList ds) = markupOrderedList m (map (\(index, a) -> (index, markup m a)) ds)
markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))
markup m (DocAName ref) = markupAName m ref
markup m (DocPic img) = markupPic m img
markup m (DocMathInline mathjax) = markupMathInline m mathjax
markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax
markup m (DocProperty p) = markupProperty m p
markup m (DocExamples e) = markupExample m e
markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))
markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))
markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a)
markupPair m (a,b) = (markup m a, markup m b)
-- | The identity markup
idMarkup :: DocMarkupH mod id (DocH mod id)
idMarkup = Markup {
markupEmpty = DocEmpty,
markupString = DocString,
markupParagraph = DocParagraph,
markupAppend = DocAppend,
markupIdentifier = DocIdentifier,
markupIdentifierUnchecked = DocIdentifierUnchecked,
markupModule = DocModule,
markupWarning = DocWarning,
markupEmphasis = DocEmphasis,
markupBold = DocBold,
markupMonospaced = DocMonospaced,
markupUnorderedList = DocUnorderedList,
markupOrderedList = DocOrderedList,
markupDefList = DocDefList,
markupCodeBlock = DocCodeBlock,
markupHyperlink = DocHyperlink,
markupAName = DocAName,
markupPic = DocPic,
markupMathInline = DocMathInline,
markupMathDisplay = DocMathDisplay,
markupProperty = DocProperty,
markupExample = DocExamples,
markupHeader = DocHeader,
markupTable = DocTable
}
-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to
-- strip away any formatting while preserving as much of the actual text as
-- possible.
plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String
plainMarkup plainMod plainIdent = Markup {
markupEmpty = "",
markupString = id,
markupParagraph = id,
markupAppend = (++),
markupIdentifier = plainIdent,
markupIdentifierUnchecked = plainMod,
markupModule = \(ModLink m lbl) -> fromMaybe m lbl,
markupWarning = id,
markupEmphasis = id,
markupBold = id,
markupMonospaced = id,
markupUnorderedList = const "",
markupOrderedList = const "",
markupDefList = const "",
markupCodeBlock = id,
markupHyperlink = \(Hyperlink url lbl) -> fromMaybe url lbl,
markupAName = id,
markupPic = \(Picture uri title) -> fromMaybe uri title,
markupMathInline = id,
markupMathDisplay = id,
markupProperty = id,
markupExample = const "",
markupHeader = \(Header _ title) -> title,
markupTable = const ""
}
haddock-library-1.11.0/src/Documentation/Haddock/Parser.hs 0000644 0000000 0000000 00000075333 07346545000 021562 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module : Documentation.Haddock.Parser
-- Copyright : (c) Mateusz Kowalczyk 2013-2014,
-- Simon Hengel 2013
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
--
-- Parser used for Haddock comments. For external users of this
-- library, the most commonly used combination of functions is going
-- to be
--
-- @'toRegular' . '_doc' . 'parseParas'@
module Documentation.Haddock.Parser (
parseString,
parseParas,
overIdentifier,
toRegular,
Identifier
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isUpper, isAlpha, isSpace)
import Data.List (intercalate, unfoldr, elemIndex)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
import Documentation.Haddock.Doc
import Documentation.Haddock.Markup ( markup, plainMarkup )
import Documentation.Haddock.Parser.Monad
import Documentation.Haddock.Parser.Util
import Documentation.Haddock.Parser.Identifier
import Documentation.Haddock.Types
import Prelude hiding (takeWhile)
import qualified Prelude as P
import qualified Text.Parsec as Parsec
import Text.Parsec (try)
import qualified Data.Text as T
import Data.Text (Text)
-- $setup
-- >>> :set -XOverloadedStrings
-- | Drops the quotes/backticks around all identifiers, as if they
-- were valid but still 'String's.
toRegular :: DocH mod Identifier -> DocH mod String
toRegular = fmap (\(Identifier _ _ x _) -> x)
-- | Maps over 'DocIdentifier's over 'String' with potentially failing
-- conversion using user-supplied function. If the conversion fails,
-- the identifier is deemed to not be valid and is treated as a
-- regular string.
overIdentifier :: (Namespace -> String -> Maybe a)
-> DocH mod Identifier
-> DocH mod a
overIdentifier f d = g d
where
g (DocIdentifier (Identifier ns o x e)) = case f ns x of
Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e]
Just x' -> DocIdentifier x'
g DocEmpty = DocEmpty
g (DocAppend x x') = DocAppend (g x) (g x')
g (DocString x) = DocString x
g (DocParagraph x) = DocParagraph $ g x
g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x
g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x))
g (DocWarning x) = DocWarning $ g x
g (DocEmphasis x) = DocEmphasis $ g x
g (DocMonospaced x) = DocMonospaced $ g x
g (DocBold x) = DocBold $ g x
g (DocUnorderedList x) = DocUnorderedList $ fmap g x
g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x
g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x
g (DocCodeBlock x) = DocCodeBlock $ g x
g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))
g (DocPic x) = DocPic x
g (DocMathInline x) = DocMathInline x
g (DocMathDisplay x) = DocMathDisplay x
g (DocAName x) = DocAName x
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))
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 :: Maybe Package
-> String -- ^ String to parse
-> MetaDoc mod Identifier
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 (emptyLines *> p) . T.pack . (++ "\n") . filter (/= '\r')
where
p :: Parser (DocH mod Identifier)
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) -> Parsec.putState state *> pure a
-- | Variant of 'parseText' for 'String' instead of 'Text'
parseString :: String -> DocH mod Identifier
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')
parseParagraph :: Text -> DocH mod Identifier
parseParagraph = snd . parse p
where
p :: Parser (DocH mod Identifier)
p = docConcat <$> many (choice' [ monospace
, anchor
, identifier
, moduleName
, picture
, mathDisplay
, mathInline
, markdownImage
, markdownLink
, hyperlink
, bold
, emphasis
, encodedChar
, string'
, skipSpecialChar
])
-- | Parses and processes
--
--
-- >>> parseString "A"
-- DocString "A"
encodedChar :: Parser (DocH mod a)
encodedChar = "&#" *> c <* ";"
where
c = DocString . return . chr <$> num
num = hex <|> decimal
hex = ("x" <|> "X") *> hexadecimal
-- | List of characters that we use to delimit any special markup.
-- Once we have checked for any of these and tried to parse the
-- relevant markup, we can assume they are used as regular text.
specialChar :: [Char]
specialChar = "_/<@\"&'`#[ "
-- | Plain, regular parser for text. Called as one of the last parsers
-- to ensure that we have already given a chance to more meaningful parsers
-- before capturing their characters.
string' :: Parser (DocH mod a)
string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar)
where
unescape "" = ""
unescape ('\\':x:xs) = x : unescape xs
unescape (x:xs) = x : unescape xs
-- | Skips a single special character and treats it as a plain string.
-- 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 <$> Parsec.oneOf specialChar
-- | Emphasis parser.
--
-- >>> parseString "/Hello world/"
-- DocEmphasis (DocString "Hello world")
emphasis :: Parser (DocH mod Identifier)
emphasis = DocEmphasis . parseParagraph <$>
disallowNewline ("/" *> takeWhile1_ (/= '/') <* "/")
-- | Bold parser.
--
-- >>> parseString "__Hello world__"
-- DocBold (DocString "Hello world")
bold :: Parser (DocH mod Identifier)
bold = DocBold . parseParagraph <$> disallowNewline ("__" *> takeUntil "__")
disallowNewline :: Parser Text -> Parser Text
disallowNewline = mfilter (T.all (/= '\n'))
-- | Like `takeWhile`, but unconditionally take escaped characters.
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 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 . T.unpack <$>
("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#")
-- | Monospaced strings.
--
-- >>> parseString "@cruel@"
-- DocMonospaced (DocString "cruel")
monospace :: Parser (DocH mod Identifier)
monospace = DocMonospaced . parseParagraph
<$> ("@" *> takeWhile1_ (/= '@') <* "@")
-- | 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 . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"")
-- | A module name, optionally with an anchor
--
moduleNameString :: Parser String
moduleNameString = modid `maybeFollowedBy` anchor_
where
modid = intercalate "." <$> conid `Parsec.sepBy1` "."
anchor_ = (++)
<$> (Parsec.string "#" <|> Parsec.string "\\#")
<*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c)))
maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf
conid :: Parser String
conid = (:)
<$> Parsec.satisfy (\c -> isAlpha c && isUpper c)
<*> many conChar
conChar = Parsec.alphaNum <|> Parsec.char '_'
-- | A labeled link to an indentifier, module or url using markdown
-- syntax.
markdownLink :: Parser (DocH mod Identifier)
markdownLink = do
lbl <- markdownLinkText
choice' [ markdownModuleName lbl, markdownURL lbl ]
where
markdownModuleName lbl = do
mn <- "(" *> skipHorizontalSpace *>
"\"" *> moduleNameString <* "\""
<* skipHorizontalSpace <* ")"
pure $ DocModule (ModLink mn (Just lbl))
markdownURL lbl = do
target <- markdownLinkTarget
pure $ DocHyperlink $ Hyperlink target (Just lbl)
-- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify
-- a title for the picture.
--
-- >>> parseString "<>"
-- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Nothing})
-- >>> parseString "<>"
-- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"})
picture :: Parser (DocH mod a)
picture = DocPic . makeLabeled Picture
<$> disallowNewline ("<<" *> takeUntil ">>")
-- | Inline math parser, surrounded by \\( and \\).
--
-- >>> parseString "\\(\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\)"
-- DocMathInline "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}"
mathInline :: Parser (DocH mod a)
mathInline = DocMathInline . T.unpack
<$> disallowNewline ("\\(" *> takeUntil "\\)")
-- | Display math parser, surrounded by \\[ and \\].
--
-- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]"
-- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}"
mathDisplay :: Parser (DocH mod a)
mathDisplay = DocMathDisplay . T.unpack
<$> ("\\[" *> takeUntil "\\]")
-- | Markdown image parser. As per the commonmark reference recommendation, the
-- description text for an image converted to its a plain string representation.
--
-- >>> parseString ""
-- DocPic (Picture "www.site.com" (Just "some emphasis in a description"))
markdownImage :: Parser (DocH mod Identifier)
markdownImage = do
text <- markup stringMarkup <$> ("!" *> markdownLinkText)
url <- markdownLinkTarget
pure $ DocPic (Picture url (Just text))
where
stringMarkup = plainMarkup (const "") renderIdent
renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r]
-- | Paragraph parser, called by 'parseParas'.
paragraph :: Parser (DocH mod Identifier)
paragraph = 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 consecutive 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
cs <- takeWhile (\c -> c == '-' || c == '+')
-- upper-left and upper-right corners are `+`
guard (T.length cs >= 2 &&
T.head cs == '+' &&
T.last cs == '+')
-- trailing space
skipHorizontalSpace
_ <- Parsec.newline
return cs
parseRestRows :: Int -> Parser Text
parseRestRows l = do
skipHorizontalSpace
bs <- scan predicate l
-- Left and right edges are `|` or `+`
guard (T.length bs >= 2 &&
(T.head bs == '|' || T.head bs == '+') &&
(T.last bs == '|' || T.last bs == '+'))
-- trailing space
skipHorizontalSpace
_ <- Parsec.newline
return bs
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.stripEnd $ T.stripStart $ 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 `Parsec.sepBy1` "."
-- | Headers inside the comment denoted with @=@ signs, up to 6 levels
-- deep.
--
-- >>> snd <$> parseOnly header "= Hello"
-- Right (DocHeader (Header {headerLevel = 1, headerTitle = DocString "Hello"}))
-- >>> snd <$> parseOnly header "== World"
-- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"}))
header :: Parser (DocH mod Identifier)
header = do
let psers = map (string . flip T.replicate "=") [6, 5 .. 1]
pser = Parsec.choice psers
depth <- T.length <$> pser
line <- parseText <$> (skipHorizontalSpace *> nonEmptyLine)
rest <- try paragraph <|> return DocEmpty
return $ DocHeader (Header depth line) `docAppend` rest
textParagraph :: Parser (DocH mod Identifier)
textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine
textParagraphThatStartsWithMarkdownLink :: Parser (DocH mod Identifier)
textParagraphThatStartsWithMarkdownLink = docParagraph <$> (docAppend <$> markdownLink <*> optionalTextParagraph)
where
optionalTextParagraph :: Parser (DocH mod Identifier)
optionalTextParagraph = choice' [ docAppend <$> whitespace <*> textParagraph
, pure DocEmpty ]
whitespace :: Parser (DocH mod a)
whitespace = DocString <$> (f <$> takeHorizontalSpace <*> optional "\n")
where
f :: Text -> Maybe Text -> String
f xs (fromMaybe "" -> x)
| T.null (xs <> x) = ""
| otherwise = " "
-- | Parses unordered (bullet) lists.
unorderedList :: Text -> Parser (DocH mod Identifier)
unorderedList indent = DocUnorderedList <$> p
where
p = ("*" <|> "-") *> innerList indent p
-- | Parses ordered lists (numbered or dashed).
orderedList :: Text -> Parser (DocH mod Identifier)
orderedList indent = DocOrderedList <$> p
where
p = do
index <- paren <|> dot
innerList' indent p index
dot = (decimal :: Parser Int) <* "."
paren = "(" *> decimal <* ")"
-- | Like 'innerList' but takes the parsed index of the list item
innerList' :: Text -> Parser [(Int, DocH mod Identifier)]
-> Int
-> Parser [(Int, DocH mod Identifier)]
innerList' indent item index = do
c <- takeLine
(cs, items) <- more indent item
let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs
return $ case items of
Left p -> [(index, contents `docAppend` p)]
Right i -> (index, contents) : i
-- | Generic function collecting any further lines belonging to the
-- list entry and recursively collecting any further lists in the
-- same paragraph. Usually used as
--
-- > someListFunction = listBeginning *> innerList someListFunction
innerList :: Text -> Parser [DocH mod Identifier]
-> Parser [DocH mod Identifier]
innerList indent item = do
c <- takeLine
(cs, items) <- more indent item
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 :: Text -> Parser (DocH mod Identifier)
definitionList indent = DocDefList <$> p
where
p = do
label <- "[" *> (parseParagraph <$> takeWhile1_ (`notElem` ("]\n" :: String))) <* ("]" <* optional ":")
c <- takeLine
(cs, items) <- more indent p
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 :: 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 => 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 :: 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 :: Text -> Parser a
-> Parser ([Text], Either (DocH mod Identifier) a)
moreListItems indent item = (,) [] . Right <$> indentedItem
where
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 => 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 :: Text -> Parser (DocH mod Identifier)
indentedParagraphs indent =
(T.unpack . T.concat <$> dropFrontOfPara indent') >>= parseParagraphs
where
indent' = string $ indent <> " "
-- | Grab as many fully indented paragraphs as we can.
dropFrontOfPara :: Parser Text -> Parser [Text]
dropFrontOfPara sp = do
currentParagraph <- some (try (sp *> takeNonEmptyLine))
followingParagraphs <-
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 :: Text -> Parser Text
nonSpace xs
| 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 Text
takeNonEmptyLine = do
l <- takeWhile1 (/= '\n') >>= nonSpace
_ <- "\n"
pure (l <> "\n")
-- | Takes indentation of first non-empty line.
--
-- More precisely: skips all whitespace-only lines and returns indentation
-- (horizontal space, might be empty) of that non-empty line.
takeIndent :: Parser Text
takeIndent = do
indent <- takeHorizontalSpace
choice' [ "\n" *> takeIndent
, return indent
]
-- | Blocks of text of the form:
--
-- >> foo
-- >> bar
-- >> baz
--
birdtracks :: Parser (DocH mod a)
birdtracks = DocCodeBlock . DocString . T.unpack . T.intercalate "\n" . stripSpace <$> some line
where
line = try (skipHorizontalSpace *> ">" *> takeLine)
stripSpace :: [Text] -> [Text]
stripSpace = fromMaybe <*> mapM strip'
where
strip' t = case T.uncons t of
Nothing -> Just ""
Just (' ',t') -> Just t'
_ -> Nothing
-- | Parses examples. Examples are a paragraph level entity (separated by an empty line).
-- Consecutive examples are accepted.
examples :: Parser (DocH mod a)
examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go)
where
go :: Parser [Example]
go = do
prefix <- takeHorizontalSpace <* ">>>"
expr <- takeLine
(rs, es) <- resultAndMoreExamples
return (makeExample prefix expr rs : es)
where
resultAndMoreExamples :: Parser ([Text], [Example])
resultAndMoreExamples = choice' [ moreExamples, result, pure ([], []) ]
where
moreExamples :: Parser ([Text], [Example])
moreExamples = (,) [] <$> go
result :: Parser ([Text], [Example])
result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples
makeExample :: Text -> Text -> [Text] -> Example
makeExample prefix expression res =
Example (T.unpack (T.strip expression)) result
where
result = map (T.unpack . substituteBlankLine . tryStripPrefix) res
tryStripPrefix xs = fromMaybe xs (T.stripPrefix prefix xs)
substituteBlankLine "" = ""
substituteBlankLine xs = xs
nonEmptyLine :: Parser Text
nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine)
takeLine :: Parser Text
takeLine = try (takeWhile (/= '\n') <* endOfLine)
endOfLine :: Parser ()
endOfLine = void "\n" <|> Parsec.eof
-- | Property parser.
--
-- >>> snd <$> parseOnly property "prop> hello world"
-- Right (DocProperty "hello world")
property :: Parser (DocH mod a)
property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (/= '\n'))
-- |
-- Paragraph level codeblock. Anything between the two delimiting \@ is parsed
-- for markup.
codeblock :: Parser (DocH mod Identifier)
codeblock =
DocCodeBlock . parseParagraph . dropSpaces
<$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
where
dropSpaces xs =
case splitByNl xs of
[] -> xs
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 T.uncons x of
Just ('\n',x') -> Just (T.span (/= '\n') x')
_ -> Nothing)
. ("\n" <>)
dropSpace t = case T.uncons t of
Nothing -> Just ""
Just (' ',t') -> Just t'
_ -> Nothing
block' = scan p False
where
p isNewline c
| isNewline && c == '@' = Nothing
| isNewline && isSpace c = Just isNewline
| otherwise = Just $ c == '\n'
hyperlink :: Parser (DocH mod Identifier)
hyperlink = choice' [ angleBracketLink, autoUrl ]
angleBracketLink :: Parser (DocH mod a)
angleBracketLink =
DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)
<$> disallowNewline ("<" *> takeUntil ">")
-- | The text for a markdown link, enclosed in square brackets.
markdownLinkText :: Parser (DocH mod Identifier)
markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]")
-- | The target for a markdown link, enclosed in parenthesis.
markdownLinkTarget :: Parser String
markdownLinkTarget = whitespace *> url
where
whitespace :: Parser ()
whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)
url :: Parser String
url = rejectWhitespace (decode <$> ("(" *> takeUntil ")"))
rejectWhitespace :: MonadPlus m => m String -> m String
rejectWhitespace = mfilter (all (not . isSpace))
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 <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (not . isSpace)
mkLink :: Text -> DocH mod a
mkLink s = case T.unsnoc s of
Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x]
_ -> DocHyperlink (mkHyperlink s)
mkHyperlink :: Text -> Hyperlink (DocH mod a)
mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing
-- | Parses identifiers with help of 'parseValid'.
identifier :: Parser (DocH mod Identifier)
identifier = DocIdentifier <$> parseValid
haddock-library-1.11.0/src/Documentation/Haddock/Parser/ 0000755 0000000 0000000 00000000000 07346545000 021213 5 ustar 00 0000000 0000000 haddock-library-1.11.0/src/Documentation/Haddock/Parser/Identifier.hs 0000644 0000000 0000000 00000013221 07346545000 023630 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
-- |
-- Module : Documentation.Haddock.Parser.Identifier
-- Copyright : (c) Alec Theriault 2019,
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
--
-- Functionality for parsing identifiers and operators
module Documentation.Haddock.Parser.Identifier (
Identifier(..),
parseValid,
) where
import Documentation.Haddock.Types ( Namespace(..) )
import Documentation.Haddock.Parser.Monad
import qualified Text.Parsec as Parsec
import Text.Parsec.Pos ( updatePosChar )
import Text.Parsec ( State(..)
, getParserState, setParserState )
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isAlpha, isAlphaNum)
import Control.Monad (guard)
import Data.Maybe
import CompatPrelude
-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks.
data Identifier = Identifier !Namespace !Char String !Char
deriving (Show, Eq)
parseValid :: Parser Identifier
parseValid = do
s@State{ stateInput = inp, statePos = pos } <- getParserState
case takeIdentifier inp of
Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier"
Just (ns, op, ident, cl, inp') ->
let posOp = updatePosChar pos op
posIdent = T.foldl updatePosChar posOp ident
posCl = updatePosChar posIdent cl
s' = s{ stateInput = inp', statePos = posCl }
in setParserState s' $> Identifier ns op (T.unpack ident) cl
-- | Try to parse a delimited identifier off the front of the given input.
--
-- This tries to match as many valid Haskell identifiers/operators as possible,
-- to the point of sometimes accepting invalid things (ex: keywords). Some
-- considerations:
--
-- - operators and identifiers can have module qualifications
-- - operators can be wrapped in parens (for prefix)
-- - identifiers can be wrapped in backticks (for infix)
-- - delimiters are backticks or regular ticks
-- - since regular ticks are also valid in identifiers, we opt for the
-- longest successful parse
--
-- This function should make /O(1)/ allocations
takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text)
takeIdentifier input = listToMaybe $ do
-- Optional namespace
let (ns, input') = case T.uncons input of
Just ('v', i) -> (Value, i)
Just ('t', i) -> (Type, i)
_ -> (None, input)
-- Opening tick
(op, input'') <- maybeToList (T.uncons input')
guard (op == '\'' || op == '`')
-- Identifier/operator
(ident, input''') <- wrapped input''
-- Closing tick
(cl, input'''') <- maybeToList (T.uncons input''')
guard (cl == '\'' || cl == '`')
return (ns, op, ident, cl, input'''')
where
-- | Parse out a wrapped, possibly qualified, operator or identifier
wrapped t = do
(c, t' ) <- maybeToList (T.uncons t)
-- Tuples
case c of
'(' | Just (c', _) <- T.uncons t'
, c' == ',' || c' == ')'
-> do let (commas, t'') = T.span (== ',') t'
(')', t''') <- maybeToList (T.uncons t'')
return (T.take (T.length commas + 2) t, t''')
-- Parenthesized
'(' -> do (n, t'' ) <- general False 0 [] t'
(')', t''') <- maybeToList (T.uncons t'')
return (T.take (n + 2) t, t''')
-- Backticked
'`' -> do (n, t'' ) <- general False 0 [] t'
('`', t''') <- maybeToList (T.uncons t'')
return (T.take (n + 2) t, t''')
-- Unadorned
_ -> do (n, t'' ) <- general False 0 [] t
return (T.take n t, t'')
-- | Parse out a possibly qualified operator or identifier
general :: Bool -- ^ refuse inputs starting with operators
-> Int -- ^ total characters \"consumed\" so far
-> [(Int, Text)] -- ^ accumulated results
-> Text -- ^ current input
-> [(Int, Text)] -- ^ total characters parsed & what remains
general !identOnly !i acc t
-- Starts with an identifier (either just an identifier, or a module qual)
| Just (n, rest) <- identLike t
= if T.null rest
then acc
else case T.head rest of
'`' -> (n + i, rest) : acc
')' -> (n + i, rest) : acc
'.' -> general False (n + i + 1) acc (T.tail rest)
'\'' -> let (m, rest') = quotes rest
in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest')
_ -> acc
-- An operator
| Just (n, rest) <- optr t
, not identOnly
= (n + i, rest) : acc
-- Anything else
| otherwise
= acc
-- | Parse an identifier off the front of the input
identLike t
| T.null t = Nothing
| isAlpha (T.head t) || '_' == T.head t
= let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t
!(octos, rest') = T.span (== '#') rest
in Just (T.length idt + T.length octos, rest')
| otherwise = Nothing
-- | Parse all but the last quote off the front of the input
-- PRECONDITION: T.head t `elem` ['\'', '`']
quotes :: Text -> (Int, Text)
quotes t = let !n = T.length (T.takeWhile (`elem` ['\'', '`']) t) - 1
in (n, T.drop n t)
-- | Parse an operator off the front of the input
optr t = let !(op, rest) = T.span isSymbolChar t
in if T.null op then Nothing else Just (T.length op, rest)
haddock-library-1.11.0/src/Documentation/Haddock/Parser/Monad.hs 0000644 0000000 0000000 00000012734 07346545000 022614 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
-- |
-- Module : Documentation.Haddock.Parser.Monad
-- Copyright : (c) Alec Theriault 2018-2019,
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
--
-- Defines the Parsec monad over which all parsing is done and also provides
-- more efficient versions of the usual parsec combinator functions (but
-- specialized to 'Text').
module Documentation.Haddock.Parser.Monad where
import qualified Text.Parsec.Char as Parsec
import qualified Text.Parsec as Parsec
import Text.Parsec.Pos ( updatePosChar )
import Text.Parsec ( State(..)
, getParserState, setParserState )
import qualified Data.Text as T
import Data.Text ( Text )
import Control.Monad ( mfilter )
import Data.String ( IsString(..) )
import Data.Bits ( Bits(..) )
import Data.Char ( ord )
import Data.List ( foldl' )
import Control.Applicative as App
import Documentation.Haddock.Types ( Version )
import Prelude hiding (takeWhile)
import CompatPrelude
-- | The only bit of information we really care about trudging along with us
-- through parsing is the version attached to a @\@since@ annotation - if
-- the doc even contained one.
newtype ParserState = ParserState {
parserStateSince :: Maybe Version
} deriving (Eq, Show)
initialParserState :: ParserState
initialParserState = ParserState Nothing
setSince :: Version -> Parser ()
setSince since = Parsec.modifyState (\st -> st{ parserStateSince = Just since })
type Parser = Parsec.Parsec Text ParserState
instance (a ~ Text) => IsString (Parser a) where
fromString = fmap T.pack . Parsec.string
parseOnly :: Parser a -> Text -> Either String (ParserState, a)
parseOnly p t = case Parsec.runParser p' initialParserState "" t of
Left e -> Left (show e)
Right (x,s) -> Right (s,x)
where p' = (,) <$> p <*> Parsec.getState
-- | Always succeeds, but returns 'Nothing' if at the end of input. Does not
-- consume input.
--
-- Equivalent to @Parsec.optionMaybe . Parsec.lookAhead $ Parsec.anyChar@, but
-- more efficient.
peekChar :: Parser (Maybe Char)
peekChar = headOpt . stateInput <$> getParserState
where headOpt t | T.null t = Nothing
| otherwise = Just (T.head t)
{-# INLINE peekChar #-}
-- | Fails if at the end of input. Does not consume input.
--
-- Equivalent to @Parsec.lookAhead Parsec.anyChar@, but more efficient.
peekChar' :: Parser Char
peekChar' = headFail . stateInput =<< getParserState
where headFail t | T.null t = Parsec.parserFail "peekChar': reached EOF"
| otherwise = App.pure (T.head t)
{-# INLINE peekChar' #-}
-- | Parses the given string. Returns the parsed string.
--
-- Equivalent to @Parsec.string (T.unpack t) $> t@, but more efficient.
string :: Text -> Parser Text
string t = do
s@State{ stateInput = inp, statePos = pos } <- getParserState
case T.stripPrefix t inp of
Nothing -> Parsec.parserFail "string: Failed to match the input string"
Just inp' ->
let pos' = T.foldl updatePosChar pos t
s' = s{ stateInput = inp', statePos = pos' }
in setParserState s' $> t
-- | Keep matching characters as long as the predicate function holds (and
-- return them).
--
-- Equivalent to @fmap T.pack . Parsec.many@, but more efficient.
takeWhile :: (Char -> Bool) -> Parser Text
takeWhile f = do
s@State{ stateInput = inp, statePos = pos } <- getParserState
let (t, inp') = T.span f inp
pos' = T.foldl updatePosChar pos t
s' = s{ stateInput = inp', statePos = pos' }
setParserState s' $> t
-- | Like 'takeWhile', but fails if no characters matched.
--
-- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient.
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 = mfilter (not . T.null) . takeWhile
-- | Scan the input text, accumulating characters as long as the scanning
-- function returns true.
scan :: (s -> Char -> Maybe s) -- ^ scan function
-> s -- ^ initial state
-> Parser Text
scan f st = do
s@State{ stateInput = inp, statePos = pos } <- getParserState
go inp st pos 0 $ \inp' pos' n ->
let s' = s{ Parsec.stateInput = inp', Parsec.statePos = pos' }
in setParserState s' $> T.take n inp
where
go inp s !pos !n cont
= case T.uncons inp of
Nothing -> cont inp pos n -- ran out of input
Just (c, inp') ->
case f s c of
Nothing -> cont inp pos n -- scan function failed
Just s' -> go inp' s' (updatePosChar pos c) (n+1) cont
-- | Parse a decimal number.
decimal :: Integral a => Parser a
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 = 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
haddock-library-1.11.0/src/Documentation/Haddock/Parser/Util.hs 0000644 0000000 0000000 00000004653 07346545000 022474 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Documentation.Haddock.Parser.Util
-- Copyright : (c) Mateusz Kowalczyk 2013-2014,
-- Simon Hengel 2013
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
--
-- Various utility functions used by the parser.
module Documentation.Haddock.Parser.Util (
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
import Prelude hiding (takeWhile)
import Data.Char (isSpace)
-- | Characters that count as horizontal space
horizontalSpace :: Char -> Bool
horizontalSpace c = isSpace c && c /= '\n'
-- | Skip and ignore leading horizontal space
skipHorizontalSpace :: Parser ()
skipHorizontalSpace = Parsec.skipMany (Parsec.satisfy horizontalSpace)
-- | Take leading horizontal space
takeHorizontalSpace :: Parser Text
takeHorizontalSpace = takeWhile horizontalSpace
makeLabeled :: (String -> Maybe String -> a) -> Text -> a
makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of
(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 :: 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
-- | 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 = T.unpack end_
p :: (Bool, String) -> Char -> Maybe (Bool, String)
p acc c = case acc of
(True, _) -> Just (False, end)
(_, []) -> Nothing
(_, x:xs) | x == c -> Just (False, xs)
_ -> Just (c == '\\', end)
requireEnd = mfilter (T.isSuffixOf end_)
gotSome xs
| T.null xs = fail "didn't get any content"
| otherwise = return xs
haddock-library-1.11.0/src/Documentation/Haddock/Types.hs 0000644 0000000 0000000 00000025026 07346545000 021424 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, DeriveTraversable #-}
-- |
-- Module : Documentation.Haddock.Types
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2009,
-- Mateusz Kowalczyk 2013
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskellorg
-- Stability : experimental
-- Portability : portable
--
-- Exposes documentation data types used for (some) of Haddock.
module Documentation.Haddock.Types where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Foldable
import Data.Traversable
#endif
#if MIN_VERSION_base(4,8,0)
import Control.Arrow ((***))
import Data.Bifunctor
#endif
#if MIN_VERSION_base(4,10,0)
import Data.Bifoldable
import Data.Bitraversable
#endif
-- | With the advent of 'Version', we may want to start attaching more
-- 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.
data Meta = Meta { _version :: Maybe Version
, _package :: Maybe Package
} deriving (Eq, Show)
data MetaDoc mod id =
MetaDoc { _meta :: Meta
, _doc :: DocH mod id
} deriving (Eq, Show, Functor, Foldable, Traversable)
#if MIN_VERSION_base(4,8,0)
-- | __NOTE__: Only defined for @base >= 4.8.0@
instance Bifunctor MetaDoc where
bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d)
#endif
#if MIN_VERSION_base(4,10,0)
-- | __NOTE__: Only defined for @base >= 4.10.0@
instance Bifoldable MetaDoc where
bifoldr f g z d = bifoldr f g z (_doc d)
-- | __NOTE__: Only defined for @base >= 4.10.0@
instance Bitraversable MetaDoc where
bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d
#endif
overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
overDoc f d = d { _doc = f $ _doc d }
overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d)
overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)
type Version = [Int]
type Package = String
data Hyperlink id = Hyperlink
{ hyperlinkUrl :: String
, hyperlinkLabel :: Maybe id
} deriving (Eq, Show, Functor, Foldable, Traversable)
data ModLink id = ModLink
{ modLinkName :: String
, modLinkLabel :: Maybe id
} deriving (Eq, Show, Functor, Foldable, Traversable)
data Picture = Picture
{ pictureUri :: String
, pictureTitle :: Maybe String
} deriving (Eq, Show)
data Header id = Header
{ headerLevel :: Int -- ^ between 1 and 6 inclusive
, headerTitle :: id
} deriving (Eq, Show, Functor, Foldable, Traversable)
data Example = Example
{ exampleExpression :: String
, 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)
| DocString String
| DocParagraph (DocH mod id)
| DocIdentifier id
| DocIdentifierUnchecked mod
-- ^ A qualified identifier that couldn't be resolved.
| DocModule (ModLink (DocH mod id))
-- ^ A link to a module, with an optional label.
| DocWarning (DocH mod id)
-- ^ This constructor has no counterpart in Haddock markup.
| DocEmphasis (DocH mod id)
| DocMonospaced (DocH mod id)
| DocBold (DocH mod id)
| DocUnorderedList [DocH mod id]
| DocOrderedList [(Int, DocH mod id)]
| DocDefList [(DocH mod id, DocH mod id)]
| DocCodeBlock (DocH mod id)
| DocHyperlink (Hyperlink (DocH mod id))
| DocPic Picture
| DocMathInline String
| DocMathDisplay String
| DocAName String
-- ^ A (HTML) anchor. It must not contain any spaces.
| DocProperty String
| DocExamples [Example]
| DocHeader (Header (DocH mod id))
| DocTable (Table (DocH mod id))
deriving (Eq, Show, Functor, Foldable, Traversable)
#if MIN_VERSION_base(4,8,0)
-- | __NOTE__: Only defined for @base >= 4.8.0@
instance Bifunctor DocH where
bimap _ _ DocEmpty = DocEmpty
bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB)
bimap _ _ (DocString s) = DocString s
bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc)
bimap _ g (DocIdentifier i) = DocIdentifier (g i)
bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m)
bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl))
bimap f g (DocWarning doc) = DocWarning (bimap f g doc)
bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc)
bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc)
bimap f g (DocBold doc) = DocBold (bimap f g doc)
bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)
bimap f g (DocOrderedList docs) = DocOrderedList (map (\(index, a) -> (index, bimap f g a)) docs)
bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs)
bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)
bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl))
bimap _ _ (DocPic picture) = DocPic picture
bimap _ _ (DocMathInline s) = DocMathInline s
bimap _ _ (DocMathDisplay s) = DocMathDisplay s
bimap _ _ (DocAName s) = DocAName s
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)
-- | __NOTE__: Only defined for @base >= 4.10.0@
instance Bifoldable DocH where
bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB
bifoldr f g z (DocParagraph doc) = bifoldr f g z doc
bifoldr _ g z (DocIdentifier i) = g i z
bifoldr f _ z (DocIdentifierUnchecked m) = f m z
bifoldr f g z (DocWarning doc) = bifoldr f g z doc
bifoldr f g z (DocEmphasis doc) = bifoldr f g z doc
bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc
bifoldr f g z (DocBold doc) = bifoldr f g z doc
bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs
bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z (map snd docs)
bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs
bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc
bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title
bifoldr f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header
bifoldr _ _ z _ = z
-- | __NOTE__: Only defined for @base >= 4.10.0@
instance Bitraversable DocH where
bitraverse _ _ DocEmpty = pure DocEmpty
bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB
bitraverse _ _ (DocString s) = pure (DocString s)
bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc
bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i
bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m
bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl)
bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc
bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc
bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc
bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc
bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs
bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverseSnd (bitraverse f g) docs
where traverseSnd f' = traverse (\(x, a) -> (\b -> (x, b)) <$> f' a)
bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs
bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc
bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl)
bitraverse _ _ (DocPic picture) = pure (DocPic picture)
bitraverse _ _ (DocMathInline s) = pure (DocMathInline s)
bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s)
bitraverse _ _ (DocAName s) = pure (DocAName s)
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
-- | The namespace qualification for an identifier.
data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show)
-- | Render the a namespace into the same format it was initially parsed.
renderNs :: Namespace -> String
renderNs Value = "v"
renderNs Type = "t"
renderNs None = ""
-- | 'DocMarkupH' is a set of instructions for marking up documentation.
-- In fact, it's really just a mapping from 'Doc' to some other
-- type [a], where [a] is usually the type of the output (HTML, say).
-- Use 'Documentation.Haddock.Markup.markup' to apply a 'DocMarkupH' to
-- a 'DocH'.
--
-- @since 1.4.5
--
data DocMarkupH mod id a = Markup
{ markupEmpty :: a
, markupString :: String -> a
, markupParagraph :: a -> a
, markupAppend :: a -> a -> a
, markupIdentifier :: id -> a
, markupIdentifierUnchecked :: mod -> a
, markupModule :: ModLink a -> a
, markupWarning :: a -> a
, markupEmphasis :: a -> a
, markupBold :: a -> a
, markupMonospaced :: a -> a
, markupUnorderedList :: [a] -> a
, markupOrderedList :: [(Int,a)] -> a
, markupDefList :: [(a,a)] -> a
, markupCodeBlock :: a -> a
, markupHyperlink :: Hyperlink a -> a
, markupAName :: String -> a
, markupPic :: Picture -> a
, markupMathInline :: String -> a
, markupMathDisplay :: String -> a
, markupProperty :: String -> a
, markupExample :: [Example] -> a
, markupHeader :: Header a -> a
, markupTable :: Table a -> a
}
haddock-library-1.11.0/test/Documentation/Haddock/Parser/ 0000755 0000000 0000000 00000000000 07346545000 021403 5 ustar 00 0000000 0000000 haddock-library-1.11.0/test/Documentation/Haddock/Parser/UtilSpec.hs 0000644 0000000 0000000 00000001427 07346545000 023473 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Documentation.Haddock.Parser.UtilSpec (main, spec) where
import Documentation.Haddock.Parser.Monad
import Documentation.Haddock.Parser.Util
import Data.Either (isLeft)
import Test.Hspec
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
#endif
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "takeUntil" $ do
it "takes everything until a specified byte sequence" $ do
snd <$> parseOnly (takeUntil "end") "someend" `shouldBe` Right "some"
it "requires the end sequence" $ do
snd <$> parseOnly (takeUntil "end") "someen" `shouldSatisfy` isLeft
it "takes escaped bytes unconditionally" $ do
snd <$> parseOnly (takeUntil "end") "some\\endend" `shouldBe` Right "some\\end"
haddock-library-1.11.0/test/Documentation/Haddock/ 0000755 0000000 0000000 00000000000 07346545000 020147 5 ustar 00 0000000 0000000 haddock-library-1.11.0/test/Documentation/Haddock/ParserSpec.hs 0000644 0000000 0000000 00000120063 07346545000 022554 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Documentation.Haddock.ParserSpec (main, spec) where
import Data.Char (isSpace)
import Data.String
import qualified Documentation.Haddock.Parser as Parse
import Documentation.Haddock.Types
import Documentation.Haddock.Doc (docAppend)
import Test.Hspec
import Test.QuickCheck
import Prelude hiding ((<>))
infixr 6 <>
(<>) :: Doc id -> Doc id -> Doc id
(<>) = docAppend
type Doc id = DocH () id
instance IsString (Doc String) where
fromString = DocString
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 Nothing
parseString :: String -> Doc String
parseString = Parse.toRegular . Parse.parseString
hyperlink :: String -> Maybe (Doc String) -> Doc String
hyperlink url = DocHyperlink . Hyperlink url
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "parseString" $ do
let infix 1 `shouldParseTo`
shouldParseTo :: String -> Doc String -> Expectation
shouldParseTo input ast = parseString input `shouldBe` ast
it "is total" $ do
property $ \xs ->
(length . show . parseString) xs `shouldSatisfy` (> 0)
context "when parsing text" $ do
it "can handle unicode" $ do
"灼眼のシャナ" `shouldParseTo` "灼眼のシャナ"
it "accepts numeric character references" $ do
"foo bar baz λ" `shouldParseTo` "foo bar baz λ"
it "accepts hexadecimal character references" $ do
"e" `shouldParseTo` "e"
it "allows to backslash-escape characters except \\r" $ do
property $ \y -> case y of
'\r' -> "\\\r" `shouldParseTo` DocString "\\"
x -> ['\\', x] `shouldParseTo` DocString [x]
context "when parsing strings contaning numeric character references" $ do
it "will implicitly convert digits to characters" $ do
"AAAA" `shouldParseTo` "AAAA"
"灼眼のシャナ"
`shouldParseTo` "灼眼のシャナ"
it "will implicitly convert hex encoded characters" $ do
"eeee" `shouldParseTo` "eeee"
context "when parsing identifiers" $ do
it "parses identifiers enclosed within single ticks" $ do
"'foo'" `shouldParseTo` DocIdentifier "foo"
it "parses identifiers enclosed within backticks" $ do
"`foo`" `shouldParseTo` DocIdentifier "foo"
it "parses identifiers preceded by a backtick and followed by a single quote" $ do
"`foo'" `shouldParseTo` DocIdentifier "foo"
it "parses identifiers preceded by a single quote and followed by a backtick" $ do
"'foo`" `shouldParseTo` DocIdentifier "foo"
it "can parse a constructor identifier" $ do
"'Foo'" `shouldParseTo` DocIdentifier "Foo"
it "can parse a qualified identifier" $ do
"'Foo.bar'" `shouldParseTo` DocIdentifier "Foo.bar"
it "parses a word with an one of the delimiters in it as DocString" $ do
"don't" `shouldParseTo` "don't"
it "doesn't pass pairs of delimiters with spaces between them" $ do
"hel'lo w'orld" `shouldParseTo` "hel'lo w'orld"
it "don't use apostrophe's in the wrong place's" $ do
" don't use apostrophe's in the wrong place's" `shouldParseTo`
"don't use apostrophe's in the wrong place's"
it "doesn't parse empty identifiers" $ do
"``" `shouldParseTo` "``"
it "can parse an identifier in infix notation enclosed within backticks" $ do
"``infix``" `shouldParseTo` DocIdentifier "`infix`"
it "can parse identifiers containing a single quote" $ do
"'don't'" `shouldParseTo` DocIdentifier "don't"
it "can parse identifiers ending with a single quote" $ do
"'foo''" `shouldParseTo` DocIdentifier "foo'"
it "can parse identifiers in backticks ending with a single quote" $ do
"`foo'`" `shouldParseTo` DocIdentifier "foo'"
it "can parse an identifier containing a digit" $ do
"'f0'" `shouldParseTo` DocIdentifier "f0"
it "can parse an identifier containing unicode characters" $ do
"'λ'" `shouldParseTo` DocIdentifier "λ"
it "can parse a single quote followed by an identifier" $ do
"''foo'" `shouldParseTo` "'" <> DocIdentifier "foo"
it "can parse an identifier that starts with an underscore" $ do
"'_x'" `shouldParseTo` DocIdentifier "_x"
it "can parse value-namespaced identifiers" $ do
"v'foo'" `shouldParseTo` DocIdentifier "foo"
it "can parse type-namespaced identifiers" $ do
"t'foo'" `shouldParseTo` DocIdentifier "foo"
it "can parse parenthesized operators and backticked identifiers" $ do
"'(<|>)'" `shouldParseTo` DocIdentifier "(<|>)"
"'`elem`'" `shouldParseTo` DocIdentifier "`elem`"
it "can properly figure out the end of identifiers" $ do
"'DbModule'/'DbUnitId'" `shouldParseTo` DocIdentifier "DbModule" <> "/" <> DocIdentifier "DbUnitId"
context "when parsing operators" $ do
it "can parse an operator enclosed within single quotes" $ do
"'.='" `shouldParseTo` DocIdentifier ".="
it "can parse a qualified operator" $ do
"'F..'" `shouldParseTo` DocIdentifier "F.."
it "can parse a constructor operator" $ do
"':='" `shouldParseTo` DocIdentifier ":="
it "can parse a qualified constructor operator" $ do
"'F.:='" `shouldParseTo` DocIdentifier "F.:="
it "can parse a unicode operator" $ do
"'∧'" `shouldParseTo` DocIdentifier "∧"
context "when parsing URLs" $ do
it "parses a URL" $ do
"" `shouldParseTo` hyperlink "http://example.com/" Nothing
it "accepts an optional label" $ do
"" `shouldParseTo` hyperlink "http://example.com/" "some link"
it "does not accept newlines in label" $ do
"" `shouldParseTo` ""
-- new behaviour test, this will be now consistent with other markup
it "allows us to escape > inside the URL" $ do
"le.com>" `shouldParseTo`
hyperlink "http://examp>le.com" Nothing
"mp\\>le.com>" `shouldParseTo`
hyperlink "http://exa>mp>le.com" Nothing
-- Likewise in label
"oo>" `shouldParseTo`
hyperlink "http://example.com" "f>oo"
it "parses inline URLs" $ do
"foo bar" `shouldParseTo`
"foo " <> hyperlink "http://example.com/" Nothing <> " bar"
it "doesn't allow for multi-line link tags" $ do
"" `shouldParseTo` ""
context "when parsing markdown links" $ do
it "parses a simple link" $ do
"[some label](url)" `shouldParseTo`
hyperlink "url" "some label"
it "allows whitespace between label and URL" $ do
"[some label] \t (url)" `shouldParseTo`
hyperlink "url" "some label"
it "allows newlines in label" $ do
"[some\n\nlabel](url)" `shouldParseTo`
hyperlink "url" "some\n\nlabel"
it "allows escaping in label" $ do
"[some\\] label](url)" `shouldParseTo`
hyperlink "url" "some] label"
it "strips leading and trailing whitespace from label" $ do
"[ some label ](url)" `shouldParseTo`
hyperlink "url" "some label"
it "rejects whitespace in URL" $ do
"[some label]( url)" `shouldParseTo`
"[some label]( url)"
it "allows inline markup in the label" $ do
"[something /emphasized/](url)" `shouldParseTo`
hyperlink "url" (Just ("something " <> DocEmphasis "emphasized"))
context "when URL is on a separate line" $ do
it "allows URL to be on a separate line" $ do
"[some label]\n(url)" `shouldParseTo`
hyperlink "url" "some label"
it "allows leading whitespace" $ do
"[some label]\n \t (url)" `shouldParseTo`
hyperlink "url" "some label"
it "rejects additional newlines" $ do
"[some label]\n\n(url)" `shouldParseTo`
"[some label]\n\n(url)"
context "when autolinking URLs" $ do
it "autolinks HTTP URLs" $ do
"http://example.com/" `shouldParseTo` hyperlink "http://example.com/" Nothing
it "autolinks HTTPS URLs" $ do
"https://www.example.com/" `shouldParseTo` hyperlink "https://www.example.com/" Nothing
it "autolinks FTP URLs" $ do
"ftp://example.com/" `shouldParseTo` hyperlink "ftp://example.com/" Nothing
it "does not include a trailing comma" $ do
"http://example.com/, Some other sentence." `shouldParseTo`
hyperlink "http://example.com/" Nothing <> ", Some other sentence."
it "does not include a trailing dot" $ do
"http://example.com/. Some other sentence." `shouldParseTo`
hyperlink "http://example.com/" Nothing <> ". Some other sentence."
it "does not include a trailing exclamation mark" $ do
"http://example.com/! Some other sentence." `shouldParseTo`
hyperlink "http://example.com/" Nothing <> "! Some other sentence."
it "does not include a trailing question mark" $ do
"http://example.com/? Some other sentence." `shouldParseTo`
hyperlink "http://example.com/" Nothing <> "? Some other sentence."
it "autolinks URLs occuring mid-sentence with multiple ‘/’s" $ do
"foo https://example.com/example bar" `shouldParseTo`
"foo " <> hyperlink "https://example.com/example" Nothing <> " bar"
context "when parsing images" $ do
let image :: String -> Maybe String -> Doc String
image uri = DocPic . Picture uri
it "accepts markdown syntax for images" $ do
"" `shouldParseTo` image "url" "label"
it "accepts Unicode" $ do
"" `shouldParseTo` image "url" "灼眼のシャナ"
it "supports deprecated picture syntax" $ do
"<>" `shouldParseTo` image "baz" Nothing
it "supports title for deprecated picture syntax" $ do
"<>" `shouldParseTo` image "b" "a z"
context "when parsing display math" $ do
it "accepts markdown syntax for display math containing newlines" $ do
"\\[\\pi\n\\pi\\]" `shouldParseTo` DocMathDisplay "\\pi\n\\pi"
context "when parsing anchors" $ do
it "parses a single word anchor" $ do
"#foo#" `shouldParseTo` DocAName "foo"
-- Spaces are not allowed:
-- https://www.w3.org/TR/html51/dom.html#the-id-attribute
it "doesn't parse a multi word anchor" $ do
"#foo bar#" `shouldParseTo` "#foo bar#"
it "parses a unicode anchor" $ do
"#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ"
it "does not accept newlines in anchors" $ do
"#foo\nbar#" `shouldParseTo` "#foo\nbar#"
it "accepts anchors mid-paragraph" $ do
"Hello #someAnchor# world!"
`shouldParseTo` "Hello " <> DocAName "someAnchor" <> " world!"
it "does not accept empty anchors" $ do
"##" `shouldParseTo` "##"
it "does not accept anchors containing spaces" $ do
"{-# LANGUAGE GADTs #-}" `shouldParseTo` "{-# LANGUAGE GADTs #-}"
context "when parsing emphasised text" $ do
it "emphasises a word on its own" $ do
"/foo/" `shouldParseTo` DocEmphasis "foo"
it "emphasises inline correctly" $ do
"foo /bar/ baz" `shouldParseTo` "foo " <> DocEmphasis "bar" <> " baz"
it "emphasises unicode" $ do
"/灼眼のシャナ/" `shouldParseTo` DocEmphasis "灼眼のシャナ"
it "does not emphasise multi-line strings" $ do
" /foo\nbar/" `shouldParseTo` "/foo\nbar/"
it "does not emphasise the empty string" $ do
"//" `shouldParseTo` "//"
it "parses escaped slashes literally" $ do
"/foo\\/bar/" `shouldParseTo` DocEmphasis "foo/bar"
it "recognizes other markup constructs within emphasised text" $ do
"/foo @bar@ baz/" `shouldParseTo`
DocEmphasis ("foo " <> DocMonospaced "bar" <> " baz")
it "allows other markup inside of emphasis" $ do
"/__inner bold__/" `shouldParseTo` DocEmphasis (DocBold "inner bold")
it "doesn't mangle inner markup unicode" $ do
"/__灼眼のシャナ A__/" `shouldParseTo` DocEmphasis (DocBold "灼眼のシャナ A")
it "properly converts HTML escape sequences" $ do
"/AAAA/" `shouldParseTo` DocEmphasis "AAAA"
it "allows to escape the emphasis delimiter inside of emphasis" $ do
"/empha\\/sis/" `shouldParseTo` DocEmphasis "empha/sis"
context "when parsing monospaced text" $ do
it "parses simple monospaced text" $ do
"@foo@" `shouldParseTo` DocMonospaced "foo"
it "parses inline monospaced text" $ do
"foo @bar@ baz" `shouldParseTo` "foo " <> DocMonospaced "bar" <> " baz"
it "allows to escape @" $ do
"@foo \\@ bar@" `shouldParseTo` DocMonospaced "foo @ bar"
it "accepts unicode" $ do
"@foo 灼眼のシャナ bar@" `shouldParseTo` DocMonospaced "foo 灼眼のシャナ bar"
it "accepts other markup in monospaced text" $ do
"@/foo/@" `shouldParseTo` DocMonospaced (DocEmphasis "foo")
it "requires the closing @" $ do
"@foo /bar/ baz" `shouldParseTo` "@foo " <> DocEmphasis "bar" <> " baz"
context "when parsing bold strings" $ do
it "allows for a bold string on its own" $ do
"__bold string__" `shouldParseTo`
DocBold "bold string"
it "bolds inline correctly" $ do
"hello __everyone__ there" `shouldParseTo`
"hello "
<> DocBold "everyone" <> " there"
it "bolds unicode" $ do
"__灼眼のシャナ__" `shouldParseTo`
DocBold "灼眼のシャナ"
it "does not do __multi-line\\n bold__" $ do
" __multi-line\n bold__" `shouldParseTo` "__multi-line\n bold__"
it "allows other markup inside of bold" $ do
"__/inner emphasis/__" `shouldParseTo`
(DocBold $ DocEmphasis "inner emphasis")
it "doesn't mangle inner markup unicode" $ do
"__/灼眼のシャナ A/__" `shouldParseTo`
(DocBold $ DocEmphasis "灼眼のシャナ A")
it "properly converts HTML escape sequences" $ do
"__AAAA__" `shouldParseTo`
DocBold "AAAA"
it "allows to escape the bold delimiter inside of bold" $ do
"__bo\\__ld__" `shouldParseTo`
DocBold "bo__ld"
it "doesn't allow for empty bold" $ do
"____" `shouldParseTo` "____"
context "when parsing module strings" $ do
it "should parse a module on its own" $ do
"\"Module\"" `shouldParseTo`
DocModule (ModLink "Module" Nothing)
it "should parse a module inline" $ do
"This is a \"Module\"." `shouldParseTo`
"This is a " <> DocModule (ModLink "Module" Nothing) <> "."
it "can accept a simple module name" $ do
"\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing)
it "can accept a module name with dots" $ do
"\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing)
it "can accept a module name with unicode" $ do
"\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing)
it "parses a module name with a trailing dot as regular quoted string" $ do
"\"Hello.\"" `shouldParseTo` "\"Hello.\""
it "parses a module name with a space as regular quoted string" $ do
"\"Hello World\"" `shouldParseTo` "\"Hello World\""
it "parses a module name with invalid characters as regular quoted string" $ do
"\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\""
it "accepts a module name with unicode" $ do
"\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing)
it "treats empty module name as regular double quotes" $ do
"\"\"" `shouldParseTo` "\"\""
it "accepts anchor reference syntax as DocModule" $ do
"\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing)
it "accepts anchor with hyphen as DocModule" $ do
"\"Foo#bar-baz\"" `shouldParseTo` DocModule (ModLink "Foo#bar-baz" Nothing)
it "accepts old anchor reference syntax as DocModule" $ do
"\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing)
context "when parsing labeled module links" $ do
it "parses a simple labeled module link" $ do
"[some label](\"Some.Module\")" `shouldParseTo`
DocModule (ModLink "Some.Module" (Just "some label"))
it "allows escaping in label" $ do
"[some\\] label](\"Some.Module\")" `shouldParseTo`
DocModule (ModLink "Some.Module" (Just "some] label"))
it "strips leading and trailing whitespace from label" $ do
"[ some label ](\"Some.Module\")" `shouldParseTo`
DocModule (ModLink "Some.Module" (Just "some label"))
it "allows whitespace in module name link" $ do
"[some label]( \"Some.Module\"\t )" `shouldParseTo`
DocModule (ModLink "Some.Module" (Just "some label"))
it "allows inline markup in the label" $ do
"[something /emphasized/](\"Some.Module\")" `shouldParseTo`
DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized")))
it "should parse a labeled module on its own" $ do
"[label](\"Module\")" `shouldParseTo`
DocModule (ModLink "Module" (Just "label"))
it "should parse a labeled module inline" $ do
"This is a [label](\"Module\")." `shouldParseTo`
"This is a " <> DocModule (ModLink "Module" (Just "label")) <> "."
it "can accept a labeled module name with dots" $ do
"[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label"))
it "can accept a labeled module name with unicode" $ do
"[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label"))
it "parses a labeled module name with a trailing dot as a hyperlink" $ do
"[label](\"Hello.\")" `shouldParseTo`
hyperlink "\"Hello.\"" (Just "label")
it "parses a labeled module name with a space as a regular string" $ do
"[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")"
it "parses a module name with invalid characters as a hyperlink" $ do
"[label](\"Hello&[{}(=*+]!\")" `shouldParseTo`
hyperlink "\"Hello&[{}(=*+]!\"" (Just "label")
it "accepts a labeled module name with unicode" $ do
"[label](\"Foo.Barλ\")" `shouldParseTo`
DocModule (ModLink "Foo.Barλ" (Just "label"))
it "treats empty labeled module name as empty hyperlink" $ do
"[label](\"\")" `shouldParseTo`
hyperlink "\"\"" (Just "label")
it "accepts anchor reference syntax for labeled module name" $ do
"[label](\"Foo#bar\")" `shouldParseTo`
DocModule (ModLink "Foo#bar" (Just "label"))
it "accepts old anchor reference syntax for labeled module name" $ do
"[label](\"Foo\\#bar\")" `shouldParseTo`
DocModule (ModLink "Foo\\#bar" (Just "label"))
it "interprets empty label as a unlabeled module name" $ do
"[](\"Module.Name\")" `shouldParseTo`
"[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")"
describe "parseParas" $ do
let infix 1 `shouldParseTo`
shouldParseTo :: String -> Doc String -> Expectation
shouldParseTo input ast = _doc (parseParas input) `shouldBe` ast
it "is total" $ do
property $ \xs ->
(length . show . parseParas) xs `shouldSatisfy` (> 0)
-- See
it "doesn't crash on unicode whitespace" $ do
"\8197" `shouldParseTo` DocEmpty
context "when parsing @since" $ do
it "adds specified version to the result" $ do
parseParas "@since 0.5.0" `shouldBe`
MetaDoc { _meta = emptyMeta { _version = Just [0,5,0] }
, _doc = DocEmpty }
it "ignores trailing whitespace" $ do
parseParas "@since 0.5.0 \t " `shouldBe`
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 = emptyMeta { _version = Nothing }
, _doc = DocParagraph "@since 0.5.0 foo" }
context "when given multiple times" $ do
it "gives last occurrence precedence" $ do
(parseParas . unlines) [
"@since 0.5.0"
, "@since 0.6.0"
, "@since 0.7.0"
] `shouldBe` MetaDoc { _meta = emptyMeta { _version = Just [0,7,0] }
, _doc = DocEmpty }
context "when parsing text paragraphs" $ do
let isSpecial c = isSpace c || c `elem` (".(=#-[*`\\\"'_/@<>" :: String)
filterSpecial = filter (not . isSpecial)
it "parses an empty paragraph" $ do
"" `shouldParseTo` DocEmpty
it "parses a simple text paragraph" $ do
"foo bar baz" `shouldParseTo` DocParagraph "foo bar baz"
it "accepts markup in text paragraphs" $ do
"foo /bar/ baz" `shouldParseTo` DocParagraph ("foo " <> DocEmphasis "bar" <> " baz")
it "preserve all regular characters" $ do
property $ \xs -> let input = filterSpecial xs in (not . null) input ==>
input `shouldParseTo` DocParagraph (DocString input)
it "separates paragraphs by empty lines" $ do
unlines [
"foo"
, " \t "
, "bar"
] `shouldParseTo` DocParagraph "foo" <> DocParagraph "bar"
context "when a pragraph only contains monospaced text" $ do
it "turns it into a code block" $ do
"@foo@" `shouldParseTo` DocCodeBlock "foo"
context "when a paragraph contains a markdown link" $ do
it "correctly parses the link" $ do
"Blah [label](url)" `shouldParseTo`
DocParagraph ("Blah " <> hyperlink "url" "label")
context "when the paragraph starts with the markdown link" $ do
it "correctly parses it as a text paragraph (not a definition list)" $ do
"[label](url)" `shouldParseTo`
DocParagraph (hyperlink "url" "label")
it "can be followed by an other paragraph" $ do
"[label](url)\n\nfoobar" `shouldParseTo`
DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar"
context "when paragraph contains additional text" $ do
it "accepts more text after the link" $ do
"[label](url) foo bar baz" `shouldParseTo`
DocParagraph (hyperlink "url" "label" <> " foo bar baz")
it "accepts a newline right after the markdown link" $ do
"[label](url)\nfoo bar baz" `shouldParseTo`
DocParagraph (hyperlink "url" "label" <> " foo bar baz")
it "can be followed by an other paragraph" $ do
"[label](url)foo\n\nbar" `shouldParseTo`
DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar"
context "when the link starts on a new line not at the beginning of the paragraph" $ do
it "correctly parses the link" $ do
"Bla\n[label](url)" `shouldParseTo`
DocParagraph ("Bla\n" <> hyperlink "url" "label")
context "when parsing birdtracks" $ do
it "parses them as a code block" $ do
unlines [
">foo"
, ">bar"
, ">baz"
] `shouldParseTo` DocCodeBlock "foo\nbar\nbaz"
it "ignores leading whitespace" $ do
unlines [
" >foo"
, " \t >bar"
, " >baz"
]
`shouldParseTo` DocCodeBlock "foo\nbar\nbaz"
it "strips one leading space from each line of the block" $ do
unlines [
"> foo"
, "> bar"
, "> baz"
] `shouldParseTo` DocCodeBlock "foo\n bar\nbaz"
it "ignores empty lines when stripping spaces" $ do
unlines [
"> foo"
, ">"
, "> bar"
] `shouldParseTo` DocCodeBlock "foo\n\nbar"
context "when any non-empty line does not start with a space" $ do
it "does not strip any spaces" $ do
unlines [
">foo"
, "> bar"
] `shouldParseTo` DocCodeBlock "foo\n bar"
it "ignores nested markup" $ do
unlines [
">/foo/"
] `shouldParseTo` DocCodeBlock "/foo/"
it "treats them as regular text inside text paragraphs" $ do
unlines [
"foo"
, ">bar"
] `shouldParseTo` DocParagraph "foo\n>bar"
context "when parsing code blocks" $ do
it "accepts a simple code block" $ do
unlines [
"@"
, "foo"
, "bar"
, "baz"
, "@"
] `shouldParseTo` DocCodeBlock "foo\nbar\nbaz\n"
it "ignores trailing whitespace after the opening @" $ do
unlines [
"@ "
, "foo"
, "@"
] `shouldParseTo` DocCodeBlock "foo\n"
it "rejects code blocks that are not closed" $ do
unlines [
"@"
, "foo"
] `shouldParseTo` DocParagraph "@\nfoo"
it "accepts nested markup" $ do
unlines [
"@"
, "/foo/"
, "@"
] `shouldParseTo` DocCodeBlock (DocEmphasis "foo" <> "\n")
it "allows to escape the @" $ do
unlines [
"@"
, "foo"
, "\\@"
, "bar"
, "@"
] `shouldParseTo` DocCodeBlock "foo\n@\nbar\n"
it "accepts horizontal space before the @" $ do
unlines [ " @"
, "foo"
, ""
, "bar"
, "@"
] `shouldParseTo` DocCodeBlock "foo\n\nbar\n"
it "strips a leading space from a @ block if present" $ do
unlines [ " @"
, " hello"
, " world"
, " @"
] `shouldParseTo` DocCodeBlock "hello\nworld\n"
unlines [ " @"
, " hello"
, ""
, " world"
, " @"
] `shouldParseTo` DocCodeBlock "hello\n\nworld\n"
it "only drops whitespace if there's some before closing @" $ do
unlines [ "@"
, " Formatting"
, " matters."
, "@"
]
`shouldParseTo` DocCodeBlock " Formatting\n matters.\n"
it "accepts unicode" $ do
"@foo 灼眼のシャナ bar@" `shouldParseTo` DocCodeBlock "foo 灼眼のシャナ bar"
it "requires the closing @" $ do
"@foo /bar/ baz"
`shouldParseTo` DocParagraph ("@foo " <> DocEmphasis "bar" <> " baz")
context "when parsing examples" $ do
it "parses a simple example" $ do
">>> foo" `shouldParseTo` DocExamples [Example "foo" []]
it "parses an example with result" $ do
unlines [
">>> foo"
, "bar"
, "baz"
] `shouldParseTo` DocExamples [Example "foo" ["bar", "baz"]]
it "parses consecutive examples" $ do
unlines [
">>> fib 5"
, "5"
, ">>> fib 10"
, "55"
] `shouldParseTo` DocExamples [
Example "fib 5" ["5"]
, Example "fib 10" ["55"]
]
it ("requires an example to be separated"
++ " from a previous paragraph by an empty line") $ do
"foobar\n\n>>> fib 10\n55" `shouldParseTo`
DocParagraph "foobar"
<> DocExamples [Example "fib 10" ["55"]]
it "parses bird-tracks inside of paragraphs as plain strings" $ do
let xs = "foo\n>>> bar"
xs `shouldParseTo` DocParagraph (DocString xs)
it "skips empty lines in front of an example" $ do
"\n \n\n>>> foo" `shouldParseTo` DocExamples [Example "foo" []]
it "terminates example on empty line" $ do
unlines [
">>> foo"
, "bar"
, " "
, "baz"
]
`shouldParseTo`
DocExamples [Example "foo" ["bar"]] <> DocParagraph "baz"
it "parses a result as an empty result" $ do
unlines [
">>> foo"
, "bar"
, ""
, "baz"
]
`shouldParseTo` DocExamples [Example "foo" ["bar", "", "baz"]]
it "accepts unicode in examples" $ do
">>> 灼眼\nシャナ" `shouldParseTo` DocExamples [Example "灼眼" ["シャナ"]]
context "when prompt is prefixed by whitespace" $ do
it "strips the exact same amount of whitespace from result lines" $ do
unlines [
" >>> foo"
, " bar"
, " baz"
] `shouldParseTo` DocExamples [Example "foo" ["bar", "baz"]]
it "preserves additional whitespace" $ do
unlines [
" >>> foo"
, " bar"
] `shouldParseTo` DocExamples [Example "foo" [" bar"]]
it "keeps original if stripping is not possible" $ do
unlines [
" >>> foo"
, " bar"
] `shouldParseTo` DocExamples [Example "foo" [" bar"]]
context "when parsing paragraphs nested in lists" $ do
it "can nest the same type of list" $ do
"* foo\n\n * bar" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
<> DocUnorderedList [DocParagraph "bar"]]
it "can nest another type of list inside" $ do
"* foo\n\n 1. bar" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
<> DocOrderedList [(1, DocParagraph "bar")]]
it "can nest a code block inside" $ do
"* foo\n\n @foo bar baz@" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
<> DocCodeBlock "foo bar baz"]
"* foo\n\n @\n foo bar baz\n @" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
<> DocCodeBlock "foo bar baz\n"]
it "can nest more than one level" $ do
"* foo\n\n * bar\n\n * baz\n qux" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
<> DocUnorderedList [ DocParagraph "bar"
<> DocUnorderedList [DocParagraph "baz\nqux"]
]
]
it "won't fail on not fully indented paragraph" $ do
"* foo\n\n * bar\n\n * qux\nquux" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
<> DocUnorderedList [ DocParagraph "bar" ]
, DocParagraph "qux\nquux"]
it "can nest definition lists" $ do
"[a]: foo\n\n [b]: bar\n\n [c]: baz\n qux" `shouldParseTo`
DocDefList [ ("a", "foo"
<> DocDefList [ ("b", "bar"
<> DocDefList [("c", "baz\nqux")])
])
]
it "can come back to top level with a different list" $ do
"* foo\n\n * bar\n\n1. baz" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
<> DocUnorderedList [ DocParagraph "bar" ]
]
<> DocOrderedList [ (1, DocParagraph "baz") ]
it "allows arbitrary initial indent of a list" $ do
unlines
[ " * foo"
, " * bar"
, ""
, " * quux"
, ""
, " * baz"
]
`shouldParseTo`
DocUnorderedList
[ DocParagraph "foo"
, DocParagraph "bar"
<> DocUnorderedList [ DocParagraph "quux" ]
, DocParagraph "baz"
]
it "definition lists can come back to top level with a different list" $ do
"[foo]: foov\n\n [bar]: barv\n\n1. baz" `shouldParseTo`
DocDefList [ ("foo", "foov"
<> DocDefList [ ("bar", "barv") ])
]
<> DocOrderedList [ (1, DocParagraph "baz") ]
it "list order is preserved in presence of nesting + extra text" $ do
"1. Foo\n\n > Some code\n\n2. Bar\n\nSome text"
`shouldParseTo`
DocOrderedList [ (1, DocParagraph "Foo" <> DocCodeBlock "Some code")
, (2, DocParagraph "Bar")
]
<> DocParagraph (DocString "Some text")
"1. Foo\n\n2. Bar\n\nSome text"
`shouldParseTo`
DocOrderedList [ (1, DocParagraph "Foo")
, (2, DocParagraph "Bar")
]
<> DocParagraph (DocString "Some text")
context "when parsing properties" $ do
it "can parse a single property" $ do
"prop> 23 == 23" `shouldParseTo` DocProperty "23 == 23"
it "can parse multiple subsequent properties" $ do
unlines [
"prop> 23 == 23"
, "prop> 42 == 42"
]
`shouldParseTo`
DocProperty "23 == 23" <> DocProperty "42 == 42"
it "accepts unicode in properties" $ do
"prop> 灼眼のシャナ ≡ 愛" `shouldParseTo`
DocProperty "灼眼のシャナ ≡ 愛"
it "can deal with whitespace before and after the prop> prompt" $ do
" prop> xs == (reverse $ reverse xs) " `shouldParseTo`
DocProperty "xs == (reverse $ reverse xs)"
context "when parsing unordered lists" $ do
it "parses a simple list" $ do
unlines [
" * one"
, " * two"
, " * three"
]
`shouldParseTo` DocUnorderedList [
DocParagraph "one"
, DocParagraph "two"
, DocParagraph "three"
]
it "ignores empty lines between list items" $ do
unlines [
"* one"
, ""
, "* two"
]
`shouldParseTo` DocUnorderedList [
DocParagraph "one"
, DocParagraph "two"
]
it "accepts an empty list item" $ do
"*" `shouldParseTo` DocUnorderedList [DocParagraph DocEmpty]
it "accepts multi-line list items" $ do
unlines [
"* point one"
, " more one"
, "* point two"
, "more two"
]
`shouldParseTo` DocUnorderedList [
DocParagraph "point one\n more one"
, DocParagraph "point two\nmore two"
]
it "accepts markup in list items" $ do
"* /foo/" `shouldParseTo` DocUnorderedList [DocParagraph (DocEmphasis "foo")]
it "requires empty lines between list and other paragraphs" $ do
unlines [
"foo"
, ""
, "* bar"
, ""
, "baz"
]
`shouldParseTo` DocParagraph "foo" <> DocUnorderedList [DocParagraph "bar"] <> DocParagraph "baz"
context "when parsing ordered lists" $ do
it "parses a simple list" $ do
unlines [
" 1. one"
, " (1) two"
, " 3. three"
]
`shouldParseTo` DocOrderedList [
(1, DocParagraph "one")
, (1, DocParagraph "two")
, (3, DocParagraph "three")
]
it "ignores empty lines between list items" $ do
unlines [
"1. one"
, ""
, "2. two"
]
`shouldParseTo` DocOrderedList [
(1, DocParagraph "one")
, (2, DocParagraph "two")
]
it "accepts an empty list item" $ do
"1." `shouldParseTo` DocOrderedList [(1, DocParagraph DocEmpty)]
it "accepts multi-line list items" $ do
unlines [
"1. point one"
, " more one"
, "1. point two"
, "more two"
]
`shouldParseTo` DocOrderedList [
(1, DocParagraph "point one\n more one")
, (1, DocParagraph "point two\nmore two")
]
it "accepts markup in list items" $ do
"1. /foo/" `shouldParseTo` DocOrderedList [(1, DocParagraph (DocEmphasis "foo"))]
it "requires empty lines between list and other paragraphs" $ do
unlines [
"foo"
, ""
, "1. bar"
, ""
, "baz"
]
`shouldParseTo` DocParagraph "foo" <> DocOrderedList [(1, DocParagraph "bar")] <> DocParagraph "baz"
context "when parsing definition lists" $ do
it "parses a simple list" $ do
unlines [
" [foo]: one"
, " [bar]: two"
, " [baz]: three"
]
`shouldParseTo` DocDefList [
("foo", "one")
, ("bar", "two")
, ("baz", "three")
]
it "ignores empty lines between list items" $ do
unlines [
"[foo]: one"
, ""
, "[bar]: two"
]
`shouldParseTo` DocDefList [
("foo", "one")
, ("bar", "two")
]
it "accepts an empty list item" $ do
"[foo]:" `shouldParseTo` DocDefList [("foo", DocEmpty)]
it "accepts multi-line list items" $ do
unlines [
"[foo]: point one"
, " more one"
, "[bar]: point two"
, "more two"
]
`shouldParseTo` DocDefList [
("foo", "point one\n more one")
, ("bar", "point two\nmore two")
]
it "accepts markup in list items" $ do
"[foo]: /foo/" `shouldParseTo` DocDefList [("foo", DocEmphasis "foo")]
it "accepts markup for the label" $ do
"[/foo/]: bar" `shouldParseTo` DocDefList [(DocEmphasis "foo", "bar")]
it "requires empty lines between list and other paragraphs" $ do
unlines [
"foo"
, ""
, "[foo]: bar"
, ""
, "baz"
]
`shouldParseTo` DocParagraph "foo" <> DocDefList [("foo", "bar")] <> DocParagraph "baz"
it "dose not require the colon (deprecated - this will be removed in a future release)" $ do
unlines [
" [foo] one"
, " [bar] two"
, " [baz] three"
]
`shouldParseTo` DocDefList [
("foo", "one")
, ("bar", "two")
, ("baz", "three")
]
context "when parsing consecutive paragraphs" $ do
it "will not capture irrelevant consecutive lists" $ do
unlines [ " * bullet"
, ""
, ""
, " - different bullet"
, ""
, ""
, " (1) ordered"
, " "
, " 2. different bullet"
, " "
, " [cat]: kitten"
, " "
, " [pineapple]: fruit"
] `shouldParseTo`
DocUnorderedList [ DocParagraph "bullet"
, DocParagraph "different bullet"]
<> DocOrderedList [ (1, DocParagraph "ordered")
, (2, DocParagraph "different bullet")
]
<> DocDefList [ ("cat", "kitten")
, ("pineapple", "fruit")
]
context "when parsing function documentation headers" $ do
it "can parse a simple header" $ do
"= Header 1\nHello." `shouldParseTo`
(DocHeader (Header 1 "Header 1"))
<> DocParagraph "Hello."
it "allow consecutive headers" $ do
"= Header 1\n== Header 2" `shouldParseTo`
DocHeader (Header 1 "Header 1")
<> DocHeader (Header 2 "Header 2")
it "accepts markup in the header" $ do
"= /Header/ __1__\nFoo" `shouldParseTo`
DocHeader (Header 1 (DocEmphasis "Header" <> " " <> DocBold "1"))
<> DocParagraph "Foo"
haddock-library-1.11.0/test/ 0000755 0000000 0000000 00000000000 07346545000 014001 5 ustar 00 0000000 0000000 haddock-library-1.11.0/test/Spec.hs 0000644 0000000 0000000 00000000054 07346545000 015226 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -F -pgmF hspec-discover #-}