Refactor traceRunStatus/handleRunStatus

No change in behaviour, but I combined these two functions, and I think
the result is a good deal clearer

1 files changed, 58 insertions, 75 deletions

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 439cc0c87a..c0db67a367 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -189,13 +189,8 @@ runStmtWithLocation source linenumber expr step =
 
             size = ghciHistSize idflags'
 
-        case step of
-          RunAndLogSteps ->
-              traceRunStatus expr bindings tyThings
-                             breakMVar statusMVar status (emptyHistory size)
-          _other ->
-              handleRunStatus expr bindings tyThings
-                               breakMVar statusMVar status (emptyHistory size)
+        handleRunStatus step expr bindings tyThings
+                        breakMVar statusMVar status (emptyHistory size)
 
 runDecls :: GhcMonad m => String -> m [Name]
 runDecls = runDeclsWithLocation "<interactive>" 1
@@ -240,21 +235,45 @@ parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
 emptyHistory :: Int -> BoundedList History
 emptyHistory size = nilBL size
 
-handleRunStatus :: GhcMonad m =>
-                   String-> ([TyThing],GlobalRdrEnv) -> [Id]
+handleRunStatus :: GhcMonad m
+                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
                 -> MVar () -> MVar Status -> Status -> BoundedList History
                 -> m RunResult
-handleRunStatus expr bindings final_ids breakMVar statusMVar status
-                history =
-   case status of
-      -- did we hit a breakpoint or did we complete?
-      (Break is_exception apStack info tid) -> do
-        hsc_env <- getSession
-        let mb_info | is_exception = Nothing
-                    | otherwise    = Just info
-        (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
+
+handleRunStatus step expr bindings final_ids
+               breakMVar statusMVar status history
+  | RunAndLogSteps <- step
+  , Break is_exception apStack info tid <- status
+  , not is_exception
+  =  -- When tracing, if we hit a breakpoint that is not explicitly
+     -- enabled, then we just log the event in the history and continue.
+    do { hsc_env <- getSession
+       ; b <- liftIO $ isBreakEnabled hsc_env info
+       ; if b
+           then handleRunStatus RunToCompletion expr bindings final_ids
+                                breakMVar statusMVar status history
+           else
+    do  { let history' = mkHistory hsc_env apStack info `consBL` history
+                -- probably better make history strict here, otherwise
+                -- our BoundedList will be pointless.
+        ; _ <- liftIO $ evaluate history'
+        ; status <- withBreakAction True (hsc_dflags hsc_env)
+                                    breakMVar statusMVar $ do
+                    liftIO $ mask_ $ do
+                       putMVar breakMVar ()  -- awaken the stopped thread
+                       redirectInterrupts tid $
+                         takeMVar statusMVar   -- and wait for the result
+        ; handleRunStatus RunAndLogSteps expr bindings final_ids
+                          breakMVar statusMVar status history' } }
+
+  | Break is_exception apStack info tid <- status
+  =  -- Did we hit a breakpoint or did we complete?
+    do { hsc_env <- getSession
+       ; let mb_info | is_exception = Nothing
+                     | otherwise    = Just info
+       ; (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
                                                                mb_info
-        let
+       ; let
             resume = Resume { resumeStmt = expr, resumeThreadId = tid
                             , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
                             , resumeBindings = bindings, resumeFinalIds = final_ids
@@ -262,56 +281,25 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status
                             , resumeSpan = span, resumeHistory = toListBL history
                             , resumeHistoryIx = 0 }
             hsc_env2 = pushResume hsc_env1 resume
-        --
-        modifySession (\_ -> hsc_env2)
-        return (RunBreak tid names mb_info)
-      (Complete either_hvals) ->
-        case either_hvals of
-            Left e -> return (RunException e)
-            Right hvals -> do
-                hsc_env <- getSession
-                let final_ic = extendInteractiveContext (hsc_IC hsc_env)
-                                                        (map AnId final_ids)
-                    final_names = map getName final_ids
-                liftIO $ Linker.extendLinkEnv (zip final_names hvals)
-                hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
-                modifySession (\_ -> hsc_env')
-                return (RunOk final_names)
-
-traceRunStatus :: GhcMonad m =>
-                  String -> ([TyThing], GlobalRdrEnv) -> [Id]
-               -> MVar () -> MVar Status -> Status -> BoundedList History
-               -> m RunResult
-traceRunStatus expr bindings final_ids
-               breakMVar statusMVar status history = do
-  hsc_env <- getSession
-  case status of
-     -- when tracing, if we hit a breakpoint that is not explicitly
-     -- enabled, then we just log the event in the history and continue.
-     (Break is_exception apStack info tid) | not is_exception -> do
-        b <- liftIO $ isBreakEnabled hsc_env info
-        if b
-           then handle_normally
-           else do
-             let history' = mkHistory hsc_env apStack info `consBL` history
-                -- probably better make history strict here, otherwise
-                -- our BoundedList will be pointless.
-             _ <- liftIO $ evaluate history'
-             status <-
-                 withBreakAction True (hsc_dflags hsc_env)
-                                      breakMVar statusMVar $ do
-                   liftIO $ mask_ $ do
-                       putMVar breakMVar ()  -- awaken the stopped thread
-                       redirectInterrupts tid $
-                         takeMVar statusMVar   -- and wait for the result
-             traceRunStatus expr bindings final_ids
-                            breakMVar statusMVar status history'
-     _other ->
-        handle_normally
-  where
-        handle_normally = handleRunStatus expr bindings final_ids
-                                          breakMVar statusMVar status history
 
+        ; modifySession (\_ -> hsc_env2)
+        ; return (RunBreak tid names mb_info) }
+
+  | Complete (Left e) <- status
+  = return (RunException e)
+
+  | Complete (Right hvals) <- status
+  = do { hsc_env <- getSession
+       ; let final_ic = extendInteractiveContext (hsc_IC hsc_env)
+                                                 (map AnId final_ids)
+             final_names = map getName final_ids
+       ; liftIO $ Linker.extendLinkEnv (zip final_names hvals)
+       ; hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
+       ; modifySession (\_ -> hsc_env')
+       ; return (RunOk final_names) }
+
+  | otherwise
+  = panic "handleRunStatus"  -- The above cases are in fact exhaustive
 
 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
 isBreakEnabled hsc_env inf =
@@ -506,13 +494,8 @@ resume canLogSpan step
                          | not $canLogSpan span -> prevHistoryLst
                          | otherwise -> mkHistory hsc_env apStack i `consBL`
                                                         fromListBL 50 hist
-                case step of
-                  RunAndLogSteps ->
-                        traceRunStatus expr bindings final_ids
-                                       breakMVar statusMVar status hist'
-                  _other ->
-                        handleRunStatus expr bindings final_ids
-                                        breakMVar statusMVar status hist'
+                handleRunStatus step expr bindings final_ids
+                                breakMVar statusMVar status hist'
 
 back :: GhcMonad m => m ([Name], Int, SrcSpan)
 back  = moveHist (+1)