haddock-library-1.7.0/0000755000000000000000000000000013361426704012752 5ustar0000000000000000haddock-library-1.7.0/LICENSE0000644000000000000000000000235413361426704013763 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.7.0/Setup.hs0000644000000000000000000000005613361426704014407 0ustar0000000000000000import Distribution.Simple main = defaultMain haddock-library-1.7.0/haddock-library.cabal0000644000000000000000000000674113361426704017005 0ustar0000000000000000cabal-version: 2.0 name: haddock-library version: 1.7.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell libraries. These modules expose some functionality of it without pulling in the GHC dependency. Please note that the API is likely to change so specify upper bounds in your project. For interacting with Haddock itself, see the [haddock package](https://hackage.haskell.org/package/haddock). license: BSD3 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 build-type: Simple extra-source-files: CHANGES.md library default-language: Haskell2010 build-depends: base >= 4.5 && < 4.13 , bytestring >= 0.9.2.1 && < 0.11 , containers >= 0.4.2.1 && < 0.7 , transformers >= 0.3.0 && < 0.6 , text >= 1.2.3.0 && < 1.3 , parsec >= 3.1.13.0 && < 3.2 hs-source-dirs: src exposed-modules: Documentation.Haddock.Doc Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Types Documentation.Haddock.Utf8 other-modules: Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad ghc-options: -funbox-strict-fields -Wall -fwarn-tabs if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: Spec.hs hs-source-dirs: test , src ghc-options: -Wall cpp-options: -DTEST other-modules: Documentation.Haddock.Doc Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.UtilSpec Documentation.Haddock.ParserSpec Documentation.Haddock.Types Documentation.Haddock.Utf8 Documentation.Haddock.Utf8Spec build-depends: base >= 4.5 && < 4.13 , base-compat >= 0.9.3 && < 0.11 , bytestring >= 0.9.2.1 && < 0.11 , containers >= 0.4.2.1 && < 0.7 , transformers >= 0.3.0 && < 0.6 , hspec >= 2.4.4 && < 2.6 , QuickCheck ^>= 2.11 , text >= 1.2.3.0 && < 1.3 , parsec >= 3.1.13.0 && < 3.2 , deepseq >= 1.3 && < 1.5 build-tool-depends: hspec-discover:hspec-discover >= 2.4.4 && < 2.6 test-suite fixtures type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: Fixtures.hs ghc-options: -Wall -O0 hs-source-dirs: fixtures buildable: False build-depends: base >= 4.5 && < 4.13 , base-compat >= 0.9.3 && < 0.11 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 , optparse-applicative ^>= 0.14.0.0 , tree-diff ^>= 0.0.0.1 -- Depend on the library. build-depends: haddock-library source-repository head type: git subdir: haddock-library location: https://github.com/haskell/haddock.git haddock-library-1.7.0/CHANGES.md0000644000000000000000000000127513361426704014351 0ustar0000000000000000## 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.7.0/src/0000755000000000000000000000000013361426704013541 5ustar0000000000000000haddock-library-1.7.0/src/Documentation/0000755000000000000000000000000013361426704016352 5ustar0000000000000000haddock-library-1.7.0/src/Documentation/Haddock/0000755000000000000000000000000013361426704017707 5ustar0000000000000000haddock-library-1.7.0/src/Documentation/Haddock/Markup.hs0000644000000000000000000000602313361426704021503 0ustar0000000000000000-- | @since 1.4.5 module Documentation.Haddock.Markup ( markup , idMarkup ) where import Documentation.Haddock.Types markup :: DocMarkupH mod id a -> DocH mod id -> a markup m DocEmpty = markupEmpty m markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) markup m (DocString s) = markupString m s markup m (DocParagraph d) = markupParagraph m (markup m d) markup m (DocIdentifier x) = markupIdentifier m x markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x markup m (DocModule mod0) = markupModule m mod0 markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocBold d) = markupBold m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img markup m (DocMathInline mathjax) = markupMathInline m mathjax markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax markup m (DocProperty p) = markupProperty m p markup m (DocExamples e) = markupExample m e markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) 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 } haddock-library-1.7.0/src/Documentation/Haddock/Doc.hs0000644000000000000000000000700713361426704020754 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.7.0/src/Documentation/Haddock/Parser.hs0000644000000000000000000007423713361426704021514 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, isAlphaNum, isSpace) import Data.List (intercalate, unfoldr, elemIndex, notElem) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set import Documentation.Haddock.Doc import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util 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) #if MIN_VERSION_base(4,9,0) import Text.Read.Lex (isSymbolChar) #else import Data.Char (GeneralCategory (..), generalCategory) #endif -- $setup -- >>> :set -XOverloadedStrings #if !MIN_VERSION_base(4,9,0) -- inlined from base-4.10.0.0 isSymbolChar :: Char -> Bool isSymbolChar c = not (isPuncChar c) && case generalCategory c of MathSymbol -> True CurrencySymbol -> True ModifierSymbol -> True OtherSymbol -> True DashPunctuation -> True OtherPunctuation -> c `notElem` ("'\"" :: String) ConnectorPunctuation -> c /= '_' _ -> False where -- | The @special@ character class as defined in the Haskell Report. isPuncChar :: Char -> Bool isPuncChar = (`elem` (",;()[]{}`" :: String)) #endif -- | Identifier string surrounded with opening and closing quotes/backticks. type Identifier = (Char, String, Char) -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String toRegular = fmap (\(_, x, _) -> x) -- | Maps over 'DocIdentifier's over 'String' with potentially failing -- conversion using user-supplied function. If the conversion fails, -- the identifier is deemed to not be valid and is treated as a -- regular string. overIdentifier :: (String -> Maybe a) -> DocH mod Identifier -> DocH mod a overIdentifier f d = g d where g (DocIdentifier (o, x, e)) = case f x of Nothing -> DocString $ o : x ++ [e] 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 x) = DocHyperlink 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 "\\]") markdownImage :: Parser (DocH mod a) markdownImage = fromHyperlink <$> ("!" *> linkParser) where fromHyperlink (Hyperlink url label) = DocPic (Picture url label) -- | 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 -- upper-left corner is + c <- Parsec.char '+' cs <- some (Parsec.char '-' <|> Parsec.char '+') -- upper right corner is + too guard (last cs == '+') -- trailing space skipHorizontalSpace _ <- Parsec.newline return (T.cons c $ T.pack cs) parseRestRows :: Int -> Parser Text parseRestRows l = do skipHorizontalSpace c <- Parsec.char '|' <|> Parsec.char '+' bs <- scan predicate (l - 2) c2 <- Parsec.char '|' <|> Parsec.char '+' -- trailing space skipHorizontalSpace _ <- Parsec.newline return (T.cons c (T.snoc bs c2)) where predicate n c | n <= 0 = Nothing | c == '\n' = Nothing | otherwise = Just (n - 1) -- Second step searchs for row of '+' and '=' characters, records it's index -- and changes to '=' to '-'. tableStepTwo :: Int -- ^ width -> [Text] -- ^ rows -> Parser (Table (DocH mod Identifier)) tableStepTwo width = go 0 [] where go _ left [] = tableStepThree width (reverse left) Nothing go n left (r : rs) | T.all (`elem` ['+', '=']) r = tableStepThree width (reverse left ++ r' : rs) (Just n) | otherwise = go (n + 1) (r : left) rs where r' = T.map (\c -> if c == '=' then '-' else c) r -- Third step recognises cells in the table area, returning a list of TC, cells. tableStepThree :: Int -- ^ width -> [Text] -- ^ rows -> Maybe Int -- ^ index of header separator -> Parser (Table (DocH mod Identifier)) tableStepThree width rs hdrIndex = do cells <- loop (Set.singleton (0, 0)) tableStepFour rs hdrIndex cells where height = length rs loop :: Set.Set (Int, Int) -> Parser [TC] loop queue = case Set.minView queue of Nothing -> return [] Just ((y, x), queue') | y + 1 >= height || x + 1 >= width -> loop queue' | otherwise -> case scanRight x y of Nothing -> loop queue' Just (x2, y2) -> do let tc = TC y x y2 x2 fmap (tc :) $ loop $ queue' `Set.union` Set.fromList [(y, x2), (y2, x), (y2, x2)] -- scan right looking for +, then try scan down -- -- do we need to record + saw on the way left and down? scanRight :: Int -> Int -> Maybe (Int, Int) scanRight x y = go (x + 1) where bs = rs !! y go x' | x' >= width = fail "overflow right " | T.index bs x' == '+' = scanDown x y x' <|> go (x' + 1) | T.index bs x' == '-' = go (x' + 1) | otherwise = fail $ "not a border (right) " ++ show (x,y,x') -- scan down looking for + scanDown :: Int -> Int -> Int -> Maybe (Int, Int) scanDown x y x2 = go (y + 1) where go y' | y' >= height = fail "overflow down" | T.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1) | T.index (rs !! y') x2 == '|' = go (y' + 1) | otherwise = fail $ "not a border (down) " ++ show (x,y,x2,y') -- check that at y2 x..x2 characters are '+' or '-' scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int) scanLeft x y x2 y2 | all (\x' -> T.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2 | otherwise = fail $ "not a border (left) " ++ show (x,y,x2,y2) where bs = rs !! y2 -- check that at y2 x..x2 characters are '+' or '-' scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int) scanUp x y x2 y2 | all (\y' -> T.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2) | otherwise = fail $ "not a border (up) " ++ show (x,y,x2,y2) -- | table cell: top left bottom right data TC = TC !Int !Int !Int !Int deriving Show tcXS :: TC -> [Int] tcXS (TC _ x _ x2) = [x, x2] tcYS :: TC -> [Int] tcYS (TC y _ y2 _) = [y, y2] -- | Fourth step. Given the locations of cells, forms 'Table' structure. tableStepFour :: [Text] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier)) tableStepFour rs hdrIndex cells = case hdrIndex of Nothing -> return $ Table [] rowsDoc Just i -> case elemIndex i yTabStops of Nothing -> return $ Table [] rowsDoc Just i' -> return $ uncurry Table $ splitAt i' rowsDoc where xTabStops = sortNub $ concatMap tcXS cells yTabStops = sortNub $ concatMap tcYS cells sortNub :: Ord a => [a] -> [a] sortNub = Set.toList . Set.fromList init' :: [a] -> [a] init' [] = [] init' [_] = [] init' (x : xs) = x : init' xs rowsDoc = (fmap . fmap) parseParagraph rows rows = map makeRow (init' yTabStops) where makeRow y = TableRow $ mapMaybe (makeCell y) cells makeCell y (TC y' x y2 x2) | y /= y' = Nothing | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1)) where xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops -- extract cell contents given boundaries extract :: Int -> Int -> Int -> Int -> Text extract x y x2 y2 = T.intercalate "\n" [ T.take (x2 - x + 1) $ T.drop x $ rs !! y' | y' <- [y .. y2] ] -- | Parse \@since annotations. since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty where version = decimal `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 (Parsec.noneOf "\n") >>= nonSpace _ <- "\n" pure (l <> "\n") -- | Takes indentation of first non-empty line. -- -- More precisely: skips all whitespace-only lines and returns indentation -- (horizontal space, might be empty) of that non-empty line. takeIndent :: Parser 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 (Parsec.noneOf "\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 (Parsec.noneOf "\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 a) hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = DocHyperlink . makeLabeled Hyperlink <$> disallowNewline ("<" *> takeUntil ">") markdownLink :: Parser (DocH mod a) markdownLink = DocHyperlink <$> linkParser linkParser :: Parser Hyperlink linkParser = flip Hyperlink <$> label <*> (whitespace *> url) where label :: Parser (Maybe String) label = Just . decode . 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 (Parsec.satisfy (not . isSpace)) mkLink :: Text -> DocH mod a mkLink s = case T.unsnoc s of Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x] _ -> DocHyperlink (mkHyperlink s) mkHyperlink :: Text -> Hyperlink mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing -- | Parses strings between identifier delimiters. Consumes all input that it -- deems to be valid in an identifier. Note that it simply blindly consumes -- characters and does no actual validation itself. parseValid :: Parser String parseValid = p some where idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') p p' = do vs <- p' idChar c <- peekChar' case c of '`' -> return vs '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] _ -> fail "outofvalid" -- | Parses identifiers with help of 'parseValid'. Asks GHC for -- 'String' from the string it deems valid. identifier :: Parser (DocH mod Identifier) identifier = do o <- idDelim vid <- parseValid e <- idDelim return $ DocIdentifier (o, vid, e) where idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') haddock-library-1.7.0/src/Documentation/Haddock/Types.hs0000644000000000000000000002256313361426704021357 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 = Hyperlink { hyperlinkUrl :: String , hyperlinkLabel :: Maybe String } deriving (Eq, Show) 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 | 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 _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink 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 _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink) 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 -- | '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 , 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.7.0/src/Documentation/Haddock/Utf8.hs0000644000000000000000000000541413361426704021075 0ustar0000000000000000module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where import Data.Bits ((.|.), (.&.), shiftL, shiftR) import qualified Data.ByteString as BS import Data.Char (chr, ord) import Data.Word (Word8) -- | Helper that encodes and packs a 'String' into a 'BS.ByteString' encodeUtf8 :: String -> BS.ByteString encodeUtf8 = BS.pack . encode -- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String' decodeUtf8 :: BS.ByteString -> String decodeUtf8 = decode . BS.unpack -- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding -- | Character to use when 'encode' or 'decode' fail for a byte. replacementCharacter :: Char replacementCharacter = '\xfffd' -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. encode :: String -> [Word8] encode = concatMap (map fromIntegral . go . ord) where go oc | oc <= 0x7f = [oc] | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) , 0x80 + oc .&. 0x3f ] | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) , 0x80 + ((oc `shiftR` 6) .&. 0x3f) , 0x80 + oc .&. 0x3f ] | otherwise = [ 0xf0 + (oc `shiftR` 18) , 0x80 + ((oc `shiftR` 12) .&. 0x3f) , 0x80 + ((oc `shiftR` 6) .&. 0x3f) , 0x80 + oc .&. 0x3f ] -- | Decode a UTF8 string packed into a list of Word8 values, directly to String decode :: [Word8] -> String decode [ ] = "" decode (c:cs) | c < 0x80 = chr (fromEnum c) : decode cs | c < 0xc0 = replacementCharacter : decode cs | c < 0xe0 = multi1 | c < 0xf0 = multi_byte 2 0xf 0x800 | c < 0xf8 = multi_byte 3 0x7 0x10000 | c < 0xfc = multi_byte 4 0x3 0x200000 | c < 0xfe = multi_byte 5 0x1 0x4000000 | otherwise = replacementCharacter : decode cs where multi1 = case cs of c1 : ds | c1 .&. 0xc0 == 0x80 -> let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) in if d >= 0x000080 then toEnum d : decode ds else replacementCharacter : decode ds _ -> replacementCharacter : decode cs multi_byte :: Int -> Word8 -> Int -> String multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) where aux 0 rs acc | overlong <= acc && acc <= 0x10ffff && (acc < 0xd800 || 0xdfff < acc) && (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs | otherwise = replacementCharacter : decode rs aux n (r:rs) acc | r .&. 0xc0 == 0x80 = aux (n-1) rs $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) aux _ rs _ = replacementCharacter : decode rs haddock-library-1.7.0/src/Documentation/Haddock/Parser/0000755000000000000000000000000013361426704021143 5ustar0000000000000000haddock-library-1.7.0/src/Documentation/Haddock/Parser/Monad.hs0000644000000000000000000000637213361426704022545 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} module Documentation.Haddock.Parser.Monad where import qualified Text.Parsec.Char as Parsec import qualified Text.Parsec as Parsec import qualified Data.Text as T import Data.Text ( Text ) 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 ) 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. peekChar :: Parser (Maybe Char) peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar -- | Fails if at the end of input. Does not consume input. peekChar' :: Parser Char peekChar' = Parsec.lookAhead Parsec.anyChar -- | Parses the given string. Returns the parsed string. string :: Text -> Parser Text string t = Parsec.string (T.unpack t) *> App.pure t -- | Scan the input text, accumulating characters as long as the scanning -- function returns true. scan :: (s -> Char -> Maybe s) -- ^ scan function -> s -- ^ initial state -> Parser Text scan f = fmap T.pack . go where go s1 = do { cOpt <- peekChar ; case cOpt >>= f s1 of Nothing -> pure "" Just s2 -> (:) <$> Parsec.anyChar <*> go s2 } -- | Apply a parser for a character zero or more times and collect the result in -- a string. takeWhile :: Parser Char -> Parser Text takeWhile = fmap T.pack . Parsec.many -- | Apply a parser for a character one or more times and collect the result in -- a string. takeWhile1 :: Parser Char -> Parser Text takeWhile1 = fmap T.pack . Parsec.many1 -- | Parse a decimal number. decimal :: Integral a => Parser a decimal = 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.7.0/src/Documentation/Haddock/Parser/Util.hs0000644000000000000000000000465013361426704022421 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 (Parsec.oneOf 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.7.0/fixtures/0000755000000000000000000000000013361426704014623 5ustar0000000000000000haddock-library-1.7.0/fixtures/Fixtures.hs0000644000000000000000000001075013361426704016773 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 instance ToExpr Hyperlink deriving instance Generic Picture instance ToExpr Picture deriving instance Generic Example instance ToExpr Example deriving instance Generic (Table id) instance ToExpr id => ToExpr (Table id) deriving instance Generic (TableRow id) instance ToExpr id => ToExpr (TableRow id) deriving instance Generic (TableCell id) instance ToExpr id => ToExpr (TableCell id) haddock-library-1.7.0/test/0000755000000000000000000000000013361426704013731 5ustar0000000000000000haddock-library-1.7.0/test/Spec.hs0000644000000000000000000000005413361426704015156 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} haddock-library-1.7.0/test/Documentation/0000755000000000000000000000000013361426704016542 5ustar0000000000000000haddock-library-1.7.0/test/Documentation/Haddock/0000755000000000000000000000000013361426704020077 5ustar0000000000000000haddock-library-1.7.0/test/Documentation/Haddock/ParserSpec.hs0000644000000000000000000010563613361426704022515 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 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" 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)" 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.7.0/test/Documentation/Haddock/Utf8Spec.hs0000644000000000000000000000050513361426704022074 0ustar0000000000000000module Documentation.Haddock.Utf8Spec (main, spec) where import Test.Hspec import Test.QuickCheck import Documentation.Haddock.Utf8 main :: IO () main = hspec spec spec :: Spec spec = do describe "decodeUtf8" $ do it "is inverse to encodeUtf8" $ do property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs haddock-library-1.7.0/test/Documentation/Haddock/Parser/0000755000000000000000000000000013361426704021333 5ustar0000000000000000haddock-library-1.7.0/test/Documentation/Haddock/Parser/UtilSpec.hs0000644000000000000000000000134313361426704023420 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"