diff options
Diffstat (limited to 'haddock-library/src/Documentation/Haddock')
| -rw-r--r-- | haddock-library/src/Documentation/Haddock/Markup.hs | 4 | ||||
| -rw-r--r-- | haddock-library/src/Documentation/Haddock/Parser.hs | 50 | ||||
| -rw-r--r-- | haddock-library/src/Documentation/Haddock/Types.hs | 14 |
3 files changed, 49 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..de336d45 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -72,7 +72,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 @@ -148,6 +148,7 @@ parseParagraph = snd . parse p , mathDisplay , mathInline , markdownImage + , markdownLink , hyperlink , bold , emphasis @@ -242,7 +243,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 +256,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 +313,11 @@ mathDisplay = DocMathDisplay . T.unpack -- >>> parseString "" -- 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 +797,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 |