[commit: haddock] 2.15, 2.15.0.1, 2.15.0.2, T6018-injective-type-families, adamse-D1033, clean, ghc-head, master, metainfo, v2.15, wip/10268, wip/10313, wip/D538, wip/D538-1, wip/D538-2, wip/D538-3, wip/D538-4, wip/D538-5, wip/D538-6, wip/D548-master, wip/D548-master-2, wip/T10483, wip/T9840, wip/api-annot-tweaks-7.10, wip/api-annots-ghc-7.10-3, wip/orf-reboot: export things to allow customizing how the Ghc session is run (a18e080)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.15,2.15.0.1,2.15.0.2,T6018-injective-type-families,adamse-D1033,clean,ghc-head,master,metainfo,v2.15,wip/10268,wip/10313,wip/D538,wip/D538-1,wip/D538-2,wip/D538-3,wip/D538-4,wip/D538-5,wip/D538-6,wip/D548-master,wip/D548-master-2,wip/T10483,wip/T9840,wip/api-annot-tweaks-7.10,wip/api-annots-ghc-7.10-3,wip/orf-reboot
Link       : http://git.haskell.org/haddock.git/commitdiff/a18e080534a2778f37cb8ff9d501959fe6cc7acd

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

commit a18e080534a2778f37cb8ff9d501959fe6cc7acd
Author: Luite Stegeman <stegeman at gmail.com>
Date:   Wed Aug 20 05:42:45 2014 +0200

    export things to allow customizing how the Ghc session is run


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

a18e080534a2778f37cb8ff9d501959fe6cc7acd
 src/Documentation/Haddock.hs |  8 +++++++-
 src/Haddock.hs               | 29 +++++++++++++++++++----------
 2 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
index 655a972..1ff5cf7 100644
--- a/src/Documentation/Haddock.hs
+++ b/src/Documentation/Haddock.hs
@@ -57,8 +57,14 @@ module Documentation.Haddock (
   Flag(..),
   DocOption(..),
 
+  -- * Error handling
+  HaddockException(..),
+
   -- * Program entry point
   haddock,
+  haddockWithGhc,
+  getGhcDirs,
+  withGhc
 ) where
 
 
@@ -79,5 +85,5 @@ createInterfaces
   -> [String]       -- ^ File or module names
   -> IO [Interface] -- ^ Resulting list of interfaces
 createInterfaces flags modules = do
-  (_, ifaces, _) <- withGhc' flags (readPackagesAndProcessModules flags modules)
+  (_, ifaces, _) <- withGhc flags (readPackagesAndProcessModules flags modules)
   return ifaces
diff --git a/src/Haddock.hs b/src/Haddock.hs
index ad78c50..0cff5bd 100644
--- a/src/Haddock.hs
+++ b/src/Haddock.hs
@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
 {-# LANGUAGE LambdaCase #-}
 -----------------------------------------------------------------------------
 -- |
@@ -17,7 +17,13 @@
 --
 -- Program entry point and top-level code.
 -----------------------------------------------------------------------------
-module Haddock (haddock, readPackagesAndProcessModules, withGhc') where
+module Haddock (
+  haddock,
+  haddockWithGhc,
+  getGhcDirs,
+  readPackagesAndProcessModules,
+  withGhc
+) where
 
 import Haddock.Backends.Xhtml
 import Haddock.Backends.Xhtml.Themes (getThemes)
@@ -128,7 +134,10 @@ handleGhcExceptions =
 --
 -- > main = getArgs >>= haddock
 haddock :: [String] -> IO ()
-haddock args = handleTopExceptions $ do
+haddock args = haddockWithGhc withGhc args
+
+haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
+haddockWithGhc ghc args = handleTopExceptions $ do
 
   -- Parse command-line flags and handle some of them initially.
   -- TODO: unify all of this (and some of what's in the 'render' function),
@@ -139,7 +148,7 @@ haddock args = handleTopExceptions $ do
   qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
 
   -- inject dynamic-too into flags before we proceed
-  flags' <- withGhc' flags $ do
+  flags' <- ghc flags $ do
         df <- getDynFlags
         case lookup "GHC Dynamic" (compilerInfo df) of
           Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
@@ -149,7 +158,7 @@ haddock args = handleTopExceptions $ do
     forM_ (warnings args) $ \warning -> do
       hPutStrLn stderr warning
 
-  withGhc' flags' $ do
+  ghc flags' $ do
 
     dflags <- getDynFlags
 
@@ -183,8 +192,8 @@ warnings = map format . filter (isPrefixOf "-optghc")
     format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
 
 
-withGhc' :: [Flag] -> Ghc a -> IO a
-withGhc' flags action = do
+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.
@@ -192,7 +201,7 @@ withGhc' flags action = do
         printException err
         liftIO exitFailure
 
-  withGhc libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
+  withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
 
 
 readPackagesAndProcessModules :: [Flag] -> [String]
@@ -313,8 +322,8 @@ readInterfaceFiles name_cache_accessor pairs = do
 
 -- | Start a GHC session with the -haddock flag set. Also turn off
 -- compilation and linking. Then run the given 'Ghc' action.
-withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
-withGhc libDir flags ghcActs = runGhc (Just libDir) $ do
+withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
+withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
   dynflags  <- getSessionDynFlags
   dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) {
     hscTarget = HscNothing,