import InstEnv
import Var
import Id
-import IdInfo
import Name hiding ( varName )
import NameSet
import RdrName
import FastString
import MonadUtils
+import System.Directory
import Data.Dynamic
import Data.List (find)
import Control.Monad
clearWarnings
status <-
+ withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
liftIO $ sandboxIO dflags' statusMVar thing_to_run
handleRunStatus expr bindings ids
breakMVar statusMVar status emptyHistory
+withVirtualCWD :: GhcMonad m => m a -> m a
+withVirtualCWD m = do
+ hsc_env <- getSession
+ let ic = hsc_IC hsc_env
+
+ let set_cwd = do
+ dir <- liftIO $ getCurrentDirectory
+ case ic_cwd ic of
+ Just dir -> liftIO $ setCurrentDirectory dir
+ Nothing -> return ()
+ return dir
+
+ reset_cwd orig_dir = do
+ virt_dir <- liftIO $ getCurrentDirectory
+ hsc_env <- getSession
+ let old_IC = hsc_IC hsc_env
+ setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
+ liftIO $ setCurrentDirectory orig_dir
+
+ gbracket set_cwd reset_cwd $ \_ -> m
+
+
emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
-- not "Interrupted", we unset the exception flag before throwing.
--
rethrow :: DynFlags -> IO a -> IO a
-#if __GLASGOW_HASKELL__ < 609
-rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
- case e of
- -- If -fbreak-on-error, we break unconditionally,
- -- but with care of not breaking twice
- _ | dopt Opt_BreakOnError dflags &&
- not(dopt Opt_BreakOnException dflags)
- -> poke exceptionFlag 1
-
- -- If it is an "Interrupted" exception, we allow
- -- a possible break by way of -fbreak-on-exception
- DynException d | Just Interrupted <- fromDynamic d
- -> return ()
-
- -- In any other case, we don't want to break
- _ -> poke exceptionFlag 0
-
- Exception.throwIO e
-#else
-rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+rethrow dflags io = Exception.catch io $ \se -> do
-- If -fbreak-on-error, we break unconditionally,
-- but with care of not breaking twice
if dopt Opt_BreakOnError dflags &&
not (dopt Opt_BreakOnException dflags)
then poke exceptionFlag 1
- else case cast e of
+ else case fromException se of
-- If it is an "Interrupted" exception, we allow
-- a possible break by way of -fbreak-on-exception
Just Interrupted -> return ()
_ -> poke exceptionFlag 0
Exception.throwIO se
-#endif
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
case r of
Resume expr tid breakMVar statusMVar bindings
final_ids apStack info _ hist _ -> do
+ withVirtualCWD $ do
withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
status <- liftIO $ withInterruptsSentTo tid $ do
e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
- exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
- vanillaIdInfo
+ exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
new_tyvars = unitVarSet e_tyvar
ictxt0 = hsc_IC hsc_env
-- _result in scope at any time.
let result_name = mkInternalName (getUnique result_fs)
(mkVarOccFS result_fs) span
- result_id = Id.mkGlobalId VanillaGlobal result_name result_ty
- vanillaIdInfo
+ result_id = Id.mkVanillaGlobal result_name result_ty
-- for each Id we're about to bind in the local envt:
-- - skolemise the type variables in its type, so they can't
loc = nameSrcSpan (idName id)
name = mkInternalName uniq occ loc
ty = idType id
- new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
+ new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
return new_id
rttiEnvironment :: HscEnv -> IO HscEnv