packages feed

haddock-library 1.9.0 → 1.11.0

raw patch · 12 files changed

Files

CHANGES.md view
@@ -1,3 +1,10 @@+## Changes in version 1.11.0++  * Add support for linking identifiers with a quote between backticks (#1408)++## Changes in version 1.10.0++  * Add support for labeled module references (#1360) ## Changes in version 1.9.0   * Fix build-time regression for `base < 4.7` (#1119)
fixtures/Fixtures.hs view
@@ -9,8 +9,7 @@ import Data.List (foldl') import Data.Traversable (for) import GHC.Generics (Generic)-import Prelude ()-import Prelude.Compat+import Prelude import System.Directory (getDirectoryContents) import System.Exit (exitFailure) import System.FilePath@@ -148,6 +147,9 @@  deriving instance Generic (Hyperlink id) instance ToExpr id => ToExpr (Hyperlink id)++deriving instance Generic (ModLink id)+instance ToExpr id => ToExpr (ModLink id)  deriving instance Generic Picture instance ToExpr Picture
haddock-library.cabal view
@@ -1,6 +1,6 @@-cabal-version:        2.2+cabal-version:        3.0 name:                 haddock-library-version:              1.9.0+version:              1.11.0 synopsis:             Library exposing some functionality of Haddock.  description:          Haddock is a documentation-generation tool for Haskell@@ -27,6 +27,8 @@                     , GHC == 8.6.5                     , GHC == 8.8.3                     , GHC == 8.10.1+                    , GHC == 9.0.1+                    , GHC == 9.2.0  extra-source-files:   CHANGES.md@@ -37,14 +39,12 @@   default-language: Haskell2010    build-depends:-    , base         >= 4.5     && < 4.15-    , bytestring   ^>= 0.9.2.1 || ^>= 0.10.0.0+    , base         >= 4.5     && < 4.17     , 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+    , text         ^>= 1.2.3.0 || ^>= 2.0     , parsec       ^>= 3.1.13.0 -  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs+  ghc-options: -funbox-strict-fields -Wall   if impl(ghc >= 8.0)     ghc-options: -Wcompat -Wnoncanonical-monad-instances @@ -86,8 +86,8 @@     Documentation.Haddock.Parser.Identifier    build-depends:-    , base-compat  ^>= 0.9.3 || ^>= 0.11.0-    , QuickCheck   ^>= 2.11  || ^>= 2.13.2+    , base-compat  ^>= 0.12.0+    , QuickCheck   ^>= 2.11  || ^>= 2.13.2 || ^>= 2.14      , deepseq      ^>= 1.3.0.0 || ^>= 1.4.0.0    -- NB: build-depends & build-tool-depends have independent@@ -95,10 +95,10 @@   --     version of `hspec` & `hspec-discover` to ensure   --     intercompatibility   build-depends:-    , hspec                          >= 2.4.4    && < 2.8+    , hspec                          >= 2.4.4    && < 2.10    build-tool-depends:-    , hspec-discover:hspec-discover  >= 2.4.4    && < 2.8+    , hspec-discover:hspec-discover  >= 2.4.4    && < 2.10  test-suite fixtures   type:             exitcode-stdio-1.0@@ -113,11 +113,11 @@     , base        -- extra dependencies-    , base-compat           ^>= 0.9.3 || ^>= 0.11.0+    , base-compat           ^>= 0.12.0     , directory             ^>= 1.3.0.2     , filepath              ^>= 1.4.1.2     , optparse-applicative  ^>= 0.15-    , tree-diff             ^>= 0.1+    , tree-diff             ^>= 0.2  source-repository head   type:     git
src/CompatPrelude.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -#if !MIN_VERSION_base(4,5,0)+#ifdef __HLINT__+#elif !MIN_VERSION_base(4,5,0) # error This module doesn't provide compat-shims for versions prior to base-4.5 #endif
src/Documentation/Haddock/Markup.hs view
@@ -16,13 +16,13 @@ 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 (DocModule (ModLink mo l))     = markupModule m (ModLink mo (fmap (markup m) l)) markup m (DocWarning d)                 = markupWarning m (markup m d) markup m (DocEmphasis d)                = markupEmphasis m (markup m d) markup m (DocBold d)                    = markupBold m (markup m d) markup m (DocMonospaced d)              = markupMonospaced m (markup m d) markup m (DocUnorderedList ds)          = markupUnorderedList m (map (markup m) ds)-markup m (DocOrderedList ds)            = markupOrderedList m (map (markup m) ds)+markup m (DocOrderedList ds)            = markupOrderedList m (map (\(index, a) -> (index, markup m a)) ds) markup m (DocDefList ds)                = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d)               = markupCodeBlock m (markup m d) markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))@@ -78,7 +78,7 @@   markupAppend               = (++),   markupIdentifier           = plainIdent,   markupIdentifierUnchecked  = plainMod,-  markupModule               = id,+  markupModule               = \(ModLink m lbl) -> fromMaybe m lbl,   markupWarning              = id,   markupEmphasis             = id,   markupBold                 = id,
src/Documentation/Haddock/Parser.hs view
@@ -72,13 +72,13 @@     g (DocString x) = DocString x     g (DocParagraph x) = DocParagraph $ g x     g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x-    g (DocModule x) = DocModule x+    g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x))     g (DocWarning x) = DocWarning $ g x     g (DocEmphasis x) = DocEmphasis $ g x     g (DocMonospaced x) = DocMonospaced $ g x     g (DocBold x) = DocBold $ g x     g (DocUnorderedList x) = DocUnorderedList $ fmap g x-    g (DocOrderedList x) = DocOrderedList $ fmap g x+    g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x     g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x     g (DocCodeBlock x) = DocCodeBlock $ g x     g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))@@ -148,6 +148,7 @@                                     , mathDisplay                                     , mathInline                                     , markdownImage+                                    , markdownLink                                     , hyperlink                                     , bold                                     , emphasis@@ -172,11 +173,11 @@ -- Once we have checked for any of these and tried to parse the -- relevant markup, we can assume they are used as regular text. specialChar :: [Char]-specialChar = "_/<@\"&'`# "+specialChar = "_/<@\"&'`#[ "  -- | Plain, regular parser for text. Called as one of the last parsers -- to ensure that we have already given a chance to more meaningful parsers--- before capturing their characers.+-- before capturing their characters. string' :: Parser (DocH mod a) string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar)   where@@ -227,7 +228,7 @@ -- DocAName "Hello world" anchor :: Parser (DocH mod a) anchor = DocAName . T.unpack <$>-         disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")+         ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#")  -- | Monospaced strings. --@@ -242,15 +243,43 @@ -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a)-moduleName = DocModule <$> ("\"" *> modid <* "\"")+moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"")++-- | A module name, optionally with an anchor+--+moduleNameString :: Parser String+moduleNameString = modid `maybeFollowedBy` anchor_   where     modid = intercalate "." <$> conid `Parsec.sepBy1` "."+    anchor_ = (++)+      <$> (Parsec.string "#" <|> Parsec.string "\\#")+      <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c)))++    maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf+    conid :: Parser String     conid = (:)       <$> Parsec.satisfy (\c -> isAlpha c && isUpper c)-      <*> many (conChar <|> Parsec.oneOf "\\#")+      <*> many conChar      conChar = Parsec.alphaNum <|> Parsec.char '_' +-- | A labeled link to an indentifier, module or url using markdown+-- syntax.+markdownLink :: Parser (DocH mod Identifier)+markdownLink = do+  lbl <- markdownLinkText+  choice' [ markdownModuleName lbl, markdownURL lbl ]+  where+    markdownModuleName lbl = do+      mn <- "(" *> skipHorizontalSpace *>+            "\"" *> moduleNameString <* "\""+            <* skipHorizontalSpace <* ")"+      pure $ DocModule (ModLink mn (Just lbl))++    markdownURL lbl = do+      target <- markdownLinkTarget+      pure $ DocHyperlink $ Hyperlink target (Just lbl)+ -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. --@@ -284,9 +313,11 @@ -- >>> 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)+markdownImage = do+  text <- markup stringMarkup <$> ("!" *> markdownLinkText)+  url <- markdownLinkTarget+  pure $ DocPic (Picture url (Just text))   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] @@ -330,7 +361,7 @@     firstRow <- parseFirstRow     let len = T.length firstRow -    -- then we parse all consequtive rows starting and ending with + or |,+    -- then we parse all consecutive rows starting and ending with + or |,     -- of the width `len`.     restRows <- many (try (parseRestRows len)) @@ -512,11 +543,11 @@ 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+      pser = Parsec.choice psers+  depth <- T.length <$> pser+  line <- parseText <$> (skipHorizontalSpace *> nonEmptyLine)   rest <- try paragraph <|> return DocEmpty-  return $ DocHeader (Header (length delim) line) `docAppend` rest+  return $ DocHeader (Header depth line) `docAppend` rest  textParagraph :: Parser (DocH mod Identifier) textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine@@ -546,10 +577,24 @@ orderedList :: Text -> Parser (DocH mod Identifier) orderedList indent = DocOrderedList <$> p   where-    p = (paren <|> dot) *> innerList indent p+    p = do+      index <- paren <|> dot+      innerList' indent p index     dot = (decimal :: Parser Int) <* "."     paren = "(" *> decimal <* ")" +-- | Like 'innerList' but takes the parsed index of the list item+innerList' :: Text -> Parser [(Int, DocH mod Identifier)]+           -> Int+           -> Parser [(Int, DocH mod Identifier)]+innerList' indent item index = do+  c <- takeLine+  (cs, items) <- more indent item+  let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs+  return $ case items of+    Left p -> [(index, contents `docAppend` p)]+    Right i -> (index, contents) : i+ -- | Generic function collecting any further lines belonging to the -- list entry and recursively collecting any further lists in the -- same paragraph. Usually used as@@ -679,7 +724,7 @@                  Just (' ',t') -> Just t'                  _ -> Nothing --- | Parses examples. Examples are a paragraph level entitity (separated by an empty line).+-- | Parses examples. Examples are a paragraph level entity (separated by an empty line). -- Consecutive examples are accepted. examples :: Parser (DocH mod a) examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go)@@ -766,22 +811,21 @@           | otherwise = Just $ c == '\n'  hyperlink :: Parser (DocH mod Identifier)-hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ]+hyperlink = choice' [ angleBracketLink, autoUrl ]  angleBracketLink :: Parser (DocH mod a) angleBracketLink =     DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)     <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod Identifier)-markdownLink = DocHyperlink <$> linkParser+-- | The text for a markdown link, enclosed in square brackets.+markdownLinkText :: Parser (DocH mod Identifier)+markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]") -linkParser :: Parser (Hyperlink (DocH mod Identifier))-linkParser = flip Hyperlink <$> label <*> (whitespace *> url)+-- | The target for a markdown link, enclosed in parenthesis.+markdownLinkTarget :: Parser String+markdownLinkTarget = whitespace *> url   where-    label :: Parser (Maybe (DocH mod Identifier))-    label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]")-     whitespace :: Parser ()     whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)
src/Documentation/Haddock/Parser/Identifier.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-} -- | -- Module      :  Documentation.Haddock.Parser.Identifier -- Copyright   :  (c) Alec Theriault 2019,@@ -150,9 +149,9 @@       | otherwise = Nothing      -- | Parse all but the last quote off the front of the input-    -- PRECONDITION: T.head t == '\''+    -- PRECONDITION: T.head t `elem` ['\'', '`']     quotes :: Text -> (Int, Text)-    quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1+    quotes t = let !n = T.length (T.takeWhile (`elem` ['\'', '`']) t) - 1                in (n, T.drop n t)      -- | Parse an operator off the front of the input
src/Documentation/Haddock/Parser/Monad.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module      :  Documentation.Haddock.Parser.Monad -- Copyright   :  (c) Alec Theriault 2018-2019,@@ -40,7 +39,7 @@ import           Prelude hiding (takeWhile) import           CompatPrelude --- | The only bit of information we really care about truding along with us+-- | The only bit of information we really care about trudging along with us -- through parsing is the version attached to a @\@since@ annotation - if -- the doc even contained one. newtype ParserState = ParserState {
src/Documentation/Haddock/Parser/Util.hs view
@@ -31,16 +31,16 @@ import           Data.Char (isSpace)  -- | Characters that count as horizontal space-horizontalSpace :: [Char]-horizontalSpace = " \t\f\v\r"+horizontalSpace :: Char -> Bool+horizontalSpace c = isSpace c && c /= '\n'  -- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser ()-skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace)+skipHorizontalSpace = Parsec.skipMany (Parsec.satisfy horizontalSpace)  -- | Take leading horizontal space-takeHorizontalSpace :: Parser Text -takeHorizontalSpace = takeWhile (`elem` horizontalSpace)+takeHorizontalSpace :: Parser Text+takeHorizontalSpace = takeWhile horizontalSpace  makeLabeled :: (String -> Maybe String -> a) -> Text -> a makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of@@ -60,10 +60,10 @@  -- | 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 :: Text -> Parser Text takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome   where-    end = T.unpack end_ +    end = T.unpack end_      p :: (Bool, String) -> Char -> Maybe (Bool, String)     p acc c = case acc of
src/Documentation/Haddock/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE CPP, DeriveTraversable #-}  -- | -- Module      :  Documentation.Haddock.Types@@ -73,13 +73,18 @@   , hyperlinkLabel :: Maybe id   } deriving (Eq, Show, Functor, Foldable, Traversable) +data ModLink id = ModLink+  { modLinkName   :: String+  , modLinkLabel :: Maybe id+  } deriving (Eq, Show, Functor, Foldable, Traversable)+ data Picture = Picture   { pictureUri   :: String   , pictureTitle :: Maybe String   } deriving (Eq, Show)  data Header id = Header-  { headerLevel :: Int+  { headerLevel :: Int  -- ^ between 1 and 6 inclusive   , headerTitle :: id   } deriving (Eq, Show, Functor, Foldable, Traversable) @@ -111,14 +116,15 @@   | DocIdentifier id   | DocIdentifierUnchecked mod   -- ^ A qualified identifier that couldn't be resolved.-  | DocModule String+  | DocModule (ModLink (DocH mod id))+  -- ^ A link to a module, with an optional label.   | DocWarning (DocH mod id)   -- ^ This constructor has no counterpart in Haddock markup.   | DocEmphasis (DocH mod id)   | DocMonospaced (DocH mod id)   | DocBold (DocH mod id)   | DocUnorderedList [DocH mod id]-  | DocOrderedList [DocH mod id]+  | DocOrderedList [(Int, DocH mod id)]   | DocDefList [(DocH mod id, DocH mod id)]   | DocCodeBlock (DocH mod id)   | DocHyperlink (Hyperlink (DocH mod id))@@ -126,7 +132,7 @@   | DocMathInline String   | DocMathDisplay String   | DocAName String-  -- ^ A (HTML) anchor.+  -- ^ A (HTML) anchor. It must not contain any spaces.   | DocProperty String   | DocExamples [Example]   | DocHeader (Header (DocH mod id))@@ -142,13 +148,13 @@   bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc)   bimap _ g (DocIdentifier i) = DocIdentifier (g i)   bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m)-  bimap _ _ (DocModule s) = DocModule s+  bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl))   bimap f g (DocWarning doc) = DocWarning (bimap f g doc)   bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc)   bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc)   bimap f g (DocBold doc) = DocBold (bimap f g doc)   bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)-  bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)+  bimap f g (DocOrderedList docs) = DocOrderedList (map (\(index, a) -> (index, bimap f g a)) docs)   bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs)   bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)   bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl))@@ -174,7 +180,7 @@   bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc   bifoldr f g z (DocBold doc) = bifoldr f g z doc   bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs-  bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs+  bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z (map snd docs)   bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs   bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc   bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title@@ -189,13 +195,14 @@   bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc   bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i   bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m-  bitraverse _ _ (DocModule s) = pure (DocModule s)+  bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl)   bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc   bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc   bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc   bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc   bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs-  bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs+  bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverseSnd (bitraverse f g) docs+    where traverseSnd f' = traverse (\(x, a) -> (\b -> (x, b)) <$> f' a)   bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs   bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc   bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl)@@ -234,13 +241,13 @@   , markupAppend               :: a -> a -> a   , markupIdentifier           :: id -> a   , markupIdentifierUnchecked  :: mod -> a-  , markupModule               :: String -> a+  , markupModule               :: ModLink a -> a   , markupWarning              :: a -> a   , markupEmphasis             :: a -> a   , markupBold                 :: a -> a   , markupMonospaced           :: a -> a   , markupUnorderedList        :: [a] -> a-  , markupOrderedList          :: [a] -> a+  , markupOrderedList          :: [(Int,a)] -> a   , markupDefList              :: [(a,a)] -> a   , markupCodeBlock            :: a -> a   , markupHyperlink            :: Hyperlink a -> a
test/Documentation/Haddock/Parser/UtilSpec.hs view
@@ -1,11 +1,14 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Documentation.Haddock.Parser.UtilSpec (main, spec) where  import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util-import Data.Either.Compat (isLeft)+import Data.Either (isLeft) import Test.Hspec+#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative+#endif  main :: IO () main = hspec spec
test/Documentation/Haddock/ParserSpec.hs view
@@ -3,6 +3,7 @@  module Documentation.Haddock.ParserSpec (main, spec) where +import           Data.Char (isSpace) import           Data.String import qualified Documentation.Haddock.Parser as Parse import           Documentation.Haddock.Types@@ -120,6 +121,9 @@       it "can parse identifiers ending with a single quote" $ do         "'foo''" `shouldParseTo` DocIdentifier "foo'" +      it "can parse identifiers in backticks ending with a single quote" $ do+        "`foo'`" `shouldParseTo` DocIdentifier "foo'"+       it "can parse an identifier containing a digit" $ do         "'f0'" `shouldParseTo` DocIdentifier "f0" @@ -288,8 +292,10 @@       it "parses a single word anchor" $ do         "#foo#" `shouldParseTo` DocAName "foo" -      it "parses a multi word anchor" $ do-        "#foo bar#" `shouldParseTo` DocAName "foo bar"+      -- Spaces are not allowed:+      -- https://www.w3.org/TR/html51/dom.html#the-id-attribute+      it "doesn't parse a multi word anchor" $ do+        "#foo bar#" `shouldParseTo` "#foo bar#"        it "parses a unicode anchor" $ do         "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ"@@ -304,6 +310,9 @@       it "does not accept empty anchors" $ do         "##" `shouldParseTo` "##" +      it "does not accept anchors containing spaces" $ do+        "{-# LANGUAGE GADTs #-}" `shouldParseTo` "{-# LANGUAGE GADTs #-}"+     context "when parsing emphasised text" $ do       it "emphasises a word on its own" $ do         "/foo/" `shouldParseTo` DocEmphasis "foo"@@ -397,20 +406,20 @@     context "when parsing module strings" $ do       it "should parse a module on its own" $ do         "\"Module\"" `shouldParseTo`-          DocModule "Module"+          DocModule (ModLink "Module" Nothing)        it "should parse a module inline" $ do         "This is a \"Module\"." `shouldParseTo`-          "This is a " <> DocModule "Module" <> "."+          "This is a " <> DocModule (ModLink "Module" Nothing) <> "."        it "can accept a simple module name" $ do-        "\"Hello\"" `shouldParseTo` DocModule "Hello"+        "\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing)        it "can accept a module name with dots" $ do-        "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World"+        "\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing)        it "can accept a module name with unicode" $ do-        "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ"+        "\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing)        it "parses a module name with a trailing dot as regular quoted string" $ do         "\"Hello.\"" `shouldParseTo` "\"Hello.\""@@ -422,17 +431,86 @@         "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\""        it "accepts a module name with unicode" $ do-        "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ"+        "\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing)        it "treats empty module name as regular double quotes" $ do         "\"\"" `shouldParseTo` "\"\""        it "accepts anchor reference syntax as DocModule" $ do-        "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar"+        "\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing) +      it "accepts anchor with hyphen as DocModule" $ do+        "\"Foo#bar-baz\"" `shouldParseTo` DocModule (ModLink "Foo#bar-baz" Nothing)+       it "accepts old anchor reference syntax as DocModule" $ do-        "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar"+        "\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing) +    context "when parsing labeled module links" $ do+      it "parses a simple labeled module link" $ do+        "[some label](\"Some.Module\")" `shouldParseTo`+          DocModule (ModLink "Some.Module" (Just "some label"))++      it "allows escaping in label" $ do+        "[some\\] label](\"Some.Module\")" `shouldParseTo`+          DocModule (ModLink "Some.Module" (Just "some] label"))++      it "strips leading and trailing whitespace from label" $ do+        "[  some label  ](\"Some.Module\")" `shouldParseTo`+          DocModule (ModLink "Some.Module" (Just "some label"))++      it "allows whitespace in module name link" $ do+        "[some label]( \"Some.Module\"\t )" `shouldParseTo`+          DocModule (ModLink "Some.Module" (Just "some label"))++      it "allows inline markup in the label" $ do+        "[something /emphasized/](\"Some.Module\")" `shouldParseTo`+          DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized")))++      it "should parse a labeled module on its own" $ do+        "[label](\"Module\")" `shouldParseTo`+          DocModule (ModLink "Module" (Just "label"))++      it "should parse a labeled module inline" $ do+        "This is a [label](\"Module\")." `shouldParseTo`+          "This is a " <> DocModule (ModLink "Module" (Just "label")) <> "."++      it "can accept a labeled module name with dots" $ do+        "[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label"))++      it "can accept a labeled module name with unicode" $ do+        "[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label"))++      it "parses a labeled module name with a trailing dot as a hyperlink" $ do+        "[label](\"Hello.\")" `shouldParseTo`+          hyperlink "\"Hello.\"" (Just "label")++      it "parses a labeled module name with a space as a regular string" $ do+        "[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")"++      it "parses a module name with invalid characters as a hyperlink" $ do+        "[label](\"Hello&[{}(=*+]!\")" `shouldParseTo`+          hyperlink "\"Hello&[{}(=*+]!\"" (Just "label")++      it "accepts a labeled module name with unicode" $ do+        "[label](\"Foo.Barλ\")" `shouldParseTo`+          DocModule (ModLink "Foo.Barλ" (Just "label"))++      it "treats empty labeled module name as empty hyperlink" $ do+        "[label](\"\")" `shouldParseTo`+          hyperlink "\"\"" (Just "label")++      it "accepts anchor reference syntax for labeled module name" $ do+        "[label](\"Foo#bar\")" `shouldParseTo`+          DocModule (ModLink "Foo#bar" (Just "label"))++      it "accepts old anchor reference syntax for labeled module name" $ do+        "[label](\"Foo\\#bar\")" `shouldParseTo`+          DocModule (ModLink "Foo\\#bar" (Just "label"))++      it "interprets empty label as a unlabeled module name" $ do+        "[](\"Module.Name\")" `shouldParseTo`+          "[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")"+   describe "parseParas" $ do     let infix 1 `shouldParseTo`         shouldParseTo :: String -> Doc String -> Expectation@@ -442,6 +520,10 @@       property $ \xs ->         (length . show . parseParas) xs `shouldSatisfy` (> 0) +    -- See <https://github.com/haskell/haddock/issues/1142>+    it "doesn't crash on unicode whitespace" $ do+      "\8197" `shouldParseTo` DocEmpty+     context "when parsing @since" $ do       it "adds specified version to the result" $ do         parseParas "@since 0.5.0" `shouldBe`@@ -470,7 +552,8 @@       context "when parsing text paragraphs" $ do-      let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String))+      let isSpecial c = isSpace c || c `elem` (".(=#-[*`\\\"'_/@<>" :: String)+          filterSpecial = filter (not . isSpecial)        it "parses an empty paragraph" $ do         "" `shouldParseTo` DocEmpty@@ -496,28 +579,38 @@         it "turns it into a code block" $ do           "@foo@" `shouldParseTo` DocCodeBlock "foo" -      context "when a paragraph starts with a markdown link" $ do-        it "correctly parses it as a text paragraph (not a definition list)" $ do-          "[label](url)" `shouldParseTo`-            DocParagraph (hyperlink "url" "label")+      context "when a paragraph contains a markdown link" $ do+        it "correctly parses the link" $ do+          "Blah [label](url)" `shouldParseTo`+            DocParagraph ("Blah " <> hyperlink "url" "label") -        it "can be followed by an other paragraph" $ do-          "[label](url)\n\nfoobar" `shouldParseTo`-            DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar"+        context "when the paragraph starts with the markdown link" $ do+          it "correctly parses it as a text paragraph (not a definition list)" $ do+            "[label](url)" `shouldParseTo`+              DocParagraph (hyperlink "url" "label") -        context "when paragraph contains additional text" $ do-          it "accepts more text after the link" $ do-            "[label](url) foo bar baz" `shouldParseTo`-              DocParagraph (hyperlink "url" "label" <> " foo bar baz")+          it "can be followed by an other paragraph" $ do+            "[label](url)\n\nfoobar" `shouldParseTo`+              DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar" -          it "accepts a newline right after the markdown link" $ do-            "[label](url)\nfoo bar baz" `shouldParseTo`-              DocParagraph (hyperlink "url" "label" <> " foo bar baz")+          context "when paragraph contains additional text" $ do+            it "accepts more text after the link" $ do+              "[label](url) foo bar baz" `shouldParseTo`+                DocParagraph (hyperlink "url" "label" <> " foo bar baz") -          it "can be followed by an other paragraph" $ do-            "[label](url)foo\n\nbar" `shouldParseTo`-              DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar"+            it "accepts a newline right after the markdown link" $ do+              "[label](url)\nfoo bar baz" `shouldParseTo`+                DocParagraph (hyperlink "url" "label" <> " foo bar baz") +            it "can be followed by an other paragraph" $ do+              "[label](url)foo\n\nbar" `shouldParseTo`+                DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar"++        context "when the link starts on a new line not at the beginning of the paragraph" $ do+          it "correctly parses the link" $ do+            "Bla\n[label](url)" `shouldParseTo`+              DocParagraph ("Bla\n" <> hyperlink "url" "label")+     context "when parsing birdtracks" $ do       it "parses them as a code block" $ do         unlines [@@ -730,7 +823,7 @@       it "can nest another type of list inside" $ do         "* foo\n\n    1. bar" `shouldParseTo`           DocUnorderedList [ DocParagraph "foo"-                             <> DocOrderedList [DocParagraph "bar"]]+                             <> DocOrderedList [(1, DocParagraph "bar")]]        it "can nest a code block inside" $ do         "* foo\n\n    @foo bar baz@" `shouldParseTo`@@ -769,7 +862,7 @@           DocUnorderedList [ DocParagraph "foo"                              <> DocUnorderedList [ DocParagraph "bar" ]                            ]-          <> DocOrderedList [ DocParagraph "baz" ]+          <> DocOrderedList [ (1, DocParagraph "baz") ]        it "allows arbitrary initial indent of a list" $ do         unlines@@ -793,20 +886,20 @@           DocDefList [ ("foo", "foov"                                <> DocDefList [ ("bar", "barv") ])                      ]-          <> DocOrderedList [ DocParagraph "baz" ]+          <> DocOrderedList [ (1, DocParagraph "baz") ]        it "list order is preserved in presence of nesting + extra text" $ do         "1. Foo\n\n    > Some code\n\n2. Bar\n\nSome text"           `shouldParseTo`-          DocOrderedList [ DocParagraph "Foo" <> DocCodeBlock "Some code"-                         , DocParagraph "Bar"+          DocOrderedList [ (1, DocParagraph "Foo" <> DocCodeBlock "Some code")+                         , (2, DocParagraph "Bar")                          ]           <> DocParagraph (DocString "Some text")          "1. Foo\n\n2. Bar\n\nSome text"           `shouldParseTo`-          DocOrderedList [ DocParagraph "Foo"-                         , DocParagraph "Bar"+          DocOrderedList [ (1, DocParagraph "Foo")+                         , (2, DocParagraph "Bar")                          ]           <> DocParagraph (DocString "Some text") @@ -890,9 +983,9 @@           , " 3. three"           ]         `shouldParseTo` DocOrderedList [-            DocParagraph "one"-          , DocParagraph "two"-          , DocParagraph "three"+            (1, DocParagraph "one")+          , (1, DocParagraph "two")+          , (3, DocParagraph "three")           ]        it "ignores empty lines between list items" $ do@@ -902,12 +995,12 @@           , "2. two"           ]         `shouldParseTo` DocOrderedList [-            DocParagraph "one"-          , DocParagraph "two"+            (1, DocParagraph "one")+          , (2, DocParagraph "two")           ]        it "accepts an empty list item" $ do-        "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty]+        "1." `shouldParseTo` DocOrderedList [(1, DocParagraph DocEmpty)]        it "accepts multi-line list items" $ do         unlines [@@ -917,12 +1010,12 @@           , "more two"           ]         `shouldParseTo` DocOrderedList [-            DocParagraph "point one\n  more one"-          , DocParagraph "point two\nmore two"+            (1, DocParagraph "point one\n  more one")+          , (1, DocParagraph "point two\nmore two")           ]        it "accepts markup in list items" $ do-        "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")]+        "1. /foo/" `shouldParseTo` DocOrderedList [(1, DocParagraph (DocEmphasis "foo"))]        it "requires empty lines between list and other paragraphs" $ do         unlines [@@ -932,7 +1025,7 @@           , ""           , "baz"           ]-        `shouldParseTo` DocParagraph "foo" <> DocOrderedList [DocParagraph "bar"] <> DocParagraph "baz"+        `shouldParseTo` DocParagraph "foo" <> DocOrderedList [(1, DocParagraph "bar")] <> DocParagraph "baz"      context "when parsing definition lists" $ do       it "parses a simple list" $ do@@ -1019,8 +1112,8 @@                 ] `shouldParseTo`           DocUnorderedList [ DocParagraph "bullet"                            , DocParagraph "different bullet"]-          <> DocOrderedList [ DocParagraph "ordered"-                            , DocParagraph "different bullet"+          <> DocOrderedList [ (1, DocParagraph "ordered")+                            , (2, DocParagraph "different bullet")                             ]           <> DocDefList [ ("cat", "kitten")                         , ("pineapple", "fruit")