Super-monster patch implementing the new typechecker -- at last

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index b713bc8..92345c7 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -98,7 +98,7 @@ module GHC (
        typeKind,
        parseName,
        RunResult(..),  
-       runStmt, SingleStep(..),
+       runStmt, parseImportDecl, SingleStep(..),
         resume,
         Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
                resumeHistory, resumeHistoryIx),
@@ -111,13 +111,13 @@ module GHC (
        showModule,
         isModuleInterpreted,
        InteractiveEval.compileExpr, HValue, dynCompileExpr,
-       lookupName,
         GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
         modInfoModBreaks,
         ModBreaks(..), BreakIndex,
         BreakInfo(breakInfo_number, breakInfo_module),
         BreakArray, setBreakOn, setBreakOff, getBreak,
 #endif
+        lookupName,
 
        -- * Abstract syntax elements
 
@@ -148,7 +148,7 @@ module GHC (
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
-       isOpenTyCon,
+       isFamilyTyCon,
        synTyConDefn, synTyConType, synTyConResKind,
 
        -- ** Type variables
@@ -158,7 +158,7 @@ module GHC (
        -- ** Data constructors
        DataCon,
        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
-       dataConIsInfix, isVanillaDataCon,
+       dataConIsInfix, isVanillaDataCon, dataConUserType,
        dataConStrictMarks,  
        StrictnessMark(..), isMarkedStrict,
 
@@ -176,7 +176,7 @@ module GHC (
        pprParendType, pprTypeApp, 
        Kind,
        PredType,
-       ThetaType, pprThetaArrow,
+       ThetaType, pprForAll, pprThetaArrow,
 
        -- ** Entities
        TyThing(..), 
@@ -243,11 +243,11 @@ import Linker           ( HValue )
 import ByteCodeInstr
 import BreakArray
 import InteractiveEval
-import TcRnDriver
 #endif
 
+import TcRnDriver
 import TcIface
-import TcRnTypes        hiding (LIE)
+import TcRnTypes
 import TcRnMonad        ( initIfaceCheck )
 import Packages
 import NameSet
@@ -255,6 +255,7 @@ 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 Id
 import Var
@@ -334,6 +335,7 @@ defaultErrorHandler dflags inner =
                 Just (ioe :: IOException) ->
                   fatalErrorMsg dflags (text (show ioe))
                 _ -> case fromException exception of
+                    Just UserInterrupt -> exitWith (ExitFailure 1)
                      Just StackOverflow ->
                          fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
                      _ -> case fromException exception of
@@ -350,7 +352,6 @@ defaultErrorHandler dflags inner =
                hFlush stdout
                case ge of
                     PhaseFailed _ code -> exitWith code
-                    Interrupted -> exitWith (ExitFailure 1)
                     Signal _ -> exitWith (ExitFailure 1)
                     _ -> do fatalErrorMsg dflags (text (show ge))
                             exitWith (ExitFailure 1)
@@ -2016,7 +2017,10 @@ msDeps s =
         ++ [ (m,False) | m <- ms_home_imps s ] 
 
 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
-home_imps imps = [ ideclName i |  L _ i <- imps, isNothing (ideclPkgQual i) ]
+home_imps imps = [ ideclName i |  L _ i <- imps, isLocal (ideclPkgQual i) ]
+  where isLocal Nothing = True
+        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
+        isLocal _ = False
 
 ms_home_allimps :: ModSummary -> [ModuleName]
 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
@@ -2432,7 +2436,7 @@ getPackageModuleInfo hsc_env mdl = do
        return (Just (ModuleInfo {
                        minf_type_env  = mkTypeEnv tys,
                        minf_exports   = names,
-                       minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
+                       minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
                         minf_modBreaks = emptyModBreaks  
                }))
@@ -2720,3 +2724,12 @@ obtainTermFromId bound force id =
       liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
 
 #endif
+
+-- | 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?
+