[haddock @ 2003-07-30 16:05:40 by simonmar]

Rename instances based on the import_env for the module in which they
are to be displayed.  This should give, in many cases, better links
for the types and classes mentioned in the instance head.

This involves keeping around the import_env in the iface until the
end, because instances are not collected up until all the modules have
been processed.  Fortunately it doesn't seem to affect performance
much.

Instance heads are now attached to ExportDecls, rather than the HTML
backend passing around a separate mapping for instances.  This is a
cleanup.

4 files changed, 97 insertions, 79 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 7275e948..062b29c0 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -41,22 +41,17 @@ 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
 	-> Maybe Doc			-- prologue text, maybe
 	-> Bool				-- do MS Help stuff
 	-> IO ()
 
-ppHtml doctitle source_url ifaces odir maybe_css libdir inst_maps prologue do_ms_help =  do
+ppHtml doctitle source_url ifaces odir maybe_css libdir prologue do_ms_help =  do
   let 
 	css_file = case maybe_css of
 			Nothing -> libdir ++ pathSeparator:cssFile
@@ -82,7 +77,7 @@ ppHtml doctitle source_url ifaces odir maybe_css libdir inst_maps prologue do_ms
     ppHHContents odir (map fst visible_ifaces)
     ppHHIndex odir visible_ifaces
 
-  mapM_ (ppHtmlModule odir doctitle source_url inst_maps) visible_ifaces
+  mapM_ (ppHtmlModule odir doctitle source_url) visible_ifaces
 
 contentsHtmlFile, indexHtmlFile :: String
 contentsHtmlFile = "index.html"
@@ -316,27 +311,27 @@ idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
 -- ---------------------------------------------------------------------------
 -- Generate the HTML page for a module
 
-ppHtmlModule :: FilePath -> String -> Maybe String -> InstMaps
-	-> (Module,Interface) -> IO ()
-ppHtmlModule odir doctitle source_url inst_maps (Module mdl,iface) = do
+ppHtmlModule :: FilePath -> String -> Maybe String -> 
+	(Module,Interface) -> IO ()
+ppHtmlModule odir doctitle source_url (Module mdl,iface) = do
   let html = 
 	header (thetitle (toHtml mdl) +++
 		thelink ! [href cssFile,
 		  rel "stylesheet", thetype "text/css"]) +++
         body << vanillaTable << (
 	    pageHeader mdl iface doctitle source_url </> s15 </>
-	    ifaceToHtml mdl iface inst_maps </> s15 </>
+	    ifaceToHtml mdl iface </> s15 </>
 	    footer
          )
   writeFile (moduleHtmlFile odir mdl) (renderHtml html)
 
-ifaceToHtml :: String -> Interface -> InstMaps -> HtmlTable
-ifaceToHtml _ iface inst_maps
+ifaceToHtml :: String -> Interface -> HtmlTable
+ifaceToHtml _ iface 
   = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy)
   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
 
@@ -358,7 +353,7 @@ ifaceToHtml _ iface inst_maps
 	  = (tda [theclass "section1"] << toHtml "Synopsis") </>
 	    s15 </>
             (tda [theclass "body"] << vanillaTable <<
-  	        abovesSep s8 (map (processExport True inst_maps) 
+  	        abovesSep s8 (map (processExport True)
 			(filter forSummary exports))
 	    )
 
@@ -372,7 +367,7 @@ ifaceToHtml _ iface inst_maps
 		   _ -> tda [ theclass "section1" ] << toHtml "Documentation"
 	     | otherwise  = Html.emptyTable
 
-	bdy = map (processExport False inst_maps) exports
+	bdy = map (processExport False) exports
 
 ppModuleContents :: [ExportItem] -> HtmlTable
 ppModuleContents exports
@@ -408,14 +403,14 @@ numberSectionHeadings exports = go 1 exports
 	go n (other:es)
 	  = other : go n es
 
-processExport :: Bool -> InstMaps -> ExportItem -> HtmlTable
-processExport _ _ (ExportGroup lev id0 doc)
+processExport :: Bool -> ExportItem -> HtmlTable
+processExport _ (ExportGroup lev id0 doc)
   = ppDocGroup lev (namedAnchor id0 << docToHtml doc)
-processExport summary inst_maps (ExportDecl x decl)
-  = doDecl summary inst_maps x decl
-processExport _       _ (ExportDoc doc)
+processExport summary (ExportDecl x decl insts)
+  = doDecl summary x decl insts
+processExport _ (ExportDoc doc)
   = docBox (docToHtml doc)
-processExport _       _ (ExportModule (Module mdl))
+processExport _ (ExportModule (Module mdl))
   = declBox (toHtml "module" <+> ppHsModule mdl)
 
 forSummary :: ExportItem -> Bool
@@ -439,8 +434,8 @@ declWithDoc False Nothing    html_decl = declBox html_decl
 declWithDoc False (Just doc) html_decl = 
 		declBox html_decl </> docBox (docToHtml doc)
 
-doDecl :: Bool -> InstMaps -> HsQName -> HsDecl -> HtmlTable
-doDecl summary inst_maps x d = do_decl d
+doDecl :: Bool -> HsQName -> HsDecl -> [InstHead] -> HtmlTable
+doDecl summary x d instances = do_decl d
   where
      do_decl (HsTypeSig _ [nm] ty doc) 
 	= ppFunSig summary nm ty doc
@@ -454,15 +449,15 @@ doDecl summary inst_maps x d = do_decl d
 		 ++ map ppHsName args) <+> equals <+> ppHsType ty)
 
      do_decl (HsNewTypeDecl loc ctx nm args con drv doc)
-	= ppHsDataDecl summary inst_maps True{-is newtype-} x
+	= ppHsDataDecl summary instances True{-is newtype-} x
 		(HsDataDecl loc ctx nm args [con] drv doc)
 	  -- print it as a single-constructor datatype
 
      do_decl d0@(HsDataDecl{})
-	= ppHsDataDecl summary inst_maps False{-not newtype-} x d0
+	= ppHsDataDecl summary instances False{-not newtype-} x d0
 
      do_decl d0@(HsClassDecl{})
-	= ppHsClassDecl summary inst_maps x d0
+	= ppHsClassDecl summary instances x d0
 
      do_decl (HsDocGroup _ lev str)
 	= if summary then Html.emptyTable 
@@ -498,9 +493,8 @@ ppShortDataDecl _ _ d =
     error $ "HaddockHtml.ppShortDataDecl: unexpected decl " ++ show d
 
 -- The rest of the cases:
-ppHsDataDecl :: Ord key => Bool	-> (a, FiniteMap key [InstHead])
-	     -> Bool -> key -> HsDecl -> HtmlTable
-ppHsDataDecl summary (_, ty_inst_map) is_newty 
+ppHsDataDecl :: Ord key => Bool	-> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable
+ppHsDataDecl summary instances is_newty 
      x decl@(HsDataDecl _ _ nm args cons _ doc)
   | summary = declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
 
@@ -529,16 +523,10 @@ ppHsDataDecl summary (_, ty_inst_map) is_newty
 			 aboves (map ppSideBySideConstr cons)
 			)
 
-	instances = lookupFM ty_inst_map x
-
 	instances_bit
-	   = case instances of
-		Nothing -> Html.emptyTable
-		Just [] -> Html.emptyTable
-		Just is -> 
-		 inst_hdr </>
+	   =  inst_hdr </>
 		 tda [theclass "body"] << spacedTable1 << (
-			aboves (map (declBox.ppInstHead) is)
+			aboves (map (declBox.ppInstHead) instances)
 		  )
 ppHsDataDecl _ _ _ _ d =
     error $ "HaddockHtml.ppHsDataDecl: unexpected decl " ++ show d
@@ -657,9 +645,8 @@ ppFds fds =
 	fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
 			       hsep (map ppHsName vars2)
 
-ppShortClassDecl :: Bool -> a -> HsDecl -> HtmlTable
-ppShortClassDecl summary _
-	(HsClassDecl _ ctxt nm tvs fds decls _) = 
+ppShortClassDecl :: Bool -> HsDecl -> HtmlTable
+ppShortClassDecl summary (HsClassDecl _ ctxt nm tvs fds decls _) = 
   if null decls
     then declBox hdr
     else declBox (hdr <+> keyword "where")
@@ -673,14 +660,13 @@ ppShortClassDecl summary _
          
    where
 	hdr = ppClassHdr summary ctxt nm tvs fds
-ppShortClassDecl _ _ d =
+ppShortClassDecl _ d =
     error $ "HaddockHtml.ppShortClassDecl: unexpected decl: " ++ show d
 
-ppHsClassDecl :: Ord key => Bool -> (FiniteMap key [InstHead], t_a4nrR)
-	      -> key -> HsDecl -> HtmlTable
-ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c 
+ppHsClassDecl :: Ord key => Bool -> [InstHead] -> key -> HsDecl -> HtmlTable
+ppHsClassDecl summary instances orig_c
 	decl@(HsClassDecl _ ctxt nm tvs fds decls doc)
-  | summary = ppShortClassDecl summary inst_maps decl
+  | summary = ppShortClassDecl summary decl
 
   | otherwise
         = classheader </>
@@ -710,16 +696,11 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c
 			)
 
 	instances_bit
-	   = case instances of
-		Nothing -> Html.emptyTable
-		Just [] -> Html.emptyTable
-		Just is -> 
-		 s8 </> inst_hdr </>
+	   =  s8 </> inst_hdr </>
 		 tda [theclass "body"] << spacedTable1 << (
-			aboves (map (declBox.ppInstHead) is)
+			aboves (map (declBox.ppInstHead) instances)
 		  )
 
-	instances = lookupFM cls_inst_map orig_c
 ppHsClassDecl _ _ _ d =
     error $ "HaddockHtml.ppHsClassDecl: unexpected decl: " ++ show d
 
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 1a2ab04e..994bf500 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -9,7 +9,7 @@ module HaddockRename (
 
 	renameExportList, 
 	renameDecl,
-	renameExportItems,
+	renameExportItems, renameInstHead,
 	renameDoc, renameMaybeDoc,
   ) where
 
@@ -94,19 +94,19 @@ renameDecl decl
 	    doc <- renameMaybeDoc doc0
 	    return (HsTypeDecl loc t args ty doc)
 	HsDataDecl loc ctx0 t args cons0 drv0 doc0 -> do
-	    ctx <- mapM renamePred ctx0
+	    ctx <- renameContext ctx0
 	    cons <- mapM renameConDecl cons0
 	    drv <- mapM (lookupRn id) drv0
 	    doc <- renameMaybeDoc doc0
 	    return (HsDataDecl loc ctx t args cons drv doc)
         HsNewTypeDecl loc ctx0 t args con0 drv0 doc0 -> do
-	    ctx <- mapM renamePred ctx0
+	    ctx <- renameContext ctx0
 	    con <- renameConDecl con0
 	    drv <- mapM (lookupRn id) drv0
 	    doc <- renameMaybeDoc doc0
 	    return (HsNewTypeDecl loc ctx t args con drv doc)
         HsClassDecl loc ctxt0 nm tvs fds decls0 doc0 -> do
-	    ctxt <- mapM renamePred ctxt0
+	    ctxt <- renameContext ctxt0
 	    decls <- mapM renameDecl decls0
 	    doc <- renameMaybeDoc doc0
 	    return (HsClassDecl loc ctxt nm tvs fds decls doc)
@@ -119,7 +119,7 @@ renameDecl decl
 	    doc <- renameMaybeDoc doc0
 	    return (HsForeignImport loc cc safe ent n ty doc)
 	HsInstDecl loc ctxt0 asst0 decls -> do
-	    ctxt <- mapM renamePred ctxt0
+	    ctxt <- renameContext ctxt0
 	    asst <- renamePred asst0
 	    return (HsInstDecl loc ctxt asst decls)
 	HsDocCommentNamed loc name doc0 -> do
@@ -148,6 +148,9 @@ renameBangTy :: HsBangType -> RnM HsBangType
 renameBangTy (HsBangedTy ty)   = HsBangedTy   `liftM` renameType ty
 renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty
 
+renameContext :: HsContext -> RnM HsContext
+renameContext = mapM renamePred
+
 renamePred :: (HsQName,[HsType]) -> RnM (HsQName,[HsType])
 renamePred (c,tys0) = do
   tys <- mapM renameType tys0
@@ -178,6 +181,12 @@ renameType (HsTyDoc ty0 doc0) = do
   doc <- renameDoc doc0
   return (HsTyDoc ty doc)
 
+renameInstHead :: InstHead -> RnM InstHead
+renameInstHead (ctx,asst) = do
+  ctx <- renameContext ctx
+  asst <- renamePred asst
+  return (ctx,asst)
+
 -- -----------------------------------------------------------------------------
 -- Renaming documentation
 
@@ -240,9 +249,10 @@ renameExportItems items = mapM rn items
  	rn (ExportGroup lev id0 doc0) 
 	   = do doc <- renameDoc doc0
 	        return (ExportGroup lev id0 doc)
-	rn (ExportDecl x decl0) -- x is an original name, don't rename it
+	rn (ExportDecl x decl0 insts) -- x is an original name, don't rename it
 	   = do decl <- renameDecl decl0
-		return (ExportDecl x decl)
+		mapM renameInstHead insts
+		return (ExportDecl x decl insts)
 	rn (ExportDoc doc0)
 	   = do doc <- renameDoc doc0
 		return (ExportDoc doc)
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index cc6585bc..74916099 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -33,11 +33,15 @@ data Interface
 	iface_env :: NameEnv,
 		-- ^ environment mapping names to *original* names
 
+	iface_import_env :: FiniteMap HsQName HsQName,
+
 	iface_reexported :: NameEnv,
-		-- ^ For names exported by this module, but not actually documented
-		-- in this module's documentation (perhaps because they are reexported via
-		-- 'module M' in the export list), this mapping gives the location of
-		-- documentation for the name in another module.
+		-- ^ For names exported by this module, but not
+		-- actually documented in this module's documentation
+		-- (perhaps because they are reexported via 'module M'
+		-- in the export list), this mapping gives the
+		-- location of documentation for the name in another
+		-- module.
 
 	iface_sub :: FiniteMap HsName [HsName],
 		-- ^ maps names to "subordinate" names 
@@ -75,6 +79,7 @@ data ExportItem
   = ExportDecl
 	HsQName		-- the original name
 	HsDecl		-- a declaration (with doc annotations)
+	[InstHead]	-- instances relevant to this declaration
 
   | ExportGroup		-- a section heading
 	Int		-- section level (1, 2, 3, ... )
diff --git a/src/Main.hs b/src/Main.hs
index c328bad0..d0a1721e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -180,14 +180,14 @@ run flags files = do
   module_map <- loop (listToFM read_ifaces) sorted_mod_files
   let mod_ifaces = fmToList module_map
 
-      these_mod_ifaces = [ (mdl, iface) 
-			 | (mdl, iface) <- mod_ifaces,
-			   mdl `notElem` external_mods ]
+      these_mod_ifaces0 = [ (mdl, iface) 
+			  | (mdl, iface) <- mod_ifaces,
+			    mdl `notElem` external_mods ]
 
 --  when (Flag_DocBook `elem` flags) $
 --    putStr (ppDocBook odir mod_ifaces)
 
-  let inst_maps = collectInstances these_mod_ifaces
+  let these_mod_ifaces = attachInstances these_mod_ifaces0
 
   when (Flag_Debug `elem` flags) $ do
     mapM_ putStrLn (map show [ (mdl, fmToList (iface_env i), 
@@ -196,7 +196,7 @@ run flags files = do
 
   when (Flag_Html `elem` flags) $
     ppHtml title source_url these_mod_ifaces odir css_file 
-	libdir inst_maps prologue (Flag_MSHtmlHelp `elem` flags)
+	libdir prologue (Flag_MSHtmlHelp `elem` flags)
 
   -- dump an interface if requested
   case dump_iface of
@@ -226,6 +226,7 @@ readIface filename = do
 	  (mdl, Interface { 
 		   iface_filename     = "",
 		   iface_env          = listToFM env,
+		   iface_import_env   = emptyFM,
 		   iface_sub	      = listToFM sub,
 		   iface_reexported   = emptyFM,
 		   iface_exports      = [],
@@ -395,7 +396,8 @@ mkInterface no_implicit_prelude mod_map filename
   return (mdl, Interface { 
 		   iface_filename     = filename,
 		   iface_env          = name_env,
-		   iface_reexported    = reexports,
+		   iface_import_env   = import_env,
+		   iface_reexported   = reexports,
 		   iface_exports      = renamed_export_list,
 		   iface_sub	      = sub_map,
 		   iface_orig_exports = pruned_export_list,
@@ -525,7 +527,7 @@ mkExportItems mod_map this_mod orig_env decl_map sub_map decls
     declWith (UnQual _)     _ = return []
     declWith t@(Qual mdl x) mb_subs
 	| Just decl <- findDecl t
-	= return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) ]
+	= return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ]
 	| otherwise
 	= return []
 	where 
@@ -567,7 +569,7 @@ fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem]
 fullContentsOfThisModule mdl decls = 
   map mkExportItem (filter keepDecl decls)
   where mkExportItem (HsDocGroup _ lev doc) = ExportGroup lev "" doc
-	mkExportItem decl = ExportDecl (Qual mdl x) decl
+	mkExportItem decl = ExportDecl (Qual mdl x) decl []
 	     where Just x = declMainBinder decl
 
 keepDecl :: HsDecl -> Bool
@@ -636,7 +638,7 @@ extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest)
 
 pruneExportItems :: [ExportItem] -> [ExportItem]
 pruneExportItems items = filter has_doc items
-  where has_doc (ExportDecl _ d) = isJust (declDoc d)
+  where has_doc (ExportDecl _ d _) = isJust (declDoc d)
 	has_doc _ = True
 
 -- -----------------------------------------------------------------------------
@@ -954,16 +956,36 @@ sortModules mdls = mapM for_each_scc sccs
 		   unwords (map show (get_mods (map fst hsmodules))))
 
 -- -----------------------------------------------------------------------------
--- Collect instances
+-- Collect instances and attach them to declarations
+
+attachInstances :: [(Module,Interface)] -> [(Module,Interface)]
+attachInstances mod_ifaces
+  = map attach mod_ifaces
+  where
+  inst_map = collectInstances mod_ifaces
+
+  attach (mod,iface) = (mod, iface{ iface_exports = new_exports })
+   where
+	new_exports = map attach_export (iface_exports iface)
+
+	rename_insts :: [InstHead] -> [InstHead]
+	rename_insts insts = fst (runRnFM (iface_import_env iface)
+				    (mapM renameInstHead insts))
+
+	attach_export (ExportDecl nm decl _) =
+	    ExportDecl nm decl (case lookupFM inst_map nm of
+				  Nothing -> []
+				  Just instheads -> rename_insts instheads)
+	attach_export other_export =
+	    other_export
 
 collectInstances
-   :: [(Module,Interface)] 
-   -> (FiniteMap HsQName [InstHead],	-- maps class names to instances
-       FiniteMap HsQName [InstHead])	-- maps type names to instances
+   :: [(Module,Interface)]
+   -> FiniteMap HsQName [InstHead]  -- maps class/type names to instances
 
 collectInstances mod_ifaces
-  = (addListToFM_C (++) emptyFM class_inst_pairs, 
-     addListToFM_C (++) emptyFM ty_inst_pairs)
+  = addListToFM_C (++) emptyFM class_inst_pairs `plusFM` 
+    addListToFM_C (++) emptyFM ty_inst_pairs
   where
     all_instances = concat (map (iface_insts.snd) mod_ifaces)