ghc-debug-brick 0.2.1.0 → 0.3.0.0
raw patch · 13 files changed
+559/−893 lines, 13 filesdep +contra-tracerdep ~brickdep ~ghc-debug-clientdep ~ghc-debug-commonnew-component:exe:ghc-debug-brick
Dependencies added: contra-tracer
Dependency ranges changed: brick, ghc-debug-client, ghc-debug-common, ghc-debug-convention
Files
- CHANGELOG.md +4/−0
- LICENSE +19/−21
- ghc-debug-brick.cabal +10/−16
- src/Common.hs +5/−10
- src/Cursor/List.hs +0/−185
- src/Cursor/Text.hs +0/−224
- src/Cursor/Types.hs +0/−75
- src/IOTree.hs +43/−34
- src/Lib.hs +13/−4
- src/Main.hs +449/−280
- src/Model.hs +15/−5
- src/Namespace.hs +1/−0
- src/TextCursor.hs +0/−39
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for ghc-debug-brick +## 0.3.0.0 -- 2022-10-06++* Major improvments to interface+ ## 0.2.1.0 -- 2022-05-06 * Add function to find closures by exact name (F8)
LICENSE view
@@ -1,30 +1,28 @@-Copyright (c) 2019, Ben Gamari+BSD 3-Clause License -All rights reserved.+Copyright (c) 2019, Ben Gamari, David Eichmann, Matthew Pickering Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.+2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution. - * Neither the name of Ben Gamari nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
ghc-debug-brick.cabal view
@@ -1,32 +1,25 @@ cabal-version: 2.4 name: ghc-debug-brick-version: 0.2.1.0-synopsis: A simple TUI using ghc-debug-description: A simple TUI using ghc-debug--- bug-reports:+version: 0.3.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-copyright:-category: build-type: Simple extra-source-files: CHANGELOG.md -executable ghc-heap-view+executable ghc-debug-brick main-is: Main.hs other-modules: Model , Namespace , IOTree- , TextCursor , Common , Lib- , Cursor.Types- , Cursor.Text- , Cursor.List- -- other-extensions: build-depends: base >=4.16 && <5- , brick+ , brick ^>= 1.3 , containers , directory , filepath@@ -36,11 +29,12 @@ , time , deepseq , microlens- , ghc-debug-client == 0.2.1.0- , ghc-debug-common == 0.2.1.0- , ghc-debug-convention == 0.2.0.0+ , ghc-debug-client == 0.3.0.0+ , ghc-debug-common == 0.3.0.0+ , ghc-debug-convention == 0.3.0.0 , unordered-containers , exceptions+ , contra-tracer hs-source-dirs: src default-language: Haskell2010 ghc-options: -threaded -Wall
src/Common.hs view
@@ -7,13 +7,9 @@ import Lens.Micro import Namespace -type Handler' s k =- s- -> T.BrickEvent Name ()- -> T.EventM Name (T.Next k)--type Handler s = Handler' s s-+type Handler s =+ T.BrickEvent Name ()+ -> 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@@ -24,9 +20,8 @@ -> (c -> a) -- How to inject the new state -> Handler c -- Handler for inner state -> Handler s-liftHandler l c i h st ev = do- let update s = set l (i s) st- fmap update <$> h c ev+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/Cursor/List.hs
@@ -1,185 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{- Authored by Tom Sydney Kerckhove, copied from cursor package #-}--module Cursor.List- ( ListCursor (..),- emptyListCursor,- makeListCursor,- makeListCursorWithSelection,- rebuildListCursor,- listCursorNull,- listCursorLength,- listCursorIndex,- listCursorSelectPrev,- listCursorSelectNext,- listCursorSelectIndex,- listCursorSelectStart,- listCursorSelectEnd,- listCursorPrevItem,- listCursorNextItem,- listCursorPrevUntil,- listCursorNextUntil,- listCursorInsert,- listCursorAppend,- listCursorInsertList,- listCursorAppendList,- listCursorRemove,- listCursorDelete,- listCursorSplit,- listCursorCombine,- traverseListCursor,- foldListCursor,- )-where--import Control.DeepSeq-import Cursor.Types-import GHC.Generics (Generic)--data ListCursor a = ListCursor- { -- | In reverse order- listCursorPrev :: [a],- listCursorNext :: [a]- }- deriving (Show, Eq, Generic, Functor)--instance NFData a => NFData (ListCursor a)--emptyListCursor :: ListCursor a-emptyListCursor = ListCursor {listCursorPrev = [], listCursorNext = []}--makeListCursor :: [a] -> ListCursor a-makeListCursor as = ListCursor {listCursorPrev = [], listCursorNext = as}--makeListCursorWithSelection :: Int -> [a] -> Maybe (ListCursor a)-makeListCursorWithSelection i as- | i < 0 = Nothing- | i > length as = Nothing- | otherwise = Just ListCursor {listCursorPrev = reverse $ take i as, listCursorNext = drop i as}--rebuildListCursor :: ListCursor a -> [a]-rebuildListCursor ListCursor {..} = reverse listCursorPrev ++ listCursorNext--listCursorNull :: ListCursor a -> Bool-listCursorNull ListCursor {..} = null listCursorPrev && null listCursorNext--listCursorLength :: ListCursor a -> Int-listCursorLength = length . rebuildListCursor--listCursorIndex :: ListCursor a -> Int-listCursorIndex = length . listCursorPrev--listCursorSelectPrev :: ListCursor a -> Maybe (ListCursor a)-listCursorSelectPrev tc =- case listCursorPrev tc of- [] -> Nothing- (c : cs) -> Just ListCursor {listCursorPrev = cs, listCursorNext = c : listCursorNext tc}--listCursorSelectNext :: ListCursor a -> Maybe (ListCursor a)-listCursorSelectNext tc =- case listCursorNext tc of- [] -> Nothing- (c : cs) -> Just ListCursor {listCursorPrev = c : listCursorPrev tc, listCursorNext = cs}--listCursorSelectIndex :: Int -> ListCursor a -> ListCursor a-listCursorSelectIndex ix_ lc =- let ls = rebuildListCursor lc- in case splitAt ix_ ls of- (l, r) -> ListCursor {listCursorPrev = reverse l, listCursorNext = r}--listCursorSelectStart :: ListCursor a -> ListCursor a-listCursorSelectStart tc =- case listCursorSelectPrev tc of- Nothing -> tc- Just tc' -> listCursorSelectStart tc'--listCursorSelectEnd :: ListCursor a -> ListCursor a-listCursorSelectEnd tc =- case listCursorSelectNext tc of- Nothing -> tc- Just tc' -> listCursorSelectEnd tc'--listCursorPrevItem :: ListCursor a -> Maybe a-listCursorPrevItem lc =- case listCursorPrev lc of- [] -> Nothing- (c : _) -> Just c--listCursorNextItem :: ListCursor a -> Maybe a-listCursorNextItem lc =- case listCursorNext lc of- [] -> Nothing- (c : _) -> Just c--listCursorPrevUntil :: (a -> Bool) -> ListCursor a -> ListCursor a-listCursorPrevUntil p = go- where- go lc =- case listCursorPrev lc of- [] -> lc- (c : _)- | p c -> lc- _ -> maybe lc go (listCursorSelectPrev lc)--listCursorNextUntil :: (a -> Bool) -> ListCursor a -> ListCursor a-listCursorNextUntil p = go- where- go lc =- case listCursorNext lc of- [] -> lc- (c : _)- | p c -> lc- _ -> maybe lc go (listCursorSelectNext lc)--listCursorInsert :: a -> ListCursor a -> ListCursor a-listCursorInsert c lc = lc {listCursorPrev = c : listCursorPrev lc}--listCursorAppend :: a -> ListCursor a -> ListCursor a-listCursorAppend c lc = lc {listCursorNext = c : listCursorNext lc}--listCursorInsertList :: [a] -> ListCursor a -> ListCursor a-listCursorInsertList l lc = lc {listCursorPrev = reverse l ++ listCursorPrev lc}--listCursorAppendList :: [a] -> ListCursor a -> ListCursor a-listCursorAppendList l lc = lc {listCursorNext = l ++ listCursorNext lc}--listCursorRemove :: ListCursor a -> Maybe (DeleteOrUpdate (ListCursor a))-listCursorRemove tc =- case listCursorPrev tc of- [] ->- case listCursorNext tc of- [] -> Just Deleted- _ -> Nothing- (_ : prev) -> Just $ Updated $ tc {listCursorPrev = prev}--listCursorDelete :: ListCursor a -> Maybe (DeleteOrUpdate (ListCursor a))-listCursorDelete tc =- case listCursorNext tc of- [] ->- case listCursorPrev tc of- [] -> Just Deleted- _ -> Nothing- (_ : next) -> Just $ Updated $ tc {listCursorNext = next}--listCursorSplit :: ListCursor a -> (ListCursor a, ListCursor a)-listCursorSplit ListCursor {..} =- ( ListCursor {listCursorPrev = listCursorPrev, listCursorNext = []},- ListCursor {listCursorPrev = [], listCursorNext = listCursorNext}- )--listCursorCombine :: ListCursor a -> ListCursor a -> ListCursor a-listCursorCombine lc1 lc2 =- ListCursor- { listCursorPrev = reverse $ rebuildListCursor lc1,- listCursorNext = rebuildListCursor lc2- }--traverseListCursor :: ([a] -> [a] -> f b) -> ListCursor a -> f b-traverseListCursor = foldListCursor--foldListCursor :: ([a] -> [a] -> b) -> ListCursor a -> b-foldListCursor func ListCursor {..} = func (reverse listCursorPrev) listCursorNext-
− src/Cursor/Text.hs
@@ -1,224 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-}-{- Authored by Tom Sydney Kerckhove, copied from cursor package #-}--module Cursor.Text- ( TextCursor (..),- emptyTextCursor,- makeTextCursor,- makeTextCursorWithSelection,- rebuildTextCursor,- textCursorNull,- textCursorLength,- textCursorIndex,- textCursorSelectPrev,- textCursorSelectNext,- textCursorSelectIndex,- textCursorSelectStart,- textCursorSelectEnd,- textCursorPrevChar,- textCursorNextChar,- textCursorSelectBeginWord,- textCursorSelectEndWord,- textCursorSelectNextWord,- textCursorSelectPrevWord,- textCursorInsert,- textCursorAppend,- textCursorInsertString,- textCursorAppendString,- textCursorInsertText,- textCursorAppendText,- textCursorRemove,- textCursorDelete,- textCursorSplit,- textCursorCombine,- )-where--import Control.DeepSeq-import Cursor.List-import Cursor.Types-import Data.Char-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Generics (Generic)-import Lens.Micro---- | A cursor for single-line texts-newtype TextCursor = TextCursor- { textCursorList :: ListCursor Char- }- deriving (Show, Eq, Generic)--instance NFData TextCursor--emptyTextCursor :: TextCursor-emptyTextCursor = TextCursor emptyListCursor--makeTextCursor :: Text -> Maybe TextCursor-makeTextCursor t = makeTextCursorWithSelection (T.length t) t--makeTextCursorWithSelection :: Int -> Text -> Maybe TextCursor-makeTextCursorWithSelection i t =- case T.split (== '\n') t of- [l] -> TextCursor <$> makeListCursorWithSelection i (T.unpack l)- _ -> Nothing--rebuildTextCursor :: TextCursor -> Text-rebuildTextCursor = T.pack . rebuildListCursor . textCursorList--textCursorListCursorL ::- Functor f => (ListCursor Char -> f (ListCursor Char)) -> TextCursor -> f TextCursor-textCursorListCursorL = lens textCursorList (\tc lc -> tc {textCursorList = lc})--textCursorNull :: TextCursor -> Bool-textCursorNull = listCursorNull . textCursorList--textCursorLength :: TextCursor -> Int-textCursorLength = listCursorLength . textCursorList--textCursorIndex :: TextCursor -> Int-textCursorIndex = listCursorIndex . textCursorList--textCursorSelectPrev :: TextCursor -> Maybe TextCursor-textCursorSelectPrev = textCursorListCursorL listCursorSelectPrev--textCursorSelectNext :: TextCursor -> Maybe TextCursor-textCursorSelectNext = textCursorListCursorL listCursorSelectNext--textCursorSelectIndex :: Int -> TextCursor -> TextCursor-textCursorSelectIndex ix_ = textCursorListCursorL %~ listCursorSelectIndex ix_--textCursorSelectStart :: TextCursor -> TextCursor-textCursorSelectStart = textCursorListCursorL %~ listCursorSelectStart--textCursorSelectEnd :: TextCursor -> TextCursor-textCursorSelectEnd = textCursorListCursorL %~ listCursorSelectEnd--textCursorPrevChar :: TextCursor -> Maybe Char-textCursorPrevChar = listCursorPrevItem . textCursorList--textCursorNextChar :: TextCursor -> Maybe Char-textCursorNextChar = listCursorNextItem . textCursorList---- | Move to the beginning of the word------ * @"hell|o"@ -> @"|hello"@--- * @"hello | world"@ -> @"|hello world"@--- * @"hello |world"@ -> @"hello |world"@--- * @"| hello"@ -> @"| hello"@-textCursorSelectBeginWord :: TextCursor -> TextCursor-textCursorSelectBeginWord tc =- let goLeft = maybe tc textCursorSelectBeginWord (textCursorSelectPrev tc)- in case textCursorPrevChar tc of- Nothing -> tc- Just p- | isSpace p -> case textCursorNextChar tc of- Nothing -> goLeft- Just n- | isSpace n -> goLeft- | otherwise -> tc- | otherwise -> goLeft---- | Move to the end of the word------ * @"hell|o"@ -> @"hello|"@--- * @"hello | world"@ -> @"hello world|"@--- * @"hello| world"@ -> @"hello| world"@--- * @"hello |"@ -> @"hello |"@-textCursorSelectEndWord :: TextCursor -> TextCursor-textCursorSelectEndWord tc =- let goRight = maybe tc textCursorSelectEndWord (textCursorSelectNext tc)- in case textCursorNextChar tc of- Nothing -> tc- Just p- | isSpace p -> case textCursorPrevChar tc of- Nothing -> goRight- Just n- | isSpace n -> goRight- | otherwise -> tc- | otherwise -> goRight---- | Move to the beginning of the next word------ * @"|hello"@ -> @"hello|"@--- * @"hell|o world"@ -> @"hello |world"@--- * @"hello| world"@ -> @"hello |world"@--- * @"hello |"@ -> @"hello |"@-textCursorSelectNextWord :: TextCursor -> TextCursor-textCursorSelectNextWord tc =- case (textCursorPrevChar tc, textCursorNextChar tc) of- (_, Nothing) -> tc- (Just p, Just n) ->- case (isSpace p, isSpace n) of- (_, True) -> TextCursor $ listCursorNextUntil (not . isSpace) lc- _ -> textCursorSelectNextWord . TextCursor $ listCursorNextUntil isSpace lc- _ -> textCursorSelectNextWord $ TextCursor $ listCursorNextUntil isSpace lc- where- lc = textCursorList tc---- | Move to the end of the previous word------ * @"hello|"@ -> @"|hello"@--- * @"hello w|orld"@ -> @"hello| world"@--- * @"hello |world"@ -> @"hello| world"@--- * @" h|ello"@ -> @"| hello"@-textCursorSelectPrevWord :: TextCursor -> TextCursor-textCursorSelectPrevWord tc =- case (textCursorPrevChar tc, textCursorNextChar tc) of- (Nothing, _) -> tc- (Just p, Just n) ->- case (isSpace p, isSpace n) of- (True, _) -> TextCursor $ listCursorPrevUntil (not . isSpace) lc- _ -> textCursorSelectPrevWord . TextCursor $ listCursorPrevUntil isSpace lc- _ -> textCursorSelectPrevWord . TextCursor $ listCursorPrevUntil isSpace lc- where- lc = textCursorList tc--textCursorInsert :: Char -> TextCursor -> Maybe TextCursor-textCursorInsert '\n' _ = Nothing-textCursorInsert c tc =- if isSafeChar c- then Just (tc & textCursorListCursorL %~ listCursorInsert c)- else Nothing--textCursorAppend :: Char -> TextCursor -> Maybe TextCursor-textCursorAppend '\n' _ = Nothing-textCursorAppend c tc =- if isSafeChar c- then Just (tc & textCursorListCursorL %~ listCursorAppend c)- else Nothing--textCursorInsertString :: String -> TextCursor -> Maybe TextCursor-textCursorInsertString s tc =- if any (\c -> c == '\n' || not (isSafeChar c)) s- then Nothing- else Just $ tc & textCursorListCursorL %~ listCursorInsertList s--textCursorAppendString :: String -> TextCursor -> Maybe TextCursor-textCursorAppendString s tc =- if any (\c -> c == '\n' || not (isSafeChar c)) s- then Nothing- else Just $ tc & textCursorListCursorL %~ listCursorAppendList s--textCursorInsertText :: Text -> TextCursor -> Maybe TextCursor-textCursorInsertText = textCursorInsertString . T.unpack--textCursorAppendText :: Text -> TextCursor -> Maybe TextCursor-textCursorAppendText = textCursorAppendString . T.unpack--textCursorRemove :: TextCursor -> Maybe (DeleteOrUpdate TextCursor)-textCursorRemove = focusPossibleDeleteOrUpdate textCursorListCursorL listCursorRemove--textCursorDelete :: TextCursor -> Maybe (DeleteOrUpdate TextCursor)-textCursorDelete = focusPossibleDeleteOrUpdate textCursorListCursorL listCursorDelete--textCursorSplit :: TextCursor -> (TextCursor, TextCursor)-textCursorSplit tc =- let (lc1, lc2) = listCursorSplit $ textCursorList tc- in (TextCursor lc1, TextCursor lc2)--textCursorCombine :: TextCursor -> TextCursor -> TextCursor-textCursorCombine (TextCursor lc1) (TextCursor lc2) =- TextCursor {textCursorList = listCursorCombine lc1 lc2}-
− src/Cursor/Types.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes #-}-{- Authored by Tom Sydney Kerckhove, copied from cursor package #-}--module Cursor.Types where--import Control.Applicative-import Data.Functor.Compose-import qualified Data.Text.Internal as T-import GHC.Generics (Generic)-import Lens.Micro--isSafeChar :: Char -> Bool-isSafeChar c = T.safe c == c--data DeleteOrUpdate a- = Deleted- | Updated a- deriving (Show, Eq, Generic)--instance Functor DeleteOrUpdate where- fmap _ Deleted = Deleted- fmap f (Updated a) = Updated (f a)--instance Applicative DeleteOrUpdate where- pure = Updated- Deleted <*> _ = Deleted- _ <*> Deleted = Deleted- (Updated f) <*> (Updated a) = Updated (f a)--instance Alternative DeleteOrUpdate where- empty = Deleted- Updated a <|> _ = Updated a- Deleted <|> doua = doua--instance Monad DeleteOrUpdate where- dou >>= f = case dou of- Updated a -> f a- Deleted -> Deleted--joinDeletes :: Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) -> DeleteOrUpdate a-joinDeletes m1 m2 =- case (m1, m2) of- (Nothing, Nothing) -> Deleted- (Nothing, Just a) -> a- (Just a, _) -> a--joinDeletes3 ::- Maybe (DeleteOrUpdate a) ->- Maybe (DeleteOrUpdate a) ->- Maybe (DeleteOrUpdate a) ->- DeleteOrUpdate a-joinDeletes3 m1 m2 m3 =- case (m1, m2, m3) of- (Nothing, Nothing, Nothing) -> Deleted- (Nothing, Nothing, Just a) -> a- (Nothing, Just a, _) -> a- (Just a, _, _) -> a--joinPossibleDeletes ::- Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a)-joinPossibleDeletes d1 d2 = getCompose $ Compose d1 <|> Compose d2--focusPossibleDeleteOrUpdate ::- Lens' b a -> (a -> Maybe (DeleteOrUpdate a)) -> b -> Maybe (DeleteOrUpdate b)-focusPossibleDeleteOrUpdate l func = getCompose . l (Compose . func)--dullMDelete :: Maybe (DeleteOrUpdate a) -> Maybe a-dullMDelete Nothing = Nothing-dullMDelete (Just dou) = dullDelete dou--dullDelete :: DeleteOrUpdate a -> Maybe a-dullDelete Deleted = Nothing-dullDelete (Updated a) = Just a-
src/IOTree.hs view
@@ -8,6 +8,8 @@ module IOTree ( IOTree , IOTreePath+ , RowState(..)+ , RowCtx(..) , ioTree , setIOTreeRoots , getIOTreeRoots@@ -21,6 +23,7 @@ , viewPath , viewSelect , viewUp+ , viewUp' , viewUnsafeDown , viewPrevSibling , viewNextSibling@@ -29,37 +32,36 @@ , 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 Brick+import Graphics.Vty.Input.Events (Key(..)) + -- 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 :: Bool -- Is row selected- -> Int -- Tree depth+ , _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 a single row- , _renderFirstChild- :: Int -- Tree depth (of the children)- -> node -- the (parent) node- -> [node] -- the children- -> 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) } @@ -87,25 +89,21 @@ -- ^ Root nodes -> (node -> IO [node]) -- ^ Get child nodes of a node- -> (Bool -- Is row selected- -> Int -- Tree depth+ -> (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)- -> (Int -- Tree depth (of the children)- -> node -- the (parent) node- -> [node] -- the children- -> Widget name)- -- Render some extra info as the first child of each node -> IOTree node name-ioTree name rootNodes getChildrenIO renderRow renderFirstChild+ioTree name rootNodes getChildrenIO renderRow = IOTree { _name = name , _roots = nodeToTreeNode getChildrenIO <$> rootNodes , _getChildren = getChildrenIO , _renderRow = renderRow- , _renderFirstChild = renderFirstChild- , _selection = []+ , _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 }@@ -115,28 +113,28 @@ nodeToTreeNode k n = IOTreeNode n (Left (fmap (nodeToTreeNode k) <$> k n)) renderIOTree :: (Show name, Ord name) => IOTree node name -> Widget name-renderIOTree (IOTree widgetName rs _ renderRow renderFirstChild pathTop)- = viewport widgetName Both $ vBox $ renderTree 0 0 rs pathTop+renderIOTree (IOTree widgetName rs _ renderRow pathTop)+ = viewport widgetName Vertical $ vBox $ renderTree 0 [] rs pathTop where -- Render the tree of nodes renderTree _ _ [] _ = [] renderTree minorIx depth (IOTreeNode node' csE : ns) path = case csE of -- Collapsed- Left _ -> row : rowsRest+ Left _ -> row Collapsed : rowsRest -- Expanded- Right cs -> row- : renderFirstChild (depth + 1) node' (_node <$> cs)- : renderTree 0 (depth + 1) cs (if childIsSelected then drop 1 path else [])+ Right cs -> row (Expanded (null cs))+ : renderTree 0 (rowCtx : depth) cs (if childIsSelected then drop 1 path else []) ++ rowsRest where childIsSelected = case path of x:_ -> x == minorIx _ -> False selected = path == [minorIx]- row = (if selected then visible else id) $ renderRow selected depth node'+ rowCtx = if null ns then LastRow else NotLastRow+ row state = (if selected then visible else id) $ renderRow state selected rowCtx depth node' rowsRest = renderTree (minorIx + 1) depth ns path -handleIOTreeEvent :: Vty.Event -> IOTree node name -> EventM name (IOTree node name)+handleIOTreeEvent :: Vty.Event -> IOTree node name -> EventM name s (IOTree node name) handleIOTreeEvent e tree = liftIO $ forIOTreeViewSelection tree@@ -144,10 +142,15 @@ Vty.EvKey KRight _ -> do (view', cs) <- viewExpand view return $ if null cs then view' else viewUnsafeDown view' 0- Vty.EvKey KDown _ -> return $ fromMaybe view (viewNextVisible view)- Vty.EvKey KLeft _ -> return $ viewCollapse $ fromMaybe view (viewUp view)- Vty.EvKey KUp _ -> return $ fromMaybe view (viewPrevVisible view)+ Vty.EvKey KDown _ -> return $ next 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)@@ -205,7 +208,13 @@ Root{} -> Nothing Node mkParent _ t' -> Just (mkParent t') --- | Move down to a cild in the tree. Index must be in range. Must be expanded.+-- | 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"@@ -218,7 +227,7 @@ viewPrevVisible :: HasCallStack => IOTreeView node name -> Maybe (IOTreeView node name) viewPrevVisible view = case viewPrevSibling view of- Nothing -> viewUp view+ Nothing -> viewUp' view Just nextSib -> Just (viewLastVisibleChild nextSib) where viewLastVisibleChild view' = if viewIsCollapsed view'
src/Lib.hs view
@@ -69,6 +69,7 @@ -- * Retainers , retainersOfConstructor+ , retainersOfAddress , retainersOfConstructorExact -- * Snapshot@@ -84,6 +85,7 @@ , StackCont , PayloadCont , ClosurePtr+ , readClosurePtr , HG.StackHI , HG.PapHI , HG.HeapGraphIndex@@ -109,6 +111,7 @@ import Control.Monad import System.FilePath import System.Directory+import Control.Tracer data Analysis = Analysis { analysisDominatorRoots :: ![ClosurePtr]@@ -184,10 +187,11 @@ -- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done. debuggeeConnect :: FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) -> IO Debuggee-debuggeeConnect socketName = GD.debuggeeConnect socketName+debuggeeConnect socketName = GD.debuggeeConnectWithTracer debugTracer socketName + snapshotConnect :: FilePath -> IO Debuggee-snapshotConnect snapshotName = GD.snapshotInit snapshotName+snapshotConnect snapshotName = GD.snapshotInitWithTracer debugTracer snapshotName -- | Close the connection to the debuggee. debuggeeClose :: Debuggee -> IO ()@@ -226,6 +230,13 @@ createDirectoryIfMissing True dir GD.makeSnapshot dbg (dir </> fp) +retainersOfAddress :: Maybe [ClosurePtr] -> Debuggee -> [ClosurePtr] -> IO [[Closure]]+retainersOfAddress mroots dbg address = do+ run dbg $ do+ roots <- maybe GD.gcRoots return mroots+ stack <- GD.findRetainersOf (Just 100) roots address+ traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack+ retainersOfConstructor :: Maybe [ClosurePtr] -> Debuggee -> String -> IO [[Closure]] retainersOfConstructor mroots dbg con_name = do run dbg $ do@@ -273,8 +284,6 @@ data Ptr = CP ClosurePtr | SP StackCont deriving (Eq, Ord) -deriving instance Eq StackCont-deriving instance Ord StackCont dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr) dereferencePtr dbg (CP cp) = run dbg (Closure <$> pure cp <*> GD.dereferenceClosure cp)
src/Main.hs view
@@ -13,6 +13,13 @@ {-# LANGUAGE TypeFamilies #-} 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) import Control.Monad.IO.Class@@ -22,8 +29,7 @@ import Data.Ord (comparing) import qualified Data.Ord as Ord import qualified Data.Sequence as Seq-import Graphics.Vty(defaultConfig, mkVty, defAttr)-import qualified Graphics.Vty.Input.Events as Vty+import qualified Graphics.Vty as Vty import Graphics.Vty.Input.Events (Key(..)) import Lens.Micro.Platform import System.Directory@@ -34,16 +40,9 @@ import Data.Bifunctor import Data.Maybe -import IOTree-import TextCursor-import Brick-import Brick.BChan-import Brick.Widgets.Border-import Brick.Widgets.List- import GHC.Debug.Client.Search as GD+import IOTree import Lib as GD- import Model data Event@@ -55,111 +54,143 @@ drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name drawSetup herald other_herald vals =- let nKnownDebuggees = Seq.length $ (vals ^. listElementsL) in mainBorder "ghc-debug" $ vBox- [ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):"- , txt $ "Select " <> other_herald <> " with <TAB>"+ [ hBox+ [ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):"+ ] , renderList- (\elIsSelected socketPath -> hBox- [ txt $ if elIsSelected then "*" else " "- , txt " "- , txt (socketName socketPath)+ (\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 = borderWithLabel (txt title) . padAll 1+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+ case majorState' of Setup setupKind' dbgs snaps -> case setupKind' of- Socket -> drawSetup "process" "snapshot" dbgs- Snapshot -> drawSetup "snapshot" "process" snaps+ Socket -> [drawSetup "process" "snapshots" dbgs]+ Snapshot -> [drawSetup "snapshot" "processes" snaps] Connected _socket _debuggee mode' -> case mode' of - RunningMode -> mainBorder "ghc-debug - Running" $ vBox- [ txt "Pause (p)"- ]+ RunningMode -> [mainBorder "ghc-debug - Running" $ 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 treeMode' fmode _ro _dtree _ _reverseTree _hg)) -> let- in mainBorder "ghc-debug - Paused" $ vBox- [ hBox- [ border $ vBox- ([ txt "Resume (F12)"- , txt "Tree (F1)"- , txt "Parent (<-)"- , txt "Child (->)"- , txt "Saved/GC Roots (F1)"- , txt "Write Profile (F3)"- , txt "Find Retainers (F4)"- , txt "Find Retainers (Exact) (F6)"- , txt "Take Snapshot (F5)"- ])- , -- Current closure details- borderWithLabel (txt "Closure Details") $ pauseModeTree (renderClosureDetails . ioTreeSelection) os- ]+ (PausedMode os@(OperationalState treeMode' kbmode fmode _ro _dtree _ _reverseTree _hg)) -> let+ in kbOverlay kbmode $ [mainBorder "ghc-debug - Paused" $ vBox+ [ -- Current closure details+ joinBorders $ borderWithLabel (txt "Closure Details") $+ vLimit 9 $+ pauseModeTree (renderClosureDetails . ioTreeSelection) os+ <=> fill ' ' , -- Tree- borderWithLabel+ joinBorders $ borderWithLabel (txt $ case treeMode' of Dominator -> "Dominator Tree" SavedAndGCRoots -> "Root Closures" Reverse -> "Reverse Edges" Retainer {} -> "Retainers"+ Searched {} -> "Search Results" ) (pauseModeTree renderIOTree os)- , hBorder , footer fmode- ]- ]+ ]]+ where + kbOverlay :: KeybindingsMode -> [Widget Name] -> [Widget Name]+ kbOverlay KeybindingsShown ws = centerLayer kbWindow : ws+ kbOverlay KeybindingsHidden ws = ws++ kbWindow :: Widget Name+ kbWindow =+ withAttr menuAttr $+ borderWithLabel (txt "Keybindings") $ vBox $+ [ txt "Resume (^r)"+ , txt "Tree (^t)"+ , txt "Parent (<-)"+ , txt "Child (->)"+ , txt "Saved/GC Roots (^s)"+ , txt "Write Profile (^w)"+ , txt "Find Retainers (^f)"+ , txt "Find Retainers (Exact) (^e)"+ , txt "Find Closures (Exact) (^c)"+ , txt "Find Address (^p)"+ , txt "Take Snapshot (^x)"+ , txt "Exit (ESC)"+ ]+ renderClosureDetails :: Maybe (ClosureDetails pap s c) -> Widget Name renderClosureDetails (Just cd@(ClosureDetails {})) =- vLimit 9 $ vBox $+ vLimit 9 $+ -- viewport Connected_Paused_ClosureDetails Both $+ vBox $ renderInfoInfo (_info cd) ++- [ txt $ "Exclusive Size "- <> maybe "" (pack . show @Int . GD.getSize) (Just $ _excSize cd) <> " bytes"- , txt $ "Retained Size "- <> maybe "" (pack . show @Int . GD.getRetainerSize) (_retainerSize cd) <> " bytes"- , fill ' '+ [ hBox [+ txtLabel $ "Exclusive Size "+ <> maybe "" (pack . show @Int . GD.getSize) (Just $ _excSize cd) <> " bytes"+ ] ] renderClosureDetails Nothing = emptyWidget renderClosureDetails (Just (LabelNode n)) = txt n renderClosureDetails (Just (InfoDetails info')) = vLimit 9 $ vBox $ renderInfoInfo info' + renderInfoInfo :: InfoInfo -> [Widget Name] renderInfoInfo info' =- [ txt "SourceLocation "- <+> txt (maybe "" renderSourceInformation (_sourceLocation info'))+ maybe [] renderSourceInformation (_sourceLocation info') -- TODO these aren't actually implemented yet -- , txt $ "Type " -- <> fromMaybe "" (_closureType =<< cd) -- , txt $ "Constructor " -- <> fromMaybe "" (_constructor =<< cd)- ] - renderSourceInformation :: SourceInformation -> T.Text+ renderSourceInformation :: SourceInformation -> [Widget Name] renderSourceInformation (SourceInformation name cty ty label' modu loc) =- T.pack $ unlines [name, show 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 lbl w =+ hLimit 17 (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ')+ footer :: FooterMode -> Widget Name footer m = vLimit 1 $ case m of FooterMessage t -> txt t- FooterInfo -> txt ""- FooterInput im t -> txt (formatFooterMode im) <+> drawTextCursor t+ FooterInfo -> withAttr menuAttr $ hBox [txt "(↑↓): select item | (→): expand | (←): collapse | (?): full keybindings", fill ' ']+ 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@@ -187,171 +218,175 @@ llist -myAppHandleEvent :: BChan Event -> AppState -> BrickEvent Name Event -> EventM Name (Next AppState)-myAppHandleEvent eventChan appState@(AppState majorState') brickEvent = case brickEvent of- _ -> case majorState' of- Setup st knownDebuggees' knownSnapshots' -> case brickEvent of+myAppHandleEvent :: BChan Event -> BrickEvent Name Event -> EventM Name AppState ()+myAppHandleEvent eventChan brickEvent = do+ appState@(AppState majorState') <- get+ case brickEvent of+ _ -> case majorState' of+ Setup st knownDebuggees' knownSnapshots' -> case brickEvent of - VtyEvent (Vty.EvKey KEsc []) -> halt appState- VtyEvent event -> case event of- -- Connect to the selected debuggee- Vty.EvKey (KChar '\t') [] -> do- continue $ appState & majorState . setupKind %~ toggleSetup- Vty.EvKey KEnter _ ->- case st of- Snapshot- | Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots'- -> do- debuggee' <- liftIO $ snapshotConnect (view socketLocation socket)- continue $ appState & majorState .~ Connected- { _debuggeeSocket = socket- , _debuggee = debuggee'- , _mode = RunningMode -- TODO should we query the debuggee for this?- }- Socket- | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees'- -> do- bracket- (liftIO $ debuggeeConnect (view socketLocation socket))- (\debuggee' -> liftIO $ resume debuggee')- (\debuggee' ->- continue $ appState & majorState .~ Connected- { _debuggeeSocket = socket- , _debuggee = debuggee'- , _mode = RunningMode -- TODO should we query the debuggee for this?- })- _ -> continue appState+ 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 (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 (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- newOptions <- handleListEventVi handleListEvent event knownSnapshots'- continue $ appState & majorState . knownSnapshots .~ newOptions- Socket -> do- newOptions <- handleListEventVi handleListEvent event knownDebuggees'- continue $ appState & majorState . knownDebuggees .~ newOptions+ -- 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'- continue $ appState & majorState . knownDebuggees .~ knownDebuggees''- & majorState . knownSnapshots .~ knownSnapshots''- DominatorTreeReady {} -> continue appState- ReverseAnalysisReady {} -> continue appState- HeapGraphReady {} -> continue appState- _ -> continue appState+ 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''+ DominatorTreeReady {} -> return ()+ ReverseAnalysisReady {} -> return ()+ HeapGraphReady {} -> return ()+ _ -> return () - Connected _socket' debuggee' mode' -> case mode' of+ Connected _socket' debuggee' mode' -> case mode' of - RunningMode -> case brickEvent of- -- Pause the debuggee- VtyEvent (Vty.EvKey KEsc []) ->- halt appState- VtyEvent (Vty.EvKey (KChar 'p') []) -> do- liftIO $ pause debuggee'--- _ <- liftIO $ initialiseViews- (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree Nothing- continue (appState & majorState . mode .~- PausedMode- (OperationalState SavedAndGCRoots- FooterInfo- (DefaultRoots initRoots)- Nothing- rootsTree- Nothing- Nothing))+ RunningMode -> case brickEvent of+ -- Exit+ VtyEvent (Vty.EvKey KEsc _) ->+ halt+ -- Pause the debuggee+ VtyEvent (Vty.EvKey (KChar 'p') []) -> do+ liftIO $ pause debuggee'+ -- _ <- liftIO $ initialiseViews+ (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree Nothing+ put (appState & majorState . mode .~+ PausedMode+ (OperationalState SavedAndGCRoots+ KeybindingsHidden+ FooterInfo+ (DefaultRoots initRoots)+ Nothing+ rootsTree+ Nothing+ Nothing)) - _ -> continue appState+ _ -> return () - PausedMode os -> case brickEvent of+ PausedMode os -> case brickEvent of - -- Once the computation is finished, store the result of the- -- analysis in the state.- AppEvent (DominatorTreeReady dt) -> do- -- TODO: This should retain the state of the rootsTree, whilst- -- adding the new information.- -- rootsTree <- mkSavedAndGCRootsIOTree (Just (view getDominatorAnalysis dt))- continue (appState & majorState . mode . pausedMode . treeDominator .~ Just dt)+ -- Once the computation is finished, store the result of the+ -- analysis in the state.+ AppEvent (DominatorTreeReady dt) -> do+ -- TODO: This should retain the state of the rootsTree, whilst+ -- adding the new information.+ -- rootsTree <- mkSavedAndGCRootsIOTree (Just (view getDominatorAnalysis dt))+ put (appState & majorState . mode . pausedMode . treeDominator .~ Just dt) - AppEvent (ReverseAnalysisReady ra) -> do- continue (appState & majorState . mode . pausedMode . treeReverse .~ Just ra)+ AppEvent (ReverseAnalysisReady ra) -> do+ put (appState & majorState . mode . pausedMode . treeReverse .~ Just ra) - AppEvent (HeapGraphReady hg) -> do- continue (appState & majorState . mode . pausedMode . heapGraph .~ Just hg)+ AppEvent (HeapGraphReady hg) -> do+ put (appState & majorState . mode . pausedMode . heapGraph .~ Just hg) - -- Resume the debuggee- VtyEvent (Vty.EvKey (KFun 12) _) -> do- liftIO $ resume debuggee'- continue (appState & majorState . mode .~ RunningMode)+ -- Resume the debuggee if '^r', exit if ESC+ VtyEvent (Vty.EvKey (KChar 'r') [Vty.MCtrl]) -> do+ liftIO $ resume debuggee'+ put (appState & majorState . mode .~ RunningMode)+ VtyEvent (Vty.EvKey (KEsc) _) -> do+ liftIO $ resume debuggee'+ put $ initialAppState - VtyEvent (Vty.EvKey KEsc []) -> do- liftIO $ resume debuggee'- continue $ initialAppState+ -- handle any other more local events; mostly key events+ _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee')+ (() <$ brickEvent) - _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee')- appState (() <$ brickEvent) + where - where+ _initialiseViews = forkIO $ do+ !hg <- initialTraversal debuggee'+ writeBChan eventChan (HeapGraphReady hg)+ -- _ <- mkDominatorTreeIO hg+ -- _ <- mkReversalTreeIO hg+ return () - _initialiseViews = forkIO $ do- !hg <- initialTraversal debuggee'- writeBChan eventChan (HeapGraphReady hg)--- _ <- mkDominatorTreeIO hg--- _ <- mkReversalTreeIO hg- return ()+ -- This is really slow on big heaps, needs to be made more efficient+ -- or some progress/timeout indicator+ {-+ mkDominatorTreeIO hg = forkIO $ do+ !analysis <- runAnalysis debuggee' hg+ !rootClosures' <- liftIO $ mapM (getClosureDetails debuggee' (Just analysis) "" <=< fillConstrDesc debuggee') =<< GD.dominatorRootClosures debuggee' analysis+ let domIoTree = mkIOTree (Just analysis) rootClosures'+ (getChildren analysis) - -- This is really slow on big heaps, needs to be made more efficient- -- or some progress/timeout indicator- {-- mkDominatorTreeIO hg = forkIO $ do- !analysis <- runAnalysis debuggee' hg- !rootClosures' <- liftIO $ mapM (getClosureDetails debuggee' (Just analysis) "" <=< fillConstrDesc debuggee') =<< GD.dominatorRootClosures debuggee' analysis- let domIoTree = mkIOTree (Just analysis) rootClosures'- (getChildren analysis)+ (List.sortOn (Ord.Down . _retainerSize))+ writeBChan eventChan (DominatorTreeReady (DominatorAnalysis analysis domIoTree))+ where+ getChildren analysis _dbg c = do+ cs <- closureDominatees debuggee' analysis c+ fmap (("",)) <$> mapM (fillConstrDesc debuggee') cs+ -} - (List.sortOn (Ord.Down . _retainerSize))- writeBChan eventChan (DominatorTreeReady (DominatorAnalysis analysis domIoTree))- where- getChildren analysis _dbg c = do- cs <- closureDominatees debuggee' analysis c- fmap (("",)) <$> mapM (fillConstrDesc debuggee') cs- -} + -- mkReversalTreeIO hg = forkIO $ do+ -- let !revg = mkReverseGraph hg+ -- let revIoTree = mkIOTree Nothing [] (reverseClosureReferences hg revg) id+ -- writeBChan eventChan (ReverseAnalysisReady (ReverseAnalysis revIoTree (lookupHeapGraph hg))) --- mkReversalTreeIO hg = forkIO $ do--- let !revg = mkReverseGraph hg--- let revIoTree = mkIOTree Nothing [] (reverseClosureReferences hg revg) id--- writeBChan eventChan (ReverseAnalysisReady (ReverseAnalysis revIoTree (lookupHeapGraph hg))) + mkSavedAndGCRootsIOTree manalysis = do+ raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures debuggee'+ rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_roots+ raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee'+ savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_saved+ return $ (mkIOTree debuggee' manalysis (savedClosures' ++ rootClosures') getChildren id+ , fmap toPtr <$> (raw_roots ++ raw_saved))+ where - mkSavedAndGCRootsIOTree manalysis = do- raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures debuggee'- rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_roots- raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee'- savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_saved- return $ (mkIOTree debuggee' manalysis (savedClosures' ++ rootClosures') getChildren id- , fmap toPtr <$> (raw_roots ++ raw_saved))- where- getChildren :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr- -> IO- [(String, ListItem PayloadCont ConstrDesc StackCont ClosurePtr)]- getChildren d c = do- children <- closureReferences d c- traverse (traverse (fillListItem d)) children - fillListItem :: Debuggee- -> ListItem PayloadCont ConstrDescCont StackCont ClosurePtr- -> IO (ListItem PayloadCont ConstrDesc StackCont ClosurePtr)- fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x- fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd- fillListItem _ ListData = return ListData+getChildren :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr+ -> IO+ [(String, ListItem PayloadCont ConstrDesc StackCont ClosurePtr)]+getChildren d c = do+ children <- closureReferences d c+ traverse (traverse (fillListItem d)) children +fillListItem :: Debuggee+ -> ListItem PayloadCont ConstrDescCont StackCont ClosurePtr+ -> IO (ListItem PayloadCont ConstrDesc StackCont ClosurePtr)+fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x+fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd+fillListItem _ ListData = return ListData + mkIOTree :: Show c => Debuggee -> Maybe Analysis -> [ClosureDetails pap s c]@@ -369,27 +404,102 @@ cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children return (sort cDets) )- (\selected depth closureDesc -> hBox- [ txt (T.replicate depth " ")- , (if selected then visible . txt else txt) $- (if selected then "* " else " ")- <> renderInlineClosureDesc closureDesc- ]+ -- rendering the row+ (\state selected ctx depth closureDesc ->+ let+ body =+ (if selected then visible . highlighted else id) $+ hBox $+ renderInlineClosureDesc closureDesc+ in+ vdecorate state ctx depth body -- body (T.concat context) )- (\depth _closureDesc children -> if List.null children- then txt $ T.replicate (depth + 2) " " <> "<Empty>"- else emptyWidget) -renderInlineClosureDesc :: ClosureDetails pap s c -> Text-renderInlineClosureDesc (LabelNode t) = t+-- | 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 pap s c -> [Widget n]+renderInlineClosureDesc (LabelNode t) = [txtLabel t] renderInlineClosureDesc (InfoDetails info') =- _labelInParent info' <> " " <> _pretty info'+ [txtLabel (_labelInParent info'), txt " ", txt (_pretty info')] renderInlineClosureDesc closureDesc =- _labelInParent (_info closureDesc)- <> " "- <> pack (closureShowAddress (_closure closureDesc))- <> " "- <> _pretty (_info closureDesc)+ [ txtLabel (_labelInParent (_info closureDesc))+ , txt " "+ , txtWrap $+ pack (closureShowAddress (_closure closureDesc))+ <> " "+ <> _pretty (_info closureDesc)+ ] completeClosureDetails :: Show c => Debuggee -> Maybe Analysis -> (Text, DebugClosure pap ConstrDescCont s c) -> IO (ClosureDetails pap s c)@@ -445,22 +555,28 @@ -- Event handling when the main window has focus handleMain :: Debuggee -> Handler OperationalState-handleMain dbg os e =- case view footerMode os of- FooterInput fm tc -> inputFooterHandler dbg fm tc (handleMainWindowEvent dbg) os e- _ -> handleMainWindowEvent dbg os e+handleMain dbg e = do+ os <- get+ case view keybindingsMode os of+ KeybindingsShown ->+ case e of+ VtyEvent (Vty.EvKey _ _) -> put $ os & keybindingsMode .~ KeybindingsHidden+ _ -> put os+ _ -> case view footerMode os of+ FooterInput fm form -> inputFooterHandler dbg fm form (handleMainWindowEvent dbg) e+ _ -> handleMainWindowEvent dbg e handleMainWindowEvent :: Debuggee -> Handler OperationalState-handleMainWindowEvent _dbg os@(OperationalState treeMode' _footerMode _curRoots domTree rootsTree reverseA _hg)- brickEvent =+handleMainWindowEvent _dbg brickEvent = do+ os@(OperationalState treeMode' _kbMode _footerMode _curRoots domTree rootsTree reverseA _hg) <- get case brickEvent of- -- Change Modes- VtyEvent (Vty.EvKey (KFun 1) _) -> continue $ os & treeMode .~ SavedAndGCRoots- VtyEvent (Vty.EvKey (KFun 2) _)+ VtyEvent (Vty.EvKey (KChar '?') []) -> put $ os & keybindingsMode .~ KeybindingsShown+ VtyEvent (Vty.EvKey (KChar 's') [Vty.MCtrl]) -> put $ os & treeMode .~ SavedAndGCRoots+ VtyEvent (Vty.EvKey (KChar 't') [Vty.MCtrl]) -- Only switch if the dominator view is ready- | Just {} <- domTree -> continue $ os & treeMode .~ Dominator+ | Just {} <- domTree -> put $ os & treeMode .~ Dominator {- VtyEvent (Vty.EvKey (KFun 3) _) -- Only switch if the reverse view is ready | Just ra <- reverseA -> do@@ -472,116 +588,169 @@ continue $ os & treeMode .~ Reverse & treeReverse . _Just . reverseIOTree %~ setIOTreeRoots rs' -}- VtyEvent (Vty.EvKey (KFun 8) _) ->- continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor)+ VtyEvent (Vty.EvKey (KChar 'c') [Vty.MCtrl]) ->+ put $ os & footerMode .~ footerInput FSearch - VtyEvent (Vty.EvKey (KFun 3) _) ->- continue $ os & footerMode .~ (FooterInput FProfile emptyTextCursor)+ VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) ->+ put $ os & footerMode .~ footerInput FAddress - VtyEvent (Vty.EvKey (KFun 4) _) ->- continue $ os & footerMode .~ (FooterInput FRetainer emptyTextCursor)+ VtyEvent (Vty.EvKey (KChar 'w') [Vty.MCtrl]) ->+ put $ os & footerMode .~ footerInput FProfile - VtyEvent (Vty.EvKey (KFun 6) _) ->- continue $ os & footerMode .~ (FooterInput FRetainerExact emptyTextCursor)+ VtyEvent (Vty.EvKey (KChar 'f') [Vty.MCtrl]) ->+ put $ os & footerMode .~ footerInput FRetainer - VtyEvent (Vty.EvKey (KFun 5) _) ->- continue $ os & footerMode .~ (FooterInput FSnapshot emptyTextCursor)+ VtyEvent (Vty.EvKey (KChar 'e') [Vty.MCtrl]) ->+ put $ os & footerMode .~ footerInput FRetainerExact + VtyEvent (Vty.EvKey (KChar 'x') [Vty.MCtrl]) ->+ put $ os & footerMode .~ footerInput FSnapshot+ -- Navigate the tree of closures VtyEvent event -> case treeMode' of Dominator -> do newTree <- traverseOf (_Just . getDominatorTree) (handleIOTreeEvent event) domTree- continue (os & treeDominator .~ newTree)+ put (os & treeDominator .~ newTree) SavedAndGCRoots -> do newTree <- handleIOTreeEvent event rootsTree- continue (os & treeSavedAndGCRoots .~ newTree)+ put (os & treeSavedAndGCRoots .~ newTree) Reverse -> do newTree <- traverseOf (_Just . reverseIOTree) (handleIOTreeEvent event) reverseA- continue (os & treeReverse .~ newTree)+ put (os & treeReverse .~ newTree) Retainer t -> do newTree <- handleIOTreeEvent event t- continue (os & treeMode .~ Retainer newTree)+ put (os & treeMode .~ Retainer newTree) - _ -> continue os+ Searched t -> do+ newTree <- handleIOTreeEvent event t+ put (os & treeMode .~ Searched newTree) + _ -> return ()+ inputFooterHandler :: Debuggee -> FooterInputMode- -> TextCursor+ -> Form Text () Name -> Handler OperationalState -> Handler OperationalState-inputFooterHandler dbg m tc _k l re@(VtyEvent e) =+inputFooterHandler dbg m form _k re@(VtyEvent e) = case e of- Vty.EvKey KEsc [] -> continue (resetFooter l)- Vty.EvKey KEnter [] -> dispatchFooterInput dbg m tc l- _ ->- handleTextCursorEvent- (\tc' -> continue (set footerMode (FooterInput m tc') l))- tc re-inputFooterHandler _ _ _ k l re = k l re+ Vty.EvKey KEsc [] -> modify resetFooter+ Vty.EvKey KEnter [] -> dispatchFooterInput dbg m form+ _ -> 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- -> TextCursor- -> OperationalState- -> EventM n (Next OperationalState)-dispatchFooterInput dbg FSearch tc os = do- cps <- map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (rebuildTextCursor tc)))+ -> Form Text () Name+ -> EventM n OperationalState ()+dispatchFooterInput dbg FSearch form = do+ os <- get+ cps <- map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (formState form))) let cps' = (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'- let new_roots = map (second toPtr) cps'- root_details = res- continue (os & resetFooter- & rootsFrom .~ SearchedRoots new_roots- & treeMode .~ SavedAndGCRoots- & treeSavedAndGCRoots %~ setIOTreeRoots root_details)-dispatchFooterInput dbg FProfile tc os = do- liftIO $ profile dbg (T.unpack (rebuildTextCursor tc))- continue (os & resetFooter)-dispatchFooterInput dbg FRetainer tc os = do+ let tree = mkIOTree dbg Nothing res getChildren id+ put (os & resetFooter+ & treeMode .~ Searched tree+ )+dispatchFooterInput dbg FAddress form = do+ os <- get+ let address = T.unpack (formState form)+ case readClosurePtr address of+ Just cp -> do+ cps <- map head <$> (liftIO $ retainersOfAddress Nothing dbg [cp])+ let cps' = (zipWith (\n cp' -> (T.pack (show n),cp')) [0 :: Int ..]) cps+ res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'+ let tree = mkIOTree dbg Nothing res getChildren id+ put (os & resetFooter+ & treeMode .~ Searched tree+ )+ Nothing -> put (os & resetFooter)++dispatchFooterInput dbg FProfile form = do+ os <- get+ liftIO $ profile dbg (T.unpack (formState form))+ put (os & resetFooter)+dispatchFooterInput dbg FRetainer form = do+ os <- get let roots = mapMaybe go (map snd (currentRoots (view rootsFrom os))) go (CP p) = Just p- go (SP p) = Nothing- cps <- liftIO $ retainersOfConstructor (Just roots) dbg (T.unpack (rebuildTextCursor tc))+ go (SP _) = Nothing+ cps <- liftIO $ retainersOfConstructor (Just roots) dbg (T.unpack (formState form)) let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps' let tree = mkRetainerTree dbg res- continue (os & resetFooter+ put (os & resetFooter & treeMode .~ Retainer tree)-dispatchFooterInput dbg FRetainerExact tc os = do- cps <- liftIO $ retainersOfConstructorExact dbg (T.unpack (rebuildTextCursor tc))+dispatchFooterInput dbg FRetainerExact form = do+ os <- get+ cps <- liftIO $ retainersOfConstructorExact dbg (T.unpack (formState form)) let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps' let tree = mkRetainerTree dbg res- continue (os & resetFooter+ put (os & resetFooter & treeMode .~ Retainer tree)-dispatchFooterInput dbg FSnapshot tc os = do- liftIO $ snapshot dbg (T.unpack (rebuildTextCursor tc))- continue (os & resetFooter)+dispatchFooterInput dbg FSnapshot form = do+ os <- get+ liftIO $ snapshot dbg (T.unpack (formState form))+ put (os & resetFooter) mkRetainerTree :: Debuggee -> [[ClosureDetails PayloadCont StackCont ClosurePtr]] -> IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name mkRetainerTree dbg stacks = do let stack_map = [ (cp, rest) | stack <- stacks, Just (cp, rest) <- [List.uncons stack]] roots = map fst stack_map+ info_map :: M.Map Ptr [(String, ListItem PayloadCont ConstrDesc StackCont ClosurePtr)] info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((show n), ListFullClosure (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map] - lookup_c _dbg dc = let ptr = toPtr dc- in case M.lookup ptr info_map of- Nothing -> return []- Just ss -> return ss+ lookup_c dbg' 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+ return (cs ++ results) mkIOTree dbg Nothing roots lookup_c id resetFooter :: OperationalState -> OperationalState resetFooter l = (set footerMode FooterInfo l) -myAppStartEvent :: AppState -> EventM Name AppState-myAppStartEvent = return+myAppStartEvent :: EventM Name AppState ()+myAppStartEvent = return () myAppAttrMap :: AppState -> AttrMap-myAppAttrMap _appState = attrMap defAttr []+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)+ ] +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"++txtLabel :: Text -> Widget n+txtLabel = withAttr labelAttr . txt++highlighted :: Widget n -> Widget n+highlighted = forceAttr highlightAttr+ main :: IO () main = do eventChan <- newBChan 10@@ -589,7 +758,7 @@ writeBChan eventChan PollTick -- 2s threadDelay 2_000_000- let buildVty = mkVty defaultConfig+ let buildVty = Vty.mkVty Vty.defaultConfig initialVty <- buildVty let app :: App AppState Event Name app = App
src/Model.hs view
@@ -19,9 +19,9 @@ import System.FilePath import Data.Text(Text, pack) +import Brick.Forms import Brick.Widgets.List import IOTree-import TextCursor import Namespace import Common@@ -101,15 +101,23 @@ | InfoDetails { _info :: InfoInfo } | LabelNode { _label :: Text } -data TreeMode = Dominator | SavedAndGCRoots | Reverse | Retainer (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name)+data TreeMode = Dominator+ | SavedAndGCRoots+ | Reverse+ | Retainer (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name)+ | Searched (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name) data FooterMode = FooterInfo | FooterMessage Text- | FooterInput FooterInputMode TextCursor+ | FooterInput FooterInputMode (Form Text () Name) -data FooterInputMode = FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot+data FooterInputMode = FAddress | FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot +data KeybindingsMode = KeybindingsShown+ | KeybindingsHidden+ formatFooterMode :: FooterInputMode -> Text+formatFooterMode FAddress = "address (0x..): " formatFooterMode FSearch = "search: " formatFooterMode FProfile = "filename: " formatFooterMode FRetainer = "constructor name: "@@ -132,6 +140,7 @@ data OperationalState = OperationalState { _treeMode :: TreeMode+ , _keybindingsMode :: KeybindingsMode , _footerMode :: FooterMode , _rootsFrom :: RootsOrigin , _treeDominator :: Maybe DominatorAnalysis@@ -153,11 +162,12 @@ , _convertPtr :: ClosurePtr -> Maybe (DebugClosure PapHI ConstrDesc StackHI (Maybe HeapGraphIndex)) } pauseModeTree :: (forall pap s c . IOTree (ClosureDetails pap s c) Name -> r) -> OperationalState -> r-pauseModeTree k (OperationalState mode _ _footer dom roots reverseA _) = case mode of+pauseModeTree k (OperationalState mode _kb _footer _from dom roots reverseA _graph) = case mode of Dominator -> k $ maybe (error "DOMINATOR-DavidE is not ready") _getDominatorTree dom SavedAndGCRoots -> k roots Reverse -> k $ maybe (error "bop it, flip, reverse it, DavidE") _reverseIOTree reverseA Retainer r -> k r+ Searched r -> k r makeLenses ''AppState makeLenses ''MajorState
src/Namespace.hs view
@@ -10,6 +10,7 @@ data Name = Setup_KnownDebuggeesList | Setup_KnownSnapshotsList+ | Connected_Paused_ClosureDetails | Connected_Paused_ClosureTree | Footer deriving (Eq, Ord, Show)
− src/TextCursor.hs
@@ -1,39 +0,0 @@-module TextCursor(module Cursor.Text, module TextCursor) where--import Data.Maybe ( fromMaybe )--import Cursor.Text-import Cursor.Types--import Brick hiding (continue, halt)-import qualified Graphics.Vty as V--import Namespace---drawTextCursor :: TextCursor -> Widget Name-drawTextCursor tc =- showCursor Footer (Location (textCursorIndex tc, 0))- $ txt (rebuildTextCursor tc)--handleTextCursorEvent :: (TextCursor -> EventM Name (Next k))- -> TextCursor- -> BrickEvent n e- -> EventM Name (Next k)-handleTextCursorEvent k tc e =- case e of- VtyEvent ve ->- case ve of- V.EvKey key _mods ->- let mDo func = k . fromMaybe tc $ func tc- in case key of- V.KChar c -> mDo $ textCursorInsert c- V.KLeft -> mDo textCursorSelectPrev- V.KRight -> mDo textCursorSelectNext- V.KBS -> mDo (dullMDelete . textCursorRemove)- V.KHome -> k $ textCursorSelectStart tc- V.KEnd -> k $ textCursorSelectEnd tc- V.KDel -> mDo (dullMDelete . textCursorDelete)- _ -> k tc- _ -> k tc- _ -> k tc