haddock-library-1.8.0/0000755000000000000000000000000007346545000012750 5ustar0000000000000000haddock-library-1.8.0/CHANGES.md0000755000000000000000000000162007346545000014344 0ustar0000000000000000## 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.8.0/LICENSE0000644000000000000000000000235407346545000013761 0ustar0000000000000000Copyright 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: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. haddock-library-1.8.0/Setup.hs0000644000000000000000000000005607346545000014405 0ustar0000000000000000import Distribution.Simple main = defaultMain haddock-library-1.8.0/fixtures/0000755000000000000000000000000007346545000014621 5ustar0000000000000000haddock-library-1.8.0/fixtures/Fixtures.hs0000644000000000000000000001077707346545000017002 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Control.Applicative ((<|>)) import Control.Exception (IOException, catch) import Control.Monad (when) import Data.Foldable (traverse_) import Data.List (foldl') import Data.Traversable (for) import GHC.Generics (Generic) import Prelude () import Prelude.Compat import System.Directory (getDirectoryContents) import System.Exit (exitFailure) import System.FilePath import System.IO import Data.TreeDiff import Data.TreeDiff.Golden import qualified Options.Applicative as O import Documentation.Haddock.Types import qualified Documentation.Haddock.Parser as Parse type Doc id = DocH () id data Fixture = Fixture { fixtureName :: FilePath , fixtureOutput :: FilePath } deriving Show data Result = Result { _resultSuccess :: !Int , _resultTotal :: !Int } deriving Show combineResults :: Result -> Result -> Result combineResults (Result s t) (Result s' t') = Result (s + s') (t + t') readFixtures :: IO [Fixture] readFixtures = do let dir = "fixtures/examples" files <- getDirectoryContents dir let inputs = filter (\fp -> takeExtension fp == ".input") files return $ flip map inputs $ \fp -> Fixture { fixtureName = dir fp , fixtureOutput = dir fp -<.> "parsed" } goldenFixture :: String -> IO Expr -> IO Expr -> (Expr -> Expr -> IO (Maybe String)) -> (Expr -> IO ()) -> IO Result goldenFixture name expect actual cmp wrt = do putStrLn $ "running " ++ name a <- actual e <- expect `catch` handler a mres <- cmp e a case mres of Nothing -> return (Result 1 1) Just str -> do putStrLn str return (Result 0 1) where handler :: Expr -> IOException -> IO Expr handler a exc = do putStrLn $ "Caught " ++ show exc putStrLn "Accepting the test" wrt a return a runFixtures :: [Fixture] -> IO () runFixtures fixtures = do results <- for fixtures $ \(Fixture i o) -> do let name = takeBaseName i let readDoc = do input <- readFile i return (parseString input) ediffGolden goldenFixture name o readDoc case foldl' combineResults (Result 0 0) results of Result s t -> do putStrLn $ "Fixtures: success " ++ show s ++ "; total " ++ show t when (s /= t) exitFailure listFixtures :: [Fixture] -> IO () listFixtures = traverse_ $ \(Fixture i _) -> do let name = takeBaseName i putStrLn name acceptFixtures :: [Fixture] -> IO () acceptFixtures = traverse_ $ \(Fixture i o) -> do input <- readFile i let doc = parseString input let actual = show (prettyExpr $ toExpr doc) ++ "\n" writeFile o actual parseString :: String -> Doc String parseString = Parse.toRegular . _doc . Parse.parseParas Nothing data Cmd = CmdRun | CmdAccept | CmdList main :: IO () main = do hSetBuffering stdout NoBuffering -- For interleaved output when debugging runCmd =<< O.execParser opts where opts = O.info (O.helper <*> cmdParser) O.fullDesc cmdParser :: O.Parser Cmd cmdParser = cmdRun <|> cmdAccept <|> cmdList <|> pure CmdRun cmdRun = O.flag' CmdRun $ mconcat [ O.long "run" , O.help "Run parser fixtures" ] cmdAccept = O.flag' CmdAccept $ mconcat [ O.long "accept" , O.help "Run & accept parser fixtures" ] cmdList = O.flag' CmdList $ mconcat [ O.long "list" , O.help "List fixtures" ] runCmd :: Cmd -> IO () runCmd CmdRun = readFixtures >>= runFixtures runCmd CmdList = readFixtures >>= listFixtures runCmd CmdAccept = readFixtures >>= acceptFixtures ------------------------------------------------------------------------------- -- Orphans ------------------------------------------------------------------------------- deriving instance Generic (DocH mod id) instance (ToExpr mod, ToExpr id) => ToExpr (DocH mod id) deriving instance Generic (Header id) instance ToExpr id => ToExpr (Header id) deriving instance Generic (Hyperlink id) instance ToExpr id => ToExpr (Hyperlink 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.8.0/fixtures/examples/0000755000000000000000000000000007346545000016437 5ustar0000000000000000haddock-library-1.8.0/fixtures/examples/definitionList.input0000755000000000000000000000001307346545000022501 0ustar0000000000000000[foo]: bar haddock-library-1.8.0/fixtures/examples/definitionList.parsed0000755000000000000000000000006607346545000022630 0ustar0000000000000000DocDefList [_×_ (DocString "foo") (DocString "bar")] haddock-library-1.8.0/fixtures/examples/identifier.input0000755000000000000000000000000607346545000021641 0ustar0000000000000000'foo' haddock-library-1.8.0/fixtures/examples/identifier.parsed0000755000000000000000000000004307346545000021761 0ustar0000000000000000DocParagraph (DocIdentifier "foo") haddock-library-1.8.0/fixtures/examples/identifierBackticks.input0000755000000000000000000000000607346545000023460 0ustar0000000000000000`foo` haddock-library-1.8.0/fixtures/examples/identifierBackticks.parsed0000755000000000000000000000004307346545000023600 0ustar0000000000000000DocParagraph (DocIdentifier "foo") haddock-library-1.8.0/fixtures/examples/link.input0000755000000000000000000000003307346545000020454 0ustar0000000000000000[link](http://example.com) haddock-library-1.8.0/fixtures/examples/link.parsed0000755000000000000000000000021407346545000020574 0ustar0000000000000000DocParagraph (DocHyperlink Hyperlink {hyperlinkLabel = Just (DocString "link"), hyperlinkUrl = "http://example.com"}) haddock-library-1.8.0/fixtures/examples/linkInline.input0000755000000000000000000000003707346545000021617 0ustar0000000000000000Bla [link](http://example.com) haddock-library-1.8.0/fixtures/examples/linkInline.parsed0000755000000000000000000000027607346545000021743 0ustar0000000000000000DocParagraph (DocAppend (DocString "Bla ") (DocHyperlink Hyperlink {hyperlinkLabel = Just (DocString "link"), hyperlinkUrl = "http://example.com"})) haddock-library-1.8.0/fixtures/examples/linkInlineMarkup.input0000755000000000000000000000005407346545000022776 0ustar0000000000000000Bla [link /emphasized/](http://example.com) haddock-library-1.8.0/fixtures/examples/linkInlineMarkup.parsed0000755000000000000000000000043607346545000023121 0ustar0000000000000000DocParagraph (DocAppend (DocString "Bla ") (DocHyperlink Hyperlink {hyperlinkLabel = Just (DocAppend (DocString "link ") (DocEmphasis (DocString "emphasized"))), hyperlinkUrl = "http://example.com"})) haddock-library-1.8.0/fixtures/examples/list-blocks1.input0000755000000000000000000000027107346545000022032 0ustar0000000000000000* 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.8.0/fixtures/examples/list-blocks1.parsed0000755000000000000000000000064507346545000022156 0ustar0000000000000000DocUnorderedList [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.8.0/fixtures/examples/list-blocks2.input0000755000000000000000000000015307346545000022032 0ustar0000000000000000=== Title * List directly * after the title @ with some inline things @ * is parsed weirdly haddock-library-1.8.0/fixtures/examples/list-blocks2.parsed0000755000000000000000000000061007346545000022147 0ustar0000000000000000DocAppend (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.8.0/fixtures/examples/table-simple.input0000755000000000000000000000072507346545000022105 0ustar0000000000000000+------+--------------+------------------------------------------+ | code | message | description | +======+==============+==========================================+ | 200 | @OK@ | operation successful | +------+--------------+------------------------------------------+ | 204 | @No Content@ | operation successful, no body returned | +------+--------------+------------------------------------------+ haddock-library-1.8.0/fixtures/examples/table-simple.parsed0000755000000000000000000000537107346545000022226 0ustar0000000000000000DocTable Table {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " 200 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocAppend (DocString " ") (DocAppend (DocMonospaced (DocString "OK")) (DocString " ")), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " operation successful ", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " 204 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocAppend (DocString " ") (DocAppend (DocMonospaced (DocString "No Content")) (DocString " ")), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " operation successful, no body returned ", tableCellRowspan = 1}]], tableHeaderRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " code ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " message ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " description ", tableCellRowspan = 1}]]} haddock-library-1.8.0/fixtures/examples/table1.input0000755000000000000000000000135007346545000020672 0ustar0000000000000000+------------------------+------------+----------+----------+ | 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.8.0/fixtures/examples/table1.parsed0000755000000000000000000001062307346545000021014 0ustar0000000000000000DocTable Table {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " body row 1, column 1 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 2 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 3 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 4 ", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " body row 2 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 3, tableCellContents = DocString " Cells may span columns. ", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " body row 3 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString (concat [" Cells may \n", " span rows. \n", " "]), tableCellRowspan = 2}, TableCell {tableCellColspan = 2, tableCellContents = DocAppend (DocString " ") (DocAppend (DocMathDisplay (concat [" \n", " f(n) = \\sum_{i=1} \n", " "])) (DocString " ")), tableCellRowspan = 2}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " body row 4 ", tableCellRowspan = 1}]], tableHeaderRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString (concat [" Header row, column 1 \n", " (header rows optional) "]), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString (concat [" Header 2 \n", " "]), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString (concat [" Header 3 \n", " "]), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString (concat [" Header 4 \n", " "]), tableCellRowspan = 1}]]} haddock-library-1.8.0/fixtures/examples/table2.input0000755000000000000000000000055407346545000020700 0ustar0000000000000000+--------------+----------+-----------+-----------+ | row 1, col 1 | column 2 | column 3 | column 4 | +--------------+----------+-----------+-----------+ | row 2 | | +--------------+----------+-----------+-----------+ | row 3 | | | | +--------------+----------+-----------+-----------+ haddock-library-1.8.0/fixtures/examples/table2.parsed0000755000000000000000000000432507346545000021017 0ustar0000000000000000DocTable Table {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " row 1, col 1 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 2 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 3 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 4 ", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " row 2 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 3, tableCellContents = DocString " ", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " row 3 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}]], tableHeaderRows = []} haddock-library-1.8.0/fixtures/examples/table3.input0000755000000000000000000000055407346545000020701 0ustar0000000000000000+--------------+----------+-----------+-----------+ | row 1, col 1 | column 2 | column 3 | column 4 | +--------------+----------+-----------+-----------+ | row 2 | Use the command ``ls | more``. | +--------------+----------+-----------+-----------+ | row 3 | | | | +--------------+----------+-----------+-----------+ haddock-library-1.8.0/fixtures/examples/table3.parsed0000755000000000000000000000463207346545000021021 0ustar0000000000000000DocTable Table {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " row 1, col 1 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 2 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 3 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 4 ", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " row 2 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 2, tableCellContents = DocString " Use the command ``ls ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " more``. ", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " row 3 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}]], tableHeaderRows = []} haddock-library-1.8.0/fixtures/examples/table4.input0000755000000000000000000000037407346545000020702 0ustar0000000000000000Single outer cell: +-------------+ | outer | | | +-------+ | | inner | | +-------+-----+ Broken (only inner cell is rendered): +-------+-----+ | inner | | +-------+ | | | | outer | +-------------+ haddock-library-1.8.0/fixtures/examples/table4.parsed0000755000000000000000000000230507346545000021015 0ustar0000000000000000DocAppend (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.8.0/fixtures/examples/table5.input0000755000000000000000000000064007346545000020677 0ustar0000000000000000+--------------+----------+-----------+-----------+ | row 1, col 1 | column 2 | column 3 | column 4 | +==============+==========+===========+===========+ | row 2 | Use the command @ls | more@. | | | | | +----------+-----------+-----------+ | row 3 | | | | +--------------+----------+-----------+-----------+ haddock-library-1.8.0/fixtures/examples/table5.parsed0000755000000000000000000000551507346545000021024 0ustar0000000000000000DocTable Table {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString (concat [" row 2 \n", " \n", " \n", " row 3 "]), tableCellRowspan = 2}, TableCell {tableCellColspan = 3, tableCellContents = DocAppend (DocString " Use the command ") (DocAppend (DocMonospaced (DocString "ls | more")) (DocString (concat [". \n", " "]))), tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " ", tableCellRowspan = 1}]], tableHeaderRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString " row 1, col 1 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 2 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 3 ", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString " column 4 ", tableCellRowspan = 1}]]} haddock-library-1.8.0/fixtures/examples/url.input0000755000000000000000000000002607346545000020323 0ustar0000000000000000 haddock-library-1.8.0/fixtures/examples/url.parsed0000755000000000000000000000016507346545000020446 0ustar0000000000000000DocParagraph (DocHyperlink Hyperlink {hyperlinkLabel = Nothing, hyperlinkUrl = "http://example.com/"}) haddock-library-1.8.0/fixtures/examples/urlLabel.input0000755000000000000000000000004007346545000021257 0ustar0000000000000000 haddock-library-1.8.0/fixtures/examples/urlLabel.parsed0000755000000000000000000000022207346545000021400 0ustar0000000000000000DocParagraph (DocHyperlink Hyperlink {hyperlinkLabel = Just (DocString "some link"), hyperlinkUrl = "http://example.com/"}) haddock-library-1.8.0/haddock-library.cabal0000644000000000000000000000721307346545000016776 0ustar0000000000000000cabal-version: 2.2 name: haddock-library version: 1.8.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell libraries. These modules expose some functionality of it without pulling in the GHC dependency. Please note that the API is likely to change so 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-files: 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 extra-source-files: CHANGES.md fixtures/examples/*.input fixtures/examples/*.parsed common lib-defaults default-language: Haskell2010 build-depends: , base >= 4.5 && < 4.14 , bytestring ^>= 0.9.2.1 || ^>= 0.10.0.0 , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1 , transformers ^>= 0.3.0.0 || ^>= 0.4.1.0 || ^>= 0.5.0.0 , text ^>= 1.2.3.0 , parsec ^>= 3.1.13.0 ghc-options: -funbox-strict-fields -Wall -fwarn-tabs if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances library import: lib-defaults hs-source-dirs: src exposed-modules: Documentation.Haddock.Doc Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Types other-modules: Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Identifier test-suite spec import: lib-defaults type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test src cpp-options: -DTEST other-modules: Documentation.Haddock.Doc Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.UtilSpec Documentation.Haddock.ParserSpec Documentation.Haddock.Types Documentation.Haddock.Parser.Identifier build-depends: , base-compat ^>= 0.9.3 || ^>= 0.11.0 , QuickCheck ^>= 2.11 || ^>= 2.13.2 , deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0 -- NB: build-depends & build-tool-depends have independent -- install-plans, so it's best to limit to a single major -- version of `hspec` & `hspec-discover` to ensure -- intercompatibility build-depends: , hspec >= 2.4.4 && < 2.8 build-tool-depends: , hspec-discover:hspec-discover >= 2.4.4 && < 2.8 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.9.3 || ^>= 0.11.0 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 , optparse-applicative ^>= 0.15 , tree-diff ^>= 0.1 source-repository head type: git subdir: haddock-library location: https://github.com/haskell/haddock.git haddock-library-1.8.0/src/Documentation/Haddock/0000755000000000000000000000000007346545000017705 5ustar0000000000000000haddock-library-1.8.0/src/Documentation/Haddock/Doc.hs0000644000000000000000000000700707346545000020752 0ustar0000000000000000{-# 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.8.0/src/Documentation/Haddock/Markup.hs0000644000000000000000000001065507346545000021507 0ustar0000000000000000-- | @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 mod0) = markupModule m mod0 markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocBold d) = markupBold m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l)) markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img markup m (DocMathInline mathjax) = markupMathInline m mathjax markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax markup m (DocProperty p) = markupProperty m p markup m (DocExamples e) = markupExample m e markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) -- | 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 = id, markupWarning = id, markupEmphasis = id, markupBold = id, markupMonospaced = id, markupUnorderedList = const "", markupOrderedList = const "", markupDefList = const "", markupCodeBlock = id, markupHyperlink = \(Hyperlink url lbl) -> fromMaybe url lbl, markupAName = id, markupPic = \(Picture uri title) -> fromMaybe uri title, markupMathInline = id, markupMathDisplay = id, markupProperty = id, markupExample = const "", markupHeader = \(Header _ title) -> title, markupTable = const "" } haddock-library-1.8.0/src/Documentation/Haddock/Parser.hs0000644000000000000000000007235407346545000021510 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 x) = DocModule x g (DocWarning x) = DocWarning $ g x g (DocEmphasis x) = DocEmphasis $ g x g (DocMonospaced x) = DocMonospaced $ g x g (DocBold x) = DocBold $ g x g (DocUnorderedList x) = DocUnorderedList $ fmap g x g (DocOrderedList x) = DocOrderedList $ fmap g x g (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 , 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 characers. 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 <$> disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") -- | 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 <$> ("\"" *> modid <* "\"") where modid = intercalate "." <$> conid `Parsec.sepBy1` "." conid = (:) <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) <*> many (conChar <|> Parsec.oneOf "\\#") conChar = Parsec.alphaNum <|> Parsec.char '_' -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. -- -- >>> 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 "![some /emphasis/ in a description](www.site.com)" -- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) markdownImage :: Parser (DocH mod Identifier) markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) where fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) stringMarkup = plainMarkup (const "") renderIdent renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) paragraph = choice' [ examples , table , do indent <- takeIndent choice' [ since , unorderedList indent , orderedList indent , birdtracks , codeblock , property , header , textParagraphThatStartsWithMarkdownLink , definitionList indent , docParagraph <$> textParagraph ] ] -- | Provides support for grid tables. -- -- Tables are composed by an optional header and body. The header is composed by -- a single row. The body is composed by a non-empty list of rows. -- -- Example table with header: -- -- > +----------+----------+ -- > | /32bit/ | 64bit | -- > +==========+==========+ -- > | 0x0000 | @0x0000@ | -- > +----------+----------+ -- -- Algorithms loosely follows ideas in -- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py -- table :: Parser (DocH mod Identifier) table = do -- first we parse the first row, which determines the width of the table firstRow <- parseFirstRow let len = T.length firstRow -- then we parse all consequtive rows starting and ending with + or |, -- of the width `len`. restRows <- many (try (parseRestRows len)) -- Now we gathered the table block, the next step is to split the block -- into cells. DocTable <$> tableStepTwo len (firstRow : restRows) where parseFirstRow :: Parser Text parseFirstRow = do skipHorizontalSpace 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.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 = choice' psers delim <- T.unpack <$> pser line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText rest <- try paragraph <|> return DocEmpty return $ DocHeader (Header (length delim) line) `docAppend` rest textParagraph :: Parser (DocH mod Identifier) textParagraph = 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 = (paren <|> dot) *> innerList indent p dot = (decimal :: Parser Int) <* "." paren = "(" *> decimal <* ")" -- | 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 entitity (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, markdownLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString) <$> disallowNewline ("<" *> takeUntil ">") markdownLink :: Parser (DocH mod Identifier) markdownLink = DocHyperlink <$> linkParser linkParser :: Parser (Hyperlink (DocH mod Identifier)) linkParser = flip Hyperlink <$> label <*> (whitespace *> url) where label :: Parser (Maybe (DocH mod Identifier)) label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]") 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.8.0/src/Documentation/Haddock/Parser/0000755000000000000000000000000007346545000021141 5ustar0000000000000000haddock-library-1.8.0/src/Documentation/Haddock/Parser/Identifier.hs0000644000000000000000000001503007346545000023556 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Documentation.Haddock.Parser.Identifier -- Copyright : (c) Alec Theriault 2019, -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable -- -- Functionality for parsing identifiers and operators module Documentation.Haddock.Parser.Identifier ( Identifier(..), parseValid, ) where import Documentation.Haddock.Types ( Namespace(..) ) import Documentation.Haddock.Parser.Monad import qualified Text.Parsec as Parsec import Text.Parsec.Pos ( updatePosChar ) import Text.Parsec ( State(..) , getParserState, setParserState ) import Data.Text (Text) import qualified Data.Text as T import Data.Char (isAlpha, isAlphaNum) import Control.Monad (guard) import Data.Functor (($>)) #if MIN_VERSION_base(4,9,0) import Text.Read.Lex (isSymbolChar) #else import Data.Char (GeneralCategory (..), generalCategory) #endif import Data.Maybe -- | Identifier string surrounded with namespace, opening, and closing quotes/backticks. data Identifier = Identifier !Namespace !Char String !Char deriving (Show, Eq) parseValid :: Parser Identifier parseValid = do s@State{ stateInput = inp, statePos = pos } <- getParserState case takeIdentifier inp of Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier" Just (ns, op, ident, cl, inp') -> let posOp = updatePosChar pos op posIdent = T.foldl updatePosChar posOp ident posCl = updatePosChar posIdent cl s' = s{ stateInput = inp', statePos = posCl } in setParserState s' $> Identifier ns op (T.unpack ident) cl #if !MIN_VERSION_base(4,9,0) -- inlined from base-4.10.0.0 isSymbolChar :: Char -> Bool isSymbolChar c = not (isPuncChar c) && case generalCategory c of MathSymbol -> True CurrencySymbol -> True ModifierSymbol -> True OtherSymbol -> True DashPunctuation -> True OtherPunctuation -> c `notElem` "'\"" ConnectorPunctuation -> c /= '_' _ -> False where -- | The @special@ character class as defined in the Haskell Report. isPuncChar :: Char -> Bool isPuncChar = (`elem` (",;()[]{}`" :: String)) #endif -- | Try to parse a delimited identifier off the front of the given input. -- -- This tries to match as many valid Haskell identifiers/operators as possible, -- to the point of sometimes accepting invalid things (ex: keywords). Some -- considerations: -- -- - operators and identifiers can have module qualifications -- - operators can be wrapped in parens (for prefix) -- - identifiers can be wrapped in backticks (for infix) -- - delimiters are backticks or regular ticks -- - since regular ticks are also valid in identifiers, we opt for the -- longest successful parse -- -- This function should make /O(1)/ allocations takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text) takeIdentifier input = listToMaybe $ do -- Optional namespace let (ns, input') = case T.uncons input of Just ('v', i) -> (Value, i) Just ('t', i) -> (Type, i) _ -> (None, input) -- Opening tick (op, input'') <- maybeToList (T.uncons input') guard (op == '\'' || op == '`') -- Identifier/operator (ident, input''') <- wrapped input'' -- Closing tick (cl, input'''') <- maybeToList (T.uncons input''') guard (cl == '\'' || cl == '`') return (ns, op, ident, cl, input'''') where -- | Parse out a wrapped, possibly qualified, operator or identifier wrapped t = do (c, t' ) <- maybeToList (T.uncons t) -- Tuples case c of '(' | Just (c', _) <- T.uncons t' , c' == ',' || c' == ')' -> do let (commas, t'') = T.span (== ',') t' (')', t''') <- maybeToList (T.uncons t'') return (T.take (T.length commas + 2) t, t''') -- Parenthesized '(' -> do (n, t'' ) <- general False 0 [] t' (')', t''') <- maybeToList (T.uncons t'') return (T.take (n + 2) t, t''') -- Backticked '`' -> do (n, t'' ) <- general False 0 [] t' ('`', t''') <- maybeToList (T.uncons t'') return (T.take (n + 2) t, t''') -- Unadorned _ -> do (n, t'' ) <- general False 0 [] t return (T.take n t, t'') -- | Parse out a possibly qualified operator or identifier general :: Bool -- ^ refuse inputs starting with operators -> Int -- ^ total characters \"consumed\" so far -> [(Int, Text)] -- ^ accumulated results -> Text -- ^ current input -> [(Int, Text)] -- ^ total characters parsed & what remains general !identOnly !i acc t -- Starts with an identifier (either just an identifier, or a module qual) | Just (n, rest) <- identLike t = if T.null rest then acc else case T.head rest of '`' -> (n + i, rest) : acc ')' -> (n + i, rest) : acc '.' -> general False (n + i + 1) acc (T.tail rest) '\'' -> let (m, rest') = quotes rest in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest') _ -> acc -- An operator | Just (n, rest) <- optr t , not identOnly = (n + i, rest) : acc -- Anything else | otherwise = acc -- | Parse an identifier off the front of the input identLike t | T.null t = Nothing | isAlpha (T.head t) || '_' == T.head t = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t !(octos, rest') = T.span (== '#') rest in Just (T.length idt + T.length octos, rest') | otherwise = Nothing -- | Parse all but the last quote off the front of the input -- PRECONDITION: T.head t == '\'' quotes :: Text -> (Int, Text) quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1 in (n, T.drop n t) -- | Parse an operator off the front of the input optr t = let !(op, rest) = T.span isSymbolChar t in if T.null op then Nothing else Just (T.length op, rest) haddock-library-1.8.0/src/Documentation/Haddock/Parser/Monad.hs0000644000000000000000000001304407346545000022535 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Documentation.Haddock.Parser.Monad -- Copyright : (c) Alec Theriault 2018-2019, -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable -- -- Defines the Parsec monad over which all parsing is done and also provides -- more efficient versions of the usual parsec combinator functions (but -- specialized to 'Text'). module Documentation.Haddock.Parser.Monad where import qualified Text.Parsec.Char as Parsec import qualified Text.Parsec as Parsec import Text.Parsec.Pos ( updatePosChar ) import Text.Parsec ( State(..) , getParserState, setParserState ) import qualified Data.Text as T import Data.Text ( Text ) import Control.Monad ( mfilter ) import Data.Functor ( ($>) ) import Data.String ( IsString(..) ) import Data.Bits ( Bits(..) ) import Data.Char ( ord ) import Data.List ( foldl' ) import Control.Applicative as App import Documentation.Haddock.Types ( Version ) import Prelude hiding (takeWhile) -- | The only bit of information we really care about truding along with us -- through parsing is the version attached to a @\@since@ annotation - if -- the doc even contained one. newtype ParserState = ParserState { parserStateSince :: Maybe Version } deriving (Eq, Show) 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.8.0/src/Documentation/Haddock/Parser/Util.hs0000644000000000000000000000464207346545000022420 0ustar0000000000000000{-# 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] horizontalSpace = " \t\f\v\r" -- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser () skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) -- | Take leading horizontal space takeHorizontalSpace :: Parser Text takeHorizontalSpace = takeWhile (`elem` 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.8.0/src/Documentation/Haddock/Types.hs0000644000000000000000000002343307346545000021352 0ustar0000000000000000{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, 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) instance Bifunctor MetaDoc where bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d) #endif #if MIN_VERSION_base(4,10,0) instance Bifoldable MetaDoc where bifoldr f g z d = bifoldr f g z (_doc d) 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 Picture = Picture { pictureUri :: String , pictureTitle :: Maybe String } deriving (Eq, Show) data Header id = Header { headerLevel :: Int , 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 String | DocWarning (DocH mod id) -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) | DocMonospaced (DocH mod id) | DocBold (DocH mod id) | DocUnorderedList [DocH mod id] | DocOrderedList [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. | 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) 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 _ _ (DocModule s) = DocModule s bimap f g (DocWarning doc) = DocWarning (bimap f g doc) bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) bimap f g (DocBold doc) = DocBold (bimap f g doc) bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs) bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs) bimap f g (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) 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 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 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 _ _ (DocModule s) = pure (DocModule s) bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs bitraverse f g (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 :: String -> a , markupWarning :: a -> a , markupEmphasis :: a -> a , markupBold :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a , markupOrderedList :: [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.8.0/test/Documentation/Haddock/Parser/0000755000000000000000000000000007346545000021331 5ustar0000000000000000haddock-library-1.8.0/test/Documentation/Haddock/Parser/UtilSpec.hs0000644000000000000000000000134307346545000023416 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Documentation.Haddock.Parser.UtilSpec (main, spec) where import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util import Data.Either.Compat (isLeft) import Test.Hspec import Control.Applicative 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.8.0/test/Documentation/Haddock/0000755000000000000000000000000007346545000020075 5ustar0000000000000000haddock-library-1.8.0/test/Documentation/Haddock/ParserSpec.hs0000644000000000000000000010723207346545000022505 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Documentation.Haddock.ParserSpec (main, spec) where 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 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 "![label](url)" `shouldParseTo` image "url" "label" it "accepts Unicode" $ do "![灼眼のシャナ](url)" `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" it "parses a multi word anchor" $ do "#foo bar#" `shouldParseTo` DocAName "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` "##" 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 "Module" it "should parse a module inline" $ do "This is a \"Module\"." `shouldParseTo` "This is a " <> DocModule "Module" <> "." it "can accept a simple module name" $ do "\"Hello\"" `shouldParseTo` DocModule "Hello" it "can accept a module name with dots" $ do "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World" it "can accept a module name with unicode" $ do "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ" 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 "Foo.Barλ" it "treats empty module name as regular double quotes" $ do "\"\"" `shouldParseTo` "\"\"" it "accepts anchor reference syntax as DocModule" $ do "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar" it "accepts old anchor reference syntax as DocModule" $ do "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" 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) 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 filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) 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 starts with a markdown link" $ do it "correctly parses it as a text paragraph (not a definition list)" $ do "[label](url)" `shouldParseTo` DocParagraph (hyperlink "url" "label") 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 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 [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 [ 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 [ DocParagraph "baz" ] it "list order is preserved in presence of nesting + extra text" $ do "1. Foo\n\n > Some code\n\n2. Bar\n\nSome text" `shouldParseTo` DocOrderedList [ DocParagraph "Foo" <> DocCodeBlock "Some code" , DocParagraph "Bar" ] <> DocParagraph (DocString "Some text") "1. Foo\n\n2. Bar\n\nSome text" `shouldParseTo` DocOrderedList [ DocParagraph "Foo" , 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 [ DocParagraph "one" , DocParagraph "two" , DocParagraph "three" ] it "ignores empty lines between list items" $ do unlines [ "1. one" , "" , "2. two" ] `shouldParseTo` DocOrderedList [ DocParagraph "one" , DocParagraph "two" ] it "accepts an empty list item" $ do "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty] it "accepts multi-line list items" $ do unlines [ "1. point one" , " more one" , "1. point two" , "more two" ] `shouldParseTo` DocOrderedList [ DocParagraph "point one\n more one" , DocParagraph "point two\nmore two" ] it "accepts markup in list items" $ do "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")] it "requires empty lines between list and other paragraphs" $ do unlines [ "foo" , "" , "1. bar" , "" , "baz" ] `shouldParseTo` DocParagraph "foo" <> DocOrderedList [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 [ DocParagraph "ordered" , 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.8.0/test/0000755000000000000000000000000007346545000013727 5ustar0000000000000000haddock-library-1.8.0/test/Spec.hs0000644000000000000000000000005407346545000015154 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}