aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/HaddockHtml.hs68
-rw-r--r--src/HaddockUtil.hs26
-rw-r--r--src/Main.hs27
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)
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 13:40:04 +0000