Refactoring and tidyup of HscMain and related things (also fix #1666)
authorSimon Marlow <marlowsd@gmail.com>
Wed, 27 Oct 2010 12:11:32 +0000 (12:11 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 27 Oct 2010 12:11:32 +0000 (12:11 +0000)
While trying to fix #1666 (-Werror aborts too early) I decided to some
tidyup in GHC/DriverPipeline/HscMain.

 - The GhcMonad overloading is gone from DriverPipeline and HscMain
   now.  GhcMonad is now defined in a module of its own, and only
   used in the top-level GHC layer.  DriverPipeline and HscMain
   use the plain IO monad and take HscEnv as an argument.

 - WarnLogMonad is gone.  printExceptionAndWarnings is now called
   printException (the old name is deprecated).  Session no longer
   contains warnings.

 - HscMain has its own little monad that collects warnings, and also
   plumbs HscEnv around.  The idea here is that warnings are collected
   while we're in HscMain, but on exit from HscMain (any function) we
   check for warnings and either print them (via log_action, so IDEs
   can still override the printing), or turn them into an error if
   -Werror is on.

 - GhcApiCallbacks is gone, along with GHC.loadWithLogger.  Thomas
   Schilling told me he wasn't using these, and I don't see a good
   reason to have them.

 - there's a new pure API to the parser (suggestion from Neil Mitchell):
      parser :: String
             -> DynFlags
             -> FilePath
             -> Either ErrorMessages (WarningMessages,
                                      Located (HsModule RdrName))

23 files changed:
compiler/basicTypes/SrcLoc.lhs
compiler/ghc.cabal.in
compiler/ghci/Debugger.hs
compiler/main/DriverMkDepend.hs
compiler/main/DriverPipeline.hs
compiler/main/ErrUtils.lhs
compiler/main/GHC.hs
compiler/main/GhcMonad.hs [new file with mode: 0644]
compiler/main/HeaderInfo.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/InteractiveEval.hs
compiler/rename/RnNames.lhs
compiler/simplCore/CoreMonad.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcSplice.lhs
compiler/utils/MonadUtils.hs
compiler/utils/StringBuffer.lhs
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Monad.hs
ghc/GhciMonad.hs
ghc/InteractiveUI.hs
ghc/Main.hs

index d912beb..06f8ec8 100644 (file)
@@ -165,11 +165,11 @@ instance Ord SrcLoc where
    
 cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
 cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
-cmpSrcLoc (UnhelpfulLoc _)  _other            = LT
+cmpSrcLoc (UnhelpfulLoc _)  (SrcLoc _ _ _)    = GT
+cmpSrcLoc (SrcLoc _ _ _)    (UnhelpfulLoc _)  = LT
 
 cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)      
   = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
-cmpSrcLoc (SrcLoc _ _ _) _other = GT
 
 instance Outputable SrcLoc where
     ppr (SrcLoc src_path src_line src_col)
index a7f5242..0711a93 100644 (file)
@@ -152,6 +152,7 @@ Library
         DataCon
         Demand
         Exception
+        GhcMonad
         Id
         IdInfo
         Literal
index 9f38313..141a513 100644 (file)
@@ -15,23 +15,20 @@ module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
 import Linker
 import RtClosureInspect
 
+import GhcMonad
 import HscTypes
 import Id
 import Name
 import Var hiding ( varName )
 import VarSet
--- import Name 
 import UniqSupply
 import TcType
 import GHC
--- import DynFlags
 import InteractiveEval
 import Outputable
--- import SrcLoc
 import PprTyThing
 import MonadUtils
 
--- import Exception
 import Control.Monad
 import Data.List
 import Data.Maybe
index 48617ec..e430c6e 100644 (file)
@@ -17,6 +17,7 @@ module DriverMkDepend (
 
 import qualified GHC
 -- import GHC              ( ModSummary(..), GhcMonad )
+import GhcMonad
 import HsSyn            ( ImportDecl(..) )
 import DynFlags
 import Util
index 1c29c7f..9b57c4d 100644 (file)
@@ -49,7 +49,7 @@ import ParserCoreUtils  ( getCoreModuleName )
 import SrcLoc
 import FastString
 import LlvmCodeGen      ( llvmFixupAsm )
--- import MonadUtils
+import MonadUtils
 
 -- import Data.Either
 import Exception
@@ -73,10 +73,9 @@ import System.Environment
 -- We return the augmented DynFlags, because they contain the result
 -- of slurping in the OPTIONS pragmas
 
-preprocess :: GhcMonad m =>
-              HscEnv
+preprocess :: HscEnv
            -> (FilePath, Maybe Phase) -- ^ filename and starting phase
-           -> m (DynFlags, FilePath)
+           -> IO (DynFlags, FilePath)
 preprocess hsc_env (filename, mb_phase) =
   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
   runPipeline anyHsc hsc_env (filename, mb_phase)
@@ -90,37 +89,33 @@ preprocess hsc_env (filename, mb_phase) =
 --
 -- This is the interface between the compilation manager and the
 -- compiler proper (hsc), where we deal with tedious details like
--- reading the OPTIONS pragma from the source file, and passing the
--- output of hsc through the C compiler.
+-- reading the OPTIONS pragma from the source file, converting the
+-- C or assembly that GHC produces into an object file, and compiling
+-- FFI stub files.
 --
 -- NB.  No old interface can also mean that the source has changed.
 
-compile :: GhcMonad m =>
-           HscEnv
+compile :: HscEnv
         -> ModSummary      -- ^ summary for module being compiled
         -> Int             -- ^ module N ...
         -> Int             -- ^ ... of M
         -> Maybe ModIface  -- ^ old interface, if we have one
         -> Maybe Linkable  -- ^ old linkable, if we have one
-        -> m HomeModInfo   -- ^ the complete HomeModInfo, if successful
+        -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
 
 compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch)
 
-type Compiler m a = HscEnv -> ModSummary -> Bool
-                  -> Maybe ModIface -> Maybe (Int, Int)
-                  -> m a
-
-compile' :: GhcMonad m =>
-           (Compiler m (HscStatus, ModIface, ModDetails),
-            Compiler m (InteractiveStatus, ModIface, ModDetails),
-            Compiler m (HscStatus, ModIface, ModDetails))
+compile' :: 
+           (Compiler (HscStatus, ModIface, ModDetails),
+            Compiler (InteractiveStatus, ModIface, ModDetails),
+            Compiler (HscStatus, ModIface, ModDetails))
         -> HscEnv
         -> ModSummary      -- ^ summary for module being compiled
         -> Int             -- ^ module N ...
         -> Int             -- ^ ... of M
         -> Maybe ModIface  -- ^ old interface, if we have one
         -> Maybe Linkable  -- ^ old linkable, if we have one
-        -> m HomeModInfo   -- ^ the complete HomeModInfo, if successful
+        -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
 
 compile' (nothingCompiler, interactiveCompiler, batchCompiler)
         hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
@@ -132,7 +127,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
        input_fn    = expectJust "compile:hs" (ml_hs_file location)
        input_fnpp  = ms_hspp_file summary
 
-   liftIO $ debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
+   debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
 
    let basename = dropExtension input_fn
 
@@ -151,7 +146,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
    -- ... and what the next phase should be
    let next_phase = hscNextPhase dflags src_flavour hsc_lang
    -- ... and what file to generate the output into
-   output_fn <- liftIO $ getOutputFilename next_phase
+   output_fn <- getOutputFilename next_phase
                         Temporary basename dflags next_phase (Just location)
 
    let dflags' = dflags { hscTarget = hsc_lang,
@@ -193,7 +188,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
                                               Persistent
                                               (Just location)
                                   -- The object filename comes from the ModLocation
-                                  o_time <- liftIO $ getModificationTime object_filename
+                                  o_time <- getModificationTime object_filename
                                   return ([DotO object_filename], o_time)
                     let linkable = LM unlinked_time this_mod
                                    (hs_unlinked ++ stub_unlinked)
@@ -231,13 +226,9 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
                                      hm_linkable = linkable })
    -- run the compiler
    case hsc_lang of
-      HscInterpreted ->
-                runCompiler interactiveCompiler handleInterpreted
-      HscNothing ->
-                runCompiler nothingCompiler handleBatch
-      _other ->
-                runCompiler batchCompiler handleBatch
-
+      HscInterpreted -> runCompiler interactiveCompiler handleInterpreted
+      HscNothing     -> runCompiler nothingCompiler     handleBatch
+      _other         -> runCompiler batchCompiler       handleBatch
 
 -----------------------------------------------------------------------------
 -- stub .h and .c files (for foreign export support)
@@ -258,8 +249,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
 -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want
 -- obj/A_stub.o.
 
-compileStub :: GhcMonad m => HscEnv -> Module -> ModLocation
-            -> m FilePath
+compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath
 compileStub hsc_env mod location = do
         -- compile the _stub.c file w/ gcc
         let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env)
@@ -415,16 +405,14 @@ findHSLib dirs lib = do
 -- -----------------------------------------------------------------------------
 -- Compile files in one-shot mode.
 
-oneShot :: GhcMonad m =>
-           HscEnv -> Phase -> [(String, Maybe Phase)] -> m ()
+oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
 oneShot hsc_env stop_phase srcs = do
   o_files <- mapM (compileFile hsc_env stop_phase) srcs
-  liftIO $ doLink (hsc_dflags hsc_env) stop_phase o_files
+  doLink (hsc_dflags hsc_env) stop_phase o_files
 
-compileFile :: GhcMonad m =>
-               HscEnv -> Phase -> (FilePath, Maybe Phase) -> m FilePath
+compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
 compileFile hsc_env stop_phase (src, mb_phase) = do
-   exists <- liftIO $ doesFileExist src
+   exists <- doesFileExist src
    when (not exists) $
         ghcError (CmdLineError ("does not exist: " ++ src))
 
@@ -489,14 +477,13 @@ data PipelineOutput
 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
 -- pipeline.
 runPipeline
-  :: GhcMonad m =>
-     Phase                      -- ^ When to stop
+  :: Phase                      -- ^ When to stop
   -> HscEnv                     -- ^ Compilation environment
   -> (FilePath,Maybe Phase)     -- ^ Input filename (and maybe -x suffix)
   -> Maybe FilePath             -- ^ original basename (if different from ^^^)
   -> PipelineOutput             -- ^ Output filename
   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
-  -> m (DynFlags, FilePath)     -- ^ (final flags, output filename)
+  -> IO (DynFlags, FilePath)     -- ^ (final flags, output filename)
 
 runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
   = do
@@ -542,7 +529,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo
   case output of
     Temporary ->
         return (dflags', output_fn)
-    _other -> liftIO $
+    _other -> 
         do final_fn <- get_output_fn dflags' stop_phase maybe_loc
            when (final_fn /= output_fn) $ do
               let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
@@ -552,12 +539,11 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo
 
 
 
-pipeLoop :: GhcMonad m =>
-            HscEnv -> Phase -> Phase
+pipeLoop :: HscEnv -> Phase -> Phase
          -> FilePath  -> String -> Suffix
          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
          -> Maybe ModLocation
-         -> m (DynFlags, FilePath, Maybe ModLocation)
+         -> IO (DynFlags, FilePath, Maybe ModLocation)
 
 pipeLoop hsc_env phase stop_phase
          input_fn orig_basename orig_suff
@@ -575,8 +561,8 @@ pipeLoop hsc_env phase stop_phase
            " but I wanted to stop at phase " ++ show stop_phase)
 
   | otherwise
-  = do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
-                              (ptext (sLit "Running phase") <+> ppr phase)
+  = do debugTraceMsg (hsc_dflags hsc_env) 4
+                         (ptext (sLit "Running phase") <+> ppr phase)
        (next_phase, dflags', maybe_loc, output_fn)
           <- runPhase phase stop_phase hsc_env orig_basename
                       orig_suff input_fn orig_get_output_fn maybe_loc
@@ -645,8 +631,7 @@ getOutputFilename stop_phase output basename
 -- of a source file can change the latter stages of the pipeline from
 -- taking the via-C route to using the native code generator.
 --
-runPhase :: GhcMonad m =>
-            Phase       -- ^ Do this phase first
+runPhase :: Phase       -- ^ Do this phase first
          -> Phase       -- ^ Stop just before this phase
          -> HscEnv
          -> String      -- ^ basename of original input source
@@ -655,10 +640,10 @@ runPhase :: GhcMonad m =>
          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
                         -- ^ how to calculate the output filename
          -> Maybe ModLocation           -- ^ the ModLocation, if we have one
-         -> m (Phase,                   -- next phase
-               DynFlags,                -- new dynamic flags
-               Maybe ModLocation,       -- the ModLocation, if we have one
-               FilePath)                -- output filename
+         -> IO (Phase,                   -- next phase
+                DynFlags,                -- new dynamic flags
+                Maybe ModLocation,       -- the ModLocation, if we have one
+                FilePath)                -- output filename
 
         -- Invariant: the output filename always contains the output
         -- Interesting case: Hsc when there is no recompilation to do
@@ -670,7 +655,7 @@ runPhase :: GhcMonad m =>
 runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do
        let dflags = hsc_dflags hsc_env
-       output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc
+       output_fn <- get_output_fn dflags (Cpp sf) maybe_loc
 
        let unlit_flags = getOpts dflags opt_L
            flags = map SysTools.Option unlit_flags ++
@@ -684,7 +669,7 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
                    , SysTools.FileOption "" output_fn
                    ]
 
-       liftIO $ SysTools.runUnlit dflags flags
+       SysTools.runUnlit dflags flags
 
        return (Cpp sf, dflags, maybe_loc, output_fn)
 
@@ -694,9 +679,9 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
 
 runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do let dflags0 = hsc_dflags hsc_env
-       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
+       src_opts <- getOptionsFromFile dflags0 input_fn
        (dflags1, unhandled_flags, warns)
-           <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
+           <- parseDynamicNoPackageFlags dflags0 src_opts
        checkProcessArgsResult unhandled_flags
 
        if not (xopt Opt_Cpp dflags1) then do
@@ -707,13 +692,13 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
            -- to the next phase of the pipeline.
            return (HsPp sf, dflags1, maybe_loc, input_fn)
         else do
-            output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc
-            liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
+            output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc
+            doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
             -- re-read the pragmas now that we've preprocessed the file
             -- See #2464,#3457
-            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
+            src_opts <- getOptionsFromFile dflags0 output_fn
             (dflags2, unhandled_flags, warns)
-                <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
+                <- parseDynamicNoPackageFlags dflags0 src_opts
             unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
             -- the HsPp pass below will emit warnings
             checkProcessArgsResult unhandled_flags
@@ -732,8 +717,8 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
         else do
             let hspp_opts = getOpts dflags opt_F
             let orig_fn = basename <.> suff
-            output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc
-            liftIO $ SysTools.runPp dflags
+            output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
+            SysTools.runPp dflags
                            ( [ SysTools.Option     orig_fn
                              , SysTools.Option     input_fn
                              , SysTools.FileOption "" output_fn
@@ -742,9 +727,9 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
                            )
 
             -- re-read pragmas now that we've parsed the file (see #3674)
-            src_opts <- liftIO $ getOptionsFromFile dflags output_fn
+            src_opts <- getOptionsFromFile dflags output_fn
             (dflags1, unhandled_flags, warns)
-                <- liftIO $ parseDynamicNoPackageFlags dflags src_opts
+                <- parseDynamicNoPackageFlags dflags src_opts
             handleFlagWarnings dflags1 warns
             checkProcessArgsResult unhandled_flags
 
@@ -773,11 +758,11 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
         (hspp_buf,mod_name,imps,src_imps) <-
             case src_flavour of
                 ExtCoreFile -> do  -- no explicit imports in ExtCore input.
-                    m <- liftIO $ getCoreModuleName input_fn
+                    m <- getCoreModuleName input_fn
                     return (Nothing, mkModuleName m, [], [])
 
                 _           -> do
-                    buf <- liftIO $ hGetStringBuffer input_fn
+                    buf <- hGetStringBuffer input_fn
                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
                     return (Just buf, mod_name, imps, src_imps)
 
@@ -787,7 +772,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
   -- the .hi and .o filenames, and this is as good a way
   -- as any to generate them, and better than most. (e.g. takes
   -- into accout the -osuf flags)
-        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
+        location1 <- mkHomeModLocation2 dflags mod_name basename suff
 
   -- Boot-ify it if necessary
         let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
@@ -822,7 +807,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
   -- changed (which the compiler itself figures out).
   -- Setting source_unchanged to False tells the compiler that M.o is out of
   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
-        src_timestamp <- liftIO $ getModificationTime (basename <.> suff)
+        src_timestamp <- getModificationTime (basename <.> suff)
 
         let force_recomp = dopt Opt_ForceRecomp dflags
             hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
@@ -833,17 +818,17 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
              then return False
                 -- Otherwise look at file modification dates
-             else do o_file_exists <- liftIO $ doesFileExist o_file
+             else do o_file_exists <- doesFileExist o_file
                      if not o_file_exists
                         then return False       -- Need to recompile
-                        else do t2 <- liftIO $ getModificationTime o_file
+                        else do t2 <- getModificationTime o_file
                                 if t2 > src_timestamp
                                   then return True
                                   else return False
 
   -- get the DynFlags
         let next_phase = hscNextPhase dflags src_flavour hsc_lang
-        output_fn  <- liftIO $ get_output_fn dflags next_phase (Just location4)
+        output_fn  <- get_output_fn dflags next_phase (Just location4)
 
         let dflags' = dflags { hscTarget = hsc_lang,
                                hscOutName = output_fn,
@@ -852,7 +837,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 
   -- Tell the finder cache about this module
-        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4
+        mod <- addHomeModuleToFinder hsc_env' mod_name location4
 
   -- Make the ModSummary to hand to hscMain
         let
@@ -875,7 +860,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
 
         case result of
           HscNoRecomp
-              -> do liftIO $ SysTools.touch dflags' "Touching object file" o_file
+              -> do SysTools.touch dflags' "Touching object file" o_file
                     -- The .o file must have a later modification date
                     -- than the source file (else we wouldn't be in HscNoRecomp)
                     -- but we touch it anyway, to keep 'make' happy (we think).
@@ -887,7 +872,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
                     -- In the case of hs-boot files, generate a dummy .o-boot
                     -- stamp file for the benefit of Make
                     when (isHsBoot src_flavour) $
-                      liftIO $ SysTools.touch dflags' "Touching object file" o_file
+                      SysTools.touch dflags' "Touching object file" o_file
                     return (next_phase, dflags', Just location4, output_fn)
 
 -----------------------------------------------------------------------------
@@ -896,8 +881,8 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do
        let dflags = hsc_dflags hsc_env
-       output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc
-       liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
+       output_fn <- get_output_fn dflags Cmm maybe_loc
+       doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
        return (Cmm, dflags, maybe_loc, output_fn)
 
 runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
@@ -905,14 +890,14 @@ runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
         let dflags = hsc_dflags hsc_env
         let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
-        output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
+        output_fn <- get_output_fn dflags next_phase maybe_loc
 
         let dflags' = dflags { hscTarget = hsc_lang,
                                hscOutName = output_fn,
                                extCoreName = basename ++ ".hcr" }
         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 
-        hscCmmFile hsc_env' input_fn
+        hscCompileCmmFile hsc_env' input_fn
 
         -- XXX: catch errors above and convert them into ghcError?  Original
         -- code was:
@@ -936,17 +921,17 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
         let cmdline_include_paths = includePaths dflags
 
         -- HC files have the dependent packages stamped into them
-        pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return []
+        pkgs <- if hcc then getHCFilePackages input_fn else return []
 
         -- add package include paths even if we're just compiling .c
         -- files; this is the Value Add(TM) that using ghc instead of
         -- gcc gives you :)
-        pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
+        pkg_include_dirs <- getPackageIncludePath dflags pkgs
         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
                               (cmdline_include_paths ++ pkg_include_dirs)
 
         let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
-        gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags
+        gcc_extra_viac_flags <- getExtraViaCOpts dflags
         let pic_c_flags = picCCOpts dflags
 
         let verb = getVerbFlag dflags
@@ -957,10 +942,10 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
         pkg_extra_cc_opts <-
           if cc_phase `eqPhase` HCc
              then return []
-             else liftIO $ getPackageExtraCcOpts dflags pkgs
+             else getPackageExtraCcOpts dflags pkgs
 
 #ifdef darwin_TARGET_OS
-        pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs
+        pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
         let cmdline_framework_paths = frameworkPaths dflags
         let framework_paths = map ("-F"++)
                         (cmdline_framework_paths ++ pkg_framework_paths)
@@ -979,7 +964,7 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
             next_phase
                 | hcc && mangle     = Mangle
                 | otherwise         = As
-        output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
+        output_fn <- get_output_fn dflags next_phase maybe_loc
 
         let
           more_hcc_opts =
@@ -999,7 +984,7 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
                 -- very weakly typed, being derived from C--.
                 ["-fno-strict-aliasing"]
 
-        liftIO $ SysTools.runCc dflags (
+        SysTools.runCc dflags (
                 -- force the C compiler to interpret this file as C when
                 -- compiling .hc files, by adding the -x c option.
                 -- Also useful for plain .c files, just in case GHC saw a
@@ -1080,9 +1065,9 @@ runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
             next_phase
                 | split = SplitMangle
                 | otherwise = As
-        output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
+        output_fn <- get_output_fn dflags next_phase maybe_loc
 
-        liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts
+        SysTools.runMangle dflags (map SysTools.Option mangler_opts
                           ++ [ SysTools.FileOption "" input_fn
                              , SysTools.FileOption "" output_fn
                              ]
@@ -1094,8 +1079,7 @@ runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 -- Splitting phase
 
 runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
-  = liftIO $
-    do  -- tmp_pfx is the prefix used for the split .s files
+  = do  -- tmp_pfx is the prefix used for the split .s files
         -- We also use it as the file to contain the no. of split .s files (sigh)
         let dflags = hsc_dflags hsc_env
         split_s_prefix <- SysTools.newTempName dflags "split"
@@ -1123,8 +1107,7 @@ runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe
 -- As phase
 
 runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
-  = liftIO $
-    do  let dflags = hsc_dflags hsc_env
+  = do  let dflags = hsc_dflags hsc_env
         let as_opts =  getOpts dflags opt_a
         let cmdline_include_paths = includePaths dflags
 
@@ -1159,7 +1142,7 @@ runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 
 
 runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
-  = liftIO $ do
+  = do
         let dflags = hsc_dflags hsc_env
         output_fn <- get_output_fn dflags StopLn maybe_loc
 
@@ -1207,36 +1190,16 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
 
         mapM_ assemble_file [1..n]
 
-        -- and join the split objects into a single object file:
-        let ld_r args = SysTools.runLink dflags ([
-                            SysTools.Option "-nostdlib",
-                            SysTools.Option "-nodefaultlibs",
-                            SysTools.Option "-Wl,-r",
-                            SysTools.Option ld_x_flag,
-                            SysTools.Option "-o",
-                            SysTools.FileOption "" output_fn ]
-                         ++ map SysTools.Option md_c_flags
-                         ++ args)
-            ld_x_flag | null cLD_X = ""
-                      | otherwise  = "-Wl,-x"
-
-        if cLdIsGNULd == "YES"
-            then do
-                  let script = split_odir </> "ld.script"
-                  writeFile script $
-                      "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
-                  ld_r [SysTools.FileOption "" script]
-            else do
-                  ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
+        -- join them into a single .o file
+        joinObjectFiles dflags (map split_obj [1..n]) output_fn
 
         return (StopLn, dflags, maybe_loc, output_fn)
 
-
 -----------------------------------------------------------------------------
 -- LlvmOpt phase
 
 runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
-  = liftIO $ do
+  = do
     let dflags  = hsc_dflags hsc_env
     let lo_opts = getOpts dflags opt_lo
     let opt_lvl = max 0 (min 2 $ optLevel dflags)
@@ -1268,7 +1231,7 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 -- LlvmLlc phase
 
 runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
-  = liftIO $ do
+  = do
     let dflags  = hsc_dflags hsc_env
     let lc_opts = getOpts dflags opt_lc
     let opt_lvl = max 0 (min 2 $ optLevel dflags)
@@ -1303,7 +1266,7 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 -- LlvmMangle phase
 
 runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
-  = liftIO $ do
+  = do
     let dflags = hsc_dflags hsc_env
     output_fn <- get_output_fn dflags As maybe_loc
     llvmFixupAsm input_fn output_fn
@@ -1865,6 +1828,32 @@ hsSourceCppOpts :: [String]
 hsSourceCppOpts =
         [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 
+-- ---------------------------------------------------------------------------
+-- join object files into a single relocatable object file, using ld -r
+
+joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
+joinObjectFiles dflags o_files output_fn = do
+  let ld_r args = SysTools.runLink dflags ([
+                            SysTools.Option "-nostdlib",
+                            SysTools.Option "-nodefaultlibs",
+                            SysTools.Option "-Wl,-r",
+                            SysTools.Option ld_x_flag,
+                            SysTools.Option "-o",
+                            SysTools.FileOption "" output_fn ]
+                         ++ map SysTools.Option md_c_flags
+                         ++ args)
+      ld_x_flag | null cLD_X = ""
+                | otherwise  = "-Wl,-x"
+
+      (md_c_flags, _) = machdepCCOpts dflags
+  
+  if cLdIsGNULd == "YES"
+     then do
+          script <- newTempName dflags "ldscript"
+          writeFile script $ "INPUT(" ++ unwords o_files ++ ")"
+          ld_r [SysTools.FileOption "" script]
+     else do
+          ld_r (map (SysTools.FileOption "") o_files)
 
 -- -----------------------------------------------------------------------------
 -- Misc.
index 3ab89bd..15b142b 100644 (file)
@@ -13,7 +13,7 @@ module ErrUtils (
         errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
        Messages, errorsFound, emptyMessages,
        mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
-       printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+       printBagOfErrors, printBagOfWarnings,
        warnIsErrorMsg, mkLongWarnMsg,
 
        ghcExit,
@@ -39,7 +39,6 @@ import SrcLoc
 import DynFlags                ( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags     ( opt_ErrorSpans )
 
-import Control.Monad
 import System.Exit     ( ExitCode(..), exitWith )
 import Data.List
 import System.IO
@@ -126,56 +125,29 @@ emptyMessages :: Messages
 emptyMessages = (emptyBag, emptyBag)
 
 warnIsErrorMsg :: ErrMsg
-warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n")
+warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
 
 errorsFound :: DynFlags -> Messages -> Bool
--- The dyn-flags are used to see if the user has specified
--- -Werror, which says that warnings should be fatal
-errorsFound dflags (warns, errs) 
-  | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
-  | otherwise                          = not (isEmptyBag errs)
-
-printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
-printErrorsAndWarnings dflags (warns, errs)
-  | no_errs && no_warns = return ()
-  | no_errs             = do printBagOfWarnings dflags warns
-                             when (dopt Opt_WarnIsError dflags) $
-                                 errorMsg dflags $
-                                     text "\nFailing due to -Werror.\n"
-                          -- Don't print any warnings if there are errors
-  | otherwise           = printBagOfErrors dflags errs
-  where
-    no_warns = isEmptyBag warns
-    no_errs  = isEmptyBag errs
+errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
-printBagOfErrors dflags bag_of_errors
-  = sequence_   [ let style = mkErrStyle unqual
-                 in log_action dflags SevError s style (d $$ e)
-               | ErrMsg { errMsgSpans = s:_,
-                          errMsgShortDoc = d,
-                          errMsgExtraInfo = e,
-                          errMsgContext = unqual } <- sorted_errs ]
-    where
-      bag_ls     = bagToList bag_of_errors
-      sorted_errs = sortLe occ'ed_before bag_ls
+printBagOfErrors dflags bag_of_errors = 
+  printMsgBag dflags bag_of_errors SevError
 
-      occ'ed_before err1 err2 = 
-         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
-               LT -> True
-               EQ -> True
-               GT -> False
+printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
+printBagOfWarnings dflags bag_of_warns = 
+  printMsgBag dflags bag_of_warns SevWarning
 
-printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
-printBagOfWarnings dflags bag_of_warns
+printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
+printMsgBag dflags bag sev
   = sequence_   [ let style = mkErrStyle unqual
-                 in log_action dflags SevWarning s style (d $$ e)
+                 in log_action dflags sev s style (d $$ e)
                | ErrMsg { errMsgSpans = s:_,
                           errMsgShortDoc = d,
                           errMsgExtraInfo = e,
                           errMsgContext = unqual } <- sorted_errs ]
     where
-      bag_ls     = bagToList bag_of_warns
+      bag_ls     = bagToList bag
       sorted_errs = sortLe occ'ed_before bag_ls
 
       occ'ed_before err1 err2 = 
index 638e1db..e1bc5de 100644 (file)
@@ -15,9 +15,9 @@ module GHC (
         Ghc, GhcT, GhcMonad(..),
         runGhc, runGhcT, initGhcMonad,
         gcatch, gbracket, gfinally,
-        clearWarnings, getWarnings, hasWarnings,
-        printExceptionAndWarnings, printWarnings,
-        handleSourceError, defaultCallbacks, GhcApiCallbacks(..),
+        printException,
+        printExceptionAndWarnings,
+        handleSourceError,
         needsTemplateHaskell,
 
        -- * Flags and settings
@@ -38,7 +38,7 @@ module GHC (
        
        -- * Loading\/compiling the program
        depanal,
-       load, loadWithLogger, LoadHowMuch(..),
+       load, LoadHowMuch(..),
        SuccessFlag(..), succeeded, failed,
         defaultWarnErrLogger, WarnErrLogger,
        workingDirectoryChanged,
@@ -217,6 +217,9 @@ module GHC (
         getTokenStream, getRichTokenStream,
         showRichTokenStream, addSourceToTokens,
 
+        -- * Pure interface to the parser
+        parser,
+
        -- * Miscellaneous
        --sessionHscEnv,
        cyclicModuleErr,
@@ -239,7 +242,7 @@ import BreakArray
 import InteractiveEval
 #endif
 
-import TcRnDriver
+import GhcMonad
 import TcIface
 import TcRnTypes
 import TcRnMonad        ( initIfaceCheck )
@@ -260,11 +263,9 @@ import Class
 import DataCon
 import Name             hiding ( varName )
 -- import OccName              ( parenSymOcc )
-import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
-                          emptyInstEnv )
-import FamInstEnv       ( emptyFamInstEnv )
+import InstEnv
 import SrcLoc
---import CoreSyn
+import CoreSyn          ( CoreBind )
 import TidyPgm
 import DriverPipeline
 import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
@@ -282,15 +283,16 @@ import Module
 import UniqFM
 import Panic
 import Digraph
-import Bag             ( unitBag, listToBag, emptyBag, isEmptyBag )
+import Bag             ( unitBag, listToBag )
 import ErrUtils
 import MonadUtils
 import Util
-import StringBuffer    ( StringBuffer, hGetStringBuffer, nextChar )
+import StringBuffer
 import Outputable
 import BasicTypes
 import Maybes          ( expectJust, mapCatMaybes )
 import FastString
+import qualified Parser
 import Lexer
 
 import System.Directory ( getModificationTime, doesFileExist,
@@ -373,28 +375,14 @@ defaultCleanupHandler dflags inner =
 
 -- | Print the error message and all warnings.  Useful inside exception
 --   handlers.  Clears warnings after printing.
+printException :: GhcMonad m => SourceError -> m ()
+printException err = do
+  dflags <- getSessionDynFlags
+  liftIO $ printBagOfErrors dflags (srcErrorMessages err)
+
+{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-}
 printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
-printExceptionAndWarnings err = do
-    let errs = srcErrorMessages err
-    warns <- getWarnings
-    dflags <- getSessionDynFlags
-    if isEmptyBag errs
-       -- Empty errors means we failed due to -Werror.  (Since this function
-       -- takes a source error as argument, we know for sure _some_ error
-       -- did indeed happen.)
-       then liftIO $ do
-              printBagOfWarnings dflags warns
-              printBagOfErrors dflags (unitBag warnIsErrorMsg)
-       else liftIO $ printBagOfErrors dflags errs
-    clearWarnings
-
--- | Print all accumulated warnings using 'log_action'.
-printWarnings :: GhcMonad m => m ()
-printWarnings = do
-    dflags <- getSessionDynFlags
-    warns <- getWarnings
-    liftIO $ printBagOfWarnings dflags warns
-    clearWarnings
+printExceptionAndWarnings = printException
 
 -- | Run function for the 'Ghc' monad.
 --
@@ -409,9 +397,8 @@ runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> Ghc a           -- ^ The action to perform.
        -> IO a
 runGhc mb_top_dir ghc = do
-  wref <- newIORef emptyBag
   ref <- newIORef undefined
-  let session = Session ref wref
+  let session = Session ref
   flip unGhc session $ do
     initGhcMonad mb_top_dir
     ghc
@@ -428,9 +415,8 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
         -> GhcT m a        -- ^ The action to perform.
         -> m a
 runGhcT mb_top_dir ghct = do
-  wref <- liftIO $ newIORef emptyBag
   ref <- liftIO $ newIORef undefined
-  let session = Session ref wref
+  let session = Session ref
   flip unGhcT session $ do
     initGhcMonad mb_top_dir
     ghct
@@ -456,24 +442,12 @@ initGhcMonad mb_top_dir = do
 
   dflags0 <- liftIO $ initDynFlags defaultDynFlags
   dflags <- liftIO $ initSysTools mb_top_dir dflags0
-  env <- liftIO $ newHscEnv defaultCallbacks dflags
+  env <- liftIO $ newHscEnv dflags
   setSession env
-  clearWarnings
-
-defaultCallbacks :: GhcApiCallbacks
-defaultCallbacks =
-  GhcApiCallbacks {
-    reportModuleCompilationResult =
-        \_ mb_err -> defaultWarnErrLogger mb_err
-  }
 
 -- -----------------------------------------------------------------------------
 -- Flags & settings
 
--- | Grabs the DynFlags from the Session
-getSessionDynFlags :: GhcMonad m => m DynFlags
-getSessionDynFlags = withSession (return . hsc_dflags)
-
 -- | Updates the DynFlags in a Session.  This also reads
 -- the package database (unless it has already been read),
 -- and prepares the compilers knowledge about packages.  It
@@ -620,7 +594,7 @@ depanal excluded_mods allow_dup_roots = do
             text "Chasing modules from: ",
             hcat (punctuate comma (map pprTarget targets))])
 
-  mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
+  mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots
   modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
   return mod_graph
 
@@ -657,29 +631,8 @@ load how_much = do
 type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
 
 defaultWarnErrLogger :: WarnErrLogger
-defaultWarnErrLogger Nothing = printWarnings
-defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
-
--- | Try to load the program.  If a Module is supplied, then just
--- attempt to load up to this target.  If no Module is supplied,
--- then try to load all targets.
---
--- The first argument is a function that is called after compiling each
--- module to print wanrings and errors.
---
--- While compiling a module, all 'SourceError's are caught and passed to the
--- logger, however, this function may still throw a 'SourceError' if
--- dependency analysis failed (e.g., due to a parse error).
---
-loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
-loadWithLogger logger how_much = do
-    -- Dependency analysis first.  Note that this fixes the module graph:
-    -- even if we don't get a fully successful upsweep, the full module
-    -- graph is still retained in the Session.  We can tell which modules
-    -- were successfully loaded by inspecting the Session's HPT.
-    withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult =
-                                          \_ -> logger }) $
-      load how_much
+defaultWarnErrLogger Nothing  = return ()
+defaultWarnErrLogger (Just e) = printException e
 
 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
       -> m SuccessFlag
@@ -809,9 +762,10 @@ load2 how_much mod_graph = do
 
        liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
                                   2 (ppr mg))
-        (upsweep_ok, hsc_env1, modsUpswept)
-           <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
-                     pruned_hpt stable_mods cleanup mg
+
+        setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
+        (upsweep_ok, modsUpswept)
+           <- upsweep pruned_hpt stable_mods cleanup mg
 
        -- Make modsDone be the summaries for each home module now
        -- available; this should equal the domain of hpt3.
@@ -853,9 +807,10 @@ load2 how_much mod_graph = do
                           moduleNameString (moduleName main_mod) ++ " module.")
 
              -- link everything together
+              hsc_env1 <- getSession
               linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
 
-             loadFinish Succeeded linkresult hsc_env1
+             loadFinish Succeeded linkresult
 
          else 
            -- Tricky.  We need to back out the effects of compiling any
@@ -872,6 +827,7 @@ load2 how_much mod_graph = do
                      = filter ((`notElem` mods_to_zap_names).ms_mod) 
                          modsDone
 
+              hsc_env1 <- getSession
               let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) 
                                              (hsc_HPT hsc_env1)
 
@@ -885,24 +841,25 @@ load2 how_much mod_graph = do
              -- Link everything together
               linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
 
-             let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
-             loadFinish Failed linkresult hsc_env4
+              modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
+             loadFinish Failed linkresult
 
 -- Finish up after a load.
 
 -- If the link failed, unload everything and return.
 loadFinish :: GhcMonad m =>
-              SuccessFlag -> SuccessFlag -> HscEnv
+              SuccessFlag -> SuccessFlag
            -> m SuccessFlag
-loadFinish _all_ok Failed hsc_env
-  = do liftIO $ unload hsc_env []
-       modifySession $ \_ -> discardProg hsc_env
+loadFinish _all_ok Failed
+  = do hsc_env <- getSession
+       liftIO $ unload hsc_env []
+       modifySession discardProg
        return Failed
 
 -- Empty the interactive context and set the module context to the topmost
 -- newly loaded module, or the Prelude if none were loaded.
-loadFinish all_ok Succeeded hsc_env
-  = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
+loadFinish all_ok Succeeded
+  = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }
        return all_ok
 
 
@@ -1026,9 +983,9 @@ getModSummary mod = do
 -- Throws a 'SourceError' on parse error.
 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
 parseModule ms = do
-   rdr_module <- withTempSession
-                     (\e -> e { hsc_dflags = ms_hspp_opts ms }) $
-                   hscParse ms
+   hsc_env <- getSession
+   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+   rdr_module <- liftIO $ hscParse hsc_env_tmp ms
    return (ParsedModule ms rdr_module)
 
 -- | Typecheck and rename a parsed module.
@@ -1037,11 +994,12 @@ parseModule ms = do
 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
 typecheckModule pmod = do
  let ms = modSummary pmod
- withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
-   (tc_gbl_env, rn_info)
-       <- hscTypecheckRename ms (parsedSource pmod)
-   details <- makeSimpleDetails tc_gbl_env
-   return $
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ (tc_gbl_env, rn_info)
+       <- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod)
+ details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
+ return $
      TypecheckedModule {
        tm_internals_          = (tc_gbl_env, details),
        tm_parsed_module       = pmod,
@@ -1062,10 +1020,11 @@ typecheckModule pmod = do
 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
 desugarModule tcm = do
  let ms = modSummary tcm
- withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
-   let (tcg, _) = tm_internals tcm
-   guts <- hscDesugar ms tcg
-   return $
+ let (tcg, _) = tm_internals tcm
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
+ return $
      DesugaredModule {
        dm_typechecked_module = tcm,
        dm_core_module        = guts
@@ -1086,32 +1045,44 @@ loadModule tcm = do
    let mod = ms_mod_name ms
    let loc = ms_location ms
    let (tcg, _details) = tm_internals tcm
-   hpt_new <-
-       withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
 
-         let compilerBackend comp env ms' _ _mb_old_iface _ =
-               withTempSession (\_ -> env) $
-                 hscBackend comp tcg ms' Nothing
-
-         hsc_env <- getSession
-         mod_info <- do
-             mb_linkable <- 
-                  case ms_obj_date ms of
+   mb_linkable <- case ms_obj_date ms of
                      Just t | t > ms_hs_date ms  -> do
                          l <- liftIO $ findObjectLinkable (ms_mod ms) 
                                                   (ml_obj_file loc) t
                          return (Just l)
                      _otherwise -> return Nothing
                                                 
-             compile' (compilerBackend hscNothingCompiler
-                      ,compilerBackend hscInteractiveCompiler
-                      ,hscCheckRecompBackend hscBatchCompiler tcg)
-                      hsc_env ms 1 1 Nothing mb_linkable
-         -- compile' shouldn't change the environment
-         return $ addToUFM (hsc_HPT hsc_env) mod mod_info
-   modifySession $ \e -> e{ hsc_HPT = hpt_new }
+   -- compile doesn't change the session
+   hsc_env <- getSession
+   mod_info <- liftIO $ compile' (hscNothingBackendOnly     tcg,
+                                  hscInteractiveBackendOnly tcg,
+                                  hscBatchBackendOnly       tcg)
+                                  hsc_env ms 1 1 Nothing mb_linkable
+
+   modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
    return tcm
 
+-- -----------------------------------------------------------------------------
+-- Operations dealing with Core
+
+-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
+-- the 'GHC.compileToCoreModule' interface.
+data CoreModule
+  = CoreModule {
+      -- | Module name
+      cm_module   :: !Module,
+      -- | Type environment for types declared in this module
+      cm_types    :: !TypeEnv,
+      -- | Declarations
+      cm_binds    :: [CoreBind],
+      -- | Imports
+      cm_imports  :: ![Module]
+    }
+
+instance Outputable CoreModule where
+   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) =
+      text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb)
 
 -- | This is the way to get access to the Core bindings corresponding
 -- to a module. 'compileToCore' parses, typechecks, and
@@ -1166,40 +1137,9 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
          ms_hspp_buf = Nothing
       }
 
-  let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
-                              | otherwise = return mod_guts
-  guts <- maybe_simplify (mkModGuts cm)
-  (iface, changed, _details, cgguts)
-      <- hscNormalIface guts Nothing
-  hscWriteIface iface changed modSummary
-  _ <- hscGenHardCode cgguts modSummary
-  return ()
-
--- Makes a "vanilla" ModGuts.
-mkModGuts :: CoreModule -> ModGuts
-mkModGuts coreModule = ModGuts {
-  mg_module = cm_module coreModule,
-  mg_boot = False,
-  mg_exports = [],
-  mg_deps = noDependencies,
-  mg_dir_imps = emptyModuleEnv,
-  mg_used_names = emptyNameSet,
-  mg_rdr_env = emptyGlobalRdrEnv,
-  mg_fix_env = emptyFixityEnv,
-  mg_types = emptyTypeEnv,
-  mg_insts = [],
-  mg_fam_insts = [],
-  mg_rules = [],
-  mg_binds = cm_binds coreModule,
-  mg_foreign = NoStubs,
-  mg_warns = NoWarnings,
-  mg_anns = [],
-  mg_hpc_info = emptyHpcInfo False,
-  mg_modBreaks = emptyModBreaks,
-  mg_vect_info = noVectInfo,
-  mg_inst_env = emptyInstEnv,
-  mg_fam_inst_env = emptyFamInstEnv
-}
+  hsc_env <- getSession
+  liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm)
+
 
 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
 compileCore simplify fn = do
@@ -1222,7 +1162,7 @@ compileCore simplify fn = do
              -- If simplify is true: simplify (hscSimplify), then tidy
              -- (tidyProgram).
              hsc_env <- getSession
-             simpl_guts <- hscSimplify mod_guts
+             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
              tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
              return $ Left tidy_guts
           else
@@ -1435,54 +1375,54 @@ findPartiallyCompletedCycles modsDone theGraph
 -- There better had not be any cyclic groups here -- we check for them.
 
 upsweep
-    :: GhcMonad m =>
-       HscEnv                  -- ^ Includes initially-empty HPT
-    -> HomePackageTable                -- ^ HPT from last time round (pruned)
+    :: GhcMonad m
+    => HomePackageTable                -- ^ HPT from last time round (pruned)
     -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
     -> IO ()                   -- ^ How to clean up unwanted tmp files
     -> [SCC ModSummary]                -- ^ Mods to do (the worklist)
     -> m (SuccessFlag,
-         HscEnv,
-         [ModSummary])
+          [ModSummary])
        -- ^ Returns:
        --
        --  1. A flag whether the complete upsweep was successful.
-       --  2. The 'HscEnv' with an updated HPT
+       --  2. The 'HscEnv' in the monad has an updated HPT
        --  3. A list of modules which succeeded loading.
 
-upsweep hsc_env old_hpt stable_mods cleanup sccs = do
-   (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
-   return (res, hsc_env, reverse done)
+upsweep old_hpt stable_mods cleanup sccs = do
+   (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
+   return (res, reverse done)
  where
 
-  upsweep' hsc_env _old_hpt done
+  upsweep' _old_hpt done
      [] _ _
-   = return (Succeeded, hsc_env, done)
+   = return (Succeeded, done)
 
-  upsweep' hsc_env _old_hpt done
+  upsweep' _old_hpt done
      (CyclicSCC ms:_) _ _
-   = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
-        return (Failed, hsc_env, done)
+   = do dflags <- getSessionDynFlags
+        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
+        return (Failed, done)
 
-  upsweep' hsc_env old_hpt done
+  upsweep' old_hpt done
      (AcyclicSCC mod:mods) mod_index nmods
    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ 
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface) 
        --                     (moduleEnvElts (hsc_HPT hsc_env)))
-        let logger = reportModuleCompilationResult (hsc_callbacks hsc_env)
+        let logger _mod = defaultWarnErrLogger
 
+        hsc_env <- getSession
         mb_mod_info
             <- handleSourceError
                    (\err -> do logger mod (Just err); return Nothing) $ do
-                 mod_info <- upsweep_mod hsc_env old_hpt stable_mods
-                                         mod mod_index nmods
+                 mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
+                                                  mod mod_index nmods
                  logger mod Nothing -- log warnings
                  return (Just mod_info)
 
         liftIO cleanup -- Remove unwanted tmp files between compilations
 
         case mb_mod_info of
-          Nothing -> return (Failed, hsc_env, done)
+          Nothing -> return (Failed, done)
           Just mod_info -> do
                let this_mod = ms_mod_name mod
 
@@ -1505,19 +1445,19 @@ upsweep hsc_env old_hpt stable_mods cleanup sccs = do
                         -- fixup our HomePackageTable after we've finished compiling
                         -- a mutually-recursive loop.  See reTypecheckLoop, below.
                 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
+                setSession hsc_env2
 
-               upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
+               upsweep' old_hpt1 done' mods (mod_index+1) nmods
 
 -- | Compile a single module.  Always produce a Linkable for it if
 -- successful.  If no compilation happened, return the old Linkable.
-upsweep_mod :: GhcMonad m =>
-               HscEnv
+upsweep_mod :: HscEnv
             -> HomePackageTable
            -> ([ModuleName],[ModuleName])
             -> ModSummary
             -> Int  -- index of module
             -> Int  -- total number of modules
-            -> m HomeModInfo
+            -> IO HomeModInfo
 
 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
    =    let 
@@ -1569,13 +1509,15 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                                   where 
                                     iface = hm_iface hm_info
 
-           compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo
-           compile_it  = compile hsc_env summary' mod_index nmods mb_old_iface
+           compile_it :: Maybe Linkable -> IO HomeModInfo
+           compile_it  mb_linkable = 
+                  compile hsc_env summary' mod_index nmods 
+                          mb_old_iface mb_linkable
 
-            compile_it_discard_iface :: GhcMonad m =>
-                                        Maybe Linkable -> m HomeModInfo
-            compile_it_discard_iface 
-                        = compile hsc_env summary' mod_index nmods Nothing
+            compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
+            compile_it_discard_iface mb_linkable =
+                  compile hsc_env summary' mod_index nmods
+                          Nothing mb_linkable
 
             -- With the HscNothing target we create empty linkables to avoid
             -- recompilation.  We have to detect these to recompile anyway if
@@ -1857,7 +1799,7 @@ nodeMapElts = Map.elems
 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
 -- were necessary, then the edge would be part of a cycle.
 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
-warnUnnecessarySourceImports sccs =
+warnUnnecessarySourceImports sccs = do
   logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
   where check ms =
           let mods_in_this_cycle = map ms_mod_name ms in
@@ -1885,22 +1827,19 @@ warnUnnecessarySourceImports sccs =
 -- module, plus one for any hs-boot files.  The imports of these nodes 
 -- are all there, including the imports of non-home-package modules.
 
-downsweep :: GhcMonad m =>
-             HscEnv
+downsweep :: HscEnv
          -> [ModSummary]       -- Old summaries
          -> [ModuleName]       -- Ignore dependencies on these; treat
                                -- them as if they were package modules
          -> Bool               -- True <=> allow multiple targets to have 
                                --          the same module name; this is 
                                --          very useful for ghc -M
-         -> m [ModSummary]
+         -> IO [ModSummary]
                -- The elts of [ModSummary] all have distinct
                -- (Modules, IsBoot) identifiers, unless the Bool is true
                -- in which case there can be repeats
 downsweep hsc_env old_summaries excl_mods allow_dup_roots
-   = do -- catch error messages and return them
-     --handleErrMsg   -- should be covered by GhcMonad now
-     --          (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
+   = do
        rootSummaries <- mapM getRootSummary roots
        let root_map = mkRootMap rootSummaries
        checkDuplicates root_map
@@ -1912,7 +1851,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
        old_summary_map :: NodeMap ModSummary
        old_summary_map = mkNodeMap old_summaries
 
-       getRootSummary :: GhcMonad m => Target -> m ModSummary
+       getRootSummary :: Target -> IO ModSummary
        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
           = do exists <- liftIO $ doesFileExist file
                if exists 
@@ -1934,7 +1873,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
        -- name, so we have to check that there aren't multiple root files
        -- defining the same module (otherwise the duplicates will be silently
        -- ignored, leading to confusing behaviour).
-       checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m ()
+       checkDuplicates :: NodeMap [ModSummary] -> IO ()
        checkDuplicates root_map 
           | allow_dup_roots = return ()
           | null dup_roots  = return ()
@@ -1943,14 +1882,13 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
             dup_roots :: [[ModSummary]]        -- Each at least of length 2
             dup_roots = filterOut isSingleton (nodeMapElts root_map)
 
-       loop :: GhcMonad m =>
-                [(Located ModuleName,IsBootInterface)]
+       loop :: [(Located ModuleName,IsBootInterface)]
                        -- Work list: process these modules
             -> NodeMap [ModSummary]
                        -- Visited set; the range is a list because
                        -- the roots can have the same module names
                        -- if allow_dup_roots is True
-            -> m [ModSummary]
+            -> IO [ModSummary]
                        -- The result includes the worklist, except
                        -- for those mentioned in the visited set
        loop [] done      = return (concat (nodeMapElts done))
@@ -1959,7 +1897,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
          = if isSingleton summs then
                loop ss done
            else
-               do { liftIO $ multiRootsErr summs; return [] }
+               do { multiRootsErr summs; return [] }
          | otherwise
           = do mb_s <- summariseModule hsc_env old_summary_map 
                                        is_boot wanted_mod True
@@ -2018,14 +1956,13 @@ ms_home_imps = home_imps . ms_imps
 --     resides.
 
 summariseFile
-       :: GhcMonad m =>
-           HscEnv
+       :: HscEnv
        -> [ModSummary]                 -- old summaries
        -> FilePath                     -- source file name
        -> Maybe Phase                  -- start phase
         -> Bool                         -- object code allowed?
        -> Maybe (StringBuffer,ClockTime)
-       -> m ModSummary
+       -> IO ModSummary
 
 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
        -- we can use a cached summary if one is available and the
@@ -2104,15 +2041,14 @@ findSummaryBySourceFile summaries file
 
 -- Summarise a module, and pick up source and timestamp.
 summariseModule
-         :: GhcMonad m =>
-             HscEnv
+         :: HscEnv
          -> NodeMap ModSummary -- Map of old summaries
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Located ModuleName -- Imported module to be summarised
           -> Bool               -- object code allowed?
          -> Maybe (StringBuffer, ClockTime)
          -> [ModuleName]               -- Modules to exclude
-         -> m (Maybe ModSummary)       -- Its new summary
+         -> IO (Maybe ModSummary)      -- Its new summary
 
 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) 
                 obj_allowed maybe_buf excl_mods
@@ -2131,11 +2067,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
        case maybe_buf of
           Just (_,t) -> check_timestamp old_summary location src_fn t
           Nothing    -> do
-               m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
+               m <- System.IO.Error.try (getModificationTime src_fn)
                case m of
                   Right t -> check_timestamp old_summary location src_fn t
                   Left e | isDoesNotExistError e -> find_it
-                         | otherwise             -> liftIO $ ioError e
+                         | otherwise             -> ioError e
 
   | otherwise  = find_it
   where
@@ -2146,7 +2082,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
     check_timestamp old_summary location src_fn src_timestamp
        | ms_hs_date old_summary == src_timestamp = do
                -- update the object-file timestamp
-                obj_timestamp <- liftIO $
+                obj_timestamp <- 
                     if isObjectTarget (hscTarget (hsc_dflags hsc_env))
                        || obj_allowed -- bug #1205
                        then getObjTimestamp location is_boot
@@ -2161,8 +2097,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
        -- previously a package module, it may have now appeared on the
        -- search path, so we want to consider it to be a home module.  If
        -- the module was previously a home module, it may have moved.
-       liftIO $ uncacheModule hsc_env wanted_mod
-       found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
+       uncacheModule hsc_env wanted_mod
+       found <- findImportedModule hsc_env wanted_mod Nothing
        case found of
             Found location mod 
                | isJust (ml_hs_file location) ->
@@ -2173,7 +2109,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                        ASSERT(modulePackageId mod /= thisPackage dflags)
                        return Nothing
                        
-            err -> liftIO $ noModError dflags loc wanted_mod err
+            err -> noModError dflags loc wanted_mod err
                        -- Not found
 
     just_found location mod = do
@@ -2185,7 +2121,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
 
                -- Check that it exists
                -- It might have been deleted since the Finder last found it
-       maybe_t <- liftIO $ modificationTimeIfExists src_fn
+       maybe_t <- modificationTimeIfExists src_fn
        case maybe_t of
          Nothing -> noHsFileErr loc src_fn
          Just t  -> new_summary location' mod src_fn t
@@ -2205,7 +2141,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
 
                -- Find the object timestamp, and return the summary
-       obj_timestamp <- liftIO $
+       obj_timestamp <-
            if isObjectTarget (hscTarget (hsc_dflags hsc_env))
               || obj_allowed -- bug #1205
               then getObjTimestamp location is_boot
@@ -2229,16 +2165,15 @@ getObjTimestamp location is_boot
               else modificationTimeIfExists (ml_obj_file location)
 
 
-preprocessFile :: GhcMonad m =>
-                  HscEnv
+preprocessFile :: HscEnv
                -> FilePath
                -> Maybe Phase -- ^ Starting phase
                -> Maybe (StringBuffer,ClockTime)
-               -> m (DynFlags, FilePath, StringBuffer)
+               -> IO (DynFlags, FilePath, StringBuffer)
 preprocessFile hsc_env src_fn mb_phase Nothing
   = do
        (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
-       buf <- liftIO $ hGetStringBuffer hspp_fn
+       buf <- hGetStringBuffer hspp_fn
        return (dflags', hspp_fn, buf)
 
 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
@@ -2277,11 +2212,11 @@ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
 noModError dflags loc wanted_mod err
   = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
                                
-noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
+noHsFileErr :: SrcSpan -> String -> IO a
 noHsFileErr loc path
   = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
  
-packageModErr :: GhcMonad m => ModuleName -> m a
+packageModErr :: ModuleName -> IO a
 packageModErr mod
   = throwOneError $ mkPlainErrMsg noSrcSpan $
        text "module" <+> quotes (ppr mod) <+> text "is a package module"
@@ -2395,7 +2330,7 @@ getModuleInfo mdl = withSession $ \hsc_env -> do
 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
 #ifdef GHCI
 getPackageModuleInfo hsc_env mdl = do
-  (_msgs, mb_avails) <- getModuleExports hsc_env mdl
+  mb_avails <- hscGetModuleExports hsc_env mdl
   case mb_avails of
     Nothing -> return Nothing
     Just avails -> do
@@ -2701,8 +2636,30 @@ obtainTermFromId bound force id =
 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
-lookupName name = withSession $ \hsc_env -> do
-  mb_tything <- ioMsg $ tcRnLookupName hsc_env name
-  return mb_tything
-  -- XXX: calls panic in some circumstances;  is that ok?
+lookupName name =
+     withSession $ \hsc_env -> 
+       liftIO $ hscTcRcLookupName hsc_env name
+
+-- -----------------------------------------------------------------------------
+-- Pure API
+
+-- | A pure interface to the module parser.
+--
+parser :: String         -- ^ Haskell module source text (full Unicode is supported)
+       -> DynFlags       -- ^ the flags
+       -> FilePath       -- ^ the filename (for source locations)
+       -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
+
+parser str dflags filename = 
+   let
+       loc  = mkSrcLoc (mkFastString filename) 1 1
+       buf  = stringToStringBuffer str
+   in
+   case unP Parser.parseModule (mkPState dflags buf loc) of
+
+     PFailed span err   -> 
+         Left (unitBag (mkPlainErrMsg span err))
 
+     POk pst rdr_module ->
+         let (warns,_) = getMessages pst in
+         Right (warns, rdr_module)
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
new file mode 100644 (file)
index 0000000..c62ea4c
--- /dev/null
@@ -0,0 +1,177 @@
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2010
+--
+-- The Session type and related functionality
+--
+-- -----------------------------------------------------------------------------
+
+module GhcMonad (
+        -- * 'Ghc' monad stuff
+        GhcMonad(..),
+        Ghc(..), 
+        GhcT(..), liftGhcT,
+        reflectGhc, reifyGhc,
+        getSessionDynFlags, 
+        liftIO,
+       Session(..), withSession, modifySession, withTempSession,
+
+        -- ** Warnings
+        logWarnings
+  ) where
+
+import MonadUtils
+import HscTypes
+import DynFlags
+import Exception
+import ErrUtils
+
+import Data.IORef
+
+-- -----------------------------------------------------------------------------
+-- | A monad that has all the features needed by GHC API calls.
+--
+-- In short, a GHC monad
+--
+--   - allows embedding of IO actions,
+--
+--   - can log warnings,
+--
+--   - allows handling of (extensible) exceptions, and
+--
+--   - maintains a current session.
+--
+-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
+-- before any call to the GHC API functions can occur.
+--
+class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where
+  getSession :: m HscEnv
+  setSession :: HscEnv -> m ()
+
+
+-- | Call the argument with the current session.
+withSession :: GhcMonad m => (HscEnv -> m a) -> m a
+withSession f = getSession >>= f
+
+-- | Grabs the DynFlags from the Session
+getSessionDynFlags :: GhcMonad m => m DynFlags
+getSessionDynFlags = withSession (return . hsc_dflags)
+
+-- | Set the current session to the result of applying the current session to
+-- the argument.
+modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
+modifySession f = do h <- getSession
+                     setSession $! f h
+
+withSavedSession :: GhcMonad m => m a -> m a
+withSavedSession m = do
+  saved_session <- getSession
+  m `gfinally` setSession saved_session
+
+-- | Call an action with a temporarily modified Session.
+withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
+withTempSession f m =
+  withSavedSession $ modifySession f >> m
+
+-- -----------------------------------------------------------------------------
+-- | A monad that allows logging of warnings.
+
+logWarnings :: GhcMonad m => WarningMessages -> m ()
+logWarnings warns = do
+  dflags <- getSessionDynFlags
+  liftIO $ printOrThrowWarnings dflags warns
+
+-- -----------------------------------------------------------------------------
+-- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
+-- e.g., to maintain additional state consider wrapping this monad or using
+-- 'GhcT'.
+newtype Ghc a = Ghc { unGhc :: Session -> IO a }
+
+-- | The Session is a handle to the complete state of a compilation
+-- session.  A compilation session consists of a set of modules
+-- constituting the current program or library, the context for
+-- interactive evaluation, and various caches.
+data Session = Session !(IORef HscEnv) 
+
+instance Functor Ghc where
+  fmap f m = Ghc $ \s -> f `fmap` unGhc m s
+
+instance Monad Ghc where
+  return a = Ghc $ \_ -> return a
+  m >>= g  = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
+
+instance MonadIO Ghc where
+  liftIO ioA = Ghc $ \_ -> ioA
+
+instance ExceptionMonad Ghc where
+  gcatch act handle =
+      Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
+  gblock (Ghc m)   = Ghc $ \s -> gblock (m s)
+  gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
+  gmask f =
+      Ghc $ \s -> gmask $ \io_restore ->
+                             let
+                                g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
+                             in
+                                unGhc (f g_restore) s
+
+instance GhcMonad Ghc where
+  getSession = Ghc $ \(Session r) -> readIORef r
+  setSession s' = Ghc $ \(Session r) -> writeIORef r s'
+
+-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
+--
+-- You can use this to call functions returning an action in the 'Ghc' monad
+-- inside an 'IO' action.  This is needed for some (too restrictive) callback
+-- arguments of some library functions:
+--
+-- > libFunc :: String -> (Int -> IO a) -> IO a
+-- > ghcFunc :: Int -> Ghc a
+-- >
+-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
+-- > ghcFuncUsingLibFunc str =
+-- >   reifyGhc $ \s ->
+-- >     libFunc $ \i -> do
+-- >       reflectGhc (ghcFunc i) s
+--
+reflectGhc :: Ghc a -> Session -> IO a
+reflectGhc m = unGhc m
+
+-- > Dual to 'reflectGhc'.  See its documentation.
+reifyGhc :: (Session -> IO a) -> Ghc a
+reifyGhc act = Ghc $ act
+
+-- -----------------------------------------------------------------------------
+-- | A monad transformer to add GHC specific features to another monad.
+--
+-- Note that the wrapped monad must support IO and handling of exceptions.
+newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
+liftGhcT :: Monad m => m a -> GhcT m a
+liftGhcT m = GhcT $ \_ -> m
+
+instance Functor m => Functor (GhcT m) where
+  fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
+
+instance Monad m => Monad (GhcT m) where
+  return x = GhcT $ \_ -> return x
+  m >>= k  = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
+
+instance MonadIO m => MonadIO (GhcT m) where
+  liftIO ioA = GhcT $ \_ -> liftIO ioA
+
+instance ExceptionMonad m => ExceptionMonad (GhcT m) where
+  gcatch act handle =
+      GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
+  gblock (GhcT m) = GhcT $ \s -> gblock (m s)
+  gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
+  gmask f =
+      GhcT $ \s -> gmask $ \io_restore ->
+                           let
+                              g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
+                           in
+                              unGhcT (f g_restore) s
+
+instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
+  getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
+  setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
index 508f855..4e455a6 100644 (file)
@@ -33,9 +33,9 @@ import Outputable
 import Pretty           ()
 import Maybes
 import Bag             ( emptyBag, listToBag, unitBag )
-
-import MonadUtils       ( MonadIO )
+import MonadUtils
 import Exception
+
 import Control.Monad
 import System.IO
 import System.IO.Unsafe
@@ -46,14 +46,13 @@ import Data.List
 -- | Parse the imports of a source file.
 --
 -- Throws a 'SourceError' if parsing fails.
-getImports :: GhcMonad m =>
-              DynFlags
+getImports :: DynFlags
            -> StringBuffer -- ^ Parse this.
            -> FilePath     -- ^ Filename the buffer came from.  Used for
                            --   reporting parse error locations.
            -> FilePath     -- ^ The original source filename (used for locations
                            --   in the function result)
-           -> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
+           -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
               -- ^ The source imports, normal imports, and the module name.
 getImports dflags buf filename source_filename = do
   let loc  = mkSrcLoc (mkFastString filename) 1 1
@@ -66,7 +65,7 @@ getImports dflags buf filename source_filename = do
           ms = (emptyBag, errs)
       -- logWarnings warns
       if errorsFound dflags ms
-        then liftIO $ throwIO $ mkSrcErr errs
+        then throwIO $ mkSrcErr errs
         else
          case rdr_module of
            L _ (HsModule mb_mod _ imps _ _ _) ->
@@ -114,7 +113,7 @@ mkPrelImports this_mod implicit_prelude import_decls
 
       loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
 
-parseError :: GhcMonad m => SrcSpan -> Message -> m a
+parseError :: SrcSpan -> Message -> IO a
 parseError span err = throwOneError $ mkPlainErrMsg span err
 
 --------------------------------------------------------------
index 42ed3e4..d52337e 100644 (file)
@@ -2,57 +2,83 @@
 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
 %
 \begin{code}
--- | Main driver for the compiling plain Haskell source code.
+-- | Main API for compiling plain Haskell source code.
 --
--- This module implements compilation of a Haskell-only source file.  It is
--- /not/ concerned with preprocessing of source files; this is handled in
--- "DriverPipeline".
+-- This module implements compilation of a Haskell source.  It is
+-- /not/ concerned with preprocessing of source files; this is handled
+-- in "DriverPipeline".
+--
+-- There are various entry points depending on what mode we're in:
+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
+-- "interactive" mode (GHCi).  There are also entry points for
+-- individual passes: parsing, typechecking/renaming, desugaring, and
+-- simplification.
+--
+-- All the functions here take an 'HscEnv' as a parameter, but none of
+-- them return a new one: 'HscEnv' is treated as an immutable value
+-- from here on in (although it has mutable components, for the
+-- caches).
+--
+-- Warning messages are dealt with consistently throughout this API:
+-- during compilation warnings are collected, and before any function
+-- in @HscMain@ returns, the warnings are either printed, or turned
+-- into a real compialtion error if the @-Werror@ flag is enabled.
 --
 module HscMain
-    ( newHscEnv, hscCmmFile
-    , hscParseIdentifier
-    , hscSimplify
-    , hscNormalIface, hscWriteIface, hscGenHardCode
-#ifdef GHCI
-    , hscStmt, hscTcExpr, hscImport, hscKcType
-    , compileExpr
-#endif
-    , HsCompiler(..)
-    , hscOneShotCompiler, hscNothingCompiler
-    , hscInteractiveCompiler, hscBatchCompiler
-    , hscCompileOneShot     -- :: Compiler HscStatus
-    , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
-    , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
-    , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
-    , hscCheckRecompBackend
+    ( 
+    -- * Making an HscEnv
+      newHscEnv
+
+    -- * Compiling complete source files
+    , Compiler
     , HscStatus' (..)
     , InteractiveStatus, HscStatus
-
-    -- The new interface
+    , hscCompileOneShot
+    , hscCompileBatch
+    , hscCompileNothing
+    , hscCompileInteractive
+    , hscCompileCmmFile
+    , hscCompileCore
+
+    -- * Running passes separately
     , hscParse
-    , hscTypecheck
     , hscTypecheckRename
     , hscDesugar
     , makeSimpleIface
     , makeSimpleDetails
+    , hscSimplify -- ToDo, shouldn't really export this
+
+    -- ** Backends
+    , hscOneShotBackendOnly
+    , hscBatchBackendOnly
+    , hscNothingBackendOnly
+    , hscInteractiveBackendOnly
+
+    -- * Support for interactive evaluation
+    , hscParseIdentifier
+    , hscTcRcLookupName
+    , hscTcRnGetInfo
+    , hscRnImportDecls
+#ifdef GHCI
+    , hscGetModuleExports
+    , hscTcRnLookupRdrName
+    , hscStmt, hscTcExpr, hscImport, hscKcType
+    , hscCompileCoreExpr
+#endif
+
     ) where
 
 #ifdef GHCI
-import CodeOutput      ( outputForeignStubs )
 import ByteCodeGen     ( byteCodeGen, coreExprToBCOs )
 import Linker          ( HValue, linkExpr )
 import CoreTidy                ( tidyExpr )
-import CorePrep                ( corePrepExpr )
-import Desugar          ( deSugarExpr )
-import SimplCore        ( simplifyExpr )
-import TcRnDriver      ( tcRnStmt, tcRnExpr, tcRnType ) 
-import Type            ( Type, tyVarsOfTypes )
+import Type            ( Type )
+import TcType           ( tyVarsOfTypes )
 import PrelNames       ( iNTERACTIVE )
 import {- Kind parts of -} Type                ( Kind )
 import Id                      ( idType )
 import CoreLint                ( lintUnfolding )
 import DsMeta          ( templateHaskellNames )
-import SrcLoc          ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
 import VarSet
 import VarEnv          ( emptyTidyEnv )
 import Panic
@@ -63,22 +89,22 @@ import Module               ( emptyModuleEnv, ModLocation(..), Module )
 import RdrName
 import HsSyn
 import CoreSyn
-import SrcLoc          ( Located(..) )
 import StringBuffer
 import Parser
-import Lexer
-import SrcLoc          ( mkSrcLoc )
-import TcRnDriver      ( tcRnModule )
+import Lexer hiding (getDynFlags)
+import SrcLoc
+import TcRnDriver
 import TcIface         ( typecheckIface )
-import TcRnMonad       ( initIfaceCheck, TcGblEnv(..) )
+import TcRnMonad
+import RnNames          ( rnImports )
 import IfaceEnv                ( initNameCache )
 import LoadIface       ( ifaceStats, initExternalPackageState )
 import PrelInfo                ( wiredInThings, basicKnownKeyNames )
 import MkIface
-import Desugar          ( deSugar )
-import SimplCore        ( core2core )
+import Desugar
+import SimplCore
 import TidyPgm
-import CorePrep                ( corePrepPgm )
+import CorePrep
 import CoreToStg       ( coreToStg )
 import qualified StgCmm        ( codeGen )
 import StgSyn
@@ -98,14 +124,18 @@ import OptimizationFuel ( initOptFuelState )
 import CmmCvt
 import CmmTx
 import CmmContFlowOpt
-import CodeOutput      ( codeOutput )
+import CodeOutput
 import NameEnv          ( emptyNameEnv )
+import NameSet          ( emptyNameSet )
+import InstEnv
+import FamInstEnv       ( emptyFamInstEnv )
 import Fingerprint      ( Fingerprint )
 
 import DynFlags
 import ErrUtils
 import UniqSupply      ( mkSplitUniqSupply )
 
+import MonadUtils
 import Outputable
 import HscStats                ( ppSourceStats )
 import HscTypes
@@ -113,7 +143,7 @@ import MkExternalCore       ( emitExternalCore )
 import FastString
 import UniqFM          ( emptyUFM )
 import UniqSupply       ( initUs_ )
-import Bag             ( unitBag )
+import Bag
 import Exception
 -- import MonadUtils
 
@@ -131,8 +161,8 @@ import Data.IORef
 %************************************************************************
 
 \begin{code}
-newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv
-newHscEnv callbacks dflags
+newHscEnv :: DynFlags -> IO HscEnv
+newHscEnv dflags
   = do         { eps_var <- newIORef initExternalPackageState
        ; us      <- mkSplitUniqSupply 'r'
        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
@@ -140,7 +170,6 @@ newHscEnv callbacks dflags
        ; mlc_var <- newIORef emptyModuleEnv
         ; optFuel <- initOptFuelState
        ; return (HscEnv { hsc_dflags = dflags,
-                           hsc_callbacks = callbacks,
                           hsc_targets = [],
                           hsc_mod_graph = [],
                           hsc_IC      = emptyInteractiveContext,
@@ -160,19 +189,145 @@ knownKeyNames = map getName wiredInThings
 #ifdef GHCI
              ++ templateHaskellNames
 #endif
-\end{code}
 
+-- -----------------------------------------------------------------------------
+-- The Hsc monad: collecting warnings
 
-\begin{code}
+newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
+
+instance Monad Hsc where
+  return a = Hsc $ \_ w -> return (a, w)
+  Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
+                                 case k a of
+                                    Hsc k' -> k' e w1
+
+instance MonadIO Hsc where
+  liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
+
+runHsc :: HscEnv -> Hsc a -> IO a
+runHsc hsc_env (Hsc hsc) = do
+  (a, w) <- hsc hsc_env emptyBag
+  printOrThrowWarnings (hsc_dflags hsc_env) w
+  return a
+
+getWarnings :: Hsc WarningMessages
+getWarnings = Hsc $ \_ w -> return (w, w)
+
+clearWarnings :: Hsc ()
+clearWarnings = Hsc $ \_ _w -> return ((), emptyBag)
+
+logWarnings :: WarningMessages -> Hsc ()
+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
+
+getHscEnv :: Hsc HscEnv
+getHscEnv = Hsc $ \e w -> return (e, w)
+
+getDynFlags :: Hsc DynFlags
+getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
+
+handleWarnings :: Hsc ()
+handleWarnings = do
+  dflags <- getDynFlags
+  w <- getWarnings
+  liftIO $ printOrThrowWarnings dflags w
+  clearWarnings
+
+-- | log warning in the monad, and if there are errors then
+-- throw a SourceError exception.
+logWarningsReportErrors :: Messages -> Hsc ()
+logWarningsReportErrors (warns,errs) = do
+  logWarnings warns
+  when (not (isEmptyBag errs)) $ do
+    liftIO $ throwIO $ mkSrcErr errs
+
+-- | Deal with errors and warnings returned by a compilation step
+--
+-- In order to reduce dependencies to other parts of the compiler, functions
+-- outside the "main" parts of GHC return warnings and errors as a parameter
+-- and signal success via by wrapping the result in a 'Maybe' type.  This
+-- function logs the returned warnings and propagates errors as exceptions
+-- (of type 'SourceError').
+--
+-- This function assumes the following invariants:
+--
+--  1. If the second result indicates success (is of the form 'Just x'),
+--     there must be no error messages in the first result.
+--
+--  2. If there are no error messages, but the second result indicates failure
+--     there should be warnings in the first result.  That is, if the action
+--     failed, it must have been due to the warnings (i.e., @-Werror@).
+ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
+ioMsgMaybe ioA = do
+  ((warns,errs), mb_r) <- liftIO $ ioA
+  logWarnings warns
+  case mb_r of
+    Nothing -> liftIO $ throwIO (mkSrcErr errs)
+    Just r  -> ASSERT( isEmptyBag errs ) return r
+
+-- | like ioMsgMaybe, except that we ignore error messages and return
+-- 'Nothing' instead.
+ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
+ioMsgMaybe' ioA = do
+  ((warns,_errs), mb_r) <- liftIO $ ioA
+  logWarnings warns
+  return mb_r
+
+-- -----------------------------------------------------------------------------
+-- | Lookup things in the compiler's environment
+
+#ifdef GHCI
+hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
+hscTcRnLookupRdrName hsc_env rdr_name = 
+  runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
+#endif
+
+hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+hscTcRcLookupName hsc_env name = 
+  runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name
+    -- ignore errors: the only error we're likely to get is
+    -- "name not found", and the Maybe in the return type
+    -- is used to indicate that.
+
+hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance]))
+hscTcRnGetInfo hsc_env name =
+  runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name
+
+#ifdef GHCI
+hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo])
+hscGetModuleExports hsc_env mdl =
+  runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl
+#endif
+
+-- -----------------------------------------------------------------------------
+-- | Rename some import declarations
+
+hscRnImportDecls
+        :: HscEnv
+        -> Module
+        -> [LImportDecl RdrName]
+        -> IO GlobalRdrEnv
+
+hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ do
+  (_, r, _, _) <- 
+       ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
+          rnImports import_decls
+  return r
+
+-- -----------------------------------------------------------------------------
 -- | parse a file, returning the abstract syntax
-hscParse :: GhcMonad m =>
-            ModSummary
-         -> m (Located (HsModule RdrName))
-hscParse mod_summary = do
-   hsc_env <- getSession
-   let dflags        = hsc_dflags hsc_env
+
+hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName))
+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
+
+-- internal version, that doesn't fail due to -Werror
+hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName))
+hscParse' mod_summary
+ = do
+   dflags <- getDynFlags
+   let 
        src_filename  = ms_hspp_file mod_summary
        maybe_src_buf = ms_hspp_buf  mod_summary
+
    --------------------------  Parser  ----------------
    liftIO $ showPass dflags "Parser"
    {-# SCC "Parser" #-} do
@@ -188,30 +343,17 @@ hscParse mod_summary = do
 
    case unP parseModule (mkPState dflags buf loc) of
      PFailed span err ->
-         throwOneError (mkPlainErrMsg span err)
+         liftIO $ throwOneError (mkPlainErrMsg span err)
 
      POk pst rdr_module -> do
-         let ms@(warns,errs) = getMessages pst
-         logWarnings warns
-         if errorsFound dflags ms then
-           liftIO $ throwIO $ mkSrcErr errs
-          else liftIO $ do
-           dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
-           dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
-                               (ppSourceStats False rdr_module) ;
-           return rdr_module
+         logWarningsReportErrors (getMessages pst)
+         liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
+                                ppr rdr_module
+         liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
+                                ppSourceStats False rdr_module
+         return rdr_module
           -- ToDo: free the string buffer later.
 
--- | Rename and typecheck a module
-hscTypecheck :: GhcMonad m =>
-                ModSummary -> Located (HsModule RdrName)
-             -> m TcGblEnv
-hscTypecheck mod_summary rdr_module = do
-      hsc_env <- getSession
-      r <- {-# SCC "Typecheck-Rename" #-}
-           ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
-      return r
-
 -- XXX: should this really be a Maybe X?  Check under which circumstances this
 -- can become a Nothing and decide whether this should instead throw an
 -- exception/signal an error.
@@ -220,48 +362,59 @@ type RenamedStuff =
                 Maybe LHsDocString))
 
 -- | Rename and typecheck a module, additionally returning the renamed syntax
-hscTypecheckRename ::
-       GhcMonad m =>
-       ModSummary -> Located (HsModule RdrName)
-    -> m (TcGblEnv, RenamedStuff)
-hscTypecheckRename mod_summary rdr_module = do
-    hsc_env <- getSession
-    tc_result
+hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName)
+                   -> IO (TcGblEnv, RenamedStuff)
+hscTypecheckRename hsc_env mod_summary rdr_module
+  = runHsc hsc_env $ do
+      tc_result
           <- {-# SCC "Typecheck-Rename" #-}
-             ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
+              ioMsgMaybe $ 
+                  tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
 
-    let -- This 'do' is in the Maybe monad!
-        rn_info = do { decl <- tcg_rn_decls tc_result
-                     ; let imports = tcg_rn_imports tc_result
+      let -- This 'do' is in the Maybe monad!
+          rn_info = do decl <- tcg_rn_decls tc_result
+                       let imports = tcg_rn_imports tc_result
                            exports = tcg_rn_exports tc_result
                            doc_hdr  = tcg_doc_hdr tc_result
-                     ; return (decl,imports,exports,doc_hdr) }
+                       return (decl,imports,exports,doc_hdr)
 
-    return (tc_result, rn_info)
+      return (tc_result, rn_info)
 
 -- | Convert a typechecked module to Core
-hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts
-hscDesugar mod_summary tc_result =
-  withSession $ \hsc_env ->
-    ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result
+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
+hscDesugar hsc_env mod_summary tc_result
+  = runHsc hsc_env $ hscDesugar' mod_summary tc_result
+
+hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts
+hscDesugar' mod_summary tc_result
+ = do
+      hsc_env <- getHscEnv
+      r <- ioMsgMaybe $ 
+             deSugar hsc_env (ms_location mod_summary) tc_result
+
+      handleWarnings
+                -- always check -Werror after desugaring, this is 
+                -- the last opportunity for warnings to arise before
+                -- the backend.
+      return r
 
 -- | Make a 'ModIface' from the results of typechecking.  Used when
 -- not optimising, and the interface doesn't need to contain any
 -- unfoldings or other cross-module optimisation info.
 -- ToDo: the old interface is only needed to get the version numbers,
 -- we should use fingerprint versions instead.
-makeSimpleIface :: GhcMonad m =>
+makeSimpleIface :: HscEnv -> 
                    Maybe ModIface -> TcGblEnv -> ModDetails
-                -> m (ModIface,Bool)
-makeSimpleIface maybe_old_iface tc_result details =
-  withSession $ \hsc_env ->
-  ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
+                -> IO (ModIface,Bool)
+makeSimpleIface hsc_env maybe_old_iface tc_result details
+  = runHsc hsc_env $
+     ioMsgMaybe $ 
+       mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
 
 -- | Make a 'ModDetails' from the results of typechecking.  Used when
 -- typechecking only, as opposed to full compilation.
-makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails
-makeSimpleDetails tc_result =
-    withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result
+makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
+makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
 \end{code}
 
 %************************************************************************
@@ -327,82 +480,82 @@ type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
 
 -- FIXME: The old interface and module index are only using in 'batch' and
 --        'interactive' mode. They should be removed from 'oneshot' mode.
-type Compiler result =  GhcMonad m =>
-                        HscEnv
+type Compiler result =  HscEnv
                      -> ModSummary
                      -> Bool                -- True <=> source unchanged
                      -> Maybe ModIface      -- Old interface, if available
                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
-                     -> m result
+                     -> IO result
 
 data HsCompiler a
   = HsCompiler {
     -- | Called when no recompilation is necessary.
-    hscNoRecomp :: GhcMonad m =>
-                   ModIface -> m a,
+    hscNoRecomp :: ModIface
+                -> Hsc a,
 
     -- | Called to recompile the module.
-    hscRecompile :: GhcMonad m =>
-                    ModSummary -> Maybe Fingerprint -> m a,
+    hscRecompile :: ModSummary -> Maybe Fingerprint
+                 -> Hsc a,
 
-    hscBackend :: GhcMonad m =>
-                  TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
+    hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint
+               -> Hsc a,
 
     -- | Code generation for Boot modules.
-    hscGenBootOutput :: GhcMonad m =>
-                        TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
+    hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint
+                     -> Hsc a,
 
     -- | Code generation for normal modules.
-    hscGenOutput :: GhcMonad m =>
-                    ModGuts  -> ModSummary -> Maybe Fingerprint -> m a
+    hscGenOutput :: ModGuts  -> ModSummary -> Maybe Fingerprint
+                 -> Hsc a
   }
 
-genericHscCompile :: GhcMonad m =>
-                     HsCompiler a
-                  -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
+genericHscCompile :: HsCompiler a
+                  -> (HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ())
                   -> HscEnv -> ModSummary -> Bool
                   -> Maybe ModIface -> Maybe (Int, Int)
-                  -> m a
-genericHscCompile compiler hscMessage
-                  hsc_env mod_summary source_unchanged
-                  mb_old_iface0 mb_mod_index =
  withTempSession (\_ -> hsc_env) $ do
+                  -> IO a
+genericHscCompile compiler hscMessage hsc_env
+                  mod_summary source_unchanged
+                  mb_old_iface0 mb_mod_index
= do
      (recomp_reqd, mb_checked_iface)
          <- {-# SCC "checkOldIface" #-}
-            liftIO $ checkOldIface hsc_env mod_summary
-                                   source_unchanged mb_old_iface0
+            checkOldIface hsc_env mod_summary 
+                          source_unchanged mb_old_iface0
      -- save the interface that comes back from checkOldIface.
      -- In one-shot mode we don't have the old iface until this
      -- point, when checkOldIface reads it from the disk.
      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
      case mb_checked_iface of
        Just iface | not recomp_reqd
-           -> do hscMessage mb_mod_index False mod_summary
-                 hscNoRecomp compiler iface
+           -> do hscMessage hsc_env mb_mod_index False mod_summary
+                 runHsc hsc_env $ hscNoRecomp compiler iface
        _otherwise
-           -> do hscMessage mb_mod_index True mod_summary
-                 hscRecompile compiler mod_summary mb_old_hash
+           -> do hscMessage hsc_env mb_mod_index True mod_summary
+                 runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
 
 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
 hscCheckRecompBackend compiler tc_result 
-                   hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
-   withTempSession (\_ -> hsc_env) $ do
+                   hsc_env mod_summary source_unchanged mb_old_iface _m_of_n
+  = do
      (recomp_reqd, mb_checked_iface)
          <- {-# SCC "checkOldIface" #-}
-            liftIO $ checkOldIface hsc_env mod_summary
-                                   source_unchanged mb_old_iface
+            checkOldIface hsc_env mod_summary
+                          source_unchanged mb_old_iface
 
      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
      case mb_checked_iface of
        Just iface | not recomp_reqd
-           -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
+           -> runHsc hsc_env $ 
+                 hscNoRecomp compiler
+                             iface{ mi_globals = Just (tcg_rdr_env tc_result) }
        _otherwise
-           -> hscBackend compiler tc_result mod_summary mb_old_hash
+           -> runHsc hsc_env $
+                 hscBackend compiler tc_result mod_summary mb_old_hash
 
-genericHscRecompile :: GhcMonad m =>
-                       HsCompiler a
+genericHscRecompile :: HsCompiler a
                     -> ModSummary -> Maybe Fingerprint
-                    -> m a
+                    -> Hsc a
 genericHscRecompile compiler mod_summary mb_old_hash
   | ExtCoreFile <- ms_hsc_src mod_summary =
       panic "GHC does not currently support reading External Core files"
@@ -410,17 +563,21 @@ genericHscRecompile compiler mod_summary mb_old_hash
       tc_result <- hscFileFrontEnd mod_summary
       hscBackend compiler tc_result mod_summary mb_old_hash
 
-genericHscBackend :: GhcMonad m =>
-                     HsCompiler a
+genericHscBackend :: HsCompiler a
                   -> TcGblEnv -> ModSummary -> Maybe Fingerprint
-                  -> m a
+                  -> Hsc a
 genericHscBackend compiler tc_result mod_summary mb_old_hash
   | HsBootFile <- ms_hsc_src mod_summary =
       hscGenBootOutput compiler tc_result mod_summary mb_old_hash
   | otherwise = do
-      guts <- hscDesugar mod_summary tc_result
+      guts <- hscDesugar' mod_summary tc_result
       hscGenOutput compiler guts mod_summary mb_old_hash
 
+compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
+compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ =
+  runHsc hsc_env $
+    hscBackend comp tcg ms' Nothing
+
 --------------------------------------------------------------
 -- Compilers
 --------------------------------------------------------------
@@ -430,16 +587,17 @@ hscOneShotCompiler =
   HsCompiler {
 
     hscNoRecomp = \_old_iface -> do
-      withSession (liftIO . dumpIfaceStats)
+      hsc_env <- getHscEnv
+      liftIO $ dumpIfaceStats hsc_env
       return HscNoRecomp
 
   , hscRecompile = genericHscRecompile hscOneShotCompiler
 
   , hscBackend = \ tc_result mod_summary mb_old_hash -> do
-       hsc_env <- getSession
-       case hscTarget (hsc_dflags hsc_env) of
+       dflags <- getDynFlags
+       case hscTarget dflags of
          HscNothing -> return (HscRecomp False ())
-         _otherw    -> genericHscBackend hscOneShotCompiler 
+         _otherw    -> genericHscBackend hscOneShotCompiler
                                          tc_result mod_summary mb_old_hash
 
   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
@@ -448,9 +606,8 @@ hscOneShotCompiler =
        return (HscRecomp False ())
 
   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
-       guts <- hscSimplify guts0
-       (iface, changed, _details, cgguts)
-           <- hscNormalIface guts mb_old_iface
+       guts <- hscSimplify' guts0
+       (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface
        hscWriteIface iface changed mod_summary
        hasStub <- hscGenHardCode cgguts mod_summary
        return (HscRecomp hasStub ())
@@ -458,10 +615,11 @@ hscOneShotCompiler =
 
 -- Compile Haskell, boot and extCore in OneShot mode.
 hscCompileOneShot :: Compiler OneShotResult
-hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
+hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
+  = do
        -- One-shot mode needs a knot-tying mutable variable for interface
        -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
-      type_env_var <- liftIO $ newIORef emptyNameEnv
+      type_env_var <- newIORef emptyNameEnv
       let
          mod = ms_mod mod_summary
          hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
@@ -471,6 +629,9 @@ hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
                         mb_old_iface mb_i_of_n
 
 
+hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult
+hscOneShotBackendOnly = compilerBackend hscOneShotCompiler
+
 --------------------------------------------------------------
 
 hscBatchCompiler :: HsCompiler BatchResult
@@ -486,15 +647,13 @@ hscBatchCompiler =
   , hscBackend = genericHscBackend hscBatchCompiler
 
   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
-       (iface, changed, details)
-           <- hscSimpleIface tc_result mb_old_iface
+       (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
        hscWriteIface iface changed mod_summary
        return (HscRecomp False (), iface, details)
 
   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
-       guts <- hscSimplify guts0
-       (iface, changed, details, cgguts)
-           <- hscNormalIface guts mb_old_iface
+       guts <- hscSimplify' guts0
+       (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface
        hscWriteIface iface changed mod_summary
        hasStub <- hscGenHardCode cgguts mod_summary
        return (HscRecomp hasStub (), iface, details)
@@ -504,6 +663,9 @@ hscBatchCompiler =
 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
 
+hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult
+hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler
+
 --------------------------------------------------------------
 
 hscInteractiveCompiler :: HsCompiler InteractiveResult
@@ -522,9 +684,8 @@ hscInteractiveCompiler =
        return (HscRecomp False Nothing, iface, details)
 
   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
-       guts <- hscSimplify guts0
-       (iface, _changed, details, cgguts)
-           <- hscNormalIface guts mb_old_iface
+       guts <- hscSimplify' guts0
+       (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface
        hscInteractive (iface, details, cgguts) mod_summary
   }
 
@@ -532,6 +693,9 @@ hscInteractiveCompiler =
 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
 
+hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult
+hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler
+
 --------------------------------------------------------------
 
 hscNothingCompiler :: HsCompiler NothingResult
@@ -544,6 +708,7 @@ hscNothingCompiler =
   , hscRecompile = genericHscRecompile hscNothingCompiler
 
   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
+       handleWarnings
        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
        return (HscRecomp False (), iface, details)
 
@@ -558,39 +723,40 @@ hscNothingCompiler =
 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
 
+hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult
+hscNothingBackendOnly = compilerBackend hscNothingCompiler
+
 --------------------------------------------------------------
 -- NoRecomp handlers
 --------------------------------------------------------------
 
-genModDetails :: GhcMonad m => ModIface -> m ModDetails
-genModDetails old_iface =
-    withSession $ \hsc_env -> liftIO $ do
+genModDetails :: ModIface -> Hsc ModDetails
+genModDetails old_iface
+  = do
+      hsc_env <- getHscEnv
       new_details <- {-# SCC "tcRnIface" #-}
-                     initIfaceCheck hsc_env $
-                     typecheckIface old_iface
-      dumpIfaceStats hsc_env
+                     liftIO $ initIfaceCheck hsc_env $
+                              typecheckIface old_iface
+      liftIO $ dumpIfaceStats hsc_env
       return new_details
 
 --------------------------------------------------------------
 -- Progress displayers.
 --------------------------------------------------------------
 
-oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
-oneShotMsg _mb_mod_index recomp _mod_summary
-    = do hsc_env <- getSession
-         liftIO $ do
+oneShotMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
+oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
          if recomp
             then return ()
             else compilationProgressMsg (hsc_dflags hsc_env) $
                      "compilation IS NOT required"
 
-batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
-batchMsg mb_mod_index recomp mod_summary
-    = do hsc_env <- getSession
+batchMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
+batchMsg hsc_env mb_mod_index recomp mod_summary
+  = do
          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
                            (showModuleIndex mb_mod_index ++
                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
-         liftIO $ do
          if recomp
             then showMsg "Compiling "
             else if verbosity (hsc_dflags hsc_env) >= 2
@@ -600,47 +766,53 @@ batchMsg mb_mod_index recomp mod_summary
 --------------------------------------------------------------
 -- FrontEnds
 --------------------------------------------------------------
-hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv
+
+hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
 hscFileFrontEnd mod_summary =
-    do rdr_module <- hscParse mod_summary
-       hscTypecheck mod_summary rdr_module
+    do rdr_module <- hscParse' mod_summary
+       hsc_env <- getHscEnv
+       {-# SCC "Typecheck-Rename" #-}
+         ioMsgMaybe $ 
+             tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 
 --------------------------------------------------------------
 -- Simplifiers
 --------------------------------------------------------------
 
-hscSimplify :: GhcMonad m => ModGuts -> m ModGuts
-hscSimplify ds_result
-  = do hsc_env <- getSession
-       simpl_result <- {-# SCC "Core2Core" #-}
-                       liftIO $ core2core hsc_env ds_result
-       return simpl_result
+hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
+hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
+
+hscSimplify' :: ModGuts -> Hsc ModGuts
+hscSimplify' ds_result
+  = do hsc_env <- getHscEnv
+       {-# SCC "Core2Core" #-}
+         liftIO $ core2core hsc_env ds_result
 
 --------------------------------------------------------------
 -- Interface generators
 --------------------------------------------------------------
 
-hscSimpleIface :: GhcMonad m =>
-                  TcGblEnv
+hscSimpleIface :: TcGblEnv
                -> Maybe Fingerprint
-               -> m (ModIface, Bool, ModDetails)
+               -> Hsc (ModIface, Bool, ModDetails)
 hscSimpleIface tc_result mb_old_iface
-  = do hsc_env <- getSession
+  = do 
+       hsc_env <- getHscEnv
        details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
        (new_iface, no_change)
            <- {-# SCC "MkFinalIface" #-}
-              ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result
+              ioMsgMaybe $ 
+                mkIfaceTc hsc_env mb_old_iface details tc_result
        -- And the answer is ...
        liftIO $ dumpIfaceStats hsc_env
        return (new_iface, no_change, details)
 
-hscNormalIface :: GhcMonad m =>
-                  ModGuts
+hscNormalIface :: ModGuts
                -> Maybe Fingerprint
-               -> m (ModIface, Bool, ModDetails, CgGuts)
+               -> Hsc (ModIface, Bool, ModDetails, CgGuts)
 hscNormalIface simpl_result mb_old_iface
-  = do hsc_env <- getSession
-
+  = do 
+       hsc_env <- getHscEnv
        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
                              liftIO $ tidyProgram hsc_env simpl_result
 
@@ -651,9 +823,10 @@ hscNormalIface simpl_result mb_old_iface
            -- until after code output
        (new_iface, no_change)
           <- {-# SCC "MkFinalIface" #-}
-             ioMsgMaybe $ mkIface hsc_env mb_old_iface
-                                   details simpl_result
-       -- Emit external core
+             ioMsgMaybe $ 
+                   mkIface hsc_env mb_old_iface details simpl_result
+
+       -- Emit external core
        -- This should definitely be here and not after CorePrep,
        -- because CorePrep produces unqualified constructor wrapper declarations,
        -- so its output isn't valid External Core (without some preprocessing).
@@ -667,23 +840,23 @@ hscNormalIface simpl_result mb_old_iface
 -- BackEnd combinators
 --------------------------------------------------------------
 
-hscWriteIface :: GhcMonad m =>
-                 ModIface -> Bool
+hscWriteIface :: ModIface
+              -> Bool
               -> ModSummary
-              -> m ()
+              -> Hsc ()
+
 hscWriteIface iface no_change mod_summary
-    = do hsc_env <- getSession
-         let dflags = hsc_dflags hsc_env
-         liftIO $ do
+    = do dflags <- getDynFlags
          unless no_change
-           $ writeIfaceFile dflags (ms_location mod_summary) iface
+           $ liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
 
 -- | Compile to hard-code.
-hscGenHardCode :: GhcMonad m =>
-                  CgGuts -> ModSummary
-               -> m Bool -- ^ @True@ <=> stub.c exists
+hscGenHardCode :: CgGuts -> ModSummary
+               -> Hsc Bool -- ^ @True@ <=> stub.c exists
 hscGenHardCode cgguts mod_summary
-    = withSession $ \hsc_env -> liftIO $ do
+  = do
+    hsc_env <- getHscEnv
+    liftIO $ do
          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                      -- From now on, we just use the bits we need.
                      cg_module   = this_mod,
@@ -710,7 +883,8 @@ hscGenHardCode cgguts mod_summary
                 myCoreToStg dflags this_mod prepd_binds        
 
          ------------------  Code generation ------------------
-         cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
+         
+         cmms <- if dopt Opt_TryNewCodeGen dflags
                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
                                  dir_imps cost_centre_info
                                  stg_binds hpc_info
@@ -731,14 +905,13 @@ hscGenHardCode cgguts mod_summary
                 dependencies rawcmms
          return stub_c_exists
 
-hscInteractive :: GhcMonad m =>
-                  (ModIface, ModDetails, CgGuts)
+hscInteractive :: (ModIface, ModDetails, CgGuts)
                -> ModSummary
-               -> m (InteractiveStatus, ModIface, ModDetails)
+               -> Hsc (InteractiveStatus, ModIface, ModDetails)
 #ifdef GHCI
 hscInteractive (iface, details, cgguts) mod_summary
-    = do hsc_env <- getSession
-         liftIO $ do
+    = do
+         dflags <- getDynFlags
          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                      -- From now on, we just use the bits we need.
                      cg_module   = this_mod,
@@ -746,7 +919,7 @@ hscInteractive (iface, details, cgguts) mod_summary
                      cg_tycons   = tycons,
                      cg_foreign  = foreign_stubs,
                      cg_modBreaks = mod_breaks } = cgguts
-             dflags = hsc_dflags hsc_env
+
              location = ms_location mod_summary
              data_tycons = filter isDataTyCon tycons
              -- cg_tycons includes newtypes, for the benefit of External Core,
@@ -756,12 +929,13 @@ hscInteractive (iface, details, cgguts) mod_summary
          -- PREPARE FOR CODE GENERATION
          -- Do saturation and convert to A-normal form
          prepd_binds <- {-# SCC "CorePrep" #-}
-                        corePrepPgm dflags core_binds data_tycons ;
+                        liftIO $ corePrepPgm dflags core_binds data_tycons ;
          -----------------  Generate byte code ------------------
-         comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
+         comp_bc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks
          ------------------ Create f-x-dynamic C-side stuff ---
          (_istub_h_exists, istub_c_exists) 
-             <- outputForeignStubs dflags this_mod location foreign_stubs
+             <- liftIO $ outputForeignStubs dflags this_mod
+                                            location foreign_stubs
          return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
                 , iface, details)
 #else
@@ -770,15 +944,16 @@ hscInteractive _ _ = panic "GHC not compiled with interpreter"
 
 ------------------------------
 
-hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
-hscCmmFile hsc_env filename = do
-    dflags <- return $ hsc_dflags hsc_env
-    cmm <- ioMsgMaybe $
-             parseCmmFile dflags filename
-    cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
-    rawCmms <- liftIO $ cmmToRawCmm cmms
-    _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
-    return ()
+hscCompileCmmFile :: HscEnv -> FilePath -> IO ()
+hscCompileCmmFile hsc_env filename
+  = runHsc hsc_env $ do
+      let dflags = hsc_dflags hsc_env
+      cmm <- ioMsgMaybe $ parseCmmFile dflags filename
+      liftIO $ do
+        cmms <- optionallyConvertAndOrCPS hsc_env [cmm]
+        rawCmms <- cmmToRawCmm cmms
+        _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
+        return ()
   where
        no_mod = panic "hscCmmFile: no_mod"
        no_loc = ModLocation{ ml_hs_file  = Just filename,
@@ -905,116 +1080,155 @@ A naked expression returns a singleton Name [it].
 \begin{code}
 #ifdef GHCI
 hscStmt                -- Compile a stmt all the way to an HValue, but don't run it
-  :: GhcMonad m =>
-     HscEnv
+  :: HscEnv
   -> String                    -- The statement
-  -> m (Maybe ([Id], HValue))
+  -> IO (Maybe ([Id], HValue))
      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
-hscStmt hsc_env stmt = do
-    maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
+hscStmt hsc_env stmt = runHsc hsc_env $ do
+    maybe_stmt <- hscParseStmt stmt
     case maybe_stmt of
       Nothing -> return Nothing
       Just parsed_stmt -> do  -- The real stuff
 
              -- Rename and typecheck it
        let icontext = hsc_IC hsc_env
-       (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
+       (ids, tc_expr) <- ioMsgMaybe $ 
+                            tcRnStmt hsc_env icontext parsed_stmt
            -- Desugar it
        let rdr_env  = ic_rn_gbl_env icontext
            type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
        ds_expr <- ioMsgMaybe $
                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
+        handleWarnings
 
        -- Then desugar, code gen, and link it
        let src_span = srcLocSpan interactiveSrcLoc
-       hval <- liftIO $ compileExpr hsc_env src_span ds_expr
+        hsc_env <- getHscEnv
+       hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
 
        return $ Just (ids, hval)
 
-hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
-hscImport hsc_env str = do
-    (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
+hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
+hscImport hsc_env str = runHsc hsc_env $ do
+    (L _ (HsModule{hsmodImports=is})) <- 
+       hscParseThing parseModule str
     case is of
         [i] -> return (unLoc i)
-        _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))
+        _ -> liftIO $ throwOneError $
+                mkPlainErrMsg noSrcSpan $
+                    ptext (sLit "parse error in import declaration")
 
 hscTcExpr      -- Typecheck an expression (but don't run it)
-  :: GhcMonad m =>
-     HscEnv
+  :: HscEnv
   -> String                    -- The expression
-  -> m Type
+  -> IO Type
 
-hscTcExpr hsc_env expr = do
-    maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
-    let icontext = hsc_IC hsc_env
+hscTcExpr hsc_env expr = runHsc hsc_env $ do
+    maybe_stmt <- hscParseStmt expr
     case maybe_stmt of
-      Just (L _ (ExprStmt expr _ _)) -> do
-          ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
-          return ty
-      _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
-                        noSrcSpan
-                        (text "not an expression:" <+> quotes (text expr))
+      Just (L _ (ExprStmt expr _ _)) ->
+          ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+      _ -> 
+          liftIO $ throwIO $ mkSrcErr $ unitBag $ 
+              mkPlainErrMsg noSrcSpan
+                            (text "not an expression:" <+> quotes (text expr))
 
 -- | Find the kind of a type
 hscKcType
-  :: GhcMonad m =>
-     HscEnv
+  :: HscEnv
   -> String                    -- ^ The type
-  -> m Kind
+  -> IO Kind
 
-hscKcType hsc_env str = do
-    ty <- hscParseType (hsc_dflags hsc_env) str
-    let icontext = hsc_IC hsc_env
-    ioMsgMaybe $ tcRnType hsc_env icontext ty
+hscKcType hsc_env str = runHsc hsc_env $ do
+    ty <- hscParseType str
+    ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) ty
 
 #endif
 \end{code}
 
 \begin{code}
 #ifdef GHCI
-hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
+hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
 hscParseStmt = hscParseThing parseStmt
 
-hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
+hscParseType :: String -> Hsc (LHsType RdrName)
 hscParseType = hscParseThing parseType
 #endif
 
-hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
-hscParseIdentifier = hscParseThing parseIdentifier
+hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
+hscParseIdentifier hsc_env str = runHsc hsc_env $ 
+                                   hscParseThing parseIdentifier str
 
-hscParseThing :: (Outputable thing, GhcMonad m)
-             => Lexer.P thing
-             -> DynFlags -> String
-             -> m thing
-       -- Nothing => Parse error (message already printed)
-       -- Just x  => success
-hscParseThing parser dflags str
- = (liftIO $ showPass dflags "Parser") >>
-      {-# SCC "Parser" #-} do
 
-      buf <- liftIO $ stringToStringBuffer str
+hscParseThing :: (Outputable thing)
+             => Lexer.P thing
+             -> String
+             -> Hsc thing
 
-      let loc  = mkSrcLoc (fsLit "<interactive>") 1 1
+hscParseThing parser str
+ = {-# SCC "Parser" #-} do
+      dflags <- getDynFlags
+      liftIO $ showPass dflags "Parser"
+  
+      let buf = stringToStringBuffer str
+          loc = mkSrcLoc (fsLit "<interactive>") 1 1
 
       case unP parser (mkPState dflags buf loc) of
 
-       PFailed span err -> do
+        PFailed span err -> do
           let msg = mkPlainErrMsg span err
-          throw (mkSrcErr (unitBag msg))
+          liftIO $ throwIO (mkSrcErr (unitBag msg))
 
-       POk pst thing -> do
-
-          let ms@(warns, errs) = getMessages pst
-          logWarnings warns
-          when (errorsFound dflags ms) $ -- handle -Werror
-            throw (mkSrcErr errs)
-
-          --ToDo: can't free the string buffer until we've finished this
-          -- compilation sweep and all the identifiers have gone away.
+        POk pst thing -> do
+          logWarningsReportErrors (getMessages pst)
           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
           return thing
 \end{code}
 
+\begin{code}
+hscCompileCore :: HscEnv
+               -> Bool
+               -> ModSummary
+               -> [CoreBind]
+               -> IO ()
+
+hscCompileCore hsc_env simplify mod_summary binds
+  = runHsc hsc_env $ do
+      let maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
+                                  | otherwise = return mod_guts
+      guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds)
+      (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
+      hscWriteIface iface changed mod_summary
+      _ <- hscGenHardCode cgguts mod_summary
+      return ()
+
+-- Makes a "vanilla" ModGuts.
+mkModGuts :: Module -> [CoreBind] -> ModGuts
+mkModGuts mod binds = ModGuts {
+  mg_module = mod,
+  mg_boot = False,
+  mg_exports = [],
+  mg_deps = noDependencies,
+  mg_dir_imps = emptyModuleEnv,
+  mg_used_names = emptyNameSet,
+  mg_rdr_env = emptyGlobalRdrEnv,
+  mg_fix_env = emptyFixityEnv,
+  mg_types = emptyTypeEnv,
+  mg_insts = [],
+  mg_fam_insts = [],
+  mg_rules = [],
+  mg_binds = binds,
+  mg_foreign = NoStubs,
+  mg_warns = NoWarnings,
+  mg_anns = [],
+  mg_hpc_info = emptyHpcInfo False,
+  mg_modBreaks = emptyModBreaks,
+  mg_vect_info = noVectInfo,
+  mg_inst_env = emptyInstEnv,
+  mg_fam_inst_env = emptyFamInstEnv
+}
+\end{code}
+
 %************************************************************************
 %*                                                                     *
        Desugar, simplify, convert to bytecode, and link an expression
@@ -1023,46 +1237,44 @@ hscParseThing parser dflags str
 
 \begin{code}
 #ifdef GHCI
-compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
-
-compileExpr hsc_env srcspan ds_expr
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
+hscCompileCoreExpr hsc_env srcspan ds_expr
   | rtsIsProfiled
-  = throwIO (InstallationError "You can't call compileExpr in a profiled compiler")
+  = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
          -- Otherwise you get a seg-fault when you run it
 
-  | otherwise
-  = do { let { dflags  = hsc_dflags hsc_env ;
-               lint_on = dopt Opt_DoCoreLinting dflags }
-             
-               -- Simplify it
-       ; simpl_expr <- simplifyExpr dflags ds_expr
-
-               -- Tidy it (temporary, until coreSat does cloning)
-       ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
-
-               -- Prepare for codegen
-       ; prepd_expr <- corePrepExpr dflags tidy_expr
-
-               -- Lint if necessary
-               -- ToDo: improve SrcLoc
-       ; if lint_on then 
-                let ictxt = hsc_IC hsc_env
-                    tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
-                in
-               case lintUnfolding noSrcLoc tyvars prepd_expr of
-                  Just err -> pprPanic "compileExpr" err
-                  Nothing  -> return ()
-         else
-               return ()
-
-               -- Convert to BCOs
-       ; bcos <- coreExprToBCOs dflags prepd_expr
-
-               -- link it
-       ; hval <- linkExpr hsc_env srcspan bcos
-
-       ; return hval
-     }
+  | otherwise = do
+    let dflags = hsc_dflags hsc_env
+    let lint_on = dopt Opt_DoCoreLinting dflags
+
+       -- Simplify it
+    simpl_expr <- simplifyExpr dflags ds_expr
+
+       -- Tidy it (temporary, until coreSat does cloning)
+    let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
+
+       -- Prepare for codegen
+    prepd_expr <- corePrepExpr dflags tidy_expr
+
+       -- Lint if necessary
+       -- ToDo: improve SrcLoc
+    if lint_on then 
+       let ictxt = hsc_IC hsc_env
+           tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
+       in
+           case lintUnfolding noSrcLoc tyvars prepd_expr of
+             Just err -> pprPanic "hscCompileCoreExpr" err
+             Nothing  -> return ()
+    else
+       return ()
+
+          -- Convert to BCOs
+    bcos <- coreExprToBCOs dflags prepd_expr
+
+       -- link it
+    hval <- linkExpr hsc_env srcspan bcos
+
+    return hval
 #endif
 \end{code}
 
index 1124f99..33b4448 100644 (file)
@@ -6,29 +6,15 @@
 \begin{code}
 -- | Types for the per-module compiler
 module HscTypes ( 
-        -- * 'Ghc' monad stuff
-        Ghc(..), GhcT(..), liftGhcT,
-        GhcMonad(..), WarnLogMonad(..),
-        liftIO,
-        ioMsgMaybe, ioMsg,
-        logWarnings, clearWarnings, hasWarnings,
-        SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
-        throwOneError, handleSourceError,
-        reflectGhc, reifyGhc,
-        handleFlagWarnings,
-
-       -- * Sessions and compilation state
-       Session(..), withSession, modifySession, withTempSession,
+       -- * compilation state
         HscEnv(..), hscEPS,
        FinderCache, FindResult(..), ModLocationCache,
        Target(..), TargetId(..), pprTarget, pprTargetId,
        ModuleGraph, emptyMG,
-        -- ** Callbacks
-        GhcApiCallbacks(..), withLocalCallbacks,
 
         -- * Information about modules
        ModDetails(..), emptyModDetails,
-       ModGuts(..), CoreModule(..), CgGuts(..), ForeignStubs(..),
+       ModGuts(..), CgGuts(..), ForeignStubs(..),
         ImportedMods,
 
        ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
@@ -102,7 +88,12 @@ module HscTypes (
 
         -- * Vectorisation information
         VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, 
-        noIfaceVectInfo
+        noIfaceVectInfo,
+
+        -- * Compilation errors and warnings
+        SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
+        throwOneError, handleSourceError,
+        handleFlagWarnings, printOrThrowWarnings,
     ) where
 
 #include "HsVersions.h"
@@ -163,22 +154,12 @@ import Data.List
 import Data.Map (Map)
 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
-\end{code}
 
+-- -----------------------------------------------------------------------------
+-- Source Errors
 
-%************************************************************************
-%*                                                                     *
-\subsection{Compilation environment}
-%*                                                                     *
-%************************************************************************
-
-
-\begin{code}
--- | The Session is a handle to the complete state of a compilation
--- session.  A compilation session consists of a set of modules
--- constituting the current program or library, the context for
--- interactive evaluation, and various caches.
-data Session = Session !(IORef HscEnv) !(IORef WarningMessages)
+-- When the compiler (HscMain) discovers errors, it throws an
+-- exception in the IO monad.
 
 mkSrcErr :: ErrorMessages -> SourceError
 srcErrorMessages :: SourceError -> ErrorMessages
@@ -246,255 +227,25 @@ instance Exception GhcApiError
 
 mkApiErr = GhcApiError
 
--- | A monad that allows logging of warnings.
-class Monad m => WarnLogMonad m where
-  setWarnings  :: WarningMessages -> m ()
-  getWarnings :: m WarningMessages
-
-logWarnings :: WarnLogMonad m => WarningMessages -> m ()
-logWarnings warns = do
-    warns0 <- getWarnings
-    setWarnings (unionBags warns warns0)
-
--- | Clear the log of 'Warnings'.
-clearWarnings :: WarnLogMonad m => m ()
-clearWarnings = setWarnings emptyBag
-
--- | Returns true if there were any warnings.
-hasWarnings :: WarnLogMonad m => m Bool
-hasWarnings = getWarnings >>= return . not . isEmptyBag
-
--- | A monad that has all the features needed by GHC API calls.
---
--- In short, a GHC monad
---
---   - allows embedding of IO actions,
---
---   - can log warnings,
---
---   - allows handling of (extensible) exceptions, and
---
---   - maintains a current session.
---
--- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
--- before any call to the GHC API functions can occur.
---
-class (Functor m, MonadIO m, WarnLogMonad m, ExceptionMonad m)
-    => GhcMonad m where
-  getSession :: m HscEnv
-  setSession :: HscEnv -> m ()
-
--- | Call the argument with the current session.
-withSession :: GhcMonad m => (HscEnv -> m a) -> m a
-withSession f = getSession >>= f
-
--- | Set the current session to the result of applying the current session to
--- the argument.
-modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
-modifySession f = do h <- getSession
-                     setSession $! f h
-
-withSavedSession :: GhcMonad m => m a -> m a
-withSavedSession m = do
-  saved_session <- getSession
-  m `gfinally` setSession saved_session
-
--- | Call an action with a temporarily modified Session.
-withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
-withTempSession f m =
-  withSavedSession $ modifySession f >> m
-
--- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
--- e.g., to maintain additional state consider wrapping this monad or using
--- 'GhcT'.
-newtype Ghc a = Ghc { unGhc :: Session -> IO a }
-
-instance Functor Ghc where
-  fmap f m = Ghc $ \s -> f `fmap` unGhc m s
-
-instance Monad Ghc where
-  return a = Ghc $ \_ -> return a
-  m >>= g  = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
-
-instance MonadIO Ghc where
-  liftIO ioA = Ghc $ \_ -> ioA
-
-instance ExceptionMonad Ghc where
-  gcatch act handle =
-      Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
-  gblock (Ghc m)   = Ghc $ \s -> gblock (m s)
-  gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
-  gmask f =
-      Ghc $ \s -> gmask $ \io_restore ->
-                             let
-                                g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
-                             in
-                                unGhc (f g_restore) s
-
-instance WarnLogMonad Ghc where
-  setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
-  -- | Return 'Warnings' accumulated so far.
-  getWarnings       = Ghc $ \(Session _ wref) -> readIORef wref
-
-instance GhcMonad Ghc where
-  getSession = Ghc $ \(Session r _) -> readIORef r
-  setSession s' = Ghc $ \(Session r _) -> writeIORef r s'
-
--- | A monad transformer to add GHC specific features to another monad.
---
--- Note that the wrapped monad must support IO and handling of exceptions.
-newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
-liftGhcT :: Monad m => m a -> GhcT m a
-liftGhcT m = GhcT $ \_ -> m
-
-instance Functor m => Functor (GhcT m) where
-  fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
-
-instance Monad m => Monad (GhcT m) where
-  return x = GhcT $ \_ -> return x
-  m >>= k  = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
-
-instance MonadIO m => MonadIO (GhcT m) where
-  liftIO ioA = GhcT $ \_ -> liftIO ioA
-
-instance ExceptionMonad m => ExceptionMonad (GhcT m) where
-  gcatch act handle =
-      GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
-  gblock (GhcT m) = GhcT $ \s -> gblock (m s)
-  gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
-  gmask f =
-      GhcT $ \s -> gmask $ \io_restore ->
-                           let
-                              g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
-                           in
-                              unGhcT (f g_restore) s
-
-instance MonadIO m => WarnLogMonad (GhcT m) where
-  setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
-  -- | Return 'Warnings' accumulated so far.
-  getWarnings       = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref
-
-instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
-  getSession = GhcT $ \(Session r _) -> liftIO $ readIORef r
-  setSession s' = GhcT $ \(Session r _) -> liftIO $ writeIORef r s'
-
--- | Lift an IO action returning errors messages into a 'GhcMonad'.
---
--- In order to reduce dependencies to other parts of the compiler, functions
--- outside the "main" parts of GHC return warnings and errors as a parameter
--- and signal success via by wrapping the result in a 'Maybe' type.  This
--- function logs the returned warnings and propagates errors as exceptions
--- (of type 'SourceError').
---
--- This function assumes the following invariants:
---
---  1. If the second result indicates success (is of the form 'Just x'),
---     there must be no error messages in the first result.
---
---  2. If there are no error messages, but the second result indicates failure
---     there should be warnings in the first result.  That is, if the action
---     failed, it must have been due to the warnings (i.e., @-Werror@).
-ioMsgMaybe :: GhcMonad m =>
-              IO (Messages, Maybe a) -> m a
-ioMsgMaybe ioA = do
-  ((warns,errs), mb_r) <- liftIO ioA
-  logWarnings warns
-  case mb_r of
-    Nothing -> liftIO $ throwIO (mkSrcErr errs)
-    Just r  -> ASSERT( isEmptyBag errs ) return r
-
--- | Lift a non-failing IO action into a 'GhcMonad'.
---
--- Like 'ioMsgMaybe', but assumes that the action will never return any error
--- messages.
-ioMsg :: GhcMonad m => IO (Messages, a) -> m a
-ioMsg ioA = do
-    ((warns,errs), r) <- liftIO ioA
-    logWarnings warns
-    ASSERT( isEmptyBag errs ) return r
-
--- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
---
--- You can use this to call functions returning an action in the 'Ghc' monad
--- inside an 'IO' action.  This is needed for some (too restrictive) callback
--- arguments of some library functions:
---
--- > libFunc :: String -> (Int -> IO a) -> IO a
--- > ghcFunc :: Int -> Ghc a
--- >
--- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
--- > ghcFuncUsingLibFunc str =
--- >   reifyGhc $ \s ->
--- >     libFunc $ \i -> do
--- >       reflectGhc (ghcFunc i) s
---
-reflectGhc :: Ghc a -> Session -> IO a
-reflectGhc m = unGhc m
-
--- > Dual to 'reflectGhc'.  See its documentation.
-reifyGhc :: (Session -> IO a) -> Ghc a
-reifyGhc act = Ghc $ act
+-- | Given a bag of warnings, turn them into an exception if
+-- -Werror is enabled, or print them out otherwise.
+printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
+printOrThrowWarnings dflags warns
+  | dopt Opt_WarnIsError dflags
+  = when (not (isEmptyBag warns)) $ do
+      throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg
+  | otherwise
+  = printBagOfWarnings dflags warns
 
-handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m ()
+handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
 handleFlagWarnings dflags warns
- = when (dopt Opt_WarnDeprecatedFlags dflags)
-        (handleFlagWarnings' dflags warns)
-
-handleFlagWarnings' :: GhcMonad m => DynFlags -> [Located String] -> m ()
-handleFlagWarnings' _ [] = return ()
-handleFlagWarnings' dflags warns
- = do -- It would be nicer if warns :: [Located Message], but that has circular
-      -- import problems.
-      logWarnings $ listToBag (map mkFlagWarning warns)
-      when (dopt Opt_WarnIsError dflags) $
-        liftIO $ throwIO $ mkSrcErr emptyBag
-
-mkFlagWarning :: Located String -> WarnMsg
-mkFlagWarning (L loc warn)
- = mkPlainWarnMsg loc (text warn)
-\end{code}
-
-\begin{code}
--- | These functions are called in various places of the GHC API.
---
--- API clients can override any of these callbacks to change GHC's default
--- behaviour.
-data GhcApiCallbacks
-  = GhcApiCallbacks {
-
-    -- | Called by 'load' after the compilating of each module.
-    --
-    -- The default implementation simply prints all warnings and errors to
-    -- @stderr@.  Don't forget to call 'clearWarnings' when implementing your
-    -- own call.
-    --
-    -- The first argument is the module that was compiled.
-    --
-    -- The second argument is @Nothing@ if no errors occured, but there may
-    -- have been warnings.  If it is @Just err@ at least one error has
-    -- occured.  If 'srcErrorMessages' is empty, compilation failed due to
-    -- @-Werror@.
-    reportModuleCompilationResult :: GhcMonad m =>
-                                     ModSummary -> Maybe SourceError
-                                  -> m ()
-  }
-
--- | Temporarily modify the callbacks.  After the action is executed all
--- callbacks are reset (not, however, any other modifications to the session
--- state.)
-withLocalCallbacks :: GhcMonad m =>
-                      (GhcApiCallbacks -> GhcApiCallbacks)
-                   -> m a -> m a
-withLocalCallbacks f m = do
-  hsc_env <- getSession
-  let cb0 = hsc_callbacks hsc_env
-  let cb' = f cb0
-  setSession (hsc_env { hsc_callbacks = cb' `seq` cb' })
-  r <- m
-  hsc_env' <- getSession
-  setSession (hsc_env' { hsc_callbacks = cb0 })
-  return r
+ = when (dopt Opt_WarnDeprecatedFlags dflags) $ do
+        -- It would be nicer if warns :: [Located Message], but that
+        -- has circular import problems.
+      let bag = listToBag [ mkPlainWarnMsg loc (text warn) 
+                          | L loc warn <- warns ]
 
+      printOrThrowWarnings dflags bag
 \end{code}
 
 \begin{code}
@@ -513,9 +264,6 @@ data HscEnv
        hsc_dflags :: DynFlags,
                -- ^ The dynamic flag settings
 
-        hsc_callbacks :: GhcApiCallbacks,
-                -- ^ Callbacks for the GHC API.
-
        hsc_targets :: [Target],
                -- ^ The targets (or roots) of the current session
 
@@ -1006,24 +754,6 @@ data ModGuts
 --     mg_rules        Orphan rules only (local ones now attached to binds)
 --     mg_binds        With rules attached
 
--- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
--- the 'GHC.compileToCoreModule' interface.
-data CoreModule
-  = CoreModule {
-      -- | Module name
-      cm_module   :: !Module,
-      -- | Type environment for types declared in this module
-      cm_types    :: !TypeEnv,
-      -- | Declarations
-      cm_binds    :: [CoreBind],
-      -- | Imports
-      cm_imports  :: ![Module]
-    }
-
-instance Outputable CoreModule where
-   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) =
-      text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb)
-
 -- The ModGuts takes on several slightly different forms:
 --
 -- After simplification, the following fields change slightly:
index 4161d98..f1ecd87 100644 (file)
@@ -37,12 +37,12 @@ module InteractiveEval (
 
 #include "HsVersions.h"
 
-import HscMain          hiding (compileExpr)
+import GhcMonad
+import HscMain
 import HsSyn (ImportDecl)
 import HscTypes
 import TcRnDriver
-import TcRnMonad (initTc)
-import RnNames         (gresFromAvails, rnImports)
+import RnNames         (gresFromAvails)
 import InstEnv
 import Type
 import TcType          hiding( typeKind )
@@ -201,20 +201,12 @@ runStmt expr step =
     let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
         hsc_env' = hsc_env{ hsc_dflags = dflags' }
 
-    r <- hscStmt hsc_env' expr
+    r <- liftIO $ hscStmt hsc_env' expr
 
     case r of
       Nothing -> return RunFailed -- empty statement / comment
 
       Just (ids, hval) -> do
-          -- XXX: This is the only place we can print warnings before the
-          -- result.  Is this really the right thing to do?  It's fine for
-          -- GHCi, but what's correct for other GHC API clients?  We could
-          -- introduce a callback argument.
-        warns <- getWarnings
-        liftIO $ printBagOfWarnings dflags' warns
-        clearWarnings
-
         status <-
           withVirtualCWD $
             withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
@@ -254,7 +246,7 @@ withVirtualCWD m = do
   gbracket set_cwd reset_cwd $ \_ -> m
 
 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
-parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
+parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
 
 emptyHistory :: BoundedList History
 emptyHistory = nilBL 50 -- keep a log of length 50
@@ -790,11 +782,9 @@ setContext toplev_mods other_mods = do
     export_env  <- liftIO $ mkExportEnv hsc_env export_mods
     import_env  <-
         if null imprt_decls then return emptyGlobalRdrEnv else do
-            let imports = rnImports imprt_decls
-                this_mod = if null toplev_mods then pRELUDE else head toplev_mods
-            (_, env, _,_) <-
-                ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
-            return env
+            let this_mod | null toplev_mods = pRELUDE
+                         | otherwise        = head toplev_mods
+            liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
     toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
     let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
     modifySession $ \_ ->
@@ -859,7 +849,7 @@ moduleIsInterpreted modl = withSession $ \h ->
 getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
 getInfo name
   = withSession $ \hsc_env ->
-    do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
+    do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
        case mb_stuff of
          Nothing -> return Nothing
          Just (thing, fixity, ispecs) -> do
@@ -911,8 +901,8 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 -- the identifier can refer to in the current interactive context.
 parseName :: GhcMonad m => String -> m [Name]
 parseName str = withSession $ \hsc_env -> do
-   (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
-   ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
+   (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
+   liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
 
 -- -----------------------------------------------------------------------------
 -- Getting the type of an expression
@@ -920,7 +910,7 @@ parseName str = withSession $ \hsc_env -> do
 -- | Get the type of an expression
 exprType :: GhcMonad m => String -> m Type
 exprType expr = withSession $ \hsc_env -> do
-   ty <- hscTcExpr hsc_env expr
+   ty <- liftIO $ hscTcExpr hsc_env expr
    return $ tidyType emptyTidyEnv ty
 
 -- -----------------------------------------------------------------------------
@@ -929,14 +919,14 @@ exprType expr = withSession $ \hsc_env -> do
 -- | Get the kind of a  type
 typeKind  :: GhcMonad m => String -> m Kind
 typeKind str = withSession $ \hsc_env -> do
-   hscKcType hsc_env str
+   liftIO $ hscKcType hsc_env str
 
 -----------------------------------------------------------------------------
 -- cmCompileExpr: compile an expression and deliver an HValue
 
 compileExpr :: GhcMonad m => String -> m HValue
 compileExpr expr = withSession $ \hsc_env -> do
-  Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+  Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
                 -- Run it!
   hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
 
@@ -955,7 +945,8 @@ dynCompileExpr expr = do
             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
         ,Nothing):exports
     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
-    Just (ids, hvals) <- withSession (flip hscStmt stmt)
+    Just (ids, hvals) <- withSession $ \hsc_env -> 
+                           liftIO $ hscStmt hsc_env stmt
     setContext full exports
     vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
     case (ids,vals) of
index bc01bf6..a9a9c46 100644 (file)
@@ -1499,11 +1499,23 @@ exportClashErr global_env name1 name2 ie1 ie2
        = case lookupGRE_Name global_env name of
             (gre:_) -> gre
             []      -> pprPanic "exportClashErr" (ppr name)
-    get_loc name = nameSrcLoc $ gre_name $ get_gre name
+    get_loc name = greSrcSpan (get_gre name)
     (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
                                    then (name1, ie1, name2, ie2)
                                    else (name2, ie2, name1, ie1)
 
+-- the SrcSpan that pprNameProvenance prints out depends on whether
+-- the Name is defined locally or not: for a local definition the
+-- definition site is used, otherwise the location of the import
+-- declaration.  We want to sort the export locations in
+-- exportClashErr by this SrcSpan, we need to extract it:
+greSrcSpan :: GlobalRdrElt -> SrcSpan
+greSrcSpan gre
+  | Imported (is:_) <- gre_prov gre = is_dloc (is_decl is)
+  | otherwise                       = name_span
+  where
+    name_span = nameSrcSpan (gre_name gre)
+
 addDupDeclErr :: [Name] -> TcRn ()
 addDupDeclErr []
   = panic "addDupDeclErr: empty list"
index e3dbf3a..d821d40 100644 (file)
@@ -79,6 +79,7 @@ import Bag
 import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
+import MonadUtils
 
 import Util            ( split )
 import Data.List       ( intersperse )
index 097db04..65128ba 100644 (file)
@@ -168,9 +168,8 @@ initTcPrintErrors   -- Used from the interactive loop only
        -> Module 
        -> TcM r
        -> IO (Messages, Maybe r)
-initTcPrintErrors env mod todo = do
-  (msgs, res) <- initTc env HsSrcFile False mod todo
-  return (msgs, res)
+
+initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
 \end{code}
 
 %************************************************************************
index 2a3bce6..7e46e52 100644 (file)
@@ -787,7 +787,7 @@ runMeta show_code run_and_convert expr
        ; hsc_env <- getTopEnv
        ; src_span <- getSrcSpanM
        ; either_hval <- tryM $ liftIO $
-                        HscMain.compileExpr hsc_env src_span ds_expr
+                        HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
        ; case either_hval of {
            Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
            Right hval -> do
index dc54620..75a88df 100644 (file)
@@ -27,16 +27,16 @@ module MonadUtils
 
 import Outputable 
 
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- Detection of available libraries
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 -- we don't depend on MTL for now
 #define HAVE_MTL 0
 
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- Imports
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 import Maybes
 
@@ -47,9 +47,9 @@ import Control.Monad.Trans
 import Control.Monad
 import Control.Monad.Fix
 
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- The ID monad
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 newtype ID a = ID a
 instance Monad ID where
@@ -61,9 +61,9 @@ instance Monad ID where
 runID :: ID a -> a
 runID (ID x) = x
 
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- MTL
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 #if !HAVE_MTL
 
@@ -73,10 +73,10 @@ class Monad m => MonadIO m where
 instance MonadIO IO where liftIO = id
 #endif
 
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- Lift combinators
 --  These are used throughout the compiler
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 -- | Lift an 'IO' operation with 1 argument into another monad
 liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b
@@ -94,10 +94,10 @@ liftIO3 = ((.).((.).(.))) liftIO
 liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e
 liftIO4 = (((.).(.)).((.).(.))) liftIO
 
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 -- Common functions
 --  These are used throughout the compiler
-----------------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 
 zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
 zipWith3M _ []     _      _      = return []
index 2b3b775..869cb8a 100644 (file)
@@ -138,8 +138,9 @@ appendStringBuffers sb1 sb2
           calcLen sb = len sb - cur sb
           size =  sb1_len + sb2_len
 
-stringToStringBuffer :: String -> IO StringBuffer
-stringToStringBuffer str = do
+stringToStringBuffer :: String -> StringBuffer
+stringToStringBuffer str =
+ unsafePerformIO $ do
   let size = utf8EncodedLength str
   buf <- mallocForeignPtrArray (size+3)
   withForeignPtr buf $ \ptr -> do
index 223d88b..b4b383e 100644 (file)
@@ -25,6 +25,8 @@ import OccName
 import BasicTypes           ( isLoopBreaker )
 import Outputable
 import Util                 ( zipLazy )
+import MonadUtils
+
 import Control.Monad
 
 debug          = False
index 42c1435..6ead3d0 100644 (file)
@@ -31,6 +31,7 @@ import Vectorise.Builtins
 import Vectorise.Env
 
 import HscTypes hiding  ( MonadThings(..) )
+import MonadUtils (liftIO)
 import Module
 import TyCon
 import Var
index 5494b4e..82f2aa7 100644 (file)
@@ -14,12 +14,13 @@ module GhciMonad where
 #include "HsVersions.h"
 
 import qualified GHC
+import GhcMonad         hiding (liftIO)
 import Outputable       hiding (printForUser, printForUserPartWay)
 import qualified Outputable
 import Panic            hiding (showException)
 import Util
 import DynFlags
-import HscTypes hiding (liftIO)
+import HscTypes
 import SrcLoc
 import Module
 import ObjLink
@@ -28,13 +29,10 @@ import StaticFlags
 import qualified MonadUtils
 
 import Exception
--- import Data.Maybe
 import Numeric
 import Data.Array
--- import Data.Char
 import Data.Int         ( Int64 )
 import Data.IORef
--- import Data.List
 import System.CPUTime
 import System.Environment
 import System.IO
@@ -181,10 +179,6 @@ instance GhcMonad (InputT GHCi) where
 instance MonadUtils.MonadIO (InputT GHCi) where
   liftIO = Trans.liftIO
 
-instance WarnLogMonad (InputT GHCi) where
-  setWarnings = lift . setWarnings
-  getWarnings = lift getWarnings
-
 instance ExceptionMonad GHCi where
   gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
   gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
@@ -196,10 +190,6 @@ instance ExceptionMonad GHCi where
                              in
                                 unGHCi (f g_restore) s
 
-instance WarnLogMonad GHCi where
-  setWarnings warns = liftGhc $ setWarnings warns
-  getWarnings = liftGhc $ getWarnings
-
 instance MonadIO GHCi where
   liftIO = io
 
@@ -263,7 +253,7 @@ runStmt expr step = do
     withProgName (progname st) $
     withArgs (args st) $
       reflectGHCi x $ do
-        GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+        GHC.handleSourceError (\e -> do GHC.printException e
                                         return GHC.RunFailed) $ do
           GHC.runStmt expr step
 
index 7249ef4..ef81535 100644 (file)
@@ -599,7 +599,7 @@ runOneCommand eh getCmd = do
                (doCommand c)
   where
     printErrorAndKeepGoing err = do
-        GHC.printExceptionAndWarnings err
+        GHC.printException err
         return False
 
     noSpace q = q >>= maybe (return Nothing)
@@ -815,7 +815,7 @@ help _ = io (putStr helpText)
 
 info :: String -> InputT GHCi ()
 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info s  = handleSourceError GHC.printExceptionAndWarnings $
+info s  = handleSourceError GHC.printException $
           withFlattenedDynflags $ do
              { let names = words s
             ; dflags <- getDynFlags
@@ -894,8 +894,7 @@ changeDirectory "" = do
 changeDirectory dir = do
   graph <- GHC.getModuleGraph
   when (not (null graph)) $
-        do liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,"
-           liftIO $ putStrLn "because the search path has changed."
+        liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
   prev_context <- GHC.getContext
   GHC.setTargets []
   _ <- GHC.load LoadAllTargets
@@ -906,7 +905,7 @@ changeDirectory dir = do
 
 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
 trySuccess act =
-    handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+    handleSourceError (\e -> do GHC.printException e
                                 return Failed) $ do
       act
 
@@ -977,7 +976,7 @@ defineMacro overwrite s = do
   let new_expr = '(' : definition ++ ") :: String -> IO String"
 
   -- compile the expression
-  handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+  handleSourceError (\e -> GHC.printException e) $
    withFlattenedDynflags $ do
     hv <- GHC.compileExpr new_expr
     io (writeIORef macros_ref --
@@ -1005,7 +1004,7 @@ undefineMacro str = mapM_ undef (words str)
 cmdCmd :: String -> GHCi ()
 cmdCmd str = do
   let expr = '(' : str ++ ") :: IO String"
-  handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+  handleSourceError (\e -> GHC.printException e) $
    withFlattenedDynflags $ do
     hv <- GHC.compileExpr expr
     cmds <- io $ (unsafeCoerce# hv :: IO String)
@@ -1048,7 +1047,7 @@ checkModule :: String -> InputT GHCi ()
 checkModule m = do
   let modl = GHC.mkModuleName m
   prev_context <- GHC.getContext
-  ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
+  ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
           r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
           liftIO $ putStrLn $ showSDoc $
           case GHC.moduleInfo r of
@@ -1169,7 +1168,7 @@ modulesLoadedMsg ok mods = do
 
 typeOfExpr :: String -> InputT GHCi ()
 typeOfExpr str 
-  = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+  = handleSourceError GHC.printException
   $ withFlattenedDynflags
   $ do
        ty <- GHC.exprType str
@@ -1179,7 +1178,7 @@ typeOfExpr str
 
 kindOfType :: String -> InputT GHCi ()
 kindOfType str 
-  = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+  = handleSourceError GHC.printException
   $ withFlattenedDynflags
   $ do
        ty <- GHC.typeKind str
@@ -1506,7 +1505,7 @@ newDynFlags minus_opts = do
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
       (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
-      handleFlagWarnings dflags' warns
+      liftIO $ handleFlagWarnings dflags' warns
 
       if (not (null leftovers))
         then ghcError $ errorsToGhcException leftovers
@@ -1855,7 +1854,7 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m
                               -> (Name -> m ())
                               -> m ()
 wantNameFromInterpretedModule noCanDo str and_then =
-  handleSourceError (GHC.printExceptionAndWarnings) $ do
+  handleSourceError GHC.printException $ do
    names <- GHC.parseName str
    case names of
       []    -> return ()
index fab773b..53a7af1 100644 (file)
@@ -14,8 +14,8 @@ module Main (main) where
 import qualified GHC
 import GHC             ( -- DynFlags(..), HscTarget(..),
                           -- GhcMode(..), GhcLink(..),
-                         LoadHowMuch(..), -- dopt, DynFlag(..),
-                          defaultCallbacks )
+                          Ghc, GhcMonad(..),
+                         LoadHowMuch(..) )
 import CmdLineParser
 
 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
@@ -44,7 +44,7 @@ import Outputable
 import SrcLoc
 import Util
 import Panic
--- import MonadUtils       ( liftIO )
+import MonadUtils       ( liftIO )
 
 -- Imports for --abi-hash
 import LoadIface           ( loadUserInterface )
@@ -167,9 +167,9 @@ main' postLoadMode dflags0 args flagWarnings = do
   let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
 
   handleSourceError (\e -> do
-       GHC.printExceptionAndWarnings e
-       liftIO $ exitWith (ExitFailure 1)) $
-    handleFlagWarnings dflags2 flagWarnings'
+       GHC.printException e
+       liftIO $ exitWith (ExitFailure 1)) $ do
+         liftIO $ handleFlagWarnings dflags2 flagWarnings'
 
         -- make sure we clean up after ourselves
   GHC.defaultCleanupHandler dflags2 $ do
@@ -204,14 +204,13 @@ main' postLoadMode dflags0 args flagWarnings = do
 
   ---------------- Do the business -----------
   handleSourceError (\e -> do
-       GHC.printExceptionAndWarnings e
+       GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
     case postLoadMode of
        ShowInterface f        -> liftIO $ doShowIface dflags3 f
        DoMake                 -> doMake srcs
-       DoMkDependHS           -> do doMkDependHS (map fst srcs)
-                                    GHC.printWarnings
-       StopBefore p           -> oneShot hsc_env p srcs >> GHC.printWarnings
+       DoMkDependHS           -> doMkDependHS (map fst srcs)
+       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
        DoInteractive          -> interactiveUI srcs Nothing
        DoEval exprs           -> interactiveUI srcs $ Just $ reverse exprs
        DoAbiHash              -> abiHash srcs
@@ -601,13 +600,10 @@ doMake srcs  = do
     -- This means that "ghc Foo.o Bar.o -o baz" links the program as
     -- we expect.
     if (null hs_srcs)
-       then oneShot hsc_env StopLn srcs >> GHC.printWarnings
+       then liftIO (oneShot hsc_env StopLn srcs)
        else do
 
-    o_files <- mapM (\x -> do
-                        f <- compileFile hsc_env StopLn x
-                        GHC.printWarnings
-                        return f)
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
                  non_hs_srcs
     liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
 
@@ -624,7 +620,7 @@ doMake srcs  = do
 
 doShowIface :: DynFlags -> FilePath -> IO ()
 doShowIface dflags file = do
-  hsc_env <- newHscEnv defaultCallbacks dflags
+  hsc_env <- newHscEnv dflags
   showIface hsc_env file
 
 -- ---------------------------------------------------------------------------