Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263

[ghc-hetmet.git] / compiler / main / InteractiveEval.hs

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index b4d49c9..44972d5 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -47,7 +47,6 @@ import TcType           hiding (typeKind)
 import InstEnv
 import Var
 import Id
-import IdInfo
 import Name             hiding ( varName )
 import NameSet
 import RdrName
@@ -72,6 +71,7 @@ import Outputable
 import FastString
 import MonadUtils
 
+import System.Directory
 import Data.Dynamic
 import Data.List (find)
 import Control.Monad
@@ -213,6 +213,7 @@ runStmt expr step =
         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
@@ -228,6 +229,28 @@ runStmt expr step =
               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
 
@@ -285,7 +308,7 @@ traceRunStatus expr bindings final_ids
              let history' = mkHistory hsc_env apStack info `consBL` history
                 -- probably better make history strict here, otherwise
                 -- our BoundedList will be pointless.
-             liftIO $ evaluate history'
+             _ <- liftIO $ evaluate history'
              status <-
                  withBreakAction True (hsc_dflags hsc_env)
                                       breakMVar statusMVar $ do
@@ -408,8 +431,8 @@ noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
 noBreakAction True  _ _ = return () -- exception: just continue
 
-resume :: GhcMonad m => SingleStep -> m RunResult
-resume step
+resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
+resume canLogSpan step
  = do
    hsc_env <- getSession
    let ic = hsc_IC hsc_env
@@ -436,7 +459,8 @@ resume step
         when (isStep step) $ liftIO setStepFlag
         case r of 
           Resume expr tid breakMVar statusMVar bindings 
-              final_ids apStack info _ hist _ -> do
+              final_ids apStack info span hist _ -> do
+               withVirtualCWD $ do
                 withBreakAction (isStep step) (hsc_dflags hsc_env) 
                                         breakMVar statusMVar $ do
                 status <- liftIO $ withInterruptsSentTo tid $ do
@@ -444,10 +468,12 @@ resume step
                                       -- this awakens the stopped thread...
                              takeMVar statusMVar
                                       -- and wait for the result 
-                let hist' = 
-                     case info of 
-                       Nothing -> fromListBL 50 hist
-                       Just i -> mkHistory hsc_env apStack i `consBL` 
+                let prevHistoryLst = fromListBL 50 hist
+                    hist' = case info of
+                       Nothing -> prevHistoryLst
+                       Just i
+                         | not $canLogSpan span -> prevHistoryLst
+                         | otherwise -> mkHistory hsc_env apStack i `consBL`
                                                         fromListBL 50 hist
                 case step of
                   RunAndLogSteps -> 
@@ -583,18 +609,22 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
    --    - tidy the type variables
    --    - globalise the Id (Ids are supposed to be Global, apparently).
    --
-   let all_ids | isPointer result_id = result_id : new_ids
-               | otherwise           = new_ids
+   let result_ok = isPointer result_id
+                    && not (isUnboxedTupleType (idType result_id))
+
+       all_ids | result_ok = result_id : new_ids
+               | otherwise = new_ids
        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
        new_tyvars = unionVarSets tyvarss             
-   let final_ids = zipWith setIdType all_ids tidy_tys
+       final_ids = zipWith setIdType all_ids tidy_tys
        ictxt0 = hsc_IC hsc_env
        ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
+
    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
-   Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+   when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
-   return (hsc_env1, result_name:names, span)
+   return (hsc_env1, if result_ok then result_name:names else names, span)
   where
    mkNewId :: OccName -> Id -> IO Id
    mkNewId occ id = do