Introduce DebuggeeAction-monad

* Introduce DebuggeeAction as alias for StateT Debugee IO
  -> Get rid of Debuggee being passed explicitly into IO actions,
  turning function signatures like
      (Debuggee -> ... -> IO a)
  into
      (... -> DebuggeeAction a)

* This is done in order to track state in Debuggee in the future.

* Introduce a lot of liftIO :(

Author: obreitwi

client/ghc-debug-client.cabal

@@ -19,6 +19,7 @@ library
                        network >=2.6 && <2.7,
                        unordered-containers,
                        ghc-debug-common, cpu,
-                       dwarfadt, dwarf-el, text, process, filepath, directory
+                       dwarfadt, dwarf-el, text, process, filepath, directory,
+                       mtl
   hs-source-dirs:      src
-  default-language:    Haskell2010
+  default-language:    Haskell2010

client/src/GHC/Debug/Client.hs

@@ -1,5 +1,7 @@
 module GHC.Debug.Client
   ( Debuggee
+  , DebuggeeAction
+  , applyDebuggeeAction
   , withDebuggee
   , withDebuggeeSocket
   , pauseDebuggee
@@ -26,6 +28,7 @@ module GHC.Debug.Client
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
+import Control.Monad.State.Lazy
 import GHC.Debug.Types
 import GHC.Debug.Decode
 import GHC.Debug.Decode.Stack
@@ -55,11 +58,17 @@ import System.Directory
 import Text.Printf
 
 data Debuggee = Debuggee { debuggeeHdl :: Handle
-                         , debuggeeInfoTblEnv :: MVar (HM.HashMap InfoTablePtr RawInfoTable)
+                         , debuggeeInfoTblEnv :: HM.HashMap InfoTablePtr RawInfoTable
                          , debuggeeDwarf :: Maybe Dwarf
                          , debuggeeFilename :: FilePath
                          }
 
+type DebuggeeAction a = StateT Debuggee IO a
+
+
+applyDebuggeeAction :: Debuggee -> DebuggeeAction a -> IO a
+applyDebuggeeAction = flip evalStateT
+
 
 debuggeeProcess :: FilePath -> FilePath -> IO CreateProcess
 debuggeeProcess exe sockName = do
@@ -69,7 +78,7 @@ debuggeeProcess exe sockName = do
 
 -- | Open a debuggee, this will also read the DWARF information
 withDebuggee :: FilePath  -- ^ path to executable
-             -> (Debuggee -> IO a)
+             -> DebuggeeAction a
              -> IO a
 withDebuggee exeName action = do
     let sockName = "/tmp/ghc-debug2"
@@ -86,33 +95,39 @@ withDebuggee exeName action = do
 withDebuggeeSocket :: FilePath  -- ^ executable name of the debuggee
                    -> FilePath  -- ^ debuggee's socket location
                    -> Maybe Dwarf
-                   -> (Debuggee -> IO a)
+                   -> DebuggeeAction a
                    -> IO a
 withDebuggeeSocket exeName sockName mdwarf action = do
     s <- socket AF_UNIX Stream defaultProtocol
     connect s (SockAddrUnix sockName)
     hdl <- socketToHandle s ReadWriteMode
-    infoTableEnv <- newMVar mempty
-    action (Debuggee hdl infoTableEnv mdwarf exeName)
+    evalStateT action (Debuggee hdl mempty mdwarf exeName)
 
 -- | Send a request to a 'Debuggee' paused with 'pauseDebuggee'.
-request :: Debuggee -> Request resp -> IO resp
-request d req = doRequest (debuggeeHdl d) req
+request :: Request resp -> DebuggeeAction resp
+request req = do
+  hdl <- gets debuggeeHdl
+  liftIO $ doRequest hdl req
 
-lookupInfoTable :: Debuggee -> RawClosure -> IO (RawInfoTable, RawClosure)
-lookupInfoTable d rc = do
+lookupInfoTable :: RawClosure -> DebuggeeAction (RawInfoTable, RawClosure)
+lookupInfoTable rc = do
     let ptr = getInfoTblPtr rc
-    itblEnv <- readMVar (debuggeeInfoTblEnv d)
+    itblEnv <- gets debuggeeInfoTblEnv
     case HM.lookup ptr itblEnv of
       Nothing -> do
-        [itbl] <- request d (RequestInfoTables [ptr])
-        modifyMVar_ (debuggeeInfoTblEnv d) $ return . HM.insert ptr itbl
+        [itbl] <- request (RequestInfoTables [ptr])
+        infoTblEnv <- gets debuggeeInfoTblEnv
+        modify' $ \s -> s { debuggeeInfoTblEnv = HM.insert ptr itbl infoTblEnv }
         return (itbl, rc)
       Just itbl ->  return (itbl, rc)
 
-pauseDebuggee :: Debuggee -> IO a -> IO a
-pauseDebuggee d =
-    bracket_ (void $ request d RequestPause) (void $ request d RequestResume)
+pauseDebuggee :: DebuggeeAction a -> DebuggeeAction a
+pauseDebuggee action = do
+    -- TODO: replace poor-mans bracket_ with proper implementation for StateT
+    request RequestPause
+    rc <- action
+    request RequestResume
+    return rc
 
 getDwarfInfo :: FilePath -> IO Dwarf
 getDwarfInfo fn = do
@@ -121,10 +136,12 @@ getDwarfInfo fn = do
 -- print $ DwarfPretty.dwarf dwarf
  return dwarf
 
-lookupDwarf :: Debuggee -> InfoTablePtr -> Maybe ([FilePath], Int, Int)
-lookupDwarf d (InfoTablePtr w) = do
-  (Dwarf units) <- debuggeeDwarf d
-  asum (map (lookupDwarfUnit (fromBE64 w)) units)
+lookupDwarf :: InfoTablePtr -> DebuggeeAction (Maybe ([FilePath], Int, Int))
+lookupDwarf (InfoTablePtr w) = do
+  mDwarf <- gets debuggeeDwarf
+  case mDwarf of
+    Nothing -> return Nothing
+    Just (Dwarf units) -> return $ asum (map (lookupDwarfUnit (fromBE64 w)) units)
 
 lookupDwarfUnit :: Word64 -> Boxed CompilationUnit -> Maybe ([FilePath], Int, Int)
 lookupDwarfUnit w (Boxed _ cu) = do
@@ -158,63 +175,66 @@ lookupDwarfLine w Nothing (d, nd) = do
     else Nothing
 lookupDwarfLine _ (Just r) _ =  Just r
 
-showFileSnippet :: Debuggee -> ([FilePath], Int, Int) -> IO ()
-showFileSnippet d (fps, l, c) = go fps
+showFileSnippet :: ([FilePath], Int, Int) -> DebuggeeAction ()
+showFileSnippet (fps, l, c) =  do
+  dbgFilename <- gets debuggeeFilename
+  liftIO $ go dbgFilename fps
   where
-    go [] = putStrLn ("No files could be found: " ++ show fps)
-    go (fp: fps) = do
-      exists <- doesFileExist fp
+    go :: FilePath -> [FilePath] -> IO ()
+    go _ [] = putStrLn ("No files could be found: " ++ show fps)
+    go dbgFilename (fp:fps) = do
+      exists <- liftIO $ doesFileExist $ fp
       -- get file modtime
       if not exists
-        then go fps
+        then go dbgFilename fps
         else do
-          fp `warnIfNewer` (debuggeeFilename d)
+          -- TODO: get the modtime of debuggee above
+          fp `warnIfNewer` dbgFilename
           src <- zip [1..] . lines <$> readFile fp
           let ctx = take 10 (drop (max (l - 5) 0) src)
           putStrLn (fp <> ":" <> show l <> ":" <> show c)
           mapM_ (\(n, l) ->
            let sn = show n
            in putStrLn (sn <> replicate (5 - length sn) ' ' <> l)) ctx
 
-dereferenceClosure :: Debuggee -> ClosurePtr -> IO Closure
-dereferenceClosure d c = head <$> dereferenceClosures d [c]
+dereferenceClosure :: ClosurePtr -> DebuggeeAction Closure
+dereferenceClosure c = head <$> dereferenceClosures [c]
 
-dereferenceClosures  :: Debuggee -> [ClosurePtr] -> IO [Closure]
-dereferenceClosures d cs = do
-    raw_cs <- request d (RequestClosures cs)
+dereferenceClosures :: [ClosurePtr] -> DebuggeeAction [Closure]
+dereferenceClosures cs = do
+    raw_cs <- request (RequestClosures cs)
     let its = map getInfoTblPtr raw_cs
     --print $ map (lookupDwarf d) its
-    raw_its <- request d (RequestInfoTables its)
+    raw_its <- request (RequestInfoTables its)
     return $ map (uncurry decodeClosure) (zip raw_its (zip cs raw_cs))
 
-dereferenceStack :: Debuggee -> StackCont -> IO Stack
-dereferenceStack d (StackCont stack) = do
-  print stack
-  i <- lookupInfoTable d (coerce stack)
+dereferenceStack :: StackCont -> DebuggeeAction Stack
+dereferenceStack (StackCont stack) = do
+  liftIO $ print stack
+  i <- lookupInfoTable (coerce stack)
   let st_it = decodeInfoTable . fst $ i
-  print i
-  print st_it
-  bt <- request d (RequestBitmap (getInfoTblPtr (coerce stack)))
+  liftIO $ print i
+  liftIO $ print st_it
+  bt <- request (RequestBitmap (getInfoTblPtr (coerce stack)))
   let decoded_stack = decodeStack stack st_it bt
-  print decoded_stack
+  liftIO $ print decoded_stack
   return decoded_stack
 
-dereferenceConDesc :: Debuggee -> ClosurePtr -> IO ConstrDesc
-dereferenceConDesc d i = do
-  request d (RequestConstrDesc i)
+dereferenceConDesc :: ClosurePtr -> DebuggeeAction ConstrDesc
+dereferenceConDesc i = request (RequestConstrDesc i)
 
 
-fullTraversal :: Debuggee -> ClosurePtr -> IO UClosure
-fullTraversal d c = do
-  dc <- dereferenceClosure d c
-  print dc
-  MkFix1 <$> tritraverse (dereferenceConDesc d) (fullStackTraversal d) (fullTraversal d)  dc
+fullTraversal :: ClosurePtr -> DebuggeeAction UClosure
+fullTraversal c = do
+  dc <- dereferenceClosure c
+  liftIO $ print dc
+  MkFix1 <$> tritraverse dereferenceConDesc fullStackTraversal fullTraversal  dc
 
-fullStackTraversal :: Debuggee -> StackCont -> IO UStack
-fullStackTraversal d sc = do
-  ds <- dereferenceStack d sc
-  print ds
-  MkFix2 <$> traverse (fullTraversal d) ds
+fullStackTraversal :: StackCont -> DebuggeeAction UStack
+fullStackTraversal sc = do
+  ds <- dereferenceStack sc
+  liftIO $ print ds
+  MkFix2 <$> traverse fullTraversal ds
 
 -- | Print a warning if source file (first argument) is newer than the binary (second argument)
 warnIfNewer :: FilePath -> FilePath -> IO ()

ghc-vis/src/GHC/Vis.hs

@@ -475,8 +475,9 @@ react dbg window canvas = do
 
 derefBox :: Debuggee -> DerefFunction
 derefBox dbg cp = do
-  c <- dereferenceClosure dbg cp
-  tritraverse (dereferenceConDesc dbg) pure pure c
+  let apply = applyDebuggeeAction dbg
+  c <- apply $ dereferenceClosure cp
+  tritraverse (\x -> apply $ dereferenceConDesc x) pure pure c
 
 runCorrect :: MonadIO m => (View -> f) -> m f
 runCorrect f = do

stub/Test.hs

@@ -27,7 +27,7 @@ main :: IO ()
 main = do
   start
   let !y = Data.Sequence.fromList [1..5]
-  -- let !y = [1..5]
+  let !y = [1..5]
   performGC
   saveClosures [Box y]
   print "start"