diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 26 | ||||
| -rw-r--r-- | src/Main.hs | 68 |
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 ++ |