import TysWiredIn ( intTy, stringTy, mkListTy, unitTy, boolTy )
import PrelNames ( breakpointJumpName, breakpointCondJumpName )
import NameEnv ( mkNameEnv )
+import TcEnv ( tcExtendIdEnv )
#endif
import HsSyn ( emptyLHsBinds )
import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, 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 Bag ( snocBag, unionBags )
import Panic ( showException )
-- 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 () }