packages feed

ghc-debug-brick 0.7.0.0 → 0.8.0.0

raw patch · 37 files changed

+4120/−2616 lines, 37 filesdep +asyncdep +dependent-mapdep +dependent-sum-templatedep ~basedep ~ghc-debug-clientdep ~ghc-debug-commonnew-uploader

Dependencies added: async, dependent-map, dependent-sum-template, ghc-debug-brick, safe-exceptions, some

Dependency ranges changed: base, ghc-debug-client, ghc-debug-common, ghc-debug-convention

Files

CHANGELOG.md view
@@ -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--
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import GHC.Debug.Brick.UI (mainApp)++main :: IO ()+main = mainApp
ghc-debug-brick.cabal view
@@ -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
+ src/Brick/Widgets/IOTree.hs view
@@ -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
+ src/Brick/Widgets/ListPicker.hs view
@@ -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)
− src/Common.hs 
@@ -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)
+ src/GHC/Debug/Brick/Action/ArrWords.hs view
@@ -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
+ src/GHC/Debug/Brick/Action/Async.hs view
@@ -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
+ src/GHC/Debug/Brick/Action/Profile.hs view
@@ -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)+  ]
+ src/GHC/Debug/Brick/Action/Retainers.hs view
@@ -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
+ src/GHC/Debug/Brick/Action/Strings.hs view
@@ -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
+ src/GHC/Debug/Brick/Action/Thunk.hs view
@@ -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
+ src/GHC/Debug/Brick/ClosureDetails.hs view
@@ -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
+ src/GHC/Debug/Brick/Common.hs view
@@ -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)
+ src/GHC/Debug/Brick/IOTree.hs view
@@ -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))
+ src/GHC/Debug/Brick/Lib.hs view
@@ -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)
+ src/GHC/Debug/Brick/Model.hs view
@@ -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 (<era>/<start-era>-<end-era>): "+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)+    )
+ src/GHC/Debug/Brick/Namespace.hs view
@@ -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)
+ src/GHC/Debug/Brick/Render.hs view
@@ -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
+ src/GHC/Debug/Brick/Render/Closure.hs view
@@ -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
+ src/GHC/Debug/Brick/Render/Command.hs view
@@ -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)
+ src/GHC/Debug/Brick/Render/Filter.hs view
@@ -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
+ src/GHC/Debug/Brick/Render/Footer.hs view
@@ -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)] ""
+ src/GHC/Debug/Brick/Render/Header.hs view
@@ -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)
+ src/GHC/Debug/Brick/Render/Histogram.hs view
@@ -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
+ src/GHC/Debug/Brick/Render/HistoryPicker.hs view
@@ -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"
+ src/GHC/Debug/Brick/Render/Key.hs view
@@ -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 = "�"
+ src/GHC/Debug/Brick/Render/Utils.hs view
@@ -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
+ src/GHC/Debug/Brick/UI.hs view
@@ -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 ()
+ src/GHC/Debug/Brick/UI/Async.hs view
@@ -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))
+ src/GHC/Debug/Brick/UI/Filter.hs view
@@ -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
+ src/GHC/Debug/Brick/Update.hs view
@@ -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
− src/IOTree.hs 
@@ -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
− src/Lib.hs 
@@ -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)]----
− src/Main.hs 
@@ -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 ()
− src/Model.hs 
@@ -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 (<era>/<start-era>-<end-era>): "-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
− src/Namespace.hs 
@@ -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)