ghc-debug-brick 0.1.0.0 → 0.2.0.0
raw patch · 8 files changed
+383/−116 lines, 8 filesdep +exceptionsdep ~ghc-debug-clientdep ~ghc-debug-commondep ~ghc-debug-convention
Dependencies added: exceptions
Dependency ranges changed: ghc-debug-client, ghc-debug-common, ghc-debug-convention
Files
- CHANGELOG.md +10/−0
- ghc-debug-brick.cabal +5/−4
- src/Common.hs +1/−0
- src/Lib.hs +82/−11
- src/Main.hs +252/−91
- src/Model.hs +32/−9
- src/Namespace.hs +1/−0
- src/TextCursor.hs +0/−1
CHANGELOG.md view
@@ -1,1 +1,11 @@ # Revision history for ghc-debug-brick++## 0.2.0.0 -- 2021-12-06++* Second release++## 0.1.0.0 -- 2021-06-14++* First release++
ghc-debug-brick.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-debug-brick-version: 0.1.0.0+version: 0.2.0.0 synopsis: A simple TUI using ghc-debug description: A simple TUI using ghc-debug -- bug-reports:@@ -28,15 +28,16 @@ , containers , directory , filepath- , ghc-debug-client , microlens-platform , text , vty , time , microlens- , ghc-debug-common- , ghc-debug-convention+ , ghc-debug-client == 0.2.0.0+ , ghc-debug-common == 0.2.0.0+ , ghc-debug-convention == 0.2.0.0 , unordered-containers+ , exceptions hs-source-dirs: src default-language: Haskell2010 ghc-options: -threaded -Wall
src/Common.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Common where import qualified Brick.Types as T
src/Lib.hs view
@@ -9,15 +9,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Lib ( -- * Running/Connecting to a debuggee Debuggee , debuggeeRun , debuggeeConnect+ , snapshotConnect , debuggeeClose , withDebuggeeRun , withDebuggeeConnect , socketDirectory+ , snapshotDirectory -- * Pause/Resume , GD.pause@@ -40,6 +44,10 @@ , closureReferences , closurePretty , fillConstrDesc+ , InfoTablePtr+ , ListItem(..)+ , closureInfoPtr+ , infoSourceLocation -- * Common initialisation , initialTraversal@@ -56,6 +64,16 @@ , reverseClosureReferences , lookupHeapGraph + -- * Profiling+ , profile++ -- * Retainers+ , retainersOfConstructor+ , retainersOfConstructorExact++ -- * Snapshot+ , snapshot+ -- * Types , Ptr(..) , toPtr@@ -77,16 +95,20 @@ import Data.Maybe (fromMaybe, mapMaybe) import qualified GHC.Debug.Types as GD import GHC.Debug.Types hiding (Closure, DebugClosure)-import GHC.Debug.Convention (socketDirectory)+import GHC.Debug.Convention (socketDirectory, snapshotDirectory) import GHC.Debug.Client.Monad (request, run, Debuggee) import qualified GHC.Debug.Client.Monad as GD import qualified GHC.Debug.Client.Query as GD+import qualified GHC.Debug.Profile as GD+import qualified GHC.Debug.Retainers as GD+import qualified GHC.Debug.Snapshot as GD import qualified GHC.Debug.Types.Graph as HG import qualified GHC.Debug.Dominators as HG import qualified Data.HashMap.Strict as HM import Data.Tree import Control.Monad-+import System.FilePath+import System.Directory data Analysis = Analysis { analysisDominatorRoots :: ![ClosurePtr]@@ -164,6 +186,9 @@ -> IO Debuggee debuggeeConnect socketName = GD.debuggeeConnect socketName +snapshotConnect :: FilePath -> IO Debuggee+snapshotConnect snapshotName = GD.snapshotInit snapshotName+ -- | Close the connection to the debuggee. debuggeeClose :: Debuggee -> IO () debuggeeClose = GD.debuggeeClose@@ -188,6 +213,33 @@ closurePtrs closures +profile :: Debuggee -> FilePath -> IO ()+profile dbg fp = do+ c <- run dbg $ do+ roots <- GD.gcRoots+ GD.censusClosureType roots+ GD.writeCensusByClosureType fp c++snapshot :: Debuggee -> FilePath -> IO ()+snapshot dbg fp = do+ dir <- snapshotDirectory+ createDirectoryIfMissing True dir+ GD.makeSnapshot dbg (dir </> fp)++retainersOfConstructor :: Debuggee -> String -> IO [[Closure]]+retainersOfConstructor dbg con_name = do+ run dbg $ do+ roots <- GD.gcRoots+ stack <- GD.findRetainersOfConstructor (Just 100) roots con_name+ traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack++retainersOfConstructorExact :: Debuggee -> String -> IO [[Closure]]+retainersOfConstructorExact dbg con_name = do+ run dbg $ do+ roots <- GD.gcRoots+ stack <- GD.findRetainersOfConstructorExact (Just 100) roots con_name+ traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack+ -- -- | Request the description for an info table. -- -- The `InfoTablePtr` is just used for the equality -- requestConstrDesc :: Debuggee -> PayloadWithKey InfoTablePtr ClosurePtr -> IO ConstrDesc@@ -203,6 +255,8 @@ type Closure = DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr +data ListItem a b c d = ListData | ListOnlyInfo InfoTablePtr | ListFullClosure (DebugClosure a b c d)+ data DebugClosure p cd s c = Closure { _closurePtr :: ClosurePtr@@ -217,8 +271,11 @@ toPtr (Closure cp _) = CP cp toPtr (Stack sc _) = SP sc -data Ptr = CP ClosurePtr | SP StackCont+data Ptr = CP ClosurePtr | SP StackCont deriving (Eq, Ord) +deriving instance Eq StackCont+deriving instance Ord StackCont+ dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr) dereferencePtr dbg (CP cp) = run dbg (Closure <$> pure cp <*> GD.dereferenceClosure cp) dereferencePtr dbg (SP sc) = run dbg (Stack <$> pure sc <*> GD.dereferenceStack sc)@@ -253,28 +310,42 @@ closureSourceLocation e (Closure _ c) = run e $ do request (RequestSourceInfo (tableId (info (noSize c)))) +closureInfoPtr :: DebugClosure p cd s c -> Maybe InfoTablePtr+closureInfoPtr (Stack {}) = Nothing+closureInfoPtr (Closure _ c) = Just (tableId (info (noSize c)))++infoSourceLocation :: Debuggee -> InfoTablePtr -> IO (Maybe SourceInformation)+infoSourceLocation e ip = run e $ request (RequestSourceInfo ip)+ -- | Get the directly referenced closures (with a label) of a closure.-closureReferences :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, Closure)]+closureReferences :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem PayloadCont ConstrDescCont StackCont ClosurePtr)] closureReferences e (Stack _ stack) = run e $ do- let lblAndPtrs = [ ( "Frame " ++ show frameIx ++ " Pointer " ++ show ptrIx- , ptr- )+ let action (GD.SPtr ptr) = ("Pointer", ListFullClosure . Closure ptr <$> GD.dereferenceClosure ptr)+ action (GD.SNonPtr dat) = ("Data:" ++ show dat, return ListData)++ frame_items frame = ("Info: " ++ show (tableId (frame_info frame)), return (ListOnlyInfo (tableId (frame_info frame)))) :+ map action (GD.values frame)++ add_frame_ix ix (lbl, x) = ("Frame " ++ show ix ++ " " ++ lbl, x)+ let lblAndPtrs = [ map (add_frame_ix frameIx) (frame_items frame) | (frameIx, frame) <- zip [(0::Int)..] (GD.getFrames stack)- , (ptrIx , ptr ) <- zip [(0::Int)..] [ptr | GD.SPtr ptr <- GD.values frame] ]- closures <- GD.dereferenceClosures (snd <$> lblAndPtrs)+-- traverse GD.dereferenceClosures (snd <$> lblAndPtrs)+ traverse (traverse id) (concat lblAndPtrs)+ {- return $ zipWith (\(lbl,ptr) c -> (lbl, Closure ptr c)) lblAndPtrs closures+ -} closureReferences e (Closure _ closure) = run e $ do let refPtrs = closureReferencesAndLabels (unDCS closure) forM refPtrs $ \(label, ptr) -> case ptr of Left cPtr -> do refClosure' <- GD.dereferenceClosure cPtr- return (label, Closure cPtr refClosure')+ return (label, ListFullClosure $ Closure cPtr refClosure') Right sPtr -> do refStack' <- GD.dereferenceStack sPtr- return (label, Stack sPtr refStack')+ return (label, ListFullClosure $ Stack sPtr refStack') reverseClosureReferences :: HG.HeapGraph Size -> HG.ReverseGraph
src/Main.hs view
@@ -8,14 +8,17 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeFamilies #-} module Main where import Control.Applicative-import Control.Monad (forever, (<=<))+import Control.Monad (forever) import Control.Monad.IO.Class+import Control.Monad.Catch (bracket) import Control.Concurrent import qualified Data.List as List-import Data.Maybe (fromJust) import Data.Ord (comparing) import qualified Data.Ord as Ord import qualified Data.Sequence as Seq@@ -27,6 +30,7 @@ import System.FilePath import Data.Text (Text, pack) import qualified Data.Text as T+import qualified Data.Map as M import IOTree import TextCursor@@ -46,14 +50,14 @@ | ReverseAnalysisReady ReverseAnalysis | HeapGraphReady (HeapGraph GD.Size) -myAppDraw :: AppState -> [Widget Name]-myAppDraw (AppState majorState') =- [ case majorState' of - Setup knownDebuggees' -> let- nKnownDebuggees = Seq.length $ majorState'^.knownDebuggees.listElementsL+drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name+drawSetup herald other_herald vals =++ let nKnownDebuggees = Seq.length $ (vals ^. listElementsL) in mainBorder "ghc-debug" $ vBox- [ txt $ "Select a process to debug (" <> pack (show nKnownDebuggees) <> " found):"+ [ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):"+ , txt $ "Select " <> other_herald <> " with <TAB>" , renderList (\elIsSelected socketPath -> hBox [ txt $ if elIsSelected then "*" else " "@@ -64,29 +68,42 @@ ] ) True- knownDebuggees'+ vals ] +mainBorder :: Text -> Widget a -> Widget a+mainBorder title = borderWithLabel (txt title) . padAll 1++myAppDraw :: AppState -> [Widget Name]+myAppDraw (AppState majorState') =+ [ case majorState' of++ Setup setupKind' dbgs snaps ->+ case setupKind' of+ Socket -> drawSetup "process" "snapshot" dbgs+ Snapshot -> drawSetup "snapshot" "process" snaps++ Connected _socket _debuggee mode' -> case mode' of RunningMode -> mainBorder "ghc-debug - Running" $ vBox [ txt "Pause (p)" ] - (PausedMode os@(OperationalState treeMode' fmode _ro dtree _ reverseTree hg)) -> let+ (PausedMode os@(OperationalState treeMode' fmode _ro _dtree _ _reverseTree _hg)) -> let in mainBorder "ghc-debug - Paused" $ vBox [ hBox [ border $ vBox ([ txt "Resume (F12)"+ , txt "Tree (F1)" , txt "Parent (<-)" , txt "Child (->)" , txt "Saved/GC Roots (F1)"- ] ++- [ txt "Dominator Tree (F2)" | Just {} <- [dtree] ]- ++- [ txt "Reverse Analysis (F3)" | Just {} <- [reverseTree] ]- ++- [ txt "Search for Constructor (F8)" | Just {} <- [hg] ] )+ , txt "Write Profile (F3)"+ , txt "Find Retainers (F4)"+ , txt "Find Retainers (Exact) (F6)"+ , txt "Take Snapshot (F5)"+ ]) , -- Current closure details borderWithLabel (txt "Closure Details") $ pauseModeTree (renderClosureDetails . ioTreeSelection) os ]@@ -96,6 +113,7 @@ Dominator -> "Dominator Tree" SavedAndGCRoots -> "Root Closures" Reverse -> "Reverse Edges"+ Retainer {} -> "Retainers" ) (pauseModeTree renderIOTree os) , hBorder@@ -103,26 +121,35 @@ ] ] where- mainBorder title = borderWithLabel (txt title) . padAll 1 renderClosureDetails :: Maybe (ClosureDetails pap s c) -> Widget Name- renderClosureDetails cd = vLimit 9 $ vBox $+ renderClosureDetails (Just cd@(ClosureDetails {})) =+ vLimit 9 $ vBox $+ renderInfoInfo (_info cd)+ +++ [ txt $ "Exclusive Size "+ <> maybe "" (pack . show @Int . GD.getSize) (Just $ _excSize cd) <> " bytes"+ , txt $ "Retained Size "+ <> maybe "" (pack . show @Int . GD.getRetainerSize) (_retainerSize cd) <> " bytes"+ , fill ' '+ ]+ renderClosureDetails Nothing = emptyWidget+ renderClosureDetails (Just (LabelNode n)) = txt n+ renderClosureDetails (Just (InfoDetails info')) = vLimit 9 $ vBox $ renderInfoInfo info'++ renderInfoInfo info' = [ txt "SourceLocation "- <+> txt (maybe "" renderSourceInformation (_sourceLocation =<< cd))+ <+> txt (maybe "" renderSourceInformation (_sourceLocation info')) -- TODO these aren't actually implemented yet -- , txt $ "Type " -- <> fromMaybe "" (_closureType =<< cd) -- , txt $ "Constructor " -- <> fromMaybe "" (_constructor =<< cd)- , txt $ "Exclusive Size "- <> maybe "" (pack . show @Int . GD.getSize) (_excSize <$> cd) <> " bytes"- , txt $ "Retained Size "- <> maybe "" (pack . show @Int . GD.getRetainerSize) (_retainerSize =<< cd) <> " bytes"- , fill ' ' ]+ renderSourceInformation :: SourceInformation -> T.Text- renderSourceInformation (SourceInformation name cty ty label modu loc) =- T.pack $ unlines [name, show cty, ty, label, modu, loc]+ renderSourceInformation (SourceInformation name cty ty label' modu loc) =+ T.pack $ unlines [name, show cty, ty, label', modu, loc] footer :: FooterMode -> Widget Name footer m = vLimit 1 $@@ -131,35 +158,12 @@ FooterInfo -> txt "" FooterInput im t -> txt (formatFooterMode im) <+> drawTextCursor t --myAppHandleEvent :: BChan Event -> AppState -> BrickEvent Name Event -> EventM Name (Next AppState)-myAppHandleEvent eventChan appState@(AppState majorState') brickEvent = case brickEvent of- VtyEvent (Vty.EvKey KEsc []) -> halt appState- _ -> case majorState' of- Setup knownDebuggees' -> case brickEvent of-- VtyEvent event -> case event of- -- Connect to the selected debuggee- Vty.EvKey KEnter _- | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees'- -> do- debuggee' <- liftIO $ debuggeeConnect (view socketLocation socket)- continue $ appState & majorState .~ Connected- { _debuggeeSocket = socket- , _debuggee = debuggee'- , _mode = RunningMode -- TODO should we query the debuggee for this?- }-- -- Navigate through the list.- _ -> do- newOptions <- handleListEventVi handleListEvent event knownDebuggees'- continue $ appState & majorState . knownDebuggees .~ newOptions-- AppEvent event -> case event of- PollTick -> do- -- Poll for debuggees- knownDebuggees'' <- liftIO $ do- dir :: FilePath <- socketDirectory+updateListFrom :: MonadIO m =>+ IO FilePath+ -> GenericList n Seq.Seq SocketInfo+ -> m (GenericList n Seq.Seq SocketInfo)+updateListFrom dirIO llist = liftIO $ do+ dir :: FilePath <- dirIO debuggeeSocketFiles :: [FilePath] <- listDirectory dir <|> return [] -- Sort the sockets by the time they have been created, newest@@ -168,7 +172,7 @@ <$> mapM (mkSocketInfo . (dir </>)) debuggeeSocketFiles let currentSelectedPathMay :: Maybe SocketInfo- currentSelectedPathMay = fmap snd (listSelectedElement knownDebuggees')+ currentSelectedPathMay = fmap snd (listSelectedElement llist) newSelection :: Maybe Int newSelection = do@@ -178,9 +182,61 @@ return $ listReplace (Seq.fromList debuggeeSockets) (newSelection <|> (if Prelude.null debuggeeSockets then Nothing else Just 0))- knownDebuggees'+ llist ++myAppHandleEvent :: BChan Event -> AppState -> BrickEvent Name Event -> EventM Name (Next AppState)+myAppHandleEvent eventChan appState@(AppState majorState') brickEvent = case brickEvent of+ _ -> case majorState' of+ Setup st knownDebuggees' knownSnapshots' -> case brickEvent of++ VtyEvent (Vty.EvKey KEsc []) -> halt appState+ VtyEvent event -> case event of+ -- Connect to the selected debuggee+ Vty.EvKey (KChar '\t') [] -> do+ continue $ appState & majorState . setupKind %~ toggleSetup+ Vty.EvKey KEnter _ ->+ case st of+ Snapshot+ | Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots'+ -> do+ debuggee' <- liftIO $ snapshotConnect (view socketLocation socket)+ continue $ appState & majorState .~ Connected+ { _debuggeeSocket = socket+ , _debuggee = debuggee'+ , _mode = RunningMode -- TODO should we query the debuggee for this?+ }+ Socket+ | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees'+ -> do+ bracket+ (liftIO $ debuggeeConnect (view socketLocation socket))+ (\debuggee' -> liftIO $ resume debuggee')+ (\debuggee' ->+ continue $ appState & majorState .~ Connected+ { _debuggeeSocket = socket+ , _debuggee = debuggee'+ , _mode = RunningMode -- TODO should we query the debuggee for this?+ })+ _ -> continue appState++ -- Navigate through the list.+ _ -> do+ case st of+ Snapshot -> do+ newOptions <- handleListEventVi handleListEvent event knownSnapshots'+ continue $ appState & majorState . knownSnapshots .~ newOptions+ Socket -> do+ newOptions <- handleListEventVi handleListEvent event knownDebuggees'+ continue $ appState & majorState . knownDebuggees .~ newOptions++ AppEvent event -> case event of+ PollTick -> do+ -- Poll for debuggees+ knownDebuggees'' <- updateListFrom socketDirectory knownDebuggees'+ knownSnapshots'' <- updateListFrom snapshotDirectory knownSnapshots' continue $ appState & majorState . knownDebuggees .~ knownDebuggees''+ & majorState . knownSnapshots .~ knownSnapshots'' DominatorTreeReady {} -> continue appState ReverseAnalysisReady {} -> continue appState HeapGraphReady {} -> continue appState@@ -190,6 +246,8 @@ RunningMode -> case brickEvent of -- Pause the debuggee+ VtyEvent (Vty.EvKey KEsc []) ->+ halt appState VtyEvent (Vty.EvKey (KChar 'p') []) -> do liftIO $ pause debuggee' -- _ <- liftIO $ initialiseViews@@ -227,6 +285,10 @@ liftIO $ resume debuggee' continue (appState & majorState . mode .~ RunningMode) + VtyEvent (Vty.EvKey KEsc []) -> do+ liftIO $ resume debuggee'+ continue $ initialAppState+ _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee') appState (() <$ brickEvent) @@ -234,15 +296,16 @@ where - initialiseViews = forkIO $ do+ _initialiseViews = forkIO $ do !hg <- initialTraversal debuggee' writeBChan eventChan (HeapGraphReady hg)- _ <- mkDominatorTreeIO hg- _ <- mkReversalTreeIO hg+-- _ <- mkDominatorTreeIO hg+-- _ <- mkReversalTreeIO hg return () -- This is really slow on big heaps, needs to be made more efficient -- or some progress/timeout indicator+ {- mkDominatorTreeIO hg = forkIO $ do !analysis <- runAnalysis debuggee' hg !rootClosures' <- liftIO $ mapM (getClosureDetails debuggee' (Just analysis) "" <=< fillConstrDesc debuggee') =<< GD.dominatorRootClosures debuggee' analysis@@ -255,12 +318,13 @@ getChildren analysis _dbg c = do cs <- closureDominatees debuggee' analysis c fmap (("",)) <$> mapM (fillConstrDesc debuggee') cs+ -} - mkReversalTreeIO hg = forkIO $ do- let !revg = mkReverseGraph hg- let revIoTree = mkIOTree Nothing [] (reverseClosureReferences hg revg) id- writeBChan eventChan (ReverseAnalysisReady (ReverseAnalysis revIoTree (lookupHeapGraph hg)))+-- mkReversalTreeIO hg = forkIO $ do+-- let !revg = mkReverseGraph hg+-- let revIoTree = mkIOTree Nothing [] (reverseClosureReferences hg revg) id+-- writeBChan eventChan (ReverseAnalysisReady (ReverseAnalysis revIoTree (lookupHeapGraph hg))) mkSavedAndGCRootsIOTree manalysis = do@@ -268,68 +332,114 @@ rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_roots raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee' savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_saved- return $ (mkIOTree manalysis (savedClosures' ++ rootClosures') getChildren id+ return $ (mkIOTree debuggee' manalysis (savedClosures' ++ rootClosures') getChildren id , fmap toPtr <$> (raw_roots ++ raw_saved)) where+ getChildren :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr+ -> IO+ [(String, ListItem PayloadCont ConstrDesc StackCont ClosurePtr)] getChildren d c = do children <- closureReferences d c- mapM (mapM (fillConstrDesc d)) children+ traverse (traverse (fillListItem d)) children + fillListItem :: Debuggee+ -> ListItem PayloadCont ConstrDescCont StackCont ClosurePtr+ -> IO (ListItem PayloadCont ConstrDesc StackCont ClosurePtr)+ fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x+ fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd+ fillListItem _ ListData = return ListData - mkIOTree :: Show c => Maybe Analysis -> [ClosureDetails pap s c] -> (Debuggee -> DebugClosure pap ConstrDesc s c -> IO [(String, DebugClosure pap ConstrDesc s c)]) -> ([ClosureDetails pap s c] -> [ClosureDetails pap s c]) -> IOTree (ClosureDetails pap s c) Name- mkIOTree manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree++mkIOTree :: Show c => Debuggee+ -> Maybe Analysis+ -> [ClosureDetails pap s c]+ -> (Debuggee -> DebugClosure pap ConstrDesc s c -> IO [(String, ListItem pap ConstrDesc s c)])+ -> ([ClosureDetails pap s c] -> [ClosureDetails pap s c])+ -> IOTree (ClosureDetails pap s c) Name+mkIOTree debuggee' manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree (sort cs) (\c -> do- children <- getChildren debuggee' (_closure c)- cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children- return (sort cDets)+ case c of+ LabelNode {} -> return []+ InfoDetails {} -> return []+ _ -> do+ children <- getChildren debuggee' (_closure c)+ cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children+ return (sort cDets) ) (\selected depth closureDesc -> hBox [ txt (T.replicate depth " ") , (if selected then visible . txt else txt) $ (if selected then "* " else " ")- <> _labelInParent closureDesc- <> " "- <> pack (closureShowAddress (_closure closureDesc))- <> " "- <> _pretty closureDesc+ <> renderInlineClosureDesc closureDesc ] ) (\depth _closureDesc children -> if List.null children then txt $ T.replicate (depth + 2) " " <> "<Empty>"- else emptyWidget- )+ else emptyWidget)++renderInlineClosureDesc :: ClosureDetails pap s c -> Text+renderInlineClosureDesc (LabelNode t) = t+renderInlineClosureDesc (InfoDetails info') =+ _labelInParent info' <> " " <> _pretty info'+renderInlineClosureDesc closureDesc =+ _labelInParent (_info closureDesc)+ <> " "+ <> pack (closureShowAddress (_closure closureDesc))+ <> " "+ <> _pretty (_info closureDesc) completeClosureDetails :: Show c => Debuggee -> Maybe Analysis -> (Text, DebugClosure pap ConstrDescCont s c) -> IO (ClosureDetails pap s c) -completeClosureDetails dbg manalysis (label, clos) =- getClosureDetails dbg manalysis label =<< fillConstrDesc dbg clos+completeClosureDetails dbg manalysis (label', clos) =+ getClosureDetails dbg manalysis label' . ListFullClosure =<< fillConstrDesc dbg clos getClosureDetails :: Show c => Debuggee -> Maybe Analysis -> Text- -> DebugClosure pap ConstrDesc s c+ -> ListItem pap ConstrDesc s c -> IO (ClosureDetails pap s c)-getClosureDetails debuggee' manalysis label c = do+getClosureDetails debuggee' _ t (ListOnlyInfo info_ptr) = do+ info' <- getInfoInfo debuggee' t info_ptr+ return $ InfoDetails info'+getClosureDetails _ _ t ListData = return $ LabelNode t+getClosureDetails debuggee' manalysis label' (ListFullClosure c) = do let excSize' = closureExclusiveSize c retSize' = closureRetainerSize <$> manalysis <*> pure c- sourceLoc <- closureSourceLocation debuggee' c+ sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c) let pretty' = closurePretty c return ClosureDetails { _closure = c- , _pretty = pack pretty'- , _labelInParent = label- , _sourceLocation = sourceLoc- , _closureType = Nothing- , _constructor = Nothing+ , _info = InfoInfo {+ _pretty = pack pretty'+ , _labelInParent = label'+ , _sourceLocation = sourceLoc+ , _closureType = Nothing+ , _constructor = Nothing+ } , _excSize = excSize' , _retainerSize = retSize' } +getInfoInfo :: Debuggee -> Text -> InfoTablePtr -> IO InfoInfo+getInfoInfo debuggee' label' infoPtr = do + sourceLoc <- infoSourceLocation debuggee' infoPtr+ let pretty' = case sourceLoc of+ Just loc -> pack (infoPosition loc)+ Nothing -> ""+ return $ InfoInfo {+ _pretty = pretty'+ , _labelInParent = label'+ , _sourceLocation = sourceLoc+ , _closureType = Nothing+ , _constructor = Nothing+ }++ -- Event handling when the main window has focus handleMain :: Debuggee -> Handler OperationalState@@ -349,7 +459,7 @@ VtyEvent (Vty.EvKey (KFun 2) _) -- Only switch if the dominator view is ready | Just {} <- domTree -> continue $ os & treeMode .~ Dominator- VtyEvent (Vty.EvKey (KFun 3) _)+{- VtyEvent (Vty.EvKey (KFun 3) _) -- Only switch if the reverse view is ready | Just ra <- reverseA -> do -- Get roots from rootTree and use those for the reverse view@@ -359,9 +469,22 @@ rs' = map convert rs continue $ os & treeMode .~ Reverse & treeReverse . _Just . reverseIOTree %~ setIOTreeRoots rs'- VtyEvent (Vty.EvKey (KFun 8) _) ->- continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor)+ -}+-- VtyEvent (Vty.EvKey (KFun 8) _) ->+-- continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor) + VtyEvent (Vty.EvKey (KFun 3) _) ->+ continue $ os & footerMode .~ (FooterInput FProfile emptyTextCursor)++ VtyEvent (Vty.EvKey (KFun 4) _) ->+ continue $ os & footerMode .~ (FooterInput FRetainer emptyTextCursor)++ VtyEvent (Vty.EvKey (KFun 6) _) ->+ continue $ os & footerMode .~ (FooterInput FRetainerExact emptyTextCursor)++ VtyEvent (Vty.EvKey (KFun 5) _) ->+ continue $ os & footerMode .~ (FooterInput FSnapshot emptyTextCursor)+ -- Navigate the tree of closures VtyEvent event -> case treeMode' of Dominator -> do@@ -373,6 +496,11 @@ Reverse -> do newTree <- traverseOf (_Just . reverseIOTree) (handleIOTreeEvent event) reverseA continue (os & treeReverse .~ newTree)++ Retainer t -> do+ newTree <- handleIOTreeEvent event t+ continue (os & treeMode .~ Retainer newTree)+ _ -> continue os inputFooterHandler :: Debuggee@@ -412,6 +540,39 @@ & treeSavedAndGCRoots %~ setIOTreeRoots root_details) -- Should never happen Nothing -> continue os+dispatchFooterInput dbg FProfile tc os = do+ liftIO $ profile dbg (T.unpack (rebuildTextCursor tc))+ continue (os & resetFooter)+dispatchFooterInput dbg FRetainer tc os = do+ cps <- liftIO $ retainersOfConstructor dbg (T.unpack (rebuildTextCursor tc))+ let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps+ res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps'+ let tree = mkRetainerTree dbg res+ continue (os & resetFooter+ & treeMode .~ Retainer tree)+dispatchFooterInput dbg FRetainerExact tc os = do+ cps <- liftIO $ retainersOfConstructorExact dbg (T.unpack (rebuildTextCursor tc))+ let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps+ res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps'+ let tree = mkRetainerTree dbg res+ continue (os & resetFooter+ & treeMode .~ Retainer tree)+dispatchFooterInput dbg FSnapshot tc os = do+ liftIO $ snapshot dbg (T.unpack (rebuildTextCursor tc))+ continue (os & resetFooter)++mkRetainerTree :: Debuggee -> [[ClosureDetails PayloadCont StackCont ClosurePtr]] -> IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name+mkRetainerTree dbg stacks = do+ let stack_map = [ (cp, rest) | stack <- stacks, Just (cp, rest) <- [List.uncons stack]]+ roots = map fst stack_map+ info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((show n), ListFullClosure (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map]++ lookup_c _dbg dc = let ptr = toPtr dc+ in case M.lookup ptr info_map of+ Nothing -> return []+ Just ss -> return ss++ mkIOTree dbg Nothing roots lookup_c id resetFooter :: OperationalState -> OperationalState resetFooter l = (set footerMode FooterInfo l)
src/Model.hs view
@@ -31,7 +31,9 @@ initialAppState :: AppState initialAppState = AppState { _majorState = Setup- { _knownDebuggees = list Setup_KnownDebuggeesList [] 1+ { _setupKind = Socket+ , _knownDebuggees = list Setup_KnownDebuggeesList [] 1+ , _knownSnapshots = list Setup_KnownSnapshotsList [] 1 } } @@ -58,10 +60,20 @@ -- Compare time first compare t1 t2 <> compare s1 s2 +type SnapshotInfo = SocketInfo++data SetupKind = Socket | Snapshot++toggleSetup :: SetupKind -> SetupKind+toggleSetup Socket = Snapshot+toggleSetup Snapshot = Socket+ data MajorState -- | We have not yet connected to a debuggee. = Setup- { _knownDebuggees :: GenericList Name Seq SocketInfo+ { _setupKind :: SetupKind+ , _knownDebuggees :: GenericList Name Seq SocketInfo+ , _knownSnapshots :: GenericList Name Seq SnapshotInfo } -- | Connected to a debuggee@@ -71,28 +83,38 @@ , _mode :: ConnectedMode } -data ClosureDetails pap s c = ClosureDetails- { _closure :: DebugClosure pap ConstrDesc s c- , _labelInParent :: Text -- ^ A label describing the relationship to the parent+data InfoInfo = InfoInfo+ {+ _labelInParent :: Text -- ^ A label describing the relationship to the parent -- Stuff that requires IO to calculate , _pretty :: Text , _sourceLocation :: Maybe SourceInformation , _closureType :: Maybe Text- , _constructor :: Maybe Text- , _excSize :: Size+ , _constructor :: Maybe Text }++data ClosureDetails pap s c = ClosureDetails+ { _closure :: DebugClosure pap ConstrDesc s c , _retainerSize :: Maybe RetainerSize+ , _excSize :: Size+ , _info :: InfoInfo }+ | InfoDetails { _info :: InfoInfo }+ | LabelNode { _label :: Text } -data TreeMode = Dominator | SavedAndGCRoots | Reverse+data TreeMode = Dominator | SavedAndGCRoots | Reverse | Retainer (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name) data FooterMode = FooterInfo | FooterMessage Text | FooterInput FooterInputMode TextCursor -data FooterInputMode = FSearch+data FooterInputMode = FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot formatFooterMode :: FooterInputMode -> Text formatFooterMode FSearch = "search: "+formatFooterMode FProfile = "filename: "+formatFooterMode FRetainer = "constructor name: "+formatFooterMode FRetainerExact = "closure name: "+formatFooterMode FSnapshot = "snapshot name: " data ConnectedMode -- | Debuggee is running@@ -135,6 +157,7 @@ Dominator -> k $ maybe (error "DOMINATOR-DavidE is not ready") _getDominatorTree dom SavedAndGCRoots -> k roots Reverse -> k $ maybe (error "bop it, flip, reverse it, DavidE") _reverseIOTree reverseA+ Retainer r -> k r makeLenses ''AppState makeLenses ''MajorState
src/Namespace.hs view
@@ -9,6 +9,7 @@ data Name = Setup_KnownDebuggeesList+ | Setup_KnownSnapshotsList | Connected_Paused_ClosureTree | Footer deriving (Eq, Ord, Show)
src/TextCursor.hs view
@@ -8,7 +8,6 @@ import Brick hiding (continue, halt) import qualified Graphics.Vty as V -import Brick.Types ( Widget ) import Namespace