[commit: haddock] ghc-7.6: Make API buildable with GHC 7.6. (d40f783)

[David Waern]

Repository : ssh://darcs.haskell.org//srv/darcs/haddock

On branch  : ghc-7.6

http://hackage.haskell.org/trac/ghc/changeset/d40f783dae503a194c036f5c8272563fcca187a4

>---------------------------------------------------------------

commit d40f783dae503a194c036f5c8272563fcca187a4
Author: David Waern <david.waern at gmail.com>
Date:   Fri Sep 28 10:21:32 2012 +0200

    Make API buildable with GHC 7.6.

>---------------------------------------------------------------

 src/Documentation/Haddock.hs |    2 +-
 src/Main.hs                  |   24 ++++++++++++++----------
 2 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
index 60bb314..cbdc4d6 100644
--- a/src/Documentation/Haddock.hs
+++ b/src/Documentation/Haddock.hs
@@ -70,6 +70,6 @@ createInterfaces
   -> [String]       -- ^ File or module names
   -> IO [Interface] -- ^ Resulting list of interfaces
 createInterfaces flags modules = do
-  (_, ifaces, _) <- readPackagesAndProcessModules flags modules
+  (_, ifaces, _) <- withGhc' flags (readPackagesAndProcessModules flags modules)
   return ifaces
 
diff --git a/src/Main.hs b/src/Main.hs
index 31e2726..abeda77 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,7 +15,7 @@
 --
 -- Program entry point and top-level code.
 -----------------------------------------------------------------------------
-module Main (main, readPackagesAndProcessModules) where
+module Main (main, readPackagesAndProcessModules, withGhc') where
 
 
 import Haddock.Backends.Xhtml
@@ -135,15 +135,7 @@ main = handleTopExceptions $ do
   shortcutFlags flags
   qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
 
-  libDir <- fmap snd (getGhcDirs flags)
-
-  -- Catches all GHC source errors, then prints and re-throws them.
-  let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
-        printException err
-        liftIO exitFailure
-
-  -- Initialize GHC.
-  withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
+  withGhc' flags $ do
 
     dflags <- getDynFlags
 
@@ -169,6 +161,18 @@ main = handleTopExceptions $ do
       liftIO $ renderStep dflags flags qual packages []
 
 
+withGhc' :: [Flag] -> Ghc a -> IO a
+withGhc' flags action = do
+  libDir <- fmap snd (getGhcDirs flags)
+
+  -- Catches all GHC source errors, then prints and re-throws them.
+  let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
+        printException err
+        liftIO exitFailure
+
+  withGhc libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
+
+
 readPackagesAndProcessModules :: [Flag] -> [String]
                               -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
 readPackagesAndProcessModules flags files = do