import TysWiredIn ( intTy, stringTy, mkListTy, unitTy, boolTy )
import PrelNames ( breakpointJumpName, breakpointCondJumpName )
import NameEnv ( mkNameEnv )
+import TcEnv ( tcExtendIdEnv )
#endif
import HsSyn ( emptyLHsBinds )
import TcType ( tcIsTyVarTy, tcGetTyVar )
import NameEnv ( extendNameEnvList, nameEnvElts )
import InstEnv ( emptyInstEnv )
+import FamInstEnv ( emptyFamInstEnv )
import Var ( setTyVarName )
import VarSet ( emptyVarSet )
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,
-- 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}
%************************************************************************
%* *