ghc-debug-brick 0.3.0.0 → 0.4.0.0
raw patch · 8 files changed
+381/−288 lines, 8 filesdep ~ghc-debug-clientdep ~ghc-debug-commondep ~ghc-debug-convention
Dependency ranges changed: ghc-debug-client, ghc-debug-common, ghc-debug-convention
Files
- CHANGELOG.md +8/−0
- ghc-debug-brick.cabal +4/−4
- src/Common.hs +4/−4
- src/IOTree.hs +16/−1
- src/Lib.hs +55/−42
- src/Main.hs +250/−202
- src/Model.hs +42/−35
- src/Namespace.hs +2/−0
CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for ghc-debug-brick +## 0.4.0.0 -- 2022-12-14++* Add command picker (Ctrl-P) for selecting commands+* Add support for tracing SRTs+* Better progress indicating+* Fix some bugs with `ESC` not respecting the correct scopes.+* Keybinding for multi collapse (Shift-Left)+ ## 0.3.0.0 -- 2022-10-06 * Major improvments to interface
ghc-debug-brick.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-debug-brick-version: 0.3.0.0+version: 0.4.0.0 synopsis: A simple TUI using ghc-debug description: A simple TUI using ghc-debug bug-reports: https://gitlab.haskell.org/ghc/ghc-debug/-/issues@@ -29,9 +29,9 @@ , time , deepseq , microlens- , ghc-debug-client == 0.3.0.0- , ghc-debug-common == 0.3.0.0- , ghc-debug-convention == 0.3.0.0+ , ghc-debug-client == 0.4.0.0+ , ghc-debug-common == 0.4.0.0+ , ghc-debug-convention == 0.4.0.0 , unordered-containers , exceptions , contra-tracer
src/Common.hs view
@@ -7,8 +7,8 @@ import Lens.Micro import Namespace -type Handler s =- T.BrickEvent Name ()+type Handler e s =+ T.BrickEvent Name e -> T.EventM Name s () -- | liftHandler lifts a handler which only operates on its own state into@@ -18,8 +18,8 @@ :: ASetter s s a a -- The mode to modify -> c -- Inner state -> (c -> a) -- How to inject the new state- -> Handler c -- Handler for inner state- -> Handler s+ -> Handler e c -- Handler for inner state+ -> Handler e s liftHandler l c i h ev = do T.zoom (lens (const c) (\ s c' -> set l (i c') s)) (h ev)
src/IOTree.hs view
@@ -143,6 +143,7 @@ (view', cs) <- viewExpand view return $ if null cs then view' else viewUnsafeDown view' 0 Vty.EvKey KDown _ -> return $ next view+ Vty.EvKey KLeft [Vty.MShift] -> return $ viewCollapseAll view Vty.EvKey KLeft _ -> return $ viewCollapse $ fromMaybe view (viewUp' view) Vty.EvKey KUp _ -> return $ prev view Vty.EvKey KPageDown _ -> return $ List.foldl' (flip ($)) view (replicate 15 next)@@ -282,7 +283,21 @@ Left _ -> t Right cs -> Node mkParent i t'{_children = Left (return cs)} --- | Expand the current node. Returns the children+-- | Collapse the current node and all the nodes in the subtree rooted at+-- the current node.+viewCollapseAll :: HasCallStack => IOTreeView node name -> IOTreeView node name+viewCollapseAll tv = case tv of+ Root t -> Root (t {_roots = fmap go (_roots t)})+ Node mkParent i t -> case _children t of+ Left cs -> Node mkParent i t {_children = Left $ fmap go <$> cs}+ Right cs -> Node mkParent i t {_children = Left . pure $ fmap go cs }+ where+ go :: IOTreeNode node name -> IOTreeNode node name+ go tn = case _children tn of+ Left cs -> tn {_children = Left $ fmap go <$> cs }+ Right cs -> tn {_children = Left . pure $ fmap go cs}++-- | Expand the current node. Returns the children of the current node. viewExpand :: HasCallStack => IOTreeView node name -> IO (IOTreeView node name, [IOTreeNode node name]) viewExpand t = case t of Root t' -> return (t, _roots t')
src/Lib.hs view
@@ -84,10 +84,12 @@ , GenPapPayload(..) , StackCont , PayloadCont+ , SrtCont , ClosurePtr , readClosurePtr , HG.StackHI , HG.PapHI+ , HG.SrtHI , HG.HeapGraphIndex -- ) where@@ -112,6 +114,8 @@ import System.FilePath import System.Directory import Control.Tracer+import Data.Bitraversable+import Data.Text (Text, pack) data Analysis = Analysis { analysisDominatorRoots :: ![ClosurePtr]@@ -129,7 +133,7 @@ rs <- request RequestRoots let derefFuncM cPtr = do c <- GD.dereferenceClosure cPtr- quadtraverse GD.dereferencePapPayload GD.dereferenceConDesc GD.dereferenceStack pure c+ quintraverse GD.dereferenceSRT GD.dereferencePapPayload GD.dereferenceConDesc (bitraverse GD.dereferenceSRT pure <=< GD.dereferenceStack) pure c hg <- case rs of [] -> error "Empty roots" (x:xs) -> HG.multiBuildHeapGraph derefFuncM Nothing (x :| xs)@@ -185,13 +189,14 @@ debuggeeRun exeName socketName = GD.debuggeeRun exeName socketName -- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done.-debuggeeConnect :: FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@)+debuggeeConnect :: (Text -> IO ())+ -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) -> IO Debuggee-debuggeeConnect socketName = GD.debuggeeConnectWithTracer debugTracer socketName+debuggeeConnect toChan socketName = GD.debuggeeConnectWithTracer (contramap pack $ Tracer (emit toChan)) socketName -snapshotConnect :: FilePath -> IO Debuggee-snapshotConnect snapshotName = GD.snapshotInitWithTracer debugTracer snapshotName+snapshotConnect :: (Text -> IO ()) -> FilePath -> IO Debuggee+snapshotConnect toChan snapshotName = GD.snapshotInitWithTracer (contramap pack $ Tracer (emit toChan)) snapshotName -- | Close the connection to the debuggee. debuggeeClose :: Debuggee -> IO ()@@ -228,7 +233,7 @@ snapshot dbg fp = do dir <- snapshotDirectory createDirectoryIfMissing True dir- GD.makeSnapshot dbg (dir </> fp)+ GD.run dbg $ GD.snapshot (dir </> fp) retainersOfAddress :: Maybe [ClosurePtr] -> Debuggee -> [ClosurePtr] -> IO [[Closure]] retainersOfAddress mroots dbg address = do@@ -264,49 +269,49 @@ -- requestClosures :: Debuggee -> [ClosurePtr] -> IO [RawClosure] -- requestClosures (Debuggee e _) = run e $ request RequestClosures -type Closure = DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr+type Closure = DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr -data ListItem a b c d = ListData | ListOnlyInfo InfoTablePtr | ListFullClosure (DebugClosure a b c d)+data ListItem srt a b c d = ListData | ListOnlyInfo InfoTablePtr | ListFullClosure (DebugClosure srt a b c d) -data DebugClosure p cd s c+data DebugClosure srt p cd s c = Closure { _closurePtr :: ClosurePtr- , _closureSized :: DebugClosureWithSize p cd s c+ , _closureSized :: DebugClosureWithSize srt p cd s c } | Stack { _stackPtr :: StackCont- , _stackStack :: GD.GenStackFrames c+ , _stackStack :: GD.GenStackFrames srt c } -toPtr :: DebugClosure p cd s c -> Ptr+toPtr :: DebugClosure srt p cd s c -> Ptr toPtr (Closure cp _) = CP cp toPtr (Stack sc _) = SP sc data Ptr = CP ClosurePtr | SP StackCont deriving (Eq, Ord) -dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)+dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure SrtCont 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) -instance Quadtraversable DebugClosure where- quadtraverse p f g h (Closure cp c) = Closure cp <$> quadtraverse p f g h c- quadtraverse _ _ _ h (Stack sp s) = Stack sp <$> traverse h s+instance Quintraversable DebugClosure where+ quintraverse p f g h i (Closure cp c) = Closure cp <$> quintraverse p f g h i c+ quintraverse p _ _ _ h (Stack sp s) = Stack sp <$> bitraverse p h s -closureShowAddress :: DebugClosure p cd s c -> String+closureShowAddress :: DebugClosure srt p cd s c -> String closureShowAddress (Closure c _) = show c-closureShowAddress (Stack s _) = show s+closureShowAddress (Stack (StackCont s _) _) = show s -- | Get the exclusive size (not including any referenced closures) of a closure.-closureExclusiveSize :: DebugClosure p cd s c -> Size+closureExclusiveSize :: DebugClosure srt p cd s c -> Size closureExclusiveSize (Stack{}) = Size (-1) closureExclusiveSize (Closure _ c) = (GD.dcSize c) -- | Get the retained size (including all dominated closures) of a closure.-closureRetainerSize :: Analysis -> DebugClosure p cd s c -> RetainerSize+closureRetainerSize :: Analysis -> DebugClosure srt p cd s c -> RetainerSize closureRetainerSize analysis c = snd (closureExcAndRetainerSizes analysis c) -closureExcAndRetainerSizes :: Analysis -> DebugClosure p cd s c -> (Size, RetainerSize)+closureExcAndRetainerSizes :: Analysis -> DebugClosure srt p cd s c -> (Size, RetainerSize) closureExcAndRetainerSizes _ Stack{} = (Size (-1), RetainerSize (-1)) -- ^ TODO How should we handle stack size? only used space on the stack? -- Include underflow frames? Return Maybe?@@ -314,12 +319,12 @@ let getSizes = analysisSizes analysis in getSizes cPtr -closureSourceLocation :: Debuggee -> DebugClosure p cd s c -> IO (Maybe SourceInformation)+closureSourceLocation :: Debuggee -> DebugClosure srt p cd s c -> IO (Maybe SourceInformation) closureSourceLocation _ (Stack _ _) = return Nothing closureSourceLocation e (Closure _ c) = run e $ do request (RequestSourceInfo (tableId (info (noSize c)))) -closureInfoPtr :: DebugClosure p cd s c -> Maybe InfoTablePtr+closureInfoPtr :: DebugClosure srt p cd s c -> Maybe InfoTablePtr closureInfoPtr (Stack {}) = Nothing closureInfoPtr (Closure _ c) = Just (tableId (info (noSize c))) @@ -327,17 +332,19 @@ 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, ListItem PayloadCont ConstrDescCont StackCont ClosurePtr)]+closureReferences :: Debuggee -> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)] closureReferences e (Stack _ stack) = run e $ do+ stack' <- bitraverse GD.dereferenceSRT pure stack 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)+ [ ("SRT: ", ListFullClosure . Closure srt <$> GD.dereferenceClosure srt) | Just srt <- [getSrt (frame_srt 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)+ | (frameIx, frame) <- zip [(0::Int)..] (GD.getFrames stack') ] -- traverse GD.dereferenceClosures (snd <$> lblAndPtrs) traverse (traverse id) (concat lblAndPtrs)@@ -347,7 +354,8 @@ closures -} closureReferences e (Closure _ closure) = run e $ do- let refPtrs = closureReferencesAndLabels (unDCS closure)+ closure' <- quintraverse GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure+ let refPtrs = closureReferencesAndLabels (unDCS closure') forM refPtrs $ \(label, ptr) -> case ptr of Left cPtr -> do refClosure' <- GD.dereferenceClosure cPtr@@ -359,8 +367,9 @@ reverseClosureReferences :: HG.HeapGraph Size -> HG.ReverseGraph -> Debuggee- -> DebugClosure HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex)+ -> DebugClosure HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex) -> IO [(String, DebugClosure+ HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex))]@@ -375,27 +384,27 @@ (DCS (HG.hgeData hge) (HG.hgeClosure hge) )) | (n, hge) <- zip [0 :: Int ..] revs] -lookupHeapGraph :: HG.HeapGraph Size -> ClosurePtr -> Maybe (DebugClosure HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex))+lookupHeapGraph :: HG.HeapGraph Size -> ClosurePtr -> Maybe (DebugClosure HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex)) lookupHeapGraph hg cp = case HG.lookupHeapGraph cp hg of Just (HG.HeapGraphEntry ptr d s) -> Just (Closure ptr (DCS s d)) Nothing -> Nothing fillConstrDesc :: Debuggee- -> DebugClosure pap ConstrDescCont s c- -> IO (DebugClosure pap ConstrDesc s c)+ -> DebugClosure srt pap ConstrDescCont s c+ -> IO (DebugClosure srt pap ConstrDesc s c) fillConstrDesc e closure = do- run e $ GD.quadtraverse pure GD.dereferenceConDesc pure pure closure+ run e $ GD.quintraverse pure pure GD.dereferenceConDesc pure pure closure -- | Pretty print a closure-closurePretty :: Show c => DebugClosure p ConstrDesc s c -> String-closurePretty (Stack _ _) = "STACK"-closurePretty (Closure _ closure) =- HG.ppClosure- "??"+closurePretty :: Debuggee -> DebugClosure InfoTablePtr PayloadCont ConstrDesc s ClosurePtr -> IO String+closurePretty _ (Stack _ frames) = return $ (show (length frames) ++ " frames")+closurePretty dbg (Closure _ closure) = run dbg $ do+ closure' <- quintraverse GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure+ return $ HG.ppClosure (\_ refPtr -> show refPtr) 0- (unDCS closure)+ (unDCS closure') -- $dominatorTree --@@ -417,7 +426,7 @@ ] -- | Get the dominatess of a closure i.e. the children in the dominator tree.-closureDominatees :: Debuggee -> Analysis -> DebugClosure p cd s ClosurePtr -> IO [Closure]+closureDominatees :: Debuggee -> Analysis -> DebugClosure srt p cd s ClosurePtr -> IO [Closure] closureDominatees _ _ (Stack{}) = error "TODO dominator tree does not yet support STACKs" closureDominatees e analysis (Closure cPtr _) = run e $ do let cPtrToDominatees = analysisDominatees analysis@@ -432,9 +441,10 @@ -- Internal Stuff -- -closureReferencesAndLabels :: GD.DebugClosure pap string stack pointer -> [(String, Either pointer stack)]+closureReferencesAndLabels :: GD.DebugClosure (GenSrtPayload pointer) PapPayload string stack pointer -> [(String, Either pointer stack)] closureReferencesAndLabels closure = case closure of TSOClosure {..} ->+ [ ("Thread label", Left lbl) | Just lbl <- pure threadLabel ] ++ [ ("Stack", Left tsoStack) , ("Link", Left _link) , ("Global Link", Left global_link)@@ -454,7 +464,8 @@ TVarClosure {..} -> [("val", Left current_value)] MutPrimClosure {..} -> withArgLables ptrArgs ConstrClosure {..} -> withFieldLables ptrArgs- ThunkClosure {..} -> withArgLables ptrArgs+ ThunkClosure {..} -> [ ("SRT", Left cp) | Just cp <- [getSrt srt]]+ ++ withArgLables ptrArgs SelectorClosure {..} -> [("Selectee", Left selectee)] IndClosure {..} -> [("Indirectee", Left indirectee)] BlackholeClosure {..} -> [("Indirectee", Left indirectee)]@@ -473,7 +484,9 @@ , ("Queue Tail", Left queueTail) , ("Value", Left value) ]- FunClosure {..} -> withArgLables ptrArgs+ FunClosure {..} ->+ [ ("SRT", Left cp) | Just cp <- [getSrt srt]]+ ++ withArgLables ptrArgs BlockingQueueClosure {..} -> [ ("Link", Left link) , ("Black Hole", Left blackHole) , ("Owner", Left owner)
src/Main.hs view
@@ -37,21 +37,14 @@ import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Map as M-import Data.Bifunctor import Data.Maybe+import qualified Data.Foldable as F -import GHC.Debug.Client.Search as GD import IOTree import Lib as GD import Model -data Event- = PollTick -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees- | DominatorTreeReady DominatorAnalysis -- A signal when the dominator tree has been computed- | ReverseAnalysisReady ReverseAnalysis- | HeapGraphReady (HeapGraph GD.Size) - drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name drawSetup herald other_herald vals = let nKnownDebuggees = Seq.length $ (vals ^. listElementsL)@@ -76,7 +69,7 @@ vLimit 1 (withAttr menuAttr $ hCenter $ fill ' ' <+> txt title <+> fill ' ') <=> w myAppDraw :: AppState -> [Widget Name]-myAppDraw (AppState majorState') =+myAppDraw (AppState majorState' _) = case majorState' of Setup setupKind' dbgs snaps ->@@ -93,7 +86,7 @@ , withAttr menuAttr $ vLimit 1 $ hBox [txt "(p): Pause | (ESC): Exit", fill ' '] ]] - (PausedMode os@(OperationalState treeMode' kbmode fmode _ro _dtree _ _reverseTree _hg)) -> let+ (PausedMode os@(OperationalState _ treeMode' kbmode fmode _ _ _)) -> let in kbOverlay kbmode $ [mainBorder "ghc-debug - Paused" $ vBox [ -- Current closure details joinBorders $ borderWithLabel (txt "Closure Details") $@@ -103,9 +96,7 @@ , -- Tree joinBorders $ borderWithLabel (txt $ case treeMode' of- Dominator -> "Dominator Tree" SavedAndGCRoots -> "Root Closures"- Reverse -> "Reverse Edges" Retainer {} -> "Retainers" Searched {} -> "Search Results" )@@ -115,29 +106,58 @@ where - kbOverlay :: KeybindingsMode -> [Widget Name] -> [Widget Name]+ kbOverlay :: OverlayMode -> [Widget Name] -> [Widget Name] kbOverlay KeybindingsShown ws = centerLayer kbWindow : ws- kbOverlay KeybindingsHidden ws = ws+ kbOverlay (CommandPicker inp cmd_list) ws = centerLayer (cpWindow inp cmd_list) : ws+ kbOverlay NoOverlay ws = ws + cpWindow :: Form Text () Name -> GenericList Name Seq.Seq Command -> Widget Name+ cpWindow input cmd_list = hLimit (actual_width + 2) $ vLimit (length commandList + 4) $+ withAttr menuAttr $+ borderWithLabel (txt "Command Picker") $ vBox $+ [ renderForm input+ , renderList (\elIsSelected -> if elIsSelected then highlighted . renderCommand else renderCommand) False cmd_list]+ kbWindow :: Widget Name kbWindow = withAttr menuAttr $ borderWithLabel (txt "Keybindings") $ vBox $- [ txt "Resume (^r)"- , txt "Tree (^t)"- , txt "Parent (<-)"- , txt "Child (->)"- , txt "Saved/GC Roots (^s)"- , txt "Write Profile (^w)"- , txt "Find Retainers (^f)"- , txt "Find Retainers (Exact) (^e)"- , txt "Find Closures (Exact) (^c)"- , txt "Find Address (^p)"- , txt "Take Snapshot (^x)"- , txt "Exit (ESC)"- ]+ map renderCommandDesc all_keys - renderClosureDetails :: Maybe (ClosureDetails pap s c) -> Widget Name+ all_keys =+ [ ("Resume", Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl])+ , ("Parent", Vty.EvKey KLeft [])+ , ("Child", Vty.EvKey KRight [])+ , ("Command Picker", Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]) ]+ ++ [(commandDescription cmd, commandKey cmd) | cmd <- F.toList commandList ]+ ++ [ ("Exit", Vty.EvKey KEsc []) ]++ maximum_size = maximum (map (T.length . fst) all_keys)++ actual_width = maximum_size + 5 -- 5, maximum width of rendering a key+ + 1 -- 1, at least one padding++ renderKey :: Vty.Event -> Text+ renderKey (Vty.EvKey k [Vty.MCtrl]) = "(^" <> renderNormalKey k <> ")"+ renderKey (Vty.EvKey k []) = "(" <> renderNormalKey k <> ")"+ renderKey _k = "()"++ renderNormalKey (KChar c) = T.pack [c]+ renderNormalKey KEsc = "ESC"+ renderNormalKey KLeft = "←"+ renderNormalKey KRight = "→"+ renderNormalKey _k = "�"++ renderCommand cmd = renderCommandDesc (commandDescription cmd, commandKey cmd)+++ renderCommandDesc :: (Text, Vty.Event) -> Widget Name+ renderCommandDesc (desc, k) = txt (desc <> T.replicate padding " " <> renderKey k)+ where+ key = renderKey k+ padding = (actual_width - T.length desc - T.length key)++ renderClosureDetails :: Maybe ClosureDetails -> Widget Name renderClosureDetails (Just cd@(ClosureDetails {})) = vLimit 9 $ -- viewport Connected_Paused_ClosureDetails Both $@@ -179,8 +199,8 @@ footer :: FooterMode -> Widget Name footer m = vLimit 1 $ case m of- FooterMessage t -> txt t- FooterInfo -> withAttr menuAttr $ hBox [txt "(↑↓): select item | (→): expand | (←): collapse | (?): full keybindings", fill ' ']+ FooterMessage t -> withAttr menuAttr $ hBox [txt t, fill ' ']+ FooterInfo -> withAttr menuAttr $ hBox [txt "(↑↓): select item | (→): expand | (←): collapse | (^p): command picker | (?): full keybindings", fill ' '] FooterInput _im form -> renderForm form footerInput :: FooterInputMode -> FooterMode@@ -218,9 +238,9 @@ llist -myAppHandleEvent :: BChan Event -> BrickEvent Name Event -> EventM Name AppState ()-myAppHandleEvent eventChan brickEvent = do- appState@(AppState majorState') <- get+myAppHandleEvent :: BrickEvent Name Event -> EventM Name AppState ()+myAppHandleEvent brickEvent = do+ appState@(AppState majorState' eventChan) <- get case brickEvent of _ -> case majorState' of Setup st knownDebuggees' knownSnapshots' -> case brickEvent of@@ -235,7 +255,7 @@ Snapshot | Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots' -> do- debuggee' <- liftIO $ snapshotConnect (view socketLocation socket)+ debuggee' <- liftIO $ snapshotConnect (writeBChan eventChan . ProgressMessage . error . show) (view socketLocation socket) put $ appState & majorState .~ Connected { _debuggeeSocket = socket , _debuggee = debuggee'@@ -245,7 +265,7 @@ | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees' -> do bracket- (liftIO $ debuggeeConnect (view socketLocation socket))+ (liftIO $ debuggeeConnect (writeBChan eventChan . ProgressMessage) (view socketLocation socket)) (\debuggee' -> liftIO $ resume debuggee') (\debuggee' -> put $ appState & majorState .~ Connected@@ -270,9 +290,7 @@ knownSnapshots'' <- updateListFrom snapshotDirectory knownSnapshots' put $ appState & majorState . knownDebuggees .~ knownDebuggees'' & majorState . knownSnapshots .~ knownSnapshots''- DominatorTreeReady {} -> return ()- ReverseAnalysisReady {} -> return ()- HeapGraphReady {} -> return ()+ _ -> return () _ -> return () Connected _socket' debuggee' mode' -> case mode' of@@ -284,84 +302,47 @@ -- Pause the debuggee VtyEvent (Vty.EvKey (KChar 'p') []) -> do liftIO $ pause debuggee'- -- _ <- liftIO $ initialiseViews (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree Nothing put (appState & majorState . mode .~ PausedMode- (OperationalState SavedAndGCRoots- KeybindingsHidden+ (OperationalState Nothing+ SavedAndGCRoots+ NoOverlay FooterInfo (DefaultRoots initRoots)- Nothing rootsTree- Nothing- Nothing))+ eventChan )) - _ -> return () - PausedMode os -> case brickEvent of - -- Once the computation is finished, store the result of the- -- analysis in the state.- AppEvent (DominatorTreeReady dt) -> do- -- TODO: This should retain the state of the rootsTree, whilst- -- adding the new information.- -- rootsTree <- mkSavedAndGCRootsIOTree (Just (view getDominatorAnalysis dt))- put (appState & majorState . mode . pausedMode . treeDominator .~ Just dt)-- AppEvent (ReverseAnalysisReady ra) -> do- put (appState & majorState . mode . pausedMode . treeReverse .~ Just ra)-- AppEvent (HeapGraphReady hg) -> do- put (appState & majorState . mode . pausedMode . heapGraph .~ Just hg)+ _ -> return () - -- Resume the debuggee if '^r', exit if ESC- VtyEvent (Vty.EvKey (KChar 'r') [Vty.MCtrl]) -> do- liftIO $ resume debuggee'- put (appState & majorState . mode .~ RunningMode)- VtyEvent (Vty.EvKey (KEsc) _) -> do- liftIO $ resume debuggee'- put $ initialAppState+ PausedMode os -> case brickEvent of+ _ -> case brickEvent of+ -- Resume the debuggee if '^r', exit if ESC+ VtyEvent (Vty.EvKey (KChar 'r') [Vty.MCtrl]) -> do+ liftIO $ resume debuggee'+ put (appState & majorState . mode .~ RunningMode)+ VtyEvent (Vty.EvKey (KEsc) _) | NoOverlay <- view keybindingsMode os+ , not (isFocusedFooter (view footerMode os)) -> do+ case view running_task os of+ Just tid -> do+ liftIO $ killThread tid+ put $ appState & majorState . mode . pausedMode . running_task .~ Nothing+ & majorState . mode . pausedMode %~ resetFooter+ Nothing -> do+ liftIO $ resume debuggee'+ put $ initialAppState (_appChan appState) - -- handle any other more local events; mostly key events- _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee')- (() <$ brickEvent)+ -- handle any other more local events; mostly key events+ _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee')+ (brickEvent) where - _initialiseViews = forkIO $ do- !hg <- initialTraversal debuggee'- writeBChan eventChan (HeapGraphReady 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- let domIoTree = mkIOTree (Just analysis) rootClosures'- (getChildren analysis)-- (List.sortOn (Ord.Down . _retainerSize))- writeBChan eventChan (DominatorTreeReady (DominatorAnalysis analysis domIoTree))- where- 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)))-- mkSavedAndGCRootsIOTree manalysis = do raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures debuggee' rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_roots@@ -372,27 +353,29 @@ where -getChildren :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr+getChildren :: Debuggee -> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO- [(String, ListItem PayloadCont ConstrDesc StackCont ClosurePtr)]+ [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)] getChildren d c = do children <- closureReferences d c traverse (traverse (fillListItem d)) children fillListItem :: Debuggee- -> ListItem PayloadCont ConstrDescCont StackCont ClosurePtr- -> IO (ListItem PayloadCont ConstrDesc StackCont ClosurePtr)+ -> ListItem SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr+ -> IO (ListItem SrtCont 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 => Debuggee+mkIOTree :: 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+ -> [ClosureDetails]+ -> (Debuggee -> DebugClosure+ SrtCont PayloadCont ConstrDesc StackCont ClosurePtr+ -> IO [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)])+ -> ([ClosureDetails] -> [ClosureDetails])+ -> IOTree ClosureDetails Name mkIOTree debuggee' manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree (sort cs) (\c -> do@@ -488,7 +471,7 @@ render (hLimit (c ^. availWidthL - (length depth * 2 + 4)) $ vLimit (c ^. availHeightL) $ body) -} -renderInlineClosureDesc :: ClosureDetails pap s c -> [Widget n]+renderInlineClosureDesc :: ClosureDetails -> [Widget n] renderInlineClosureDesc (LabelNode t) = [txtLabel t] renderInlineClosureDesc (InfoDetails info') = [txtLabel (_labelInParent info'), txt " ", txt (_pretty info')]@@ -500,20 +483,20 @@ <> " " <> _pretty (_info closureDesc) ]-completeClosureDetails :: Show c => Debuggee -> Maybe Analysis- -> (Text, DebugClosure pap ConstrDescCont s c)- -> IO (ClosureDetails pap s c)+completeClosureDetails :: Debuggee -> Maybe Analysis+ -> (Text, DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)+ -> IO ClosureDetails completeClosureDetails dbg manalysis (label', clos) = getClosureDetails dbg manalysis label' . ListFullClosure =<< fillConstrDesc dbg clos -getClosureDetails :: Show c => Debuggee+getClosureDetails :: Debuggee -> Maybe Analysis -> Text- -> ListItem pap ConstrDesc s c- -> IO (ClosureDetails pap s c)+ -> ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr+ -> IO ClosureDetails getClosureDetails debuggee' _ t (ListOnlyInfo info_ptr) = do info' <- getInfoInfo debuggee' t info_ptr return $ InfoDetails info'@@ -522,7 +505,7 @@ let excSize' = closureExclusiveSize c retSize' = closureRetainerSize <$> manalysis <*> pure c sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c)- let pretty' = closurePretty c+ pretty' <- closurePretty debuggee' c return ClosureDetails { _closure = c , _info = InfoInfo {@@ -554,70 +537,117 @@ -- Event handling when the main window has focus -handleMain :: Debuggee -> Handler OperationalState+handleMain :: Debuggee -> Handler Event OperationalState handleMain dbg e = do os <- get- case view keybindingsMode os of- KeybindingsShown ->- case e of- VtyEvent (Vty.EvKey _ _) -> put $ os & keybindingsMode .~ KeybindingsHidden- _ -> put os- _ -> case view footerMode os of- FooterInput fm form -> inputFooterHandler dbg fm form (handleMainWindowEvent dbg) e- _ -> handleMainWindowEvent dbg e+ case e of+ AppEvent event -> case event of+ PollTick -> return ()+ ProgressMessage t -> do+ put $ footerMessage t os+ ProgressFinished ->+ put $ os+ & running_task .~ Nothing+ & resetFooter+ AsyncFinished action -> action+ _ | Nothing <- view running_task os ->+ case view keybindingsMode os of+ KeybindingsShown ->+ case e of+ VtyEvent (Vty.EvKey _ _) -> put $ os & keybindingsMode .~ NoOverlay+ _ -> put os+ CommandPicker form cmd_list -> do+ -- Overlapping commands are up/down so handle those just via list, otherwise both+ let handle_form = nestEventM' form (handleFormEvent (() <$ e))+ handle_list =+ case e of+ VtyEvent vty_e -> nestEventM' cmd_list (handleListEvent vty_e)+ _ -> return cmd_list+ k form' cmd_list' =+ if (formState form /= formState form') then do+ let filter_string = formState form'+ new_elems = Seq.filter (\cmd -> T.toLower filter_string `T.isInfixOf` T.toLower (commandDescription cmd )) commandList+ cmd_list'' = cmd_list' & listElementsL .~ new_elems+ & listSelectedL .~ if Seq.null new_elems then Nothing else Just 0+ modify $ keybindingsMode .~ (CommandPicker form' cmd_list'')+ else+ modify $ keybindingsMode .~ (CommandPicker form' cmd_list') -handleMainWindowEvent :: Debuggee- -> Handler OperationalState-handleMainWindowEvent _dbg brickEvent = do- os@(OperationalState treeMode' _kbMode _footerMode _curRoots domTree rootsTree reverseA _hg) <- get- case brickEvent of- -- Change Modes- VtyEvent (Vty.EvKey (KChar '?') []) -> put $ os & keybindingsMode .~ KeybindingsShown- VtyEvent (Vty.EvKey (KChar 's') [Vty.MCtrl]) -> put $ os & treeMode .~ SavedAndGCRoots- VtyEvent (Vty.EvKey (KChar 't') [Vty.MCtrl])- -- Only switch if the dominator view is ready- | Just {} <- domTree -> put $ os & treeMode .~ Dominator-{- 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- let rs = getIOTreeRoots rootsTree- convert cd = cd & closure %~ do_one- do_one cd = fromJust (view convertPtr ra $ _closurePtr cd)- rs' = map convert rs- continue $ os & treeMode .~ Reverse- & treeReverse . _Just . reverseIOTree %~ setIOTreeRoots rs'- -}- VtyEvent (Vty.EvKey (KChar 'c') [Vty.MCtrl]) ->- put $ os & footerMode .~ footerInput FSearch - VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) ->- put $ os & footerMode .~ footerInput FAddress+ case e of+ VtyEvent (Vty.EvKey Vty.KUp _) -> do+ list' <- handle_list+ k form list'+ VtyEvent (Vty.EvKey Vty.KDown _) -> do+ list' <- handle_list+ k form list'+ VtyEvent (Vty.EvKey Vty.KEsc _) ->+ put $ os & keybindingsMode .~ NoOverlay+ VtyEvent (Vty.EvKey Vty.KEnter _) -> do+ case listSelectedElement cmd_list of+ Just (_, cmd) -> do+ modify $ keybindingsMode .~ NoOverlay+ dispatchCommand cmd+ Nothing -> return ()+ _ -> do+ form' <- handle_form+ list' <- handle_list+ k form' list' - VtyEvent (Vty.EvKey (KChar 'w') [Vty.MCtrl]) ->- put $ os & footerMode .~ footerInput FProfile - VtyEvent (Vty.EvKey (KChar 'f') [Vty.MCtrl]) ->- put $ os & footerMode .~ footerInput FRetainer+ NoOverlay -> case view footerMode os of+ FooterInput fm form -> inputFooterHandler dbg fm form (handleMainWindowEvent dbg) (() <$ e)+ _ -> handleMainWindowEvent dbg (() <$ e)+ _ -> return () - VtyEvent (Vty.EvKey (KChar 'e') [Vty.MCtrl]) ->- put $ os & footerMode .~ footerInput FRetainerExact+commandPickerMode :: OverlayMode+commandPickerMode =+ CommandPicker+ (newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] "")+ (list CommandPicker_List commandList 1) - VtyEvent (Vty.EvKey (KChar 'x') [Vty.MCtrl]) ->- put $ os & footerMode .~ footerInput FSnapshot +-- All the commands which we support, these show up in keybindings and also the command picker+commandList :: Seq.Seq Command+commandList =+ [ Command "Show key bindings" (Vty.EvKey (KChar '?') [])+ (modify $ keybindingsMode .~ KeybindingsShown)+ , Command "Saved/GC Roots" (Vty.EvKey (KChar 's') [Vty.MCtrl])+ (modify $ treeMode .~ SavedAndGCRoots)+ , Command "Find Closures (Exact)" (Vty.EvKey (KChar 'c') [Vty.MCtrl])+ (modify $ footerMode .~ footerInput FSearch)+ , Command "Find Address" (Vty.EvKey (KChar 'a') [Vty.MCtrl])+ (modify $ footerMode .~ footerInput FAddress)+ , Command "Write Profile" (Vty.EvKey (KChar 'w') [Vty.MCtrl])+ (modify $ footerMode .~ footerInput FProfile)+ , Command "Find Retainers" (Vty.EvKey (KChar 'f') [Vty.MCtrl])+ (modify $ footerMode .~ footerInput FRetainer)+ , Command "Find Retainers (Exact)" (Vty.EvKey (KChar 'e') [Vty.MCtrl])+ (modify $ footerMode .~ footerInput FRetainerExact)+ , Command "Take Snapshot" (Vty.EvKey (KChar 'x') [Vty.MCtrl])+ (modify $ footerMode .~ footerInput FSnapshot) ]+++findCommand :: Vty.Event -> Maybe Command+findCommand event = do+ i <- Seq.findIndexL (\cmd -> commandKey cmd == event) commandList+ Seq.lookup i commandList++handleMainWindowEvent :: Debuggee+ -> Handler () OperationalState+handleMainWindowEvent _dbg brickEvent = do+ os@(OperationalState _ treeMode' _kbMode _footerMode _curRoots rootsTree _) <- get+ case brickEvent of+ VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) ->+ put $ os & keybindingsMode .~ commandPickerMode++ -- A generic event+ VtyEvent event | Just cmd <- findCommand event -> dispatchCommand cmd -- Navigate the tree of closures VtyEvent event -> case treeMode' of- Dominator -> do- newTree <- traverseOf (_Just . getDominatorTree) (handleIOTreeEvent event) domTree- put (os & treeDominator .~ newTree) SavedAndGCRoots -> do newTree <- handleIOTreeEvent event rootsTree put (os & treeSavedAndGCRoots .~ newTree)- Reverse -> do- newTree <- traverseOf (_Just . reverseIOTree) (handleIOTreeEvent event) reverseA- put (os & treeReverse .~ newTree)- Retainer t -> do newTree <- handleIOTreeEvent event t put (os & treeMode .~ Retainer newTree)@@ -631,8 +661,8 @@ inputFooterHandler :: Debuggee -> FooterInputMode -> Form Text () Name- -> Handler OperationalState- -> Handler OperationalState+ -> Handler () OperationalState+ -> Handler () OperationalState inputFooterHandler dbg m form _k re@(VtyEvent e) = case e of Vty.EvKey KEsc [] -> modify resetFooter@@ -648,60 +678,75 @@ -> EventM n OperationalState () dispatchFooterInput dbg FSearch form = do os <- get- cps <- map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (formState form)))- let cps' = (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps- res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'- let tree = mkIOTree dbg Nothing res getChildren id- put (os & resetFooter- & treeMode .~ Searched tree- )+ asyncAction "Searching for closures" os (map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (formState form)))) $ \cps -> do+ let cps' = (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps+ res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'+ let tree = mkIOTree dbg Nothing res getChildren id+ put (os & resetFooter+ & treeMode .~ Searched tree+ ) dispatchFooterInput dbg FAddress form = do os <- get let address = T.unpack (formState form) case readClosurePtr address of Just cp -> do- cps <- map head <$> (liftIO $ retainersOfAddress Nothing dbg [cp])- let cps' = (zipWith (\n cp' -> (T.pack (show n),cp')) [0 :: Int ..]) cps- res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'- let tree = mkIOTree dbg Nothing res getChildren id- put (os & resetFooter- & treeMode .~ Searched tree- )+ asyncAction "Finding address" os (map head <$> (liftIO $ retainersOfAddress Nothing dbg [cp])) $ \cps -> do+ let cps' = (zipWith (\n cp' -> (T.pack (show n),cp')) [0 :: Int ..]) cps+ res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'+ let tree = mkIOTree dbg Nothing res getChildren id+ put (os & resetFooter+ & treeMode .~ Searched tree+ ) Nothing -> put (os & resetFooter) dispatchFooterInput dbg FProfile form = do os <- get- liftIO $ profile dbg (T.unpack (formState form))- put (os & resetFooter)+ asyncAction_ "Writing profile" os $ profile dbg (T.unpack (formState form)) dispatchFooterInput dbg FRetainer form = do os <- get let roots = mapMaybe go (map snd (currentRoots (view rootsFrom os))) go (CP p) = Just p go (SP _) = Nothing- cps <- liftIO $ retainersOfConstructor (Just roots) dbg (T.unpack (formState form))- 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- put (os & resetFooter- & treeMode .~ Retainer tree)+ asyncAction "Finding retainers" os (retainersOfConstructor (Just roots) dbg (T.unpack (formState form))) $ \cps -> do+ 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+ put (os & resetFooter+ & treeMode .~ Retainer tree) dispatchFooterInput dbg FRetainerExact form = do os <- get- cps <- liftIO $ retainersOfConstructorExact dbg (T.unpack (formState form))- 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- put (os & resetFooter- & treeMode .~ Retainer tree)+ asyncAction "Finding exact retainers" os (retainersOfConstructorExact dbg (T.unpack (formState form))) $ \cps -> do+ 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+ put (os & resetFooter+ & treeMode .~ Retainer tree) dispatchFooterInput dbg FSnapshot form = do os <- get- liftIO $ snapshot dbg (T.unpack (formState form))- put (os & resetFooter)+ asyncAction_ "Taking snapshot" os $ snapshot dbg (T.unpack (formState form)) -mkRetainerTree :: Debuggee -> [[ClosureDetails PayloadCont StackCont ClosurePtr]] -> IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name+asyncAction_ :: Text -> OperationalState -> IO a -> EventM n OperationalState ()+asyncAction_ desc os action = asyncAction desc os action (\_ -> return ())++asyncAction :: Text -> OperationalState -> IO a -> (a -> EventM Name OperationalState ()) -> EventM n OperationalState ()+asyncAction desc os action final = do+ tid <- (liftIO $ forkIO $ do+ writeBChan eventChan (ProgressMessage desc)+ res <- action+ writeBChan eventChan (AsyncFinished (final res))+ writeBChan eventChan ProgressFinished)+ put $ os & running_task .~ Just tid+ & resetFooter+ where+ eventChan = view event_chan os++++mkRetainerTree :: Debuggee -> [[ClosureDetails]] -> IOTree ClosureDetails 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.Map Ptr [(String, ListItem PayloadCont ConstrDesc StackCont ClosurePtr)]+ info_map :: M.Map Ptr [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)] 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 = do@@ -717,6 +762,9 @@ resetFooter :: OperationalState -> OperationalState resetFooter l = (set footerMode FooterInfo l) +footerMessage :: Text -> OperationalState -> OperationalState+footerMessage t l = (set footerMode (FooterMessage t) l)+ myAppStartEvent :: EventM Name AppState () myAppStartEvent = return () @@ -764,10 +812,10 @@ app = App { appDraw = myAppDraw , appChooseCursor = showFirstCursor- , appHandleEvent = (myAppHandleEvent eventChan)+ , appHandleEvent = myAppHandleEvent , appStartEvent = myAppStartEvent , appAttrMap = myAppAttrMap } _finalState <- customMain initialVty buildVty- (Just eventChan) app initialAppState+ (Just eventChan) app (initialAppState eventChan) return ()
src/Model.hs view
@@ -20,25 +20,37 @@ import Data.Text(Text, pack) import Brick.Forms+import Brick.BChan+import Brick (EventM) import Brick.Widgets.List import IOTree import Namespace import Common import Lib+import Control.Concurrent+import qualified Graphics.Vty as Vty +data Event+ = PollTick -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees+ | ProgressMessage Text+ | ProgressFinished+ | AsyncFinished (EventM Name OperationalState ()) -initialAppState :: AppState-initialAppState = AppState++initialAppState :: BChan Event -> AppState+initialAppState event = AppState { _majorState = Setup { _setupKind = Socket , _knownDebuggees = list Setup_KnownDebuggeesList [] 1 , _knownSnapshots = list Setup_KnownSnapshotsList [] 1- }+ },+ _appChan = event } data AppState = AppState { _majorState :: MajorState+ , _appChan :: BChan Event } mkSocketInfo :: FilePath -> IO SocketInfo@@ -92,8 +104,8 @@ , _closureType :: Maybe Text , _constructor :: Maybe Text } -data ClosureDetails pap s c = ClosureDetails- { _closure :: DebugClosure pap ConstrDesc s c+data ClosureDetails = ClosureDetails+ { _closure :: DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr , _retainerSize :: Maybe RetainerSize , _excSize :: Size , _info :: InfoInfo@@ -101,21 +113,31 @@ | InfoDetails { _info :: InfoInfo } | LabelNode { _label :: Text } -data TreeMode = Dominator- | SavedAndGCRoots- | Reverse- | Retainer (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name)- | Searched (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name)+data TreeMode = SavedAndGCRoots+ | Retainer (IOTree (ClosureDetails) Name)+ | Searched (IOTree (ClosureDetails) Name) data FooterMode = FooterInfo | FooterMessage Text | FooterInput FooterInputMode (Form Text () Name) +isFocusedFooter :: FooterMode -> Bool+isFocusedFooter (FooterInput {}) = True+isFocusedFooter _ = False+ data FooterInputMode = FAddress | FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot -data KeybindingsMode = KeybindingsShown- | KeybindingsHidden+data Command = Command { commandDescription :: Text+ , commandKey :: Vty.Event+ , dispatchCommand :: EventM Name OperationalState ()+ } +data OverlayMode = KeybindingsShown+ -- TODO: Abstract the "CommandPicker" into it's own module+ | CommandPicker (Form Text () Name) (GenericList Name Seq Command)+ | NoOverlay++ formatFooterMode :: FooterInputMode -> Text formatFooterMode FAddress = "address (0x..): " formatFooterMode FSearch = "search: "@@ -139,33 +161,19 @@ currentRoots (SearchedRoots cp) = cp data OperationalState = OperationalState- { _treeMode :: TreeMode- , _keybindingsMode :: KeybindingsMode+ { _running_task :: Maybe ThreadId+ , _treeMode :: TreeMode+ , _keybindingsMode :: OverlayMode , _footerMode :: FooterMode , _rootsFrom :: RootsOrigin- , _treeDominator :: Maybe DominatorAnalysis- -- ^ Tree corresponding to Dominator mode- , _treeSavedAndGCRoots :: IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name+ , _treeSavedAndGCRoots :: IOTree (ClosureDetails) Name -- ^ Tree corresponding to SavedAndGCRoots mode- , _treeReverse :: Maybe ReverseAnalysis- -- ^ Tree corresponding to Dominator mode- , _heapGraph :: Maybe (HeapGraph Size)- -- ^ Raw heap graph+ , _event_chan :: BChan Event } -data DominatorAnalysis =- DominatorAnalysis { _getDominatorAnalysis :: Analysis- , _getDominatorTree :: IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name- }--data ReverseAnalysis = ReverseAnalysis { _reverseIOTree :: IOTree (ClosureDetails PapHI StackHI (Maybe HeapGraphIndex)) Name- , _convertPtr :: ClosurePtr -> Maybe (DebugClosure PapHI ConstrDesc StackHI (Maybe HeapGraphIndex)) }--pauseModeTree :: (forall pap s c . IOTree (ClosureDetails pap s c) Name -> r) -> OperationalState -> r-pauseModeTree k (OperationalState mode _kb _footer _from dom roots reverseA _graph) = case mode of- Dominator -> k $ maybe (error "DOMINATOR-DavidE is not ready") _getDominatorTree dom+pauseModeTree :: (IOTree ClosureDetails Name -> r) -> OperationalState -> r+pauseModeTree k (OperationalState _ mode _kb _footer _from roots _) = case mode of SavedAndGCRoots -> k roots- Reverse -> k $ maybe (error "bop it, flip, reverse it, DavidE") _reverseIOTree reverseA Retainer r -> k r Searched r -> k r @@ -175,5 +183,4 @@ makeLenses ''ConnectedMode makeLenses ''OperationalState makeLenses ''SocketInfo-makeLenses ''DominatorAnalysis-makeLenses ''ReverseAnalysis+makeLenses ''OverlayMode
src/Namespace.hs view
@@ -12,5 +12,7 @@ | Setup_KnownSnapshotsList | Connected_Paused_ClosureDetails | Connected_Paused_ClosureTree+ | CommandPicker_List+ | Overlay | Footer deriving (Eq, Ord, Show)