From a18e080534a2778f37cb8ff9d501959fe6cc7acd Mon Sep 17 00:00:00 2001
From: Luite Stegeman <stegeman@gmail.com>
Date: Wed, 20 Aug 2014 05:42:45 +0200
Subject: export things to allow customizing how the Ghc session is run

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

(limited to 'src')

diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
index 655a9723..1ff5cf75 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 ad78c50d..0cff5bd3 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,
-- 
cgit v1.2.3