import IOEnv -- Re-export all
#if defined(GHCI) && defined(BREAKPOINT)
-import TypeRep ( Type(..), liftedTypeKind, TyThing(..) )
+import TypeRep ( Type(..), liftedTypeKind )
import Var ( mkTyVar, mkGlobalId )
import IdInfo ( GlobalIdDetails(..), vanillaIdInfo )
import OccName ( mkOccName, tvName )
import SrcLoc ( noSrcLoc )
-import TysWiredIn ( intTy, stringTy, mkListTy, unitTy )
-import PrelNames ( breakpointJumpName )
+import TysWiredIn ( intTy, stringTy, mkListTy, unitTy, boolTy )
+import PrelNames ( breakpointJumpName, breakpointCondJumpName )
import NameEnv ( mkNameEnv )
#endif
import HsSyn ( emptyLHsBinds )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
- TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
- isHsBoot, ModSummary(..),
+ TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
ExternalPackageState(..), HomePackageTable,
Deprecs(..), FixityEnv, FixItem,
- lookupType, unQualInScope )
-import Module ( Module, unitModuleEnv )
-import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
- LocalRdrEnv, emptyLocalRdrEnv )
-import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
+ mkPrintUnqualified )
+import Module ( Module, moduleName )
+import RdrName ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
+import Name ( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
import Type ( Type )
import TcType ( tcIsTyVarTy, tcGetTyVar )
import NameEnv ( extendNameEnvList, nameEnvElts )
import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
mkWarnMsg, printErrorsAndWarnings,
mkLocMessage, mkLongErrMsg )
-import Packages ( mkHomeModules )
import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
import NameEnv ( emptyNameEnv )
import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
import Bag ( emptyBag )
import Outputable
import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
+import UniqFM ( unitUFM )
import Unique ( Unique )
import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
import StaticFlags ( opt_PprStyle_Debug )
gbl_env = TcGblEnv {
tcg_mod = mod,
tcg_src = hsc_src,
- tcg_rdr_env = emptyGlobalRdrEnv,
+ tcg_rdr_env = hsc_global_rdr_env hsc_env,
tcg_fix_env = emptyNameEnv,
tcg_default = Nothing,
- tcg_type_env = emptyNameEnv,
+ tcg_type_env = hsc_global_type_env hsc_env,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
tcg_inst_uses = dfuns_var,
tcg_th_used = th_var,
tcg_exports = emptyNameSet,
tcg_imports = init_imports,
- tcg_home_mods = home_mods,
tcg_dus = emptyDUs,
tcg_rn_imports = Nothing,
tcg_rn_exports = Nothing,
unique <- newUnique ;
let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
tyvar = mkTyVar var liftedTypeKind;
- breakpointJumpType = mkGlobalId
- (VanillaGlobal)
- (breakpointJumpName)
- (FunTy intTy
- (FunTy (mkListTy unitTy)
- (FunTy stringTy
- (ForAllTy tyvar
- (FunTy (TyVarTy tyvar)
- (TyVarTy tyvar))))))
- (vanillaIdInfo);
- new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
+ basicType extra = (FunTy intTy
+ (FunTy (mkListTy unitTy)
+ (FunTy stringTy
+ (ForAllTy tyvar
+ (extra
+ (FunTy (TyVarTy tyvar)
+ (TyVarTy tyvar)))))));
+ breakpointJumpType
+ = mkGlobalId VanillaGlobal breakpointJumpName
+ (basicType id) vanillaIdInfo;
+ breakpointCondJumpType
+ = mkGlobalId VanillaGlobal breakpointCondJumpName
+ (basicType (FunTy boolTy)) vanillaIdInfo;
+ new_env = mkNameEnv [(breakpointJumpName
+ , ATcId breakpointJumpType topLevel False)
+ ,(breakpointCondJumpName
+ , ATcId breakpointCondJumpType topLevel False)];
};
r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
#else
return (msgs, final_res)
}
where
- home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env))
- -- A guess at the home modules. This will be correct in
- -- --make and GHCi modes, but in one-shot mode we need to
- -- fix it up after we know the real dependencies of the current
- -- module (see tcRnModule).
- -- Setting it here is necessary for the typechecker entry points
- -- other than tcRnModule: tcRnGetInfo, for example. These are
- -- all called via the GHC module, so hsc_mod_graph will contain
- -- something sensible.
-
- init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet}
+ init_imports = emptyImportAvails {imp_env =
+ unitUFM (moduleName mod) emptyNameSet}
-- Initialise tcg_imports with an empty set of bindings for
-- this module, so that if we see 'module M' in the export
-- list, and there are no bindings in M, we don't bleat
(msgs, res) <- initTc env HsSrcFile mod todo
printErrorsAndWarnings (hsc_dflags env) msgs
return res
-
--- mkImpTypeEnv makes the imported symbol table
-mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
- -> Name -> Maybe TyThing
-mkImpTypeEnv pcs hpt = lookup
- where
- pte = eps_PTE pcs
- lookup name | isInternalName name = Nothing
- | otherwise = lookupType hpt pte name
\end{code}
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
- ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
+ ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
= do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
errs_var <- getErrsVar ;
rdr_env <- getGlobalRdrEnv ;
- let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
+ let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
(warns, errs) <- readMutVar errs_var ;
writeMutVar errs_var (warns, errs `snocBag` err) }
addReportAt loc msg
= do { errs_var <- getErrsVar ;
rdr_env <- getGlobalRdrEnv ;
- let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ;
+ let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
(warns, errs) <- readMutVar errs_var ;
writeMutVar errs_var (warns `snocBag` warn, errs) }
forkM_maybe doc thing_inside
= do { unsafeInterleaveM $
do { traceIf (text "Starting fork {" <+> doc)
- ; mb_res <- tryM thing_inside ;
- case mb_res of
+ ; mb_res <- tryM $
+ updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
+ thing_inside
+ ; case mb_res of
Right r -> do { traceIf (text "} ending fork" <+> doc)
; return (Just r) }
Left exn -> do {
projects / ghc-hetmet.git / blobdiff