Add support for fancy highlighting upon hovering over identifier.

4 files changed, 70 insertions, 10 deletions

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 14656994..216627cc 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -21,6 +21,7 @@ data-files:
   html/solarized.css
   html/frames.html
   html/haddock-util.js
+  html/highlight.js
   html/Classic.theme/haskell_icon.gif
   html/Classic.theme/minus.gif
   html/Classic.theme/plus.gif
diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js
new file mode 100644
index 00000000..639cf5d5
--- /dev/null
+++ b/haddock-api/resources/html/highlight.js
@@ -0,0 +1,46 @@
+
+var styleForRule = function (rule) {
+	var sheets = document.styleSheets;
+	for (var s = 0; s < sheets.length; s++) {
+		var rules = sheets[s].cssRules;
+		for (var r = 0; r < rules.length; r++) {
+			if (rules[r].selectorText == rule) {
+				return rules[r].style;
+			}
+		}
+	}
+};
+
+var highlight = function () {
+	var color = styleForRule("a:hover")["background-color"];
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		var that = links[i];
+		if (this.href == that.href) {
+			that.style["background-color"] = color;
+		}
+	}
+};
+
+/*
+ * I have no idea what is the proper antonym for "highlight" in this
+ * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously
+ * so I like it.
+ */
+var lowlight = function () {
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		var that = links[i];
+		if (this.href == that.href) {
+			that.style["background-color"] = "";
+		}
+	}
+};
+
+window.onload = function () {
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		links[i].onmouseover = highlight;
+		links[i].onmouseout = lowlight;
+	}
+};
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 66392a67..9337307c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -16,14 +16,17 @@ ppHyperlinkedSource outdir libdir mstyle ifaces = do
     createDirectoryIfMissing True $ srcPath outdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcPath outdir </> srcCssFile
+    copyFile (libdir </> "html" </> highlightScript) $
+        srcPath outdir </> highlightScript
     mapM_ (ppHyperlinkedModuleSource outdir) ifaces
 
 ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
 ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of
-    Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens
+    Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens
     Nothing -> return ()
   where
-    mSrcCssFile = Just $ srcCssFile
+    mCssFile = Just $ srcCssFile
+    mJsFile = Just $ highlightScript
     path = srcPath outdir </> moduleSourceFile (ifaceMod iface)
 
 moduleSourceFile :: Module -> FilePath
@@ -35,5 +38,8 @@ srcPath outdir = outdir </> "src"
 srcCssFile :: FilePath
 srcCssFile = "style.css"
 
+highlightScript :: FilePath
+highlightScript = "highlight.js"
+
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 70524759..6d6d2012 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -16,21 +16,28 @@ import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> [RichToken] -> Html
-render css tokens = header css <> body tokens
+render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
+render mcss mjs tokens = header mcss mjs <> body tokens
 
 body :: [RichToken] -> Html
 body = Html.body . Html.pre . mconcat . map richToken
 
-header :: Maybe FilePath -> Html
-header Nothing = Html.noHtml
-header (Just css) =
-    Html.header $ Html.thelink Html.noHtml ! attrs
+header :: Maybe FilePath -> Maybe FilePath -> Html
+header mcss mjs
+    | isNothing mcss && isNothing mjs = Html.noHtml
+header mcss mjs =
+    Html.header $ css mcss <> js mjs
   where
-    attrs =
+    css Nothing = Html.noHtml
+    css (Just cssFile) = Html.thelink Html.noHtml !
         [ Html.rel "stylesheet"
-        , Html.href css
         , Html.thetype "text/css"
+        , Html.href cssFile
+        ]
+    js Nothing = Html.noHtml
+    js (Just jsFile) = Html.script Html.noHtml !
+        [ Html.thetype "text/javascript"
+        , Html.src jsFile
         ]
 
 richToken :: RichToken -> Html