[haddock @ 2002-05-27 09:03:51 by simonmar]

Lots of changes:

 - instances of a class are listed with the class, and
   instances involving a datatype are listed with that type.
   Derived instances aren't included at the moment: the calculation
   to find the instance head for a derived instance is non-trivial.

 - some formatting changes; use rows with specified height rather than
   cellspacing in some places.

 - various fixes (source file links were wrong, amongst others)

8 files changed, 257 insertions, 155 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 87d76d51..61113154 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -32,14 +32,19 @@ iconFile = "haskell_icon.gif"
 -- -----------------------------------------------------------------------------
 -- Generating HTML documentation
 
+type InstMaps = 
+	(FiniteMap HsQName [InstHead], -- maps class names to instances
+	 FiniteMap HsQName [InstHead]) -- maps type names to instances
+
 ppHtml	:: String
 	-> Maybe String
 	-> [(Module, Interface)]
 	-> FilePath			-- destination directory
 	-> Maybe String			-- CSS file
 	-> String			-- $libdir
+	-> InstMaps
 	-> IO ()
-ppHtml title source_url ifaces odir maybe_css libdir =  do
+ppHtml title source_url ifaces odir maybe_css libdir inst_maps =  do
   let 
 	css_file = case maybe_css of
 			Nothing -> libdir ++ pathSeparator:cssFile
@@ -59,7 +64,7 @@ ppHtml title source_url ifaces odir maybe_css libdir =  do
 
   ppHtmlContents odir title source_url (map fst visible_ifaces)
   ppHtmlIndex odir title visible_ifaces
-  mapM_ (ppHtmlModule odir title source_url) visible_ifaces
+  mapM_ (ppHtmlModule odir title source_url inst_maps) visible_ifaces
 
 moduleHtmlFile :: String -> FilePath
 moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename?
@@ -131,15 +136,14 @@ pageHeader mod iface title source_url =
 moduleInfo iface 
   | Nothing   <- iface_info iface = Html.emptyTable
   | Just info <- iface_info iface =
-          tda [align "right"] <<
-             (table ! [border 0, cellspacing 0, cellpadding 0] << (
+          tda [align "right"] << narrowTable << (
         	  (tda [theclass "infohead"] << toHtml "Portability") <->
         	  (tda [theclass "infoval"] << toHtml (portability info)) </>
         	  (tda [theclass "infohead"] << toHtml "Stability") <->
         	  (tda [theclass "infoval"] << toHtml (stability info)) </>
         	  (tda [theclass "infohead"] << toHtml "Maintainer") <->
         	  (tda [theclass "infoval"] << toHtml (maintainer info))
-              ))
+              )
 
 -- ---------------------------------------------------------------------------
 -- Generate the module contents
@@ -292,30 +296,29 @@ idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
 -- ---------------------------------------------------------------------------
 -- Generate the HTML page for a module
 
-ppHtmlModule :: FilePath -> String -> Maybe String
+ppHtmlModule :: FilePath -> String -> Maybe String -> InstMaps
 	-> (Module,Interface) -> IO ()
-ppHtmlModule odir title source_url (Module mod,iface) = do
+ppHtmlModule odir title source_url inst_maps (Module mod,iface) = do
   let html = 
 	header (thetitle (toHtml mod) +++
 		thelink ! [href cssFile,
 		  rel "stylesheet", thetype "text/css"]) +++
         body << vanillaTable << (
-	    pageHeader mod iface title source_url </>
-	    ifaceToHtml mod iface </>
+	    pageHeader mod iface title source_url </> s15 </>
+	    ifaceToHtml mod iface inst_maps </> s15 </>
 	    footer
          )
   writeFile (odir ++ pathSeparator:moduleHtmlFile mod) (renderHtml html)
 
-ifaceToHtml :: String -> Interface -> HtmlTable
-ifaceToHtml mod iface
+ifaceToHtml :: String -> Interface -> InstMaps -> HtmlTable
+ifaceToHtml mod iface inst_maps
   | null exports = Html.emptyTable
-  | otherwise =
-    td << table ! [width "100%", cellpadding 0, cellspacing 15] << 
-	(contents </> description </> synopsis </> maybe_hr </> body)
+  | otherwise    = 
+	abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: body)
   where 
 	exports = numberSectionHeadings (iface_exports iface)
 
-	has_doc (ExportDecl d) = isJust (declDoc d)
+	has_doc (ExportDecl _ d) = isJust (declDoc d)
 	has_doc (ExportModule _) = False
 	has_doc _ = True
 
@@ -335,16 +338,22 @@ ifaceToHtml mod iface
 	  | 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 True)  exports))
-
-	maybe_hr
-	     | not (no_doc_at_all),  ExportGroup 1 _ _ <- head exports
-		 = td << hr
+	    s15 </>
+            (tda [theclass "body"] << vanillaTable <<
+  	        abovesSep s8 (map (processExport True inst_maps) 
+			(filter forSummary exports))
+	    )
+
+	-- if the documentation doesn't begin with a section header, then
+	-- add one ("Documentation").
+	maybe_doc_hdr
+	     | not (no_doc_at_all) = 
+		case exports of
+		   ExportGroup _ _ _ : _ -> Html.emptyTable
+		   _ -> tda [ theclass "section1" ] << toHtml "Documentation"
 	     | otherwise  = Html.emptyTable
 
-	body = aboves (map (processExport False) exports)
+	body = map (processExport False inst_maps) exports
 
 ppModuleContents :: [ExportItem] -> HtmlTable
 ppModuleContents exports
@@ -379,18 +388,20 @@ numberSectionHeadings exports = go 1 exports
 	go n (other:es)
 	  = other : go n es
 
-processExport :: Bool -> ExportItem -> HtmlTable
-processExport summary (ExportGroup lev id doc)
-  | summary   = Html.emptyTable
-  | otherwise = ppDocGroup lev (anchor ! [name id] << docToHtml doc)
-processExport summary (ExportDecl decl)
-  = doDecl summary decl
-processExport summary (ExportDoc doc)
-  | summary = Html.emptyTable
-  | otherwise = docBox (docToHtml doc)
-processExport summary (ExportModule (Module mod))
+processExport :: Bool -> InstMaps -> ExportItem -> HtmlTable
+processExport summary inst_maps (ExportGroup lev id doc)
+  = ppDocGroup lev (anchor ! [name id] << docToHtml doc)
+processExport summary inst_maps (ExportDecl x decl)
+  = doDecl summary inst_maps x decl
+processExport summary inst_maps (ExportDoc doc)
+  = docBox (docToHtml doc)
+processExport summary inst_maps (ExportModule (Module mod))
   = declBox (toHtml "module" <+> ppHsModule mod)
 
+forSummary (ExportGroup _ _ _) = False
+forSummary (ExportDoc _) = False
+forSummary _ = True
+
 ppDocGroup lev doc
   | lev == 1  = tda [ theclass "section1" ] << doc
   | lev == 2  = tda [ theclass "section2" ] << doc
@@ -404,18 +415,16 @@ declWithDoc :: Bool -> Maybe Doc -> Html -> HtmlTable
 declWithDoc True  doc        html_decl = declBox html_decl
 declWithDoc False Nothing    html_decl = declBox html_decl
 declWithDoc False (Just doc) html_decl = 
-	tda [width "100%"] << 
-	    vanillaTable << 
-		(declBox html_decl </> docBox (docToHtml doc))
+		declBox html_decl </> docBox (docToHtml doc)
 
-doDecl :: Bool -> HsDecl -> HtmlTable
-doDecl summary decl = do_decl decl
+doDecl :: Bool -> InstMaps -> HsQName -> HsDecl -> HtmlTable
+doDecl summary inst_maps x decl = do_decl decl
   where
      do_decl (HsTypeSig _ [nm] ty doc) 
 	= ppFunSig summary nm ty doc
 
      do_decl (HsForeignImport _ _ _ _ n ty doc)
-	= declWithDoc summary doc (ppTypeSig summary n ty)
+	= ppFunSig summary n ty doc
 
      do_decl (HsTypeDecl _ nm args ty doc)
 	= declWithDoc summary doc (
@@ -423,15 +432,15 @@ doDecl summary decl = do_decl decl
 		 ++ map ppHsName args) <+> equals <+> ppHsType ty)
 
      do_decl (HsNewTypeDecl loc ctx nm args con drv doc)
-	= ppHsDataDecl summary True{-is newtype-}
+	= ppHsDataDecl summary inst_maps True{-is newtype-} x
 		(HsDataDecl loc ctx nm args [con] drv doc)
 	  -- print it as a single-constructor datatype
 
      do_decl decl@(HsDataDecl loc ctx nm args cons drv doc)
-	= ppHsDataDecl summary False{-not newtype-} decl
+	= ppHsDataDecl summary inst_maps False{-not newtype-} x decl
 
      do_decl decl@(HsClassDecl _ _ _ _ _)
-	= ppHsClassDecl summary decl
+	= ppHsClassDecl summary inst_maps x decl
 
      do_decl (HsDocGroup loc lev str)
 	= if summary then Html.emptyTable 
@@ -470,49 +479,56 @@ ppShortDataDecl summary is_newty
 
 -- First, the abstract case:
 
-ppHsDataDecl summary is_newty (HsDataDecl loc ctx nm args [] drv doc) = 
+ppHsDataDecl summary inst_maps is_newty x 
+	(HsDataDecl loc ctx nm args [] drv doc) = 
    declWithDoc summary doc (ppHsDataHeader summary is_newty nm args)
 
 -- The rest of the cases:
 
-ppHsDataDecl summary is_newty decl@(HsDataDecl loc ctx nm args cons drv doc)
-  | summary || (isNothing doc && no_constr_docs)
-	= declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
+ppHsDataDecl summary (_, ty_inst_map) is_newty 
+     x decl@(HsDataDecl loc ctx nm args cons drv doc)
+  | summary = declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
 
   | otherwise
-        = td << vanillaTable << (
-	    header </> 
+        = header </> 
 	    tda [theclass "body"] << vanillaTable << (
 		datadoc </> 
 		constr_hdr </>
-		(tda [theclass "body"] << table << constrs))
-	  )
+		(tda [theclass "body"] << constr_table << constrs) </>
+		instances_bit
+            )
   where
 	header = declBox (ppHsDataHeader False is_newty nm args)
 
-	table 
-	  | any isRecDecl cons  = spacedTable5
-	  | otherwise           = spacedTable1
+	constr_table
+	 	| any isRecDecl cons  = spacedTable5
+	  	| otherwise           = spacedTable1
 
-	datadoc 
-	  | isJust doc = ndocBox (docToHtml (fromJust doc))
-	  | otherwise  = Html.emptyTable
-
-	constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
+	datadoc | isJust doc = ndocBox (docToHtml (fromJust doc))
+	  	| otherwise  = Html.emptyTable
 
-	constrs
-	  | null cons = Html.emptyTable
-	  | otherwise = aboves (map ppSideBySideConstr cons)
+	constrs	| null cons = Html.emptyTable
+	  	| otherwise = aboves (map ppSideBySideConstr cons)
 
 	no_constr_docs = all constr_has_no_doc cons
 
-	constr_has_no_doc (HsConDecl _ nm _ _ _ doc) 
-	   = isNothing doc
-	constr_has_no_doc (HsRecDecl _ nm _ _ fields doc)
-	   = isNothing doc && all field_has_no_doc fields
+	instances = lookupFM ty_inst_map x
+
+	instances_bit
+	   = case instances of
+		Nothing -> Html.emptyTable
+		Just [] -> Html.emptyTable
+		Just is -> 
+		 inst_hdr </>
+		 tda [theclass "body"] << spacedTable1 << (
+			aboves (map (declBox.ppInstHead) is)
+		  )
+
+constr_has_no_doc (HsConDecl _ _ _ _ _ doc) = isNothing doc
+constr_has_no_doc (HsRecDecl _ _ _ _ fields doc)
+  = isNothing doc && all field_has_no_doc fields
 
- 	field_has_no_doc (HsFieldDecl nms _ doc)
-	   = isNothing doc
+field_has_no_doc (HsFieldDecl nms _ doc) = isNothing doc
 
 isRecDecl (HsRecDecl pos nm tvs ctxt fields maybe_doc) = True
 isRecDecl _ = False
@@ -523,7 +539,7 @@ ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) =
 	hsep (ppHsBinder summary nm : map ppHsBangType typeList)
 ppShortConstr summary (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
    ppHsConstrHdr tvs ctxt +++
-   ppHsBinder summary nm +++
+   ppHsBinder summary nm <+>
    braces (vanillaTable << aboves (map (ppShortField summary) fields))
 
 ppHsConstrHdr tvs ctxt
@@ -534,11 +550,11 @@ ppHsConstrHdr tvs ctxt
    (if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")
 
 ppSideBySideConstr (HsConDecl pos nm tvs ctxt typeList doc) =
-  narrowDeclBox (hsep ((ppHsConstrHdr tvs ctxt +++ 
+  declBox (hsep ((ppHsConstrHdr tvs ctxt +++ 
 		ppHsBinder False nm) : map ppHsBangType typeList)) <->
   maybeRDocBox doc
 ppSideBySideConstr (HsRecDecl pos nm tvs ctxt fields doc) =
-  narrowDeclBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <->
+  declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <->
   maybeRDocBox doc </>
   (tda [theclass "body"] << spacedTable1 <<
      aboves (map ppSideBySideField fields))
@@ -606,29 +622,32 @@ ppClassHdr ty fds =
 	fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
 			       hsep (map ppHsName vars2)
 
-ppShortClassDecl summary decl@(HsClassDecl loc ty fds decls doc) = 
+ppShortClassDecl summary inst_maps decl@(HsClassDecl loc ty fds decls doc) = 
   if null decls
     then declBox hdr
-    else td << (
-	  vanillaTable << (
-           declBox (hdr <+> keyword "where")
+    else declBox (hdr <+> keyword "where")
 	    </> 
-           tda [theclass "body"] << (
-	    vanillaTable << (
-	       aboves (map (doDecl summary) (filter keepDecl decls))
-           ))
-         ))
+           (tda [theclass "body"] << 
+	     vanillaTable << 
+	       aboves [ ppFunSig summary n ty doc 
+		      | HsTypeSig _ [n] ty doc <- decls
+		      ]
+          )
+         
    where
 	Just c = declMainBinder decl
 	hdr | not summary = linkTarget c +++ ppClassHdr ty fds
 	    | otherwise   = ppClassHdr ty fds
 
-ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc)
-  |  summary || (isNothing doc && all decl_has_no_doc kept_decls)
-	= ppShortClassDecl summary decl
+ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c 
+	decl@(HsClassDecl loc ty fds decls doc)
+  | summary = ppShortClassDecl summary inst_maps decl
 
   | otherwise
-        = td << vanillaTable << (header </> classdoc </> body)
+        = header </>
+		tda [theclass "body"] << vanillaTable << (
+		   classdoc </> methods_bit </> instances_bit
+		)
 
    where 
 	Just c = declMainBinder decl
@@ -639,24 +658,39 @@ ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc)
 					keyword "where")
 
 	classdoc
-	   | Just d <- doc = docBox (docToHtml d)
+	   | Just d <- doc = ndocBox (docToHtml d)
 	   | otherwise     = Html.emptyTable
 
-	meth_hdr = tda [ theclass "section4" ] << toHtml "Methods"
-
-	body
+	methods_bit
 	   | null decls = Html.emptyTable
 	   | otherwise  = 
-		td << table ! [width "100%", cellpadding 0, cellspacing 8] << (
-			meth_hdr </>
-	       		aboves (map (doDecl False) kept_decls)
-           	      )
+		meth_hdr </>
+		tda [theclass "body"] << spacedTable1 << (
+	       		aboves [ ppFunSig summary n ty doc 
+			       | HsTypeSig _ [n] ty doc <- decls
+			       ]
+			)
+
+	instances_bit
+	   = case instances of
+		Nothing -> Html.emptyTable
+		Just [] -> Html.emptyTable
+		Just is -> 
+		 inst_hdr </>
+		 tda [theclass "body"] << spacedTable1 << (
+			aboves (map (declBox.ppInstHead) is)
+		  )
+
+	instances = lookupFM cls_inst_map orig_c
 
 	kept_decls = filter keepDecl decls
-
         decl_has_no_doc decl = isNothing (declDoc decl)
 
--- -----------------------------------------------------------------------------
+ppInstHead	       :: InstHead -> Html
+ppInstHead ([],asst)   =  ppHsAsst asst
+ppInstHead (ctxt,asst) =  ppHsContext ctxt <+> toHtml "=>" <+> ppHsAsst asst
+
+-- ----------------------------------------------------------------------------
 -- Type signatures
 
 ppFunSig summary nm ty doc
@@ -664,7 +698,6 @@ ppFunSig summary nm ty doc
       declWithDoc summary doc (ppTypeSig summary nm ty)
 
   | otherwise   = 
-      td << vanillaTable << (
 	declBox (ppHsBinder False nm) </>
 	(tda [theclass "body"] << vanillaTable <<  (
 	   (if (isJust doc) 
@@ -672,7 +705,6 @@ ppFunSig summary nm ty doc
 		else Html.emptyTable)  </>
 	   do_args True ty
 	 ))
-     )
   where
 	no_arg_docs (HsForAllType _ _ ty) = no_arg_docs ty
 	no_arg_docs (HsTyFun (HsTyDoc _ _) _) = False
@@ -682,18 +714,19 @@ ppFunSig summary nm ty doc
 
 	do_args :: Bool -> HsType -> HtmlTable
 	do_args first (HsForAllType maybe_tvs ctxt ty)
-	  = narrowDeclBox (leader first <+> ppHsForAll maybe_tvs ctxt) </> 
+	  = (declBox (leader first <+> ppHsForAll maybe_tvs ctxt)
+		<-> rdocBox noHtml) </> 
 	    do_args False ty
 	do_args first (HsTyFun (HsTyDoc ty doc) r)
-	  = (narrowDeclBox (leader first <+> ppHsBType ty) <-> 
+	  = (declBox (leader first <+> ppHsBType ty) <-> 
 	     rdocBox (docToHtml doc)) </>
 	    do_args False r
 	do_args first (HsTyFun ty r)
-	  = (narrowDeclBox (leader first <+> ppHsBType ty) <->
+	  = (declBox (leader first <+> ppHsBType ty) <->
 	     rdocBox noHtml) </>
 	    do_args False r
 	do_args first (HsTyDoc ty doc)
-	  = (narrowDeclBox (leader first <+> ppHsBType ty) <-> 
+	  = (declBox (leader first <+> ppHsBType ty) <-> 
 	     rdocBox (docToHtml doc))
 	do_args first ty = declBox (leader first <+> ppHsBType ty) <->
 			   rdocBox (noHtml)
@@ -704,10 +737,12 @@ ppFunSig summary nm ty doc
 -- -----------------------------------------------------------------------------
 -- Types and contexts
 
-ppHsContext :: HsContext -> Html
-ppHsContext []      = empty
-ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> 
-					 hsep (map ppHsAType b)) context)
+ppHsAsst	    :: (HsQName,[HsType]) -> Html
+ppHsAsst (c,args)   =  ppHsQName c <+> hsep (map ppHsAType args)
+
+ppHsContext	    :: HsContext -> Html
+ppHsContext []      =  empty
+ppHsContext context =  parenList (map ppHsAsst context)
 
 ppHsForAll Nothing context = 
   hsep [ ppHsContext context, toHtml "=>" ]
@@ -721,9 +756,9 @@ ppHsType :: HsType -> Html
 ppHsType (HsForAllType maybe_tvs context htype) =
   ppHsForAll maybe_tvs context <+> ppHsType htype
 ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b]
-ppHsType (HsTyDoc ty doc) = ppHsBType ty
 ppHsType t = ppHsBType t
 
+ppHsBType (HsTyDoc ty doc) = ppHsBType ty
 ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
   = brackets $ ppHsType b
 ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b
@@ -837,6 +872,13 @@ punctuate p (d:ds) = go d ds
                      go d [] = [d]
                      go d (e:es) = (d +++ p) : go e es
 
+abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable
+abovesSep p []     = Html.emptyTable
+abovesSep p (d:ds) = go d ds
+                   where
+                     go d [] = d
+                     go d (e:es) = d </> p </> go e es
+
 parenList :: [Html] -> Html
 parenList = parens . hsep . punctuate comma
 
@@ -883,3 +925,10 @@ narrowTable  = table ! [theclass "narrow",  cellspacing 0, cellpadding 0]
 spacedTable1 = table ! [theclass "vanilla",  cellspacing 1, cellpadding 0]
 spacedTable5 = table ! [theclass "vanilla",  cellspacing 5, cellpadding 0]
 
+constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
+meth_hdr   = tda [ theclass "section4" ] << toHtml "Methods"
+inst_hdr   = tda [ theclass "section4" ] << toHtml "Instances"
+
+s8, s15 :: HtmlTable
+s8  = tda [ theclass "s8" ]  << noHtml
+s15 = tda [ theclass "s15" ] << noHtml
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 02085e2e..d1bc5efa 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -105,6 +105,10 @@ renameDecl decl
 	    ty <- renameType ty
 	    doc <- renameMaybeDoc doc
 	    return (HsForeignImport loc cc safe ent n ty doc)
+	HsInstDecl loc ctxt asst decls -> do
+	    ctxt <- mapM renamePred ctxt
+	    asst <- renamePred asst
+	    return (HsInstDecl loc ctxt asst decls)
 	_ -> 
 	    return decl
 
@@ -217,9 +221,9 @@ renameExportItems items = mapM rn items
  	rn (ExportGroup lev id doc) 
 	   = do doc <- renameDoc doc
 	        return (ExportGroup lev id doc)
-	rn (ExportDecl decl)
+	rn (ExportDecl x decl) -- x is an original name, don't rename it
 	   = do decl <- renameDecl decl
-		return (ExportDecl decl)
+		return (ExportDecl x decl)
 	rn (ExportDoc doc)
 	   = do doc <- renameDoc doc
 		return (ExportDoc doc)
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 9c957dd5..5554bddc 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -7,8 +7,9 @@
 module HaddockTypes (
   -- * Module interfaces
   NameEnv, Interface(..), ExportItem(..), ModuleMap,
-  DocOption(..),
 
+  -- * Misc types
+  DocOption(..), InstHead,
  ) where
 
 import FiniteMap
@@ -39,6 +40,9 @@ data Interface
 		-- restricted to only those bits exported.
 		-- the map key is the "main name" of the decl.
 
+	iface_insts :: [HsDecl],
+		-- ^ instances from this module
+
 	iface_info :: Maybe ModuleInfo,
 		-- ^ information from the module header
 
@@ -52,10 +56,9 @@ data Interface
 data DocOption = OptHide | OptPrune | OptIgnoreExports 
   deriving (Eq)
 
-type DocString = String
-
 data ExportItem 
   = ExportDecl
+	HsQName		-- the original name
 	HsDecl		-- a declaration (with doc annotations)
 
   | ExportGroup		-- a section heading
@@ -71,3 +74,4 @@ data ExportItem
 
 type ModuleMap = FiniteMap Module Interface
 
+type InstHead = (HsContext,HsAsst)
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 58033edc..27595f33 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -9,7 +9,7 @@ module HaddockUtil (
 
   -- * Misc utilities
   nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
-  restrictTo, declDoc, parseModuleHeader,
+  restrictTo, declDoc, parseModuleHeader, freeTyCons,
 
   -- * Filename utilities
   basename, dirname, splitFilename3, 
@@ -76,6 +76,16 @@ splitTyConApp t = split t []
 	split (HsTyCon t)   ts = (t,ts)
 	split _ _ = error "splitTyConApp"
 
+freeTyCons :: HsType -> [HsQName]
+freeTyCons ty = go ty []
+  where go (HsForAllType _ _ t) r = go t r
+	go (HsTyApp t u) r = go t (go u r)
+	go (HsTyCon c) r = c : r
+	go (HsTyFun f a) r = go f (go a r)
+	go (HsTyTuple b ts) r = foldr go r ts
+	go (HsTyVar v) r = r
+	go (HsTyDoc t _) r = go t r
+
 -- ---------------------------------------------------------------------------
 -- Making abstract declarations
 
diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs
index 3d795837..148fff07 100644
--- a/src/HsParseUtils.lhs
+++ b/src/HsParseUtils.lhs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: HsParseUtils.lhs,v 1.2 2002/04/10 16:10:26 simonmar Exp $
+-- $Id: HsParseUtils.lhs,v 1.3 2002/05/27 09:03:52 simonmar Exp $
 --
 -- (c) The GHC Team 1997-2000
 --
@@ -17,6 +17,7 @@ module HsParseUtils (
 	, checkPrec 		-- String -> P String
 	, checkContext		-- HsType -> P HsContext
 	, checkAssertion	-- HsType -> P HsAsst
+	, checkInstHeader	-- HsType -> P (HsContext, HsAsst)
 	, checkDataHeader	-- HsType -> P (HsContext,HsName,[HsName])
 	, checkSimple		-- HsType -> [HsName] -> P ((HsName,[HsName]))
 	, checkPattern		-- HsExp -> P HsPat
@@ -73,6 +74,14 @@ checkAssertion = checkAssertion' []
 		checkAssertion' _ _ = parseError "Illegal class assertion"
 
 
+checkInstHeader :: HsType -> P (HsContext, HsAsst)
+checkInstHeader (HsForAllType Nothing ctxt ty) =
+  checkAssertion ty `thenP` \asst ->
+  returnP (ctxt, asst)
+checkInstHeader ty =
+  checkAssertion ty `thenP` \asst ->
+  returnP ([], asst)
+
 checkDataHeader :: HsType -> P (HsContext,HsName,[HsName])
 checkDataHeader (HsForAllType Nothing cs t) =
    checkSimple t []	     `thenP` \(c,ts) ->
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 9b47f117..4c12adc7 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.11 2002/05/15 13:03:02 simonmar Exp $
+$Id: HsParser.ly,v 1.12 2002/05/27 09:03:52 simonmar Exp $
 
 (c) Simon Marlow, Sven Panne 1997-2002
 
@@ -306,7 +306,8 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
 >	| 'class' srcloc ctype fds optcbody
 >		{ HsClassDecl $2 $3 $4 $5 Nothing}
 >	| 'instance' srcloc ctype optvaldefs
->		{ HsInstDecl $2 $3 $4 }
+>		{% checkInstHeader $3 `thenP` \(ctxt,asst) ->
+>		   returnP (HsInstDecl $2 ctxt asst $4) }
 >	| 'default' srcloc '(' typelist ')'
 >		{ HsDefaultDecl $2 $4 }
 >	| 'foreign' fdecl { $2 }
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index ecd2b0ce..8f3ef31d 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.9 2002/05/15 13:03:02 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.10 2002/05/27 09:03:52 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -144,7 +144,7 @@ data HsDecl
  
   | HsClassDecl SrcLoc HsType [HsFunDep] [HsDecl] (Maybe Doc)
  
-  | HsInstDecl SrcLoc HsType [HsDecl]
+  | HsInstDecl SrcLoc HsContext HsAsst [HsDecl]
  
   | HsDefaultDecl SrcLoc [HsType]
  
diff --git a/src/Main.hs b/src/Main.hs
index 96425a46..288d1632 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -107,28 +107,29 @@ run flags files = do
   writeIORef saved_flags flags
   parsed_mods <- sequence (map parse_file files)
 
-  sorted_mods <- sortModules parsed_mods
+  sorted_mod_files <- sortModules (zip parsed_mods files)
 	-- emits an error message if there are recursive modules
 
   -- process the modules in sorted order, building up a mapping from
   -- modules to interfaces.
   let 
-	loop ifaces [] _ = return ifaces
-	loop ifaces (hsmod:hsmods) (file:files) = do 
+	loop ifaces [] = return ifaces
+	loop ifaces ((hsmod,file):mods)  = do 
 	   let ((mod,iface),msgs) = runWriter (mkInterface ifaces file hsmod)
 	       new_ifaces = addToFM ifaces mod iface
 	   mapM (hPutStrLn stderr) msgs
-	   loop new_ifaces hsmods files    
+	   loop new_ifaces mods
 
-  module_map <- loop emptyFM sorted_mods files
+  module_map <- loop emptyFM sorted_mod_files
   let mod_ifaces = fmToList module_map
 
 --  when (Flag_DocBook `elem` flags) $
 --    putStr (ppDocBook odir mod_ifaces)
 
-  when (Flag_Html `elem` flags) $
-    ppHtml title source_url mod_ifaces odir css_file libdir
+  let inst_maps = collectInstances mod_ifaces
 
+  when (Flag_Html `elem` flags) $
+    ppHtml title source_url mod_ifaces odir css_file libdir inst_maps
 
 parse_file file = do
   bracket 
@@ -201,9 +202,11 @@ mkInterface mod_map filename
      decl_map :: FiniteMap HsName HsDecl
      decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ]
 
+     instances = [ d | d@HsInstDecl{} <- final_decls ]
+
   -- make the "export items", which will be converted into docs later
-  orig_export_list <- mkExportItems mod_map mod orig_env
-   			 decl_map final_decls options orig_exports
+  orig_export_list <- mkExportItems mod_map mod decl_map
+			 		final_decls options orig_exports
 
   let
      -- prune the export list to just those declarations that have
@@ -236,6 +239,7 @@ mkInterface mod_map filename
 		   iface_env          = name_env,
 		   iface_exports      = renamed_export_list,
 		   iface_orig_exports = pruned_export_list,
+		   iface_insts	      = instances,
 		   iface_decls        = decl_map,
 		   iface_info	      = maybe_info,
 		   iface_doc          = maybe_doc,
@@ -245,17 +249,19 @@ mkInterface mod_map filename
 
 -- -----------------------------------------------------------------------------
 -- Build the list of items that will become the documentation, from the
--- export list.  At the same time we rename *original* names in the declarations
--- to *imported* names.
+-- export list.  At this point, the list of ExportItems is in terms of
+-- original names.
 
-mkExportItems :: ModuleMap -> Module
-	-> FiniteMap HsQName HsQName	-- maps orig to imported names
+mkExportItems
+	:: ModuleMap
+	-> Module			-- this module
 	-> FiniteMap HsName HsDecl	-- maps local names to declarations
 	-> [HsDecl]			-- decls in the current module
 	-> [DocOption]
 	-> Maybe [HsExportSpec]
 	-> ErrMsgM [ExportItem]
-mkExportItems mod_map mod env decl_map decls options maybe_exps
+
+mkExportItems mod_map mod decl_map decls options maybe_exps
   | Nothing <- maybe_exps	    = everything_local_exported
   | OptIgnoreExports `elem` options = everything_local_exported
   | Just specs <- maybe_exps = do 
@@ -264,26 +270,21 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
   where
 
     everything_local_exported =
-	fullContentsOfThisModule mod decls env -- everything exported
+	return (fullContentsOfThisModule mod decl_map) -- everything exported
 
     lookupExport (HsEVar x) 
 	| Just decl <- findDecl x
-	= let decl' | HsTypeSig loc ns ty doc <- decl
-			= HsTypeSig loc [nameOfQName x] ty doc
-		    | otherwise
-		  	= decl
-	  in
-	  return [ ExportDecl decl' ]
+	= return [ ExportDecl x decl ]
 	  -- ToDo: cope with record selectors here
     lookupExport (HsEAbs t)
 	| Just decl <- findDecl t
-	= return [ ExportDecl (restrictTo [] decl) ]
+	= return [ ExportDecl t (restrictTo [] decl) ]
     lookupExport (HsEThingAll t)
 	| Just decl <- findDecl t
-	= return [ ExportDecl decl ]
+	= return [ ExportDecl t decl ]
     lookupExport (HsEThingWith t cs)
 	| Just decl <- findDecl t
-	= return [ ExportDecl (restrictTo (map nameOfQName cs) decl) ]
+	= return [ ExportDecl t (restrictTo (map nameOfQName cs) decl) ]
     lookupExport (HsEModuleContents m) = fullContentsOf m
     lookupExport (HsEGroup lev doc)
 	= return [ ExportGroup lev "" doc ]
@@ -298,7 +299,7 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
     lookupExport _ = return [] -- didn't find it?
 
     fullContentsOf m
-	| m == mod  = fullContentsOfThisModule mod decls env
+	| m == mod  = return (fullContentsOfThisModule mod decl_map)
 	| otherwise = 
 	   case lookupFM mod_map m of
 	     Just iface
@@ -318,12 +319,10 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
 		Just iface -> lookupFM (iface_decls iface) n
 		Nothing -> Nothing
 
-fullContentsOfThisModule mod decls env = 
-  mapM mkExportItem (filter keepDecl decls)
-  where mkExportItem (HsDocGroup loc lev doc) =
-	   return (ExportGroup lev "" doc)
-	mkExportItem decl = 
-	   return (ExportDecl decl)
+fullContentsOfThisModule mod decl_map = 
+  map mkExportItem (filter (keepDecl.snd) (fmToList decl_map))
+  where mkExportItem (x,HsDocGroup loc lev doc) = ExportGroup lev "" doc
+	mkExportItem (x,decl) = ExportDecl (Qual mod x) decl
 
 keepDecl HsTypeSig{}     = True
 keepDecl HsTypeDecl{}    = True
@@ -338,7 +337,7 @@ keepDecl _ = False
 
 pruneExportItems :: [ExportItem] -> [ExportItem]
 pruneExportItems items = filter has_doc items
-  where has_doc (ExportDecl d) = isJust (declDoc d)
+  where has_doc (ExportDecl x d) = isJust (declDoc d)
 	has_doc _ = True
 
 -- -----------------------------------------------------------------------------
@@ -510,22 +509,48 @@ parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing
 -- -----------------------------------------------------------------------------
 -- Topologically sort the modules
 
-sortModules :: [HsModule] -> IO [HsModule]
-sortModules hsmodules = mapM for_each_scc sccs
+sortModules :: [(HsModule,FilePath)] -> IO [(HsModule,FilePath)]
+sortModules mods = mapM for_each_scc sccs
   where
 	sccs = stronglyConnComp edges
 
-	edges :: [(HsModule, Module, [Module])]
-	edges = [ (hsmod, mod, [ imp | HsImportDecl _ imp _ _ _ <- impdecls ]) 
-		| hsmod@(HsModule mod _ impdecls _ _ _ _) <- hsmodules
+	edges :: [((HsModule,FilePath), Module, [Module])]
+	edges = [ ((hsmod,file), mod, get_imps impdecls)
+		| (hsmod@(HsModule mod _ impdecls _ _ _ _), file) <- mods
 		]
 
+        get_imps impdecls  = [ imp | HsImportDecl _ imp _ _ _ <- impdecls  ]
+
+	get_mods hsmodules = [ mod | HsModule mod _ _ _ _ _ _ <- hsmodules ]
+
 	for_each_scc (AcyclicSCC hsmodule) = return hsmodule
 	for_each_scc (CyclicSCC  hsmodules) = 
-	   dieMsg ("modules are recursive: " ++ 
-		   unwords (map show [ mod | HsModule mod _ _ _ _ _ _
-						<- hsmodules ]))
+	   dieMsg ("modules are recursive: " ++
+		   unwords (map show (get_mods (map fst hsmodules))))
+
+-- -----------------------------------------------------------------------------
+-- Collect instances
 
+collectInstances
+   :: [(Module,Interface)] 
+   -> (FiniteMap HsQName [InstHead],	-- maps class names to instances
+       FiniteMap HsQName [InstHead])	-- maps type names to instances
+
+collectInstances mod_ifaces
+  = (addListToFM_C (++) emptyFM class_inst_pairs, 
+     addListToFM_C (++) emptyFM ty_inst_pairs)
+  where
+    all_instances = concat (map (iface_insts.snd) mod_ifaces)
+
+    class_inst_pairs = [ (cls, [(ctxt,(cls,args))])
+		       | HsInstDecl _ ctxt (cls,args) _ <- all_instances ]
+			
+    ty_inst_pairs = [ (nm, [(ctxt,(cls,args))])
+		    | HsInstDecl _ ctxt (cls,args) _ <- all_instances,
+		      arg <- args,
+		      nm <- freeTyCons arg
+		    ]
+ 
 -- -----------------------------------------------------------------------------
 -- A monad which collects error messages