haddock-library 1.9.0 → 1.10.0

raw patch · 9 files changed

+175/−50 lines, 9 filesdep ~QuickCheckdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, base, bytestring, text, transformers

API changes (from Hackage documentation)

Files

• CHANGES.md +4/−0
• fixtures/Fixtures.hs +3/−0
• fixtures/examples/linkInlineMarkup.parsed +3/−2
• haddock-library.cabal +5/−4
• src/Documentation/Haddock/Markup.hs +2/−2
• src/Documentation/Haddock/Parser.hs +48/−18
• src/Documentation/Haddock/Parser/Util.hs +7/−7
• src/Documentation/Haddock/Types.hs +12/−6
• test/Documentation/Haddock/ParserSpec.hs +91/−11

@@ -1,3 +1,7 @@+## Changes in version 1.10.0++ * Add support for labeled module references (#1319, #1315)+ ## Changes in version 1.9.0   * Fix build-time regression for `base < 4.7` (#1119)

@@ -149,6 +149,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 

@@ -3,6 +3,7 @@      (DocString "Bla ")      (DocHyperlink         Hyperlink-          {hyperlinkLabel = Just (DocAppend (DocString "link ")-                                            (DocEmphasis (DocString "emphasized"))),+          {hyperlinkLabel = Just+                              (DocAppend+                                 (DocString "link ") (DocEmphasis (DocString "emphasized"))),            hyperlinkUrl = "http://example.com"}))

@@ -1,6 +1,6 @@ cabal-version:        2.2 name:                 haddock-library-version:              1.9.0+version:              1.10.0 synopsis:             Library exposing some functionality of Haddock.  description:          Haddock is a documentation-generation tool for Haskell@@ -27,6 +27,7 @@                     , GHC == 8.6.5                     , GHC == 8.8.3                     , GHC == 8.10.1+                    , GHC == 9.0.1  extra-source-files:   CHANGES.md@@ -37,14 +38,14 @@   default-language: Haskell2010    build-depends:-    , base         >= 4.5     && < 4.15+    , base         >= 4.5     && < 4.16     , bytestring   ^>= 0.9.2.1 || ^>= 0.10.0.0     , containers   ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1     , transformers ^>= 0.3.0.0 || ^>= 0.4.1.0 || ^>= 0.5.0.0     , text         ^>= 1.2.3.0     , parsec       ^>= 3.1.13.0 -  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs+  ghc-options: -funbox-strict-fields -Wall   if impl(ghc >= 8.0)     ghc-options: -Wcompat -Wnoncanonical-monad-instances @@ -87,7 +88,7 @@    build-depends:     , base-compat  ^>= 0.9.3 || ^>= 0.11.0-    , QuickCheck   ^>= 2.11  || ^>= 2.13.2+    , 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

@@ -16,7 +16,7 @@ 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)@@ -78,7 +78,7 @@   markupAppend               = (++),   markupIdentifier           = plainIdent,   markupIdentifierUnchecked  = plainMod,-  markupModule               = id,+  markupModule               = \(ModLink m lbl) -> fromMaybe m lbl,   markupWarning              = id,   markupEmphasis             = id,   markupBold                 = id,

@@ -72,7 +72,7 @@     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@@ -148,6 +148,7 @@                                     , mathDisplay                                     , mathInline                                     , markdownImage+                                    , markdownLink                                     , hyperlink                                     , bold                                     , emphasis@@ -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] @@ -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@@ -766,22 +797,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) 

@@ -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

@@ -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,7 +116,8 @@   | 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)@@ -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,7 +148,7 @@   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)@@ -189,7 +195,7 @@   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@@ -234,7 +240,7 @@   , 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

@@ -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@@ -288,8 +289,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 +307,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 +403,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 +428,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 +517,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 +549,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