aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsimonmar <unknown>2003-07-30 16:05:41 +0000
committersimonmar <unknown>2003-07-30 16:05:41 +0000
commit17c3137f80b18c46755dabbdaa9588114662afee (patch)
tree09d96acd1e380810c2eb89521922573a56605dab
parentafcd30fcd5ac4d76ef805a636992978b5efc2ad7 (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.hs87
-rw-r--r--src/HaddockRename.hs24
-rw-r--r--src/HaddockTypes.hs13
-rw-r--r--src/Main.hs52
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)