diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,25 @@ # Revision history for ghc-debug-brick +## 0.8.0.0 -- 2026-03-26 + +* Decouple ListPicker completely from ghc-debug-brick +* Implement partial caching +* Introduce History Command picker +* Add History navigation capabilities +* Cache 'TreeMode' data in `ghc-debug-brick` +* Improve thread safety and cancellation in parallel trace +* Prefer Async over direct ThreadId +* Add more documentation for asynchronous API in the brick UI +* Extract ghc-debug-client async interface into separate module +* Implement asynchronous action for ArrWords in brick UI +* Fix non-exhaustive pattern warning in ArrWords action +* Compile ghc-debug-brick with -rtsopts for run-time instrumentation +* Don't crash brick UI when setting new samples +* Implement incremental results for thunk analysis +* Implement incremental string analysis action +* Refactor profile action in ghc-debug-brick +* Update dependencies for ghc 9.14 + ## 0.6.0.0 -- 2024-04-10 * Allow setting result size @@ -48,5 +68,3 @@ ## 0.1.0.0 -- 2021-06-14 * First release - - diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import GHC.Debug.Brick.UI (mainApp) + +main :: IO () +main = mainApp diff --git a/ghc-debug-brick.cabal b/ghc-debug-brick.cabal --- a/ghc-debug-brick.cabal +++ b/ghc-debug-brick.cabal @@ -1,44 +1,86 @@ cabal-version: 2.4 name: ghc-debug-brick -version: 0.7.0.0 +version: 0.8.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 license: BSD-3-Clause license-file: LICENSE -author: David Eichmann, Matthew Pickering -maintainer: matthew@well-typed.com +author: David Eichmann, Matthew Pickering, Hannes Siebenhandl +maintainer: hannes@well-typed.com build-type: Simple -extra-source-files: CHANGELOG.md +extra-doc-files: CHANGELOG.md -executable ghc-debug-brick - main-is: Main.hs - other-modules: Model - , Namespace - , IOTree - , Common - , Lib - build-depends: base >=4.16 && <5 - , brick >= 1.3 - , bytestring - , containers - , directory - , filepath - , microlens-platform - , text - , vty-crossplatform - , vty >= 6 - , time - , deepseq - , microlens - , ghc-debug-client == 0.7.0.0 - , ghc-debug-common == 0.7.0.0 - , ghc-debug-convention == 0.7.0.0 - , unordered-containers - , exceptions - , contra-tracer - , bytestring - , byteunits - hs-source-dirs: src +common shared + ghc-options: -Wall -Wincomplete-record-selectors default-language: Haskell2010 - ghc-options: -threaded -Wall "-with-rtsopts=-N -qn1" + +library + import: shared + hs-source-dirs: src + exposed-modules: + Brick.Widgets.IOTree + Brick.Widgets.ListPicker + GHC.Debug.Brick.Model + GHC.Debug.Brick.Namespace + GHC.Debug.Brick.ClosureDetails + GHC.Debug.Brick.Common + GHC.Debug.Brick.IOTree + GHC.Debug.Brick.Lib + GHC.Debug.Brick.Render + GHC.Debug.Brick.Render.Closure + GHC.Debug.Brick.Render.Command + GHC.Debug.Brick.Render.Filter + GHC.Debug.Brick.Render.Footer + GHC.Debug.Brick.Render.Header + GHC.Debug.Brick.Render.Histogram + GHC.Debug.Brick.Render.HistoryPicker + GHC.Debug.Brick.Render.Key + GHC.Debug.Brick.Render.Utils + GHC.Debug.Brick.Update + GHC.Debug.Brick.UI + GHC.Debug.Brick.UI.Async + GHC.Debug.Brick.UI.Filter + GHC.Debug.Brick.Action.ArrWords + GHC.Debug.Brick.Action.Async + GHC.Debug.Brick.Action.Profile + GHC.Debug.Brick.Action.Retainers + GHC.Debug.Brick.Action.Strings + GHC.Debug.Brick.Action.Thunk + + build-depends: + async, + base >=4.16 && <5, + brick >= 1.3, + bytestring, + containers, + directory, + filepath, + microlens-platform, + safe-exceptions, + text, + vty-crossplatform, + vty >= 6, + time, + deepseq, + microlens, + ghc-debug-client == 0.8.0.0, + ghc-debug-common == 0.8.0.0, + ghc-debug-convention == 0.8.0.0, + unordered-containers, + exceptions, + contra-tracer, + bytestring, + byteunits, + dependent-map >= 0.4.0 && < 0.5, + some >= 1.0.6 && < 1.1, + dependent-sum-template >= 0.2.0 && < 0.3, + +executable ghc-debug-brick + import: shared + hs-source-dirs: app + main-is: Main.hs + build-depends: + base, + ghc-debug-brick, + ghc-options: -threaded "-with-rtsopts=-N -qn1" -rtsopts diff --git a/src/Brick/Widgets/IOTree.hs b/src/Brick/Widgets/IOTree.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/IOTree.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Brick.Widgets.IOTree + ( IOTree + , IOTreePath + , RowState(..) + , RowCtx(..) + , ioTree + , setIOTreeRoots + , addIOTreeRoots + , getIOTreeRoots + , renderIOTree + , handleIOTreeEvent + , ioTreeSelection + , ioTreeToggle + + , ioTreeViewSelection + , unViewTree + , viewPath + , viewSelect + , viewUp + , viewUp' + , viewUnsafeDown + , viewPrevSibling + , viewNextSibling + , viewCollapse + , viewExpand + , viewIsCollapsed + ) where + +import Brick +import Control.Applicative +import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) +import qualified Data.List as List +import GHC.Stack +import qualified Graphics.Vty.Input.Events as Vty +import Graphics.Vty.Input.Events (Key(..)) +import Lens.Micro ((^.)) + + +-- A tree style list where items can be expanded and collapsed +data IOTree node name = IOTree + { _name :: name + , _roots :: [IOTreeNode node name] + , _getChildren :: (node -> IO [node]) + , _renderRow :: RowState -- is row expanded? + -> Bool -- is row selected? + -> RowCtx -- is current node last in subtree? + -> [RowCtx] -- per level of tree depth, are parent nodes last in subtree? + -> node -- the node to render + -> Widget name + -- Render some extra info as the first child of each node + , _selection :: [Int] + -- ^ Indices along the path to the current selection. Empty list means no + -- selection. + } + +data RowState = Expanded Bool | Collapsed +data RowCtx = NotLastRow | LastRow + +-- | Set a new list of nodes as the root of the tree. If any of the nodes where +-- previously expanded, they are collapsed. +-- Keeps the cursor at the same row, if there are enough elements. +setIOTreeRoots :: [node] -> IOTree node name -> IOTree node name +setIOTreeRoots newRoots iot = + iot + { _roots = nodeToTreeNode (_getChildren iot) <$> newRoots + , _selection = case _selection iot of + [] -> [] + (sel:_selectedChildren) + | length newRoots >= length (_roots iot) -> [sel] + | otherwise -> [] + } + +addIOTreeRoots :: [node] -> IOTree node name -> IOTree node name +addIOTreeRoots newRoots iot = iot { _roots = (_roots iot ++ (nodeToTreeNode (_getChildren iot) <$> newRoots)) } + +getIOTreeRoots :: IOTree node name -> [node] +getIOTreeRoots iot = map _node (_roots iot) + +type IOTreePath node = [(Int, node)] + +data IOTreeNode node name + = IOTreeNode + { _node :: node + -- ^ Current node + , _children :: Either + (IO [IOTreeNode node name]) -- Node is collapsed + [IOTreeNode node name] -- Node is expanded + } + +ioTree + :: forall node name + . name + -- ^ Name of the tree + -> [node] + -- ^ Root nodes + -> (node -> IO [node]) + -- ^ Get child nodes of a node + -> (RowState -- is row expanded or collapsed? + -> Bool -- Is row selected + -> RowCtx -- innermost context + -> [RowCtx] -- Tree depth + -> node -- the node to render + -> Widget name) + -- ^ Row renderer (should add it's own indent based on depth) + -> IOTree node name +ioTree name rootNodes getChildrenIO renderRow + = IOTree + { _name = name + , _roots = nodeToTreeNode getChildrenIO <$> rootNodes + , _getChildren = getChildrenIO + , _renderRow = renderRow + , _selection = if null rootNodes then [] else [0] + -- ^ TODO we could take the initial path but we'd have to expand through to + -- that path with IO + } + where + +nodeToTreeNode :: (node -> IO [node]) -> node -> IOTreeNode node name +nodeToTreeNode k n = IOTreeNode n (Left (fmap (nodeToTreeNode k) <$> k n)) + +renderIOTree :: (Show name, Ord name) => IOTree node name -> Widget name +renderIOTree iotree + = drawTreeElements iotree + +data TreeNodeWithRenderContext node = TreeNodeWithRenderContext + { _nodeDepth :: Int + , _nodeState :: RowState + , _nodeSelected :: Bool + , _nodeLast :: RowCtx + , _nodeParentLast :: [RowCtx] + , _nodeContent :: node + } + +renderTreeNodeWithContext :: + (RowState -> Bool -> RowCtx -> [RowCtx] -> node -> Widget name) -> + TreeNodeWithRenderContext node -> Widget name +renderTreeNodeWithContext rowRenderer ctx = + rowRenderer (_nodeState ctx) (_nodeSelected ctx) (_nodeLast ctx) (_nodeParentLast ctx) (_nodeContent ctx) + +drawTreeElements :: (Ord n, Show n) => IOTree node n -> Widget n +drawTreeElements (IOTree widgetName treeNodes _ renderRow pathTop) = + -- This function takes inspiration from 'Brick.Widget.List.drawListElements' + Widget Greedy Greedy $ do + c <- getContext + + -- Take (numPerHeight * 2) elements, or whatever is left + let + rs = flattenTree 0 [] treeNodes pathTop + es = take (numPerHeight * 2) $ drop start rs + + idx = fromMaybe 0 (List.findIndex (_nodeSelected) rs) + + start = max 0 $ idx - numPerHeight + 1 + + -- We hardcode the height of each element to be expected as 1 row. + -- Perhaps we could greedily compute the number of elements based on + -- their dynamic height for a perfect result, + -- but it currently feels like overkill. + itemHeight = 1 + + -- The number of items to show is the available height + -- divided by the item height... + initialNumPerHeight = (c^.availHeightL) `div` itemHeight + -- ... but if the available height leaves a remainder of + -- an item height then we need to ensure that we render an + -- extra item to show a partial item at the top or bottom to + -- give the expected result when an item is more than one + -- row high. (Example: 5 rows available with item height + -- of 3 yields two items: one fully rendered, the other + -- rendered with only its top 2 or bottom 2 rows visible, + -- depending on how the viewport state changes.) + numPerHeight = initialNumPerHeight + + if initialNumPerHeight * itemHeight == c^.availHeightL + then 0 + else 1 + + off = start * itemHeight + + render $ viewport widgetName Vertical $ + translateBy (Location (0, off)) $ + vBox $ (map (renderTreeNodeWithContext renderRow) es) + where + -- Compute metadata for each row we may display. + -- This is a logical representation of each row that can + -- be split and filtered later. + -- Each 'TreeNodeWithRenderContext' can be individually rendered without + -- further issue. + flattenTree _ _ [] _ = [] + flattenTree minorIx depth (IOTreeNode node' csE : ns) path = case csE of + -- Collapsed + Left _ -> row Collapsed : rowsRest + -- Expanded + Right cs -> row (Expanded (null cs)) + : flattenTree 0 (rowCtx : depth) cs (if childIsSelected then drop 1 path else []) + ++ rowsRest + where + childIsSelected = case path of + x:_ -> x == minorIx + _ -> False + selected = path == [minorIx] + rowCtx = if null ns then LastRow else NotLastRow + row state = TreeNodeWithRenderContext + { _nodeDepth = length depth + , _nodeState = state + , _nodeSelected = selected + , _nodeLast = rowCtx + , _nodeParentLast = depth + , _nodeContent = node' + } + rowsRest = flattenTree (minorIx + 1) depth ns path + +handleIOTreeEvent :: Vty.Event -> IOTree node name -> EventM name s (IOTree node name) +handleIOTreeEvent e tree + = liftIO + $ forIOTreeViewSelection tree + $ \view -> fmap viewSelect $ case e of + Vty.EvKey KRight _ -> do + (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) + Vty.EvKey KPageUp _ -> return $ List.foldl' (flip ($)) view (replicate 15 prev) + _ -> return view + where + next v = fromMaybe v (viewNextVisible v) + prev v = fromMaybe v (viewPrevVisible v) + +-- | Toggle (expanded/collapsed) at the current selection. +ioTreeToggle :: IOTree node name -> IO (IOTree node name) +ioTreeToggle t = forIOTreeViewSelection t $ \view -> + if viewIsCollapsed view + then fst <$> viewExpand view + else return (viewCollapse view) + +-- | A view (or Zipper) used to navigate the tree +data IOTreeView node name + = Root (IOTree node name) + | Node + (IOTreeNode node name -> IOTreeView node name) -- reconstruct the parent given this node + Int -- The index in the parent + (IOTreeNode node name) -- This node + +forIOTreeViewSelection + :: IOTree node name + -> (IOTreeView node name -> IO (IOTreeView node name)) + -> IO (IOTree node name) +forIOTreeViewSelection t f = unViewTree <$> f (ioTreeViewSelection t) + +ioTreeViewSelection :: IOTree node name -> IOTreeView node name +ioTreeViewSelection t = List.foldl' viewUnsafeDown (Root t) (_selection t) + +ioTreeSelection :: IOTree node name -> Maybe node +ioTreeSelection t = case ioTreeViewSelection t of + Root{} -> Nothing + Node _ _ n -> Just (_node n) + +unViewTree :: IOTreeView node name -> IOTree node name +unViewTree t = case t of + Root t' -> t' + Node mkParent _ t' -> unViewTree (mkParent t') + +-- | Current path in the tree +viewPath :: IOTreeView node name -> [Int] +viewPath tTop = reverse $ go tTop + where + go t = case t of + Root _ -> [] + Node mkParent i t' -> i : go (mkParent t') + +-- | Select the current path +viewSelect :: IOTreeView node name -> IOTreeView node name +viewSelect t = ioTreeViewSelection newTree + where + newTree = oldTree { _selection = newSelection } + oldTree = unViewTree t + newSelection = viewPath t + +-- | move up the tree +viewUp :: IOTreeView node name -> Maybe (IOTreeView node name) +viewUp t = case t of + Root{} -> Nothing + Node mkParent _ t' -> Just (mkParent t') + +-- | move up the tree, but never to the root +viewUp' :: IOTreeView node name -> Maybe (IOTreeView node name) +viewUp' t = case viewUp t of + Just Root{} -> Nothing + x -> x + +-- | Move down to a child in the tree. Index must be in range. Must be expanded. +viewUnsafeDown :: HasCallStack => IOTreeView node name -> Int -> IOTreeView node name +viewUnsafeDown view i + | viewIsCollapsed view = error "viewUnsafeDown: view must be expanded" + | otherwise = case view of + Root t -> Node (\c -> Root t{ _roots = listSet i c (_roots t) }) i (t !. i) + Node mkParent ixInParent t -> Node + (\c -> Node mkParent ixInParent (unsafeSetChild c i t)) + i + (t ! i) + +viewPrevVisible :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) +viewPrevVisible view = case viewPrevSibling view of + Nothing -> viewUp' view + Just nextSib -> Just (viewLastVisibleChild nextSib) + where + viewLastVisibleChild view' = if viewIsCollapsed view' + then view' + else let + n = case view' of + Root t -> length (_roots t) - 1 + Node _ _ t -> either (error "Impossible! view' is expanded") length (_children t) + in if n == 0 then view' else viewLastVisibleChild $ viewUnsafeDown view' (n-1) + +viewNextVisible :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) +viewNextVisible view = let + upwardNext v = case viewNextSibling v of + Nothing -> upwardNext =<< viewUp v + Just s -> Just s + in viewFirstVisibleChild view <|> upwardNext view + where + viewFirstVisibleChild view' = if viewIsCollapsed view' + then Nothing + else let + nullChildren = case view' of + Root t -> null (_roots t) + Node _ _ t -> either (error "Impossible! view' is expanded") null (_children t) + in if nullChildren then Nothing else Just (viewUnsafeDown view' 0) + +-- | Move to the previous sibling within the parent node +viewPrevSibling :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) +viewPrevSibling t = case t of + Root{} -> Nothing + Node mkParent ixInParent t' -> if ixInParent == 0 + then Nothing + else Just $ viewUnsafeDown (mkParent t') (ixInParent - 1) + +-- | Move to the next sibling within the parent node +viewNextSibling :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) +viewNextSibling t = case t of + Root{} -> Nothing + Node mkParent ixInParent t' -> let + parent = mkParent t' + nSiblings = case parent of + Root t'' -> length (_roots t'') + Node _ _ t'' -> length (either (error "Impossible! syblings must be expanded") id (_children t'')) + in if ixInParent + 1 == nSiblings + then Nothing + else Just (viewUnsafeDown parent (ixInParent + 1)) + +-- | Collapse the current node. +viewCollapse :: HasCallStack => IOTreeView node name -> IOTreeView node name +viewCollapse t = case t of + Root _ -> t -- Can't collapse the root + Node mkParent i t' -> case _children t' of + Left _ -> t + Right cs -> Node mkParent i t'{_children = Left (return cs)} + +-- | 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') + Node mkParent i t' -> case _children t' of + Left getChildren -> do + cs <- getChildren + return (Node mkParent i t'{_children=Right cs}, cs) + Right cs -> return (t, cs) + + +viewIsCollapsed :: HasCallStack => IOTreeView node name -> Bool +viewIsCollapsed t = case t of + Root{} -> False + Node _ _ t' -> case _children t' of + Left{} -> True + Right{} -> False + +(!.) :: IOTree node name -> Int -> IOTreeNode node name +t !. i = _roots t !! i + +(!) :: IOTreeNode node name -> Int -> IOTreeNode node name +t ! i = case _children t of + Right xs -> xs !! i + Left _ -> error "(!): tree node not expanded" + +unsafeSetChild :: HasCallStack => IOTreeNode node name -> Int -> IOTreeNode node name -> IOTreeNode node name +unsafeSetChild newChild i t = case _children t of + Right xs -> t { _children = Right (listSet i newChild xs) } + Left _ -> error "(!): tree node not expanded" + +listSet :: HasCallStack => Int -> a -> [a] -> [a] +listSet i a as + | i >= length as = error $ "listSet: index (" ++ show i ++ ") out of bounds [0 - " ++ show (length as) ++ ")" + | otherwise = take i as ++ [a] ++ drop (i+1) as diff --git a/src/Brick/Widgets/ListPicker.hs b/src/Brick/Widgets/ListPicker.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/ListPicker.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +module Brick.Widgets.ListPicker ( + -- * ListPicker + ListPicker(..), + -- * Lenses + listPickerInput, + listPickerElements, + listPickerAllElements, + listPickerSelect, + listPickerDescription, + listPickerRenderRow, + listPickerLabel, + listPickerHighlightAttrName, + -- * Render and Update + Update(..), + renderListPicker, + handleListPicker, +) where + +import Brick +import Brick.Forms +import Brick.Widgets.Border +import Brick.Widgets.List +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Graphics.Vty.Input as Vty +import Lens.Micro +import Lens.Micro.Platform (makeLenses) + +data ListPicker name state ev element = ListPicker + { _listPickerInput :: Form Text ev name + , _listPickerElements :: GenericList name Seq element + , _listPickerAllElements :: Seq element + , _listPickerSelect :: element -> EventM name state (Update name state ev element) + , _listPickerDescription :: element -> Text + , _listPickerRenderRow :: Int -> element -> Widget name + , _listPickerLabel :: Text + , _listPickerHighlightAttrName :: AttrName + } + +data Update name state ev element + = Changed (ListPicker name state ev element) + | Unchanged + | Exit + +makeLenses ''ListPicker + +renderListPicker :: (Ord name, Show name) => ListPicker name state ev element -> Widget name +renderListPicker picker = + hLimit vWidth $ vLimit vHeight $ + borderWithLabel (txt (_listPickerLabel picker)) $ vBox $ + [ renderForm (_listPickerInput picker) + , renderList + (\elIsSelected -> + if elIsSelected + then withHighlighting picker . renderLine + else renderLine + ) + False + (_listPickerElements picker) + ] + where + renderLine = _listPickerRenderRow picker actual_width + + vHeight = length (_listPickerAllElements picker) + 4 + vWidth = actual_width + 2 + + maximum_size_ = maximum (fmap (Text.length . (_listPickerDescription picker)) (_listPickerAllElements picker)) + -- we limit the size to 120 to avoid row overflow + maximum_size = min maximum_size_ 120 + + actual_width = + maximum_size + + 5 -- 5, maximum width of rendering a key + + 1 -- 1, at least one padding + +handleListPicker :: (Ord n) => BrickEvent n e -> ListPicker n a e element -> EventM n a (Update n a e element) +handleListPicker e picker = 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 -> fuzzyMatcher filter_string (_listPickerDescription picker cmd)) orig_cmds + cmd_list'' = cmd_list' + & listElementsL .~ new_elems + & listSelectedL .~ if Seq.null new_elems then Nothing else Just 0 + pure $ Changed $ picker + & listPickerInput .~ form' + & listPickerElements .~ cmd_list'' + else + pure $ Changed $ picker + & listPickerInput .~ form' + & listPickerElements .~ cmd_list' + + 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 _) -> do + pure Exit + VtyEvent (Vty.EvKey Vty.KEnter _) -> do + case listSelectedElement cmd_list of + Just (_, cmd) -> do + _listPickerSelect picker cmd + Nothing -> + pure Unchanged + _ -> do + form' <- handle_form + list' <- handle_list + k form' list' + where + form = _listPickerInput picker + cmd_list = _listPickerElements picker + orig_cmds = _listPickerAllElements picker + +-- | Check whether the search string occurs with sufficient likelihood in the +-- given string. +fuzzyMatcher :: Text -> Text -> Bool +fuzzyMatcher filterString haystack = + -- TODO: This should be a fuzzy search, not 'Text.isInfixOf' + Text.toLower filterString `Text.isInfixOf` Text.toLower haystack + +withHighlighting :: ListPicker name state ev element -> Widget n -> Widget n +withHighlighting picker = forceAttr (_listPickerHighlightAttrName picker) diff --git a/src/Common.hs b/src/Common.hs deleted file mode 100644 --- a/src/Common.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Common where - -import qualified Brick.Types as T -import Lens.Micro -import Namespace - -data ProfileLevel = OneLevel | TwoLevel deriving Show - -type Handler e s = - T.BrickEvent Name e - -> T.EventM Name s () - --- | liftHandler lifts a handler which only operates on its own state into --- a larger state. It won't work if the handler needs to modify something --- from a larger scope. -liftHandler - :: ASetter s s a a -- The mode to modify - -> c -- Inner state - -> (c -> a) -- How to inject the new state - -> 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) - --- Missing instance from brick -deriving instance Functor (T.BrickEvent n) diff --git a/src/GHC/Debug/Brick/Action/ArrWords.hs b/src/GHC/Debug/Brick/Action/ArrWords.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Action/ArrWords.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +module GHC.Debug.Brick.Action.ArrWords ( + arrWordsAction, + renderArrWordsHeader, + arrWordsTreeMode, + arrWordsTree, +) where + +import Brick +import Brick.Widgets.Border +import Control.Monad (forM) +import Lens.Micro.Platform +import Data.Text (pack) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Set as S + +import Brick.Widgets.IOTree (IOTree, setIOTreeRoots) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Ord as Ord +import qualified Data.Set as Set +import GHC.Debug.Brick.Action.Async +import GHC.Debug.Brick.ClosureDetails +import GHC.Debug.Brick.IOTree +import GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render.Closure +import GHC.Debug.Brick.Render.Header (renderHeaderWithSummary) +import GHC.Debug.Brick.Render.Histogram +import GHC.Debug.Brick.Render.Utils +import GHC.Debug.Retainers (SearchLimit) +import qualified GHC.Debug.Strings as GD + +arrWordsAction :: Debuggee -> EventM n OperationalState () +arrWordsAction dbg = do + outside_os <- get + let + + put + (outside_os + & resetFooter + & treeMode .~ arrWordsTreeMode (_resultSize outside_os) (arrWordsTree dbg) Map.empty + ) + + runWithAsyncSampleReporter dbg "Counting ARR_WORDS" ArrWordsSample + (arrWordsAnalysisAsync Nothing dbg) + (\ result -> do + sendEvent $ CacheSearch DoArrWordsSearch result + os <- get + put (os & resetFooter)) + +arrWordsTreeMode :: SearchLimit -> IOTree ArrWordsLine Name -> Map.Map BS.ByteString (Set.Set ClosurePtr) -> TreeMode +arrWordsTreeMode limit tree payload = + let + sorted_res = [(k, v) | (k, v) <- List.sortOn ((\(k, v) -> Ord.Down $ fromIntegral (BS.length k) * Set.size v)) (Map.toList payload)] + display_res = maybe id take limit sorted_res + top_closure = [ArrWordsCountLine k (fromIntegral (BS.length k)) (Set.size v) v | (k, v) <- display_res] + in + ArrWords (renderArrWordsHeader payload) (setIOTreeRoots top_closure tree) + +arrWordsTree :: Debuggee -> IOTree ArrWordsLine Name +arrWordsTree dbg = + let + g_children d (ArrWordsCountLine _ _ _ cs) = do + cs' <- run d $ forM (S.toList cs) $ \c -> do + c' <- GD.dereferenceClosure c + return $ ListFullClosure $ Closure c c' + children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs' + mapM (\(lbl, child) -> ArrWordsFieldLine <$> getClosureDetails d (pack lbl) child) children' + g_children d (ArrWordsFieldLine c) = map ArrWordsFieldLine <$> getChildren d c + in + mkIOTree dbg [] g_children renderArrWordsLines id + +renderArrWordsHeader :: GD.CensusByByteString -> ArrWordsLine -> Widget Name +renderArrWordsHeader census c = + renderHeaderWithSummary (renderHeaderPane c) (renderArrWordsHistogram census) + +renderArrWordsHistogram :: GD.CensusByByteString -> Widget Name +renderArrWordsHistogram census = + borderWithLabel (txt "Histogram") $ hLimit 100 $ mkSimpleArrWordsHistogram census + +mkSimpleArrWordsHistogram :: GD.CensusByByteString -> Widget Name +mkSimpleArrWordsHistogram census = + histogram 8 (concatMap (\(k, bs) -> let sz = BS.length k in replicate (length bs) (Size (fromIntegral sz))) (Map.toList census)) + +renderArrWordsLines :: ArrWordsLine -> [Widget n] +renderArrWordsLines (ArrWordsCountLine k l n _) = [strLabel (show n), vSpace, renderBytes l, vSpace, strWrap (take 100 $ show k)] +renderArrWordsLines (ArrWordsFieldLine cd) = renderInlineClosureDesc cd + +renderHeaderPane :: ArrWordsLine -> Widget Name +renderHeaderPane (ArrWordsCountLine b l n _) = vBox + [ labelled "Count" $ vLimit 1 $ str (show n) + , labelled "Size" $ vLimit 1 $ renderBytes l + , labelled "Total Size" $ vLimit 1 $ renderBytes (n * l) + , strWrap (take 100 $ show b) + ] +renderHeaderPane (ArrWordsFieldLine c) = renderClosureDetails c diff --git a/src/GHC/Debug/Brick/Action/Async.hs b/src/GHC/Debug/Brick/Action/Async.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Action/Async.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Debug.Brick.Action.Async ( + runWithAsyncSampleReporter, +) where + +import Brick.BChan +import Brick.Types +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async +import Control.Exception +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as Text +import Lens.Micro + +import GHC.Debug.Async +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.UI.Async +import GHC.Debug.Client + +-- | Run the action asynchronously sending update messages periodically +-- to the brick UI. +-- +-- After the computation @action@ has finished, a final operation @andThen@ can be executed, for example to update +-- the UI footer, or to persist the results of the heap traversal to disk. +-- +-- The update period is configurable via @'OperationalState'.'_asyncSamplingInterval'@. +-- +-- @'runWithAsyncSampleReporter' dbg desc mkEvent action andThen@ +runWithAsyncSampleReporter :: forall a n . Debuggee -> Text -> (a -> SampleEvent) -> IO (AsyncTrace a) -> (a -> EventM Name OperationalState ()) -> EventM n OperationalState () +runWithAsyncSampleReporter dbg desc mkEvent action andThen = do + outside_os <- get + let + reportSampleResult :: a -> IO () + reportSampleResult a = do + writeBChan (outside_os ^. event_chan) (NewSampleEvent $ mkEvent a) + + runAsyncAction :: IO a + runAsyncAction = do + asyncTrace <- action + + let + progressReporter = do + threadDelay (outside_os ^. asyncSamplingInterval) + asyncResult asyncTrace >>= \ case + Done a -> reportSampleResult a + Running a -> reportSampleResult a + NotStarted -> pure () + progressReporter + + mRes <- run dbg (waitForAsyncTraceResultM asyncTrace) + `race` progressReporter + case mRes of + Left finalRes -> pure finalRes + Right () -> throwIO $ ErrorCall $ Text.unpack desc <> ": progress reporter unexpectedly terminated" + + asyncAction desc runAsyncAction $ \ finalRes -> do + -- write final result to the IOTree + liftIO $ reportSampleResult finalRes + andThen finalRes diff --git a/src/GHC/Debug/Brick/Action/Profile.hs b/src/GHC/Debug/Brick/Action/Profile.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Action/Profile.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE LambdaCase #-} +module GHC.Debug.Brick.Action.Profile ( + profileAction, + profileTreeMode, + profileTree, + renderProfileHeader, +) where + +import Brick +import Brick.Widgets.IOTree +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Ord as Ord +import qualified Data.Semigroup +import qualified Data.Text as T +import Data.Traversable +import GHC.Debug.Brick.Action.Async +import GHC.Debug.Brick.ClosureDetails +import GHC.Debug.Brick.IOTree +import GHC.Debug.Brick.Lib +import qualified GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render.Closure +import GHC.Debug.Brick.Render.Header (renderHeaderWithSummary) +import GHC.Debug.Brick.Render.Utils +import GHC.Debug.Profile +import qualified GHC.Debug.Profile as GD +import qualified GHC.Debug.Profile as GDP +import GHC.Debug.Profile.Types +import GHC.Debug.Retainers (SearchLimit) +import qualified Graphics.Vty as Vty +import Lens.Micro +import qualified Numeric + +profileAction :: Debuggee -> ProfileLevel -> EventM n OperationalState () +profileAction dbg lvl = do + outside_os <- get + let + + put (outside_os + & resetFooter + & treeMode .~ profileTreeMode (_resultSize outside_os) (profileTree dbg) Map.empty + ) + + runWithAsyncSampleReporter dbg "Profile" (ProfileSample lvl) + (profileAsync dbg lvl) + (\ result -> do + -- write the final result to disk + -- liftIO $ GD.writeCensusByClosureType fp finalRes + sendEvent $ CacheSearch (DoProfileSearch lvl) result + os <- get + put (os & resetFooter) + ) + +profileTreeMode :: SearchLimit -> IOTree ProfileLine Name -> GD.CensusByClosureType -> TreeMode +profileTreeMode _limit tree census = + let + top_closure = [ProfileLine k kargs v | ((k, kargs), v) <- (List.sortOn (Ord.Down . (cssize . snd)) (Map.toList census))] + total_stats = foldMap snd (Map.toList census) + in + Profile (renderProfileHeader total_stats) (setIOTreeRoots top_closure tree) + +profileTree :: Debuggee -> IOTree ProfileLine Name +profileTree dbg = + let + g_children d (ClosureLine c) = map ClosureLine <$> getChildren d c + g_children d (ProfileLine _ _ stats) = do + let cs = getSamples (sample stats) + cs' <- run dbg $ forM cs $ \c -> do + c' <- GD.dereferenceClosure c + return $ ListFullClosure $ Closure c c' + children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs' + mapM (\(lbl, child) -> ClosureLine <$> getClosureDetails d (T.pack lbl) child) children' + in + mkIOTree dbg [] g_children renderProfileLine id + +renderProfileLine :: ProfileLine -> [Widget Name] +renderProfileLine (ClosureLine c) = renderInlineClosureDesc c +renderProfileLine (ProfileLine k kargs c) = + [ txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs kargs) + , txt " " + , showLine c + ] + where + showLine :: CensusStats -> Widget Name + showLine (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _) = + hBox + [ withFontColor totalSizeColor $ str (show s), vSpace + , withFontColor countColor $ str (show n), vSpace + , withFontColor sizeColor $ str (show mn), vSpace + , withFontColor avgSizeColor $ str (Numeric.showFFloat @Double (Just 1) (fromIntegral s / fromIntegral n) "") + ] + + withFontColor color = modifyDefAttr (flip Vty.withForeColor color) + + totalSizeColor = Vty.RGBColor 0x26 0x83 0xDE + countColor = Vty.RGBColor 0xDE 0x66 0x26 + sizeColor = Vty.RGBColor 0x26 0xDE 0xD7 + avgSizeColor = Vty.RGBColor 0xAB 0x4D 0xE0 + +renderProfileHeader :: CensusStats -> ProfileLine -> Widget Name +renderProfileHeader total_stats l = + renderHeaderWithSummary + (renderHeaderPane l) + (renderHeaderPane (ProfileLine (GDP.ProfileClosureDesc "Total") GDP.NoArgs total_stats)) + +renderHeaderPane :: ProfileLine -> Widget Name +renderHeaderPane (ClosureLine cs) = renderClosureDetails cs +renderHeaderPane (ProfileLine k args (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _)) = vBox $ + [ txtLabel "Label " <+> vSpace <+> txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs args) + ] + <> + (case k of + GDP.ProfileConstrDesc desc -> + [ txtLabel "Package " <+> vSpace <+> (txt (GDP.pkgsText desc)) + , txtLabel "Module " <+> vSpace <+> (txt (GDP.modlText desc)) + , txtLabel "Constructor" <+> vSpace <+> (txt (GDP.nameText desc)) + ] + _ -> [] + ) + <> + [ txtLabel "Count " <+> vSpace <+> str (show n) + , txtLabel "Size " <+> vSpace <+> renderBytes s + , txtLabel "Max " <+> vSpace <+> renderBytes mn + , txtLabel "Average " <+> vSpace <+> renderBytes @Double (fromIntegral s / fromIntegral n) + ] diff --git a/src/GHC/Debug/Brick/Action/Retainers.hs b/src/GHC/Debug/Brick/Action/Retainers.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Action/Retainers.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +module GHC.Debug.Brick.Action.Retainers ( + searchWithCurrentFiltersIncremental, + RetainerMap, + retainerTreeMode, + topRetainersFromRetainerMap, + retainerTree, + retainerTreeM, +) where + +import Brick.BChan +import Brick.Types +import Brick.Widgets.IOTree +import Control.Monad.IO.Class (liftIO) +import Data.IORef +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Lens.Micro +import Lens.Micro.Extras + +import GHC.Debug.Brick.ClosureDetails +import GHC.Debug.Brick.IOTree (mkIOTree) +import GHC.Debug.Brick.Lib +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render.Closure +import GHC.Debug.Brick.UI.Async +import GHC.Debug.Retainers (SearchLimit) +import GHC.Debug.Brick.UI.Filter + +searchWithCurrentFiltersIncremental :: Debuggee -> [UIFilter] -> EventM n OperationalState () +searchWithCurrentFiltersIncremental dbg uifilters = do + outside_os <- get + let mClosFilter = uiFiltersToFilter uifilters + info_map_ref <- liftIO $ newIORef Map.empty + let tree = retainerTreeM dbg (readIORef info_map_ref) + let + add_new_sample :: [ClosureDetails] -> IO () + add_new_sample new_retainer_stack_sample = do + -- We expect this retainer stack to be non-empty. + -- The first entry is the "Leaf" node in the tree, while the tail of '[ClosureDetails]' + -- is the stack of retainers of the first 'ClosureDetails'. + case List.uncons new_retainer_stack_sample of + Just (k, v) -> do + let kk = toPtr (_closure k) + modifyIORef info_map_ref (Map.insert kk (k, v)) + Nothing -> return () + + ret_add_sample cps = do + let cps' = zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..] cps + res <- mapM (completeClosureDetails dbg) cps' + -- 1. Add the sample to the IOTree + add_new_sample res + -- 2. Update the IOTree + writeBChan (view event_chan outside_os) (NewSampleEvent $ RetainerSample res) + + let searchLimit = _resultSize outside_os + + put $ outside_os + & treeMode .~ retainerTreeMode searchLimit tree [] + + asyncAction "Searching for closures" (liftIO $ retainersOfIncremental searchLimit mClosFilter Nothing dbg ret_add_sample) $ \() -> do + -- We finished the traversal, finalise the search results + result <- liftIO $ readIORef info_map_ref + sendEvent $ CacheSearch (DoRetainerSearch searchLimit uifilters) result + os <- get + put (os & resetFooter) + +retainerTreeMode :: SearchLimit -> IOTree RetainerNode Name -> [RetainerNode] -> TreeMode +retainerTreeMode _limit tree retainers = + Retainer (renderClosureDetails . retainerNodeClosure) (setIOTreeRoots retainers tree) + +topRetainersFromRetainerMap :: RetainerMap -> [RetainerNode] +topRetainersFromRetainerMap retainerMap = + fmap (RetainerStackRoot . fst) $ Map.elems retainerMap + +retainerTree :: Debuggee -> RetainerMap -> IOTree RetainerNode Name +retainerTree dbg retainerStacks = + retainerTreeM dbg (pure retainerStacks) + +retainerTreeM :: Debuggee -> IO RetainerMap -> IOTree RetainerNode Name +retainerTreeM dbg get_info_map_ref = + let + lookup_c dbg' (RetainerStackRoot dc'@(ClosureDetails dc _ _)) = do + let ptr = toPtr dc + info_map <- get_info_map_ref + let results = maybe [] snd $ Map.lookup ptr info_map + -- We are also looking up the children of the object we are retaining, + -- and displaying them prior to the retainer stack + cs <- getChildren dbg' dc' + results' <- liftIO $ mapM (\(l, c) -> getClosureDetails dbg' l (ListFullClosure c)) (withIndex results) + return $ map RetainerStackChild (cs ++ results') + lookup_c dbg' (RetainerStackRoot dc) = fmap (map RetainerStackChild) $ getChildren dbg' dc + lookup_c dbg' (RetainerStackChild dc) = fmap (map RetainerStackChild) $ getChildren dbg' dc + in + mkIOTree dbg [] lookup_c (renderInlineClosureDesc . retainerNodeClosure) id + + where + withIndex vs = zipWith (\ n v -> (T.show n, _closure v) ) [(1 :: Int) .. ] vs diff --git a/src/GHC/Debug/Brick/Action/Strings.hs b/src/GHC/Debug/Brick/Action/Strings.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Action/Strings.hs @@ -0,0 +1,129 @@ + +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +module GHC.Debug.Brick.Action.Strings ( + stringsAction, + stringTreeMode, + stringTree, + renderStringHeader, + renderStringHeaderPane, + stringTotalsFromCensus, + stringHeapBytes, + StringTotals(..) +) where + +import Brick +import Brick.Widgets.Border (borderWithLabel) +import Brick.Widgets.IOTree +import Control.Monad (forM) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Ord as Ord +import Data.Semigroup (Sum (..)) +import qualified Data.Set as Set +import Data.Text (pack) +import GHC.Debug.Brick.Action.Async +import GHC.Debug.Brick.ClosureDetails +import GHC.Debug.Brick.IOTree +import GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render.Closure +import GHC.Debug.Brick.Render.Header (renderHeaderWithSummary) +import GHC.Debug.Brick.Render.Utils +import GHC.Debug.Retainers (SearchLimit) +import qualified GHC.Debug.Strings as GS +import GHC.Generics (Generic, Generically (..)) +import Lens.Micro.Platform + +stringsAction :: Debuggee -> EventM n OperationalState () +stringsAction dbg = do + outside_os <- get + + put (outside_os + & resetFooter + & treeMode .~ stringTreeMode (_resultSize outside_os) (stringTree dbg) Map.empty + ) + + runWithAsyncSampleReporter dbg "Counting strings" StringSample + (stringsAnalysisAsync Nothing dbg) + (\ result -> do + sendEvent $ CacheSearch DoStringSearch result + os <- get + put (os & resetFooter)) + +stringTreeMode :: SearchLimit -> IOTree StringCountLine Name -> GS.CensusByStrings -> TreeMode +stringTreeMode limit tree census = + let + sorted_res = [(k, v ) | (k, v) <- (List.sortOn (Ord.Down . (Set.size . snd)) (Map.toList census))] + display_res = maybe id take limit sorted_res + top_closure = [StringCountLine k (stringHeapBytes k) (length v) v | (k, v) <- display_res] + totals = stringTotalsFromCensus census + in + Strings (renderStringHeader totals) (setIOTreeRoots top_closure tree) + +stringTree :: Debuggee -> IOTree StringCountLine Name +stringTree dbg = + let + g_children d (StringCountLine _ _ _ cs) = do + cs' <- run d $ forM (Set.toList cs) $ \c -> do + c' <- GD.dereferenceClosure c + return $ ListFullClosure $ Closure c c' + children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs' + mapM (\(lbl, child) -> StringFieldLine <$> getClosureDetails d (pack lbl) child) children' + g_children d (StringFieldLine c) = map StringFieldLine <$> getChildren d c + in + mkIOTree dbg [] g_children renderStringLines id + +renderStringHeader :: StringTotals -> StringCountLine -> Widget Name +renderStringHeader totals line = + renderHeaderWithSummary + (renderStringHeaderPane line) + (renderTotalsPane totals) + +renderStringHeaderPane :: StringCountLine -> Widget Name +renderStringHeaderPane (StringCountLine k l n _) = vBox + [ labelled "Count " $ vLimit 1 $ str (show n) + , labelled "Size " $ vLimit 1 $ renderBytes l + , labelled "Total Size" $ vLimit 1 $ renderBytes (n * l) + , strWrap (take 100 $ show k) + ] +renderStringHeaderPane (StringFieldLine c) = renderClosureDetails c + +renderTotalsPane :: StringTotals -> Widget Name +renderTotalsPane (StringTotals distinct totalCount totalSize) = + borderWithLabel (txt "Summary") $ hLimit 32 $ vBox + [ labelled "Distinct Strings" $ vLimit 1 $ str (show $ getSum distinct) + , labelled "Total Count" $ vLimit 1 $ str (show $ getSum totalCount) + , labelled "Total Size" $ vLimit 1 $ renderBytes $ getSum totalSize + ] + +data StringTotals = StringTotals + { stDistinct :: !(Sum Int) + , stTotalCount :: !(Sum Int) + , stTotalSize :: !(Sum Int) + } + deriving stock (Show, Eq, Ord, Generic) + deriving (Semigroup, Monoid) via (Generically StringTotals) + +stringTotalsFromCensus :: GS.CensusByStrings -> StringTotals +stringTotalsFromCensus = Map.foldlWithKey' go mempty + where + go acc s closures = + let count = Set.size closures + perStringBytes = stringHeapBytes s + total = count * perStringBytes + in acc <> StringTotals 1 (Sum count) (Sum total) + +stringHeapBytes :: String -> Int +stringHeapBytes s = length s * stringConsCellBytes + +stringConsCellBytes :: Int +stringConsCellBytes = 32 + +renderStringLines :: StringCountLine -> [Widget n] +renderStringLines (StringCountLine k l n _) = [strLabel (show n), vSpace, renderBytes l, vSpace, strWrap (take 100 $ show k)] +renderStringLines (StringFieldLine cd) = renderInlineClosureDesc cd diff --git a/src/GHC/Debug/Brick/Action/Thunk.hs b/src/GHC/Debug/Brick/Action/Thunk.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Action/Thunk.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +module GHC.Debug.Brick.Action.Thunk ( + thunkAnalysisActionAsync, + thunkTreeMode, + thunkTree, + ) where + +import Brick +import Brick.Widgets.IOTree (IOTree, setIOTreeRoots) +import Control.Monad (forM) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Ord as Ord +import Data.Text (pack) +import Lens.Micro.Platform + +import GHC.Debug.Brick.Action.Async +import GHC.Debug.Brick.ClosureDetails +import GHC.Debug.Brick.IOTree +import GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render.Closure +import GHC.Debug.Brick.Render.Utils +import GHC.Debug.Profile.Types +import GHC.Debug.Retainers (SearchLimit) +import qualified GHC.Debug.Thunks as GD + +thunkAnalysisActionAsync :: Debuggee -> EventM n OperationalState () +thunkAnalysisActionAsync dbg = do + outside_os <- get + + put $ outside_os + & treeMode .~ thunkTreeMode (_resultSize outside_os) (thunkTree dbg) Map.empty + + runWithAsyncSampleReporter dbg "Counting thunks" ThunkSample + (thunkAnalysisAsync dbg) + (\ result -> do + sendEvent $ CacheSearch DoThunkSearch result + os <- get + put (os & resetFooter)) + +thunkTreeMode :: SearchLimit -> IOTree ThunkLine Name -> GD.ThunkCensusBySourceLocation -> TreeMode +thunkTreeMode _limit tree census = + let + top_closures = [ ThunkLine k (cscount v) (sample v) | (k, v) <- (List.sortOn (Ord.Down . (cscount . snd)) (Map.toList census))] + in + Thunk renderHeaderPane (setIOTreeRoots top_closures tree) + +-- | Create a retainer tree which we can incrementally add retainer samples to when we receive them. +thunkTree :: Debuggee -> IOTree ThunkLine Name +thunkTree dbg = + mkIOTree dbg [] getChildrenOfThunkLine renderInline id + +getChildrenOfThunkLine :: Debuggee -> ThunkLine -> IO [ThunkLine] +getChildrenOfThunkLine dbg (ThunkLine _ _ smp) = do + cs' <- run dbg $ forM (getSamples smp) $ \c -> do + c' <- GD.dereferenceClosure c + return $ ListFullClosure $ Closure c c' + children <- traverse (traverse (fillListItem dbg)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs' + mapM (\(lbl, child) -> ThunkClosureLine <$> getClosureDetails dbg (pack lbl) child) children +getChildrenOfThunkLine dbg (ThunkClosureLine c) = map ThunkClosureLine <$> getChildren dbg c + +renderHeaderPane :: ThunkLine -> Widget Name +renderHeaderPane (ThunkLine sc c _smp) = vBox $ + maybe [txt "NoLoc"] renderSourceInformation sc + ++ [ strWrap ("Count: " ++ show (getCount c)) ] +renderHeaderPane (ThunkClosureLine cd) = renderClosureDetails cd + +renderInline :: ThunkLine -> [Widget n] +renderInline (ThunkLine msc (Count c) _smp) = + [ case msc of + Just sc -> strLabel (infoPosition sc) + Nothing -> txtLabel "NoLoc" + , txt " " + , str (show c) + ] +renderInline (ThunkClosureLine cd) = renderInlineClosureDesc cd diff --git a/src/GHC/Debug/Brick/ClosureDetails.hs b/src/GHC/Debug/Brick/ClosureDetails.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/ClosureDetails.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +module GHC.Debug.Brick.ClosureDetails where + +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import qualified Data.Text as T + +import GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Model +import qualified GHC.Debug.Types.Closures as Debug +import qualified GHC.Debug.Types.StackAnnotation as GD + +getChildren :: Debuggee -> ClosureDetails + -> IO [ClosureDetails] +getChildren _ LabelNode{} = return [] +getChildren _ CCDetails {} = return [] +getChildren _ InfoDetails {} = return [] +getChildren d (ClosureDetails c _ _) = do + children <- closureReferences d c + children' <- traverse (traverse (fillListItem d)) children + mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children' +getChildren d (CCSDetails _ _ cp) = do + references <- zip [0 :: Int ..] <$> ccsReferences d cp + mapM (\(lbl, cc) -> getClosureDetails d (pack (show lbl)) cc) references +getChildren d (StackFrameDetails _ sframe _) = do + children <- stackFrameReferences d sframe + children' <- traverse (traverse (fillListItem d)) children + mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children' + +fillListItem :: Debuggee + -> ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr + -> IO (ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr) +fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x +fillListItem d (ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd +fillListItem _ ListData = return ListData +fillListItem _ (ListCCS c1 c2) = return $ ListCCS c1 c2 +fillListItem _ (ListCC c1) = return $ ListCC c1 +fillListItem _ (ListStackFrame s) = return $ ListStackFrame s + +completeClosureDetails :: Debuggee -> (Text, DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) + -> IO ClosureDetails + +completeClosureDetails dbg (label', clos) = + getClosureDetails dbg label' . ListFullClosure =<< fillConstrDesc dbg clos + + +getClosureDetails :: Debuggee + -> Text + -> ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr + -> IO ClosureDetails +getClosureDetails debuggee' t (ListOnlyInfo info_ptr) = do + info' <- getInfoInfo debuggee' t info_ptr + return $ InfoDetails info' +getClosureDetails _ plabel (ListCCS ccs payload) = return $ CCSDetails plabel ccs payload +getClosureDetails _ plabel (ListCC cc) = return $ CCDetails plabel cc +getClosureDetails _ t ListData = return $ LabelNode t +getClosureDetails debuggee' label' (ListFullClosure c) = do + let excSize' = closureExclusiveSize c + sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c) + pretty' <- closurePretty debuggee' c + return ClosureDetails + { _closure = c + , _info = InfoInfo { + _pretty = pack pretty' + , _labelInParent = label' + , _sourceLocation = sourceLoc + , _closureType = Just (T.pack $ show c) + , _constructor = Nothing + , _profHeaderInfo = case c of + Closure{_closureSized=c1} -> Debug.hp <$> Debug.profHeader (Debug.unDCS c1) + _ -> Nothing + } + , _excSize = excSize' + } +getClosureDetails debuggee' label' (ListStackFrame c) = do + let stackFrameTypeOf = Debug.tipe . Debug.decodedTable . Debug.frame_info + tipe' = stackFrameTypeOf c + sourceLoc <- infoSourceLocation debuggee' (Debug.tableId $ Debug.frame_info c) + mPrettyClos <- case tipe' of + Debug.ANN_FRAME -> do + case Debug.values c of + [Debug.SPtr annPtr] -> do + (dbgClosure, mPayload) <- dereferenceStackAnnotation debuggee' annPtr + payload <- case mPayload of + Nothing -> pure dbgClosure + Just stackAnnoClos -> do + payloadClos <- dereferencePtr debuggee' (CP $ GD.stackAnno_payload stackAnnoClos) + fillConstrDesc debuggee' payloadClos + prettyClos <- closurePretty debuggee' payload + pure $ Just $ pack prettyClos + vals -> + -- If this is not 'SomeStackAnnotation', just display the arguments + pure $ Just $ T.unwords $ fmap (showStackValue (pack . show)) vals + _ -> pure Nothing + return $ StackFrameDetails + { _tipe = tipe' + , _frame = c + , _info = InfoInfo + { _labelInParent = label' + , _pretty = fromMaybe T.empty mPrettyClos + , _sourceLocation = sourceLoc + , _closureType = Just $ pack $ show tipe' + , _constructor = Nothing + , _profHeaderInfo = + -- This is a stack closure, there is no profHeader. + Nothing + } + } + +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 + , _profHeaderInfo = Nothing + } + +showStackValue :: (b -> Text) -> Debug.FieldValue b -> Text +showStackValue f = \ case + Debug.SPtr b -> f b + Debug.SNonPtr v -> pack $ show v diff --git a/src/GHC/Debug/Brick/Common.hs b/src/GHC/Debug/Brick/Common.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Common.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module GHC.Debug.Brick.Common where + +import qualified Brick.Types as T +import Lens.Micro +import GHC.Debug.Brick.Namespace + +data ProfileLevel = OneLevel | TwoLevel + deriving (Show, Eq, Ord, Enum, Bounded) + +type Handler e s = + T.BrickEvent Name e + -> T.EventM Name s () + +-- | liftHandler lifts a handler which only operates on its own state into +-- a larger state. It won't work if the handler needs to modify something +-- from a larger scope. +liftHandler + :: ASetter s s a a -- The mode to modify + -> c -- Inner state + -> (c -> a) -- How to inject the new state + -> 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) + +-- Missing instance from brick +deriving instance Functor (T.BrickEvent n) diff --git a/src/GHC/Debug/Brick/IOTree.hs b/src/GHC/Debug/Brick/IOTree.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/IOTree.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +module GHC.Debug.Brick.IOTree where + +import Brick +import qualified Data.List as List +import qualified Graphics.Vty as Vty +import Lens.Micro.Platform +import Data.Text (Text) +import qualified Data.Text as T + +import Brick.Widgets.IOTree +import GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Namespace +import GHC.Debug.Brick.Render.Utils + + +mkIOTree :: Debuggee + -> [a] + -> (Debuggee -> a -> IO [a]) + -> (a -> [Widget Name]) + -> ([a] -> [a]) + -> IOTree a Name +mkIOTree debuggee' cs getChildrenGen renderNode sort = ioTree Connected_Paused_ClosureTree + (sort cs) + (\c -> sort <$> getChildrenGen debuggee' c + ) + -- rendering the row + (\state selected ctx depth closureDesc -> + let + body = + (if selected then visible . highlighted else id) $ + hBox $ + renderNode closureDesc + in + vdecorate state ctx depth body -- body (T.concat context) + ) + +-- | Draw the tree structure around the row item. Inspired by the +-- 'border' functions in brick. +-- +vdecorate :: RowState -> RowCtx -> [RowCtx] -> Widget n -> Widget n +vdecorate state ctx depth body = + Widget Fixed Fixed $ do + c <- getContext + + let decorationWidth = 2 * length depth + 4 + + bodyResult <- + render $ + hLimit (c ^. availWidthL - decorationWidth) $ + vLimit (c ^. availHeightL) $ + body + + let leftTxt = + T.concat $ + map + (\ x -> case x of + LastRow -> " " + NotLastRow -> "│ " + ) + (List.reverse depth) + leftPart = withAttr treeAttr (vreplicate leftTxt) + middleTxt1 = + case ctx of + LastRow -> "└─" + NotLastRow -> "├─" + middleTxt1' = + case ctx of + LastRow -> " " + NotLastRow -> "│ " + middleTxt2 = + case state of + Expanded True -> "● " -- "⋅" + Expanded False -> "┐ " + Collapsed -> "┄ " + middleTxt2' = + case state of + Expanded True -> " " + Expanded False -> "│ " + Collapsed -> " " + middlePart = + withAttr treeAttr $ + (txt middleTxt1 <=> vreplicate middleTxt1') + <+> (txt middleTxt2 <=> vreplicate middleTxt2') + rightPart = Widget Fixed Fixed $ return bodyResult + total = leftPart <+> middlePart <+> rightPart + + render $ + hLimit (bodyResult ^. imageL . to Vty.imageWidth + decorationWidth) $ + vLimit (bodyResult ^. imageL . to Vty.imageHeight) $ + total + +vreplicate :: Text -> Widget n +vreplicate t = + Widget Fixed Greedy $ do + c <- getContext + return $ emptyResult & imageL .~ Vty.vertCat (replicate (c ^. availHeightL) (Vty.text' (c ^. attrL) t)) diff --git a/src/GHC/Debug/Brick/Lib.hs b/src/GHC/Debug/Brick/Lib.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Lib.hs @@ -0,0 +1,619 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE NamedFieldPuns #-} +module GHC.Debug.Brick.Lib + ( -- * Running/Connecting to a debuggee + Debuggee + , debuggeeRun + , debuggeeConnect + , snapshotConnect + , debuggeeClose + , withDebuggeeRun + , withDebuggeeConnect + , socketDirectory + , snapshotDirectory + + -- * Pause/Resume + , GD.pause + , GD.resume + , GD.pausePoll + , GD.withPause + + -- * Querying the paused debuggee + , rootClosures + , savedClosures + , version + , profilingMode + , GD.Version + + -- * Closures + , Closure + , ClosureType + , DebugClosure(..) + , closureShowAddress + , closureExclusiveSize + , closureSourceLocation + , SourceInformation(..) + , closureReferences + , closurePretty + , fillConstrDesc + , InfoTablePtr + , ListItem(..) + , closureInfoPtr + , infoSourceLocation + , GD.dereferenceClosure + , run + , ccsReferences + -- * Stack frames + , stackFrameReferences + , dereferenceStackAnnotation + + -- * Common initialisation + , initialTraversal + , HG.HeapGraph(..) + -- * Dominator Tree + , Size(..) + , RetainerSize(..) + -- * Reverse Edge Map + , HG.mkReverseGraph + , reverseClosureReferences + , lookupHeapGraph + + -- * Profiling + , profile + , profileAsync + , thunkAnalysis + , thunkAnalysisAsync + , GD.CensusStats(..) + + -- * Retainers + , retainersOf + , retainersOfIncremental + , findAllChildrenOfCCs + + -- * Counting + , arrWordsAnalysis + , arrWordsAnalysisAsync + , stringsAnalysis + , stringsAnalysisAsync + + -- * Snapshot + , snapshot + + -- * Types + , Ptr(..) + , CCSPtr + , CCPayload + , GenCCSPayload + , toPtr + , dereferencePtr + , ConstrDesc(..) + , ConstrDescCont + , GenPapPayload(..) + , StackCont + , PayloadCont + , SrtCont + , ClosurePtr + , readClosurePtr + , CCPtr + , readCCPtr + , HG.StackHI + , HG.PapHI + , HG.SrtHI + , HG.HeapGraphIndex + , ProfHeaderWord + -- + , EraRange(..) + , GD.profHeaderInEraRange + , tipe + , ClosureFilter(..) + , GD.profHeaderReferencesCCS + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (mapMaybe) +import qualified GHC.Debug.Async as GD +import qualified GHC.Debug.Types as GD +import GHC.Debug.Types hiding (Closure, DebugClosure) +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.CostCentres as GD +import GHC.Debug.Retainers (EraRange(..), ClosureFilter(..)) +import qualified GHC.Debug.Snapshot as GD +import qualified GHC.Debug.Strings as GD +import qualified GHC.Debug.Types.StackAnnotation as GD +import qualified GHC.Debug.Types.Version as GD +import qualified GHC.Debug.Types.Graph as HG +import qualified GHC.Debug.Thunks as GD +import Control.Monad +import System.FilePath +import System.Directory +import Control.Tracer +import Data.Bitraversable +import Data.Text (Text, pack) +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import qualified Data.Set as Set +import Data.Int +import GHC.Debug.Client.Monad (DebugM) +import GHC.Debug.Brick.Common + +initialTraversal :: Debuggee -> IO (HG.HeapGraph Size) +initialTraversal e = run e $ do + -- Calculate the dominator tree with retainer sizes + -- TODO perhaps this conversion to a graph can be done in GHC.Debug.Types.Graph + _ <- GD.precacheBlocks + rs <- request RequestRoots + let derefFuncM cPtr = do + c <- GD.dereferenceClosure cPtr + hextraverse pure 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) + return hg + +-- This function is very very very slow, it needs to be optimised. +{- +runAnalysis :: Debuggee -> HG.HeapGraph Size -> IO Analysis +runAnalysis e hg = run e $ do + let drs :: [G.Tree (ClosurePtr, (Size, RetainerSize))] + drs = fmap (\ent -> (HG.hgeClosurePtr ent, HG.hgeData ent)) <$> HG.retainerSize hg + + !hmGraph = HM.unions (map snd $ foldTree buildGraphNode <$> (HG.retainerSize hg)) + + buildGraphNode :: HG.HeapGraphEntry v + -> [(ClosurePtr, HM.HashMap ClosurePtr (v, [ClosurePtr]))] + -> (ClosurePtr, HM.HashMap ClosurePtr (v, [ClosurePtr])) + buildGraphNode hge subtrees = + (cptr, HM.insert cptr v (HM.unions submaps)) + where + cptr = HG.hgeClosurePtr hge + v = (HG.hgeData hge, children) + (children, submaps) = unzip subtrees + + cPtrToData + = fromMaybe ((-12221, RetainerSize (-12221)), []) + -- ^ TODO I would expect the mapping to be complete unless out analysis misses some closures. + . flip HM.lookup hmGraph + + return $ Analysis + [drPtr | G.Node (drPtr, _) _ <- drs] + ((\(_,x) -> x) . cPtrToData) + ((\(x,_) -> x) . cPtrToData) + -} + +-- | Bracketed version of @debuggeeRun@. Runs a debuggee, connects to it, runs +-- the action, kills the process, then closes the debuggee. +withDebuggeeRun :: FilePath -- ^ path to executable to run as the debuggee + -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) + -> (Debuggee -> IO a) + -> IO a +withDebuggeeRun exeName socketName action = GD.withDebuggeeRun exeName socketName action + +-- | Bracketed version of @debuggeeConnect@. Connects to a debuggee, runs the +-- action, then closes the debuggee. +withDebuggeeConnect :: FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) + -> (Debuggee -> IO a) + -> IO a +withDebuggeeConnect socketName action = GD.withDebuggeeConnect socketName action + +-- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done. +debuggeeRun :: FilePath -- ^ path to executable to run as the debuggee + -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) + -> IO Debuggee +debuggeeRun exeName socketName = GD.debuggeeRun exeName socketName + +-- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done. +debuggeeConnect :: (Text -> IO ()) + -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) + -> IO Debuggee +debuggeeConnect toChan socketName = GD.debuggeeConnectWithTracer (contramap pack $ Tracer (emit toChan)) socketName + + +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 () +debuggeeClose = GD.debuggeeClose + +-- | Request the debuggee's root pointers. +rootClosures :: Debuggee -> IO [Closure] +rootClosures e = run e $ do + closurePtrs <- request RequestRoots + closures <- GD.dereferenceClosures closurePtrs + return [ Closure closurePtr' closure + | closurePtr' <- closurePtrs + | closure <- closures + ] + +version :: Debuggee -> IO GD.Version +version e = run e GD.version + +profilingMode :: GD.Version -> Maybe GD.ProfilingMode +profilingMode = GD.v_profiling + +-- | A client can save objects by calling a special RTS method +-- This function returns the closures it saved. +savedClosures :: Debuggee -> IO [Closure] +savedClosures e = run e $ do + closurePtrs <- request RequestSavedObjects + closures <- GD.dereferenceClosures closurePtrs + return $ zipWith Closure + closurePtrs + closures + +profile :: Debuggee -> ProfileLevel -> FilePath -> IO GD.CensusByClosureType +profile dbg lvl fp = do + c <- run dbg $ do + roots <- GD.gcRoots + case lvl of + OneLevel -> GD.censusClosureType roots + TwoLevel -> GD.census2LevelClosureType roots + GD.writeCensusByClosureType fp c + return c + +profileAsync :: Debuggee -> ProfileLevel -> IO (GD.AsyncTrace GD.CensusByClosureType) +profileAsync dbg lvl = do + c <- run dbg $ do + roots <- GD.gcRoots + case lvl of + OneLevel -> GD.censusClosureTypeAsync roots + TwoLevel -> GD.census2LevelClosureTypeAsync roots + return c + +thunkAnalysis :: Debuggee -> IO (Map.Map (Maybe SourceInformation) GD.CensusStats) +thunkAnalysis dbg = do + c <- run dbg $ do + roots <- GD.gcRoots + GD.thunkAnalysis roots + return c + +thunkAnalysisAsync :: Debuggee -> IO (GD.AsyncTrace GD.ThunkCensusBySourceLocation) +thunkAnalysisAsync dbg = do + c <- run dbg $ do + roots <- GD.gcRoots + GD.thunkAnalysisAsync roots + return c + +snapshot :: Debuggee -> FilePath -> IO () +snapshot dbg fp = do + dir <- snapshotDirectory + createDirectoryIfMissing True dir + GD.run dbg $ GD.snapshot (dir fp) + +retainersOf :: Maybe Int -> DebugM ClosureFilter -> Maybe [ClosurePtr] -> Debuggee -> IO [[Closure]] +retainersOf n retainer_filter mroots dbg = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + closfilter <- retainer_filter + stack <- GD.findRetainers n closfilter roots + traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack + +retainersOfIncremental :: Maybe Int -> DebugM ClosureFilter -> Maybe [ClosurePtr] -> Debuggee + -> ([Closure] -> IO ()) -> IO () +retainersOfIncremental n retainer_filter mroots dbg add_new_sample = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + closfilter <- retainer_filter + GD.findRetainersIncremental n closfilter roots (\cs -> do + cs' <- zipWith Closure cs <$> (GD.dereferenceClosures cs) + GD.unsafeLiftIO $ add_new_sample cs') + + +findAllChildrenOfCCs :: Int64 -> Debuggee -> IO (Set.Set CCSPtr) +findAllChildrenOfCCs ccId dbg = do + run dbg $ do + GD.findAllChildrenOfCC ((ccId ==) . ccID) + +arrWordsAnalysis :: Maybe [ClosurePtr] -> Debuggee -> IO (Map.Map BS.ByteString (Set.Set ClosurePtr)) +arrWordsAnalysis mroots dbg = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + arr_words <- GD.arrWordsAnalysis roots + return arr_words + +arrWordsAnalysisAsync :: Maybe [ClosurePtr] -> Debuggee -> IO (GD.AsyncTrace GD.CensusByByteString) +arrWordsAnalysisAsync mroots dbg = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + arr_words <- GD.arrWordsAnalysisAsync roots + return arr_words + +stringsAnalysis :: Maybe [ClosurePtr] -> Debuggee -> IO GD.CensusByStrings +stringsAnalysis mroots dbg = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + arr_words <- GD.stringAnalysis roots + return arr_words + +stringsAnalysisAsync :: Maybe [ClosurePtr] -> Debuggee -> IO (GD.AsyncTrace GD.CensusByStrings) +stringsAnalysisAsync mroots dbg = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + GD.stringAnalysisAsync roots + +-- -- | Request the description for an info table. +-- -- The `InfoTablePtr` is just used for the equality +-- requestConstrDesc :: Debuggee -> PayloadWithKey InfoTablePtr ClosurePtr -> IO ConstrDesc +-- requestConstrDesc (Debuggee e _) = run e $ request RequestConstrDesc + +-- -- | Lookup source information of an info table +-- requestSourceInfo :: Debuggee -> InfoTablePtr -> IO [String] +-- requestSourceInfo (Debuggee e _) = run e $ request RequestSourceInfo + +-- -- | Request a set of closures. +-- requestClosures :: Debuggee -> [ClosurePtr] -> IO [RawClosure] +-- requestClosures (Debuggee e _) = run e $ request RequestClosures + +type Closure = DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr + +data ListItem ccs srt a b c d + = ListData + | ListOnlyInfo InfoTablePtr + | ListCCS CCSPtr (GenCCSPayload CCSPtr CCPayload) + | ListCC CCPayload + | ListFullClosure (DebugClosure ccs srt a b c d) + | ListStackFrame (DebugStackFrame (GenSrtPayload ClosurePtr) ClosurePtr) + +data DebugClosure ccs srt p cd s c + = Closure + { _closurePtr :: ClosurePtr + , _closureSized :: DebugClosureWithSize ccs srt p cd s c + } + | Stack + { _stackPtr :: StackCont + , _stackStack :: GD.GenStackFrames srt c + } + deriving Show + +toPtr :: DebugClosure ccs 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 CCSPtr 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 Hextraversable DebugClosure where + hextraverse p f g h i j (Closure cp c) = Closure cp <$> hextraverse p f g h i j c + hextraverse _ p _ _ _ h (Stack sp s) = Stack sp <$> bitraverse p h s + +closureShowAddress :: DebugClosure ccs srt p cd s c -> String +closureShowAddress (Closure c _) = show c +closureShowAddress (Stack (StackCont s _) _) = show s + +-- | Get the exclusive size (not including any referenced closures) of a closure. +closureExclusiveSize :: DebugClosure ccs srt p cd s c -> Size +closureExclusiveSize (Stack{}) = Size (-1) +closureExclusiveSize (Closure _ c) = (GD.dcSize c) + +closureSourceLocation :: Debuggee -> DebugClosure ccs 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 ccs srt 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) + +stackFrameReferences :: + Debuggee -> + DebugStackFrame (GenSrtPayload ClosurePtr) ClosurePtr -> + IO [(String, ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)] +stackFrameReferences e frame = do + let action (GD.SPtr ptr) = ("Pointer", ListFullClosure . Closure ptr <$> GD.dereferenceClosure ptr) + action (GD.SNonPtr dat) = ("Data:" ++ show dat, return ListData) + run e $ do + info <- GD.getSourceInfo (tableId (frame_info frame)) + case info of + Just (SourceInformation {infoName = "stg_orig_thunk_info_frame_info"}) -> + let [GD.SNonPtr dat] = GD.values frame + in return [("Blackhole arising from thunk:", (ListOnlyInfo (InfoTablePtr dat)))] + _ -> traverse sequenceA $ + + ("Info: " ++ show (tableId (frame_info frame)), return (ListOnlyInfo (tableId (frame_info frame)))) : + [ ("SRT: ", ListFullClosure . Closure srt <$> GD.dereferenceClosure srt) | Just srt <- [getSrt (frame_srt frame)]] + ++ map action (GD.values frame) + +-- | Get the directly referenced closures (with a label) of a closure. +closureReferences :: + Debuggee -> + DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> + IO [(String, ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)] +closureReferences e (Stack _ stack) = run e $ do + stack' <- bitraverse GD.dereferenceSRT pure stack + return $ + [ ("Frame " ++ show frameIx, ListStackFrame frame) + | (frameIx, frame) <- zip [(0::Int)..] (GD.getFrames stack') + ] + {- + return $ zipWith (\(lbl,ptr) c -> (lbl, Closure ptr c)) + lblAndPtrs + closures + -} +closureReferences e (Closure _ closure) = run e $ do + closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure + let wrapClosure cPtr = do + refClosure' <- GD.dereferenceClosure cPtr + return $ ListFullClosure $ Closure cPtr refClosure' + wrapStack sPtr = do + refStack' <- GD.dereferenceStack sPtr + return $ ListFullClosure $ Stack sPtr refStack' + wrapCCS ccsPtr = do + refCCS <- do + GD.dereferenceCCS ccsPtr >>= \ccs -> + bitraverse pure GD.dereferenceCC ccs + return $ ListCCS ccsPtr refCCS + closureReferencesAndLabels wrapClosure + wrapStack + wrapCCS + (unDCS closure') + +ccsReferences :: Debuggee -> GenCCSPayload CCSPtr CCPayload -> IO [ListItem ccs srt a b c d] +ccsReferences e initialCcs = run e $ (ListCC (ccsCc initialCcs) :) <$> go initialCcs + where + go ccs = do + case ccsPrevStack ccs of + Nothing -> pure [ListCC (ccsCc ccs)] + Just ccsPtr -> do + child <- GD.dereferenceCCS ccsPtr + child' <- bitraverse pure GD.dereferenceCC child + children <- go child' + return (ListCC (ccsCc child') : children) + +reverseClosureReferences :: HG.HeapGraph Size + -> HG.ReverseGraph + -> Debuggee + -> DebugClosure CCSPtr HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex) + -> IO [(String, DebugClosure + CCSPtr + HG.SrtHI + HG.PapHI + ConstrDesc HG.StackHI + (Maybe HG.HeapGraphIndex))] +reverseClosureReferences hg rm _ c = + case c of + Stack {} -> error "Nope - Stack" + Closure cp _ -> case (HG.reverseEdges cp rm) of + Nothing -> return [] + Just es -> + let revs = mapMaybe (flip HG.lookupHeapGraph hg) es + in return [(show n, Closure (HG.hgeClosurePtr hge) + (DCS (HG.hgeData hge) (HG.hgeClosure hge) )) + | (n, hge) <- zip [0 :: Int ..] revs] + +lookupHeapGraph :: HG.HeapGraph Size -> ClosurePtr -> Maybe (DebugClosure CCSPtr 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 ccs srt pap ConstrDescCont s c + -> IO (DebugClosure ccs srt pap ConstrDesc s c) +fillConstrDesc e closure = do + run e $ GD.hextraverse pure pure pure GD.dereferenceConDesc pure pure closure + +-- | Pretty print a closure +closurePretty :: Debuggee -> DebugClosure ccs InfoTablePtr PayloadCont ConstrDesc s ClosurePtr -> IO String +closurePretty _ (Stack _ frames) = return $ (show (length frames) ++ " frames") +closurePretty dbg (Closure _ closure) = run dbg $ do + closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure + return $ HG.ppClosure + (\_ refPtr -> show refPtr) + 0 + (unDCS closure') + +-- Internal Stuff +-- + +closureReferencesAndLabels :: Monad m => (pointer -> m a) -> (stack -> m a) -> (ccs -> m a) -> GD.DebugClosure ccs (GenSrtPayload pointer) PapPayload string stack pointer -> m [(String, a)] +closureReferencesAndLabels pointer stack fccs closure = sequence . map sequence $ [("CCS", fccs (ccs ph)) | Just ph <- pure (profHeader closure)] ++ case closure of + TSOClosure {..} -> + [ ("Thread label", pointer lbl) | Just lbl <- pure threadLabel ] ++ + [ ("Stack", pointer tsoStack) + , ("Link", pointer _link) + , ("Global Link", pointer global_link) + , ("TRec", pointer trec) + , ("Blocked Exceptions", pointer blocked_exceptions) + , ("Blocking Queue", pointer bq) + ] + StackClosure{..} -> [("Frames", stack frames )] + WeakClosure {..} -> [ ("Key", pointer key) + , ("Value", pointer value) + , ("C Finalizers", pointer cfinalizers) + , ("Finalizer", pointer finalizer) + ] ++ + [ ("Link", pointer link) + | Just link <- [mlink] -- TODO do we want to show NULL pointers some how? + ] + TVarClosure {..} -> [("val", pointer current_value)] + MutPrimClosure {..} -> withArgLables ptrArgs + PrimClosure{..} -> withArgLables ptrArgs + ConstrClosure {..} -> withFieldLables ptrArgs + ThunkClosure {..} -> [("SRT", pointer cp) | Just cp <- [getSrt srt]] + ++ withArgLables ptrArgs + SelectorClosure {..} -> [("Selectee", pointer selectee)] + IndClosure {..} -> [("Indirectee", pointer indirectee)] + BlackholeClosure {..} -> [("Indirectee", pointer indirectee)] + APClosure {..} -> ("Function", pointer fun) : [] -- TODO withBitmapLables ap_payload + PAPClosure {..} -> ("Function", pointer fun) : [] -- TODO: withBitmapLables pap_payload + APStackClosure {..} -> ("Function", pointer fun) : ("Frames", stack payload) : [] + BCOClosure {..} -> [ ("Instructions", pointer instrs) + , ("Literals", pointer literals) + , ("Byte Code Objects", pointer bcoptrs) + ] + ArrWordsClosure {} -> [] + MutArrClosure {..} -> withIxLables mccPayload + SmallMutArrClosure {..} -> withIxLables mccPayload + MutVarClosure {..} -> [("Value", pointer var)] + MVarClosure {..} -> [ ("Queue Head", pointer queueHead) + , ("Queue Tail", pointer queueTail) + , ("Value", pointer value) + ] + FunClosure {..} -> + [ ("SRT", pointer cp) | Just cp <- [getSrt srt]] + ++ withArgLables ptrArgs + BlockingQueueClosure {..} -> [ ("Link", pointer link) + , ("Black Hole", pointer blackHole) + , ("Owner", pointer owner) + , ("Queue", pointer queue) + ] + TRecChunkClosure{} -> [] --TODO + CompactNFDataClosure {} -> [] --TODO + OtherClosure {..} -> ("",) . pointer <$> hvalues + UnsupportedClosure {} -> [] + where + withIxLables elements = [("[" <> show i <> "]" , pointer x) | (i, x) <- zip [(0::Int)..] elements] + withArgLables ptrArgs = [("Argument " <> show i, pointer x) | (i, x) <- zip [(0::Int)..] ptrArgs] + withFieldLables ptrArgs = [("Field " <> show i , pointer x) | (i, x) <- zip [(0::Int)..] ptrArgs] +-- withBitmapLables pap = [("Argument " <> show i , Left x) | (i, SPtr x) <- zip [(0::Int)..] (getValues pap)] + +-- + +dereferenceStackAnnotation :: + Debuggee -> + ClosurePtr -> + IO ( DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr + , Maybe (GD.StackAnnotation ConstrDesc ClosurePtr ClosurePtr ClosurePtr) + ) +dereferenceStackAnnotation dbg clos = do + stackClos' <- dereferencePtr dbg (CP clos) + stackClos <- fillConstrDesc dbg stackClos' + withPayload <- case stackClos of + Closure{_closureSized} -> case GD.unDCS _closureSized of + GD.ConstrClosure{ptrArgs = [typEv, disEv, payload], constrDesc} -> + if GD.isSomeStackAnnotationConstrDesc constrDesc + then pure $ Just $ GD.StackAnnotation + { stackAnno_constr = constrDesc + , stackAnno_typeableEv = typEv + , stackAnno_displayStackAnnoEv = disEv + , stackAnno_payload = payload + } + else pure Nothing + _ -> pure Nothing + _ -> pure Nothing + pure (stackClos, withPayload) diff --git a/src/GHC/Debug/Brick/Model.hs b/src/GHC/Debug/Brick/Model.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Model.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Debug.Brick.Model + ( module GHC.Debug.Brick.Model + , module GHC.Debug.Brick.Namespace + , module GHC.Debug.Brick.Common + ) where + +import Brick (EventM, Widget) +import qualified Brick +import Brick.BChan +import Brick.Forms +import Brick.Widgets.IOTree +import Brick.Widgets.List +import Control.Concurrent.Async (Async) +import qualified Control.Exception as Exc +import Control.Monad.IO.Class (liftIO) +import Data.ByteString.Lazy (ByteString) +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.GADT.Compare +import Data.GADT.Compare.TH +import Data.Map.Strict (Map) +import Data.Sequence as Seq +import Data.Set (Set) +import Data.Text (Text, pack) +import qualified Data.Text as T +import Data.Time +import GHC.Debug.Brick.Common +import GHC.Debug.Brick.Lib +import GHC.Debug.Brick.Namespace +import qualified Graphics.Vty as Vty +import Lens.Micro.Platform +import System.Directory +import System.FilePath +import Text.Read + +import Brick.Widgets.ListPicker +import GHC.Debug.Brick.UI.Filter (UIFilter) +import qualified GHC.Debug.Profile as GD +import qualified GHC.Debug.Profile.Types as GD +import qualified GHC.Debug.Retainers as GD +import qualified GHC.Debug.Strings as GD +import qualified GHC.Debug.Thunks as GD +import qualified GHC.Debug.Types as GD +import qualified GHC.Debug.Types.Version as GD + +data Event + = PollTick -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees + | ProgressMessage Text + | ProgressFinished Text NominalDiffTime + | AsyncAborted Exc.SomeException + | AsyncFinished (EventM Name OperationalState ()) + | NewSampleEvent SampleEvent + -- ^ A sample event is a partial result of a heap traversal. + | NavigatorEvent NavigatorEvent + -- ^ Events that navigate the history. + | DoSearch SomeSearchCmd + -- ^ Search which doesn't push a new "page" onto the history. + -- Primarily used for changing the view, for navigation. + | DoSearchWithHistoryPush SomeSearchCmd + -- ^ Perform a heap traversal search that pushes a new value + -- onto the history. The history can be navigated via 'NavigatorEvent'. + | forall a . CacheSearch (SearchCmd a) a + -- ^ A final message that is sent when the result of a search query + -- is finalised. Partial results are not expected here. + | forall a . CachePartialSearch (SearchCmd a) a + -- ^ Partial result that we can still use + +-- | Wraps a 'SearchCmd' and hides the type variable. +data SomeSearchCmd = forall a . SomeSearchCmd (SearchCmd a) + +-- | Messages that switch the view to a new 'TreeMode'. +-- These Messages and their respective result can be cached. +data SearchCmd a where + -- | Find the garbage collector roots + DoGcRootsSearch :: SearchCmd [ClosureDetails] + -- | Perform a retainer search. + -- We record the search limit in this constructor, because the result is obsolete + -- when the search limit changes. + -- This is strictly speaking only correct for when the search limit is increased, + -- but at the moment we consider it too much work to behave correctly when the + -- search limit is decreased. + DoRetainerSearch :: GD.SearchLimit -> [UIFilter] -> SearchCmd RetainerMap + DoProfileSearch :: ProfileLevel -> SearchCmd GD.CensusByClosureType + DoStringSearch :: SearchCmd GD.CensusByStrings + DoArrWordsSearch :: SearchCmd GD.CensusByByteString + DoThunkSearch :: SearchCmd GD.ThunkCensusBySourceLocation + +data SampleEvent + = GcRootsSample [ClosureDetails] + | RetainerSample [ClosureDetails] + -- ^ A new retainer sample is available, and we need to update the retainer tree. + | ProfileSample ProfileLevel GD.CensusByClosureType + | StringSample GD.CensusByStrings + | ArrWordsSample GD.CensusByByteString + | ThunkSample GD.ThunkCensusBySourceLocation + +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 +mkSocketInfo fp = SocketInfo fp <$> getModificationTime fp + +socketName :: SocketInfo -> Text +socketName = pack . takeFileName . _socketLocation + +renderSocketTime :: SocketInfo -> Text +renderSocketTime = pack . formatTime defaultTimeLocale "%c" . _socketCreated + +data SocketInfo = SocketInfo + { _socketLocation :: FilePath -- ^ FilePath to socket, absolute path + , _socketCreated :: UTCTime -- ^ Time of socket creation + } deriving Eq + +instance Ord SocketInfo where + compare (SocketInfo s1 t1) (SocketInfo s2 t2) = + -- 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 + { _setupKind :: SetupKind + , _knownDebuggees :: GenericList Name Seq SocketInfo + , _knownSnapshots :: GenericList Name Seq SnapshotInfo + } + + -- | Connected to a debuggee + | Connected + { _debuggeeSocket :: SocketInfo + , _debuggee :: Debuggee + , _mode :: ConnectedMode + } + +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 + , _profHeaderInfo :: !(Maybe ProfHeaderWord) + } deriving Show + +data ClosureDetails = ClosureDetails + { _closure :: DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr + , _excSize :: Size + , _info :: InfoInfo + } + | InfoDetails { _info :: InfoInfo } + | CCSDetails Text CCSPtr (GenCCSPayload CCSPtr CCPayload) + | CCDetails Text CCPayload + | StackFrameDetails + { _tipe :: ClosureType + , _frame :: GD.DebugStackFrame (GD.GenSrtPayload ClosurePtr) ClosurePtr + , _info :: InfoInfo + } + | LabelNode { _label :: Text } deriving Show + +data RetainerNode = RetainerStackRoot ClosureDetails -- ^ At the root, display the retainer stack as well + | RetainerStackChild ClosureDetails -- ^ Not at the root, just display normal closure details + +retainerNodeClosure :: RetainerNode -> ClosureDetails +retainerNodeClosure (RetainerStackRoot dc) = dc +retainerNodeClosure (RetainerStackChild dc) = dc + +data TreeMode = GcRoots (ClosureDetails -> Widget Name) (IOTree ClosureDetails Name) + -- ^ Tree corresponding to SavedAndGCRoots mode + | Retainer (RetainerNode -> Widget Name) (IOTree RetainerNode Name) + | Profile (ProfileLine -> Widget Name) (IOTree ProfileLine Name) + | Strings (StringCountLine -> Widget Name) (IOTree StringCountLine Name) + | ArrWords (ArrWordsLine -> Widget Name) (IOTree ArrWordsLine Name) + | Thunk (ThunkLine -> Widget Name) (IOTree ThunkLine Name) + +data ThunkLine = + ThunkLine (Maybe SourceInformation) GD.Count GD.Sample + | ThunkClosureLine ClosureDetails + +treeLength :: TreeMode -> Int +treeLength (GcRoots _ tree) = Prelude.length $ getIOTreeRoots tree +treeLength (Retainer _ tree) = Prelude.length $ getIOTreeRoots tree +treeLength (Profile _ tree) = Prelude.length $ getIOTreeRoots tree +treeLength (Strings _ tree) = Prelude.length $ getIOTreeRoots tree +treeLength (ArrWords _ tree) = Prelude.length $ getIOTreeRoots tree +treeLength (Thunk _ tree) = Prelude.length $ getIOTreeRoots tree + +-- TODO: This should not be defined here +type RetainerMap = Map Ptr (ClosureDetails, [ClosureDetails]) + +-- TODO: should maybe not be defined here but rather in `Action.Profile`? +data ProfileLine + = ProfileLine GD.ProfileKey GD.ProfileKeyArgs CensusStats + | ClosureLine ClosureDetails + +-- TODO: should maybe not be defined here but rather in `Action.ArrWords`? +data ArrWordsLine = ArrWordsCountLine ByteString Int Int (Set ClosurePtr) | ArrWordsFieldLine ClosureDetails + +arrWordLineClosureDetails :: ArrWordsLine -> Maybe ClosureDetails +arrWordLineClosureDetails ArrWordsCountLine {} = Nothing +arrWordLineClosureDetails (ArrWordsFieldLine cd) = Just cd + +data StringCountLine = StringCountLine String Int Int (Set ClosurePtr) | StringFieldLine ClosureDetails + +stringLineClosureDetails :: StringCountLine -> Maybe ClosureDetails +stringLineClosureDetails StringCountLine {} = Nothing +stringLineClosureDetails (StringFieldLine cd) = Just cd + +data FooterMode = FooterInfo + | FooterMessage Text + | FooterInput FooterInputMode (Form Text () Name) + +isFocusedFooter :: FooterMode -> Bool +isFocusedFooter (FooterInput {}) = True +isFocusedFooter _ = False + +data FooterInputMode = FClosureAddress {runNow :: Bool, invert :: Bool} + | FInfoTableAddress {runNow :: Bool, invert :: Bool} + | FConstructorName {runNow :: Bool, invert :: Bool} + | FClosureName {runNow :: Bool, invert :: Bool} + | FArrWordsSize + | FFilterEras {runNow :: Bool, invert :: Bool} + | FFilterClosureType {invert :: Bool} + | FFilterClosureSize {invert :: Bool} + | FFilterCcId {runNow :: Bool, invert :: Bool} + | FSnapshot + | FDumpArrWords + | FSetResultSize + | FSaveTree + deriving Show + +-- | Profiling requirement for a command +data ProfilingReq + = ReqSomeProfiling + | ReqErasProfiling + | NoReq + +data Command = Command { commandDescription :: Text + , commandKey :: Maybe Vty.Event + , dispatchCommand :: EventM Name OperationalState () + , commandRequiresProfMode :: ProfilingReq + -- ^ The command requires that the debuggee is in a specific + -- profiling mode. + -- For example, we can only filter by eras if the program + -- has era profiling enabled. + } + +mkCommand :: Text -> Vty.Event -> EventM Name OperationalState () -> Command +mkCommand desc ev dispatch = Command desc (Just ev) dispatch NoReq + +mkCommand' :: Text -> EventM Name OperationalState () -> Command +mkCommand' desc dispatch = Command desc Nothing dispatch NoReq + +mkFilterCmd :: Text -> Vty.Event -> EventM Name OperationalState () -> ProfilingReq -> Command +mkFilterCmd desc ev dispatch profMode = Command desc (Just ev) dispatch profMode + +mkFilterCmd' :: Text -> EventM Name OperationalState () -> ProfilingReq -> Command +mkFilterCmd' desc dispatch profMode = Command desc Nothing dispatch profMode + +isCmdEnabled :: GD.Version -> Command -> Bool +isCmdEnabled debuggeeVersion cmd = case commandRequiresProfMode cmd of + NoReq -> True + ReqErasProfiling -> + Just GD.EraProfiling == GD.v_profiling debuggeeVersion + ReqSomeProfiling -> + GD.isProfiledRTS debuggeeVersion + +isCmdDisabled :: GD.Version -> Command -> Bool +isCmdDisabled v cmd = not $ isCmdEnabled v cmd + +data OverlayMode + = KeybindingsShown + | CommandPicker (ListPicker Name OperationalState Event Command) + | HistoryPicker (ListPicker Name OperationalState Event HistoryCommand) + | NoOverlay + +invertInput :: FooterInputMode -> FooterInputMode +invertInput x@FClosureAddress{invert} = x{invert = not invert} +invertInput x@FInfoTableAddress{invert} = x{invert = not invert} +invertInput x@FConstructorName{invert} = x{invert = not invert} +invertInput x@FClosureName{invert} = x{invert = not invert} +invertInput x@FFilterEras{invert} = x{invert = not invert} +invertInput x@FFilterClosureSize{invert} = x{invert = not invert} +invertInput x@FFilterClosureType{invert} = x{invert = not invert} +invertInput x@FFilterCcId{invert} = x{invert = not invert} +invertInput x = x + +formatFooterMode :: FooterInputMode -> Text +formatFooterMode FClosureAddress{invert} = (if invert then "!" else "") <> "address (0x..): " +formatFooterMode FInfoTableAddress{invert} = (if invert then "!" else "") <> "info table pointer (0x..): " +formatFooterMode FConstructorName{invert} = (if invert then "!" else "") <> "constructor name: " +formatFooterMode FClosureName{invert} = (if invert then "!" else "") <> "closure name: " +formatFooterMode FFilterEras{invert} = (if invert then "!" else "") <> "era range (/-): " +formatFooterMode FFilterClosureSize{invert} = (if invert then "!" else "") <> "closure size (bytes): " +formatFooterMode FFilterClosureType{invert} = (if invert then "!" else "") <> "closure type: " +formatFooterMode FFilterCcId{invert} = (if invert then "!" else "") <> "CC Id: " +formatFooterMode FArrWordsSize = "size (bytes)>= " +formatFooterMode FDumpArrWords = "dump payload to file: " +formatFooterMode FSetResultSize = "search result limit (0 for infinity): " +formatFooterMode FSnapshot = "snapshot name: " +formatFooterMode (FSaveTree {}) = "filename: " + +data ConnectedMode + -- | Debuggee is running + = RunningMode + -- | Debuggee is paused and we're exploring the heap + | PausedMode { _pausedMode :: OperationalState } + +data RootsOrigin = DefaultRoots [(Text, Ptr)] + | SearchedRoots [(Text, Ptr)] + + +currentRoots :: RootsOrigin -> [(Text, Ptr)] +currentRoots (DefaultRoots cp) = cp +currentRoots (SearchedRoots cp) = cp + +data OperationalState = OperationalState + { _running_task :: Maybe (Async ()) + , _last_run_time :: Maybe (Text, NominalDiffTime) + , _treeMode :: TreeMode + , _keybindingsMode :: OverlayMode + , _footerMode :: FooterMode + , _rootsFrom :: RootsOrigin + , _viewCache :: RequestCache SearchCmd + , _navigator :: HistoryNavigator SomeSearchCmd + , _event_chan :: BChan Event + , _resultSize :: Maybe Int + , _filters :: [UIFilter] + , _asyncSamplingInterval :: !Int + -- ^ Update period of asynchronous heap traversals in microseconds + , _version :: GD.Version + } + +clearFilters :: OperationalState -> OperationalState +clearFilters os = os { _filters = [] } + +setFilters :: [UIFilter] -> OperationalState -> OperationalState +setFilters fs os = os {_filters = fs} + +addFilters :: [UIFilter] -> OperationalState -> OperationalState +addFilters fs os = os {_filters = fs ++ _filters os} + +parseEraRange :: Text -> Maybe EraRange +parseEraRange range = case T.splitOn "-" range of + [nstr] -> case readMaybe (T.unpack nstr) of + Just n -> Just $ EraRange n n + Nothing -> Nothing + [start,end] -> case (T.unpack start, T.unpack end) of + ("", "") -> Just $ EraRange 0 maxBound + ("", readMaybe -> Just e) -> Just $ EraRange 0 e + (readMaybe -> Just s, "") -> Just $ EraRange s maxBound + (readMaybe -> Just s, readMaybe -> Just e) -> Just $ EraRange s e + _ -> Nothing + _ -> Nothing + + +osSize :: OperationalState -> Int +osSize os = treeLength (_treeMode os) + +pauseModeTree :: (forall a . (a -> Widget Name) -> IOTree a Name -> r) -> OperationalState -> r +pauseModeTree k os = case _treeMode os of + GcRoots render r -> k render r + Retainer render r -> k render r + Profile render r -> k render r + Strings render r -> k render r + ArrWords render r -> k render r + Thunk render r -> k render r + +sendEvent :: Event -> EventM n OperationalState () +sendEvent ev = do + os <- Brick.get + liftIO $ writeBChan (_event_chan os) ev + +-- ---------------------------------------------------------------------------- +-- Command History Picker +-- ---------------------------------------------------------------------------- + +data HistoryCommand = HistoryCommand + { _historyItem :: SomeSearchCmd + } + +historyCommandDispatch :: HistoryCommand -> EventM Name OperationalState () +historyCommandDispatch (HistoryCommand searchCmd) = + sendEvent $ DoSearch searchCmd + +-- ---------------------------------------------------------------------------- +-- Request Cache Layer +-- ---------------------------------------------------------------------------- + +data CacheResult a + = Partial a + | Complete a + +cacheValue :: CacheResult a -> a +cacheValue = \ case + Partial a -> a + Complete a -> a + +data RequestCache f = RequestCache + { _requestCache :: DMap f CacheResult + } + +lookupCache :: (GCompare f) => f a -> RequestCache f -> Maybe (CacheResult a) +lookupCache key (RequestCache cache) = + DMap.lookup key cache + +insertCache :: (GCompare f) => f a -> CacheResult a -> RequestCache f -> RequestCache f +insertCache key value (RequestCache cache) = + RequestCache (DMap.insertWith insertIfNotComplete key value cache) + where + -- only insert the new value if the old value isn't already complete + insertIfNotComplete new old = case old of + Complete _ -> old + Partial _ -> new + +emptyCache :: RequestCache f +emptyCache = RequestCache + { _requestCache = DMap.empty + } + +-- ---------------------------------------------------------------------------- +-- History Navigation +-- ---------------------------------------------------------------------------- + +data NavigatorEvent + = GoOneBackwards + | GoOneForwards + deriving (Show, Eq, Ord) + +data HistoryNavigator a = HistoryNavigator + { _history :: [a] + , _current :: a + , _future :: [a] + } + +navBackwards :: HistoryNavigator a -> (Maybe a, HistoryNavigator a) +navBackwards orig@(HistoryNavigator history cur future) = + case history of + [] -> (Nothing, orig) + (h:hs) -> (Just h, HistoryNavigator hs h (cur:future)) + +navForward :: HistoryNavigator a -> (Maybe a, HistoryNavigator a) +navForward orig@(HistoryNavigator history cur future) = + case future of + [] -> (Nothing, orig) + (f:fs) -> (Just f, HistoryNavigator (cur:history) f fs) + +navPush :: a -> HistoryNavigator a -> HistoryNavigator a +navPush value orig = + HistoryNavigator + { _history = _current orig : _history orig + , _current = value + , _future = [] + } + +newHistoryNavigator :: a -> HistoryNavigator a +newHistoryNavigator value = HistoryNavigator + { _history = [] + , _current = value + , _future = [] + } + +navList :: HistoryNavigator a -> [a] +navList nav = Prelude.reverse (_future nav) <> [_current nav] <> _history nav + +-- | Get a list of the current history stack with the index pointing +-- to the '_current' element. +navListWithIndex :: HistoryNavigator a -> (Int, [a]) +navListWithIndex nav = (Prelude.length (_future nav), navList nav) + +-- ---------------------------------------------------------------------------- +-- TH derivations +-- ---------------------------------------------------------------------------- + +makeLenses ''AppState +makeLenses ''MajorState +makeLenses ''ClosureDetails +makeLenses ''ConnectedMode +makeLenses ''OperationalState +makeLenses ''RequestCache +makeLenses ''HistoryNavigator +makeLenses ''SocketInfo +makeLenses ''OverlayMode + +deriveGEq ''SearchCmd +deriveGCompare ''SearchCmd + +resetFooter :: OperationalState -> OperationalState +resetFooter l = (set footerMode FooterInfo l) + +footerMessage :: Text -> OperationalState -> OperationalState +footerMessage t l = (set footerMode (FooterMessage t) l) + +-- ---------------------------------------------------------------------------- +-- Cache Layer +-- ---------------------------------------------------------------------------- + +cachedOrRun :: Bool -> SearchCmd a -> (a -> EventM n OperationalState ()) -> EventM n OperationalState () -> EventM n OperationalState () +cachedOrRun fullSearch query ifFound notFound = do + lookupCacheForCmd query >>= \ case + Nothing -> + notFound + Just cachedValue + | fullSearch -> + case cachedValue of + Complete value -> + ifFound value + Partial _ -> + notFound + | otherwise -> + ifFound (cacheValue cachedValue) + +lookupCacheForCmd :: SearchCmd a -> EventM n OperationalState (Maybe (CacheResult a)) +lookupCacheForCmd query = do + os <- Brick.get + pure $ lookupCache query (os ^. viewCache) + +cacheCompleteResult :: SearchCmd a -> a -> EventM n OperationalState () +cacheCompleteResult key value = do + os <- Brick.get + Brick.put (os & + viewCache %~ insertCache key (Complete value) + ) + +cachePartialResult :: SearchCmd a -> a -> EventM n OperationalState () +cachePartialResult key value = do + os <- Brick.get + Brick.put (os & + viewCache %~ insertCache key (Partial value) + ) diff --git a/src/GHC/Debug/Brick/Namespace.hs b/src/GHC/Debug/Brick/Namespace.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Namespace.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHC.Debug.Brick.Namespace where + +data Name + = Setup_KnownDebuggeesList + | Setup_KnownSnapshotsList + | Connected_Paused_ClosureDetails + | Connected_Paused_ClosureTree + | CommandPicker_List + | HistoryPicker_List + | FilterPicker_List + | HistoryFilterPicker_List + | Overlay + | Footer + deriving (Eq, Ord, Show) diff --git a/src/GHC/Debug/Brick/Render.hs b/src/GHC/Debug/Brick/Render.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GADTs #-} + +module GHC.Debug.Brick.Render where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center (centerLayer, hCenter) +import Brick.Widgets.List +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq +import Data.Text (Text, pack) +import qualified Data.Text as T +import Data.Time.Format +import qualified Graphics.Vty as Vty +import Graphics.Vty.Input.Events (Key (..)) +import Lens.Micro.Platform + +import Brick.Widgets.IOTree +import GHC.Debug.Brick.Model as Model +import GHC.Debug.Brick.Render.Footer +import GHC.Debug.Brick.Render.Utils +import GHC.Debug.Brick.Update +import qualified Brick.Widgets.ListPicker as ListPicker +import GHC.Debug.Brick.Render.Command (renderCommandDesc) +import GHC.Debug.Brick.Render.Filter (renderUIFilter) + +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 + [ hBox + [ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):" + ] + , renderList + (\elIsSelected socketPath -> (if elIsSelected then highlighted else id) $ hBox + [ txt (socketName socketPath) + , txt " - " + , txt (renderSocketTime socketPath) + ] + ) + True + vals + , vLimit 1 $ withAttr menuAttr $ hBox [txt $ "(ESC): exit | (TAB): toggle " <> other_herald <> " view", fill ' '] + ] + +mainBorder :: Text -> Widget a -> Widget a +mainBorder title w = -- borderWithLabel (txt title) . padAll 1 + vLimit 1 (withAttr menuAttr $ hCenter $ fill ' ' <+> txt title <+> fill ' ') <=> w + +myAppDraw :: AppState -> [Widget Name] +myAppDraw (AppState majorState' _) = + case majorState' of + + Setup setupKind' dbgs snaps -> + case setupKind' of + Socket -> [drawSetup "process" "snapshots" dbgs] + Snapshot -> [drawSetup "snapshot" "processes" snaps] + + + Connected socket _debuggee mode' -> case mode' of + + RunningMode -> [mainBorder ("ghc-debug - Running - " <> socketName socket) $ vBox + [ txtWrap "There is nothing you can do until the process is paused by pressing (p) ..." + , fill ' ' + , withAttr menuAttr $ vLimit 1 $ hBox [txt "(p): Pause | (ESC): Exit", fill ' '] + ]] + + PausedMode os -> let + last_task_string = + case os ^. last_run_time of + Nothing -> "" + Just (d,t) -> " - " <> d <> " (" <> T.pack (formatTime defaultTimeLocale "%2Es" t) <> "s)" + + in kbOverlay (os ^. keybindingsMode) + $ [mainBorder ("ghc-debug - Paused - " <> socketName socket <> last_task_string) $ vBox + [ -- Current closure details + joinBorders $ (borderWithLabel (txt "Closure Details") $ + (vLimit 9 $ + pauseModeTree (\r io -> maybe emptyWidget r (ioTreeSelection io)) os + <=> fill ' ')) + <+> (filterWindow $ os ^. filters) + , -- Tree + joinBorders $ borderWithLabel + (txt $ case os ^. treeMode of + GcRoots {} -> "Root Closures" + Retainer {} -> "Retainers" + Profile {} -> "Profile" + Strings {} -> "Strings" + ArrWords {} -> "ArrWords" + Thunk {} -> "Thunks" + ) + (pauseModeTree (\_ -> renderIOTree) os) + , footer (osSize os) (_resultSize os) (os ^. footerMode) + ]] + + where + + kbOverlay :: OverlayMode -> [Widget Name] -> [Widget Name] + kbOverlay KeybindingsShown ws = centerLayer kbWindow : ws + kbOverlay (CommandPicker picker) ws = centerLayer (withAttr menuAttr $ ListPicker.renderListPicker picker) : ws + kbOverlay (HistoryPicker picker) ws = centerLayer (withAttr menuAttr $ ListPicker.renderListPicker picker) : ws + kbOverlay NoOverlay ws = ws + + filterWindow [] = emptyWidget + filterWindow xs = borderWithLabel (txt "Filters") $ hLimit 50 $ vBox $ map renderUIFilter xs + + kbWindow :: Widget Name + kbWindow = + withAttr menuAttr $ + borderWithLabel (txt "Keybindings") $ vBox $ + map (renderCommandDesc actual_width) all_keys + + all_keys = + [ ("Parent", Just (Vty.EvKey KLeft [])) + , ("Child", Just (Vty.EvKey KRight [])) + , ("Command Picker", Just (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl])) + , ("Invert Filter", Just invertFilterEvent)] + ++ [(commandDescription cmd, commandKey cmd) | cmd <- F.toList commandList ] + ++ [ ("Exit", Just (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 diff --git a/src/GHC/Debug/Brick/Render/Closure.hs b/src/GHC/Debug/Brick/Render/Closure.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Closure.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +module GHC.Debug.Brick.Render.Closure where + +import Brick +import qualified Graphics.Vty as Vty +import Data.Text (Text, pack) +import qualified Data.Text as T + +import qualified GHC.Debug.Types.Ptr as GD +import qualified GHC.Debug.Types.Closures as GD + +import qualified GHC.Debug.Types.Closures as Debug +import GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render.Utils + +era_colors :: [Vty.Color] +era_colors = [Vty.Color240 n | n <- [17..230]] + +prettyCCS :: GenCCSPayload CCSPtr CCPayload -> Text +prettyCCS Debug.CCSPayload{ccsCc = cc} = prettyCC cc + +prettyCC :: CCPayload -> Text +prettyCC Debug.CCPayload{..} = + T.pack ccLabel <> " " <> T.pack ccMod <> " " <> T.pack ccLoc + +prettyInfoTablePtr :: InfoTablePtr -> Text +prettyInfoTablePtr (GD.InfoTablePtr addr) = T.pack $ GD.prettyAddr addr + +renderSourceInformation :: SourceInformation -> [Widget Name] +renderSourceInformation (SourceInformation name cty ty label' modu loc) = + [ labelled "Name" $ vLimit 1 (str name) + , labelled "Closure type" $ vLimit 1 (str (show cty)) + , labelled "Type" $ vLimit 3 (str ty) + , labelled "Label" $ vLimit 1 (str label') + , labelled "Module" $ vLimit 1 (str modu) + , labelled "Location" $ vLimit 1 (str loc) + ] + +renderInlineSourceInformation :: SourceInformation -> Widget n +renderInlineSourceInformation (SourceInformation _name _cty _ty label' modu loc) = + str label' <+> vSpace <+> str modu <+> txt ":" <+> str loc + +renderClosureDetails :: ClosureDetails -> Widget Name +renderClosureDetails (cd@(ClosureDetails {})) = + vLimit 8 $ + -- viewport Connected_Paused_ClosureDetails Both $ + vBox $ + renderInfoInfo (_info cd) + ++ + [ hBox + [ txtLabel "Exclusive Size" <+> vSpace <+> renderBytes (GD.getSize $ _excSize cd) + ] + ] +renderClosureDetails ((LabelNode n)) = txt n +renderClosureDetails ((InfoDetails info')) = vLimit 8 $ vBox $ renderInfoInfo info' +renderClosureDetails (CCSDetails _ _ptr (Debug.CCSPayload{..})) = vLimit 8 $ vBox $ + [ labelled "ID" $ vLimit 1 (str $ show ccsID) + ] ++ renderCCPayload ccsCc +renderClosureDetails (CCDetails _ c) = vLimit 8 $ vBox $ renderCCPayload c +renderClosureDetails (StackFrameDetails _ _ info') = vLimit 8 $ vBox $ concat + [ [ labelled "Label" $ vLimit 1 $ txtLabel (_labelInParent info') + ] + , renderInfoInfo info' + ] + +renderCCPayload :: CCPayload -> [Widget Name] +renderCCPayload Debug.CCPayload{..} = + [ labelled "Label" $ vLimit 1 (str ccLabel) + , labelled "CC ID" $ vLimit 1 (str $ show ccID) + , labelled "Module" $ vLimit 1 (str ccMod) + , labelled "Location" $ vLimit 1 (str ccLoc) + , labelled "Allocation" $ vLimit 1 (str $ show ccMemAlloc) + , labelled "Time Ticks" $ vLimit 1 (str $ show ccTimeTicks) + , labelled "Is CAF" $ vLimit 1 (str $ show ccIsCaf) + ] + + +renderInfoInfo :: InfoInfo -> [Widget Name] +renderInfoInfo info' = + maybe [] renderSourceInformation (_sourceLocation info') + ++ profHeaderInfo + -- TODO these aren't actually implemented yet + -- , txt $ "Type " + -- <> fromMaybe "" (_closureType =<< cd) + -- , txt $ "Constructor " + -- <> fromMaybe "" (_constructor =<< cd) + where + profHeaderInfo = case _profHeaderInfo info' of + Just x -> + let plabel = case x of + Debug.RetainerHeader{} -> "Retainer info" + Debug.LDVWord{} -> "LDV info" + Debug.EraWord{} -> "Era" + Debug.OtherHeader{} -> "Other" + in [labelled plabel $ vLimit 1 (txt $ renderProfHeaderInline x)] + Nothing -> [] + + renderProfHeaderInline :: ProfHeaderWord -> Text + renderProfHeaderInline pinfo = + case pinfo of + Debug.RetainerHeader {} -> pack (show pinfo) -- This should never be visible + Debug.LDVWord {state, creationTime, lastUseTime} -> + (if state then "✓" else "✘") <> " created: " <> pack (show creationTime) <> (if state then " last used: " <> pack (show lastUseTime) else "") + Debug.EraWord era -> pack (show era) + Debug.OtherHeader other -> "Not supported: " <> pack (show other) + +renderInlineClosureDesc :: ClosureDetails -> [Widget n] +renderInlineClosureDesc (LabelNode t) = [txtLabel t] +renderInlineClosureDesc (InfoDetails info') = + [txtLabel (_labelInParent info'), vSpace, txt (_pretty info')] +renderInlineClosureDesc (CCSDetails clabel _cptr ccspayload) = + [ txtLabel clabel, vSpace, txt (prettyCCS ccspayload)] +renderInlineClosureDesc (CCDetails clabel cc) = + [ txtLabel clabel, vSpace, txt (prettyCC cc)] +renderInlineClosureDesc (StackFrameDetails frameTipe f info') = concat $ + [ [ txtLabel (_labelInParent info') + , vSpace, txt $ T.pack $ show frameTipe + , vSpace, txt $ prettyInfoTablePtr $ GD.tableId $ GD.frame_info f + ] + , if T.null (_pretty info') + then [] + else [ vSpace, txt (_pretty info') ] + , case _sourceLocation info' of + Nothing -> [] + Just sourceInfo -> [ vSpace, renderInlineSourceInformation sourceInfo ] + ] +renderInlineClosureDesc closureDesc@(ClosureDetails{}) = + [ txtLabel (_labelInParent (_info closureDesc)) + , colorBar + , txt $ pack (closureShowAddress (_closure closureDesc)) + , vSpace + , txtWrap $ _pretty (_info closureDesc) + ] + where + colorBar = + case colorId of + Just {} -> padLeftRight 1 (colorEra (txt " ")) + Nothing -> vSpace + + colorId = _profHeaderInfo $ _info closureDesc + colorEra = case colorId of + Just (Debug.EraWord i) -> modifyDefAttr (flip Vty.withBackColor (era_colors !! (1 + (fromIntegral $ abs i) `mod` (length era_colors - 1)))) + Just (Debug.LDVWord {state}) -> case state of + -- Used + True -> modifyDefAttr (flip Vty.withBackColor Vty.green) + -- Unused + False -> id + _ -> id diff --git a/src/GHC/Debug/Brick/Render/Command.hs b/src/GHC/Debug/Brick/Render/Command.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Command.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module GHC.Debug.Brick.Render.Command where + +import Brick.Types +import Brick.Widgets.Core +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Debug.Brick.Lib (Version) +import GHC.Debug.Brick.Model (Command (..), isCmdDisabled) +import GHC.Debug.Brick.Namespace +import GHC.Debug.Brick.Render.Key (renderKey) +import GHC.Debug.Brick.Render.Utils (disabledMenuItem) +import qualified Graphics.Vty.Input as Vty + +renderCommand :: Version -> Int -> Command -> Widget Name +renderCommand debuggeeVersion actual_width cmd = + mayDisableMenuItem $ + renderCommandDesc actual_width (commandDescription cmd, commandKey cmd) + where + mayDisableMenuItem + | isCmdDisabled debuggeeVersion cmd = disabledMenuItem + | otherwise = id + +renderCommandDesc :: Int -> (Text, Maybe Vty.Event) -> Widget Name +renderCommandDesc actual_width (desc, k) = txt (desc <> Text.replicate padding " " <> key) + where + key = maybe mempty renderKey k + padding = (actual_width - Text.length desc - Text.length key) diff --git a/src/GHC/Debug/Brick/Render/Filter.hs b/src/GHC/Debug/Brick/Render/Filter.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Filter.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module GHC.Debug.Brick.Render.Filter where + +import Brick.Types +import Brick.Widgets.Core +import Data.Bool +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Debug.Brick.Lib (EraRange (..), getSize) +import GHC.Debug.Brick.Namespace +import GHC.Debug.Brick.Render.Utils (labelled, showBytes) +import GHC.Debug.Brick.UI.Filter + +renderUIFilter :: UIFilter -> Widget Name +renderUIFilter (UIAddressFilter invert x) = labelled (bool "" "!" invert <> "Closure address") (txt (Text.show x)) +renderUIFilter (UIInfoAddressFilter invert x) = labelled (bool "" "!" invert <> "Info table address") (txt (Text.show x)) +renderUIFilter (UIConstructorFilter invert x) = labelled (bool "" "!" invert <> "Constructor name") (txt $ Text.pack x) +renderUIFilter (UIInfoNameFilter invert x) = labelled (bool "" "!" invert <> "Constructor name (exact)") (txt $ Text.pack x) +renderUIFilter (UIEraFilter invert x) = labelled (bool "" "!" invert <> "Era range") (txt (showEraRange x)) +renderUIFilter (UISizeFilter invert x) = labelled (bool "" "!" invert <> "Size (lower bound)") (txt (Text.show $ getSize x)) +renderUIFilter (UIClosureTypeFilter invert x) = labelled (bool "" "!" invert <> "Closure type") (txt (Text.show x)) +renderUIFilter (UICcId invert x) = labelled (bool "" "!" invert <> "CC Id") (txt (Text.show x)) + +showEraRange :: EraRange -> Text +showEraRange (EraRange s e) + | s == e = Text.show s + | otherwise = "[" <> Text.show s <> "," <> go e + where + go n + | n == maxBound = "∞)" + | otherwise = Text.show n <> "]" + +renderShortUIDescription :: UIFilter -> Text +renderShortUIDescription uifilter = + case uifilter of + UIAddressFilter invert x -> bool "" "!" invert <> "ClosureAddr=" <> Text.show x + UIInfoAddressFilter invert x -> bool "" "!" invert <> "InfoTableAddr=" <> Text.show x + UIConstructorFilter invert x -> bool "" "!" invert <> "Constr=" <> Text.pack x + UIInfoNameFilter invert x -> bool "" "!" invert <> "ConstrAddr=" <> Text.pack x + UIEraFilter invert x -> bool "" "!" invert <> "Era=" <> showEraRange x + UISizeFilter invert x -> bool "" "!" invert <> ">" <> showBytes (getSize x) + UIClosureTypeFilter invert x -> bool "" "!" invert <> "ClosureType=" <> Text.show x + UICcId invert x -> bool "" "!" invert <> "CC Id=" <> Text.show x diff --git a/src/GHC/Debug/Brick/Render/Footer.hs b/src/GHC/Debug/Brick/Render/Footer.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Footer.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.Debug.Brick.Render.Footer where + +import Brick +import Brick.Forms +import Data.Text (Text) + + +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render.Utils + +footer :: Int -> Maybe Int -> FooterMode -> Widget Name +footer n m fmode = vLimit 1 $ + case fmode of + FooterMessage t -> withAttr menuAttr $ hBox [txt t, fill ' '] + FooterInfo -> withAttr menuAttr $ hBox $ [padRight Brick.Max $ txt "(↑↓): select item | (→): expand | (←): collapse | (^p): command picker | (^g): invert filter | (?): full keybindings"] + ++ [padLeft (Pad 1) $ str $ + (show n <> " items/" <> maybe "∞" show m <> " max")] + FooterInput _im form -> renderForm form + +footerInput :: FooterInputMode -> FooterMode +footerInput im = + FooterInput im (footerInputForm im) + +footerInputForm :: FooterInputMode -> Form Text e Name +footerInputForm im = + newForm [(\w -> txtLabel (formatFooterMode im) <+> forceAttr inputAttr w) @@= editTextField id Footer (Just 1)] "" diff --git a/src/GHC/Debug/Brick/Render/Header.hs b/src/GHC/Debug/Brick/Render/Header.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Header.hs @@ -0,0 +1,10 @@ +module GHC.Debug.Brick.Render.Header ( + renderHeaderWithSummary +) where + +import Brick.Types (Widget) +import Brick.Widgets.Core + +renderHeaderWithSummary :: Widget n -> Widget n -> Widget n +renderHeaderWithSummary header statsPanel = + joinBorders $ header <+> padRight (Pad 1) (padLeft Max statsPanel) diff --git a/src/GHC/Debug/Brick/Render/Histogram.hs b/src/GHC/Debug/Brick/Render/Histogram.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Histogram.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +module GHC.Debug.Brick.Render.Histogram where + +import Brick +import qualified GHC.Debug.Types as GD +import GHC.Debug.Types +import GHC.Debug.Brick.Model +import qualified Data.List as List +import GHC.Debug.Brick.Render.Utils + +-- | Render a histogram with n lines which displays the number of elements in each bucket, +-- and how much they contribute to the total size. +histogram :: Int -> [GD.Size] -> Widget Name +histogram boxes m = + vBox $ map displayLine (bin 0 (map calcPercentage (List.sort m ))) + where + Size maxSize = case m of + [] -> Size 0 -- we dont divide by maxSize if m is empty + _ -> maximum m + + calcPercentage (Size tot) = + (tot, (fromIntegral tot / fromIntegral maxSize) * 100 :: Double) + + displayLine (l, h, n, tot) = + str (show l) <+> txt "%-" <+> str (show h) <+> str "%: " <+> str (show n) <+> str " " <+> renderBytes tot + + step = fromIntegral (ceiling @Double @Int (100 / fromIntegral boxes)) + + bin _ [] = [] + bin k xs = case now of + [] -> bin (k + step) later + _ -> (k, k+step, length now, sum (map fst now)) : bin (k + step) later + where + (now, later) = span ((<= k + step) . snd) xs diff --git a/src/GHC/Debug/Brick/Render/HistoryPicker.hs b/src/GHC/Debug/Brick/Render/HistoryPicker.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/HistoryPicker.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +module GHC.Debug.Brick.Render.HistoryPicker ( + commandWidget, + commandDescription, +) where + +import GHC.Debug.Brick.Model (SearchCmd(..), HistoryCommand(..), SomeSearchCmd(..), ProfileLevel (..)) +import GHC.Debug.Brick.Namespace +import Brick.Types +import Brick.Widgets.Core +import qualified Data.Text as Text +import Data.Text (Text) +import GHC.Debug.Brick.Render.Filter (renderShortUIDescription) + +commandWidget :: Int -> HistoryCommand -> Widget Name +commandWidget _size = + txt . commandDescription + +commandDescription :: HistoryCommand -> Text +commandDescription (HistoryCommand (SomeSearchCmd cmd)) = + case cmd of + DoGcRootsSearch -> + "Gc Roots" + DoRetainerSearch _limit uifilters -> + "Retainer" <> case uifilters of + [] -> "" + _ -> " " <> Text.intercalate "," (map renderShortUIDescription uifilters) + DoProfileSearch lvl -> + "Profile" <> case lvl of + OneLevel -> "" + TwoLevel -> " (2 level)" + DoStringSearch -> + "Strings" + DoArrWordsSearch -> + "ArrWords" + DoThunkSearch -> + "Thunks" diff --git a/src/GHC/Debug/Brick/Render/Key.hs b/src/GHC/Debug/Brick/Render/Key.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Key.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module GHC.Debug.Brick.Render.Key where + +import Data.Text (Text) +import qualified Data.Text as Text +import Graphics.Vty.Input + +renderKey :: Event -> Text +renderKey (EvKey (KFun n) []) = "(F" <> Text.pack (show n) <> ")" +renderKey (EvKey k [MCtrl]) = "(^" <> renderNormalKey k <> ")" +renderKey (EvKey k [MMeta]) = "(Alt + " <> renderNormalKey k <> ")" +renderKey (EvKey k []) = "(" <> renderNormalKey k <> ")" +renderKey _k = "()" + +renderNormalKey :: Key -> Text +renderNormalKey (KChar c) = Text.pack [c] +renderNormalKey KEsc = "ESC" +renderNormalKey KLeft = "←" +renderNormalKey KRight = "→" +renderNormalKey _k = "�" diff --git a/src/GHC/Debug/Brick/Render/Utils.hs b/src/GHC/Debug/Brick/Render/Utils.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Render/Utils.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +module GHC.Debug.Brick.Render.Utils where + +import Brick +import Data.ByteUnits +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Graphics.Vty as Vty + +import GHC.Debug.Brick.Namespace + +-- | Vertical space used to separate elements on the same line. +-- +-- This is standardised for a consistent UI. +vSpace :: Widget n +vSpace = txt " " + +menuAttr :: AttrName +menuAttr = attrName "menu" + +inputAttr :: AttrName +inputAttr = attrName "input" + +labelAttr :: AttrName +labelAttr = attrName "label" + +treeAttr :: AttrName +treeAttr = attrName "tree" + +highlightAttr :: AttrName +highlightAttr = attrName "highlighted" + +disabledMenuAttr :: AttrName +disabledMenuAttr = attrName "disabledMenu" + +txtLabel :: Text -> Widget n +txtLabel = withAttr labelAttr . txt + +strLabel :: String -> Widget n +strLabel = withAttr labelAttr . str + +highlighted :: Widget n -> Widget n +highlighted = forceAttr highlightAttr + +disabledMenuItem :: Widget n -> Widget n +disabledMenuItem = forceAttr disabledMenuAttr + +labelled :: Text -> Widget Name -> Widget Name +labelled = labelled' 20 + +labelled' :: Int -> Text -> Widget Name -> Widget Name +labelled' leftSize lbl w = + hLimit leftSize (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ') + +renderBytes :: Real a => a -> Widget n +renderBytes n = + txt (showBytes n) + +showBytes :: Real a => a -> Text +showBytes n = Text.pack $ getShortHand (getAppropriateUnits (ByteValue (realToFrac n) Bytes)) + +grey :: Vty.Color +grey = Vty.rgbColor (158 :: Int) 158 158 diff --git a/src/GHC/Debug/Brick/UI.hs b/src/GHC/Debug/Brick/UI.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/UI.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NumericUnderscores #-} + +module GHC.Debug.Brick.UI where + +import Brick +import Brick.BChan +import Control.Concurrent +import Control.Monad (forever) +import qualified Graphics.Vty as Vty +import qualified Graphics.Vty.CrossPlatform as Vty + +import GHC.Debug.Brick.Model +import GHC.Debug.Brick.Render +import GHC.Debug.Brick.Render.Utils +import GHC.Debug.Brick.Update + +{- + hBox + [ withAttr treeAttr $ Widget Fixed Fixed $ do + c <- getContext + limitedResult <- render (hLimit (c ^. availWidthL - T.length t) $ vLimit (c ^. availHeightL) $ body) + return $ emptyResult & imageL .~ vertCat (replicate (limitedResult ^. imageL . to imageHeight) (text' (c ^. attrL) t)) + , body + ] + where + bodyWidth = + render (hLimit (c ^. availWidthL - (length depth * 2 + 4)) $ vLimit (c ^. availHeightL) $ body) +-} + + +myAppStartEvent :: EventM Name AppState () +myAppStartEvent = return () + +myAppAttrMap :: AppState -> AttrMap +myAppAttrMap _appState = + attrMap (Vty.withStyle (Vty.white `on` Vty.black) Vty.dim) + [ (menuAttr, Vty.withStyle (Vty.white `on` Vty.blue) Vty.bold) + , (inputAttr, Vty.black `on` Vty.green) + , (labelAttr, Vty.withStyle (fg Vty.white) Vty.bold) + , (highlightAttr, Vty.black `on` Vty.yellow) + , (treeAttr, fg Vty.red) + , (disabledMenuAttr, Vty.withStyle (grey `on` Vty.blue) Vty.bold) + ] + +mainApp :: IO () +mainApp = do + eventChan <- newBChan 10 + _ <- forkIO $ forever $ do + writeBChan eventChan PollTick + -- 2s + threadDelay 2_000_000 + let buildVty = Vty.mkVty Vty.defaultConfig + initialVty <- buildVty + let app :: App AppState Event Name + app = App + { appDraw = myAppDraw + , appChooseCursor = showFirstCursor + , appHandleEvent = myAppHandleEvent + , appStartEvent = myAppStartEvent + , appAttrMap = myAppAttrMap + } + _finalState <- customMain initialVty buildVty + (Just eventChan) app (initialAppState eventChan) + return () diff --git a/src/GHC/Debug/Brick/UI/Async.hs b/src/GHC/Debug/Brick/UI/Async.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/UI/Async.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BangPatterns #-} +module GHC.Debug.Brick.UI.Async where + +import Brick +import Brick.BChan +import Control.Concurrent.Async +import Control.Monad.IO.Class +import Data.Text (Text) +import Data.Time.Clock +import GHC.Debug.Brick.Model +import Lens.Micro.Platform +import qualified Control.Exception.Safe as Safe + +asyncAction_ :: Text -> IO a -> EventM n OperationalState () +asyncAction_ desc action = asyncAction desc action (\_ -> return ()) + +-- | Abort the currently 'running_task', if there is any, and +-- set the given 'ThreadId' as the new running task. +-- +-- This is important to avoid hanging threads and zombies. +setPendingTask :: Async () -> EventM n OperationalState () +setPendingTask task = do + os <- get + case os ^. running_task of + Just oldTask -> liftIO $ cancel oldTask + Nothing -> pure () + put $ os & running_task .~ Just task + +asyncAction :: Text -> IO a -> (a -> EventM Name OperationalState ()) -> EventM n OperationalState () +asyncAction desc action final = do + eventChan <- view event_chan <$> get + task <- liftIO $ async (actionWithProgressReporter eventChan) + setPendingTask task + where + actionWithProgressReporter eventChan = do + writeBChan eventChan (ProgressMessage desc) + start <- getCurrentTime + !res <- Safe.try action + end <- getCurrentTime + + case res of + Left exc -> do + writeBChan eventChan (AsyncAborted exc) + Right result -> do + writeBChan eventChan (AsyncFinished (final result)) + writeBChan eventChan (ProgressFinished desc (end `diffUTCTime` start)) diff --git a/src/GHC/Debug/Brick/UI/Filter.hs b/src/GHC/Debug/Brick/UI/Filter.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/UI/Filter.hs @@ -0,0 +1,44 @@ +module GHC.Debug.Brick.UI.Filter ( + UIFilter(..), + uiFiltersToFilter, + uiFilterToFilter, +) where + +import GHC.Debug.Types +import GHC.Debug.Brick.Lib +import Data.Int +import GHC.Debug.Client.Monad +import GHC.Debug.CostCentres (findAllChildrenOfCC) + +data UIFilter = + UIAddressFilter Bool ClosurePtr + | UIInfoAddressFilter Bool InfoTablePtr + | UIConstructorFilter Bool String + | UIInfoNameFilter Bool String + | UIEraFilter Bool EraRange + | UISizeFilter Bool Size + | UIClosureTypeFilter Bool ClosureType + | UICcId Bool Int64 + deriving (Eq, Ord) + +uiFiltersToFilter :: [UIFilter] -> DebugM ClosureFilter +uiFiltersToFilter uifilters = do + closFilters <- mapM uiFilterToFilter uifilters + pure $ foldr AndFilter (PureFilter True) closFilters + +uiFilterToFilter :: UIFilter -> DebugM ClosureFilter +uiFilterToFilter (UIAddressFilter invert x) = pure $ AddressFilter (xor invert . (== x)) +uiFilterToFilter (UIInfoAddressFilter invert x) = pure $ InfoPtrFilter (xor invert . (== x)) +uiFilterToFilter (UIConstructorFilter invert x) = pure $ ConstructorDescFilter (xor invert . (== x) . name) +uiFilterToFilter (UIInfoNameFilter invert x) = pure $ InfoSourceFilter (xor invert . (== x) . infoName) +uiFilterToFilter (UIEraFilter invert x) = pure $ ProfHeaderFilter (xor invert . (`profHeaderInEraRange` (Just x))) +uiFilterToFilter (UISizeFilter invert x) = pure $ SizeFilter (xor invert . (>= x)) +uiFilterToFilter (UIClosureTypeFilter invert x) = pure $ InfoFilter (xor invert . (== x) . tipe) +uiFilterToFilter (UICcId invert x) = do + ccsPtrs <- findAllChildrenOfCC ((x ==) . ccID) + pure $ ProfHeaderFilter (xor invert . (`profHeaderReferencesCCS` ccsPtrs)) + +xor :: Bool -> Bool -> Bool +xor False False = False +xor True True = False +xor _ _ = True diff --git a/src/GHC/Debug/Brick/Update.hs b/src/GHC/Debug/Brick/Update.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Brick/Update.hs @@ -0,0 +1,711 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} + +module GHC.Debug.Brick.Update where + +import Brick +import Brick.BChan +import Brick.Forms +import Brick.Widgets.List +import Control.Applicative +import Control.Concurrent.Async (cancel) +import Control.Monad.Catch (bracket) +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as BS +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Ord (comparing) +import qualified Data.Ord as Ord +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as T +import qualified Graphics.Vty as Vty +import Graphics.Vty.Input.Events (Key (..)) +import Lens.Micro.Platform +import System.Directory +import System.FilePath +import Text.Read (readMaybe) + +import GHC.Debug.Profile (writeCensusByClosureType) +import qualified GHC.Debug.Types.Closures as Debug +import GHC.Debug.Types.Ptr (arrWordsBS, readInfoTablePtr) + +import Brick.Widgets.IOTree +import Brick.Widgets.ListPicker (ListPicker (..)) +import qualified Brick.Widgets.ListPicker as ListPicker +import GHC.Debug.Brick.Action.ArrWords +import GHC.Debug.Brick.Action.Profile +import GHC.Debug.Brick.Action.Retainers +import GHC.Debug.Brick.Action.Strings +import GHC.Debug.Brick.Action.Thunk +import GHC.Debug.Brick.ClosureDetails +import GHC.Debug.Brick.IOTree +import GHC.Debug.Brick.Lib as GD +import GHC.Debug.Brick.Model as Model +import GHC.Debug.Brick.Render.Closure +import qualified GHC.Debug.Brick.Render.Command as Command +import GHC.Debug.Brick.Render.Footer +import qualified GHC.Debug.Brick.Render.HistoryPicker as History +import GHC.Debug.Brick.Render.Utils +import GHC.Debug.Brick.UI.Async +import GHC.Debug.Brick.UI.Filter + +-- ---------------------------------------------------------------------------- +-- Window Management +-- ---------------------------------------------------------------------------- + +handleMainWindowEvent :: Handler () OperationalState +handleMainWindowEvent brickEvent = do + os <- get + + case brickEvent of + VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) -> + navigationDisabledOr $ do + put $ os & keybindingsMode .~ CommandPicker (commandListPicker (os ^. Model.version)) + + VtyEvent (Vty.EvKey (KChar 'r') [Vty.MCtrl]) -> do + navigationDisabledOr $ do + put $ os & keybindingsMode .~ HistoryPicker (historyListPicker (os ^. navigator)) + + -- A generic event + VtyEvent event + | Just cmd <- findCommand event -> + if isCmdDisabled (os ^. Model.version) cmd + then return () -- Command is disabled, don't dispatch the command + else dispatchCommand cmd + + -- Navigate the tree of closures + VtyEvent event -> case os ^. treeMode of + GcRoots r t-> do + newTree <- handleIOTreeEvent event t + put (os & treeMode .~ GcRoots r newTree) + Retainer r t -> do + newTree <- handleIOTreeEvent event t + put (os & treeMode .~ Retainer r newTree) + Profile r t -> do + newTree <- handleIOTreeEvent event t + put (os & treeMode .~ Profile r newTree) + Strings r t -> do + newTree <- handleIOTreeEvent event t + put (os & treeMode .~ Strings r newTree) + ArrWords r t -> do + newTree <- handleIOTreeEvent event t + put (os & treeMode .~ ArrWords r newTree) + Thunk r t -> do + newTree <- handleIOTreeEvent event t + put (os & treeMode .~ Thunk r newTree) + + _ -> return () + +-- Event handling when the main window has focus + +handleMain :: Debuggee -> Handler Event OperationalState +handleMain dbg e = do + os <- get + case e of + AppEvent event -> case event of + PollTick -> return () + ProgressMessage t -> do + put $ footerMessage t os + ProgressFinished desc runtime -> + put $ os + & running_task .~ Nothing + & last_run_time .~ Just (desc, runtime) + & footerMode .~ FooterInfo + AsyncFinished action -> action + AsyncAborted exc -> do + -- As the running task was aborted for some reason + -- remove it from the running_task field + put $ os & running_task .~ Nothing + put $ footerMessage (T.pack $ show exc) os + + NewSampleEvent sampleEv -> + handleSampleEvent sampleEv + + NavigatorEvent navEv -> + navigationDisabledOr $ do + handleHistoryNavigatorEvent navEv + + DoSearchWithHistoryPush searchCmd -> do + put (os & navigator %~ navPush searchCmd) + -- We perform a full search if the cached results + -- are partial. + handleSearchEvent dbg True searchCmd + + DoSearch searchCmd -> + -- This is a navigation event, show partial results if there are any. + handleSearchEvent dbg False searchCmd + + CacheSearch cmd result -> + cacheCompleteResult cmd result + + CachePartialSearch cmd result -> + cachePartialResult cmd result + + _ -> + case view keybindingsMode os of + KeybindingsShown -> + case e of + VtyEvent (Vty.EvKey _ _) -> put $ os & keybindingsMode .~ NoOverlay + _ -> put os + + HistoryPicker listPicker -> + handleHistoryListPicker e listPicker + + CommandPicker listPicker -> + handleCommandListPicker e listPicker + + NoOverlay -> case view footerMode os of + FooterInput fm form -> inputFooterHandler dbg fm form handleMainWindowEvent (() <$ e) + _ -> handleMainWindowEvent (() <$ e) + +handleHistoryListPicker :: BrickEvent Name Event -> ListPicker Name OperationalState Event HistoryCommand -> EventM Name OperationalState () +handleHistoryListPicker e picker = do + ListPicker.handleListPicker e picker >>= \ case + ListPicker.Unchanged -> pure () + ListPicker.Changed newPicker -> modify (keybindingsMode .~ HistoryPicker newPicker) + ListPicker.Exit -> modify (keybindingsMode .~ NoOverlay) + +handleCommandListPicker :: BrickEvent Name Event -> ListPicker Name OperationalState Event Command -> EventM Name OperationalState () +handleCommandListPicker e picker = do + ListPicker.handleListPicker e picker >>= \ case + ListPicker.Unchanged -> pure () + ListPicker.Changed newPicker -> modify (keybindingsMode .~ CommandPicker newPicker) + ListPicker.Exit -> modify (keybindingsMode .~ NoOverlay) + +navigationDisabledOr :: EventM Name OperationalState () -> EventM Name OperationalState () +navigationDisabledOr act = do + os <- get + case os ^. running_task of + Nothing -> + act + Just _ -> + modify (footerMessage "Navigation disabled during a running heap traversal, press ESC to cancel") + +handleHistoryNavigatorEvent :: NavigatorEvent -> EventM Name OperationalState () +handleHistoryNavigatorEvent navEv = do + os <- get + case navEv of + GoOneBackwards -> do + let + nav = os ^. navigator + (mEvent, newNav) = navBackwards nav + + put $ + os & navigator .~ newNav + + case mEvent of + Nothing -> + put (os & footerMessage "No previous view available") + Just ev -> do + sendEvent $ DoSearch ev + + GoOneForwards -> do + let + nav = os ^. navigator + (mEvent, newNav) = navForward nav + + put $ + os & navigator .~ newNav + + case mEvent of + Nothing -> + put (os & footerMessage "No next view available") + Just ev -> do + sendEvent $ DoSearch ev + +handleSearchEvent :: Debuggee -> Bool -> SomeSearchCmd -> EventM Name OperationalState () +handleSearchEvent dbg fullSearch (SomeSearchCmd searchCmd) = do + os <- get + case searchCmd of + DoGcRootsSearch -> + cachedOrRun + fullSearch + DoGcRootsSearch + (\ gcRoots -> + put (os & treeMode .~ gcRootsTreeMode (gcRootsIOTree dbg gcRoots)) + ) + (do + -- TODO: This logic belongs in GHC.Debug.Brick.GcRoots + -- TODO: introduce event to set the 'rootsFrom' + (closures, roots) <- liftIO $ gcRootsAction dbg + modify (\ o -> o & rootsFrom .~ DefaultRoots roots) + -- TODO: This is awkward, but this makes sure the view is updated. + -- Rather, we should have two types of events, one that changes the + -- view and one that sends values. + sendEvent $ NewSampleEvent $ GcRootsSample closures + sendEvent $ CacheSearch DoGcRootsSearch closures + ) + + DoRetainerSearch limit uifilters -> + cachedOrRun + fullSearch + (DoRetainerSearch limit uifilters) + (\ retainers -> + put (os & treeMode .~ retainerTreeMode (os ^. resultSize) (retainerTree dbg retainers) (topRetainersFromRetainerMap retainers)) + ) + (searchWithCurrentFiltersIncremental dbg uifilters) + + DoProfileSearch lvl -> + cachedOrRun + fullSearch + (DoProfileSearch lvl) + (\ census -> + put (os & treeMode .~ profileTreeMode (os ^. resultSize) (profileTree dbg) census) + ) + (profileAction dbg lvl) + + DoStringSearch -> + cachedOrRun + fullSearch + DoStringSearch + (\ census -> + put (os & treeMode .~ stringTreeMode (os ^. resultSize) (stringTree dbg) census) + ) + (stringsAction dbg) + + DoArrWordsSearch -> + cachedOrRun + fullSearch + DoArrWordsSearch + (\ census -> + put (os & treeMode .~ arrWordsTreeMode (os ^. resultSize) (arrWordsTree dbg) census) + ) + (arrWordsAction dbg) + + DoThunkSearch -> + cachedOrRun + fullSearch + DoThunkSearch + (\ census -> + put (os & treeMode .~ thunkTreeMode (os ^. resultSize) (thunkTree dbg) census) + ) + (thunkAnalysisActionAsync dbg) + +handleSampleEvent :: SampleEvent -> EventM Name OperationalState () +handleSampleEvent ev = do + os <- get + case ev of + GcRootsSample closures -> do + case os ^. treeMode of + GcRoots render t -> do + put $ os & treeMode .~ GcRoots render (setIOTreeRoots closures t) + -- TODO: support partial results + _ -> + -- If a sample is received but not displaying a gcRoots view in the tree for some reason, just ignore it. + return () + + RetainerSample closure_retainer_stack_sample -> do + case os ^. treeMode of + Retainer render t -> do + case closure_retainer_stack_sample of + [] -> pure () -- Theoretically, this should never occur. + (new_sample_clos_detail:_) -> do + -- Why do we only need the first element? + -- Because the first element of the 'new_closure_stack_sample' + -- is the closure of interest (or Leaf closure), while the tail + -- is the retainer stack of closures. + let root = RetainerStackRoot new_sample_clos_detail + put $ os & treeMode .~ Retainer render (addIOTreeRoots [root] t) + -- TODO: support partial results + _ -> + -- If a sample is received but not displaying a retainer view in the tree for some reason, just ignore it. + return () + + ProfileSample lvl census -> do + case os ^. treeMode of + Profile _ t -> do + put $ os & treeMode .~ profileTreeMode (os ^. resultSize) t census + sendEvent $ CachePartialSearch (DoProfileSearch lvl) census + _ -> + -- If a sample is received but not displaying a profile view in the tree for some reason, just ignore it. + return () + + StringSample census -> do + case os ^. treeMode of + Strings _render t -> do + put $ os & treeMode .~ stringTreeMode (os ^. resultSize) t census + sendEvent $ CachePartialSearch DoStringSearch census + _ -> + -- If a sample is received but not displaying a strings view in the tree for some reason, just ignore it. + return () + + ArrWordsSample census -> do + case os ^. treeMode of + ArrWords _render t -> do + put $ os & treeMode .~ arrWordsTreeMode (os ^. resultSize) t census + sendEvent $ CachePartialSearch DoArrWordsSearch census + _ -> + -- If a sample is received but not displaying a arr words view in the tree for some reason, just ignore it. + return () + + ThunkSample census -> do + case os ^. treeMode of + Thunk _render t -> do + put $ os & treeMode .~ thunkTreeMode (os ^. resultSize) t census + sendEvent $ CachePartialSearch DoThunkSearch census + _ -> + -- If a sample is received but not displaying a thunk view in the tree for some reason, just ignore it. + return () + +inputFooterHandler :: Debuggee + -> FooterInputMode + -> Form Text () Name + -> Handler () OperationalState + -> Handler () OperationalState +inputFooterHandler dbg m form _k re@(VtyEvent e) = + case e of + Vty.EvKey KEsc [] -> do + modify resetFooter + Vty.EvKey KEnter [] -> do + dispatchFooterInput dbg m form + _ + | isInvertFilterEvent e -> + let m' = invertInput m in + modify (footerMode .~ (FooterInput m' (updateFormState (formState form) $ footerInputForm m'))) + | otherwise -> do + zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re) +inputFooterHandler _ _ _ k re = k re + +-- | What happens when we press enter in footer input mode +dispatchFooterInput :: Debuggee + -> FooterInputMode + -> Form Text () n + -> EventM n OperationalState () +dispatchFooterInput _ (FClosureAddress runf invert) form = addOrSendUiFilter form runf readClosurePtr (pure . UIAddressFilter invert) +dispatchFooterInput _ (FInfoTableAddress runf invert) form = addOrSendUiFilter form runf readInfoTablePtr (pure . UIInfoAddressFilter invert) +dispatchFooterInput _ (FConstructorName runf invert) form = addOrSendUiFilter form runf Just (pure . UIConstructorFilter invert) +dispatchFooterInput _ (FClosureName runf invert) form = addOrSendUiFilter form runf Just (pure . UIInfoNameFilter invert) +dispatchFooterInput _ FArrWordsSize form = addOrSendUiFilter form True readMaybe (\size -> [UIClosureTypeFilter False Debug.ARR_WORDS, UISizeFilter False size]) +dispatchFooterInput _ (FFilterEras runf invert) form = addOrSendUiFilter form runf (parseEraRange . T.pack) (pure . UIEraFilter invert) +dispatchFooterInput _ (FFilterClosureSize invert) form = addOrSendUiFilter form False readMaybe (pure . UISizeFilter invert) +dispatchFooterInput _ (FFilterClosureType invert) form = addOrSendUiFilter form False readMaybe (pure . UIClosureTypeFilter invert) +dispatchFooterInput _ (FFilterCcId runf invert) form = addOrSendUiFilter form runf readMaybe (pure . UICcId invert) +dispatchFooterInput _ FDumpArrWords form = do + os <- get + let + act node = asyncAction_ "dumping ARR_WORDS payload" $ + case node of + Just ClosureDetails{_closure = Closure{_closureSized = Debug.unDCS -> Debug.ArrWordsClosure{bytes, arrWords}}} -> + BS.writeFile (T.unpack $ formState form) $ arrWordsBS (take (fromIntegral bytes) arrWords) + _ -> pure () + case view treeMode os of + Retainer _ iotree -> act (fmap retainerNodeClosure $ ioTreeSelection iotree) + Profile _ _ -> put (os & footerMessage "Dump for profile mode not implemented yet") + Strings _ iotree -> act (stringLineClosureDetails =<< ioTreeSelection iotree) + Thunk _ _ -> put (os & footerMessage "Dump for thunk mode not implemented yet") + ArrWords _ iotree -> act (arrWordLineClosureDetails =<< ioTreeSelection iotree) + GcRoots _ iotree -> act (ioTreeSelection iotree) +dispatchFooterInput _ FSetResultSize form = do + asyncAction "setting result size" (pure ()) $ \() -> do + os <- get + case readMaybe $ T.unpack (formState form) of + Just n + | n <= 0 -> put (os & resultSize .~ Nothing) + | otherwise -> put (os & resultSize .~ (Just n)) + Nothing -> pure () +dispatchFooterInput dbg FSnapshot form = do + asyncAction_ "Taking snapshot" $ snapshot dbg (T.unpack (formState form)) +dispatchFooterInput _ FSaveTree form = do + os <- get + case os ^. treeMode of + Profile _ t -> do + let + profLineToCensusByClosure = \ case + ProfileLine key args stats -> Just ((key, args), stats) + ClosureLine _ -> Nothing + + census = Map.fromList $ Maybe.mapMaybe profLineToCensusByClosure (getIOTreeRoots t) + liftIO $ writeCensusByClosureType (T.unpack $ formState form) census + + _ -> + put (os & footerMessage "Saving to file only supported for Profile views") + +addOrSendUiFilter :: Form Text e n -> Bool -> (String -> Maybe t) -> (t -> [UIFilter]) -> EventM n OperationalState () +addOrSendUiFilter form doRun parse newFilter = do + os <- get + addFilterOrSendEvent form doRun parse newFilter (DoRetainerSearch (os ^. resultSize)) + +addFilterOrSendEvent :: Form Text e n -> Bool -> (String -> Maybe t) -> (t -> [UIFilter]) -> ([UIFilter] -> SearchCmd RetainerMap) -> EventM n OperationalState () +addFilterOrSendEvent form doRun parse createFilterM mkEvent = do + case parse (T.unpack (formState form)) of + Just x + | doRun -> do + let newFilter = createFilterM x + let searchCmd = SomeSearchCmd $ mkEvent newFilter + sendEvent (DoSearchWithHistoryPush searchCmd) + | otherwise -> do + let newFilter = createFilterM x + modify (resetFooter . addFilters newFilter) + Nothing -> + pure () + +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 + + VtyEvent (Vty.EvKey KEsc _) -> halt + VtyEvent event -> case event of + -- Connect to the selected debuggee + Vty.EvKey (KChar '\t') [] -> do + put $ appState & majorState . setupKind %~ toggleSetup + Vty.EvKey KEnter _ -> + case st of + Snapshot + | Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots' + -> do + debuggee' <- liftIO $ snapshotConnect (writeBChan eventChan . ProgressMessage) (view socketLocation socket) + put $ 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 (writeBChan eventChan . ProgressMessage) (view socketLocation socket)) + (\debuggee' -> liftIO $ resume debuggee') + (\debuggee' -> + put $ appState & majorState .~ Connected + { _debuggeeSocket = socket + , _debuggee = debuggee' + , _mode = RunningMode -- TODO should we query the debuggee for this? + }) + _ -> return () + + -- Navigate through the list. + _ -> do + case st of + Snapshot -> do + zoom (majorState . knownSnapshots) (handleListEventVi handleListEvent event) + Socket -> do + zoom (majorState . knownDebuggees) (handleListEventVi handleListEvent event) + + AppEvent event -> case event of + PollTick -> do + -- Poll for debuggees + knownDebuggees'' <- updateListFrom socketDirectory knownDebuggees' + knownSnapshots'' <- updateListFrom snapshotDirectory knownSnapshots' + put $ appState & majorState . knownDebuggees .~ knownDebuggees'' + & majorState . knownSnapshots .~ knownSnapshots'' + _ -> return () + _ -> return () + + Connected _socket' debuggee' mode' -> case mode' of + + RunningMode -> case brickEvent of + -- Exit + VtyEvent (Vty.EvKey KEsc _) -> + halt + -- Pause the debuggee + VtyEvent (Vty.EvKey (KChar 'p') []) -> do + liftIO $ pause debuggee' + ver <- liftIO $ GD.version debuggee' + put (appState & majorState . mode .~ + PausedMode + OperationalState + { _running_task = Nothing + , _last_run_time = Nothing + , _treeMode = gcRootsTreeMode (gcRootsIOTree debuggee' []) + , _keybindingsMode = NoOverlay + , _footerMode = FooterInfo + , _rootsFrom = DefaultRoots [] + , _event_chan = eventChan + , _resultSize = Just 100 + , _filters = [] + , _asyncSamplingInterval = 1_000_000 {- 1 Second -} + , _version = ver + , _viewCache = emptyCache + , _navigator = newHistoryNavigator $ SomeSearchCmd DoGcRootsSearch + } + ) + + liftIO $ writeBChan eventChan $ DoSearch $ SomeSearchCmd DoGcRootsSearch + + _ -> return () + + PausedMode os -> case brickEvent of + _ -> case brickEvent of + VtyEvent (Vty.EvKey (KEsc) _) | NoOverlay <- view keybindingsMode os + , not (isFocusedFooter (view footerMode os)) -> do + case view running_task os of + Just task -> do + liftIO $ cancel task + 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 + +gcRootsTreeMode :: IOTree ClosureDetails Name -> TreeMode +gcRootsTreeMode = GcRoots renderClosureDetails + +gcRootsIOTree :: Debuggee -> [ClosureDetails] -> IOTree ClosureDetails Name +gcRootsIOTree dbg closures = + mkIOTree dbg closures getChildren renderInlineClosureDesc id + +gcRootsAction :: Debuggee -> IO ([ClosureDetails], [(Text, Ptr)]) +gcRootsAction dbg = do + raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures dbg + rootClosures' <- mapM (completeClosureDetails dbg) raw_roots + raw_saved <- map ("Saved Object",) <$> GD.savedClosures dbg + savedClosures' <- mapM (completeClosureDetails dbg) raw_saved + pure (savedClosures' <> rootClosures', fmap toPtr <$> (raw_roots ++ raw_saved)) + +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 + -- first. + debuggeeSockets <- List.sortBy (comparing Ord.Down) + <$> mapM (mkSocketInfo . (dir )) debuggeeSocketFiles + + let currentSelectedPathMay :: Maybe SocketInfo + currentSelectedPathMay = fmap snd (listSelectedElement llist) + + newSelection :: Maybe Int + newSelection = do + currentSelectedPath <- currentSelectedPathMay + List.findIndex ((currentSelectedPath ==)) debuggeeSockets + + return $ listReplace + (Seq.fromList debuggeeSockets) + (newSelection <|> (if Prelude.null debuggeeSockets then Nothing else Just 0)) + llist + +-- ---------------------------------------------------------------------------- +-- Command & History ListPicker +-- ---------------------------------------------------------------------------- + +commandListPicker :: GD.Version -> ListPicker Name OperationalState Event Command +commandListPicker ver = + ListPicker + { _listPickerInput = newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] "" + , _listPickerElements = list CommandPicker_List commandList 1 + , _listPickerAllElements = commandList + , _listPickerSelect = \ case + cmd + | isCmdDisabled ver cmd -> + pure ListPicker.Unchanged + | otherwise -> do + dispatchCommand cmd + pure ListPicker.Exit + , _listPickerDescription = commandDescription + , _listPickerRenderRow = Command.renderCommand ver + , _listPickerLabel = "Command Picker" + , _listPickerHighlightAttrName = highlightAttr + } + +historyListPicker :: HistoryNavigator SomeSearchCmd -> ListPicker Name OperationalState Event HistoryCommand +historyListPicker historyNav = + ListPicker + { _listPickerInput = newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] "" + , _listPickerElements = list HistoryPicker_List historyCommands 1 + , _listPickerAllElements = historyCommands + , _listPickerSelect = \ cmd -> do + historyCommandDispatch cmd + pure ListPicker.Exit + , _listPickerDescription = History.commandDescription + , _listPickerRenderRow = History.commandWidget + , _listPickerLabel = "History Picker" + , _listPickerHighlightAttrName = highlightAttr + } + where + historyCommands = Seq.fromList $ map HistoryCommand navStack + navStack = navList historyNav + +-- ---------------------------------------------------------------------------- +-- Commands and Shortcut constants +-- ---------------------------------------------------------------------------- + +invertFilterEvent :: Vty.Event +invertFilterEvent = Vty.EvKey (KChar 'g') [Vty.MCtrl] + +isInvertFilterEvent :: Vty.Event -> Bool +isInvertFilterEvent = (invertFilterEvent ==) + +-- All the commands which we support, these show up in keybindings and also the command picker +commandList :: Seq.Seq Command +commandList = Seq.fromList + [ mkCommand "Show key bindings" (Vty.EvKey (KChar '?') []) (modify $ keybindingsMode .~ KeybindingsShown) + , mkCommand "Clear filters" (withCtrlKey 'w') (modify clearFilters) + , Command "Search with current filters" (Just $ withCtrlKey 'f') doRetainerSearch NoReq + , mkCommand "Set search limit (default 100)" (withCtrlKey 'l') (setFooterInputMode FSetResultSize) + , mkCommand "GC Roots" (withCtrlKey 's') (doSearch DoGcRootsSearch) + , mkCommand "Find Address" (withCtrlKey 'a') (setFooterInputMode (FClosureAddress True False)) + , mkCommand "Find Info Table" (withCtrlKey 't') (setFooterInputMode (FInfoTableAddress True False)) + , mkCommand "Find Retainers" (withCtrlKey 'e') (setFooterInputMode (FConstructorName True False)) + , mkCommand' "Find Retainers (Exact)" (setFooterInputMode (FClosureName True False)) + , mkFilterCmd "Find closures by era" (withCtrlKey 'v') (setFooterInputMode (FFilterEras True False)) ReqErasProfiling + , mkCommand "Find Retainers of large ARR_WORDS" (withCtrlKey 'u') (setFooterInputMode FArrWordsSize) + , mkCommand "Dump ARR_WORDS payload" (withCtrlKey 'j') (setFooterInputMode FDumpArrWords) + , mkCommand "Profile" (withCtrlKey 'b') (doSearch (DoProfileSearch OneLevel)) + , mkCommand' "Profile (2 level)" (doSearch (DoProfileSearch TwoLevel)) + , Command "Thunk Analysis" Nothing (doSearch DoThunkSearch) NoReq + , mkCommand "Take Snapshot" (withCtrlKey 'x') (setFooterInputMode FSnapshot) + , Command "ARR_WORDS Count" Nothing (doSearch DoArrWordsSearch) NoReq + , Command "Strings Count" Nothing (doSearch DoStringSearch) NoReq + , mkCommand' "Save View to file" (setFooterInputMode FSaveTree) + , mkCommand "Go to previous view" (withAltKey KLeft) (sendEvent $ NavigatorEvent GoOneBackwards) + , mkCommand "Go to next view" (withAltKey KRight) (sendEvent $ NavigatorEvent GoOneForwards) + , mkCommand "Show History" (withCtrlKey 'r') (sendEvent $ NavigatorEvent GoOneForwards) + ] <> addFilterCommands + where + doSearch = sendEvent . DoSearchWithHistoryPush . SomeSearchCmd + + doRetainerSearch = do + os <- get + doSearch $ DoRetainerSearch (os ^. resultSize) (os ^. filters) + + setFooterInputMode m = modify $ footerMode .~ footerInput m + + addFilterCommands :: Seq.Seq Command + addFilterCommands = Seq.fromList + [ mkCommand' "Add filter for address" (setFooterInputMode (FClosureAddress False False)) + , mkCommand' "Add filter for info table ptr" (setFooterInputMode (FInfoTableAddress False False)) + , mkCommand' "Add filter for constructor name" (setFooterInputMode (FConstructorName False False)) + , mkCommand' "Add filter for closure name" (setFooterInputMode (FClosureName False False)) + , mkFilterCmd' "Add filter for era" (setFooterInputMode (FFilterEras False False)) ReqErasProfiling + , mkFilterCmd' "Add filter for cost centre id" (setFooterInputMode (FFilterCcId False False)) ReqSomeProfiling + , mkCommand' "Add filter for closure size" (setFooterInputMode (FFilterClosureSize False)) + , mkCommand' "Add filter for closure type" (setFooterInputMode (FFilterClosureType False)) + , mkCommand' "Add exclusion for address" (setFooterInputMode (FClosureAddress False True)) + , mkCommand' "Add exclusion for info table ptr" (setFooterInputMode (FInfoTableAddress False True)) + , mkCommand' "Add exclusion for constructor name" (setFooterInputMode (FConstructorName False True)) + , mkCommand' "Add exclusion for closure name" (setFooterInputMode (FClosureName False True)) + , mkFilterCmd' "Add exclusion for era" (setFooterInputMode (FFilterEras False True)) ReqErasProfiling + , mkFilterCmd' "Add exclusion for cost centre id" (setFooterInputMode (FFilterCcId False True)) ReqSomeProfiling + , mkCommand' "Add exclusion for closure size" (setFooterInputMode (FFilterClosureSize True)) + , mkCommand' "Add exclusion for closure type" (setFooterInputMode (FFilterClosureType True)) + ] + + withCtrlKey char = Vty.EvKey (KChar char) [Vty.MCtrl] + withAltKey key = Vty.EvKey key [Vty.MMeta] + +findCommand :: Vty.Event -> Maybe Command +findCommand event = do + i <- Seq.findIndexL (\cmd -> commandKey cmd == Just event) commandList + Seq.lookup i commandList diff --git a/src/IOTree.hs b/src/IOTree.hs deleted file mode 100644 --- a/src/IOTree.hs +++ /dev/null @@ -1,404 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module IOTree - ( IOTree - , IOTreePath - , RowState(..) - , RowCtx(..) - , ioTree - , setIOTreeRoots - , getIOTreeRoots - , renderIOTree - , handleIOTreeEvent - , ioTreeSelection - , ioTreeToggle - - , ioTreeViewSelection - , unViewTree - , viewPath - , viewSelect - , viewUp - , viewUp' - , viewUnsafeDown - , viewPrevSibling - , viewNextSibling - , viewCollapse - , viewExpand - , viewIsCollapsed - ) where - -import Brick -import Control.Applicative -import Control.Monad.IO.Class -import Data.Maybe (fromMaybe) -import qualified Data.List as List -import GHC.Stack -import qualified Graphics.Vty.Input.Events as Vty -import Graphics.Vty.Input.Events (Key(..)) -import Lens.Micro ((^.)) - - --- A tree style list where items can be expanded and collapsed -data IOTree node name = IOTree - { _name :: name - , _roots :: [IOTreeNode node name] - , _getChildren :: (node -> IO [node]) - , _renderRow :: RowState -- is row expanded? - -> Bool -- is row selected? - -> RowCtx -- is current node last in subtree? - -> [RowCtx] -- per level of tree depth, are parent nodes last in subtree? - -> node -- the node to render - -> Widget name - -- Render some extra info as the first child of each node - , _selection :: [Int] - -- ^ Indices along the path to the current selection. Empty list means no - -- selection. - } - -data RowState = Expanded Bool | Collapsed -data RowCtx = NotLastRow | LastRow - -setIOTreeRoots :: [node] -> IOTree node name -> IOTree node name -setIOTreeRoots newRoots iot = iot { _roots = (nodeToTreeNode (_getChildren iot) <$> newRoots) } - -getIOTreeRoots :: IOTree node name -> [node] -getIOTreeRoots iot = map _node (_roots iot) - - - -type IOTreePath node = [(Int, node)] - -data IOTreeNode node name - = IOTreeNode - { _node :: node - -- ^ Current node - , _children :: Either - (IO [IOTreeNode node name]) -- Node is collapsed - [IOTreeNode node name] -- Node is expanded - } - -ioTree - :: forall node name - . name - -- ^ Name of the tree - -> [node] - -- ^ Root nodes - -> (node -> IO [node]) - -- ^ Get child nodes of a node - -> (RowState -- is row expanded or collapsed? - -> Bool -- Is row selected - -> RowCtx -- innermost context - -> [RowCtx] -- Tree depth - -> node -- the node to render - -> Widget name) - -- ^ Row renderer (should add it's own indent based on depth) - -> IOTree node name -ioTree name rootNodes getChildrenIO renderRow - = IOTree - { _name = name - , _roots = nodeToTreeNode getChildrenIO <$> rootNodes - , _getChildren = getChildrenIO - , _renderRow = renderRow - , _selection = if null rootNodes then [] else [0] - -- ^ TODO we could take the initial path but we'd have to expand through to - -- that path with IO - } - where - -nodeToTreeNode :: (node -> IO [node]) -> node -> IOTreeNode node name -nodeToTreeNode k n = IOTreeNode n (Left (fmap (nodeToTreeNode k) <$> k n)) - -renderIOTree :: (Show name, Ord name) => IOTree node name -> Widget name -renderIOTree iotree - = drawTreeElements iotree - -data TreeNodeWithRenderContext node = TreeNodeWithRenderContext - { _nodeDepth :: Int - , _nodeState :: RowState - , _nodeSelected :: Bool - , _nodeLast :: RowCtx - , _nodeParentLast :: [RowCtx] - , _nodeContent :: node - } - -renderTreeNodeWithContext :: - (RowState -> Bool -> RowCtx -> [RowCtx] -> node -> Widget name) -> - TreeNodeWithRenderContext node -> Widget name -renderTreeNodeWithContext rowRenderer ctx = - rowRenderer (_nodeState ctx) (_nodeSelected ctx) (_nodeLast ctx) (_nodeParentLast ctx) (_nodeContent ctx) - -drawTreeElements :: (Ord n, Show n) => IOTree node n -> Widget n -drawTreeElements (IOTree widgetName treeNodes _ renderRow pathTop) = - -- This function takes inspiration from 'Brick.Widget.List.drawListElements' - Widget Greedy Greedy $ do - c <- getContext - - -- Take (numPerHeight * 2) elements, or whatever is left - let - rs = flattenTree 0 [] treeNodes pathTop - es = take (numPerHeight * 2) $ drop start rs - - idx = fromMaybe 0 (List.findIndex (_nodeSelected) rs) - - start = max 0 $ idx - numPerHeight + 1 - - -- We hardcode the height of each element to be expected as 1 row. - -- Perhaps we could greedily compute the number of elements based on - -- their dynamic height for a perfect result, - -- but it currently feels like overkill. - itemHeight = 1 - - -- The number of items to show is the available height - -- divided by the item height... - initialNumPerHeight = (c^.availHeightL) `div` itemHeight - -- ... but if the available height leaves a remainder of - -- an item height then we need to ensure that we render an - -- extra item to show a partial item at the top or bottom to - -- give the expected result when an item is more than one - -- row high. (Example: 5 rows available with item height - -- of 3 yields two items: one fully rendered, the other - -- rendered with only its top 2 or bottom 2 rows visible, - -- depending on how the viewport state changes.) - numPerHeight = initialNumPerHeight + - if initialNumPerHeight * itemHeight == c^.availHeightL - then 0 - else 1 - - off = start * itemHeight - - render $ viewport widgetName Vertical $ - translateBy (Location (0, off)) $ - vBox $ (map (renderTreeNodeWithContext renderRow) es) - where - -- Compute metadata for each row we may display. - -- This is a logical representation of each row that can - -- be split and filtered later. - -- Each 'TreeNodeWithRenderContext' can be individually rendered without - -- further issue. - flattenTree _ _ [] _ = [] - flattenTree minorIx depth (IOTreeNode node' csE : ns) path = case csE of - -- Collapsed - Left _ -> row Collapsed : rowsRest - -- Expanded - Right cs -> row (Expanded (null cs)) - : flattenTree 0 (rowCtx : depth) cs (if childIsSelected then drop 1 path else []) - ++ rowsRest - where - childIsSelected = case path of - x:_ -> x == minorIx - _ -> False - selected = path == [minorIx] - rowCtx = if null ns then LastRow else NotLastRow - row state = TreeNodeWithRenderContext - { _nodeDepth = length depth - , _nodeState = state - , _nodeSelected = selected - , _nodeLast = rowCtx - , _nodeParentLast = depth - , _nodeContent = node' - } - rowsRest = flattenTree (minorIx + 1) depth ns path - -handleIOTreeEvent :: Vty.Event -> IOTree node name -> EventM name s (IOTree node name) -handleIOTreeEvent e tree - = liftIO - $ forIOTreeViewSelection tree - $ \view -> fmap viewSelect $ case e of - Vty.EvKey KRight _ -> do - (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) - Vty.EvKey KPageUp _ -> return $ List.foldl' (flip ($)) view (replicate 15 prev) - _ -> return view - where - next v = fromMaybe v (viewNextVisible v) - prev v = fromMaybe v (viewPrevVisible v) - --- | Toggle (expanded/collapsed) at the current selection. -ioTreeToggle :: IOTree node name -> IO (IOTree node name) -ioTreeToggle t = forIOTreeViewSelection t $ \view -> - if viewIsCollapsed view - then fst <$> viewExpand view - else return (viewCollapse view) - --- | A view (or Zipper) used to navigate the tree -data IOTreeView node name - = Root (IOTree node name) - | Node - (IOTreeNode node name -> IOTreeView node name) -- reconstruct the parent given this node - Int -- The index in the parent - (IOTreeNode node name) -- This node - -forIOTreeViewSelection - :: IOTree node name - -> (IOTreeView node name -> IO (IOTreeView node name)) - -> IO (IOTree node name) -forIOTreeViewSelection t f = unViewTree <$> f (ioTreeViewSelection t) - -ioTreeViewSelection :: IOTree node name -> IOTreeView node name -ioTreeViewSelection t = List.foldl' viewUnsafeDown (Root t) (_selection t) - -ioTreeSelection :: IOTree node name -> Maybe node -ioTreeSelection t = case ioTreeViewSelection t of - Root{} -> Nothing - Node _ _ n -> Just (_node n) - -unViewTree :: IOTreeView node name -> IOTree node name -unViewTree t = case t of - Root t' -> t' - Node mkParent _ t' -> unViewTree (mkParent t') - --- | Current path in the tree -viewPath :: IOTreeView node name -> [Int] -viewPath tTop = reverse $ go tTop - where - go t = case t of - Root _ -> [] - Node mkParent i t' -> i : go (mkParent t') - --- | Select the current path -viewSelect :: IOTreeView node name -> IOTreeView node name -viewSelect t = ioTreeViewSelection newTree - where - newTree = oldTree { _selection = newSelection } - oldTree = unViewTree t - newSelection = viewPath t - --- | move up the tree -viewUp :: IOTreeView node name -> Maybe (IOTreeView node name) -viewUp t = case t of - Root{} -> Nothing - Node mkParent _ t' -> Just (mkParent t') - --- | move up the tree, but never to the root -viewUp' :: IOTreeView node name -> Maybe (IOTreeView node name) -viewUp' t = case viewUp t of - Just Root{} -> Nothing - x -> x - --- | Move down to a child in the tree. Index must be in range. Must be expanded. -viewUnsafeDown :: HasCallStack => IOTreeView node name -> Int -> IOTreeView node name -viewUnsafeDown view i - | viewIsCollapsed view = error "viewUnsafeDown: view must be expanded" - | otherwise = case view of - Root t -> Node (\c -> Root t{ _roots = listSet i c (_roots t) }) i (t !. i) - Node mkParent ixInParent t -> Node - (\c -> Node mkParent ixInParent (unsafeSetChild c i t)) - i - (t ! i) - -viewPrevVisible :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) -viewPrevVisible view = case viewPrevSibling view of - Nothing -> viewUp' view - Just nextSib -> Just (viewLastVisibleChild nextSib) - where - viewLastVisibleChild view' = if viewIsCollapsed view' - then view' - else let - n = case view' of - Root t -> length (_roots t) - 1 - Node _ _ t -> either (error "Impossible! view' is expanded") length (_children t) - in if n == 0 then view' else viewLastVisibleChild $ viewUnsafeDown view' (n-1) - -viewNextVisible :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) -viewNextVisible view = let - upwardNext v = case viewNextSibling v of - Nothing -> upwardNext =<< viewUp v - Just s -> Just s - in viewFirstVisibleChild view <|> upwardNext view - where - viewFirstVisibleChild view' = if viewIsCollapsed view' - then Nothing - else let - nullChildren = case view' of - Root t -> null (_roots t) - Node _ _ t -> either (error "Impossible! view' is expanded") null (_children t) - in if nullChildren then Nothing else Just (viewUnsafeDown view' 0) - --- | Move to the previous sibling within the parent node -viewPrevSibling :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) -viewPrevSibling t = case t of - Root{} -> Nothing - Node mkParent ixInParent t' -> if ixInParent == 0 - then Nothing - else Just $ viewUnsafeDown (mkParent t') (ixInParent - 1) - --- | Move to the next sibling within the parent node -viewNextSibling :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) -viewNextSibling t = case t of - Root{} -> Nothing - Node mkParent ixInParent t' -> let - parent = mkParent t' - nSiblings = case parent of - Root t'' -> length (_roots t'') - Node _ _ t'' -> length (either (error "Impossible! syblings must be expanded") id (_children t'')) - in if ixInParent + 1 == nSiblings - then Nothing - else Just (viewUnsafeDown parent (ixInParent + 1)) - --- | Collapse the current node. -viewCollapse :: HasCallStack => IOTreeView node name -> IOTreeView node name -viewCollapse t = case t of - Root _ -> t -- Can't collapse the root - Node mkParent i t' -> case _children t' of - Left _ -> t - Right cs -> Node mkParent i t'{_children = Left (return cs)} - --- | 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') - Node mkParent i t' -> case _children t' of - Left getChildren -> do - cs <- getChildren - return (Node mkParent i t'{_children=Right cs}, cs) - Right cs -> return (t, cs) - - -viewIsCollapsed :: HasCallStack => IOTreeView node name -> Bool -viewIsCollapsed t = case t of - Root{} -> False - Node _ _ t' -> case _children t' of - Left{} -> True - Right{} -> False - -(!.) :: IOTree node name -> Int -> IOTreeNode node name -t !. i = _roots t !! i - -(!) :: IOTreeNode node name -> Int -> IOTreeNode node name -t ! i = case _children t of - Right xs -> xs !! i - Left _ -> error "(!): tree node not expanded" - -unsafeSetChild :: HasCallStack => IOTreeNode node name -> Int -> IOTreeNode node name -> IOTreeNode node name -unsafeSetChild newChild i t = case _children t of - Right xs -> t { _children = Right (listSet i newChild xs) } - Left _ -> error "(!): tree node not expanded" - -listSet :: HasCallStack => Int -> a -> [a] -> [a] -listSet i a as - | i >= length as = error $ "listSet: index (" ++ show i ++ ") out of bounds [0 - " ++ show (length as) ++ ")" - | otherwise = take i as ++ [a] ++ drop (i+1) as diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 --- a/src/Lib.hs +++ /dev/null @@ -1,541 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE NamedFieldPuns #-} -module Lib - ( -- * Running/Connecting to a debuggee - Debuggee - , debuggeeRun - , debuggeeConnect - , snapshotConnect - , debuggeeClose - , withDebuggeeRun - , withDebuggeeConnect - , socketDirectory - , snapshotDirectory - - -- * Pause/Resume - , GD.pause - , GD.resume - , GD.pausePoll - , GD.withPause - - -- * Querying the paused debuggee - , rootClosures - , savedClosures - , version - , profilingMode - , GD.Version - - -- * Closures - , Closure - , ClosureType - , DebugClosure(..) - , closureShowAddress - , closureExclusiveSize - , closureSourceLocation - , SourceInformation(..) - , closureReferences - , closurePretty - , fillConstrDesc - , InfoTablePtr - , ListItem(..) - , closureInfoPtr - , infoSourceLocation - , GD.dereferenceClosure - , run - , ccsReferences - - -- * Common initialisation - , initialTraversal - , HG.HeapGraph(..) - -- * Dominator Tree - , Size(..) - , RetainerSize(..) - -- * Reverse Edge Map - , HG.mkReverseGraph - , reverseClosureReferences - , lookupHeapGraph - - -- * Profiling - , profile - , thunkAnalysis - , GD.CensusStats(..) - - -- * Retainers - , retainersOf - , findAllChildrenOfCCs - - -- * Counting - , arrWordsAnalysis - , stringsAnalysis - - -- * Snapshot - , snapshot - - -- * Types - , Ptr(..) - , CCSPtr - , CCPayload - , GenCCSPayload - , toPtr - , dereferencePtr - , ConstrDesc(..) - , ConstrDescCont - , GenPapPayload(..) - , StackCont - , PayloadCont - , SrtCont - , ClosurePtr - , readClosurePtr - , CCPtr - , readCCPtr - , HG.StackHI - , HG.PapHI - , HG.SrtHI - , HG.HeapGraphIndex - , ProfHeaderWord - -- - , EraRange(..) - , GD.profHeaderInEraRange - , tipe - , ClosureFilter(..) - , GD.profHeaderReferencesCCS - ) where - -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (mapMaybe) -import qualified GHC.Debug.Types as GD -import GHC.Debug.Types hiding (Closure, DebugClosure) -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.CostCentres as GD -import GHC.Debug.Retainers (EraRange(..), ClosureFilter(..)) -import qualified GHC.Debug.Snapshot as GD -import qualified GHC.Debug.Strings as GD -import qualified GHC.Debug.Types.Version as GD -import qualified GHC.Debug.Types.Graph as HG -import qualified GHC.Debug.Thunks as GD -import Control.Monad -import System.FilePath -import System.Directory -import Control.Tracer -import Data.Bitraversable -import Data.Text (Text, pack) -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as BS -import qualified Data.Set as Set -import Data.Int -import GHC.Debug.Client.Monad (DebugM) -import Common - -initialTraversal :: Debuggee -> IO (HG.HeapGraph Size) -initialTraversal e = run e $ do - -- Calculate the dominator tree with retainer sizes - -- TODO perhaps this conversion to a graph can be done in GHC.Debug.Types.Graph - _ <- GD.precacheBlocks - rs <- request RequestRoots - let derefFuncM cPtr = do - c <- GD.dereferenceClosure cPtr - hextraverse pure 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) - return hg - --- This function is very very very slow, it needs to be optimised. -{- -runAnalysis :: Debuggee -> HG.HeapGraph Size -> IO Analysis -runAnalysis e hg = run e $ do - let drs :: [G.Tree (ClosurePtr, (Size, RetainerSize))] - drs = fmap (\ent -> (HG.hgeClosurePtr ent, HG.hgeData ent)) <$> HG.retainerSize hg - - !hmGraph = HM.unions (map snd $ foldTree buildGraphNode <$> (HG.retainerSize hg)) - - buildGraphNode :: HG.HeapGraphEntry v - -> [(ClosurePtr, HM.HashMap ClosurePtr (v, [ClosurePtr]))] - -> (ClosurePtr, HM.HashMap ClosurePtr (v, [ClosurePtr])) - buildGraphNode hge subtrees = - (cptr, HM.insert cptr v (HM.unions submaps)) - where - cptr = HG.hgeClosurePtr hge - v = (HG.hgeData hge, children) - (children, submaps) = unzip subtrees - - cPtrToData - = fromMaybe ((-12221, RetainerSize (-12221)), []) - -- ^ TODO I would expect the mapping to be complete unless out analysis misses some closures. - . flip HM.lookup hmGraph - - return $ Analysis - [drPtr | G.Node (drPtr, _) _ <- drs] - ((\(_,x) -> x) . cPtrToData) - ((\(x,_) -> x) . cPtrToData) - -} - --- | Bracketed version of @debuggeeRun@. Runs a debuggee, connects to it, runs --- the action, kills the process, then closes the debuggee. -withDebuggeeRun :: FilePath -- ^ path to executable to run as the debuggee - -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) - -> (Debuggee -> IO a) - -> IO a -withDebuggeeRun exeName socketName action = GD.withDebuggeeRun exeName socketName action - --- | Bracketed version of @debuggeeConnect@. Connects to a debuggee, runs the --- action, then closes the debuggee. -withDebuggeeConnect :: FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) - -> (Debuggee -> IO a) - -> IO a -withDebuggeeConnect socketName action = GD.withDebuggeeConnect socketName action - --- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done. -debuggeeRun :: FilePath -- ^ path to executable to run as the debuggee - -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) - -> IO Debuggee -debuggeeRun exeName socketName = GD.debuggeeRun exeName socketName - --- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done. -debuggeeConnect :: (Text -> IO ()) - -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) - -> IO Debuggee -debuggeeConnect toChan socketName = GD.debuggeeConnectWithTracer (contramap pack $ Tracer (emit toChan)) socketName - - -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 () -debuggeeClose = GD.debuggeeClose - --- | Request the debuggee's root pointers. -rootClosures :: Debuggee -> IO [Closure] -rootClosures e = run e $ do - closurePtrs <- request RequestRoots - closures <- GD.dereferenceClosures closurePtrs - return [ Closure closurePtr' closure - | closurePtr' <- closurePtrs - | closure <- closures - ] - -version :: Debuggee -> IO GD.Version -version e = run e GD.version - -profilingMode :: GD.Version -> Maybe GD.ProfilingMode -profilingMode = GD.v_profiling - --- | A client can save objects by calling a special RTS method --- This function returns the closures it saved. -savedClosures :: Debuggee -> IO [Closure] -savedClosures e = run e $ do - closurePtrs <- request RequestSavedObjects - closures <- GD.dereferenceClosures closurePtrs - return $ zipWith Closure - closurePtrs - closures - -profile :: Debuggee -> ProfileLevel -> FilePath -> IO GD.CensusByClosureType -profile dbg lvl fp = do - c <- run dbg $ do - roots <- GD.gcRoots - case lvl of - OneLevel -> GD.censusClosureType roots - TwoLevel -> GD.census2LevelClosureType roots - GD.writeCensusByClosureType fp c - return c - -thunkAnalysis :: Debuggee -> IO (Map.Map (Maybe SourceInformation) GD.Count) -thunkAnalysis dbg = do - c <- run dbg $ do - roots <- GD.gcRoots - GD.thunkAnalysis roots - return c - - - -snapshot :: Debuggee -> FilePath -> IO () -snapshot dbg fp = do - dir <- snapshotDirectory - createDirectoryIfMissing True dir - GD.run dbg $ GD.snapshot (dir fp) - -retainersOf :: Maybe Int -> DebugM ClosureFilter -> Maybe [ClosurePtr] -> Debuggee -> IO [[Closure]] -retainersOf n retainer_filter mroots dbg = do - run dbg $ do - roots <- maybe GD.gcRoots return mroots - closfilter <- retainer_filter - stack <- GD.findRetainers n closfilter roots - traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack - -findAllChildrenOfCCs :: Int64 -> Debuggee -> IO (Set.Set CCSPtr) -findAllChildrenOfCCs ccId dbg = do - run dbg $ do - GD.findAllChildrenOfCC ((ccId ==) . ccID) - -arrWordsAnalysis :: Maybe [ClosurePtr] -> Debuggee -> IO (Map.Map BS.ByteString (Set.Set ClosurePtr)) -arrWordsAnalysis mroots dbg = do - run dbg $ do - roots <- maybe GD.gcRoots return mroots - arr_words <- GD.arrWordsAnalysis roots - return arr_words - -stringsAnalysis :: Maybe [ClosurePtr] -> Debuggee -> IO (Map.Map String (Set.Set ClosurePtr)) -stringsAnalysis mroots dbg = do - run dbg $ do - roots <- maybe GD.gcRoots return mroots - arr_words <- GD.stringAnalysis roots - return arr_words - --- -- | Request the description for an info table. --- -- The `InfoTablePtr` is just used for the equality --- requestConstrDesc :: Debuggee -> PayloadWithKey InfoTablePtr ClosurePtr -> IO ConstrDesc --- requestConstrDesc (Debuggee e _) = run e $ request RequestConstrDesc - --- -- | Lookup source information of an info table --- requestSourceInfo :: Debuggee -> InfoTablePtr -> IO [String] --- requestSourceInfo (Debuggee e _) = run e $ request RequestSourceInfo - --- -- | Request a set of closures. --- requestClosures :: Debuggee -> [ClosurePtr] -> IO [RawClosure] --- requestClosures (Debuggee e _) = run e $ request RequestClosures - -type Closure = DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr - -data ListItem ccs srt a b c d - = ListData - | ListOnlyInfo InfoTablePtr - | ListCCS CCSPtr (GenCCSPayload CCSPtr CCPayload) - | ListCC CCPayload - | ListFullClosure (DebugClosure ccs srt a b c d) - -data DebugClosure ccs srt p cd s c - = Closure - { _closurePtr :: ClosurePtr - , _closureSized :: DebugClosureWithSize ccs srt p cd s c - } - | Stack - { _stackPtr :: StackCont - , _stackStack :: GD.GenStackFrames srt c - } - deriving Show - -toPtr :: DebugClosure ccs 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 CCSPtr 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 Hextraversable DebugClosure where - hextraverse p f g h i j (Closure cp c) = Closure cp <$> hextraverse p f g h i j c - hextraverse _ p _ _ _ h (Stack sp s) = Stack sp <$> bitraverse p h s - -closureShowAddress :: DebugClosure ccs srt p cd s c -> String -closureShowAddress (Closure c _) = show c -closureShowAddress (Stack (StackCont s _) _) = show s - --- | Get the exclusive size (not including any referenced closures) of a closure. -closureExclusiveSize :: DebugClosure ccs srt p cd s c -> Size -closureExclusiveSize (Stack{}) = Size (-1) -closureExclusiveSize (Closure _ c) = (GD.dcSize c) - -closureSourceLocation :: Debuggee -> DebugClosure ccs 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 ccs srt 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 CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem CCSPtr 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 :: DebugStackFrame --- (GenSrtPayload ClosurePtr) ClosurePtr -> GD.DebugM [(String, _)] - frame_items frame = do - info <- GD.getSourceInfo (tableId (frame_info frame)) - case info of - Just (SourceInformation {infoName = "stg_orig_thunk_info_frame_info"}) -> - let [GD.SNonPtr dat] = GD.values frame - in return [("Blackhole arising from thunk:", (ListOnlyInfo (InfoTablePtr dat)))] - _ -> traverse sequenceA $ - - ("Info: " ++ show (tableId (frame_info frame)), return (ListOnlyInfo (tableId (frame_info 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) - lblAndPtrs <- sequence [ map (add_frame_ix frameIx) <$> (frame_items frame) - | (frameIx, frame) <- zip [(0::Int)..] (GD.getFrames stack') - ] - return (concat lblAndPtrs) - {- - return $ zipWith (\(lbl,ptr) c -> (lbl, Closure ptr c)) - lblAndPtrs - closures - -} -closureReferences e (Closure _ closure) = run e $ do - closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure - let wrapClosure cPtr = do - refClosure' <- GD.dereferenceClosure cPtr - return $ ListFullClosure $ Closure cPtr refClosure' - wrapStack sPtr = do - refStack' <- GD.dereferenceStack sPtr - return $ ListFullClosure $ Stack sPtr refStack' - wrapCCS ccsPtr = do - refCCS <- do - GD.dereferenceCCS ccsPtr >>= \ccs -> - bitraverse pure GD.dereferenceCC ccs - return $ ListCCS ccsPtr refCCS - closureReferencesAndLabels wrapClosure - wrapStack - wrapCCS - (unDCS closure') - -ccsReferences :: Debuggee -> GenCCSPayload CCSPtr CCPayload -> IO [ListItem ccs srt a b c d] -ccsReferences e initialCcs = run e $ (ListCC (ccsCc initialCcs) :) <$> go initialCcs - where - go ccs = do - case ccsPrevStack ccs of - Nothing -> pure [ListCC (ccsCc ccs)] - Just ccsPtr -> do - child <- GD.dereferenceCCS ccsPtr - child' <- bitraverse pure GD.dereferenceCC child - children <- go child' - return (ListCC (ccsCc child') : children) - -reverseClosureReferences :: HG.HeapGraph Size - -> HG.ReverseGraph - -> Debuggee - -> DebugClosure CCSPtr HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex) - -> IO [(String, DebugClosure - CCSPtr - HG.SrtHI - HG.PapHI - ConstrDesc HG.StackHI - (Maybe HG.HeapGraphIndex))] -reverseClosureReferences hg rm _ c = - case c of - Stack {} -> error "Nope - Stack" - Closure cp _ -> case (HG.reverseEdges cp rm) of - Nothing -> return [] - Just es -> - let revs = mapMaybe (flip HG.lookupHeapGraph hg) es - in return [(show n, Closure (HG.hgeClosurePtr hge) - (DCS (HG.hgeData hge) (HG.hgeClosure hge) )) - | (n, hge) <- zip [0 :: Int ..] revs] - -lookupHeapGraph :: HG.HeapGraph Size -> ClosurePtr -> Maybe (DebugClosure CCSPtr 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 ccs srt pap ConstrDescCont s c - -> IO (DebugClosure ccs srt pap ConstrDesc s c) -fillConstrDesc e closure = do - run e $ GD.hextraverse pure pure pure GD.dereferenceConDesc pure pure closure - --- | Pretty print a closure -closurePretty :: Debuggee -> DebugClosure CCSPtr InfoTablePtr PayloadCont ConstrDesc s ClosurePtr -> IO String -closurePretty _ (Stack _ frames) = return $ (show (length frames) ++ " frames") -closurePretty dbg (Closure _ closure) = run dbg $ do - closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure - return $ HG.ppClosure - (\_ refPtr -> show refPtr) - 0 - (unDCS closure') - --- Internal Stuff --- - -closureReferencesAndLabels :: Monad m => (pointer -> m a) -> (stack -> m a) -> (ccs -> m a) -> GD.DebugClosure ccs (GenSrtPayload pointer) PapPayload string stack pointer -> m [(String, a)] -closureReferencesAndLabels pointer stack fccs closure = sequence . map sequence $ [("CCS", fccs (ccs ph)) | Just ph <- pure (profHeader closure)] ++ case closure of - TSOClosure {..} -> - [ ("Thread label", pointer lbl) | Just lbl <- pure threadLabel ] ++ - [ ("Stack", pointer tsoStack) - , ("Link", pointer _link) - , ("Global Link", pointer global_link) - , ("TRec", pointer trec) - , ("Blocked Exceptions", pointer blocked_exceptions) - , ("Blocking Queue", pointer bq) - ] - StackClosure{..} -> [("Frames", stack frames )] - WeakClosure {..} -> [ ("Key", pointer key) - , ("Value", pointer value) - , ("C Finalizers", pointer cfinalizers) - , ("Finalizer", pointer finalizer) - ] ++ - [ ("Link", pointer link) - | Just link <- [mlink] -- TODO do we want to show NULL pointers some how? - ] - TVarClosure {..} -> [("val", pointer current_value)] - MutPrimClosure {..} -> withArgLables ptrArgs - PrimClosure{..} -> withArgLables ptrArgs - ConstrClosure {..} -> withFieldLables ptrArgs - ThunkClosure {..} -> [("SRT", pointer cp) | Just cp <- [getSrt srt]] - ++ withArgLables ptrArgs - SelectorClosure {..} -> [("Selectee", pointer selectee)] - IndClosure {..} -> [("Indirectee", pointer indirectee)] - BlackholeClosure {..} -> [("Indirectee", pointer indirectee)] - APClosure {..} -> ("Function", pointer fun) : [] -- TODO withBitmapLables ap_payload - PAPClosure {..} -> ("Function", pointer fun) : [] -- TODO: withBitmapLables pap_payload - APStackClosure {..} -> ("Function", pointer fun) : ("Frames", stack payload) : [] - BCOClosure {..} -> [ ("Instructions", pointer instrs) - , ("Literals", pointer literals) - , ("Byte Code Objects", pointer bcoptrs) - ] - ArrWordsClosure {} -> [] - MutArrClosure {..} -> withIxLables mccPayload - SmallMutArrClosure {..} -> withIxLables mccPayload - MutVarClosure {..} -> [("Value", pointer var)] - MVarClosure {..} -> [ ("Queue Head", pointer queueHead) - , ("Queue Tail", pointer queueTail) - , ("Value", pointer value) - ] - FunClosure {..} -> - [ ("SRT", pointer cp) | Just cp <- [getSrt srt]] - ++ withArgLables ptrArgs - BlockingQueueClosure {..} -> [ ("Link", pointer link) - , ("Black Hole", pointer blackHole) - , ("Owner", pointer owner) - , ("Queue", pointer queue) - ] - OtherClosure {..} -> ("",) . pointer <$> hvalues - TRecChunkClosure{} -> [] --TODO - UnsupportedClosure {} -> [] - where - withIxLables elements = [("[" <> show i <> "]" , pointer x) | (i, x) <- zip [(0::Int)..] elements] - withArgLables ptrArgs = [("Argument " <> show i, pointer x) | (i, x) <- zip [(0::Int)..] ptrArgs] - withFieldLables ptrArgs = [("Field " <> show i , pointer x) | (i, x) <- zip [(0::Int)..] ptrArgs] --- withBitmapLables pap = [("Argument " <> show i , Left x) | (i, SPtr x) <- zip [(0::Int)..] (getValues pap)] - --- diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,1245 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} - -module Main where - -import Brick -import Brick.BChan -import Brick.Forms -import Brick.Widgets.Border -import Brick.Widgets.Center (centerLayer, hCenter) -import Brick.Widgets.List -import Control.Applicative -import Control.Monad (forever, forM) -import Control.Monad.IO.Class -import Control.Monad.Catch (bracket) -import Control.Concurrent -import qualified Data.List as List -import Data.Ord (comparing) -import qualified Data.Ord as Ord -import qualified Data.Sequence as Seq -import qualified Graphics.Vty as Vty -import qualified Graphics.Vty.CrossPlatform as Vty -import Graphics.Vty.Input.Events (Key(..)) -import Lens.Micro.Platform -import System.Directory -import System.FilePath -import Data.Bool -import Data.Text (Text, pack) -import qualified Data.Text as T -import qualified Data.Map as M -import qualified Data.ByteString.Lazy as BS -import qualified Data.Set as S -import qualified Data.Foldable as F -import Text.Read (readMaybe) - -import qualified GHC.Debug.Profile as GDP -import GHC.Debug.Profile.Types -import Data.Semigroup - -import GHC.Debug.Types.Ptr(readInfoTablePtr, arrWordsBS) -import qualified GHC.Debug.Types.Closures as Debug -import IOTree -import Lib as GD -import Model -import Data.ByteUnits -import Data.Time.Format -import Data.Time.Clock -import qualified Numeric - - -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 - [ hBox - [ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):" - ] - , renderList - (\elIsSelected socketPath -> (if elIsSelected then highlighted else id) $ hBox - [ txt (socketName socketPath) - , txt " - " - , txt (renderSocketTime socketPath) - ] - ) - True - vals - , vLimit 1 $ withAttr menuAttr $ hBox [txt $ "(ESC): exit | (TAB): toggle " <> other_herald <> " view", fill ' '] - ] - -mainBorder :: Text -> Widget a -> Widget a -mainBorder title w = -- borderWithLabel (txt title) . padAll 1 - vLimit 1 (withAttr menuAttr $ hCenter $ fill ' ' <+> txt title <+> fill ' ') <=> w - -myAppDraw :: AppState -> [Widget Name] -myAppDraw (AppState majorState' _) = - case majorState' of - - Setup setupKind' dbgs snaps -> - case setupKind' of - Socket -> [drawSetup "process" "snapshots" dbgs] - Snapshot -> [drawSetup "snapshot" "processes" snaps] - - - Connected socket _debuggee mode' -> case mode' of - - RunningMode -> [mainBorder ("ghc-debug - Running - " <> socketName socket) $ vBox - [ txtWrap "There is nothing you can do until the process is paused by pressing (p) ..." - , fill ' ' - , withAttr menuAttr $ vLimit 1 $ hBox [txt "(p): Pause | (ESC): Exit", fill ' '] - ]] - - (PausedMode os@(OperationalState _ last_task treeMode' kbmode fmode _ _ _ _ rfilters debuggeeVersion)) -> let - last_task_string = - case last_task of - Nothing -> "" - Just (d,t) -> " - " <> d <> " (" <> T.pack (formatTime defaultTimeLocale "%2Es" t) <> "s)" - - in kbOverlay kbmode debuggeeVersion - $ [mainBorder ("ghc-debug - Paused - " <> socketName socket <> last_task_string) $ vBox - [ -- Current closure details - joinBorders $ (borderWithLabel (txt "Closure Details") $ - (vLimit 9 $ - pauseModeTree (\r io -> maybe emptyWidget r (ioTreeSelection io)) os - <=> fill ' ')) - <+> (filterWindow rfilters) - , -- Tree - joinBorders $ borderWithLabel - (txt $ case treeMode' of - SavedAndGCRoots {} -> "Root Closures" - Retainer {} -> "Retainers" - Searched {} -> "Search Results" - ) - (pauseModeTree (\_ -> renderIOTree) os) - , footer (osSize os) (_resultSize os) fmode - ]] - - where - - kbOverlay :: OverlayMode -> GD.Version -> [Widget Name] -> [Widget Name] - kbOverlay KeybindingsShown _ ws = centerLayer kbWindow : ws - kbOverlay (CommandPicker inp cmd_list _) debuggeeVersion ws = centerLayer (cpWindow debuggeeVersion inp cmd_list) : ws - kbOverlay NoOverlay _ ws = ws - - filterWindow [] = emptyWidget - filterWindow xs = borderWithLabel (txt "Filters") $ hLimit 50 $ vBox $ map renderUIFilter xs - - cpWindow :: GD.Version -> Form Text () Name -> GenericList Name Seq.Seq Command -> Widget Name - cpWindow debuggeeVersion 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 debuggeeVersion else renderCommand debuggeeVersion) False cmd_list] - - kbWindow :: Widget Name - kbWindow = - withAttr menuAttr $ - borderWithLabel (txt "Keybindings") $ vBox $ - map renderCommandDesc all_keys - - all_keys = - [ ("Resume", Just (Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl])) - , ("Parent", Just (Vty.EvKey KLeft [])) - , ("Child", Just (Vty.EvKey KRight [])) - , ("Command Picker", Just (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl])) - , ("Invert Filter", Just invertFilterEvent)] - ++ [(commandDescription cmd, commandKey cmd) | cmd <- F.toList commandList ] - ++ [ ("Exit", Just (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 (KFun n) []) = "(F" <> T.pack (show n) <> ")" - 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 = "�" - - mayDisableMenuItem debuggeeVersion cmd - | isCmdDisabled debuggeeVersion cmd = disabledMenuItem - | otherwise = id - - renderCommand debuggeeVersion cmd = - mayDisableMenuItem debuggeeVersion cmd $ - renderCommandDesc (commandDescription cmd, commandKey cmd) - - renderCommandDesc :: (Text, Maybe Vty.Event) -> Widget Name - renderCommandDesc (desc, k) = txt (desc <> T.replicate padding " " <> key) - where - key = maybe mempty renderKey k - padding = (actual_width - T.length desc - T.length key) - -renderInfoInfo :: InfoInfo -> [Widget Name] -renderInfoInfo info' = - maybe [] renderSourceInformation (_sourceLocation info') - ++ profHeaderInfo - -- TODO these aren't actually implemented yet - -- , txt $ "Type " - -- <> fromMaybe "" (_closureType =<< cd) - -- , txt $ "Constructor " - -- <> fromMaybe "" (_constructor =<< cd) - where - profHeaderInfo = case _profHeaderInfo info' of - Just x -> - let plabel = case x of - Debug.RetainerHeader{} -> "Retainer info" - Debug.LDVWord{} -> "LDV info" - Debug.EraWord{} -> "Era" - Debug.OtherHeader{} -> "Other" - in [labelled plabel $ vLimit 1 (txt $ renderProfHeaderInline x)] - Nothing -> [] - - renderProfHeaderInline :: ProfHeaderWord -> Text - renderProfHeaderInline pinfo = - case pinfo of - Debug.RetainerHeader {} -> pack (show pinfo) -- This should never be visible - Debug.LDVWord {state, creationTime, lastUseTime} -> - (if state then "✓" else "✘") <> " created: " <> pack (show creationTime) <> (if state then " last used: " <> pack (show lastUseTime) else "") - Debug.EraWord era -> pack (show era) - Debug.OtherHeader other -> "Not supported: " <> pack (show other) - -renderSourceInformation :: SourceInformation -> [Widget Name] -renderSourceInformation (SourceInformation name cty ty label' modu loc) = - [ labelled "Name" $ vLimit 1 (str name) - , labelled "Closure type" $ vLimit 1 (str (show cty)) - , labelled "Type" $ vLimit 3 (str ty) - , labelled "Label" $ vLimit 1 (str label') - , labelled "Module" $ vLimit 1 (str modu) - , labelled "Location" $ vLimit 1 (str loc) - ] - -labelled :: Text -> Widget Name -> Widget Name -labelled = labelled' 20 - -labelled' :: Int -> Text -> Widget Name -> Widget Name -labelled' leftSize lbl w = - hLimit leftSize (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ') - -renderUIFilter :: UIFilter -> Widget Name -renderUIFilter (UIAddressFilter invert x) = labelled (bool "" "!" invert <> "Closure address") (str (show x)) -renderUIFilter (UIInfoAddressFilter invert x) = labelled (bool "" "!" invert <> "Info table address") (str (show x)) -renderUIFilter (UIConstructorFilter invert x) = labelled (bool "" "!" invert <> "Constructor name") (str x) -renderUIFilter (UIInfoNameFilter invert x) = labelled (bool "" "!" invert <> "Constructor name (exact)") (str x) -renderUIFilter (UIEraFilter invert x) = labelled (bool "" "!" invert <> "Era range") (str (showEraRange x)) -renderUIFilter (UISizeFilter invert x) = labelled (bool "" "!" invert <> "Size (lower bound)") (str (show $ getSize x)) -renderUIFilter (UIClosureTypeFilter invert x) = labelled (bool "" "!" invert <> "Closure type") (str (show x)) -renderUIFilter (UICcId invert x) = labelled (bool "" "!" invert <> "CC Id") (str (show x)) - - -renderClosureDetails :: ClosureDetails -> Widget Name -renderClosureDetails (cd@(ClosureDetails {})) = - vLimit 8 $ - -- viewport Connected_Paused_ClosureDetails Both $ - vBox $ - renderInfoInfo (_info cd) - ++ - [ hBox - [ txtLabel "Exclusive Size" <+> vSpace <+> renderBytes (GD.getSize $ _excSize cd) - ] - ] -renderClosureDetails ((LabelNode n)) = txt n -renderClosureDetails ((InfoDetails info')) = vLimit 8 $ vBox $ renderInfoInfo info' -renderClosureDetails (CCSDetails _ _ptr (Debug.CCSPayload{..})) = vLimit 8 $ vBox $ - [ labelled "ID" $ vLimit 1 (str $ show ccsID) - ] ++ renderCCPayload ccsCc -renderClosureDetails (CCDetails _ c) = vLimit 8 $ vBox $ renderCCPayload c - -renderCCPayload :: CCPayload -> [Widget Name] -renderCCPayload Debug.CCPayload{..} = - [ labelled "Label" $ vLimit 1 (str ccLabel) - , labelled "CC ID" $ vLimit 1 (str $ show ccID) - , labelled "Module" $ vLimit 1 (str ccMod) - , labelled "Location" $ vLimit 1 (str ccLoc) - , labelled "Allocation" $ vLimit 1 (str $ show ccMemAlloc) - , labelled "Time Ticks" $ vLimit 1 (str $ show ccTimeTicks) - , labelled "Is CAF" $ vLimit 1 (str $ show ccIsCaf) - ] - -renderBytes :: Real a => a -> Widget n -renderBytes n = - str (getShortHand (getAppropriateUnits (ByteValue (realToFrac n) Bytes))) - - - -footer :: Int -> Maybe Int -> FooterMode -> Widget Name -footer n m fmode = vLimit 1 $ - case fmode of - FooterMessage t -> withAttr menuAttr $ hBox [txt t, fill ' '] - FooterInfo -> withAttr menuAttr $ hBox $ [padRight Brick.Max $ txt "(↑↓): select item | (→): expand | (←): collapse | (^p): command picker | (^g): invert filter | (?): full keybindings"] - ++ [padLeft (Pad 1) $ str $ - (show n <> " items/" <> maybe "∞" show m <> " max")] - FooterInput _im form -> renderForm form - -footerInput :: FooterInputMode -> FooterMode -footerInput im = - FooterInput im (footerInputForm im) - -footerInputForm :: FooterInputMode -> Form Text e Name -footerInputForm im = - newForm [(\w -> txtLabel (formatFooterMode im) <+> forceAttr inputAttr w) @@= editTextField id Footer (Just 1)] "" - -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 - -- first. - debuggeeSockets <- List.sortBy (comparing Ord.Down) - <$> mapM (mkSocketInfo . (dir )) debuggeeSocketFiles - - let currentSelectedPathMay :: Maybe SocketInfo - currentSelectedPathMay = fmap snd (listSelectedElement llist) - - newSelection :: Maybe Int - newSelection = do - currentSelectedPath <- currentSelectedPathMay - List.findIndex ((currentSelectedPath ==)) debuggeeSockets - - return $ listReplace - (Seq.fromList debuggeeSockets) - (newSelection <|> (if Prelude.null debuggeeSockets then Nothing else Just 0)) - llist - - -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 - - VtyEvent (Vty.EvKey KEsc _) -> halt - VtyEvent event -> case event of - -- Connect to the selected debuggee - Vty.EvKey (KChar '\t') [] -> do - put $ appState & majorState . setupKind %~ toggleSetup - Vty.EvKey KEnter _ -> - case st of - Snapshot - | Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots' - -> do - debuggee' <- liftIO $ snapshotConnect (writeBChan eventChan . ProgressMessage) (view socketLocation socket) - put $ 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 (writeBChan eventChan . ProgressMessage) (view socketLocation socket)) - (\debuggee' -> liftIO $ resume debuggee') - (\debuggee' -> - put $ appState & majorState .~ Connected - { _debuggeeSocket = socket - , _debuggee = debuggee' - , _mode = RunningMode -- TODO should we query the debuggee for this? - }) - _ -> return () - - -- Navigate through the list. - _ -> do - case st of - Snapshot -> do - zoom (majorState . knownSnapshots) (handleListEventVi handleListEvent event) - Socket -> do - zoom (majorState . knownDebuggees) (handleListEventVi handleListEvent event) - - AppEvent event -> case event of - PollTick -> do - -- Poll for debuggees - knownDebuggees'' <- updateListFrom socketDirectory knownDebuggees' - knownSnapshots'' <- updateListFrom snapshotDirectory knownSnapshots' - put $ appState & majorState . knownDebuggees .~ knownDebuggees'' - & majorState . knownSnapshots .~ knownSnapshots'' - _ -> return () - _ -> return () - - Connected _socket' debuggee' mode' -> case mode' of - - RunningMode -> case brickEvent of - -- Exit - VtyEvent (Vty.EvKey KEsc _) -> - halt - -- Pause the debuggee - VtyEvent (Vty.EvKey (KChar 'p') []) -> do - liftIO $ pause debuggee' - ver <- liftIO $ GD.version debuggee' - (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree - put (appState & majorState . mode .~ - PausedMode - (OperationalState Nothing - Nothing - savedAndGCRoots - NoOverlay - FooterInfo - (DefaultRoots initRoots) - rootsTree - eventChan - (Just 100) - [] - ver)) - - - - _ -> return () - - 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) - - - - where - - - mkSavedAndGCRootsIOTree = do - raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures debuggee' - rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee') raw_roots - raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee' - savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee') raw_saved - return $ (mkIOTree debuggee' (savedClosures' ++ rootClosures') getChildren renderInlineClosureDesc id - , fmap toPtr <$> (raw_roots ++ raw_saved)) - - -getChildren :: Debuggee -> ClosureDetails - -> IO [ClosureDetails] -getChildren _ LabelNode{} = return [] -getChildren _ CCDetails {} = return [] -getChildren _ InfoDetails {} = return [] -getChildren d (ClosureDetails c _ _) = do - children <- closureReferences d c - children' <- traverse (traverse (fillListItem d)) children - mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children' -getChildren d (CCSDetails _ _ cp) = do - references <- zip [0 :: Int ..] <$> ccsReferences d cp - mapM (\(lbl, cc) -> getClosureDetails d (pack (show lbl)) cc) references - - -fillListItem :: Debuggee - -> ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr - -> IO (ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr) -fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x -fillListItem d (ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd -fillListItem _ ListData = return ListData -fillListItem _ (ListCCS c1 c2) = return $ ListCCS c1 c2 -fillListItem _ (ListCC c1) = return $ ListCC c1 - -mkIOTree :: Debuggee - -> [a] - -> (Debuggee -> a -> IO [a]) - -> (a -> [Widget Name]) --- -> IO [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)]) - -> ([a] -> [a]) - -> IOTree a Name -mkIOTree debuggee' cs getChildrenGen renderNode sort = ioTree Connected_Paused_ClosureTree - (sort cs) - (\c -> sort <$> getChildrenGen debuggee' c --- cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children --- return (sort cDets) - ) - -- rendering the row - (\state selected ctx depth closureDesc -> - let - body = - (if selected then visible . highlighted else id) $ - hBox $ - renderNode closureDesc - in - vdecorate state ctx depth body -- body (T.concat context) - ) - -era_colors :: [Vty.Color] -era_colors = [Vty.Color240 n | n <- [17..230]] - -grey :: Vty.Color -grey = Vty.rgbColor (158 :: Int) 158 158 - --- | Draw the tree structure around the row item. Inspired by the --- 'border' functions in brick. --- -vdecorate :: RowState -> RowCtx -> [RowCtx] -> Widget n -> Widget n -vdecorate state ctx depth body = - Widget Fixed Fixed $ do - c <- getContext - - let decorationWidth = 2 * length depth + 4 - - bodyResult <- - render $ - hLimit (c ^. availWidthL - decorationWidth) $ - vLimit (c ^. availHeightL) $ - body - - let leftTxt = - T.concat $ - map - (\ x -> case x of - LastRow -> " " - NotLastRow -> "│ " - ) - (List.reverse depth) - leftPart = withAttr treeAttr (vreplicate leftTxt) - middleTxt1 = - case ctx of - LastRow -> "└─" - NotLastRow -> "├─" - middleTxt1' = - case ctx of - LastRow -> " " - NotLastRow -> "│ " - middleTxt2 = - case state of - Expanded True -> "● " -- "⋅" - Expanded False -> "┐ " - Collapsed -> "┄ " - middleTxt2' = - case state of - Expanded True -> " " - Expanded False -> "│ " - Collapsed -> " " - middlePart = - withAttr treeAttr $ - (txt middleTxt1 <=> vreplicate middleTxt1') - <+> (txt middleTxt2 <=> vreplicate middleTxt2') - rightPart = Widget Fixed Fixed $ return bodyResult - total = leftPart <+> middlePart <+> rightPart - - render $ - hLimit (bodyResult ^. imageL . to Vty.imageWidth + decorationWidth) $ - vLimit (bodyResult ^. imageL . to Vty.imageHeight) $ - total - -vreplicate :: Text -> Widget n -vreplicate t = - Widget Fixed Greedy $ do - c <- getContext - return $ emptyResult & imageL .~ Vty.vertCat (replicate (c ^. availHeightL) (Vty.text' (c ^. attrL) t)) -{- - hBox - [ withAttr treeAttr $ Widget Fixed Fixed $ do - c <- getContext - limitedResult <- render (hLimit (c ^. availWidthL - T.length t) $ vLimit (c ^. availHeightL) $ body) - return $ emptyResult & imageL .~ vertCat (replicate (limitedResult ^. imageL . to imageHeight) (text' (c ^. attrL) t)) - , body - ] - where - bodyWidth = - render (hLimit (c ^. availWidthL - (length depth * 2 + 4)) $ vLimit (c ^. availHeightL) $ body) --} - -renderInlineClosureDesc :: ClosureDetails -> [Widget n] -renderInlineClosureDesc (LabelNode t) = [txtLabel t] -renderInlineClosureDesc (InfoDetails info') = - [txtLabel (_labelInParent info'), vSpace, txt (_pretty info')] -renderInlineClosureDesc (CCSDetails clabel _cptr ccspayload) = - [ txtLabel clabel, vSpace, txt (prettyCCS ccspayload)] -renderInlineClosureDesc (CCDetails clabel cc) = - [ txtLabel clabel, vSpace, txt (prettyCC cc)] -renderInlineClosureDesc closureDesc@(ClosureDetails{}) = - [ txtLabel (_labelInParent (_info closureDesc)) - , colorBar - , txt $ pack (closureShowAddress (_closure closureDesc)) - , vSpace - , txtWrap $ _pretty (_info closureDesc) - ] - where - colorBar = - case colorId of - Just {} -> padLeftRight 1 (colorEra (txt " ")) - Nothing -> vSpace - - colorId = _profHeaderInfo $ _info closureDesc - colorEra = case colorId of - Just (Debug.EraWord i) -> modifyDefAttr (flip Vty.withBackColor (era_colors !! (1 + (fromIntegral $ abs i) `mod` (length era_colors - 1)))) - Just (Debug.LDVWord {state}) -> case state of - -- Used - True -> modifyDefAttr (flip Vty.withBackColor Vty.green) - -- Unused - False -> id - _ -> id - -prettyCCS :: GenCCSPayload CCSPtr CCPayload -> Text -prettyCCS Debug.CCSPayload{ccsCc = cc} = prettyCC cc - -prettyCC :: CCPayload -> Text -prettyCC Debug.CCPayload{..} = - T.pack ccLabel <> " " <> T.pack ccMod <> " " <> T.pack ccLoc - -completeClosureDetails :: Debuggee -> (Text, DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) - -> IO ClosureDetails - -completeClosureDetails dbg (label', clos) = - getClosureDetails dbg label' . ListFullClosure =<< fillConstrDesc dbg clos - - - -getClosureDetails :: Debuggee - -> Text - -> ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr - -> IO ClosureDetails -getClosureDetails debuggee' t (ListOnlyInfo info_ptr) = do - info' <- getInfoInfo debuggee' t info_ptr - return $ InfoDetails info' -getClosureDetails _ plabel (ListCCS ccs payload) = return $ CCSDetails plabel ccs payload -getClosureDetails _ plabel (ListCC cc) = return $ CCDetails plabel cc -getClosureDetails _ t ListData = return $ LabelNode t -getClosureDetails debuggee' label' (ListFullClosure c) = do - let excSize' = closureExclusiveSize c - sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c) - pretty' <- closurePretty debuggee' c - return ClosureDetails - { _closure = c - , _info = InfoInfo { - _pretty = pack pretty' - , _labelInParent = label' - , _sourceLocation = sourceLoc - , _closureType = Just (T.pack $ show c) - , _constructor = Nothing - , _profHeaderInfo = case c of - Closure{_closureSized=c1} -> Debug.hp <$> Debug.profHeader (Debug.unDCS c1) - _ -> Nothing - } - , _excSize = excSize' - } - -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 - , _profHeaderInfo = Nothing - } - - --- Event handling when the main window has focus - -handleMain :: Debuggee -> Handler Event OperationalState -handleMain dbg e = do - os <- get - case e of - AppEvent event -> case event of - PollTick -> return () - ProgressMessage t -> do - put $ footerMessage t os - ProgressFinished desc runtime -> - put $ os - & running_task .~ Nothing - & last_run_time .~ Just (desc, runtime) - & footerMode .~ FooterInfo - 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 orig_cmds -> 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 )) orig_cmds - cmd_list'' = cmd_list' - & listElementsL .~ new_elems - & listSelectedL .~ if Seq.null new_elems then Nothing else Just 0 - modify $ keybindingsMode .~ CommandPicker form' cmd_list'' orig_cmds - else - modify $ keybindingsMode .~ CommandPicker form' cmd_list' orig_cmds - - - 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) - | isCmdDisabled (_version os) cmd -> - return () -- If the command is disabled, just ignore the key press - | otherwise -> do - modify $ keybindingsMode .~ NoOverlay - dispatchCommand cmd dbg - Nothing -> return () - _ -> do - form' <- handle_form - list' <- handle_list - k form' list' - - - NoOverlay -> case view footerMode os of - FooterInput fm form -> inputFooterHandler dbg fm form (handleMainWindowEvent dbg) (() <$ e) - _ -> handleMainWindowEvent dbg (() <$ e) - _ -> return () - -commandPickerMode :: OverlayMode -commandPickerMode = - CommandPicker - (newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] "") - (list CommandPicker_List commandList 1) - commandList - -savedAndGCRoots :: TreeMode -savedAndGCRoots = SavedAndGCRoots renderClosureDetails - --- ---------------------------------------------------------------------------- --- Commands and Shortcut constants --- ---------------------------------------------------------------------------- - -invertFilterEvent :: Vty.Event -invertFilterEvent = Vty.EvKey (KChar 'g') [Vty.MCtrl] - -isInvertFilterEvent :: Vty.Event -> Bool -isInvertFilterEvent = (invertFilterEvent ==) - --- All the commands which we support, these show up in keybindings and also the command picker -commandList :: Seq.Seq Command -commandList = - [ mkCommand "Show key bindings" (Vty.EvKey (KChar '?') []) (modify $ keybindingsMode .~ KeybindingsShown) - , mkCommand "Clear filters" (withCtrlKey 'w') (modify $ clearFilters) - , Command "Search with current filters" (Just $ withCtrlKey 'f') searchWithCurrentFilters NoReq - , mkCommand "Set search limit (default 100)" (withCtrlKey 'l') (setFooterInputMode FSetResultSize) - , mkCommand "Saved/GC Roots" (withCtrlKey 's') (modify $ treeMode .~ savedAndGCRoots) - , mkCommand "Find Address" (withCtrlKey 'a') (setFooterInputMode (FClosureAddress True False)) - , mkCommand "Find Info Table" (withCtrlKey 't') (setFooterInputMode (FInfoTableAddress True False)) - , mkCommand "Find Retainers" (withCtrlKey 'e') (setFooterInputMode (FConstructorName True False)) - , mkCommand' "Find Retainers (Exact)" (setFooterInputMode (FClosureName True False)) - , mkFilterCmd "Find closures by era" (withCtrlKey 'v') (setFooterInputMode (FFilterEras True False)) ReqErasProfiling - , mkCommand "Find Retainers of large ARR_WORDS" (withCtrlKey 'u') (setFooterInputMode FArrWordsSize) - , mkCommand "Dump ARR_WORDS payload" (withCtrlKey 'j') (setFooterInputMode FDumpArrWords) - , mkCommand "Write Profile" (withCtrlKey 'b') (setFooterInputMode (FProfile OneLevel)) - , mkCommand' "Write Profile (2 level)" (setFooterInputMode (FProfile TwoLevel)) - , Command "Thunk Analysis" Nothing thunkAnalysisAction NoReq - , mkCommand "Take Snapshot" (withCtrlKey 'x') (setFooterInputMode FSnapshot) - , Command "ARR_WORDS Count" Nothing arrWordsAction NoReq - , Command "Strings Count" Nothing stringsAction NoReq - ] <> addFilterCommands - where - setFooterInputMode m = modify $ footerMode .~ footerInput m - - addFilterCommands :: Seq.Seq Command - addFilterCommands = - [ mkCommand' "Add filter for address" (setFooterInputMode (FClosureAddress False False)) - , mkCommand' "Add filter for info table ptr" (setFooterInputMode (FInfoTableAddress False False)) - , mkCommand' "Add filter for constructor name" (setFooterInputMode (FConstructorName False False)) - , mkCommand' "Add filter for closure name" (setFooterInputMode (FClosureName False False)) - , mkFilterCmd' "Add filter for era" (setFooterInputMode (FFilterEras False False)) ReqErasProfiling - , mkFilterCmd' "Add filter for cost centre id" (setFooterInputMode (FFilterCcId False False)) ReqSomeProfiling - , mkCommand' "Add filter for closure size" (setFooterInputMode (FFilterClosureSize False)) - , mkCommand' "Add filter for closure type" (setFooterInputMode (FFilterClosureType False)) - , mkCommand' "Add exclusion for address" (setFooterInputMode (FClosureAddress False True)) - , mkCommand' "Add exclusion for info table ptr" (setFooterInputMode (FInfoTableAddress False True)) - , mkCommand' "Add exclusion for constructor name" (setFooterInputMode (FConstructorName False True)) - , mkCommand' "Add exclusion for closure name" (setFooterInputMode (FClosureName False True)) - , mkFilterCmd' "Add exclusion for era" (setFooterInputMode (FFilterEras False True)) ReqErasProfiling - , mkFilterCmd' "Add exclusion for cost centre id" (setFooterInputMode (FFilterCcId False True)) ReqSomeProfiling - , mkCommand' "Add exclusion for closure size" (setFooterInputMode (FFilterClosureSize True)) - , mkCommand' "Add exclusion for closure type" (setFooterInputMode (FFilterClosureType True)) - ] - - withCtrlKey char = Vty.EvKey (KChar char) [Vty.MCtrl] - -findCommand :: Vty.Event -> Maybe Command -findCommand event = do - i <- Seq.findIndexL (\cmd -> commandKey cmd == Just event) commandList - Seq.lookup i commandList - - --- ---------------------------------------------------------------------------- --- Window Management --- ---------------------------------------------------------------------------- - -handleMainWindowEvent :: Debuggee - -> Handler () OperationalState -handleMainWindowEvent dbg brickEvent = do - os@(OperationalState _ _ treeMode' _kbMode _footerMode _curRoots rootsTree _ _ _ debuggeeVersion) <- get - case brickEvent of - VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) -> - put $ os & keybindingsMode .~ commandPickerMode - - -- A generic event - VtyEvent event - | Just cmd <- findCommand event -> - if isCmdDisabled debuggeeVersion cmd - then return () -- Command is disabled, don't dispatch the command - else dispatchCommand cmd dbg - - -- Navigate the tree of closures - VtyEvent event -> case treeMode' of - SavedAndGCRoots {} -> do - newTree <- handleIOTreeEvent event rootsTree - put (os & treeSavedAndGCRoots .~ newTree) - Retainer r t -> do - newTree <- handleIOTreeEvent event t - put (os & treeMode .~ Retainer r newTree) - - Searched r t -> do - newTree <- handleIOTreeEvent event t - put (os & treeMode .~ Searched r newTree) - - _ -> return () - -inputFooterHandler :: Debuggee - -> FooterInputMode - -> Form Text () Name - -> Handler () OperationalState - -> Handler () OperationalState -inputFooterHandler dbg m form _k re@(VtyEvent e) = - case e of - Vty.EvKey KEsc [] -> modify resetFooter - Vty.EvKey KEnter [] -> dispatchFooterInput dbg m form - _ - | isInvertFilterEvent e -> - let m' = invertInput m in - modify (footerMode .~ (FooterInput m' (updateFormState (formState form) $ footerInputForm m'))) - | otherwise -> do - zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re) -inputFooterHandler _ _ _ k re = k re - -stringsAction :: Debuggee -> EventM n OperationalState () -stringsAction dbg = do - outside_os <- get - -- TODO: Does not honour search limit at all - asyncAction "Counting strings" outside_os (stringsAnalysis Nothing dbg) $ \res -> do - os <- get - let cmp (k, v) = length k * (S.size v) - let sorted_res = maybe id take (_resultSize os) $ Prelude.reverse [(k, S.toList v ) | (k, v) <- (List.sortBy (comparing (S.size . snd)) (M.toList res))] - - top_closure = [CountLine k (length k) (length v) | (k, v) <- sorted_res] - - g_children d (CountLine b _ _) = do - let Just cs = M.lookup b res - cs' <- run dbg $ forM (S.toList cs) $ \c -> do - c' <- GD.dereferenceClosure c - return $ ListFullClosure $ Closure c c' - children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs' - mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children' - g_children d (FieldLine c) = map FieldLine <$> getChildren d c - - renderHeaderPane (CountLine k l n) = vBox - [ labelled "Count " $ vLimit 1 $ str (show n) - , labelled "Size " $ vLimit 1 $ renderBytes l - , labelled "Total Size" $ vLimit 1 $ renderBytes (n * l) - , strWrap (take 100 $ show k) - ] - renderHeaderPane (FieldLine c) = renderClosureDetails c - - tree = mkIOTree dbg top_closure g_children renderArrWordsLines id - put (os & resetFooter - & treeMode .~ Searched renderHeaderPane tree - ) - - -data ArrWordsLine k = CountLine k Int Int | FieldLine ClosureDetails - - - -renderArrWordsLines :: Show a => ArrWordsLine a -> [Widget n] -renderArrWordsLines (CountLine k l n) = [strLabel (show n), vSpace, renderBytes l, vSpace, strWrap (take 100 $ show k)] -renderArrWordsLines (FieldLine cd) = renderInlineClosureDesc cd - --- | Render a histogram with n lines which displays the number of elements in each bucket, --- and how much they contribute to the total size. -histogram :: Int -> [GD.Size] -> Widget Name -histogram boxes m = - vBox $ map displayLine (bin 0 (map calcPercentage (List.sort m ))) - where - Size maxSize = maximum m - - calcPercentage (Size tot) = - (tot, (fromIntegral tot/ fromIntegral maxSize) * 100 :: Double) - - displayLine (l, h, n, tot) = - str (show l) <+> txt "%-" <+> str (show h) <+> str "%: " <+> str (show n) <+> str " " <+> renderBytes tot - - step = fromIntegral (ceiling @Double @Int (100 / fromIntegral boxes)) - - bin _ [] = [] - bin k xs = case now of - [] -> bin (k + step) later - _ -> (k, k+step, length now, sum (map fst now)) : bin (k + step) later - where - (now, later) = span ((<= k + step) . snd) xs - --- | Vertical space used to separate elements on the same line. --- --- This is standardised for a consistent UI. -vSpace :: Widget n -vSpace = txt " " - -arrWordsAction :: Debuggee -> EventM n OperationalState () -arrWordsAction dbg = do - outside_os <- get - asyncAction "Counting ARR_WORDS" outside_os (arrWordsAnalysis Nothing dbg) $ \res -> do - os <- get - let all_res = Prelude.reverse [(k, S.toList v ) | (k, v) <- (List.sortBy (comparing (\(k, v) -> fromIntegral (BS.length k) * S.size v)) (M.toList res))] - - display_res = maybe id take (_resultSize os) all_res - - top_closure = [CountLine k (fromIntegral (BS.length k)) (length v) | (k, v) <- display_res] - - !words_histogram = histogram 8 (concatMap (\(k, bs) -> let sz = BS.length k in replicate (length bs) (Size (fromIntegral sz))) all_res) - - g_children d (CountLine b _ _) = do - let Just cs = M.lookup b res - cs' <- run dbg $ forM (S.toList cs) $ \c -> do - c' <- GD.dereferenceClosure c - return $ ListFullClosure $ Closure c c' - children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs' - mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children' - g_children d (FieldLine c) = map FieldLine <$> getChildren d c - - renderHeaderPane (CountLine b l n) = vBox - [ labelled "Count" $ vLimit 1 $ str (show n) - , labelled "Size" $ vLimit 1 $ renderBytes l - , labelled "Total Size" $ vLimit 1 $ renderBytes (n * l) - , strWrap (take 100 $ show b) - ] - renderHeaderPane (FieldLine c) = renderClosureDetails c - - renderWithHistogram c = joinBorders (renderHeaderPane c <+> - (padRight (Pad 1) $ (padLeft Brick.Max $ borderWithLabel (txt "Histogram") $ hLimit 100 $ words_histogram))) - - tree = mkIOTree dbg top_closure g_children renderArrWordsLines id - put (outside_os & resetFooter - & treeMode .~ Searched renderWithHistogram tree - ) - -data ThunkLine = ThunkLine (Maybe SourceInformation) Count - -thunkAnalysisAction :: Debuggee -> EventM n OperationalState () -thunkAnalysisAction dbg = do - outside_os <- get - -- TODO: Does not honour search limit at all - asyncAction "Counting thunks" outside_os (thunkAnalysis dbg) $ \res -> do - os <- get - let top_closure = Prelude.reverse [ ThunkLine k v | (k, v) <- (List.sortBy (comparing (getCount . snd)) (M.toList res))] - - g_children _ (ThunkLine {}) = pure [] - - renderHeaderPane (ThunkLine sc c) = vBox $ - maybe [txt "NoLoc"] renderSourceInformation sc - ++ [ strWrap ("Count: " ++ show (getCount c)) ] - - renderInline (ThunkLine msc (Count c)) = - [(case msc of - Just sc -> strLabel (infoPosition sc) - Nothing -> txtLabel "NoLoc"), txt " ", str (show c) ] - - - tree = mkIOTree dbg top_closure g_children renderInline id - put (os & resetFooter - & treeMode .~ Searched renderHeaderPane tree - ) - - -searchWithCurrentFilters :: Debuggee -> EventM n OperationalState () -searchWithCurrentFilters dbg = do - outside_os <- get - let mClosFilter = uiFiltersToFilter (_filters outside_os) - asyncAction "Searching for closures" outside_os (liftIO $ retainersOf (_resultSize outside_os) mClosFilter Nothing dbg) $ \cps -> do - os <- get - let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps - res <- liftIO $ mapM (mapM (completeClosureDetails dbg)) cps' - let tree = mkRetainerTree dbg res - put (os & resetFooter - & treeMode .~ Retainer renderClosureDetails tree - ) - -filterOrRun :: Debuggee -> Form Text () Name -> Bool -> (String -> Maybe a) -> (a -> [UIFilter]) -> EventM n OperationalState () -filterOrRun dbg form doRun parse createFilter = - filterOrRunM dbg form doRun parse (pure . createFilter) - -filterOrRunM :: Debuggee -> Form Text () Name -> Bool -> (String -> Maybe a) -> (a -> EventM n OperationalState [UIFilter]) -> EventM n OperationalState () -filterOrRunM dbg form doRun parse createFilterM = do - case parse (T.unpack (formState form)) of - Just x - | doRun -> do - newFilter <- createFilterM x - modify $ setFilters newFilter - searchWithCurrentFilters dbg - | otherwise -> do - newFilter <- createFilterM x - modify $ (resetFooter . addFilters newFilter) - Nothing -> modify resetFooter - -data ProfileLine = ProfileLine GDP.ProfileKey GDP.ProfileKeyArgs CensusStats | ClosureLine ClosureDetails - -renderProfileLine :: ProfileLine -> [Widget Name] -renderProfileLine (ClosureLine c) = renderInlineClosureDesc c -renderProfileLine (ProfileLine k kargs c) = - [txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs kargs), txt " ", showLine c] - where - showLine :: CensusStats -> Widget Name - showLine (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _) = - hBox - [ withFontColor totalSizeColor $ str (show s), vSpace - , withFontColor countColor $ str (show n), vSpace - , withFontColor sizeColor $ str (show mn), vSpace - , withFontColor avgSizeColor $ str (Numeric.showFFloat @Double (Just 1) (fromIntegral s / fromIntegral n) "") - ] - - withFontColor color = modifyDefAttr (flip Vty.withForeColor color) - - totalSizeColor = Vty.RGBColor 0x26 0x83 0xDE - countColor = Vty.RGBColor 0xDE 0x66 0x26 - sizeColor = Vty.RGBColor 0x26 0xDE 0xD7 - avgSizeColor = Vty.RGBColor 0xAB 0x4D 0xE0 - - --- | What happens when we press enter in footer input mode -dispatchFooterInput :: Debuggee - -> FooterInputMode - -> Form Text () Name - -> EventM n OperationalState () -dispatchFooterInput dbg (FClosureAddress runf invert) form = filterOrRun dbg form runf readClosurePtr (pure . UIAddressFilter invert) -dispatchFooterInput dbg (FInfoTableAddress runf invert) form = filterOrRun dbg form runf readInfoTablePtr (pure . UIInfoAddressFilter invert) -dispatchFooterInput dbg (FConstructorName runf invert) form = filterOrRun dbg form runf Just (pure . UIConstructorFilter invert) -dispatchFooterInput dbg (FClosureName runf invert) form = filterOrRun dbg form runf Just (pure . UIInfoNameFilter invert) -dispatchFooterInput dbg FArrWordsSize form = filterOrRun dbg form True readMaybe (\size -> [UIClosureTypeFilter False Debug.ARR_WORDS, UISizeFilter False size]) -dispatchFooterInput dbg (FFilterEras runf invert) form = filterOrRun dbg form runf (parseEraRange . T.pack) (pure . UIEraFilter invert) -dispatchFooterInput dbg (FFilterClosureSize invert) form = filterOrRun dbg form False readMaybe (pure . UISizeFilter invert) -dispatchFooterInput dbg (FFilterClosureType invert) form = filterOrRun dbg form False readMaybe (pure . UIClosureTypeFilter invert) -dispatchFooterInput dbg (FFilterCcId runf invert) form = filterOrRun dbg form runf readMaybe (pure . UICcId invert) -dispatchFooterInput dbg (FProfile lvl) form = do - outside_os <- get - - asyncAction "Writing profile" outside_os (profile dbg lvl (T.unpack (formState form))) $ \res -> do - os <- get - let top_closure = Prelude.reverse [ProfileLine k kargs v | ((k, kargs), v) <- (List.sortBy (comparing (cssize . snd)) (M.toList res))] - - total_stats = foldMap snd (M.toList res) - - g_children d (ClosureLine c) = map ClosureLine <$> getChildren d c - g_children d (ProfileLine _ _ stats) = do - let cs = getSamples (sample stats) - cs' <- run dbg $ forM cs $ \c -> do - c' <- GD.dereferenceClosure c - return $ ListFullClosure $ Closure c c' - children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs' - mapM (\(lbl, child) -> ClosureLine <$> getClosureDetails d (pack lbl) child) children' - - renderHeaderPane (ClosureLine cs) = renderClosureDetails cs - renderHeaderPane (ProfileLine k args (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _)) = vBox $ - [ txtLabel "Label " <+> vSpace <+> txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs args) - ] - <> - (case k of - GDP.ProfileConstrDesc desc -> - [ txtLabel "Package " <+> vSpace <+> (txt (GDP.pkgsText desc)) - , txtLabel "Module " <+> vSpace <+> (txt (GDP.modlText desc)) - , txtLabel "Constructor" <+> vSpace <+> (txt (GDP.nameText desc)) - ] - _ -> [] - ) - <> - [ txtLabel "Count " <+> vSpace <+> str (show n) - , txtLabel "Size " <+> vSpace <+> renderBytes s - , txtLabel "Max " <+> vSpace <+> renderBytes mn - , txtLabel "Average " <+> vSpace <+> renderBytes @Double (fromIntegral s / fromIntegral n) - ] - - renderWithStats l = joinBorders $ renderHeaderPane l <+> - (padRight (Pad 1) $ (padLeft Brick.Max $ renderHeaderPane (ProfileLine (GDP.ProfileClosureDesc "Total") GDP.NoArgs total_stats))) - - - tree :: IOTree ProfileLine Name - tree = mkIOTree dbg top_closure g_children renderProfileLine id - put (os & resetFooter - & treeMode .~ Searched renderWithStats tree - ) -dispatchFooterInput _ FDumpArrWords form = do - os <- get - let act node = asyncAction_ "dumping ARR_WORDS payload" os $ - case node of - Just ClosureDetails{_closure = Closure{_closureSized = Debug.unDCS -> Debug.ArrWordsClosure{bytes, arrWords}}} -> - BS.writeFile (T.unpack $ formState form) $ arrWordsBS (take (fromIntegral bytes) arrWords) - _ -> pure () - case view treeMode os of - Retainer _ iotree -> act (ioTreeSelection iotree) - SavedAndGCRoots _ -> act (ioTreeSelection (view treeSavedAndGCRoots os)) - Searched {} -> put (os & footerMessage "Dump for search mode not implemented yet") -dispatchFooterInput _ FSetResultSize form = do - outside_os <- get - asyncAction "setting result size" outside_os (pure ()) $ \() -> do - os <- get - case readMaybe $ T.unpack (formState form) of - Just n - | n <= 0 -> put (os & resultSize .~ Nothing) - | otherwise -> put (os & resultSize .~ (Just n)) - Nothing -> pure () -dispatchFooterInput dbg FSnapshot form = do - os <- get - asyncAction_ "Taking snapshot" os $ snapshot dbg (T.unpack (formState form)) - -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) - start <- getCurrentTime - res <- action - end <- getCurrentTime - writeBChan eventChan (AsyncFinished (final res)) - writeBChan eventChan (ProgressFinished desc (end `diffUTCTime` start))) - 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 [(Text, (DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))] - info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((T.pack (show n)), (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map] - - lookup_c dbg' dc'@(ClosureDetails dc _ _) = do - let ptr = toPtr dc - results = M.findWithDefault [] ptr info_map - -- We are also looking up the children of the object we are retaining, - -- and displaying them prior to the retainer stack - cs <- getChildren dbg' dc' - results' <- liftIO $ mapM (\(l, c) -> getClosureDetails dbg' l (ListFullClosure c)) results - return (cs ++ results') - -- And if it's not a closure, just do the normal thing - lookup_c dbg' dc' = getChildren dbg' dc' - - mkIOTree dbg roots lookup_c renderInlineClosureDesc id - -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 () - -myAppAttrMap :: AppState -> AttrMap -myAppAttrMap _appState = - attrMap (Vty.withStyle (Vty.white `on` Vty.black) Vty.dim) - [ (menuAttr, Vty.withStyle (Vty.white `on` Vty.blue) Vty.bold) - , (inputAttr, Vty.black `on` Vty.green) - , (labelAttr, Vty.withStyle (fg Vty.white) Vty.bold) - , (highlightAttr, Vty.black `on` Vty.yellow) - , (treeAttr, fg Vty.red) - , (disabledMenuAttr, Vty.withStyle (grey `on` Vty.blue) Vty.bold) - ] - -menuAttr :: AttrName -menuAttr = attrName "menu" - -inputAttr :: AttrName -inputAttr = attrName "input" - -labelAttr :: AttrName -labelAttr = attrName "label" - -treeAttr :: AttrName -treeAttr = attrName "tree" - -highlightAttr :: AttrName -highlightAttr = attrName "highlighted" - -disabledMenuAttr :: AttrName -disabledMenuAttr = attrName "disabledMenu" - -txtLabel :: Text -> Widget n -txtLabel = withAttr labelAttr . txt - -strLabel :: String -> Widget n -strLabel = withAttr labelAttr . str - -highlighted :: Widget n -> Widget n -highlighted = forceAttr highlightAttr - -disabledMenuItem :: Widget n -> Widget n -disabledMenuItem = forceAttr disabledMenuAttr - -main :: IO () -main = do - eventChan <- newBChan 10 - _ <- forkIO $ forever $ do - writeBChan eventChan PollTick - -- 2s - threadDelay 2_000_000 - let buildVty = Vty.mkVty Vty.defaultConfig - initialVty <- buildVty - let app :: App AppState Event Name - app = App - { appDraw = myAppDraw - , appChooseCursor = showFirstCursor - , appHandleEvent = myAppHandleEvent - , appStartEvent = myAppStartEvent - , appAttrMap = myAppAttrMap - } - _finalState <- customMain initialVty buildVty - (Just eventChan) app (initialAppState eventChan) - return () diff --git a/src/Model.hs b/src/Model.hs deleted file mode 100644 --- a/src/Model.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Model - ( module Model - , module Namespace - , module Common - ) where - -import Data.Maybe (fromMaybe) -import Data.Sequence as Seq -import Lens.Micro.Platform -import Data.Time -import System.Directory -import System.FilePath -import Data.Text(Text, pack) -import qualified Data.Text as T -import Text.Read - -import Brick.Forms -import Brick.BChan -import Brick (EventM, Widget) -import Brick.Widgets.List - -import Namespace -import Common -import Lib -import IOTree -import Control.Concurrent -import qualified Graphics.Vty as Vty -import Data.Int -import GHC.Debug.Client (ccID) -import GHC.Debug.Client.Monad (DebugM) -import GHC.Debug.CostCentres (findAllChildrenOfCC) -import qualified GHC.Debug.Types as GD -import qualified GHC.Debug.Types.Version as GD - - -data Event - = PollTick -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees - | ProgressMessage Text - | ProgressFinished Text NominalDiffTime - | AsyncFinished (EventM Name OperationalState ()) - - -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 -mkSocketInfo fp = SocketInfo fp <$> getModificationTime fp - -socketName :: SocketInfo -> Text -socketName = pack . takeFileName . _socketLocation - -renderSocketTime :: SocketInfo -> Text -renderSocketTime = pack . formatTime defaultTimeLocale "%c" . _socketCreated - -data SocketInfo = SocketInfo - { _socketLocation :: FilePath -- ^ FilePath to socket, absolute path - , _socketCreated :: UTCTime -- ^ Time of socket creation - } deriving Eq - -instance Ord SocketInfo where - compare (SocketInfo s1 t1) (SocketInfo s2 t2) = - -- 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 - { _setupKind :: SetupKind - , _knownDebuggees :: GenericList Name Seq SocketInfo - , _knownSnapshots :: GenericList Name Seq SnapshotInfo - } - - -- | Connected to a debuggee - | Connected - { _debuggeeSocket :: SocketInfo - , _debuggee :: Debuggee - , _mode :: ConnectedMode - } - -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 - , _profHeaderInfo :: !(Maybe ProfHeaderWord) - } deriving Show - -data ClosureDetails = ClosureDetails - { _closure :: DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr - , _excSize :: Size - , _info :: InfoInfo - } - | InfoDetails { _info :: InfoInfo } - | CCSDetails Text CCSPtr (GenCCSPayload CCSPtr CCPayload) - | CCDetails Text CCPayload - | LabelNode { _label :: Text } deriving Show - -data TreeMode = SavedAndGCRoots (ClosureDetails -> Widget Name) - | Retainer (ClosureDetails -> Widget Name) (IOTree (ClosureDetails) Name) - | forall a . Searched (a -> Widget Name) (IOTree a Name) - -treeLength :: TreeMode -> Maybe Int -treeLength (SavedAndGCRoots {}) = Nothing -treeLength (Retainer _ tree) = Just $ Prelude.length $ getIOTreeRoots tree -treeLength (Searched _ tree) = Just $ Prelude.length $ getIOTreeRoots tree - -data FooterMode = FooterInfo - | FooterMessage Text - | FooterInput FooterInputMode (Form Text () Name) - -isFocusedFooter :: FooterMode -> Bool -isFocusedFooter (FooterInput {}) = True -isFocusedFooter _ = False - -data FooterInputMode = FClosureAddress {runNow :: Bool, invert :: Bool} - | FInfoTableAddress {runNow :: Bool, invert :: Bool} - | FConstructorName {runNow :: Bool, invert :: Bool} - | FClosureName {runNow :: Bool, invert :: Bool} - | FArrWordsSize - | FFilterEras {runNow :: Bool, invert :: Bool} - | FFilterClosureType {invert :: Bool} - | FFilterClosureSize {invert :: Bool} - | FFilterCcId {runNow :: Bool, invert :: Bool} - | FProfile ProfileLevel - | FSnapshot - | FDumpArrWords - | FSetResultSize - deriving Show - --- | Profiling requirement for a command -data ProfilingReq - = ReqSomeProfiling - | ReqErasProfiling - | NoReq - -data Command = Command { commandDescription :: Text - , commandKey :: Maybe Vty.Event - , dispatchCommand :: Debuggee -> EventM Name OperationalState () - , commandRequiresProfMode :: ProfilingReq - -- ^ The command requires that the debuggee is in a specific - -- profiling mode. - -- For example, we can only filter by eras if the program - -- has era profiling enabled. - } - -mkCommand :: Text -> Vty.Event -> EventM Name OperationalState () -> Command -mkCommand desc ev dispatch = Command desc (Just ev) (\_ -> dispatch) NoReq - -mkCommand' :: Text -> EventM Name OperationalState () -> Command -mkCommand' desc dispatch = Command desc Nothing (\_ -> dispatch) NoReq - -mkFilterCmd :: Text -> Vty.Event -> EventM Name OperationalState () -> ProfilingReq -> Command -mkFilterCmd desc ev dispatch profMode = Command desc (Just ev) (\_ -> dispatch) profMode - -mkFilterCmd' :: Text -> EventM Name OperationalState () -> ProfilingReq -> Command -mkFilterCmd' desc dispatch profMode = Command desc Nothing (\_ -> dispatch) profMode - -isCmdEnabled :: GD.Version -> Command -> Bool -isCmdEnabled debuggeeVersion cmd = case commandRequiresProfMode cmd of - NoReq -> True - ReqErasProfiling -> - Just GD.EraProfiling == GD.v_profiling debuggeeVersion - ReqSomeProfiling -> - GD.isProfiledRTS debuggeeVersion - -isCmdDisabled :: GD.Version -> Command -> Bool -isCmdDisabled v cmd = not $ isCmdEnabled v cmd - -data OverlayMode = KeybindingsShown - -- TODO: Abstract the "CommandPicker" into it's own module - | CommandPicker (Form Text () Name) (GenericList Name Seq Command) (Seq Command) - | NoOverlay - - -invertInput :: FooterInputMode -> FooterInputMode -invertInput x@FClosureAddress{invert} = x{invert = not invert} -invertInput x@FInfoTableAddress{invert} = x{invert = not invert} -invertInput x@FConstructorName{invert} = x{invert = not invert} -invertInput x@FClosureName{invert} = x{invert = not invert} -invertInput x@FFilterEras{invert} = x{invert = not invert} -invertInput x@FFilterClosureSize{invert} = x{invert = not invert} -invertInput x@FFilterClosureType{invert} = x{invert = not invert} -invertInput x@FFilterCcId{invert} = x{invert = not invert} -invertInput x = x - -formatFooterMode :: FooterInputMode -> Text -formatFooterMode FClosureAddress{invert} = (if invert then "!" else "") <> "address (0x..): " -formatFooterMode FInfoTableAddress{invert} = (if invert then "!" else "") <> "info table pointer (0x..): " -formatFooterMode FConstructorName{invert} = (if invert then "!" else "") <> "constructor name: " -formatFooterMode FClosureName{invert} = (if invert then "!" else "") <> "closure name: " -formatFooterMode FFilterEras{invert} = (if invert then "!" else "") <> "era range (/-): " -formatFooterMode FFilterClosureSize{invert} = (if invert then "!" else "") <> "closure size (bytes): " -formatFooterMode FFilterClosureType{invert} = (if invert then "!" else "") <> "closure type: " -formatFooterMode FFilterCcId{invert} = (if invert then "!" else "") <> "CC Id: " -formatFooterMode FArrWordsSize = "size (bytes)>= " -formatFooterMode FDumpArrWords = "dump payload to file: " -formatFooterMode FSetResultSize = "search result limit (0 for infinity): " -formatFooterMode FSnapshot = "snapshot name: " -formatFooterMode (FProfile {}) = "filename: " - -data ConnectedMode - -- | Debuggee is running - = RunningMode - -- | Debuggee is paused and we're exploring the heap - | PausedMode { _pausedMode :: OperationalState } - -data RootsOrigin = DefaultRoots [(Text, Ptr)] - | SearchedRoots [(Text, Ptr)] - - -currentRoots :: RootsOrigin -> [(Text, Ptr)] -currentRoots (DefaultRoots cp) = cp -currentRoots (SearchedRoots cp) = cp - -data OperationalState = OperationalState - { _running_task :: Maybe ThreadId - , _last_run_time :: Maybe (Text, NominalDiffTime) - , _treeMode :: TreeMode - , _keybindingsMode :: OverlayMode - , _footerMode :: FooterMode - , _rootsFrom :: RootsOrigin - , _treeSavedAndGCRoots :: IOTree (ClosureDetails) Name - -- ^ Tree corresponding to SavedAndGCRoots mode - , _event_chan :: BChan Event - , _resultSize :: Maybe Int - , _filters :: [UIFilter] - , _version :: GD.Version - } - -clearFilters :: OperationalState -> OperationalState -clearFilters os = os { _filters = [] } - -setFilters :: [UIFilter] -> OperationalState -> OperationalState -setFilters fs os = os {_filters = fs} - -addFilters :: [UIFilter] -> OperationalState -> OperationalState -addFilters fs os = os {_filters = fs ++ _filters os} - -data UIFilter = - UIAddressFilter Bool ClosurePtr - | UIInfoAddressFilter Bool InfoTablePtr - | UIConstructorFilter Bool String - | UIInfoNameFilter Bool String - | UIEraFilter Bool EraRange - | UISizeFilter Bool Size - | UIClosureTypeFilter Bool ClosureType - | UICcId Bool Int64 - -uiFiltersToFilter :: [UIFilter] -> DebugM ClosureFilter -uiFiltersToFilter uifilters = do - closFilters <- mapM uiFilterToFilter uifilters - pure $ foldr AndFilter (PureFilter True) closFilters - -uiFilterToFilter :: UIFilter -> DebugM ClosureFilter -uiFilterToFilter (UIAddressFilter invert x) = pure $ AddressFilter (xor invert . (== x)) -uiFilterToFilter (UIInfoAddressFilter invert x) = pure $ InfoPtrFilter (xor invert . (== x)) -uiFilterToFilter (UIConstructorFilter invert x) = pure $ ConstructorDescFilter (xor invert . (== x) . name) -uiFilterToFilter (UIInfoNameFilter invert x) = pure $ InfoSourceFilter (xor invert . (== x) . infoName) -uiFilterToFilter (UIEraFilter invert x) = pure $ ProfHeaderFilter (xor invert . (`profHeaderInEraRange` (Just x))) -uiFilterToFilter (UISizeFilter invert x) = pure $ SizeFilter (xor invert . (>= x)) -uiFilterToFilter (UIClosureTypeFilter invert x) = pure $ InfoFilter (xor invert . (== x) . tipe) -uiFilterToFilter (UICcId invert x) = do - ccsPtrs <- findAllChildrenOfCC ((x ==) . ccID) - pure $ ProfHeaderFilter (xor invert . (`profHeaderReferencesCCS` ccsPtrs)) - -xor :: Bool -> Bool -> Bool -xor False False = False -xor True True = False -xor _ _ = True - -parseEraRange :: Text -> Maybe EraRange -parseEraRange range = case T.splitOn "-" range of - [nstr] -> case readMaybe (T.unpack nstr) of - Just n -> Just $ EraRange n n - Nothing -> Nothing - [start,end] -> case (T.unpack start, T.unpack end) of - ("", "") -> Just $ EraRange 0 maxBound - ("", readMaybe -> Just e) -> Just $ EraRange 0 e - (readMaybe -> Just s, "") -> Just $ EraRange s maxBound - (readMaybe -> Just s, readMaybe -> Just e) -> Just $ EraRange s e - _ -> Nothing - _ -> Nothing - -showEraRange :: EraRange -> String -showEraRange (EraRange s e) - | s == e = show s - | otherwise = "[" ++ show s ++ "," ++ go e - where - go n - | n == maxBound = "∞)" - | otherwise = show n ++ "]" - -osSize :: OperationalState -> Int -osSize os = fromMaybe (Prelude.length (getIOTreeRoots $ _treeSavedAndGCRoots os)) $ treeLength (_treeMode os) - -pauseModeTree :: (forall a . (a -> Widget Name) -> IOTree a Name -> r) -> OperationalState -> r -pauseModeTree k (OperationalState _ _ mode _kb _footer _from roots _ _ _ _) = case mode of - SavedAndGCRoots render -> k render roots - Retainer render r -> k render r - Searched render r -> k render r - -makeLenses ''AppState -makeLenses ''MajorState -makeLenses ''ClosureDetails -makeLenses ''ConnectedMode -makeLenses ''OperationalState -makeLenses ''SocketInfo -makeLenses ''OverlayMode diff --git a/src/Namespace.hs b/src/Namespace.hs deleted file mode 100644 --- a/src/Namespace.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Namespace where - -data Name - = Setup_KnownDebuggeesList - | Setup_KnownSnapshotsList - | Connected_Paused_ClosureDetails - | Connected_Paused_ClosureTree - | CommandPicker_List - | FilterPicker_List - | Overlay - | Footer - deriving (Eq, Ord, Show)