ghc-debug-brick (empty) → 0.1.0.0
raw patch · 11 files changed
+1471/−0 lines, 11 filesdep +basedep +brickdep +containerssetup-changed
Dependencies added: base, brick, containers, cursor, directory, filepath, ghc-debug-client, ghc-debug-common, ghc-debug-convention, microlens, microlens-platform, text, time, unordered-containers, vty
Files
- CHANGELOG.md +1/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- ghc-debug-brick.cabal +42/−0
- src/Common.hs +31/−0
- src/IOTree.hs +310/−0
- src/Lib.hs +411/−0
- src/Main.hs +444/−0
- src/Model.hs +146/−0
- src/Namespace.hs +14/−0
- src/TextCursor.hs +40/−0
+ CHANGELOG.md view
@@ -0,0 +1,1 @@+# Revision history for ghc-debug-brick
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Ben Gamari++All rights reserved.++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.++ * 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.++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+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-debug-brick.cabal view
@@ -0,0 +1,42 @@+cabal-version: 2.4+name: ghc-debug-brick+version: 0.1.0.0+synopsis: A simple TUI using ghc-debug+description: A simple TUI using ghc-debug+-- bug-reports:+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+ main-is: Main.hs+ other-modules: Model+ , Namespace+ , IOTree+ , TextCursor+ , Common+ , Lib+ -- other-extensions:+ build-depends: base >=4.10 && <5+ , brick+ , cursor+ , containers+ , directory+ , filepath+ , ghc-debug-client+ , microlens-platform+ , text+ , vty+ , time+ , microlens+ , ghc-debug-common+ , ghc-debug-convention+ , unordered-containers+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -threaded -Wall
+ src/Common.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+module Common where++import qualified Brick.Types as T+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+++-- | 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 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++-- Missing instance from brick+deriving instance Functor (T.BrickEvent n)
+ src/IOTree.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module IOTree+ ( IOTree+ , IOTreePath+ , ioTree+ , setIOTreeRoots+ , getIOTreeRoots+ , renderIOTree+ , handleIOTreeEvent+ , ioTreeSelection+ , ioTreeToggle++ , ioTreeViewSelection+ , unViewTree+ , viewPath+ , viewSelect+ , viewUp+ , viewUnsafeDown+ , viewPrevSibling+ , viewNextSibling+ , viewCollapse+ , viewExpand+ , viewIsCollapsed+ ) where++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++-- 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+ -> 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.+ }++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+ -> (Bool -- Is row selected+ -> Int -- 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 = name+ , _roots = nodeToTreeNode getChildrenIO <$> rootNodes+ , _getChildren = getChildrenIO+ , _renderRow = renderRow+ , _renderFirstChild = renderFirstChild+ , _selection = []+ -- ^ 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 widgetName rs _ renderRow renderFirstChild pathTop)+ = viewport widgetName Both $ vBox $ renderTree 0 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+ -- Expanded+ Right cs -> row+ : renderFirstChild (depth + 1) node' (_node <$> cs)+ : renderTree 0 (depth + 1) 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'+ rowsRest = renderTree (minorIx + 1) depth ns path++handleIOTreeEvent :: Vty.Event -> IOTree node name -> EventM name (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 $ fromMaybe view (viewNextVisible view)+ Vty.EvKey KLeft _ -> return $ viewCollapse $ fromMaybe view (viewUp view)+ Vty.EvKey KUp _ -> return $ fromMaybe view (viewPrevVisible view)+ _ -> return view++-- | 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 down to a cild 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)}++-- | Expand the current node. Returns the children+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 view
@@ -0,0 +1,411 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ViewPatterns #-}+module Lib+ ( -- * Running/Connecting to a debuggee+ Debuggee+ , debuggeeRun+ , debuggeeConnect+ , debuggeeClose+ , withDebuggeeRun+ , withDebuggeeConnect+ , socketDirectory++ -- * Pause/Resume+ , GD.pause+ , GD.resume+ , GD.pausePoll+ , GD.withPause++ -- * Querying the paused debuggee+ , rootClosures+ , savedClosures++ -- * Closures+ , Closure+ , DebugClosure(..)+ , closureShowAddress+ , closureExclusiveSize+ , closureRetainerSize+ , closureSourceLocation+ , SourceInformation(..)+ , closureReferences+ , closurePretty+ , fillConstrDesc++ -- * Common initialisation+ , initialTraversal+ , HG.HeapGraph(..)+ -- * Dominator Tree+ , dominatorRootClosures+ , closureDominatees+ , runAnalysis+ , Analysis(..)+ , Size(..)+ , RetainerSize(..)+ -- * Reverse Edge Map+ , HG.mkReverseGraph+ , reverseClosureReferences+ , lookupHeapGraph++ -- * Types+ , Ptr(..)+ , toPtr+ , dereferencePtr+ , ConstrDesc(..)+ , ConstrDescCont+ , GenPapPayload(..)+ , StackCont+ , PayloadCont+ , ClosurePtr+ , HG.StackHI+ , HG.PapHI+ , HG.HeapGraphIndex+ --+ ) where++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Graph as G+import Data.Maybe (fromMaybe, mapMaybe)+import qualified GHC.Debug.Types as GD+import GHC.Debug.Types hiding (Closure, DebugClosure)+import GHC.Debug.Convention (socketDirectory)+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.Types.Graph as HG+import qualified GHC.Debug.Dominators as HG+import qualified Data.HashMap.Strict as HM+import Data.Tree+import Control.Monad+++data Analysis = Analysis+ { analysisDominatorRoots :: ![ClosurePtr]+ , analysisDominatees :: !(ClosurePtr -> [ClosurePtr])+ -- ^ Unsorted dominatees of a closure+ , analysisSizes :: !(ClosurePtr -> (Size, RetainerSize))+ -- ^ Size and retainer size (via dominator tree) of closures+ }++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+ quadtraverse GD.dereferencePapPayload GD.dereferenceConDesc 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 :: FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@)+ -> IO Debuggee+debuggeeConnect socketName = GD.debuggeeConnect socketName++-- | 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+ ]++-- | 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++-- -- | 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 PayloadCont ConstrDescCont StackCont ClosurePtr++data DebugClosure p cd s c+ = Closure+ { _closurePtr :: ClosurePtr+ , _closureSized :: DebugClosureWithSize p cd s c+ }+ | Stack+ { _stackPtr :: StackCont+ , _stackStack :: GD.GenStackFrames c+ }++toPtr :: DebugClosure p cd s c -> Ptr+toPtr (Closure cp _) = CP cp+toPtr (Stack sc _) = SP sc++data Ptr = CP ClosurePtr | SP StackCont++dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)+dereferencePtr dbg (CP cp) = run dbg (Closure <$> pure cp <*> GD.dereferenceClosure cp)+dereferencePtr dbg (SP sc) = run dbg (Stack <$> pure sc <*> GD.dereferenceStack sc)++instance Quadtraversable DebugClosure where+ quadtraverse p f g h (Closure cp c) = Closure cp <$> quadtraverse p f g h c+ quadtraverse _ _ _ h (Stack sp s) = Stack sp <$> traverse h s++closureShowAddress :: DebugClosure p cd s c -> String+closureShowAddress (Closure c _) = show c+closureShowAddress (Stack s _) = show s++-- | Get the exclusive size (not including any referenced closures) of a closure.+closureExclusiveSize :: DebugClosure p cd s c -> Size+closureExclusiveSize (Stack{}) = Size (-1)+closureExclusiveSize (Closure _ c) = (GD.dcSize c)++-- | Get the retained size (including all dominated closures) of a closure.+closureRetainerSize :: Analysis -> DebugClosure p cd s c -> RetainerSize+closureRetainerSize analysis c = snd (closureExcAndRetainerSizes analysis c)++closureExcAndRetainerSizes :: Analysis -> DebugClosure p cd s c -> (Size, RetainerSize)+closureExcAndRetainerSizes _ Stack{} = (Size (-1), RetainerSize (-1))+ -- ^ TODO How should we handle stack size? only used space on the stack?+ -- Include underflow frames? Return Maybe?+closureExcAndRetainerSizes analysis (Closure cPtr _) =+ let getSizes = analysisSizes analysis+ in getSizes cPtr++closureSourceLocation :: Debuggee -> DebugClosure p cd s c -> IO (Maybe SourceInformation)+closureSourceLocation _ (Stack _ _) = return Nothing+closureSourceLocation e (Closure _ c) = run e $ do+ request (RequestSourceInfo (tableId (info (noSize c))))++-- | Get the directly referenced closures (with a label) of a closure.+closureReferences :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, Closure)]+closureReferences e (Stack _ stack) = run e $ do+ let lblAndPtrs = [ ( "Frame " ++ show frameIx ++ " Pointer " ++ show ptrIx+ , ptr+ )+ | (frameIx, frame) <- zip [(0::Int)..] (GD.getFrames stack)+ , (ptrIx , ptr ) <- zip [(0::Int)..] [ptr | GD.SPtr ptr <- GD.values frame]+ ]+ closures <- GD.dereferenceClosures (snd <$> lblAndPtrs)+ return $ zipWith (\(lbl,ptr) c -> (lbl, Closure ptr c))+ lblAndPtrs+ closures+closureReferences e (Closure _ closure) = run e $ do+ let refPtrs = closureReferencesAndLabels (unDCS closure)+ forM refPtrs $ \(label, ptr) -> case ptr of+ Left cPtr -> do+ refClosure' <- GD.dereferenceClosure cPtr+ return (label, Closure cPtr refClosure')+ Right sPtr -> do+ refStack' <- GD.dereferenceStack sPtr+ return (label, Stack sPtr refStack')++reverseClosureReferences :: HG.HeapGraph Size+ -> HG.ReverseGraph+ -> Debuggee+ -> DebugClosure HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex)+ -> IO [(String, DebugClosure+ 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 HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex))+lookupHeapGraph hg cp =+ case HG.lookupHeapGraph cp hg of+ Just (HG.HeapGraphEntry ptr d s) -> Just (Closure ptr (DCS s d))+ Nothing -> Nothing++fillConstrDesc :: Debuggee+ -> DebugClosure pap ConstrDescCont s c+ -> IO (DebugClosure pap ConstrDesc s c)+fillConstrDesc e closure = do+ run e $ GD.quadtraverse pure GD.dereferenceConDesc pure pure closure++-- | Pretty print a closure+closurePretty :: Show c => DebugClosure p ConstrDesc s c -> String+closurePretty (Stack _ _) = "STACK"+closurePretty (Closure _ closure) =+ HG.ppClosure+ "??"+ (\_ refPtr -> show refPtr)+ 0+ (unDCS closure)++-- $dominatorTree+--+-- Closure `a` dominates closure `b` if all paths from GC roots to `b` pass+-- through `a`. This means that if `a` is GCed then all dominated closures can+-- be GCed. The relationship is transitive. Transitive edges are omitted in the+-- "dominator tree".+--+-- see http://kohlerm.blogspot.com/2009/02/memory-leaks-are-easy-to-find.html++-- | The roots of the dominator tree.+dominatorRootClosures :: Debuggee -> Analysis -> IO [Closure]+dominatorRootClosures e analysis = run e $ do+ let domRoots = analysisDominatorRoots analysis+ closures <- GD.dereferenceClosures domRoots+ return [ Closure closurePtr' closure+ | closurePtr' <- domRoots+ | closure <- closures+ ]++-- | Get the dominatess of a closure i.e. the children in the dominator tree.+closureDominatees :: Debuggee -> Analysis -> DebugClosure p cd s ClosurePtr -> IO [Closure]+closureDominatees _ _ (Stack{}) = error "TODO dominator tree does not yet support STACKs"+closureDominatees e analysis (Closure cPtr _) = run e $ do+ let cPtrToDominatees = analysisDominatees analysis+ cPtrs = cPtrToDominatees cPtr+ closures <- GD.dereferenceClosures cPtrs+ return [ Closure closurePtr' closure+ | closurePtr' <- cPtrs+ | closure <- closures+ ]++--+-- Internal Stuff+--++closureReferencesAndLabels :: GD.DebugClosure pap string stack pointer -> [(String, Either pointer stack)]+closureReferencesAndLabels closure = case closure of+ TSOClosure {..} ->+ [ ("Stack", Left tsoStack)+ , ("Link", Left _link)+ , ("Global Link", Left global_link)+ , ("TRec", Left trec)+ , ("Blocked Exceptions", Left blocked_exceptions)+ , ("Blocking Queue", Left bq)+ ]+ StackClosure{..} -> [("Frames", Right frames )]+ WeakClosure {..} -> [ ("Key", Left key)+ , ("Value", Left value)+ , ("C Finalizers", Left cfinalizers)+ , ("Finalizer", Left finalizer)+ ] +++ [ ("Link", Left link)+ | Just link <- [mlink] -- TODO do we want to show NULL pointers some how?+ ]+ TVarClosure {..} -> [("val", Left current_value)]+ MutPrimClosure {..} -> withArgLables ptrArgs+ ConstrClosure {..} -> withFieldLables ptrArgs+ ThunkClosure {..} -> withArgLables ptrArgs+ SelectorClosure {..} -> [("Selectee", Left selectee)]+ IndClosure {..} -> [("Indirectee", Left indirectee)]+ BlackholeClosure {..} -> [("Indirectee", Left indirectee)]+ APClosure {..} -> ("Function", Left fun) : [] -- TODO withBitmapLables ap_payload+ PAPClosure {..} -> ("Function", Left fun) : [] -- TODO: withBitmapLables pap_payload+ APStackClosure {..} -> ("Function", Left fun) : ("Frames", Right payload) : []+ BCOClosure {..} -> [ ("Instructions", Left instrs)+ , ("Literals", Left literals)+ , ("Byte Code Objects", Left bcoptrs)+ ]+ ArrWordsClosure {} -> []+ MutArrClosure {..} -> withIxLables mccPayload+ SmallMutArrClosure {..} -> withIxLables mccPayload+ MutVarClosure {..} -> [("Value", Left var)]+ MVarClosure {..} -> [ ("Queue Head", Left queueHead)+ , ("Queue Tail", Left queueTail)+ , ("Value", Left value)+ ]+ FunClosure {..} -> withArgLables ptrArgs+ BlockingQueueClosure {..} -> [ ("Link", Left link)+ , ("Black Hole", Left blackHole)+ , ("Owner", Left owner)+ , ("Queue", Left queue)+ ]+ OtherClosure {..} -> ("",) . Left <$> hvalues+ TRecChunkClosure{} -> [] --TODO+ UnsupportedClosure {} -> []+ where+ withIxLables elements = [("[" <> show i <> "]" , Left x) | (i, x) <- zip [(0::Int)..] elements]+ withArgLables ptrArgs = [("Argument " <> show i, Left x) | (i, x) <- zip [(0::Int)..] ptrArgs]+ withFieldLables ptrArgs = [("Field " <> show i , Left 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 view
@@ -0,0 +1,444 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NumericUnderscores #-}++module Main where+import Control.Applicative+import Control.Monad (forever, (<=<))+import Control.Monad.IO.Class+import Control.Concurrent+import qualified Data.List as List+import Data.Maybe (fromJust)+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 Graphics.Vty.Input.Events (Key(..))+import Lens.Micro.Platform+import System.Directory+import System.FilePath+import Data.Text (Text, pack)+import qualified Data.Text as T++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 Lib as GD++import Model++data Event+ = PollTick -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees+ | DominatorTreeReady DominatorAnalysis -- A signal when the dominator tree has been computed+ | ReverseAnalysisReady ReverseAnalysis+ | HeapGraphReady (HeapGraph GD.Size)++myAppDraw :: AppState -> [Widget Name]+myAppDraw (AppState majorState') =+ [ case majorState' of++ Setup knownDebuggees' -> let+ nKnownDebuggees = Seq.length $ majorState'^.knownDebuggees.listElementsL+ in mainBorder "ghc-debug" $ vBox+ [ txt $ "Select a process to debug (" <> pack (show nKnownDebuggees) <> " found):"+ , renderList+ (\elIsSelected socketPath -> hBox+ [ txt $ if elIsSelected then "*" else " "+ , txt " "+ , txt (socketName socketPath)+ , txt " - "+ , txt (renderSocketTime socketPath)+ ]+ )+ True+ knownDebuggees'+ ]++ Connected _socket _debuggee mode' -> case mode' of++ RunningMode -> mainBorder "ghc-debug - Running" $ vBox+ [ txt "Pause (p)"+ ]++ (PausedMode os@(OperationalState treeMode' fmode _ro dtree _ reverseTree hg)) -> let+ in mainBorder "ghc-debug - Paused" $ vBox+ [ hBox+ [ border $ vBox+ ([ txt "Resume (F12)"+ , txt "Parent (<-)"+ , txt "Child (->)"+ , txt "Saved/GC Roots (F1)"+ ] +++ [ txt "Dominator Tree (F2)" | Just {} <- [dtree] ]+ +++ [ txt "Reverse Analysis (F3)" | Just {} <- [reverseTree] ]+ +++ [ txt "Search for Constructor (F8)" | Just {} <- [hg] ] )+ , -- Current closure details+ borderWithLabel (txt "Closure Details") $ pauseModeTree (renderClosureDetails . ioTreeSelection) os+ ]+ , -- Tree+ borderWithLabel+ (txt $ case treeMode' of+ Dominator -> "Dominator Tree"+ SavedAndGCRoots -> "Root Closures"+ Reverse -> "Reverse Edges"+ )+ (pauseModeTree renderIOTree os)+ , hBorder+ , footer fmode+ ]+ ]+ where+ mainBorder title = borderWithLabel (txt title) . padAll 1++ renderClosureDetails :: Maybe (ClosureDetails pap s c) -> Widget Name+ renderClosureDetails cd = vLimit 9 $ vBox $+ [ txt "SourceLocation "+ <+> txt (maybe "" renderSourceInformation (_sourceLocation =<< cd))+ -- TODO these aren't actually implemented yet+ -- , txt $ "Type "+ -- <> fromMaybe "" (_closureType =<< cd)+ -- , txt $ "Constructor "+ -- <> fromMaybe "" (_constructor =<< cd)+ , txt $ "Exclusive Size "+ <> maybe "" (pack . show @Int . GD.getSize) (_excSize <$> cd) <> " bytes"+ , txt $ "Retained Size "+ <> maybe "" (pack . show @Int . GD.getRetainerSize) (_retainerSize =<< cd) <> " bytes"+ , fill ' '+ ]+ renderSourceInformation :: SourceInformation -> T.Text+ renderSourceInformation (SourceInformation name cty ty label modu loc) =+ T.pack $ unlines [name, show cty, ty, label, modu, loc]++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+++myAppHandleEvent :: BChan Event -> AppState -> BrickEvent Name Event -> EventM Name (Next AppState)+myAppHandleEvent eventChan appState@(AppState majorState') brickEvent = case brickEvent of+ VtyEvent (Vty.EvKey KEsc []) -> halt appState+ _ -> case majorState' of+ Setup knownDebuggees' -> case brickEvent of++ VtyEvent event -> case event of+ -- Connect to the selected debuggee+ Vty.EvKey KEnter _+ | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees'+ -> do+ debuggee' <- liftIO $ debuggeeConnect (view socketLocation socket)+ continue $ appState & majorState .~ Connected+ { _debuggeeSocket = socket+ , _debuggee = debuggee'+ , _mode = RunningMode -- TODO should we query the debuggee for this?+ }++ -- Navigate through the list.+ _ -> do+ newOptions <- handleListEventVi handleListEvent event knownDebuggees'+ continue $ appState & majorState . knownDebuggees .~ newOptions++ AppEvent event -> case event of+ PollTick -> do+ -- Poll for debuggees+ knownDebuggees'' <- liftIO $ do+ dir :: FilePath <- socketDirectory+ 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 knownDebuggees')++ 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))+ knownDebuggees'++ continue $ appState & majorState . knownDebuggees .~ knownDebuggees''+ DominatorTreeReady {} -> continue appState+ ReverseAnalysisReady {} -> continue appState+ HeapGraphReady {} -> continue appState+ _ -> continue appState++ Connected _socket' debuggee' mode' -> case mode' of++ RunningMode -> case brickEvent of+ -- Pause the debuggee+ 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))++ _ -> continue appState++ 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)++ AppEvent (ReverseAnalysisReady ra) -> do+ continue (appState & majorState . mode . pausedMode . treeReverse .~ Just ra)++ AppEvent (HeapGraphReady hg) -> do+ continue (appState & majorState . mode . pausedMode . heapGraph .~ Just hg)++ -- Resume the debuggee+ VtyEvent (Vty.EvKey (KFun 12) _) -> do+ liftIO $ resume debuggee'+ continue (appState & majorState . mode .~ RunningMode)++ _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee')+ appState (() <$ brickEvent)++++ where++ initialiseViews = forkIO $ do+ !hg <- initialTraversal debuggee'+ writeBChan eventChan (HeapGraphReady hg)+ _ <- mkDominatorTreeIO hg+ _ <- mkReversalTreeIO hg+ return ()++ -- This is really slow on big heaps, needs to be made more efficient+ -- or some progress/timeout indicator+ mkDominatorTreeIO hg = forkIO $ do+ !analysis <- runAnalysis debuggee' hg+ !rootClosures' <- liftIO $ mapM (getClosureDetails debuggee' (Just analysis) "" <=< fillConstrDesc debuggee') =<< GD.dominatorRootClosures debuggee' analysis+ let domIoTree = mkIOTree (Just analysis) rootClosures'+ (getChildren analysis)++ (List.sortOn (Ord.Down . _retainerSize))+ writeBChan eventChan (DominatorTreeReady (DominatorAnalysis analysis domIoTree))+ where+ getChildren analysis _dbg c = do+ cs <- closureDominatees debuggee' analysis c+ fmap (("",)) <$> mapM (fillConstrDesc debuggee') cs+++ mkReversalTreeIO hg = forkIO $ do+ let !revg = mkReverseGraph hg+ let revIoTree = mkIOTree Nothing [] (reverseClosureReferences hg revg) id+ writeBChan eventChan (ReverseAnalysisReady (ReverseAnalysis revIoTree (lookupHeapGraph hg)))+++ mkSavedAndGCRootsIOTree manalysis = do+ raw_roots <- 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 manalysis (savedClosures' ++ rootClosures') getChildren id+ , fmap toPtr <$> (raw_roots ++ raw_saved))+ where+ getChildren d c = do+ children <- closureReferences d c+ mapM (mapM (fillConstrDesc d)) children+++ mkIOTree :: Show c => Maybe Analysis -> [ClosureDetails pap s c] -> (Debuggee -> DebugClosure pap ConstrDesc s c -> IO [(String, DebugClosure pap ConstrDesc s c)]) -> ([ClosureDetails pap s c] -> [ClosureDetails pap s c]) -> IOTree (ClosureDetails pap s c) Name+ mkIOTree manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree+ (sort cs)+ (\c -> do+ children <- getChildren debuggee' (_closure c)+ 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 " ")+ <> _labelInParent closureDesc+ <> " "+ <> pack (closureShowAddress (_closure closureDesc))+ <> " "+ <> _pretty closureDesc+ ]+ )+ (\depth _closureDesc children -> if List.null children+ then txt $ T.replicate (depth + 2) " " <> "<Empty>"+ else emptyWidget+ )+completeClosureDetails :: Show c => Debuggee -> Maybe Analysis+ -> (Text, DebugClosure pap ConstrDescCont s c)+ -> IO (ClosureDetails pap s c)++completeClosureDetails dbg manalysis (label, clos) =+ getClosureDetails dbg manalysis label =<< fillConstrDesc dbg clos++++getClosureDetails :: Show c => Debuggee+ -> Maybe Analysis+ -> Text+ -> DebugClosure pap ConstrDesc s c+ -> IO (ClosureDetails pap s c)+getClosureDetails debuggee' manalysis label c = do+ let excSize' = closureExclusiveSize c+ retSize' = closureRetainerSize <$> manalysis <*> pure c+ sourceLoc <- closureSourceLocation debuggee' c+ let pretty' = closurePretty c+ return ClosureDetails+ { _closure = c+ , _pretty = pack pretty'+ , _labelInParent = label+ , _sourceLocation = sourceLoc+ , _closureType = Nothing+ , _constructor = Nothing+ , _excSize = excSize'+ , _retainerSize = retSize'+ }+++-- 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++handleMainWindowEvent :: Debuggee+ -> Handler OperationalState+handleMainWindowEvent _dbg os@(OperationalState treeMode' _footerMode _curRoots domTree rootsTree reverseA _hg)+ brickEvent =+ case brickEvent of++ -- Change Modes+ VtyEvent (Vty.EvKey (KFun 1) _) -> continue $ os & treeMode .~ SavedAndGCRoots+ VtyEvent (Vty.EvKey (KFun 2) _)+ -- Only switch if the dominator view is ready+ | Just {} <- domTree -> continue $ os & treeMode .~ Dominator+ VtyEvent (Vty.EvKey (KFun 3) _)+ -- Only switch if the reverse view is ready+ | Just ra <- reverseA -> do+ -- Get roots from rootTree and use those for the reverse view+ let rs = getIOTreeRoots rootsTree+ convert cd = cd & closure %~ do_one+ do_one cd = fromJust (view convertPtr ra $ _closurePtr cd)+ rs' = map convert rs+ continue $ os & treeMode .~ Reverse+ & treeReverse . _Just . reverseIOTree %~ setIOTreeRoots rs'+ VtyEvent (Vty.EvKey (KFun 8) _) ->+ continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor)++ -- Navigate the tree of closures+ VtyEvent event -> case treeMode' of+ Dominator -> do+ newTree <- traverseOf (_Just . getDominatorTree) (handleIOTreeEvent event) domTree+ continue (os & treeDominator .~ newTree)+ SavedAndGCRoots -> do+ newTree <- handleIOTreeEvent event rootsTree+ continue (os & treeSavedAndGCRoots .~ newTree)+ Reverse -> do+ newTree <- traverseOf (_Just . reverseIOTree) (handleIOTreeEvent event) reverseA+ continue (os & treeReverse .~ newTree)+ _ -> continue os++inputFooterHandler :: Debuggee+ -> FooterInputMode+ -> TextCursor+ -> Handler OperationalState+ -> Handler OperationalState+inputFooterHandler dbg m tc _k l 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++-- | 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+ 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++resetFooter :: OperationalState -> OperationalState+resetFooter l = (set footerMode FooterInfo l)++myAppStartEvent :: AppState -> EventM Name AppState+myAppStartEvent = return++myAppAttrMap :: AppState -> AttrMap+myAppAttrMap _appState = attrMap defAttr []++main :: IO ()+main = do+ eventChan <- newBChan 10+ _ <- forkIO $ forever $ do+ writeBChan eventChan PollTick+ -- 2s+ threadDelay 2_000_000+ let buildVty = mkVty defaultConfig+ initialVty <- buildVty+ let app :: App AppState Event Name+ app = App+ { appDraw = myAppDraw+ , appChooseCursor = showFirstCursor+ , appHandleEvent = (myAppHandleEvent eventChan)+ , appStartEvent = myAppStartEvent+ , appAttrMap = myAppAttrMap+ }+ _finalState <- customMain initialVty buildVty+ (Just eventChan) app initialAppState+ return ()
+ src/Model.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}++module Model+ ( module Model+ , module Namespace+ , module Common+ ) where++import Data.Sequence as Seq+import Lens.Micro.Platform+import Data.Time+import System.Directory+import System.FilePath+import Data.Text(Text, pack)++import Brick.Widgets.List+import IOTree+import TextCursor++import Namespace+import Common+import Lib+++initialAppState :: AppState+initialAppState = AppState+ { _majorState = Setup+ { _knownDebuggees = list Setup_KnownDebuggeesList [] 1+ }+ }++data AppState = AppState+ { _majorState :: MajorState+ }++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++data MajorState+ -- | We have not yet connected to a debuggee.+ = Setup+ { _knownDebuggees :: GenericList Name Seq SocketInfo+ }++ -- | Connected to a debuggee+ | Connected+ { _debuggeeSocket :: SocketInfo+ , _debuggee :: Debuggee+ , _mode :: ConnectedMode+ }++data ClosureDetails pap s c = ClosureDetails+ { _closure :: DebugClosure pap ConstrDesc s c+ , _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+ , _excSize :: Size+ , _retainerSize :: Maybe RetainerSize+ }++data TreeMode = Dominator | SavedAndGCRoots | Reverse++data FooterMode = FooterInfo+ | FooterMessage Text+ | FooterInput FooterInputMode TextCursor++data FooterInputMode = FSearch++formatFooterMode :: FooterInputMode -> Text+formatFooterMode FSearch = "search: "++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+ { _treeMode :: TreeMode+ , _footerMode :: FooterMode+ , _rootsFrom :: RootsOrigin+ , _treeDominator :: Maybe DominatorAnalysis+ -- ^ Tree corresponding to Dominator mode+ , _treeSavedAndGCRoots :: IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name+ -- ^ Tree corresponding to SavedAndGCRoots mode+ , _treeReverse :: Maybe ReverseAnalysis+ -- ^ Tree corresponding to Dominator mode+ , _heapGraph :: Maybe (HeapGraph Size)+ -- ^ Raw heap graph+ }++data DominatorAnalysis =+ DominatorAnalysis { _getDominatorAnalysis :: Analysis+ , _getDominatorTree :: IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name+ }++data ReverseAnalysis = ReverseAnalysis { _reverseIOTree :: IOTree (ClosureDetails PapHI StackHI (Maybe HeapGraphIndex)) Name+ , _convertPtr :: ClosurePtr -> Maybe (DebugClosure PapHI ConstrDesc StackHI (Maybe HeapGraphIndex)) }++pauseModeTree :: (forall pap s c . IOTree (ClosureDetails pap s c) Name -> r) -> OperationalState -> r+pauseModeTree k (OperationalState mode _ _footer dom roots reverseA _) = 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++makeLenses ''AppState+makeLenses ''MajorState+makeLenses ''ClosureDetails+makeLenses ''ConnectedMode+makeLenses ''OperationalState+makeLenses ''SocketInfo+makeLenses ''DominatorAnalysis+makeLenses ''ReverseAnalysis
+ src/Namespace.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Namespace where++data Name+ = Setup_KnownDebuggeesList+ | Connected_Paused_ClosureTree+ | Footer+ deriving (Eq, Ord, Show)
+ src/TextCursor.hs view
@@ -0,0 +1,40 @@+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 Brick.Types ( Widget )+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