Enable framed view of the HTML documentation.

This patch introduces: - A page that displays the documentation in a framed view. The left side will show a full module index. Clicking a module name will show it in the right frame. If Javascript is enabled, the left side is split again to show the modules at the top and a very short synopsis for the module currently displayed on the right. - Code to generate the mini-synopsis for each module and the mini module index ("index-frames.html"). - CSS rules for the mini-synopsis. - A very small amount of javascript to update the mini-synopsis (but only if inside a frame.) Some perhaps controversial things: - Sharing code was very difficult, so there is a small amount of code duplication. - The amount of generated pages has been doubled, since every module now also gets a mini-synopsis. The overhead should not be too much, but I haven't checked. Alternatively, the mini-synopsis could also be generated using Javascript if we properly annotate the actual synopsis.
author: Thomas Schilling <nominolo@googlemail.com> 2008-10-24 17:04:08 +0000
committer: Thomas Schilling <nominolo@googlemail.com> 2008-10-24 17:04:08 +0000
commit: 9a55030410de644cb99e127f4eef2da6692836b6 (patch)
tree: 1a445e4b1b2b920e4f83e4dd1fe1f8c265baaaf4
parent: f9f62bd4ff9079c57b13cf3346e2bf54419dce4a (diff)
6 files changed, 192 insertions, 9 deletions
diff --git a/haddock.cabal b/haddock.cabal
index f4f92ae1..d4f0ea54 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -56,6 +56,7 @@ data-files:
 	html/haskell_icon.gif
 	html/minus.gif
 	html/plus.gif
+	html/frames.html
 
 flag in-ghc-tree
   description: Are we in a GHC tree?
diff --git a/html/frames.html b/html/frames.html
new file mode 100644
index 00000000..9e904fc1
--- /dev/null
+++ b/html/frames.html
@@ -0,0 +1,27 @@
+<html>
+<head>
+<script type="text/javascript"><!--
+/*
+
+  The synopsis frame needs to be updated using javascript, so we hide
+  it by default and only show it if javascript is enabled.
+
+  TODO: provide some means to disable it.
+*/
+function load() {
+  var d = document.getElementById("inner-fs");
+  d.rows = "50%,50%";
+}
+--></script>
+<frameset id="outer-fs" cols="25%,75%" onload="load()">
+  <frameset id="inner-fs" rows="100%,0%">
+
+    <frame src="index-frames.html" name="modules">
+    <frame src="" name="synopsis">
+
+  </frameset>
+  <frame src="index.html" name="main">
+
+</frameset>
+
+</html>
diff --git a/html/haddock-util.js b/html/haddock-util.js
index e5d6977e..364081f0 100644
--- a/html/haddock-util.js
+++ b/html/haddock-util.js
@@ -131,3 +131,9 @@ function perform_search(full)
         return ""; // should never be reached
     }
 }
+
+function setSynopsis(filename) {
+    if (parent.window.synopsis) {
+      parent.window.synopsis.location = filename;
+    }
+}
diff --git a/html/haddock.css b/html/haddock.css
index 26695270..35a078d1 100644
--- a/html/haddock.css
+++ b/html/haddock.css
@@ -4,6 +4,7 @@ BODY {
   background-color: #ffffff;
   color: #000000;
   font-family: sans-serif;
+  padding: 0 0;
   } 
 
 A:link    { color: #0000e0; text-decoration: none }
@@ -265,3 +266,32 @@ TD.botbar A:hover {
   background-color: #6060ff
   }
 
+/* --------- Mini Synopsis for Frame View --------- */
+
+.outer {
+  margin: 0 0;
+  padding: 0 0;
+}
+
+.mini-synopsis {
+  padding: 0.25em 0.25em;
+}
+
+.mini-synopsis H1 { font-size: 130%; }
+.mini-synopsis H2 { font-size: 110%; }
+.mini-synopsis H3 { font-size: 100%; }
+.mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 {
+  margin-top: 0.5em;
+  margin-bottom: 0.25em;
+  padding: 0 0;
+}
+
+.mini-synopsis H1 { border-bottom: 1px solid #ccc; }
+
+.mini-topbar {
+  font-size: 130%;
+  background: #0077dd;
+  padding: 0.25em;
+}
+
+
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 579d7896..f44b6fb6 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -29,12 +29,14 @@ import qualified Haddock.Utils.Html as Html
 import Control.Exception     ( bracket )
 import Control.Monad         ( when, unless )
 import Data.Char             ( isUpper, toUpper )
-import Data.List             ( sortBy )
+import Data.List             ( sortBy, groupBy )
 import Data.Maybe
 import Foreign.Marshal.Alloc ( allocaBytes )
 import System.IO             ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
 import Data.Map              ( Map )
 import qualified Data.Map as Map hiding ( Map )
+import Data.Function
+import Data.Ord              ( comparing )
 
 #if __GLASGOW_HASKELL__ >= 609
 import GHC hiding ( NoLink, moduleInfo )
@@ -76,7 +78,6 @@ ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format
   let
 	visible_ifaces = filter visible ifaces
 	visible i = OptHide `notElem` ifaceOptions i
-
   when (not (isJust maybe_contents_url)) $ 
     ppHtmlContents odir doctitle maybe_package
         maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url
@@ -146,7 +147,7 @@ copyHtmlBits odir libdir maybe_css = do
 	copyLibFile f = do
 	   copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f])
   copyFile css_file css_destination
-  mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ]
+  mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ]
 
 footer :: HtmlTable
 footer = 
@@ -331,6 +332,9 @@ ppHtmlContents odir doctitle
 	    footer
 	  )
   writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html)
+
+  -- XXX: think of a better place for this?
+  ppHtmlContentsFrame odir doctitle ifaces
   
   -- Generate contents page for Html Help if requested
   case maybe_html_help_format of
@@ -412,6 +416,37 @@ mkNode ss (Node s leaf pkg short ts) depth id = htmlNode
 -- The URL for source and wiki links, and the current module
 type LinksInfo = (SourceURLs, WikiURLs)
 
+-- | Turn a module tree into a flat list of full module names.  E.g.,
+-- @
+--  A
+--  +-B
+--  +-C
+-- @
+-- becomes
+-- @["A", "A.B", "A.B.C"]@
+flatModuleTree :: [InstalledInterface] -> [Html]
+flatModuleTree ifaces =
+    map (uncurry ppModule' . head)
+            . groupBy ((==) `on` fst)
+            . sortBy (comparing fst)
+            $ mods
+  where
+    mods = [ (moduleString mod, mod) | mod <- map instMod ifaces ]
+    ppModule' txt mod =
+      anchor ! [href ((moduleHtmlFile mod)), target mainFrameName]
+        << toHtml txt
+
+ppHtmlContentsFrame odir doctitle ifaces = do
+  let mods = flatModuleTree ifaces
+      html =
+        header
+            (documentCharacterEncoding +++
+	     thetitle (toHtml doctitle) +++
+	     styleSheet +++
+	     (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+        body << vanillaTable << p << (
+            foldr (+++) noHtml (map (+++br) mods))
+  writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderHtml html)
 
 -- ---------------------------------------------------------------------------
 -- Generate the index
@@ -534,7 +569,12 @@ ppHtmlModule odir doctitle
 	header (documentCharacterEncoding +++
 		thetitle (toHtml mdl) +++
 		styleSheet +++
-		(script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+		(script ! [src jsFile, thetype "text/javascript"] $ noHtml) +++
+                (script ! [thetype "text/javascript"]
+                     -- XXX: quoting errors possible?
+                     << Html [HtmlString ("window.onload = function () {setSynopsis(\"mini_" 
+                                ++ moduleHtmlFile mod ++ "\")};")])
+               ) +++
         body << vanillaTable << (
 	    pageHeader mdl iface doctitle
 		maybe_source_url maybe_wiki_url
@@ -543,7 +583,22 @@ ppHtmlModule odir doctitle
 	    footer
          )
   writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html)
-
+  ppHtmlModuleMiniSynopsis odir doctitle iface
+
+ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle iface = do
+  let mod = ifaceMod iface
+      html =
+        header
+          (documentCharacterEncoding +++
+	   thetitle (toHtml $ moduleString mod) +++
+	   styleSheet +++
+	   (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+        body << thediv ! [ theclass "outer" ] << (
+           (thediv ! [theclass "mini-topbar"]
+             << toHtml (moduleString mod)) +++
+           miniSynopsis mod iface)
+  writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mod]) (renderHtml html)
 
 ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> HtmlTable
 ifaceToHtml maybe_source_url maybe_wiki_url iface
@@ -592,6 +647,52 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface
     bdy  = map (processExport False linksInfo docMap) exports
     linksInfo = (maybe_source_url, maybe_wiki_url)
 
+miniSynopsis :: Module -> Interface -> Html
+miniSynopsis mod iface =
+    thediv ! [ theclass "mini-synopsis" ]
+      << hsep (map (processForMiniSynopsis mod) $ exports)
+
+  where
+    exports = numberSectionHeadings (ifaceRnExportItems iface)
+
+processForMiniSynopsis :: Module -> ExportItem DocName -> Html
+processForMiniSynopsis mod (ExportDecl (L _loc decl0) _doc _insts) =
+  thediv ! [theclass "decl" ] <<
+  case decl0 of
+    TyClD d@(TyFamily{}) -> ppTyFamHeader True False d
+    TyClD d@(TyData{tcdTyPats = ps})
+      | Nothing <- ps    -> keyword "data" <++> ppTyClBinderWithVarsMini mod d
+      | Just _ <- ps     -> keyword "data" <++> keyword "instance"
+                                           <++> ppTyClBinderWithVarsMini mod d
+    TyClD d@(TySynonym{tcdTyPats = ps})
+      | Nothing <- ps    -> keyword "type" <++> ppTyClBinderWithVarsMini mod d
+      | Just _ <- ps     -> keyword "type" <++> keyword "instance"
+                                           <++> ppTyClBinderWithVarsMini mod d
+    TyClD d@(ClassDecl {}) ->
+                            keyword "class" <++> ppTyClBinderWithVarsMini mod d
+    SigD (TypeSig (L _ n) (L _ t)) ->
+        let nm = docNameOcc n
+        in ppNameMini mod nm
+    _ -> noHtml
+processForMiniSynopsis mod (ExportGroup lvl _id txt) =
+  let heading | lvl == 1 = h1
+              | lvl == 2 = h2
+              | lvl >= 3 = h3
+  in heading << docToHtml txt
+processForMiniSynopsis _ _ = noHtml
+
+ppNameMini :: Module -> OccName -> Html
+ppNameMini mod nm =
+    anchor ! [ href ( moduleHtmlFile mod ++ "#"
+                      ++ (escapeStr (anchorNameStr nm)))
+             , target mainFrameName ]
+      << ppBinder' nm
+
+ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
+ppTyClBinderWithVarsMini mod decl =
+  let n = unLoc $ tcdLName decl
+      ns = tyvarNames $ tcdTyVars decl
+  in ppTypeApp n ns (ppNameMini mod . docNameOcc) ppTyName
 
 ppModuleContents :: [ExportItem DocName] -> Maybe HtmlTable
 ppModuleContents exports
@@ -1542,10 +1643,13 @@ hsep :: [Html] -> Html
 hsep [] = noHtml
 hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
 
-infixr 8 <+>
+infixr 8 <+>, <++>
 (<+>) :: Html -> Html -> Html
 a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b))
 
+(<++>) :: Html -> Html -> Html
+a <++> b = a +++ spaceHtml +++ b
+
 keyword :: String -> Html
 keyword s = thespan ! [theclass "keyword"] << toHtml s
 
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index e4c6dbbe..33a3fb47 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -17,9 +17,12 @@ module Haddock.Utils (
   -- * Filename utilities
   basename, dirname, splitFilename3, 
   moduleHtmlFile, nameHtmlRef,
-  contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin,
+  contentsHtmlFile, indexHtmlFile,
+  frameIndexHtmlFile,
+  moduleIndexFrameName, mainFrameName, synopsisFrameName,
+  subIndexHtmlFile, pathJoin,
   anchorNameStr,
-  cssFile, iconFile, jsFile, plusFile, minusFile,
+  cssFile, iconFile, jsFile, plusFile, minusFile, framesFile,
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -195,6 +198,17 @@ contentsHtmlFile, indexHtmlFile :: String
 contentsHtmlFile = "index.html"
 indexHtmlFile = "doc-index.html"
 
+-- | The name of the module index file to be displayed inside a frame.
+-- Modules are display in full, but without indentation.  Clicking opens in
+-- the main window.
+frameIndexHtmlFile :: String
+frameIndexHtmlFile = "index-frames.html"
+
+moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
+moduleIndexFrameName = "modules"
+mainFrameName = "main"
+synopsisFrameName = "synopsis"
+
 subIndexHtmlFile :: Char -> String
 subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
    where b | isAlpha a = [a]
@@ -216,12 +230,13 @@ pathJoin = foldr join []
 -- -----------------------------------------------------------------------------
 -- Files we need to copy from our $libdir
 
-cssFile, iconFile, jsFile, plusFile,minusFile :: String
+cssFile, iconFile, jsFile, plusFile, minusFile, framesFile :: String
 cssFile   = "haddock.css"
 iconFile  = "haskell_icon.gif"
 jsFile    = "haddock-util.js"
 plusFile  = "plus.gif"
 minusFile = "minus.gif"
+framesFile = "frames.html"
 
 -----------------------------------------------------------------------------
 -- misc.
author	Thomas Schilling <nominolo@googlemail.com>	2008-10-24 17:04:08 +0000
committer	Thomas Schilling <nominolo@googlemail.com>	2008-10-24 17:04:08 +0000
commit	9a55030410de644cb99e127f4eef2da6692836b6 (patch)
tree	1a445e4b1b2b920e4f83e4dd1fe1f8c265baaaf4
parent	f9f62bd4ff9079c57b13cf3346e2bf54419dce4a (diff)