diff options
| -rw-r--r-- | haddock-library/src/Documentation/Haddock/Markup.hs | 34 | ||||
| -rw-r--r-- | haddock-library/src/Documentation/Haddock/Parser.hs | 15 | ||||
| -rw-r--r-- | html-test/src/Bug865.hs | 9 |
3 files changed, 53 insertions, 5 deletions
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs index b581a4d2..b44fef80 100644 --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -2,10 +2,13 @@ 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) @@ -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 fb815dd9..0992dbbc 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 @@ -301,15 +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) +-- | Markdown image parser. As per the commonmark reference recommendation, the +-- description text for an image converted to its a plain string representation. +-- +-- >>> parseString "" +-- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) +markdownImage :: Parser (DocH mod Identifier) markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) where - fromHyperlink (Hyperlink url Nothing) = Picture url Nothing - fromHyperlink (Hyperlink url (Just (DocString s))) = Picture url (Just s) - -- TODO partial ^ + 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) diff --git a/html-test/src/Bug865.hs b/html-test/src/Bug865.hs new file mode 100644 index 00000000..71a6add1 --- /dev/null +++ b/html-test/src/Bug865.hs @@ -0,0 +1,9 @@ +module Bug865 where + +-- | An emphasized link [yes /this/ is emphasized while this is +-- @monospaced@](https://www.haskell.org/). And here is an image: +-- +--  +-- +link :: () +link = () |