Make evaluation utilities available in Debugger.Runtime.Eval

These utilities are useful outside of parsing only, and come in quite
handy for a lot of  multi-threaded and callstack related code.

Author: alt-romes

haskell-debugger.cabal

@@ -64,6 +64,7 @@ library
                       GHC.Debugger.Stopped.Variables,
 
                       GHC.Debugger.Runtime,
+                      GHC.Debugger.Runtime.Eval,
                       GHC.Debugger.Runtime.Instances,
                       GHC.Debugger.Runtime.Instances.Discover,
 

haskell-debugger/GHC/Debugger/Runtime/Eval.hs

@@ -0,0 +1,67 @@
+-- | Lower-level interface to evaluating things in the (possibly remote) debuggee process
+module GHC.Debugger.Runtime.Eval where
+
+import GHC
+import GHC.Driver.Env
+import GHC.Runtime.Interpreter as Interp
+import Control.Monad.Reader
+import GHC.Driver.Config
+import GHCi.RemoteTypes
+
+import GHC.Debugger.Monad
+
+--------------------------------------------------------------------------------
+-- * Evaluation on Foreign Heap Values
+--------------------------------------------------------------------------------
+
+-- | Evaluate `f x` for any @f :: a -> b@ and any @x :: a@.
+-- The result is the foreign reference to a heap value of type @b@
+evalApplication :: ForeignHValue -> ForeignHValue -> Debugger ForeignHValue
+evalApplication fref aref = do
+  hsc_env <- getSession
+  mk_list_fv <- compileExprRemote "(pure @IO . (:[])) :: a -> IO [a]"
+
+  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
+      interp = hscInterp hsc_env
+
+  liftIO (evalStmt interp eval_opts $ (EvalThis mk_list_fv) `EvalApp` ((EvalThis fref) `EvalApp` (EvalThis aref)))
+    >>= liftIO . handleSingStatus
+
+-- | Evaluate `f x` for any @f :: a -> IO b@ and any @x :: a@.
+-- The result is the foreign reference to a heap value of type @b@ (the IO action is executed)
+evalApplicationIO :: ForeignHValue -> ForeignHValue -> Debugger ForeignHValue
+evalApplicationIO fref aref = do
+  hsc_env <- getSession
+  fmap_list_fv <- compileExprRemote "(fmap (:[])) :: IO a -> IO [a]"
+
+  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
+      interp = hscInterp hsc_env
+
+  liftIO (evalStmt interp eval_opts $ (EvalThis fmap_list_fv) `EvalApp` ((EvalThis fref) `EvalApp` (EvalThis aref)))
+    >>= liftIO . handleSingStatus
+
+-- | Handle the 'EvalStatus_' of an evaluation using 'EvalStepNone' which returns a single value
+handleSingStatus :: MonadFail m => EvalStatus_ [ForeignHValue] [HValueRef] -> m ForeignHValue
+handleSingStatus status =
+  case status of
+    EvalComplete _ (EvalSuccess [res]) -> pure res
+    EvalComplete _ (EvalSuccess []) ->
+      fail "evaluation did not bind any values"
+    EvalComplete _ (EvalSuccess (_:_:_)) ->
+      fail "evaluation produced more than one value"
+    EvalComplete _ (EvalException e) ->
+      fail ("evaluation raised an exception: " ++ show e)
+    EvalBreak {} ->
+      --TODO: Could we accidentally hit this if we set a breakpoint regardless of whether EvalStep=None? perhaps.
+      fail "evaluation unexpectedly hit a breakpoint"
+
+-- | Handle the 'EvalStatus_' of an evaluation using 'EvalStepNone' which returns a list of values
+handleMultiStatus :: MonadFail m => EvalStatus_ [ForeignHValue] [HValueRef] -> m [ForeignHValue]
+handleMultiStatus status =
+  case status of
+    EvalComplete _ (EvalSuccess res) -> pure res
+    EvalComplete _ (EvalException e) ->
+      fail ("evaluation raised an exception: " ++ show e)
+      -- TODO?: throwIO (fromSerializableException e)
+    EvalBreak {} ->
+      fail "evaluation unexpectedly hit a breakpoint"

haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs

@@ -19,13 +19,10 @@ import qualified GHC.Debugger.Logger as Logger
 import GHC.Utils.Outputable (text, (<+>), ppr)
 import Control.Monad.Reader
 import GHC.Core.TyCo.Compare
-import GHC.Driver.Config
 import GHC.Stack
-import GHCi.RemoteTypes
-
-
 
 import GHC.Debugger.Monad
+import GHC.Debugger.Runtime.Eval
 
 -- | The main entry point for running the 'TermParser'.
 obtainParsedTerm
@@ -236,34 +233,6 @@ foreignValueToTerm ty fhv =
     hsc_env <- getSession
     liftIO $ cvObtainTerm hsc_env 2 False ty fhv
 
---------------------------------------------------------------------------------
--- * Evaluation
---------------------------------------------------------------------------------
-
--- | Evaluate `f x`.
-evalApplication :: ForeignHValue -> ForeignHValue -> Debugger (EvalStatus_ [ForeignHValue] [HValueRef])
-evalApplication fref aref = do
-  hsc_env <- getSession
-  mk_list_fv <- compileExprRemote "(pure @IO . (:[])) :: a -> IO [a]"
-
-  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
-      interp = hscInterp hsc_env
-
-  liftIO $ (evalStmt interp eval_opts $ (EvalThis mk_list_fv) `EvalApp` ((EvalThis fref) `EvalApp` (EvalThis aref)))
-
-handleStatusParser :: EvalStatus_ [ForeignHValue] [HValueRef] -> TermParser ForeignHValue
-handleStatusParser status =
-  case status of
-    EvalComplete _ (EvalSuccess [res]) -> pure res
-    EvalComplete _ (EvalSuccess []) ->
-      parseError (TermParseError "evaluation did not bind any values")
-    EvalComplete _ (EvalSuccess (_:_:_)) ->
-      parseError (TermParseError "evaluation produced more than one value")
-    EvalComplete _ (EvalException e) ->
-      parseError (TermParseError ("evaluation raised an exception: " ++ show e))
-    EvalBreak {} ->
-      parseError (TermParseError "evaluation unexpectedly hit a breakpoint")
-
 --------------------------------------------------------------------------------
 -- * Logging parsers
 --------------------------------------------------------------------------------
@@ -378,8 +347,7 @@ programTermParser =
       let fref1 = val p1
       let fref2 = val p2
       let (_, _arg_ty, res_ty) = splitFunTy (termType p1)
-      eval_status <- liftDebugger $ evalApplication fref1 fref2
-      res <- handleStatusParser eval_status
+      res <- liftDebugger $ evalApplication fref1 fref2
       foreignValueToTerm res_ty res
 
     programBranchParser = do