diff options
-rw-r--r-- | src/HaddockHtml.hs | 68 | ||||
-rw-r--r-- | src/HaddockUtil.hs | 26 | ||||
-rw-r--r-- | src/Main.hs | 27 |
3 files changed, 71 insertions, 50 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 80a06806..75feb045 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -13,7 +13,7 @@ import HaddockUtil import HsSyn import IO -import Maybe ( fromJust, isNothing, isJust ) +import Maybe ( fromJust, isJust ) import FiniteMap import List ( sortBy ) import Char ( toUpper, toLower ) @@ -71,8 +71,9 @@ ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue = do ppHtmlIndex odir title visible_ifaces mapM_ (ppHtmlModule odir title source_url inst_maps) visible_ifaces -moduleHtmlFile :: String -> FilePath -moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename? +moduleHtmlFile :: FilePath -> String -> FilePath +moduleHtmlFile "" mod = mod ++ ".html" -- ToDo: Z-encode filename? +moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html" contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" @@ -99,7 +100,7 @@ parent_button mod = case span (/= '.') (reverse mod) of (m, '.':rest) -> topButBox ( - anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent") + anchor ! [href (moduleHtmlFile "" (reverse rest))] << toHtml "Parent") _ -> Html.emptyTable @@ -138,9 +139,10 @@ pageHeader mod iface title source_url = ) ) -moduleInfo iface - | Nothing <- iface_info iface = Html.emptyTable - | Just info <- iface_info iface = +moduleInfo iface = + case iface_info iface of + Nothing -> Html.emptyTable + Just info -> tda [align "right"] << narrowTable << ( (tda [theclass "infohead"] << toHtml "Portability") <-> (tda [theclass "infoval"] << toHtml (portability info)) </> @@ -191,7 +193,7 @@ mkNode ss (Node s leaf ts) = vanillaTable (toHtml (aboves (map (mkNode (s:ss)) ts)))) mkLeaf s ss False = toHtml s -mkLeaf s ss True = anchor ! [href (moduleHtmlFile mod)] << toHtml s +mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mod)] << toHtml s where mod = foldr (++) "" (s' : map ('.':) ss') (s':ss') = reverse (s:ss) -- reconstruct the module name @@ -283,7 +285,7 @@ ppHtmlIndex odir title ifaces = do where cmp (n1,_) (n2,_) = n1 `compare` n2 iface_indices f = map (getIfaceIndex f) ifaces - full_index f = foldr1 (plusFM_C (++)) (iface_indices f) + full_index f = foldr (plusFM_C (++)) emptyFM (iface_indices f) getIfaceIndex f (mod,iface) = listToFM [ (name, [(mod, mod == mod')]) @@ -294,9 +296,10 @@ ppHtmlIndex odir title ifaces = do indexElt (nm, entries) = td << ppHsName nm <-> td << (hsep [ if defining then - bold << anchor ! [href (linkId mod nm)] << toHtml mod + bold << anchor ! [href (linkId (Module mod) nm)] + << toHtml mod else - anchor ! [href (linkId mod nm)] << toHtml mod + anchor ! [href (linkId (Module mod) nm)] << toHtml mod | (Module mod, defining) <- entries ]) nameBeginsWith (HsTyClsName id) c = idBeginsWith id c @@ -321,7 +324,7 @@ ppHtmlModule odir title source_url inst_maps (Module mod,iface) = do ifaceToHtml mod iface inst_maps </> s15 </> footer ) - writeFile (odir ++ pathSeparator:moduleHtmlFile mod) (renderHtml html) + writeFile (moduleHtmlFile odir mod) (renderHtml html) ifaceToHtml :: String -> Interface -> InstMaps -> HtmlTable ifaceToHtml mod iface inst_maps @@ -463,14 +466,6 @@ doDecl summary inst_maps x decl = do_decl decl ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty - -keepDecl HsTypeSig{} = True -keepDecl HsTypeDecl{} = True -keepDecl HsNewTypeDecl{} = True -keepDecl HsDataDecl{} = True -keepDecl HsClassDecl{} = True -keepDecl _ = False - -- ----------------------------------------------------------------------------- -- Data & newtype declarations @@ -520,8 +515,6 @@ ppHsDataDecl summary (_, ty_inst_map) is_newty aboves (map ppSideBySideConstr cons) ) - no_constr_docs = all constr_has_no_doc cons - instances = lookupFM ty_inst_map x instances_bit @@ -534,12 +527,6 @@ ppHsDataDecl summary (_, ty_inst_map) is_newty aboves (map (declBox.ppInstHead) is) ) -constr_has_no_doc (HsConDecl _ _ _ _ _ doc) = isNothing doc -constr_has_no_doc (HsRecDecl _ _ _ _ fields doc) - = isNothing doc && all field_has_no_doc fields - -field_has_no_doc (HsFieldDecl nms _ doc) = isNothing doc - isRecDecl (HsRecDecl pos nm tvs ctxt fields maybe_doc) = True isRecDecl _ = False @@ -654,7 +641,6 @@ ppShortClassDecl summary inst_maps ) where - Just c = declMainBinder decl hdr = ppClassHdr summary ctxt nm tvs fds ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c @@ -668,8 +654,6 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c ) where - Just c = declMainBinder decl - header | null decls = declBox hdr | otherwise = declBox (hdr <+> keyword "where") @@ -702,8 +686,6 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c instances = lookupFM cls_inst_map orig_c - kept_decls = filter keepDecl decls - decl_has_no_doc decl = isNothing (declDoc decl) ppInstHead :: InstHead -> Html ppInstHead ([],asst) = ppHsAsst asst @@ -800,8 +782,8 @@ linkTarget :: HsName -> Html linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml "" ppHsQName :: HsQName -> Html -ppHsQName (UnQual str) = ppHsName str -ppHsQName n@(Qual (Module mod) str) +ppHsQName (UnQual str) = ppHsName str +ppHsQName n@(Qual mod str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str | otherwise = anchor ! [href (linkId mod str)] << ppHsName str @@ -834,11 +816,17 @@ ppHsBindIdent (HsIdent str) = toHtml str ppHsBindIdent (HsSymbol str) = parens (toHtml str) ppHsBindIdent (HsSpecial str) = toHtml str -linkId :: String -> HsName -> String -linkId mod str = moduleHtmlFile mod ++ '#': hsNameStr str +linkId :: Module -> HsName -> String +linkId (Module mod) str = moduleHtmlFile fp mod ++ '#': hsNameStr str + where fp = case lookupFM html_xrefs (Module mod) of + Just fp -> fp + Nothing -> "" ppHsModule :: String -> Html -ppHsModule mod = anchor ! [href (moduleHtmlFile mod)] << toHtml mod +ppHsModule mod = anchor ! [href (moduleHtmlFile fp mod)] << toHtml mod + where fp = case lookupFM html_xrefs (Module mod) of + Just fp -> fp + Nothing -> "" -- ----------------------------------------------------------------------------- -- * Doc Markup @@ -914,10 +902,6 @@ text = strAttr "TEXT" declBox :: Html -> HtmlTable declBox html = tda [theclass "decl"] << html --- a horrible hack to keep a box from expanding width-wise -narrowDeclBox :: Html -> HtmlTable -narrowDeclBox html = tda [theclass "decl", width "1"] << html - -- a box for displaying documentation, -- indented and with a little padding at the top docBox :: Html -> HtmlTable diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 27a83770..633fc36f 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -16,12 +16,15 @@ module HaddockUtil ( isPathSeparator, pathSeparator, -- * Miscellaneous utilities - die, dieMsg, mapSnd, mapMaybeM + die, dieMsg, mapSnd, mapMaybeM, + -- * HTML cross reference mapping + html_xrefs_ref, html_xrefs, ) where import HsSyn +import FiniteMap import List ( intersect ) import IO ( hPutStr, stderr ) import System @@ -70,9 +73,6 @@ conDeclBinders (HsRecDecl _ n _ _ fields _) = fieldDeclBinders (HsFieldDecl ns _ _) = ns -exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t)) -exQtNm t = nameOfQName (fst (splitTyConApp t)) - splitTyConApp :: HsType -> (HsQName, [HsType]) splitTyConApp t = split t [] where @@ -223,6 +223,24 @@ mapMaybeM f Nothing = return Nothing mapMaybeM f (Just a) = f a >>= return . Just ----------------------------------------------------------------------------- +-- HTML cross references + +-- For each module, we need to know where its HTML documentation lives +-- so that we can point hyperlinks to it. It is extremely +-- inconvenient to plumb this information to all the places that need +-- it (basically every function in HaddockHtml), and furthermore the +-- mapping is constant for any single run of Haddock. So for the time +-- being I'm going to use a write-once global variable. + +{-# NOINLINE html_xrefs_ref #-} +html_xrefs_ref :: IORef (FiniteMap Module FilePath) +html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) + +{-# NOINLINE html_xrefs #-} +html_xrefs :: FiniteMap Module FilePath +html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) + +----------------------------------------------------------------------------- -- Binary instances for stuff instance Binary Module where diff --git a/src/Main.hs b/src/Main.hs index e6c9576f..ad83cf9c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -125,16 +125,19 @@ run flags files = do [] -> Nothing fs -> Just (last fs) - ifaces_to_read = [str | Flag_ReadInterface str <- flags] + ifaces_to_read = [ parseIfaceOption str + | Flag_ReadInterface str <- flags ] no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags prologue <- getPrologue flags - writeIORef saved_flags flags - parsed_mods <- sequence (map parse_file files) + read_ifaces_s <- mapM readIface (map snd ifaces_to_read) + + updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s - read_ifaces_s <- mapM readIface ifaces_to_read + writeIORef saved_flags flags + parsed_mods <- mapM parse_file files let read_ifaces = concat read_ifaces_s external_mods = map fst read_ifaces @@ -180,6 +183,12 @@ run flags files = do prepared_ifaces = [ (mod, fmToList (iface_env iface)) | (mod, iface) <- these_mod_ifaces ] +parseIfaceOption :: String -> (FilePath,FilePath) +parseIfaceOption s = + case break (==',') s of + (path,',':file) -> (path,file) + (_, file) -> ("", file) + readIface :: FilePath -> IO [(Module,Interface)] readIface filename = do bh <- readBinMem filename @@ -201,6 +210,16 @@ readIface filename = do ) +updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO () +updateHTMLXRefs paths ifaces_s = + writeIORef html_xrefs_ref (listToFM mapping) + where + mapping = [ (mod,path) + | (path, ifaces) <- zip paths ifaces_s, + (mod, _iface) <- ifaces + ] + + parse_file file = do bracket (openFile file ReadMode) |