From e01e4790402204af02ab0127ef5b633fb7748cd4 Mon Sep 17 00:00:00 2001
From: Dominic Steinitz <dominic@steinitz.org>
Date: Sat, 16 May 2015 12:32:23 +0100
Subject: Handle inline math with mathjax.

---
 haddock-api/src/Haddock/Backends/Hoogle.hs         |  2 +
 haddock-api/src/Haddock/Backends/LaTeX.hs          |  3 +
 haddock-api/src/Haddock/Backends/Xhtml.hs          |  1 +
 .../src/Haddock/Backends/Xhtml/DocMarkup.hs        |  2 +
 haddock-api/src/Haddock/Interface/LexParseRn.hs    |  1 +
 haddock-api/src/Haddock/Types.hs                   |  2 +
 haddock-api/src/Haddock/Utils.hs                   |  2 +
 .../src/Documentation/Haddock/Parser.hs            | 16 ++++-
 haddock-library/src/Documentation/Haddock/Types.hs |  1 +
 html-test/ref/Math.html                            | 83 ++++++++++++++++++++++
 html-test/ref/mini_Math.html                       | 31 ++++++++
 html-test/src/Math.hs                              |  4 ++
 12 files changed, 147 insertions(+), 1 deletion(-)
 create mode 100644 html-test/ref/Math.html
 create mode 100644 html-test/ref/mini_Math.html
 create mode 100644 html-test/src/Math.hs

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index a9bc9a8b..8d67bd45 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -308,6 +308,8 @@ markupTag dflags = Markup {
   markupBold                 = box (TagInline "b"),
   markupMonospaced           = box (TagInline "tt"),
   markupPic                  = const $ str " ",
+  -- FIXME: We could actually emit the mathjax as it is moderately readable
+  markupMathInline           = const $ str "<math>",
   markupUnorderedList        = box (TagL 'u'),
   markupOrderedList          = box (TagL 'o'),
   markupDefList              = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index ab6bb41c..34aca327 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1107,6 +1107,7 @@ parLatexMarkup ppId = Markup {
   markupMonospaced           = \p _ -> tt (p Mono),
   markupUnorderedList        = \p v -> itemizedList (map ($v) p) $$ text "",
   markupPic                  = \p _ -> markupPic p,
+  markupMathInline           = \p _ -> markupMathInline p,
   markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
   markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
   markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
@@ -1139,6 +1140,8 @@ parLatexMarkup ppId = Markup {
 
         beg = text "image: " <> text uri
 
+    markupMathInline mathjax = text "$" <> text mathjax <> text "$"
+
     markupId ppId_ id v =
       case v of
         Verb  -> theid
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 1554a33c..89772441 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -114,6 +114,7 @@ headHtml docTitle miniPage themes =
     thetitle << docTitle,
     styleSheet themes,
     script ! [src jsFile, thetype "text/javascript"] << noHtml,
+    script ! [src "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML", thetype "text/javascript"] << noHtml,
     script ! [thetype "text/javascript"]
         -- NB: Within XHTML, the content of script tags needs to be
         -- a <![CDATA[ section. Will break if the miniPage name could
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 3fe74a82..b291af0b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -33,6 +33,7 @@ import Data.Maybe (fromMaybe)
 import GHC
 import Name
 
+
 parHtmlMarkup :: Qualification -> Bool
               -> (Bool -> a -> Html) -> DocMarkup a Html
 parHtmlMarkup qual insertAnchors ppId = Markup {
@@ -67,6 +68,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
                                   then namedAnchor aname << ""
                                   else noHtml,
   markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
+  markupMathInline           = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"),
   markupProperty             = pre . toHtml,
   markupExample              = examplesToHtml,
   markupHeader               = \(Header l t) -> makeHeader l t
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 3c14498c..87bfa9e2 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -132,6 +132,7 @@ rename dflags gre = rn
       DocModule str -> DocModule str
       DocHyperlink l -> DocHyperlink l
       DocPic str -> DocPic str
+      DocMathInline str -> DocMathInline str
       DocAName str -> DocAName str
       DocProperty p -> DocProperty p
       DocExamples e -> DocExamples e
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index b837970b..41826bfc 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -441,6 +441,7 @@ instance (NFData a, NFData mod)
     DocCodeBlock a            -> a `deepseq` ()
     DocHyperlink a            -> a `deepseq` ()
     DocPic a                  -> a `deepseq` ()
+    DocMathInline a           -> a `deepseq` ()
     DocAName a                -> a `deepseq` ()
     DocProperty a             -> a `deepseq` ()
     DocExamples a             -> a `deepseq` ()
@@ -488,6 +489,7 @@ data DocMarkup id a = Markup
   , markupHyperlink            :: Hyperlink -> a
   , markupAName                :: String -> a
   , markupPic                  :: Picture -> a
+  , markupMathInline           :: String -> a
   , markupProperty             :: String -> a
   , markupExample              :: [Example] -> a
   , markupHeader               :: Header a -> a
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 3510d908..0704f1ef 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -478,6 +478,7 @@ 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 (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))
@@ -508,6 +509,7 @@ idMarkup = Markup {
   markupHyperlink            = DocHyperlink,
   markupAName                = DocAName,
   markupPic                  = DocPic,
+  markupMathInline           = DocMathInline,
   markupProperty             = DocProperty,
   markupExample              = DocExamples,
   markupHeader               = DocHeader
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index ca9e9d8d..919ea37f 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -73,6 +73,7 @@ overIdentifier f d = g d
     g (DocCodeBlock x) = DocCodeBlock $ g x
     g (DocHyperlink x) = DocHyperlink x
     g (DocPic x) = DocPic x
+    g (DocMathInline x) = DocMathInline x
     g (DocAName x) = DocAName x
     g (DocProperty x) = DocProperty x
     g (DocExamples x) = DocExamples x
@@ -113,7 +114,8 @@ parseStringBS = snd . parse p
   where
     p :: Parser (DocH mod Identifier)
     p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName
-                            <|> picture <|> markdownImage <|> hyperlink <|> bold
+                            <|> picture <|> mathDisplay <|> markdownImage
+                            <|> hyperlink <|> bold
                             <|> emphasis <|> encodedChar <|> string'
                             <|> skipSpecialChar)
 
@@ -224,6 +226,18 @@ picture :: Parser (DocH mod a)
 picture = DocPic . makeLabeled Picture . decodeUtf8
           <$> disallowNewline ("<<" *> takeUntil ">>")
 
+-- FIXME: I have just copied the code for `picture` but it is not
+-- clear why we should disallow a newline (if that is what
+-- `disallowNewline` does)
+
+-- | Inline math parser, surrounded by \$\$ and \$\$.
+--
+-- >>> parseString "$$\int_{-infty}^{infty} e^{-x^2/2} = \sqrt{2\pi}$$"
+-- DocMathInline (DocString "\int_{-infty}^{infty} e^{-x^2/2} = \sqrt{2\pi}")
+mathDisplay :: Parser (DocH mod a)
+mathDisplay = DocMathInline . decodeUtf8
+              <$> disallowNewline  ("$$" *> takeUntil "$$")
+
 markdownImage :: Parser (DocH mod a)
 markdownImage = fromHyperlink <$> ("!" *> linkParser)
   where
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 4ef89658..2b1e7f26 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -71,6 +71,7 @@ data DocH mod id
   | DocCodeBlock (DocH mod id)
   | DocHyperlink Hyperlink
   | DocPic Picture
+  | DocMathInline String
   | DocAName String
   | DocProperty String
   | DocExamples [Example]
diff --git a/html-test/ref/Math.html b/html-test/ref/Math.html
new file mode 100644
index 00000000..3335f7b1
--- /dev/null
+++ b/html-test/ref/Math.html
@@ -0,0 +1,83 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >Math</title
+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_Math.html");};
+//]]>
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href=""
+	  >Contents</a
+	  ></li
+	><li
+	><a href=""
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      >&nbsp;</p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>Math</p
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><a href=""
+	    >f</a
+	    > :: <a href=""
+	    >Integer</a
+	    ></li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><a name="v:f" class="def"
+	    >f</a
+	    > :: <a href=""
+	    >Integer</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Math (inline) for <code
+	      >normalDensity</code
+	      > $$\int_{-\infnty}^{\infty} e^{-x^2/2} = sqrt{2\pi}$$</p
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ><p
+      >Produced by <a href=""
+	>Haddock</a
+	> version 2.16.1</p
+      ></div
+    ></body
+  ></html
+>
diff --git a/html-test/ref/mini_Math.html b/html-test/ref/mini_Math.html
new file mode 100644
index 00000000..92786b95
--- /dev/null
+++ b/html-test/ref/mini_Math.html
@@ -0,0 +1,31 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >Math</title
+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//<![CDATA[
+window.onload = function () {pageLoad();};
+//]]>
+</script
+    ></head
+  ><body id="mini"
+  ><div id="module-header"
+    ><p class="caption"
+      >Math</p
+      ></div
+    ><div id="interface"
+    ><div class="top"
+      ><p class="src"
+	><a href="" target="main"
+	  >f</a
+	  ></p
+	></div
+      ></div
+    ></body
+  ></html
+>
diff --git a/html-test/src/Math.hs b/html-test/src/Math.hs
new file mode 100644
index 00000000..aa6ff1ff
--- /dev/null
+++ b/html-test/src/Math.hs
@@ -0,0 +1,4 @@
+module Math where
+
+-- | Math (inline) for 'normalDensity' $$\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}$$
+f = 5
-- 
cgit v1.2.3