aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock.cabal1
-rw-r--r--html/frames.html27
-rw-r--r--html/haddock-util.js6
-rw-r--r--html/haddock.css30
-rw-r--r--src/Haddock/Backends/Html.hs116
-rw-r--r--src/Haddock/Utils.hs21
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.
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 10:59:01 +0000