aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Haddock/Backends/Html.hs69
1 files changed, 55 insertions, 14 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 410dd6b3..e0e12164 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -32,7 +32,7 @@ import Haddock.GhcUtils
import qualified Haddock.Utils.Html as Html
import Control.Exception ( bracket )
-import Control.Monad ( when, join )
+import Control.Monad ( when, unless, join )
import Data.Char ( toUpper )
import Data.List ( sortBy, groupBy )
import Data.Maybe
@@ -480,10 +480,14 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
body << vanillaTable << (
simpleHeader doctitle maybe_contents_url Nothing
maybe_source_url maybe_wiki_url </>
- search_box </> index_html
+ index_html
)
createDirectoryIfMissing True odir
+
+ when split_indices $
+ mapM_ (do_sub_index index) initialChars
+
writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html)
-- Generate index and contents page for Html Help if requested
@@ -494,19 +498,22 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
Just "devhelp" -> return ()
Just format -> fail ("The "++format++" format is not implemented")
where
- -- colspan 2, marginheight 5
- search_box :: HtmlTable
- search_box = tda [colspan 2, thestyle "padding-top:5px;"] << search
- where
- search :: Html
- search = form ! [strAttr "onsubmit" "full_search(); return false;", action ""] << (
- "Search: "
- +++ input ! [identifier "searchbox", strAttr "onkeyup" "quick_search()"]
- +++ " " +++ input ! [value "Search", thetype "submit"]
- +++ " " +++ thespan ! [identifier "searchmsg"] << " ")
- index_html = td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<
- aboves (map indexElt index))
+ index_html
+ | split_indices =
+ tda [theclass "section1"] <<
+ toHtml ("Index") </>
+ indexInitialLetterLinks
+ | otherwise =
+ 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 (Html xs) = Html $ map f xs
@@ -515,6 +522,40 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
| 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 (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html)
+ where
+ html = header (documentCharacterEncoding +++
+ thetitle (toHtml (doctitle ++ " (Index)")) +++
+ styleSheet) +++
+ body << vanillaTable << (
+ simpleHeader doctitle maybe_contents_url Nothing
+ maybe_source_url maybe_wiki_url </>
+ 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)