[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

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