aboutsummaryrefslogtreecommitdiff
path: root/haddock-library
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-library')
-rw-r--r--haddock-library/CHANGES.md4
-rw-r--r--haddock-library/fixtures/Fixtures.hs4
-rw-r--r--haddock-library/fixtures/examples/link.parsed2
-rw-r--r--haddock-library/fixtures/examples/linkInline.parsed3
-rw-r--r--haddock-library/fixtures/examples/linkInlineMarkup.input1
-rw-r--r--haddock-library/fixtures/examples/linkInlineMarkup.parsed8
-rw-r--r--haddock-library/fixtures/examples/urlLabel.parsed2
-rw-r--r--haddock-library/src/Documentation/Haddock/Markup.hs82
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs31
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs14
-rw-r--r--haddock-library/test/Documentation/Haddock/ParserSpec.hs6
11 files changed, 108 insertions, 49 deletions
diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md
index 0175b6af..971d8dc7 100644
--- a/haddock-library/CHANGES.md
+++ b/haddock-library/CHANGES.md
@@ -1,3 +1,7 @@
+## TBA
+
+ * Support inline markup in markdown-style links (#875)
+
## Changes in version 1.7.0
* Make `Documentation.Haddock.Parser.Monad` an internal module
diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
index a4e4321f..72ea8525 100644
--- a/haddock-library/fixtures/Fixtures.hs
+++ b/haddock-library/fixtures/Fixtures.hs
@@ -146,8 +146,8 @@ 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 (Hyperlink id)
+instance ToExpr id => ToExpr (Hyperlink id)
deriving instance Generic Picture
instance ToExpr Picture
diff --git a/haddock-library/fixtures/examples/link.parsed b/haddock-library/fixtures/examples/link.parsed
index 0e85338c..781dee87 100644
--- a/haddock-library/fixtures/examples/link.parsed
+++ b/haddock-library/fixtures/examples/link.parsed
@@ -1,5 +1,5 @@
DocParagraph
(DocHyperlink
Hyperlink
- {hyperlinkLabel = Just "link",
+ {hyperlinkLabel = Just (DocString "link"),
hyperlinkUrl = "http://example.com"})
diff --git a/haddock-library/fixtures/examples/linkInline.parsed b/haddock-library/fixtures/examples/linkInline.parsed
index 43470d7b..fe771598 100644
--- a/haddock-library/fixtures/examples/linkInline.parsed
+++ b/haddock-library/fixtures/examples/linkInline.parsed
@@ -3,4 +3,5 @@ DocParagraph
(DocString "Bla ")
(DocHyperlink
Hyperlink
- {hyperlinkLabel = Just "link", hyperlinkUrl = "http://example.com"}))
+ {hyperlinkLabel = Just (DocString "link"),
+ hyperlinkUrl = "http://example.com"}))
diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.input b/haddock-library/fixtures/examples/linkInlineMarkup.input
new file mode 100644
index 00000000..e2f4e405
--- /dev/null
+++ b/haddock-library/fixtures/examples/linkInlineMarkup.input
@@ -0,0 +1 @@
+Bla [link /emphasized/](http://example.com)
diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.parsed b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
new file mode 100644
index 00000000..39adab64
--- /dev/null
+++ b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
@@ -0,0 +1,8 @@
+DocParagraph
+ (DocAppend
+ (DocString "Bla ")
+ (DocHyperlink
+ Hyperlink
+ {hyperlinkLabel = Just (DocAppend (DocString "link ")
+ (DocEmphasis (DocString "emphasized"))),
+ hyperlinkUrl = "http://example.com"}))
diff --git a/haddock-library/fixtures/examples/urlLabel.parsed b/haddock-library/fixtures/examples/urlLabel.parsed
index d7e3a76c..58d2a81a 100644
--- a/haddock-library/fixtures/examples/urlLabel.parsed
+++ b/haddock-library/fixtures/examples/urlLabel.parsed
@@ -1,5 +1,5 @@
DocParagraph
(DocHyperlink
Hyperlink
- {hyperlinkLabel = Just "some link",
+ {hyperlinkLabel = Just (DocString "some link"),
hyperlinkUrl = "http://example.com/"})
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index da8edcd4..b44fef80 100644
--- a/haddock-library/src/Documentation/Haddock/Markup.hs
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -2,35 +2,38 @@
module Documentation.Haddock.Markup (
markup
, idMarkup
+ , plainMarkup
) where
import Documentation.Haddock.Types
+import Data.Maybe ( fromMaybe )
+
markup :: DocMarkupH mod id a -> DocH mod id -> a
-markup m DocEmpty = markupEmpty m
-markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s) = markupString m s
-markup m (DocParagraph d) = markupParagraph m (markup m d)
-markup m (DocIdentifier x) = markupIdentifier m x
-markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
-markup m (DocModule mod0) = markupModule m mod0
-markup m (DocWarning d) = markupWarning m (markup m d)
-markup m (DocEmphasis d) = markupEmphasis m (markup m d)
-markup m (DocBold d) = markupBold m (markup m d)
-markup m (DocMonospaced d) = markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
-markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
-markup m (DocHyperlink 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))
+markup m DocEmpty = markupEmpty m
+markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s) = markupString m s
+markup m (DocParagraph d) = markupParagraph m (markup m d)
+markup m (DocIdentifier x) = markupIdentifier m x
+markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
+markup m (DocModule mod0) = markupModule m mod0
+markup m (DocWarning d) = markupWarning m (markup m d)
+markup m (DocEmphasis d) = markupEmphasis m (markup m d)
+markup m (DocBold d) = markupBold m (markup m d)
+markup m (DocMonospaced d) = markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
+markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
+markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))
+markup m (DocAName ref) = markupAName m ref
+markup m (DocPic img) = markupPic m img
+markup m (DocMathInline mathjax) = markupMathInline m mathjax
+markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax
+markup m (DocProperty p) = markupProperty m p
+markup m (DocExamples e) = markupExample m e
+markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))
+markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))
markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a)
markupPair m (a,b) = (markup m a, markup m b)
@@ -63,3 +66,34 @@ idMarkup = Markup {
markupHeader = DocHeader,
markupTable = DocTable
}
+
+-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to
+-- strip away any formatting while preserving as much of the actual text as
+-- possible.
+plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String
+plainMarkup plainMod plainIdent = Markup {
+ markupEmpty = "",
+ markupString = id,
+ markupParagraph = id,
+ markupAppend = (<>),
+ markupIdentifier = plainIdent,
+ markupIdentifierUnchecked = plainMod,
+ markupModule = id,
+ markupWarning = id,
+ markupEmphasis = id,
+ markupBold = id,
+ markupMonospaced = id,
+ markupUnorderedList = const "",
+ markupOrderedList = const "",
+ markupDefList = const "",
+ markupCodeBlock = id,
+ markupHyperlink = \(Hyperlink url lbl) -> fromMaybe url lbl,
+ markupAName = id,
+ markupPic = \(Picture uri title) -> fromMaybe uri title,
+ markupMathInline = id,
+ markupMathDisplay = id,
+ markupProperty = id,
+ markupExample = const "",
+ markupHeader = \(Header _ title) -> title,
+ markupTable = const ""
+ }
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 46b7ad3e..f6c12d46 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -33,6 +33,7 @@ import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
import Documentation.Haddock.Doc
+import Documentation.Haddock.Markup ( markup, plainMarkup )
import Documentation.Haddock.Parser.Monad
import Documentation.Haddock.Parser.Util
import Documentation.Haddock.Types
@@ -107,7 +108,7 @@ overIdentifier f d = g d
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 (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))
g (DocPic x) = DocPic x
g (DocMathInline x) = DocMathInline x
g (DocMathDisplay x) = DocMathDisplay x
@@ -301,13 +302,19 @@ mathInline = DocMathInline . T.unpack
-- >>> 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
+mathDisplay = DocMathDisplay . T.unpack
<$> ("\\[" *> takeUntil "\\]")
-markdownImage :: Parser (DocH mod a)
-markdownImage = fromHyperlink <$> ("!" *> linkParser)
+-- | Markdown image parser. As per the commonmark reference recommendation, the
+-- description text for an image converted to its a plain string representation.
+--
+-- >>> parseString "![some /emphasis/ in a description](www.site.com)"
+-- DocPic (Picture "www.site.com" (Just "some emphasis in a description"))
+markdownImage :: Parser (DocH mod Identifier)
+markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser)
where
- fromHyperlink (Hyperlink url label) = DocPic (Picture url label)
+ fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l)
+ stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r])
-- | Paragraph parser, called by 'parseParas'.
paragraph :: Parser (DocH mod Identifier)
@@ -784,22 +791,22 @@ codeblock =
| isNewline && isSpace c = Just isNewline
| otherwise = Just $ c == '\n'
-hyperlink :: Parser (DocH mod a)
+hyperlink :: Parser (DocH mod Identifier)
hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ]
angleBracketLink :: Parser (DocH mod a)
angleBracketLink =
- DocHyperlink . makeLabeled Hyperlink
+ DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)
<$> disallowNewline ("<" *> takeUntil ">")
-markdownLink :: Parser (DocH mod a)
+markdownLink :: Parser (DocH mod Identifier)
markdownLink = DocHyperlink <$> linkParser
-linkParser :: Parser Hyperlink
+linkParser :: Parser (Hyperlink (DocH mod Identifier))
linkParser = flip Hyperlink <$> label <*> (whitespace *> url)
where
- label :: Parser (Maybe String)
- label = Just . decode . T.strip <$> ("[" *> takeUntil "]")
+ label :: Parser (Maybe (DocH mod Identifier))
+ label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]")
whitespace :: Parser ()
whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)
@@ -825,7 +832,7 @@ autoUrl = mkLink <$> url
Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x]
_ -> DocHyperlink (mkHyperlink s)
- mkHyperlink :: Text -> Hyperlink
+ mkHyperlink :: Text -> Hyperlink (DocH mod a)
mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index b5dea3d4..f8f7d353 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -65,10 +65,10 @@ overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)
type Version = [Int]
type Package = String
-data Hyperlink = Hyperlink
+data Hyperlink id = Hyperlink
{ hyperlinkUrl :: String
- , hyperlinkLabel :: Maybe String
- } deriving (Eq, Show)
+ , hyperlinkLabel :: Maybe id
+ } deriving (Eq, Show, Functor, Foldable, Traversable)
data Picture = Picture
{ pictureUri :: String
@@ -118,7 +118,7 @@ data DocH mod id
| DocOrderedList [DocH mod id]
| DocDefList [(DocH mod id, DocH mod id)]
| DocCodeBlock (DocH mod id)
- | DocHyperlink Hyperlink
+ | DocHyperlink (Hyperlink (DocH mod id))
| DocPic Picture
| DocMathInline String
| DocMathDisplay String
@@ -147,7 +147,7 @@ instance Bifunctor DocH where
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 f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl))
bimap _ _ (DocPic picture) = DocPic picture
bimap _ _ (DocMathInline s) = DocMathInline s
bimap _ _ (DocMathDisplay s) = DocMathDisplay s
@@ -192,7 +192,7 @@ instance Bitraversable DocH where
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 f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl)
bitraverse _ _ (DocPic picture) = pure (DocPic picture)
bitraverse _ _ (DocMathInline s) = pure (DocMathInline s)
bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s)
@@ -227,7 +227,7 @@ data DocMarkupH mod id a = Markup
, markupOrderedList :: [a] -> a
, markupDefList :: [(a,a)] -> a
, markupCodeBlock :: a -> a
- , markupHyperlink :: Hyperlink -> a
+ , markupHyperlink :: Hyperlink a -> a
, markupAName :: String -> a
, markupPic :: Picture -> a
, markupMathInline :: String -> a
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index 0449c917..6269184a 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -37,7 +37,7 @@ parseParas = overDoc Parse.toRegular . Parse.parseParas Nothing
parseString :: String -> Doc String
parseString = Parse.toRegular . Parse.parseString
-hyperlink :: String -> Maybe String -> Doc String
+hyperlink :: String -> Maybe (Doc String) -> Doc String
hyperlink url = DocHyperlink . Hyperlink url
main :: IO ()
@@ -202,6 +202,10 @@ spec = do
"[some label]( url)" `shouldParseTo`
"[some label]( url)"
+ it "allows inline markup in the label" $ do
+ "[something /emphasized/](url)" `shouldParseTo`
+ hyperlink "url" (Just ("something " <> DocEmphasis "emphasized"))
+
context "when URL is on a separate line" $ do
it "allows URL to be on a separate line" $ do
"[some label]\n(url)" `shouldParseTo`
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 19:37:27 +0000