aboutsummaryrefslogtreecommitdiff
path: root/haddock-library/src/Documentation
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-library/src/Documentation')
-rw-r--r--haddock-library/src/Documentation/Haddock/Markup.hs4
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs54
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs14
3 files changed, 53 insertions, 19 deletions
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index 365041ee..0919737f 100644
--- a/haddock-library/src/Documentation/Haddock/Markup.hs
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -16,7 +16,7 @@ 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 (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 @@ plainMarkup plainMod plainIdent = Markup {
markupAppend = (++),
markupIdentifier = plainIdent,
markupIdentifierUnchecked = plainMod,
- markupModule = id,
+ markupModule = \(ModLink m lbl) -> fromMaybe m lbl,
markupWarning = id,
markupEmphasis = id,
markupBold = id,
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index a3bba38a..bb8745a5 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -18,6 +18,7 @@
module Documentation.Haddock.Parser (
parseString,
parseParas,
+ parseModLink,
overIdentifier,
toRegular,
Identifier
@@ -72,7 +73,7 @@ overIdentifier f d = g d
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
@@ -136,6 +137,9 @@ parseString = parseText . T.pack
parseText :: Text -> DocH mod Identifier
parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r')
+parseModLink :: String -> DocH mod id
+parseModLink s = snd $ parse moduleName (T.pack s)
+
parseParagraph :: Text -> DocH mod Identifier
parseParagraph = snd . parse p
where
@@ -148,6 +152,7 @@ parseParagraph = snd . parse p
, mathDisplay
, mathInline
, markdownImage
+ , markdownLink
, hyperlink
, bold
, emphasis
@@ -242,7 +247,12 @@ monospace = DocMonospaced . parseParagraph
-- 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 `maybeFollowedBy` anchor_) <* "\"")
+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_ = (++)
@@ -250,13 +260,30 @@ moduleName = DocModule <$> ("\"" *> (modid `maybeFollowedBy` anchor_) <* "\"")
<*> 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
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.
--
@@ -290,9 +317,11 @@ mathDisplay = DocMathDisplay . T.unpack
-- >>> 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]
@@ -772,22 +801,21 @@ codeblock =
| 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)
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 12ccd28d..252eb425 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -73,6 +73,11 @@ data Hyperlink id = Hyperlink
, 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
@@ -111,7 +116,8 @@ data DocH mod id
| 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)
@@ -142,7 +148,7 @@ instance Bifunctor DocH where
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 @@ instance Bitraversable DocH where
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 @@ data DocMarkupH mod id a = Markup
, 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