aboutsummaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorThomas Schilling <nominolo@googlemail.com>2008-09-15 09:11:25 +0000
committerThomas Schilling <nominolo@googlemail.com>2008-09-15 09:11:25 +0000
commit155c63a969b217994f6cb7f64ff29e0b47de934d (patch)
treedced7741a7cd0307e5cd4b8e9d20ad5165342127 /src/Main.hs
parentc8ba22124636eaf60c439e2ac2642b72d72145a2 (diff)
Port Main to new GHC API.
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs44
1 files changed, 24 insertions, 20 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 3cd6d5f7..3710487c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -57,6 +57,7 @@ import ErrUtils
#if __GLASGOW_HASKELL__ >= 609
import Panic (handleGhcException)
import Util
+import MonadUtils ( MonadIO(..) )
#else
import Util hiding (handle)
#endif
@@ -160,30 +161,31 @@ main = handleTopExceptions $ do
#endif
-- initialize GHC
- (session, dynflags) <- startGhc libDir (ghcFlags flags)
+ startGhc libDir (ghcFlags flags) $ \dynflags -> do
- -- get packages supplied with --read-interface
- packages <- readInterfaceFiles (Just session) (ifacePairs flags)
+ -- get packages supplied with --read-interface
+ packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
- -- typecheck argument modules using GHC
- modules <- typecheckFiles session fileArgs
+ -- typecheck argument modules using GHC
+ modules <- typecheckFiles fileArgs
- -- combine the link envs of the external packages into one
- let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
+ -- combine the link envs of the external packages into one
+ 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
- mapM_ putStrLn messages
+ liftIO $ do
+ -- 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
+ -- render the interfaces
+ renderStep packages interfaces
- -- last but not least, dump the interface file
- dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
+ -- 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)
+ packages <- readInterfaceFiles freshNameCache (ifacePairs flags)
-- render even though there are no input files (usually contents/index)
renderStep packages []
@@ -293,17 +295,19 @@ render flags interfaces installedIfaces = do
-------------------------------------------------------------------------------
-readInterfaceFiles :: Maybe Session -> [(FilePath, FilePath)] ->
- IO [(InterfaceFile, FilePath)]
-readInterfaceFiles session pairs = do
+readInterfaceFiles :: MonadIO m =>
+ NameCacheAccessor m
+ -> [(FilePath, FilePath)] ->
+ m [(InterfaceFile, FilePath)]
+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 session iface
+ eIface <- readInterfaceFile name_cache_accessor iface
case eIface of
- Left err -> do
+ Left err -> liftIO $ do
putStrLn ("Warning: Cannot read " ++ iface ++ ":")
putStrLn (" " ++ show err)
putStrLn "Skipping this interface."