Major refactoring of CoAxioms
[ghc.git] / compiler / main / GHC.hs
index db8887a..6c31e2e 100644 (file)
@@ -7,12 +7,12 @@
 -- -----------------------------------------------------------------------------
 
 module GHC (
-       -- * Initialisation
-       defaultErrorHandler,
-       defaultCleanupHandler,
+        -- * Initialisation
+        defaultErrorHandler,
+        defaultCleanupHandler,
 
         -- * GHC Monad
-        Ghc, GhcT, GhcMonad(..),
+        Ghc, GhcT, GhcMonad(..), HscEnv,
         runGhc, runGhcT, initGhcMonad,
         gcatch, gbracket, gfinally,
         printException,
@@ -20,79 +20,84 @@ module GHC (
         handleSourceError,
         needsTemplateHaskell,
 
-       -- * Flags and settings
-       DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+        -- * Flags and settings
+        DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
         GhcMode(..), GhcLink(..), defaultObjectTarget,
-       parseDynamicFlags,
-       getSessionDynFlags,
-       setSessionDynFlags,
-       parseStaticFlags,
-
-       -- * Targets
-       Target(..), TargetId(..), Phase,
-       setTargets,
-       getTargets,
-       addTarget,
-       removeTarget,
-       guessTarget,
-       
-       -- * Loading\/compiling the program
-       depanal,
-       load, LoadHowMuch(..),
-       SuccessFlag(..), succeeded, failed,
+        parseDynamicFlags,
+        getSessionDynFlags,
+        setSessionDynFlags,
+        parseStaticFlags,
+
+        -- * Targets
+        Target(..), TargetId(..), Phase,
+        setTargets,
+        getTargets,
+        addTarget,
+        removeTarget,
+        guessTarget,
+        
+        -- * Loading\/compiling the program
+        depanal,
+        load, LoadHowMuch(..), InteractiveImport(..),
+        SuccessFlag(..), succeeded, failed,
         defaultWarnErrLogger, WarnErrLogger,
-       workingDirectoryChanged,
+        workingDirectoryChanged,
         parseModule, typecheckModule, desugarModule, loadModule,
         ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
-       TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
+        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
         TypecheckedMod, ParsedMod,
         moduleInfo, renamedSource, typecheckedSource,
         parsedSource, coreModule,
+
+        -- ** Compiling to Core
+        CoreModule(..),
         compileToCoreModule, compileToCoreSimplified,
         compileCoreToObj,
-        getModSummary,
 
-       -- * Inspecting the module structure of the program
-       ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
-       getModuleGraph,
-       isLoaded,
-       topSortModuleGraph,
-
-       -- * Inspecting modules
-       ModuleInfo,
-       getModuleInfo,
-       modInfoTyThings,
-       modInfoTopLevelScope,
+        -- * Inspecting the module structure of the program
+        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
+        getModSummary,
+        getModuleGraph,
+        isLoaded,
+        topSortModuleGraph,
+
+        -- * Inspecting modules
+        ModuleInfo,
+        getModuleInfo,
+        modInfoTyThings,
+        modInfoTopLevelScope,
         modInfoExports,
-       modInfoInstances,
-       modInfoIsExportedName,
-       modInfoLookupName,
-       lookupGlobalName,
-       findGlobalAnns,
+        modInfoInstances,
+        modInfoIsExportedName,
+        modInfoLookupName,
+        modInfoIface,
+        lookupGlobalName,
+        findGlobalAnns,
         mkPrintUnqualifiedForModule,
+        ModIface(..),
 
         -- * Querying the environment
         packageDbModules,
 
-       -- * Printing
-       PrintUnqualified, alwaysQualify,
+        -- * Printing
+        PrintUnqualified, alwaysQualify,
 
-       -- * Interactive evaluation
-       getBindings, getPrintUnqual,
-        findModule,
-        lookupModule,
+        -- * Interactive evaluation
+        getBindings, getInsts, getPrintUnqual,
+        findModule, lookupModule,
 #ifdef GHCI
-       setContext, getContext, 
-       getNamesInScope,
-       getRdrNamesInScope,
+        isModuleTrusted,
+        setContext, getContext, 
+        getNamesInScope,
+        getRdrNamesInScope,
         getGRE,
-       moduleIsInterpreted,
-       getInfo,
-       exprType,
-       typeKind,
-       parseName,
-       RunResult(..),  
-       runStmt, runStmtWithLocation,
+        moduleIsInterpreted,
+        getInfo,
+        exprType,
+        typeKind,
+        parseName,
+        RunResult(..),  
+        runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
         parseImportDecl, SingleStep(..),
         resume,
         Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
@@ -103,9 +108,9 @@ module GHC (
         abandon, abandonAll,
         InteractiveEval.back,
         InteractiveEval.forward,
-       showModule,
+        showModule,
         isModuleInterpreted,
-       InteractiveEval.compileExpr, HValue, dynCompileExpr,
+        InteractiveEval.compileExpr, HValue, dynCompileExpr,
         GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
         modInfoModBreaks,
         ModBreaks(..), BreakIndex,
@@ -114,104 +119,106 @@ module GHC (
 #endif
         lookupName,
 
-       -- * Abstract syntax elements
+        -- * Abstract syntax elements
 
         -- ** Packages
         PackageId,
 
-       -- ** Modules
-       Module, mkModule, pprModule, moduleName, modulePackageId,
+        -- ** Modules
+        Module, mkModule, pprModule, moduleName, modulePackageId,
         ModuleName, mkModuleName, moduleNameString,
 
-       -- ** Names
-       Name, 
-       isExternalName, nameModule, pprParenSymName, nameSrcSpan,
-       NamedThing(..),
-       RdrName(Qual,Unqual),
-       
-       -- ** Identifiers
-       Id, idType,
-       isImplicitId, isDeadBinder,
-       isExportedId, isLocalId, isGlobalId,
-       isRecordSelector,
-       isPrimOpId, isFCallId, isClassOpId_maybe,
-       isDataConWorkId, idDataCon,
-       isBottomingId, isDictonaryId,
-       recordSelectorFieldLabel,
-
-       -- ** Type constructors
-       TyCon, 
-       tyConTyVars, tyConDataCons, tyConArity,
-       isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
-       isFamilyTyCon,
-       synTyConDefn, synTyConType, synTyConResKind,
-
-       -- ** Type variables
-       TyVar,
-       alphaTyVars,
-
-       -- ** Data constructors
-       DataCon,
-       dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
-       dataConIsInfix, isVanillaDataCon, dataConUserType,
-       dataConStrictMarks,  
-       StrictnessMark(..), isMarkedStrict,
-
-       -- ** Classes
-       Class, 
-       classMethods, classSCTheta, classTvsFds,
-       pprFundeps,
-
-       -- ** Instances
-       Instance, 
-       instanceDFunId, pprInstance, pprInstanceHdr,
-
-       -- ** Types and Kinds
-       Type, splitForAllTys, funResultTy, 
-       pprParendType, pprTypeApp, 
-       Kind,
-       PredType,
-       ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
-
-       -- ** Entities
-       TyThing(..), 
-
-       -- ** Syntax
-       module HsSyn, -- ToDo: remove extraneous bits
-
-       -- ** Fixities
-       FixityDirection(..), 
-       defaultFixity, maxPrecedence, 
-       negateFixity,
-       compareFixity,
-
-       -- ** Source locations
-       SrcLoc, pprDefnLoc,
-        mkSrcLoc, isGoodSrcLoc, noSrcLoc,
-       srcLocFile, srcLocLine, srcLocCol,
-        SrcSpan,
+        -- ** Names
+        Name, 
+        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
+        NamedThing(..),
+        RdrName(Qual,Unqual),
+        
+        -- ** Identifiers
+        Id, idType,
+        isImplicitId, isDeadBinder,
+        isExportedId, isLocalId, isGlobalId,
+        isRecordSelector,
+        isPrimOpId, isFCallId, isClassOpId_maybe,
+        isDataConWorkId, idDataCon,
+        isBottomingId, isDictonaryId,
+        recordSelectorFieldLabel,
+
+        -- ** Type constructors
+        TyCon, 
+        tyConTyVars, tyConDataCons, tyConArity,
+        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
+        isFamilyTyCon, tyConClass_maybe,
+        synTyConDefn, synTyConType, synTyConResKind,
+
+        -- ** Type variables
+        TyVar,
+        alphaTyVars,
+
+        -- ** Data constructors
+        DataCon,
+        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
+        dataConIsInfix, isVanillaDataCon, dataConUserType,
+        dataConStrictMarks,  
+        StrictnessMark(..), isMarkedStrict,
+
+        -- ** Classes
+        Class, 
+        classMethods, classSCTheta, classTvsFds, classATs,
+        pprFundeps,
+
+        -- ** Instances
+        ClsInst, 
+        instanceDFunId, 
+        pprInstance, pprInstanceHdr,
+        pprFamInst, pprFamInstHdr,
+
+        -- ** Types and Kinds
+        Type, splitForAllTys, funResultTy, 
+        pprParendType, pprTypeApp, 
+        Kind,
+        PredType,
+        ThetaType, pprForAll, pprThetaArrowTy,
+
+        -- ** Entities
+        TyThing(..), 
+
+        -- ** Syntax
+        module HsSyn, -- ToDo: remove extraneous bits
+
+        -- ** Fixities
+        FixityDirection(..), 
+        defaultFixity, maxPrecedence, 
+        negateFixity,
+        compareFixity,
+
+        -- ** Source locations
+        SrcLoc(..), RealSrcLoc, 
+        mkSrcLoc, noSrcLoc,
+        srcLocFile, srcLocLine, srcLocCol,
+        SrcSpan(..), RealSrcSpan,
         mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
         srcSpanStart, srcSpanEnd,
-       srcSpanFile, 
+        srcSpanFile, 
         srcSpanStartLine, srcSpanEndLine, 
         srcSpanStartCol, srcSpanEndCol,
 
         -- ** Located
-       Located(..),
+        GenLocated(..), Located,
 
-       -- *** Constructing Located
-       noLoc, mkGeneralLocated,
+        -- *** Constructing Located
+        noLoc, mkGeneralLocated,
 
-       -- *** Deconstructing Located
-       getLoc, unLoc,
+        -- *** Deconstructing Located
+        getLoc, unLoc,
 
-       -- *** Combining and comparing Located values
-       eqLocated, cmpLocated, combineLocs, addCLoc,
+        -- *** Combining and comparing Located values
+        eqLocated, cmpLocated, combineLocs, addCLoc,
         leftmost_smallest, leftmost_largest, rightmost,
         spans, isSubspanOf,
 
-       -- * Exceptions
-       GhcException(..), showGhcException,
+        -- * Exceptions
+        GhcException(..), showGhcException,
 
         -- * Token stream manipulations
         Token,
@@ -221,9 +228,9 @@ module GHC (
         -- * Pure interface to the parser
         parser,
 
-       -- * Miscellaneous
-       --sessionHscEnv,
-       cyclicModuleErr,
+        -- * Miscellaneous
+        --sessionHscEnv,
+        cyclicModuleErr,
   ) where
 
 {-
@@ -244,28 +251,28 @@ import InteractiveEval
 
 import HscMain
 import GhcMake
-import DriverPipeline  ( compile' )
+import DriverPipeline   ( compile' )
 import GhcMonad
 import TcRnTypes
 import Packages
 import NameSet
 import RdrName
 import qualified HsSyn -- hack as we want to reexport the whole module
-import HsSyn hiding ((<.>))
-import Type
-import Coercion                ( synTyConResKind )
-import TcType          hiding( typeKind )
+import HsSyn
+import Type     hiding( typeKind )
+import Kind             ( synTyConResKind )
+import TcType           hiding( typeKind )
 import Id
-import TysPrim         ( alphaTyVars )
+import TysPrim          ( alphaTyVars )
 import TyCon
 import Class
--- import FunDeps
 import DataCon
 import Name             hiding ( varName )
--- import OccName              ( parenSymOcc )
+import Avail
 import InstEnv
+import FamInstEnv
 import SrcLoc
-import CoreSyn          ( CoreBind )
+import CoreSyn
 import TidyPgm
 import DriverPhases     ( Phase(..), isHaskellSrcFilename )
 import Finder
@@ -273,32 +280,31 @@ import HscTypes
 import DynFlags
 import StaticFlagParser
 import qualified StaticFlags
-import SysTools     ( initSysTools, cleanTempFiles, 
-                      cleanTempDirs )
+import SysTools
 import Annotations
 import Module
 import UniqFM
 import Panic
-import Bag             ( unitBag )
+import Bag              ( unitBag )
 import ErrUtils
 import MonadUtils
 import Util
 import StringBuffer
 import Outputable
 import BasicTypes
-import Maybes          ( expectJust )
+import Maybes           ( expectJust )
 import FastString
 import qualified Parser
 import Lexer
 
 import System.Directory ( doesFileExist, getCurrentDirectory )
 import Data.Maybe
-import Data.List       ( find )
+import Data.List        ( find )
 import Data.Typeable    ( Typeable )
 import Data.Word        ( Word8 )
 import Control.Monad
-import System.Exit     ( exitWith, ExitCode(..) )
-import System.Time     ( getClockTime )
+import System.Exit      ( exitWith, ExitCode(..) )
+import System.Time      ( getClockTime )
 import Exception
 import Data.IORef
 import System.FilePath
@@ -307,9 +313,9 @@ import Prelude hiding (init)
 
 
 -- %************************************************************************
--- %*                                                                     *
+-- %*                                                                      *
 --             Initialisation: exception handlers
--- %*                                                                     *
+-- %*                                                                      *
 -- %************************************************************************
 
 
@@ -317,23 +323,23 @@ import Prelude hiding (init)
 -- Unless you want to handle exceptions yourself, you should wrap this around
 -- the top level of your program.  The default handlers output the error
 -- message(s) to stderr and exit cleanly.
-defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
-defaultErrorHandler dflags inner =
+defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a
+defaultErrorHandler la inner =
   -- top-level exception handler: any unrecognised exception is a compiler bug.
   ghandle (\exception -> liftIO $ do
            hFlush stdout
            case fromException exception of
                 -- an IO exception probably isn't our fault, so don't panic
                 Just (ioe :: IOException) ->
-                  fatalErrorMsg dflags (text (show ioe))
+                  fatalErrorMsg' la (text (show ioe))
                 _ -> case fromException exception of
-                    Just UserInterrupt -> exitWith (ExitFailure 1)
+                     Just UserInterrupt -> exitWith (ExitFailure 1)
                      Just StackOverflow ->
-                         fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+                         fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it")
                      _ -> case fromException exception of
                           Just (ex :: ExitCode) -> throw ex
                           _ ->
-                              fatalErrorMsg dflags
+                              fatalErrorMsg' la
                                   (text (show (Panic (show exception))))
            exitWith (ExitFailure 1)
          ) $
@@ -341,13 +347,13 @@ defaultErrorHandler dflags inner =
   -- error messages propagated as exceptions
   handleGhcException
             (\ge -> liftIO $ do
-               hFlush stdout
-               case ge of
-                    PhaseFailed _ code -> exitWith code
-                    Signal _ -> exitWith (ExitFailure 1)
-                    _ -> do fatalErrorMsg dflags (text (show ge))
-                            exitWith (ExitFailure 1)
-           ) $
+                hFlush stdout
+                case ge of
+                     PhaseFailed _ code -> exitWith code
+                     Signal _ -> exitWith (ExitFailure 1)
+                     _ -> do fatalErrorMsg' la (text (show ge))
+                             exitWith (ExitFailure 1)
+            ) $
   inner
 
 -- | Install a default cleanup handler to remove temporary files deposited by
@@ -369,9 +375,9 @@ defaultCleanupHandler dflags inner =
 
 
 -- %************************************************************************
--- %*                                                                     *
+-- %*                                                                      *
 --             The Ghc Monad
--- %*                                                                     *
+-- %*                                                                      *
 -- %************************************************************************
 
 -- | Run function for the 'Ghc' monad.
@@ -430,16 +436,16 @@ initGhcMonad mb_top_dir = do
 
   liftIO $ StaticFlags.initStaticOpts
 
-  dflags0 <- liftIO $ initDynFlags defaultDynFlags
-  dflags <- liftIO $ initSysTools mb_top_dir dflags0
+  mySettings <- liftIO $ initSysTools mb_top_dir
+  dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings)
   env <- liftIO $ newHscEnv dflags
   setSession env
 
 
 -- %************************************************************************
--- %*                                                                     *
+-- %*                                                                      *
 --             Flags & settings
--- %*                                                                     *
+-- %*                                                                      *
 -- %************************************************************************
 
 -- | Updates the DynFlags in a Session.  This also reads
@@ -460,11 +466,16 @@ setSessionDynFlags dflags = do
   return preload
 
 
+parseDynamicFlags :: Monad m =>
+                     DynFlags -> [Located String]
+                  -> m (DynFlags, [Located String], [Located String])
+parseDynamicFlags = parseDynamicFlagsCmdLine
+
 
 -- %************************************************************************
--- %*                                                                     *
+-- %*                                                                      *
 --             Setting, getting, and modifying the targets
--- %*                                                                     *
+-- %*                                                                      *
 -- %************************************************************************
 
 -- ToDo: think about relative vs. absolute file paths. And what
@@ -512,13 +523,13 @@ guessTarget str Nothing
    = return (target (TargetFile file Nothing))
    | otherwise
    = do exists <- liftIO $ doesFileExist hs_file
-       if exists
-          then return (target (TargetFile hs_file Nothing))
-          else do
-       exists <- liftIO $ doesFileExist lhs_file
-       if exists
-          then return (target (TargetFile lhs_file Nothing))
-          else do
+        if exists
+           then return (target (TargetFile hs_file Nothing))
+           else do
+        exists <- liftIO $ doesFileExist lhs_file
+        if exists
+           then return (target (TargetFile lhs_file Nothing))
+           else do
         if looksLikeModuleName file
            then return (target (TargetModule (mkModuleName file)))
            else do
@@ -531,8 +542,8 @@ guessTarget str Nothing
                 | '*':rest <- str = (rest, False)
                 | otherwise       = (str,  True)
 
-        hs_file  = file <.> "hs"
-        lhs_file = file <.> "lhs"
+         hs_file  = file <.> "hs"
+         lhs_file = file <.> "lhs"
 
          target tid = Target tid obj_allowed Nothing
 
@@ -549,9 +560,9 @@ workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
 
 
 -- %************************************************************************
--- %*                                                                     *
+-- %*                                                                      *
 --             Running phases one at a time
--- %*                                                                     *
+-- %*                                                                      *
 -- %************************************************************************
 
 class ParsedMod m where
@@ -563,11 +574,11 @@ class ParsedMod m => TypecheckedMod m where
   typecheckedSource :: m -> TypecheckedSource
   moduleInfo        :: m -> ModuleInfo
   tm_internals      :: m -> (TcGblEnv, ModDetails)
-       -- ToDo: improvements that could be made here:
-       --  if the module succeeded renaming but not typechecking,
-       --  we can still get back the GlobalRdrEnv and exports, so
-       --  perhaps the ModuleInfo should be split up into separate
-       --  fields.
+        -- ToDo: improvements that could be made here:
+        --  if the module succeeded renaming but not typechecking,
+        --  we can still get back the GlobalRdrEnv and exports, so
+        --  perhaps the ModuleInfo should be split up into separate
+        --  fields.
 
 class TypecheckedMod m => DesugaredMod m where
   coreModule :: m -> ModGuts
@@ -575,7 +586,8 @@ class TypecheckedMod m => DesugaredMod m where
 -- | The result of successful parsing.
 data ParsedModule =
   ParsedModule { pm_mod_summary   :: ModSummary
-               , pm_parsed_source :: ParsedSource }
+               , pm_parsed_source :: ParsedSource
+               , pm_extra_src_files :: [FilePath] }
 
 instance ParsedMod ParsedModule where
   modSummary m    = pm_mod_summary m
@@ -598,7 +610,7 @@ instance ParsedMod TypecheckedModule where
 instance TypecheckedMod TypecheckedModule where
   renamedSource m     = tm_renamed_source m
   typecheckedSource m = tm_typechecked_source m
-  moduleInfo m = tm_checked_module_info m
+  moduleInfo m        = tm_checked_module_info m
   tm_internals m      = tm_internals_ m
 
 -- | The result of successful desugaring (i.e., translation to core).  Also
@@ -661,8 +673,8 @@ parseModule :: GhcMonad m => ModSummary -> m ParsedModule
 parseModule ms = do
    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)
+   hpm <- liftIO $ hscParse hsc_env_tmp ms
+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
 
 -- | Typecheck and rename a parsed module.
 --
@@ -673,7 +685,9 @@ typecheckModule pmod = do
  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)
+       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
+                      HsParsedModule { hpm_module = parsedSource pmod,
+                                       hpm_src_files = pm_extra_src_files pmod }
  details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
  return $
      TypecheckedModule {
@@ -686,9 +700,10 @@ typecheckModule pmod = do
            minf_type_env  = md_types details,
            minf_exports   = availsToNameSet $ md_exports details,
            minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
-           minf_instances = md_insts details
+           minf_instances = md_insts details,
+           minf_iface     = Nothing
 #ifdef GHCI
-           ,minf_modBreaks = emptyModBreaks
+          ,minf_modBreaks = emptyModBreaks
 #endif
          }}
 
@@ -729,21 +744,26 @@ loadModule tcm = do
                          return (Just l)
                      _otherwise -> return Nothing
                                                 
+   let source_modified | isNothing mb_linkable = SourceModified
+                       | otherwise             = SourceUnmodified
+                       -- we can't determine stability here
+
    -- 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
+                                  source_modified
 
    modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
    return tcm
 
 
 -- %************************************************************************
--- %*                                                                     *
+-- %*                                                                      *
 --             Dealing with Core
--- %*                                                                     *
+-- %*                                                                      *
 -- %************************************************************************
 
 -- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
@@ -755,7 +775,7 @@ data CoreModule
       -- | Type environment for types declared in this module
       cm_types    :: !TypeEnv,
       -- | Declarations
-      cm_binds    :: [CoreBind]
+      cm_binds    :: CoreProgram
     }
 
 instance Outputable CoreModule where
@@ -808,7 +828,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
          ms_obj_date = Nothing,
          -- Only handling the single-module case for now, so no imports.
          ms_srcimps = [],
-         ms_imps = [],
+         ms_textual_imps = [],
          -- No source file
          ms_hspp_file = "",
          ms_hspp_opts = dflags,
@@ -853,18 +873,22 @@ compileCore simplify fn = do
         -- we just have a ModGuts.
         gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
         gutsToCoreModule (Left (cg, md))  = CoreModule {
-          cm_module = cg_module cg,    cm_types = md_types md,
+          cm_module = cg_module cg,
+          cm_types = md_types md,
           cm_binds = cg_binds cg
         }
         gutsToCoreModule (Right mg) = CoreModule {
-          cm_module  = mg_module mg,                   cm_types   = mg_types mg,
+          cm_module  = mg_module mg,
+          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
+                                           (mg_tcs mg)
+                                           (mg_fam_insts mg),
           cm_binds   = mg_binds mg
          }
 
 -- %************************************************************************
--- %*                                                                     *
+-- %*                                                                      *
 --             Inspecting the session
--- %*                                                                     *
+-- %*                                                                      *
 -- %************************************************************************
 
 -- | Get the module dependency graph.
@@ -888,13 +912,12 @@ isLoaded m = withSession $ \hsc_env ->
 -- | Return the bindings for the current interactive session.
 getBindings :: GhcMonad m => m [TyThing]
 getBindings = withSession $ \hsc_env ->
-   -- we have to implement the shadowing behaviour of ic_tmp_ids here
-   -- (see InteractiveContext) and the quickest way is to use an OccEnv.
-   let 
-       occ_env = mkOccEnv [ (nameOccName (idName id), AnId id) 
-                          | id <- ic_tmp_ids (hsc_IC hsc_env) ]
-   in
-   return (occEnvElts occ_env)
+    return $ icInScopeTTs $ hsc_IC hsc_env
+
+-- | Return the instances for the current interactive session.
+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
+getInsts = withSession $ \hsc_env ->
+    return $ ic_instances (hsc_IC hsc_env)
 
 getPrintUnqual :: GhcMonad m => m PrintUnqualified
 getPrintUnqual = withSession $ \hsc_env ->
@@ -902,28 +925,30 @@ getPrintUnqual = withSession $ \hsc_env ->
 
 -- | Container for information about a 'Module'.
 data ModuleInfo = ModuleInfo {
-       minf_type_env  :: TypeEnv,
-       minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
-       minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
-       minf_instances :: [Instance]
+        minf_type_env  :: TypeEnv,
+        minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
+        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
+        minf_instances :: [ClsInst],
+        minf_iface     :: Maybe ModIface
 #ifdef GHCI
-        ,minf_modBreaks :: ModBreaks 
+       ,minf_modBreaks :: ModBreaks 
 #endif
-       -- ToDo: this should really contain the ModIface too
   }
-       -- We don't want HomeModInfo here, because a ModuleInfo applies
-       -- to package modules too.
+        -- We don't want HomeModInfo here, because a ModuleInfo applies
+        -- to package modules too.
 
 -- | Request information about a loaded 'Module'
 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
 getModuleInfo mdl = withSession $ \hsc_env -> do
   let mg = hsc_mod_graph hsc_env
   if mdl `elem` map ms_mod mg
-       then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
-       else do
+        then liftIO $ getHomeModuleInfo hsc_env mdl
+        else do
   {- if isHomeModule (hsc_dflags hsc_env) mdl
-       then return Nothing
-       else -} liftIO $ getPackageModuleInfo hsc_env mdl
+        then return Nothing
+        else -} liftIO $ getPackageModuleInfo hsc_env mdl
+   -- ToDo: we don't understand what the following comment means.
+   --    (SDM, 19/7/2011)
    -- getPackageModuleInfo will attempt to find the interface, so
    -- we don't want to call it for a home module, just in case there
    -- was a problem loading the module and the interface doesn't
@@ -931,46 +956,47 @@ getModuleInfo mdl = withSession $ \hsc_env -> do
 
 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
 #ifdef GHCI
-getPackageModuleInfo hsc_env mdl = do
-  mb_avails <- hscGetModuleExports hsc_env mdl
-  case mb_avails of
-    Nothing -> return Nothing
-    Just avails -> do
-       eps <- readIORef (hsc_EPS hsc_env)
-       let 
+getPackageModuleInfo hsc_env mdl 
+  = do  eps <- hscEPS hsc_env
+        iface <- hscGetModuleInterface hsc_env mdl
+        let 
+            avails = mi_exports iface
             names  = availsToNameSet avails
-           pte    = eps_PTE eps
-           tys    = [ ty | name <- concatMap availNames avails,
-                           Just ty <- [lookupTypeEnv pte name] ]
-       --
-       return (Just (ModuleInfo {
-                       minf_type_env  = mkTypeEnv tys,
-                       minf_exports   = names,
-                       minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
-                       minf_instances = error "getModuleInfo: instances for package module unimplemented",
+            pte    = eps_PTE eps
+            tys    = [ ty | name <- concatMap availNames avails,
+                            Just ty <- [lookupTypeEnv pte name] ]
+        --
+        return (Just (ModuleInfo {
+                        minf_type_env  = mkTypeEnv tys,
+                        minf_exports   = names,
+                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
+                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
+                        minf_iface     = Just iface,
                         minf_modBreaks = emptyModBreaks  
-               }))
+                }))
 #else
+-- bogusly different for non-GHCI (ToDo)
 getPackageModuleInfo _hsc_env _mdl = do
-  -- bogusly different for non-GHCI (ToDo)
   return Nothing
 #endif
 
-getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
+getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
 getHomeModuleInfo hsc_env mdl = 
-  case lookupUFM (hsc_HPT hsc_env) mdl of
+  case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of
     Nothing  -> return Nothing
     Just hmi -> do
       let details = hm_details hmi
+          iface   = hm_iface hmi
       return (Just (ModuleInfo {
-                       minf_type_env  = md_types details,
-                       minf_exports   = availsToNameSet (md_exports details),
-                       minf_rdr_env   = mi_globals $! hm_iface hmi,
-                       minf_instances = md_insts details
+                        minf_type_env  = md_types details,
+                        minf_exports   = availsToNameSet (md_exports details),
+                        minf_rdr_env   = mi_globals $! hm_iface hmi,
+                        minf_instances = md_insts details,
+                        minf_iface     = Just iface
 #ifdef GHCI
                        ,minf_modBreaks = getModBreaks hmi
 #endif
-                       }))
+                        }))
 
 -- | The list of top-level entities defined in a module
 modInfoTyThings :: ModuleInfo -> [TyThing]
@@ -985,7 +1011,7 @@ modInfoExports minf = nameSetToList $! minf_exports minf
 
 -- | Returns the instances defined by the specified module.
 -- Warning: currently unimplemented for package modules.
-modInfoInstances :: ModuleInfo -> [Instance]
+modInfoInstances :: ModuleInfo -> [ClsInst]
 modInfoInstances = minf_instances
 
 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
@@ -1006,7 +1032,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do
      Nothing      -> do
        eps <- liftIO $ readIORef (hsc_EPS hsc_env)
        return $! lookupType (hsc_dflags hsc_env) 
-                           (hsc_HPT hsc_env) (eps_PTE eps) name
+                            (hsc_HPT hsc_env) (eps_PTE eps) name
+
+modInfoIface :: ModuleInfo -> Maybe ModIface
+modInfoIface = minf_iface
 
 #ifdef GHCI
 modInfoModBreaks :: ModuleInfo -> ModBreaks
@@ -1101,7 +1130,7 @@ getModuleSourceAndFlags mod = do
 getTokenStream :: GhcMonad m => Module -> m [Located Token]
 getTokenStream mod = do
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts  -> return ts
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -1112,7 +1141,7 @@ getTokenStream mod = do
 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
 getRichTokenStream mod = do
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts -> return $ addSourceToTokens startLoc source ts
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -1120,21 +1149,22 @@ getRichTokenStream mod = do
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
 -- tokens.
-addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
                   -> [(Located Token, String)]
 addSourceToTokens _ _ [] = []
 addSourceToTokens loc buf (t@(L span _) : ts)
-    | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
-    | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
-    where
-      (newLoc, newBuf, str) = go "" loc buf
-      start = srcSpanStart span
-      end = srcSpanEnd span
-      go acc loc buf | loc < start = go acc nLoc nBuf
-                     | start <= loc && loc < end = go (ch:acc) nLoc nBuf
-                     | otherwise = (loc, buf, reverse acc)
-          where (ch, nBuf) = nextChar buf
-                nLoc = advanceSrcLoc loc ch
+    = case span of
+      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
+      RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts
+        where
+          (newLoc, newBuf, str) = go "" loc buf
+          start = realSrcSpanStart s
+          end = realSrcSpanEnd s
+          go acc loc buf | loc < start = go acc nLoc nBuf
+                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf
+                         | otherwise = (loc, buf, reverse acc)
+              where (ch, nBuf) = nextChar buf
+                    nLoc = advanceSrcLoc loc ch
 
 
 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
@@ -1142,21 +1172,26 @@ addSourceToTokens loc buf (t@(L span _) : ts)
 -- insignificant whitespace.)
 showRichTokenStream :: [(Located Token, String)] -> String
 showRichTokenStream ts = go startLoc ts ""
-    where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
-          startLoc = mkSrcLoc sourceFile 1 1
+    where sourceFile = getFile $ map (getLoc . fst) ts
+          getFile [] = panic "showRichTokenStream: No source file found"
+          getFile (UnhelpfulSpan _ : xs) = getFile xs
+          getFile (RealSrcSpan s : _) = srcSpanFile s
+          startLoc = mkRealSrcLoc sourceFile 1 1
           go _ [] = id
           go loc ((L span _, str):ts)
-              | not (isGoodSrcSpan span) = go loc ts
-              | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
-                                     . (str ++)
-                                     . go tokEnd ts
-              | otherwise = ((replicate (tokLine - locLine) '\n') ++)
-                            . ((replicate tokCol ' ') ++)
-                            . (str ++)
-                            . go tokEnd ts
-              where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
-                    (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
-                    tokEnd = srcSpanEnd span
+              = case span of
+                UnhelpfulSpan _ -> go loc ts
+                RealSrcSpan s
+                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
+                                       . (str ++)
+                                       . go tokEnd ts
+                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
+                              . ((replicate tokCol ' ') ++)
+                              . (str ++)
+                              . go tokEnd ts
+                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
+                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
+                        tokEnd = realSrcSpanEnd s
 
 -- -----------------------------------------------------------------------------
 -- Interactive evaluation
@@ -1210,28 +1245,34 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do
       res <- findExposedPackageModule hsc_env mod_name Nothing
       case res of
         Found _ m -> return m
-       err       -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
+        err       -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
 
-lookupLoadedHomeModule  :: GhcMonad m => ModuleName -> m (Maybe Module)
+lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
 lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
   case lookupUFM (hsc_HPT hsc_env) mod_name of
     Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))
     _not_a_home_module -> return Nothing
 
 #ifdef GHCI
+-- | Check that a module is safe to import (according to Safe Haskell).
+--
+-- We return True to indicate the import is safe and False otherwise
+-- although in the False case an error may be thrown first.
+isModuleTrusted :: GhcMonad m => Module -> m Bool
+isModuleTrusted m = withSession $ \hsc_env ->
+    liftIO $ hscCheckSafe hsc_env m noSrcSpan
+
 getHistorySpan :: GhcMonad m => History -> m SrcSpan
 getHistorySpan h = withSession $ \hsc_env ->
-                          return$ InteractiveEval.getHistorySpan hsc_env h
+    return $ InteractiveEval.getHistorySpan hsc_env h
 
 obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
-obtainTermFromVal bound force ty a =
-    withSession $ \hsc_env ->
-      liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
+obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
+    liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
 
 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
-obtainTermFromId bound force id =
-    withSession $ \hsc_env ->
-      liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
+obtainTermFromId bound force id = withSession $ \hsc_env ->
+    liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
 
 #endif
 
@@ -1254,7 +1295,7 @@ parser :: String         -- ^ Haskell module source text (full Unicode is suppor
 
 parser str dflags filename = 
    let
-       loc  = mkSrcLoc (mkFastString filename) 1 1
+       loc  = mkRealSrcLoc (mkFastString filename) 1 1
        buf  = stringToStringBuffer str
    in
    case unP Parser.parseModule (mkPState dflags buf loc) of
@@ -1265,3 +1306,4 @@ parser str dflags filename =
      POk pst rdr_module ->
          let (warns,_) = getMessages pst in
          Right (warns, rdr_module)
+