aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-13 10:09:48 +0000