diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/ghc-debug-brick.cabal b/ghc-debug-brick.cabal --- a/ghc-debug-brick.cabal +++ b/ghc-debug-brick.cabal @@ -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 diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -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) diff --git a/src/IOTree.hs b/src/IOTree.hs --- a/src/IOTree.hs +++ b/src/IOTree.hs @@ -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') diff --git a/src/Lib.hs b/src/Lib.hs --- a/src/Lib.hs +++ b/src/Lib.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 () diff --git a/src/Model.hs b/src/Model.hs --- a/src/Model.hs +++ b/src/Model.hs @@ -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 diff --git a/src/Namespace.hs b/src/Namespace.hs --- a/src/Namespace.hs +++ b/src/Namespace.hs @@ -12,5 +12,7 @@ | Setup_KnownSnapshotsList | Connected_Paused_ClosureDetails | Connected_Paused_ClosureTree + | CommandPicker_List + | Overlay | Footer deriving (Eq, Ord, Show)