Merge pull request #875 from harpocrates/feature/markup-in-hyperlinks

Inline markup in markdown-style links and images

3 files changed, 84 insertions, 43 deletions

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