From 566536d6a1db7959197bed086c07cd23457ca378 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Sat, 7 Jul 2018 20:25:35 -0400
Subject: Support hyperlink labels with inline markup
The parser for pictures hasn't been properly adjusted yet.
---
.../src/Documentation/Haddock/Markup.hs | 48 +++++++++++-----------
.../src/Documentation/Haddock/Parser.hs | 22 +++++-----
haddock-library/src/Documentation/Haddock/Types.hs | 14 +++----
3 files changed, 43 insertions(+), 41 deletions(-)
(limited to 'haddock-library')
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index da8edcd4..b581a4d2 100644
--- a/haddock-library/src/Documentation/Haddock/Markup.hs
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -7,30 +7,30 @@ module Documentation.Haddock.Markup (
import Documentation.Haddock.Types
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)
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 46b7ad3e..fb815dd9 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -107,7 +107,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
@@ -305,9 +305,11 @@ mathDisplay = DocMathDisplay . T.unpack
<$> ("\\[" *> takeUntil "\\]")
markdownImage :: Parser (DocH mod a)
-markdownImage = fromHyperlink <$> ("!" *> linkParser)
+markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser)
where
- fromHyperlink (Hyperlink url label) = DocPic (Picture url label)
+ fromHyperlink (Hyperlink url Nothing) = Picture url Nothing
+ fromHyperlink (Hyperlink url (Just (DocString s))) = Picture url (Just s)
+ -- TODO partial ^
-- | Paragraph parser, called by 'parseParas'.
paragraph :: Parser (DocH mod Identifier)
@@ -784,22 +786,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 . flip Hyperlink Nothing . T.unpack . removeEscapes
<$> 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 +827,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
--
cgit v1.2.3