aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Xhtml.hs232
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs8
2 files changed, 110 insertions, 130 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 31690b07..743e95df 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -315,15 +315,17 @@ mkNode ss p (Node s leaf pkg short ts) =
[] -> noHtml
_ -> collapsebutton p
- htmlModule
- | leaf = ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
+ htmlModule = thespan ! [theclass "module" ] <<
+ (if leaf
+ then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
(mkModuleName mdl)) ""
- | otherwise = toHtml s
-
+ else toHtml s
+ )
+
mdl = intercalate "." (reverse (s:ss))
shortDescr = maybe noHtml origDocToHtml short
- htmlPkg = maybe noHtml toHtml pkg
+ htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
subtree = mkNodeList (s:ss) p ts ! [identifier p]
@@ -358,7 +360,8 @@ ppHtmlContentsFrame odir doctitle ifaces = do
styleSheet +++
(script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
miniBody << divModuleList <<
- (sectionName << "Modules" +++ unordList mods)
+ (sectionName << "Modules" +++
+ ulist << [ li ! [theclass "module"] << m | m <- mods ])
createDirectoryIfMissing True odir
writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString html)
@@ -376,16 +379,8 @@ ppHtmlIndex :: FilePath
-> IO ()
ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do
- let html =
- header (documentCharacterEncoding +++
- thetitle (toHtml (doctitle ++ " (Index)")) +++
- styleSheet +++
- (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
- body << (
- simpleHeader doctitle maybe_contents_url Nothing
- maybe_source_url maybe_wiki_url +++
- vanillaTable << index_html
- )
+ let html = indexPage split_indices Nothing
+ (if split_indices then [] else index)
createDirectoryIfMissing True odir
@@ -401,118 +396,101 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
Just "mshelp2" -> ppHH2Index odir maybe_package ifaces
Just "devhelp" -> return ()
Just format -> fail ("The "++format++" format is not implemented")
- where
- index_html
- | split_indices =
- tda [theclass "section1"] <<
- toHtml ("Index") </>
- indexInitialLetterLinks
- | otherwise =
- cell $ td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<
- aboves (map indexElt index))
-
- -- an arbitrary heuristic:
- -- too large, and a single-page will be slow to load
- -- too small, and we'll have lots of letter-indexes with only one
- -- or two members in them, which seems inefficient or
- -- unnecessarily hard to use.
- split_indices = length index > 150
-
- setTrClass :: Html -> Html
- setTrClass = id
- -- XHtml is more strict about not allowing you to poke inside a structure
- -- hence this approach won't work for now -- since the whole table is
- -- going away soon, this is just disabled for now.
-{-
- setTrClass (Html xs) = Html $ map f xs
- where
- f (HtmlTag name attrs inner)
- | map toUpper name == "TR" = HtmlTag name (theclass "indexrow":attrs) inner
- | otherwise = HtmlTag name attrs (setTrClass inner)
- f x = x
--}
- indexInitialLetterLinks =
- td << setTrClass (table ! [cellpadding 0, cellspacing 5] <<
- besides [ td << anchor ! [href (subIndexHtmlFile c)] <<
- toHtml [c]
- | c <- initialChars
- , any ((==c) . toUpper . head . fst) index ])
-
- -- todo: what about names/operators that start with Unicode
- -- characters?
- -- Exports beginning with '_' can be listed near the end,
- -- presumably they're not as important... but would be listed
- -- with non-split index!
- initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
-
- do_sub_index this_ix c
- = unless (null index_part) $
- writeFile (joinPath [odir, subIndexHtmlFile c]) (renderToString html)
- where
- html = header (documentCharacterEncoding +++
- thetitle (toHtml (doctitle ++ " (Index)")) +++
- styleSheet) +++
- body << (
- simpleHeader doctitle maybe_contents_url Nothing
- maybe_source_url maybe_wiki_url +++
- vanillaTable << (
- indexInitialLetterLinks </>
- tda [theclass "section1"] <<
- toHtml ("Index (" ++ c:")") </>
- td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<
- aboves (map indexElt index_part) )
- ))
-
- index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
-
-
- index :: [(String, Map GHC.Name [(Module,Bool)])]
- index = sortBy cmp (Map.toAscList full_index)
- where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper n2
-
- -- for each name (a plain string), we have a number of original HsNames that
- -- it can refer to, and for each of those we have a list of modules
- -- that export that entity. Each of the modules exports the entity
- -- in a visible or invisible way (hence the Bool).
- full_index :: Map String (Map GHC.Name [(Module,Bool)])
- full_index = Map.fromListWith (flip (Map.unionWith (++)))
- (concat (map getIfaceIndex ifaces))
-
- getIfaceIndex iface =
- [ (getOccString name
- , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])])
- | name <- instExports iface ]
- where mdl = instMod iface
-
- indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
- indexElt (str, entities) =
- case Map.toAscList entities of
- [(nm,entries)] ->
- tda [ theclass "indexentry" ] << toHtml str <->
- indexLinks nm entries
- many_entities ->
- tda [ theclass "indexentry" ] << toHtml str </>
- aboves (map doAnnotatedEntity (zip [1..] many_entities))
-
- doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
- doAnnotatedEntity (j,(nm,entries))
- = tda [ theclass "indexannot" ] <<
- toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
- indexLinks nm entries
-
- ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
- | isDataOcc n = toHtml "Data Constructor"
- | otherwise = toHtml "Function"
-
- indexLinks nm entries =
- tda [ theclass "indexlinks" ] <<
- hsep (punctuate comma
- [ if visible then
- linkId mdl (Just nm) << toHtml (moduleString mdl)
- else
- toHtml (moduleString mdl)
- | (mdl, visible) <- entries ])
+ where
+ indexPage showLetters ch items =
+ header (documentCharacterEncoding +++
+ thetitle (toHtml (doctitle ++ " (" ++ indexName ch ++ ")")) +++
+ styleSheet +++
+ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)
+ ) +++
+ body <<
+ (simpleHeader doctitle maybe_contents_url Nothing
+ maybe_source_url maybe_wiki_url +++
+ divIndex <<
+ (sectionName << indexName ch +++
+ (if showLetters then indexInitialLetterLinks else noHtml) +++
+ (if null items then noHtml else buildIndex items)
+ )
+ )
+
+ indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
+
+ buildIndex items = table << aboves (map indexElt items)
+
+ -- an arbitrary heuristic:
+ -- too large, and a single-page will be slow to load
+ -- too small, and we'll have lots of letter-indexes with only one
+ -- or two members in them, which seems inefficient or
+ -- unnecessarily hard to use.
+ split_indices = length index > 150
+
+ indexInitialLetterLinks =
+ unordList [ anchor ! [href (subIndexHtmlFile c)] << [c]
+ | c <- initialChars
+ , any ((==c) . toUpper . head . fst) index ]
+
+ -- todo: what about names/operators that start with Unicode
+ -- characters?
+ -- Exports beginning with '_' can be listed near the end,
+ -- presumably they're not as important... but would be listed
+ -- with non-split index!
+ initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
+
+ do_sub_index this_ix c
+ = unless (null index_part) $
+ writeFile (joinPath [odir, subIndexHtmlFile c]) (renderToString html)
+ where
+ html = indexPage True (Just c) index_part
+ index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
+
+
+ index :: [(String, Map GHC.Name [(Module,Bool)])]
+ index = sortBy cmp (Map.toAscList full_index)
+ where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper n2
+
+ -- for each name (a plain string), we have a number of original HsNames that
+ -- it can refer to, and for each of those we have a list of modules
+ -- that export that entity. Each of the modules exports the entity
+ -- in a visible or invisible way (hence the Bool).
+ full_index :: Map String (Map GHC.Name [(Module,Bool)])
+ full_index = Map.fromListWith (flip (Map.unionWith (++)))
+ (concat (map getIfaceIndex ifaces))
+
+ getIfaceIndex iface =
+ [ (getOccString name
+ , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])])
+ | name <- instExports iface ]
+ where mdl = instMod iface
+
+ indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
+ indexElt (str, entities) =
+ case Map.toAscList entities of
+ [(nm,entries)] ->
+ td ! [ theclass "src" ] << toHtml str <->
+ indexLinks nm entries
+ many_entities ->
+ td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
+ aboves (map doAnnotatedEntity (zip [1..] many_entities))
+
+ doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
+ doAnnotatedEntity (j,(nm,entries))
+ = td ! [ theclass "alt" ] <<
+ toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
+ indexLinks nm entries
+
+ ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
+ | isDataOcc n = toHtml "Data Constructor"
+ | otherwise = toHtml "Function"
+
+ indexLinks nm entries =
+ td ! [ theclass "module" ] <<
+ hsep (punctuate comma
+ [ if visible then
+ linkId mdl (Just nm) << toHtml (moduleString mdl)
+ else
+ toHtml (moduleString mdl)
+ | (mdl, visible) <- entries ])
-- ---------------------------------------------------------------------------
-- Generate the HTML page for a module
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 616b3b95..98801d1e 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout (
miniBody,
divPackageHeader, divModuleHeader, divFooter,
- divModuleList, divTableOfContents,
+ divIndex, divModuleList, divTableOfContents,
divDescription, divSynposis, divInterface,
sectionName,
@@ -57,10 +57,12 @@ divPackageHeader = thediv ! [identifier "package-header"]
divModuleHeader = thediv ! [identifier "module-header"]
divFooter = thediv ! [identifier "footer"]
-divModuleList, divTableOfContents,
- divDescription, divSynposis, divInterface :: Html -> Html
+divIndex, divModuleList, divTableOfContents :: Html -> Html
+divIndex = thediv ! [identifier "index"]
divModuleList = thediv ! [identifier "module-list"]
divTableOfContents = thediv ! [identifier "table-of-contents"]
+
+divDescription, divSynposis, divInterface :: Html -> Html
divDescription = thediv ! [identifier "description"]
divSynposis = thediv ! [identifier "synopsis"]
divInterface = thediv ! [identifier "interface"]