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

Inline markup in markdown-style links and images

1 files changed, 58 insertions, 24 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 ""
+  }