aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2010-08-29 13:03:28 +0000
committerDavid Waern <david.waern@gmail.com>2010-08-29 13:03:28 +0000
commitd5ec98534422eba93298bb8a76e6b315a55c3158 (patch)
tree72a4c3e98b60199e4bf1808878a81d441fa9b84c
parenta01b2ef92f9164734d6673b1f3e01cde8da477c8 (diff)
Add source entity path to --read-interface
You can now use this flag like this: --read-interface=<html path>,<source entity path>,<.haddock file> By "source entity path" I mean the same thing that is specified with the --source-entity flag. The purpose of this is to be able to specify the source entity path per package, to allow source links to work in the presence of cross-package documentation. When given two arguments or less the --read-interface flag behaves as before.
Diffstat
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs6
-rw-r--r--src/Haddock/Backends/Xhtml/Types.hs10
-rw-r--r--src/Haddock/GhcUtils.hs7
-rw-r--r--src/Haddock/InterfaceFile.hs9
-rw-r--r--src/Haddock/Options.hs15
-rw-r--r--src/Haddock/Types.hs2
-rw-r--r--src/Main.hs71
7 files changed, 70 insertions, 50 deletions
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 5ffdf181..295af305 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -42,6 +42,7 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils (makeAnchorId)
+import qualified Data.Map as Map
import Text.XHtml hiding ( name, title, p, quote )
import FastString ( unpackFS )
@@ -175,10 +176,10 @@ declElem = paragraph ! [theclass "src"]
-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
topDeclElem :: LinksInfo -> SrcSpan -> DocName -> Html -> Html
-topDeclElem ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html =
+topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html =
declElem << (html +++ srcLink +++ wikiLink)
where srcLink =
- case maybe_source_url of
+ case Map.lookup origPkg sourceMap of
Nothing -> noHtml
Just url -> let url' = spliceURL (Just fname) (Just origMod)
(Just n) (Just loc) url
@@ -196,6 +197,7 @@ topDeclElem ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html =
-- TODO: do something about type instances. They will point to
-- the module defining the type family, which is wrong.
origMod = nameModule n
+ origPkg = modulePackageId origMod
-- Name must be documented, otherwise we wouldn't get here
Documented n mdl = name
diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
index 4e23f469..7bff0eb1 100644
--- a/src/Haddock/Backends/Xhtml/Types.hs
+++ b/src/Haddock/Backends/Xhtml/Types.hs
@@ -16,10 +16,14 @@ module Haddock.Backends.Xhtml.Types (
) where
+import Data.Map
+import GHC
+
+
-- the base, module and entity URLs for the source code and wiki links.
-type SourceURLs = (Maybe String, Maybe String, Maybe String)
-type WikiURLs = (Maybe String, Maybe String, Maybe String)
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath)
+type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
--- The URL for source and wiki links, and the current module
+-- The URL for source and wiki links
type LinksInfo = (SourceURLs, WikiURLs)
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index d8525532..c0911f70 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -40,12 +40,7 @@ import GHC
moduleString :: Module -> String
-moduleString = moduleNameString . moduleName
-
-
--- return the name of the package, with version info
-modulePackageString :: Module -> String
-modulePackageString = packageIdString . modulePackageId
+moduleString = moduleNameString . moduleName
-- return the (name,version) of the package
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 5fe47b72..1df9cd12 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -12,7 +12,7 @@
-- Reading and writing the .haddock interface file
-----------------------------------------------------------------------------
module Haddock.InterfaceFile (
- InterfaceFile(..),
+ InterfaceFile(..), ifPackageId,
readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
writeInterfaceFile
) where
@@ -46,6 +46,13 @@ data InterfaceFile = InterfaceFile {
}
+ifPackageId :: InterfaceFile -> PackageId
+ifPackageId if_ =
+ case ifInstalledIfaces if_ of
+ [] -> error "empty InterfaceFile"
+ iface:_ -> modulePackageId $ instMod iface
+
+
binaryInterfaceMagic :: Word32
binaryInterfaceMagic = 0xD0Cface
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index b855f545..65c3092e 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -26,7 +26,7 @@ module Haddock.Options (
optLaTeXStyle,
verbosity,
ghcFlags,
- ifacePairs
+ ifaceTriples
) where
@@ -230,14 +230,17 @@ ghcFlags :: [Flag] -> [String]
ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
-ifacePairs :: [Flag] -> [(FilePath, FilePath)]
-ifacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
+ifaceTriples :: [Flag] -> [(DocPaths, FilePath)]
+ifaceTriples flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
where
- parseIfaceOption :: String -> (FilePath, FilePath)
+ parseIfaceOption :: String -> (DocPaths, FilePath)
parseIfaceOption str =
case break (==',') str of
- (fpath, ',':file) -> (fpath, file)
- (file, _) -> ("", file)
+ (fpath, ',':rest) ->
+ case break (==',') rest of
+ (src, ',':file) -> ((fpath, Just src), file)
+ (file, _) -> ((fpath, Nothing), file)
+ (file, _) -> (("", Nothing), file)
-- | Like 'listToMaybe' but returns the last element instead of the first.
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 62a603ee..3ec37469 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -37,8 +37,10 @@ import Name
type IfaceMap = Map Module Interface
type InstIfaceMap = Map Module InstalledInterface
type DocMap = Map Name (Doc DocName)
+type SrcMap = Map PackageId FilePath
type Decl = LHsDecl Name
type GhcDocHdr = Maybe LHsDocString
+type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
-----------------------------------------------------------------------------
diff --git a/src/Main.hs b/src/Main.hs
index 22a649d2..b9eb6b95 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -58,6 +58,7 @@ import GHC hiding (flags, verbosity)
import Config
import DynFlags hiding (flags, verbosity)
import Panic (handleGhcException)
+import Module
--------------------------------------------------------------------------------
@@ -140,14 +141,14 @@ main = handleTopExceptions $ do
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles freshNameCache (ifacePairs flags)
+ packages <- readInterfaceFiles freshNameCache (ifaceTriples flags)
-- Render even though there are no input files (usually contents/index).
renderStep flags packages []
-readPackagesAndProcessModules :: [Flag] -> [String] -> IO ([(InterfaceFile, FilePath)],
- [Interface], LinkEnv)
+readPackagesAndProcessModules :: [Flag] -> [String]
+ -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
libDir <- getGhcLibDir flags
@@ -160,31 +161,32 @@ readPackagesAndProcessModules flags files = do
withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
-- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
+ packages <- readInterfaceFiles nameCacheFromGhc (ifaceTriples flags)
-- Create the interfaces -- this is the core part of Haddock.
- let ifaceFiles = map fst packages
+ let ifaceFiles = map snd packages
(ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
return (packages, ifaces, homeLinks)
-renderStep :: [Flag] -> [(InterfaceFile, FilePath)] -> [Interface] -> IO ()
-renderStep flags packages interfaces = do
- updateHTMLXRefs packages
- let ifaceFiles = map fst packages
- installedIfaces = concatMap ifInstalledIfaces ifaceFiles
- render flags interfaces installedIfaces
+renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep flags pkgs interfaces = do
+ updateHTMLXRefs pkgs
+ let
+ ifaceFiles = map snd pkgs
+ installedIfaces = concatMap ifInstalledIfaces ifaceFiles
+ srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
+ render flags interfaces installedIfaces srcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()
-render flags ifaces installedIfaces = do
+render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render flags ifaces installedIfaces srcMap = do
let
title = fromMaybe "" (optTitle flags)
unicode = Flag_UseUnicode `elem` flags
- opt_source_urls = optSourceUrls flags
opt_wiki_urls = optWikiUrls flags
opt_contents_url = optContentsUrl flags
opt_index_url = optIndexUrl flags
@@ -197,30 +199,35 @@ render flags ifaces installedIfaces = do
allIfaces = map toInstalledIface ifaces ++ installedIfaces
allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
- packageMod = ifaceMod (head ifaces)
- packageStr = Just (modulePackageString packageMod)
- (pkgName,pkgVer) = modulePackageInfo packageMod
+ pkgMod = ifaceMod (head ifaces)
+ pkgId = modulePackageId pkgMod
+ pkgStr = Just (packageIdString pkgId)
+ (pkgName,pkgVer) = modulePackageInfo pkgMod
+
+ (src_base, src_module, src_entity) = optSourceUrls flags
+ srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) src_entity
+ sourceUrls = (src_base, src_module, srcMap')
libDir <- getHaddockLibDir flags
prologue <- getPrologue flags
themes <- getThemes libDir flags >>= either bye return
when (Flag_GenIndex `elem` flags) $ do
- ppHtmlIndex odir title packageStr
- themes opt_contents_url opt_source_urls opt_wiki_urls
+ ppHtmlIndex odir title pkgStr
+ themes opt_contents_url sourceUrls opt_wiki_urls
allVisibleIfaces
copyHtmlBits odir libDir themes
when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents odir title packageStr
- themes opt_index_url opt_source_urls opt_wiki_urls
+ ppHtmlContents odir title pkgStr
+ themes opt_index_url sourceUrls opt_wiki_urls
allVisibleIfaces True prologue
copyHtmlBits odir libDir themes
when (Flag_Html `elem` flags) $ do
- ppHtml title packageStr visibleIfaces odir
+ ppHtml title pkgStr visibleIfaces odir
prologue
- themes opt_source_urls opt_wiki_urls
+ themes sourceUrls opt_wiki_urls
opt_contents_url opt_index_url unicode
copyHtmlBits odir libDir themes
@@ -229,7 +236,7 @@ render flags ifaces installedIfaces = do
ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir
when (Flag_LaTeX `elem` flags) $ do
- ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style
+ ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
libDir
-------------------------------------------------------------------------------
@@ -239,22 +246,22 @@ render flags ifaces installedIfaces = do
readInterfaceFiles :: MonadIO m =>
NameCacheAccessor m
- -> [(FilePath, FilePath)] ->
- m [(InterfaceFile, FilePath)]
+ -> [(DocPaths, FilePath)] ->
+ m [(DocPaths, InterfaceFile)]
readInterfaceFiles name_cache_accessor pairs = do
mbPackages <- mapM tryReadIface pairs
return (catMaybes mbPackages)
where
-- try to read an interface, warn if we can't
- tryReadIface (html, iface) = do
- eIface <- readInterfaceFile name_cache_accessor iface
+ tryReadIface (paths, file) = do
+ eIface <- readInterfaceFile name_cache_accessor file
case eIface of
Left err -> liftIO $ do
- putStrLn ("Warning: Cannot read " ++ iface ++ ":")
+ putStrLn ("Warning: Cannot read " ++ file ++ ":")
putStrLn (" " ++ err)
putStrLn "Skipping this interface."
return Nothing
- Right f -> return $ Just (f, html)
+ Right f -> return $ Just (paths, f)
dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO ()
@@ -366,10 +373,10 @@ shortcutFlags flags = do
byeGhcVersion = bye (cProjectVersion ++ "\n")
-updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
+updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping)
where
- mapping = [ (instMod iface, html) | (ifaces, html) <- packages
+ mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
, iface <- ifInstalledIfaces ifaces ]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 02:15:35 +0000