aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Haddock/InterfaceFile.hs26
-rw-r--r--src/Main.hs68
2 files changed, 59 insertions, 35 deletions
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index e822cdda..2fcb9351 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -97,8 +97,8 @@ writeInterfaceFile filename iface = do
return ()
-readInterfaceFile :: Session -> FilePath -> IO (Either String InterfaceFile)
-readInterfaceFile session filename = do
+readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile)
+readInterfaceFile mbSession filename = do
bh <- readBinMem filename
magic <- get bh
@@ -122,19 +122,29 @@ readInterfaceFile session filename = do
ud <- newReadState dict
bh <- return (setUserData bh ud)
- -- get the name cache from the ghc session
- ncRef <- withSession session (return . hsc_NC)
- nc <- readIORef ncRef
+ -- get the name cache from ghc if we have a ghc session,
+ -- otherwise create a new one
+ (theNC, mbRef) <- case mbSession of
+ Just session -> do
+ ref <- withSession session (return . hsc_NC)
+ nc <- readIORef ref
+ return (nc, Just ref)
+ Nothing -> do
+ -- construct an empty name cache
+ u <- mkSplitUniqSupply 'a' -- ??
+ return (initNameCache u [], Nothing)
-- get the symbol table
symtab_p <- get bh
data_p <- tellBin bh
seekBin bh symtab_p
- (nc', symtab) <- getSymbolTable bh nc
+ (nc', symtab) <- getSymbolTable bh theNC
seekBin bh data_p
- -- write back the new name cache
- writeIORef ncRef nc'
+ -- write back the new name cache if we have a ghc session
+ case mbRef of
+ Just ref -> writeIORef ref nc'
+ Nothing -> return ()
-- set the symbol table
let ud = getUserData bh
diff --git a/src/Main.hs b/src/Main.hs
index 68e34c8b..bd2b4830 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -101,32 +101,45 @@ main = handleTopExceptions $ do
-- parse command-line flags and handle some of them initially
args <- getArgs
(flags, fileArgs) <- parseHaddockOpts args
- libDir <- handleEasyFlags flags fileArgs
-
- -- initialize GHC
- (session, dynflags) <- startGhc libDir (ghcFlags flags)
+ handleEasyFlags flags fileArgs
- -- get packages via --read-interface
- packages <- readInterfaceFiles session (ifacePairs flags)
+ let renderStep packages interfaces = do
+ updateHTMLXRefs packages
+ let ifaceFiles = map fst packages
+ installedIfaces = concatMap ifInstalledIfaces ifaceFiles
+ render flags interfaces installedIfaces
- -- typecheck argument modules using GHC
- modules <- typecheckFiles session fileArgs
+ if not (null fileArgs)
+ then do
+ -- initialize GHC
+ libDir <- getGhcLibDir flags
+ (session, dynflags) <- startGhc libDir (ghcFlags flags)
- -- combine the link envs of the external packages into one
- let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
+ -- get packages supplied with --read-interface
+ packages <- readInterfaceFiles (Just session) (ifacePairs flags)
- -- create the interfaces -- this is the core part of Haddock
- let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags
- mapM_ putStrLn messages
+ -- typecheck argument modules using GHC
+ modules <- typecheckFiles session fileArgs
- -- render the interfaces
- updateHTMLXRefs packages
- let ifaceFiles = map fst packages
- let installedIfaces = concatMap ifInstalledIfaces ifaceFiles
- render flags interfaces installedIfaces
+ -- combine the link envs of the external packages into one
+ let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
- -- last but not least, dump the interface file!
- dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
+ -- create the interfaces -- this is the core part of Haddock
+ let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags
+ mapM_ putStrLn messages
+
+ -- render the interfaces
+ renderStep packages interfaces
+
+ -- last but not least, dump the interface file
+ dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
+
+ else do
+ -- get packages supplied with --read-interface
+ packages <- readInterfaceFiles Nothing (ifacePairs flags)
+
+ -- render even though there are no input files (usually contents/index)
+ renderStep packages []
-------------------------------------------------------------------------------
@@ -220,7 +233,8 @@ render flags interfaces installedIfaces = do
-------------------------------------------------------------------------------
-readInterfaceFiles :: Session -> [(FilePath, FilePath)] -> IO [(InterfaceFile, FilePath)]
+readInterfaceFiles :: Maybe Session -> [(FilePath, FilePath)] ->
+ IO [(InterfaceFile, FilePath)]
readInterfaceFiles session pairs = do
mbPackages <- mapM tryReadIface pairs
return (catMaybes mbPackages)
@@ -254,6 +268,12 @@ dumpInterfaceFile ifaces homeLinks flags =
-------------------------------------------------------------------------------
+getGhcLibDir flags =
+ case [ dir | Flag_GhcLibDir dir <- flags ] of
+ [] -> throwE "no GHC lib dir specified"
+ xs -> return $ last xs
+
+
handleEasyFlags flags fileArgs = do
usage <- getUsage
@@ -261,15 +281,9 @@ handleEasyFlags flags fileArgs = do
when (Flag_Version `elem` flags) byeVersion
when (Flag_GhcVersion `elem` flags) byeGhcVersion
- let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of
- [] -> throwE "no GHC lib dir specified"
- xs -> last xs
-
when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
&& Flag_Html `elem` flags) $
throwE ("-h cannot be used with --gen-index or --gen-contents")
-
- return ghcLibDir
where
byeVersion = bye $
"Haddock version " ++ projectVersion ++