diff options
-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) |