aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Distribution/Haddock.hs14
-rw-r--r--src/Haddock/InterfaceFile.hs72
-rw-r--r--src/Haddock/Packages.hs126
-rw-r--r--src/Main.hs41
4 files changed, 66 insertions, 187 deletions
diff --git a/src/Distribution/Haddock.hs b/src/Distribution/Haddock.hs
index b43c4f6b..2d0f3dc7 100644
--- a/src/Distribution/Haddock.hs
+++ b/src/Distribution/Haddock.hs
@@ -7,19 +7,7 @@
module Distribution.Haddock (
readInterfaceFile,
- H.InterfaceFile(..)
) where
-import Haddock.Exception
-import qualified Haddock.InterfaceFile as H
-
-import Control.Exception
-import Control.Monad
-
-
-readInterfaceFile :: FilePath -> IO (Either String H.InterfaceFile)
-readInterfaceFile f =
- liftM Right (H.readInterfaceFile f)
- `catchDyn`
- (\(e::HaddockException) -> return $ Left $ show e)
+import Haddock.InterfaceFile
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 7f2fd6f4..93d6fe4c 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -114,47 +114,51 @@ writeInterfaceFile filename iface = do
-- snd send the result to the file
writeBinMem bh filename
return ()
+
-readInterfaceFile :: FilePath -> IO InterfaceFile
+readInterfaceFile :: FilePath -> IO (Either String InterfaceFile)
readInterfaceFile filename = do
bh <- readBinMem filename
- magic <- get bh
- when (magic /= binaryInterfaceMagic) $ throwE $
- "Magic number mismatch: couldn't load interface file: " ++ filename
-
+ magic <- get bh
version <- get bh
- when (version /= binaryInterfaceVersion) $ throwE $
- "Interface file is of wrong version: " ++ filename
- -- get the dictionary
- dict_p <- get bh
- data_p <- tellBin bh
- seekBin bh dict_p
- dict <- getDictionary bh
- seekBin bh data_p
-
- -- initialise the user-data field of bh
- ud <- newReadState dict
- bh <- return (setUserData bh ud)
+ case () of
+ _ | magic /= binaryInterfaceMagic -> return . Left $
+ "Magic number mismatch: couldn't load interface file: " ++ filename
+ | version /= binaryInterfaceVersion -> return . Left $
+ "Interface file is of wrong version: " ++ filename
+ | otherwise -> do
+
+ -- get the dictionary
+ dict_p <- get bh
+ data_p <- tellBin bh
+ seekBin bh dict_p
+ dict <- getDictionary bh
+ seekBin bh data_p
+
+ -- initialise the user-data field of bh
+ ud <- newReadState dict
+ bh <- return (setUserData bh ud)
- -- get the symbol table
- symtab_p <- get bh
- data_p <- tellBin bh
- seekBin bh symtab_p
- -- (construct an empty name cache)
- u <- mkSplitUniqSupply 'a' -- ??
- let nc = initNameCache u []
- (_, symtab) <- getSymbolTable bh nc
- seekBin bh data_p
-
- -- set the symbol table
- let ud = getUserData bh
- bh <- return $! setUserData bh ud{ud_symtab = symtab}
-
- -- load the actual data
- iface <- get bh
- return iface
+ -- get the symbol table
+ symtab_p <- get bh
+ data_p <- tellBin bh
+ seekBin bh symtab_p
+ -- (construct an empty name cache)
+ u <- mkSplitUniqSupply 'a' -- ??
+ let nc = initNameCache u []
+ (_, symtab) <- getSymbolTable bh nc
+ seekBin bh data_p
+
+ -- set the symbol table
+ let ud = getUserData bh
+ bh <- return $! setUserData bh ud{ud_symtab = symtab}
+
+ -- load the actual data
+ iface <- get bh
+ return (Right iface)
+
-------------------------------------------------------------------------------
-- Symbol table
diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
deleted file mode 100644
index ba3ee841..00000000
--- a/src/Haddock/Packages.hs
+++ /dev/null
@@ -1,126 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
-
-
-module Haddock.Packages (
- HaddockPackage(..),
- getHaddockPackages,
- getHaddockPackages',
- combineLinkEnvs
-) where
-
-
-import Haddock.Types
-import Haddock.Exception
-import Haddock.InterfaceFile
-import qualified Distribution.Haddock as D
-
-import Data.Maybe
-import qualified Data.Map as Map
-import Control.Monad
-import Control.Exception
-import System.Directory
-
-import GHC
-import DynFlags
-import Module
-import Packages
-
-
--- | This structure represents the installed Haddock information for a
--- package. This is basically the contents of the .haddock file, the path
--- to the html files and the list of modules in the package
-data HaddockPackage = HaddockPackage {
- pdModules :: [Module],
- pdLinkEnv :: LinkEnv,
- pdHtmlPath :: FilePath
-}
-
-
-getHaddockPackages' :: [(FilePath, FilePath)] -> IO [HaddockPackage]
-getHaddockPackages' pairs = do
- mbPackages <- mapM tryReadIface pairs
- return (catMaybes mbPackages)
- where
- -- try to get a HaddockPackage, warn if we can't
- tryReadIface (html, iface) = do
- eIface <- D.readInterfaceFile iface
- case eIface of
- Left err -> do
- putStrLn ("Warning: Cannot read " ++ iface ++ ":")
- putStrLn (" " ++ show err)
- putStrLn "Skipping this interface."
- return Nothing
- Right iface -> return $ Just $
- HaddockPackage (ifModules iface) (ifLinkEnv iface) html
-
-
--- | Try to read the installed Haddock information for the given packages,
--- if it exists. Print a warning on stdout if it couldn't be found for a
--- package.
-getHaddockPackages :: [InstalledPackageInfo] -> IO [HaddockPackage]
-getHaddockPackages pkgInfos = liftM catMaybes $ mapM tryGetPackage pkgInfos
- where
- -- try to get a HaddockPackage, warn if we can't
- tryGetPackage pkgInfo =
- (getPackage pkgInfo >>= return . Just)
- `catchDyn`
- (\(e::HaddockException) -> do
- let pkgName = showPackageId (package pkgInfo)
- putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":")
- putStrLn (" " ++ show e)
- return Nothing
- )
-
-
--- | Try to read a HaddockPackage structure for a package
-getPackage :: InstalledPackageInfo -> IO HaddockPackage
-getPackage pkgInfo = do
-
- html <- getHtml pkgInfo
- ifacePath <- getIface pkgInfo
- iface <- readInterfaceFile ifacePath
-
- return $ HaddockPackage {
- pdModules = ifModules iface,
- pdLinkEnv = ifLinkEnv iface,
- pdHtmlPath = html
- }
-
-
--- | Recreate exposed modules from an InstalledPackageInfo
-packageModules :: InstalledPackageInfo -> [Module]
-packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames
- where
- moduleNames = map mkModuleName (exposedModules pkgInfo)
- pkgId = mkPackageId . package
-
-
--- | Get the Haddock HTML directory path for a package
-getHtml :: InstalledPackageInfo -> IO FilePath
-getHtml pkgInfo = case haddockHTMLs pkgInfo of
- (path:_) | not (null path) -> do
- dirExists <- doesDirectoryExist path
- if dirExists then return path else throwE $
- "HTML directory " ++ path ++ " does not exist."
- _ -> throwE "No Haddock documentation installed."
-
-
--- | Get the Haddock interface path for a package
-getIface :: InstalledPackageInfo -> IO FilePath
-getIface pkgInfo = case haddockInterfaces pkgInfo of
- (file:_) | not (null file) -> do
- fileExists <- doesFileExist file
- if fileExists then return file else throwE $
- "Interface file " ++ file ++ " does not exist."
- _ -> throwE "No Haddock interface installed."
-
-
--- | Build one big link env out of a list of packages. If multiple packages
--- export the same (original) name, we just pick one of the packages as the
--- documentation site.
-combineLinkEnvs :: [HaddockPackage] -> LinkEnv
-combineLinkEnvs packages = Map.unions (map pdLinkEnv packages)
diff --git a/src/Main.hs b/src/Main.hs
index 8ddea3e9..779da8f2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,7 +10,6 @@
module Main (main) where
-import Haddock.Packages
import Haddock.Backends.Html
import Haddock.Backends.Hoogle
import Haddock.Interface
@@ -108,21 +107,14 @@ main = handleTopExceptions $ do
let ghcFlags = getGhcFlags flags
(session, dynflags) <- startGhc libDir ghcFlags
- -- get the -use-package packages, load them in GHC,
- -- and try to get the corresponding installed HaddockPackages
- let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
- pkgInfos <- loadPackages session usePackages
- packages'' <- getHaddockPackages pkgInfos
-
-- get packages via --read-interface
- packages' <- getHaddockPackages' (getIfacePairs flags)
- let packages = packages'' ++ packages'
+ packages <- readInterfaceFiles (getIfacePairs flags)
-- typecheck argument modules using GHC
modules <- typecheckFiles session fileArgs
-- combine the link envs of the external packages into one
- let extLinks = combineLinkEnvs packages
+ let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
-- create the interfaces -- this is the core part of Haddock
let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags
@@ -217,10 +209,27 @@ render flags interfaces = do
-------------------------------------------------------------------------------
--- Misc
+-- Reading and dumping interface files
-------------------------------------------------------------------------------
+readInterfaceFiles :: [(FilePath, FilePath)] -> IO [(InterfaceFile, FilePath)]
+readInterfaceFiles 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 iface
+ case eIface of
+ Left err -> do
+ putStrLn ("Warning: Cannot read " ++ iface ++ ":")
+ putStrLn (" " ++ show err)
+ putStrLn "Skipping this interface."
+ return Nothing
+ Right iface -> return $ Just (iface, html)
+
+
dumpInterfaceFile :: [Module] -> LinkEnv -> [Flag] -> IO ()
dumpInterfaceFile modules homeLinks flags =
case [str | Flag_DumpInterface str <- flags] of
@@ -233,6 +242,11 @@ dumpInterfaceFile modules homeLinks flags =
}
+-------------------------------------------------------------------------------
+-- Misc
+-------------------------------------------------------------------------------
+
+
handleEasyFlags flags fileArgs = do
usage <- getUsage
@@ -255,12 +269,11 @@ handleEasyFlags flags fileArgs = do
", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n"
-updateHTMLXRefs :: [HaddockPackage] -> IO ()
+updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
updateHTMLXRefs packages = do
writeIORef html_xrefs_ref (Map.fromList mapping)
where
- mapping = [ (mod, html) |
- (HaddockPackage mods _ html) <- packages, mod <- mods ]
+ mapping = [(mod, html) | (iface, html) <- packages, mod <- ifModules iface]
getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName))
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-24 22:28:09 +0000