aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsimonmar <unknown>2002-06-24 14:37:43 +0000
committersimonmar <unknown>2002-06-24 14:37:43 +0000
commit45290d2e6e2e4558f4469a9fc19403d80117223d (patch)
tree4bc121cff2f34b1e742a4f26bbfc7a090333b473
parent780c506b11953b81d41f01d73e0beea6f9352743 (diff)
[haddock @ 2002-06-24 14:37:42 by simonmar]
When reading an interface, allow a file path offset to be specified which represents the path to the HTML files for the modules specified by that interface. The path may be either relative (to the location of the HTML for this package), or absolute. The syntax is --read-interface=PATH,FILE where PATH is the path to the HTML, and FILE is the filename containing the interface.
-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)