aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haddock-api/haddock-api.cabal1
-rw-r--r--haddock-api/resources/html/highlight.js46
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs10
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs23
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