diff options
author | simonmar <unknown> | 2003-07-30 16:05:41 +0000 |
---|---|---|
committer | simonmar <unknown> | 2003-07-30 16:05:41 +0000 |
commit | 17c3137f80b18c46755dabbdaa9588114662afee (patch) | |
tree | 09d96acd1e380810c2eb89521922573a56605dab | |
parent | afcd30fcd5ac4d76ef805a636992978b5efc2ad7 (diff) |
[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.
-rw-r--r-- | src/HaddockHtml.hs | 87 | ||||
-rw-r--r-- | src/HaddockRename.hs | 24 | ||||
-rw-r--r-- | src/HaddockTypes.hs | 13 | ||||
-rw-r--r-- | src/Main.hs | 52 |
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) |