aboutsummaryrefslogtreecommitdiff
path: root/src/HaddockHtml.hs
diff options
context:
space:
mode:
authorsimonmar <unknown>2002-04-10 13:26:10 +0000
committersimonmar <unknown>2002-04-10 13:26:10 +0000
commit3dc6aa81a96b02279c3f24c7b65baff3a4cdefe8 (patch)
treec11e186788d7ce4a101b17808b37137f5cd00918 /src/HaddockHtml.hs
parent47187edb76ddbf354b4b24429ea16c0c207a51ac (diff)
[haddock @ 2002-04-10 13:26:09 by simonmar]
Lots of changes, including: - add index support to the HTML backend - clean up the renamer, put it into a monad - propogate unresolved names to the top level and report them in a nicer way - various bugfixes
Diffstat (limited to 'src/HaddockHtml.hs')
-rw-r--r--src/HaddockHtml.hs71
1 files changed, 46 insertions, 25 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index ea6d3f73..277e45c4 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -11,7 +11,7 @@ import HaddockVersion
import HaddockTypes
import HsSyn
-import Maybe ( fromJust, isNothing )
+import Maybe ( fromJust, isNothing, isJust )
import FiniteMap
import List ( sortBy )
import Char ( toUpper, toLower )
@@ -283,24 +283,39 @@ ifaceToHtml mod iface
| null exports = Html.emptyTable
| otherwise =
td << table ! [width "100%", cellpadding 0, cellspacing 15] <<
- (body1 </> body2)
- where exports = iface_exports iface
- doc_map = iface_name_docs iface
+ (description </> synopsis </> maybe_hr </> body)
+ where
+ exports = iface_exports iface
+ doc_map = iface_name_docs iface
- body1
+ has_doc (ExportDecl d)
+ | Just x <- declMainBinder d = isJust (lookupFM doc_map x)
+ has_doc _ = True
+
+ no_doc_at_all = not (any has_doc exports)
+
+ description
| Just doc <- iface_doc iface
= (tda [theclass "section1"] << toHtml "Description") </>
docBox (markup htmlMarkup doc)
| otherwise
= Html.emptyTable
- body2 =
- (tda [theclass "section1"] << toHtml "Synopsis") </>
- (tda [width "100%", theclass "synopsis"] <<
- table ! [width "100%", cellpadding 0, cellspacing 8, border 0] <<
- aboves (map (processExport doc_map True) exports)) </>
- td << hr </>
- aboves (map (processExport doc_map False) exports)
+ -- omit the synopsis if there are no documentation annotations at all
+ synopsis
+ | no_doc_at_all = Html.emptyTable
+ | otherwise
+ = (tda [theclass "section1"] << toHtml "Synopsis") </>
+ (tda [width "100%", theclass "synopsis"] <<
+ table ! [width "100%", cellpadding 0, cellspacing 8, border 0] <<
+ aboves (map (processExport doc_map True) exports))
+
+ maybe_hr
+ | not (no_doc_at_all), ExportGroup 1 _ <- head exports
+ = td << hr
+ | otherwise = Html.emptyTable
+
+ body = aboves (map (processExport doc_map False) exports)
processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable
processExport doc_map summary (ExportGroup lev doc)
@@ -349,11 +364,12 @@ doDecl doc_map summary decl = do_decl decl
++ map ppHsName args) <+> equals <+> ppHsType ty)
do_decl (HsNewTypeDecl loc ctx nm args con drv)
- = ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [con] drv)
+ = ppHsDataDecl doc_map summary True{-is newtype-}
+ (HsDataDecl loc ctx nm args [con] drv)
-- print it as a single-constructor datatype
do_decl decl@(HsDataDecl loc ctx nm args cons drv)
- = ppHsDataDecl doc_map summary decl
+ = ppHsDataDecl doc_map summary False{-not newtype-} decl
do_decl decl@(HsClassDecl _ _ _)
= ppHsClassDecl doc_map summary decl
@@ -377,15 +393,17 @@ keepDecl _ = False
-- -----------------------------------------------------------------------------
-- Data & newtype declarations
-ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args [con] drv) =
+ppShortDataDecl doc_map summary is_newty
+ (HsDataDecl loc ctx nm args [con] drv) =
declBox ( -- single constructor special case
- ppHsDataHeader summary nm args
+ ppHsDataHeader summary is_newty nm args
<+> equals <+> ppShortConstr summary con
)
-ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args cons drv) =
+ppShortDataDecl doc_map summary is_newty
+ (HsDataDecl loc ctx nm args cons drv) =
declBox << vanillaTable << (
aboves (
- (declBox (ppHsDataHeader summary nm args) :
+ (declBox (ppHsDataHeader summary is_newty nm args) :
zipWith do_constr ('=':repeat '|') cons
)
)
@@ -395,20 +413,20 @@ ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args cons drv) =
-- First, the abstract case:
-ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [] drv) =
+ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) =
declWithDoc summary (lookupFM doc_map nm)
- (ppHsDataHeader summary nm args)
+ (ppHsDataHeader summary is_newty nm args)
-- The rest of the cases:
-ppHsDataDecl doc_map summary decl@(HsDataDecl loc ctx nm args cons drv)
+ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
| summary || (isNothing doc && all constr_has_no_doc cons)
- = ppShortDataDecl doc_map summary decl
+ = ppShortDataDecl doc_map summary is_newty decl
| otherwise
= td << vanillaTable << (header </> datadoc </> constrs)
where
- header = declBox (ppHsDataHeader False nm args)
+ header = declBox (ppHsDataHeader False is_newty nm args)
datadoc = docBox (markup htmlMarkup (fromJust doc))
constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
@@ -428,6 +446,8 @@ ppHsDataDecl doc_map summary decl@(HsDataDecl loc ctx nm args cons drv)
constr_has_no_doc (HsConDecl _ nm _ _)
= isNothing (lookupFM doc_map nm)
+ constr_has_no_doc (HsRecDecl _ nm _ _)
+ = isNothing (lookupFM doc_map nm)
ppShortConstr :: Bool -> HsConDecl -> Html
@@ -475,8 +495,9 @@ ppFullField _ _ = error "ppFullField"
expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
-ppHsDataHeader summary nm args =
- keyword "data" <+> ppHsBinder summary nm <+> hsep (map ppHsName args)
+ppHsDataHeader summary is_newty nm args =
+ (if is_newty then keyword "newtype" else keyword "data") <+>
+ ppHsBinder summary nm <+> hsep (map ppHsName args)
ppHsBangType :: HsBangType -> Html
ppHsBangType (HsBangedTy ty) = char '!' +++ ppHsAType ty