From 9a55030410de644cb99e127f4eef2da6692836b6 Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Fri, 24 Oct 2008 17:04:08 +0000 Subject: 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. --- src/Haddock/Backends/Html.hs | 116 ++++++++++++++++++++++++++++++++++++++++--- src/Haddock/Utils.hs | 21 ++++++-- 2 files changed, 128 insertions(+), 9 deletions(-) (limited to 'src/Haddock') 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. -- cgit v1.2.3