import TysWiredIn ( intTy, stringTy, mkListTy, unitTy, boolTy )
import PrelNames ( breakpointJumpName, breakpointCondJumpName )
import NameEnv ( mkNameEnv )
+import TcEnv ( tcExtendIdEnv )
#endif
-import HsSyn ( emptyLHsBinds )
+import HsSyn ( emptyLHsBinds, HaddockModInfo(..) )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
ExternalPackageState(..), HomePackageTable,
import RdrName ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
import Name ( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
import Type ( Type )
-import TcType ( tcIsTyVarTy, tcGetTyVar )
+import TcType ( TcType, tcIsTyVarTy, tcGetTyVar )
import NameEnv ( extendNameEnvList, nameEnvElts )
import InstEnv ( emptyInstEnv )
+import FamInstEnv ( emptyFamInstEnv )
import Var ( setTyVarName )
+import Id ( mkSysLocal )
import VarSet ( emptyVarSet )
import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv )
import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
import OccName ( emptyOccEnv, tidyOccName )
import Bag ( emptyBag )
import Outputable
-import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply )
import UniqFM ( unitUFM )
import Unique ( Unique )
-import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
+import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set,
+ dopt_unset, GhcMode )
import StaticFlags ( opt_PprStyle_Debug )
+import FastString ( FastString )
import Bag ( snocBag, unionBags )
import Panic ( showException )
tcg_type_env = hsc_global_type_env hsc_env,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
+ tcg_fam_inst_env = emptyFamInstEnv,
tcg_inst_uses = dfuns_var,
tcg_th_used = th_var,
tcg_exports = emptyNameSet,
tcg_rules = [],
tcg_fords = [],
tcg_dfun_n = dfun_n_var,
- tcg_keep = keep_var
+ tcg_keep = keep_var,
+ tcg_doc = Nothing,
+ tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
-- OK, here's the business end!
maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
- do {
-#if defined(GHCI) && defined(BREAKPOINT)
- unique <- newUnique ;
- let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
- tyvar = mkTyVar var liftedTypeKind;
- 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
- r <- tryM do_this
-#endif
+ addBreakpointBindings $
+ do { r <- tryM do_this
; case r of
Right res -> return (Just res)
Left _ -> return Nothing } ;
return res
\end{code}
+\begin{code}
+addBreakpointBindings :: TcM a -> TcM a
+addBreakpointBindings thing_inside
+#if defined(GHCI) && defined(BREAKPOINT)
+ = do { unique <- newUnique
+ ; let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
+ tyvar = mkTyVar var liftedTypeKind;
+ basicType extra = (FunTy intTy
+ (FunTy (mkListTy unitTy)
+ (FunTy stringTy
+ (ForAllTy tyvar
+ (extra
+ (FunTy (TyVarTy tyvar)
+ (TyVarTy tyvar)))))));
+ breakpointJumpId
+ = mkGlobalId VanillaGlobal breakpointJumpName
+ (basicType id) vanillaIdInfo;
+ breakpointCondJumpId
+ = mkGlobalId VanillaGlobal breakpointCondJumpName
+ (basicType (FunTy boolTy)) vanillaIdInfo
+ }
+ ; tcExtendIdEnv [breakpointJumpId, breakpointCondJumpId] thing_inside}
+#else
+ = thing_inside
+#endif
+\end{code}
%************************************************************************
%* *
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
+unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
+ env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
+
ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true
ifOptM flag thing_inside = do { b <- doptM flag;
if b then thing_inside else return () }
newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name -- Make a clone
- = newUnique `thenM` \ uniq ->
- returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name))
+ = do { uniq <- newUnique
+ ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) }
+
+newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
+newSysLocalIds fs tys
+ = do { us <- newUniqueSupply
+ ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
\end{code}