ghc-debug-brick 0.2.0.0 → 0.2.1.0
raw patch · 7 files changed
+517/−27 lines, 7 filesdep +deepseqdep −cursordep ~basedep ~ghc-debug-clientdep ~ghc-debug-common
Dependencies added: deepseq
Dependencies removed: cursor
Dependency ranges changed: base, ghc-debug-client, ghc-debug-common
Files
- CHANGELOG.md +4/−0
- ghc-debug-brick.cabal +8/−5
- src/Cursor/List.hs +185/−0
- src/Cursor/Text.hs +224/−0
- src/Cursor/Types.hs +75/−0
- src/Lib.hs +3/−3
- src/Main.hs +18/−19
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for ghc-debug-brick +## 0.2.1.0 -- 2022-05-06++* Add function to find closures by exact name (F8)+ ## 0.2.0.0 -- 2021-12-06 * Second release
ghc-debug-brick.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-debug-brick-version: 0.2.0.0+version: 0.2.1.0 synopsis: A simple TUI using ghc-debug description: A simple TUI using ghc-debug -- bug-reports:@@ -21,10 +21,12 @@ , TextCursor , Common , Lib+ , Cursor.Types+ , Cursor.Text+ , Cursor.List -- other-extensions:- build-depends: base >=4.10 && <5+ build-depends: base >=4.16 && <5 , brick- , cursor , containers , directory , filepath@@ -32,9 +34,10 @@ , text , vty , time+ , deepseq , microlens- , ghc-debug-client == 0.2.0.0- , ghc-debug-common == 0.2.0.0+ , ghc-debug-client == 0.2.1.0+ , ghc-debug-common == 0.2.1.0 , ghc-debug-convention == 0.2.0.0 , unordered-containers , exceptions
+ src/Cursor/List.hs view
@@ -0,0 +1,185 @@+{-# 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 view
@@ -0,0 +1,224 @@+{-# 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 view
@@ -0,0 +1,75 @@+{-# 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/Lib.hs view
@@ -226,10 +226,10 @@ createDirectoryIfMissing True dir GD.makeSnapshot dbg (dir </> fp) -retainersOfConstructor :: Debuggee -> String -> IO [[Closure]]-retainersOfConstructor dbg con_name = do+retainersOfConstructor :: Maybe [ClosurePtr] -> Debuggee -> String -> IO [[Closure]]+retainersOfConstructor mroots dbg con_name = do run dbg $ do- roots <- GD.gcRoots+ roots <- maybe GD.gcRoots return mroots stack <- GD.findRetainersOfConstructor (Just 100) roots con_name traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack
src/Main.hs view
@@ -31,6 +31,8 @@ import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Map as M+import Data.Bifunctor+import Data.Maybe import IOTree import TextCursor@@ -328,7 +330,7 @@ mkSavedAndGCRootsIOTree manalysis = do- raw_roots <- map ("GC Roots",) <$> GD.rootClosures debuggee'+ 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@@ -470,8 +472,8 @@ continue $ os & treeMode .~ Reverse & treeReverse . _Just . reverseIOTree %~ setIOTreeRoots rs' -}--- VtyEvent (Vty.EvKey (KFun 8) _) ->--- continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor)+ VtyEvent (Vty.EvKey (KFun 8) _) ->+ continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor) VtyEvent (Vty.EvKey (KFun 3) _) -> continue $ os & footerMode .~ (FooterInput FProfile emptyTextCursor)@@ -525,26 +527,23 @@ -> OperationalState -> EventM n (Next OperationalState) dispatchFooterInput dbg FSearch tc os = do- case view heapGraph os of- Just hg -> do- -- limit to 100 results- let new_roots = take 100 $ map (\cp -> ("Searched", CP (hgeClosurePtr cp)))- (findConstructors (T.unpack (rebuildTextCursor tc)) hg)- let manalysis = view getDominatorAnalysis <$> view treeDominator os- raw_roots <- liftIO $ mapM (traverse (dereferencePtr dbg)) new_roots- root_details <-- liftIO $ mapM (completeClosureDetails dbg manalysis) raw_roots- continue (os & resetFooter- & rootsFrom .~ SearchedRoots new_roots- & treeMode .~ SavedAndGCRoots- & treeSavedAndGCRoots %~ setIOTreeRoots root_details)- -- Should never happen- Nothing -> continue os+ cps <- map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (rebuildTextCursor tc)))+ 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- cps <- liftIO $ retainersOfConstructor dbg (T.unpack (rebuildTextCursor tc))+ 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)) 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