Don't require -B <ghc-libdir> when no argument files

Change readInterfaceFile to take a Maybe Session, to avoid having to pass -B 
<ghc-libdir> to Haddock when there're no source files to process. This is nice when 
computing contents/index for external packages.

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 ++