aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsimonmar <unknown>2003-11-05 15:15:59 +0000
committersimonmar <unknown>2003-11-05 15:15:59 +0000
commitf14ea82a6c7a6fc491a1c3aaf056e286de8507cd (patch)
treefd919380831cf7054569eae5604195754b73035c
parenta969de7fdb7dcaacb58b81554d67a79818541241 (diff)
[haddock @ 2003-11-05 15:15:59 by simonmar]
Index overhaul: - no more separate type/class and variable/function indices - the index now makes a distinction between different entities with the same name. One example is a type constructor with the same name as a data constructor, but another example is simply a function with the same name exported by two different modules. For example, the index entry for 'catch' now looks like this: catch 1 (Function) Control.Exception 2 (Function) GHC.Exception, Prelude, System.IO, System.IO.Error making it clear that there are two different 'catch'es, but one of them is exported by several modules. - Each index page now has the index contents (A B C ...) at the top. Please let me know if you really hate any of this.
-rw-r--r--html/haddock.css15
-rw-r--r--src/HaddockHtml.hs130
2 files changed, 89 insertions, 56 deletions
diff --git a/html/haddock.css b/html/haddock.css
index 1d52a9b2..67ef28d2 100644
--- a/html/haddock.css
+++ b/html/haddock.css
@@ -76,6 +76,21 @@ TD.body {
padding-left: 10px
}
+TD.indexentry {
+ vertical-align: top;
+ padding-right: 10px
+ }
+
+TD.indexannot {
+ vertical-align: top;
+ padding-left: 20px;
+ white-space: nowrap
+ }
+
+TD.indexlinks {
+ width: 100%
+ }
+
/* ------- Section Headings ------- */
TD.section1 {
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 7251cb90..9bdc9875 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -17,7 +17,7 @@ import HsSyn
import IO
import Maybe ( fromJust, isJust )
import List ( sortBy )
-import Char ( toUpper, toLower, isAlpha, ord )
+import Char ( isUpper, toUpper, isAlpha, ord )
import Monad ( when, unless )
#if __GLASGOW_HASKELL__ < 503
@@ -83,8 +83,8 @@ contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
indexHtmlFile = "doc-index.html"
-subIndexHtmlFile :: Char -> Char -> String
-subIndexHtmlFile k a = "doc-index-" ++ [k] ++ b ++ ".html"
+subIndexHtmlFile :: Char -> String
+subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
where b | isAlpha a = [a]
| otherwise = show (ord a)
@@ -226,88 +226,106 @@ ppHtmlIndex odir doctitle ifaces = do
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
simpleHeader doctitle </>
- tda [theclass "section1"] << toHtml "Type/Class Index" </>
- index_html tycls_index 't' </>
- tda [theclass "section1"] << toHtml "Function/Constructor Index" </>
- index_html var_index 'v'
+ index_html
)
- when split_indices
- (do mapM_ (do_sub_index "Type/Class" tycls_index 't') initialChars
- mapM_ (do_sub_index "Function/Constructor" var_index 'v') initialChars
- )
+ when split_indices $
+ mapM_ (do_sub_index index) initialChars
writeFile (odir ++ pathSeparator:indexHtmlFile) (renderHtml html)
where
- split_indices = length tycls_index > 50 || length var_index > 50
+ split_indices = length index > 50
- index_html this_ix kind
+ index_html
| split_indices =
- td << table ! [cellpadding 0, cellspacing 5] <<
- besides [ td << anchor ! [href (subIndexHtmlFile kind c)] <<
- toHtml [c]
- | c <- initialChars
- , any ((`nameBeginsWith` c) . fst) this_ix ]
+ tda [theclass "section1"] <<
+ toHtml ("Index") </>
+ indexInitialLetterLinks
| otherwise =
td << table ! [cellpadding 0, cellspacing 5] <<
- aboves (map indexElt this_ix)
+ aboves (map indexElt index)
- do_sub_index descr this_ix kind c
+ indexInitialLetterLinks =
+ td << table ! [cellpadding 0, cellspacing 5] <<
+ besides [ td << anchor ! [href (subIndexHtmlFile c)] <<
+ toHtml [c]
+ | c <- initialChars
+ , any ((==c) . head . fst) index ]
+
+ do_sub_index this_ix c
= unless (null index_part) $
- writeFile (odir ++ pathSeparator:subIndexHtmlFile kind c)
+ writeFile (odir ++ pathSeparator:subIndexHtmlFile c)
(renderHtml html)
where
- html = header (thetitle (toHtml (doctitle ++ " (" ++ descr ++ "Index)")) +++
+ html = header (thetitle (toHtml (doctitle ++ " (Index)")) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
simpleHeader doctitle </>
+ indexInitialLetterLinks </>
tda [theclass "section1"] <<
- toHtml (descr ++ " Index (" ++ c:")") </>
+ toHtml ("Index (" ++ c:")") </>
td << table ! [cellpadding 0, cellspacing 5] <<
aboves (map indexElt index_part)
)
- index_part = [(n,stuff) | (n,stuff) <- this_ix, n `nameBeginsWith` c]
-
- tycls_index = index isTyClsName
- var_index = index (not.isTyClsName)
+ index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
- isTyClsName (HsTyClsName _) = True
- isTyClsName _ = False
-
- index :: (HsName -> Bool) -> [(HsName, [(Module,Bool)])]
- index f = sortBy cmp (fmToList (full_index f))
+ index :: [(String, FiniteMap HsQName [(Module,Bool)])]
+ index = sortBy cmp (fmToList full_index)
where cmp (n1,_) (n2,_) = n1 `compare` n2
- iface_indices f = map (getIfaceIndex f) ifaces
- full_index f = foldr (plusFM_C (++)) emptyFM (iface_indices f)
-
- getIfaceIndex f (mdl,iface) = listToFM
- [ (nm, [(mdl, not (nm `elemFM` iface_reexported iface))])
- | (nm, Qual mdl' _) <- fmToList (iface_env iface), f nm ]
-
- indexElt :: (HsName, [(Module,Bool)]) -> HtmlTable
- indexElt (nm, entries) =
- td << ppHsName nm
- <-> td << (hsep [ if visible then
- linkId (Module mdl) (Just nm) << toHtml mdl
- else
- toHtml mdl
- | (Module mdl, visible) <- entries ])
+ -- 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 :: FiniteMap String (FiniteMap HsQName [(Module,Bool)])
+ full_index = addListToFM_C (plusFM_C (++)) emptyFM
+ (concat (map getIfaceIndex ifaces))
+
+ getIfaceIndex (mdl,iface) =
+ [ (hsNameStr nm,
+ listToFM [(orig, [(mdl, not (nm `elemFM` iface_reexported iface))])])
+ | (nm, orig) <- fmToList (iface_env iface) ]
+
+ indexElt :: (String, FiniteMap HsQName [(Module,Bool)]) -> HtmlTable
+ indexElt (str, entities) =
+ case fmToList entities of
+ [(nm,entries)] ->
+ tda [ theclass "indexentry" ] << toHtml str <->
+ indexLinks (unQual nm) entries
+ many_entities ->
+ tda [ theclass "indexentry" ] << toHtml str </>
+ aboves (map doAnnotatedEntity (zip [1..] many_entities))
+
+ unQual (Qual _ nm) = nm
+ unQual (UnQual nm) = nm
+
+ doAnnotatedEntity (j,(qnm,entries))
+ = tda [ theclass "indexannot" ] <<
+ toHtml (show j) <+> parens (ppAnnot nm) <->
+ indexLinks nm entries
+ where nm = unQual qnm
+
+ ppAnnot (HsTyClsName n)
+ = toHtml "Type/Class"
+ ppAnnot (HsVarName n)
+ | isUpper c || c == ':' = toHtml "Data Constructor"
+ | otherwise = toHtml "Function"
+ where c = head (ppHsIdentifier n)
+
+ indexLinks nm entries =
+ tda [ theclass "indexlinks" ] <<
+ hsep (punctuate comma
+ [ if visible then
+ linkId (Module mdl) (Just nm) << toHtml mdl
+ else
+ toHtml mdl
+ | (Module mdl, visible) <- entries ])
initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~"
-nameBeginsWith :: HsName -> Char -> Bool
-nameBeginsWith (HsTyClsName id0) c = idBeginsWith id0 c
-nameBeginsWith (HsVarName id0) c = idBeginsWith id0 c
-
-idBeginsWith :: HsIdentifier -> Char -> Bool
-idBeginsWith (HsIdent s) c = head s `elem` [toLower c, toUpper c]
-idBeginsWith (HsSymbol s) c = head s `elem` [toLower c, toUpper c]
-idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
-
-- ---------------------------------------------------------------------------
-- Generate the HTML page for a module