{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Brick
import Brick.BChan
import Brick.Forms
import Brick.Widgets.Border
import Brick.Widgets.Center (centerLayer, hCenter)
import Brick.Widgets.List
import Control.Applicative
import Control.Monad (forever, forM)
import Control.Monad.IO.Class
import Control.Monad.Catch (bracket)
import Control.Concurrent
import qualified Data.List as List
import Data.Ord (comparing)
import qualified Data.Ord as Ord
import qualified Data.Sequence as Seq
import qualified Graphics.Vty as Vty
import qualified Graphics.Vty.CrossPlatform as Vty
import Graphics.Vty.Input.Events (Key(..))
import Lens.Micro.Platform
import System.Directory
import System.FilePath
import Data.Bool
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as BS
import qualified Data.Set as S
import qualified Data.Foldable as F
import Text.Read (readMaybe)
import qualified GHC.Debug.Profile as GDP
import GHC.Debug.Profile.Types
import Data.Semigroup
import GHC.Debug.Types.Ptr(readInfoTablePtr, arrWordsBS)
import qualified GHC.Debug.Types.Closures as Debug
import IOTree
import Lib as GD
import Model
import Data.ByteUnits
import Data.Time.Format
import Data.Time.Clock
import qualified Numeric
drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name
drawSetup herald other_herald vals =
let nKnownDebuggees = Seq.length $ (vals ^. listElementsL)
in mainBorder "ghc-debug" $ vBox
[ hBox
[ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):"
]
, renderList
(\elIsSelected socketPath -> (if elIsSelected then highlighted else id) $ hBox
[ txt (socketName socketPath)
, txt " - "
, txt (renderSocketTime socketPath)
]
)
True
vals
, vLimit 1 $ withAttr menuAttr $ hBox [txt $ "(ESC): exit | (TAB): toggle " <> other_herald <> " view", fill ' ']
]
mainBorder :: Text -> Widget a -> Widget a
mainBorder title w = -- borderWithLabel (txt title) . padAll 1
vLimit 1 (withAttr menuAttr $ hCenter $ fill ' ' <+> txt title <+> fill ' ') <=> w
myAppDraw :: AppState -> [Widget Name]
myAppDraw (AppState majorState' _) =
case majorState' of
Setup setupKind' dbgs snaps ->
case setupKind' of
Socket -> [drawSetup "process" "snapshots" dbgs]
Snapshot -> [drawSetup "snapshot" "processes" snaps]
Connected socket _debuggee mode' -> case mode' of
RunningMode -> [mainBorder ("ghc-debug - Running - " <> socketName socket) $ vBox
[ txtWrap "There is nothing you can do until the process is paused by pressing (p) ..."
, fill ' '
, withAttr menuAttr $ vLimit 1 $ hBox [txt "(p): Pause | (ESC): Exit", fill ' ']
]]
(PausedMode os@(OperationalState _ last_task treeMode' kbmode fmode _ _ _ _ rfilters debuggeeVersion)) -> let
last_task_string =
case last_task of
Nothing -> ""
Just (d,t) -> " - " <> d <> " (" <> T.pack (formatTime defaultTimeLocale "%2Es" t) <> "s)"
in kbOverlay kbmode debuggeeVersion
$ [mainBorder ("ghc-debug - Paused - " <> socketName socket <> last_task_string) $ vBox
[ -- Current closure details
joinBorders $ (borderWithLabel (txt "Closure Details") $
(vLimit 9 $
pauseModeTree (\r io -> maybe emptyWidget r (ioTreeSelection io)) os
<=> fill ' '))
<+> (filterWindow rfilters)
, -- Tree
joinBorders $ borderWithLabel
(txt $ case treeMode' of
SavedAndGCRoots {} -> "Root Closures"
Retainer {} -> "Retainers"
Searched {} -> "Search Results"
)
(pauseModeTree (\_ -> renderIOTree) os)
, footer (osSize os) (_resultSize os) fmode
]]
where
kbOverlay :: OverlayMode -> GD.Version -> [Widget Name] -> [Widget Name]
kbOverlay KeybindingsShown _ ws = centerLayer kbWindow : ws
kbOverlay (CommandPicker inp cmd_list _) debuggeeVersion ws = centerLayer (cpWindow debuggeeVersion inp cmd_list) : ws
kbOverlay NoOverlay _ ws = ws
filterWindow [] = emptyWidget
filterWindow xs = borderWithLabel (txt "Filters") $ hLimit 50 $ vBox $ map renderUIFilter xs
cpWindow :: GD.Version -> Form Text () Name -> GenericList Name Seq.Seq Command -> Widget Name
cpWindow debuggeeVersion input cmd_list = hLimit (actual_width + 2) $ vLimit (length commandList + 4) $
withAttr menuAttr $
borderWithLabel (txt "Command Picker") $ vBox $
[ renderForm input
, renderList (\elIsSelected -> if elIsSelected then highlighted . renderCommand debuggeeVersion else renderCommand debuggeeVersion) False cmd_list]
kbWindow :: Widget Name
kbWindow =
withAttr menuAttr $
borderWithLabel (txt "Keybindings") $ vBox $
map renderCommandDesc all_keys
all_keys =
[ ("Resume", Just (Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl]))
, ("Parent", Just (Vty.EvKey KLeft []))
, ("Child", Just (Vty.EvKey KRight []))
, ("Command Picker", Just (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]))
, ("Invert Filter", Just invertFilterEvent)]
++ [(commandDescription cmd, commandKey cmd) | cmd <- F.toList commandList ]
++ [ ("Exit", Just (Vty.EvKey KEsc [])) ]
maximum_size = maximum (map (T.length . fst) all_keys)
actual_width = maximum_size + 5 -- 5, maximum width of rendering a key
+ 1 -- 1, at least one padding
renderKey :: Vty.Event -> Text
renderKey (Vty.EvKey (KFun n) []) = "(F" <> T.pack (show n) <> ")"
renderKey (Vty.EvKey k [Vty.MCtrl]) = "(^" <> renderNormalKey k <> ")"
renderKey (Vty.EvKey k []) = "(" <> renderNormalKey k <> ")"
renderKey _k = "()"
renderNormalKey (KChar c) = T.pack [c]
renderNormalKey KEsc = "ESC"
renderNormalKey KLeft = "←"
renderNormalKey KRight = "→"
renderNormalKey _k = "�"
mayDisableMenuItem debuggeeVersion cmd
| isCmdDisabled debuggeeVersion cmd = disabledMenuItem
| otherwise = id
renderCommand debuggeeVersion cmd =
mayDisableMenuItem debuggeeVersion cmd $
renderCommandDesc (commandDescription cmd, commandKey cmd)
renderCommandDesc :: (Text, Maybe Vty.Event) -> Widget Name
renderCommandDesc (desc, k) = txt (desc <> T.replicate padding " " <> key)
where
key = maybe mempty renderKey k
padding = (actual_width - T.length desc - T.length key)
renderInfoInfo :: InfoInfo -> [Widget Name]
renderInfoInfo info' =
maybe [] renderSourceInformation (_sourceLocation info')
++ profHeaderInfo
-- TODO these aren't actually implemented yet
-- , txt $ "Type "
-- <> fromMaybe "" (_closureType =<< cd)
-- , txt $ "Constructor "
-- <> fromMaybe "" (_constructor =<< cd)
where
profHeaderInfo = case _profHeaderInfo info' of
Just x ->
let plabel = case x of
Debug.RetainerHeader{} -> "Retainer info"
Debug.LDVWord{} -> "LDV info"
Debug.EraWord{} -> "Era"
Debug.OtherHeader{} -> "Other"
in [labelled plabel $ vLimit 1 (txt $ renderProfHeaderInline x)]
Nothing -> []
renderProfHeaderInline :: ProfHeaderWord -> Text
renderProfHeaderInline pinfo =
case pinfo of
Debug.RetainerHeader {} -> pack (show pinfo) -- This should never be visible
Debug.LDVWord {state, creationTime, lastUseTime} ->
(if state then "✓" else "✘") <> " created: " <> pack (show creationTime) <> (if state then " last used: " <> pack (show lastUseTime) else "")
Debug.EraWord era -> pack (show era)
Debug.OtherHeader other -> "Not supported: " <> pack (show other)
renderSourceInformation :: SourceInformation -> [Widget Name]
renderSourceInformation (SourceInformation name cty ty label' modu loc) =
[ labelled "Name" $ vLimit 1 (str name)
, labelled "Closure type" $ vLimit 1 (str (show cty))
, labelled "Type" $ vLimit 3 (str ty)
, labelled "Label" $ vLimit 1 (str label')
, labelled "Module" $ vLimit 1 (str modu)
, labelled "Location" $ vLimit 1 (str loc)
]
labelled :: Text -> Widget Name -> Widget Name
labelled = labelled' 20
labelled' :: Int -> Text -> Widget Name -> Widget Name
labelled' leftSize lbl w =
hLimit leftSize (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ')
renderUIFilter :: UIFilter -> Widget Name
renderUIFilter (UIAddressFilter invert x) = labelled (bool "" "!" invert <> "Closure address") (str (show x))
renderUIFilter (UIInfoAddressFilter invert x) = labelled (bool "" "!" invert <> "Info table address") (str (show x))
renderUIFilter (UIConstructorFilter invert x) = labelled (bool "" "!" invert <> "Constructor name") (str x)
renderUIFilter (UIInfoNameFilter invert x) = labelled (bool "" "!" invert <> "Constructor name (exact)") (str x)
renderUIFilter (UIEraFilter invert x) = labelled (bool "" "!" invert <> "Era range") (str (showEraRange x))
renderUIFilter (UISizeFilter invert x) = labelled (bool "" "!" invert <> "Size (lower bound)") (str (show $ getSize x))
renderUIFilter (UIClosureTypeFilter invert x) = labelled (bool "" "!" invert <> "Closure type") (str (show x))
renderUIFilter (UICcId invert x) = labelled (bool "" "!" invert <> "CC Id") (str (show x))
renderClosureDetails :: ClosureDetails -> Widget Name
renderClosureDetails (cd@(ClosureDetails {})) =
vLimit 8 $
-- viewport Connected_Paused_ClosureDetails Both $
vBox $
renderInfoInfo (_info cd)
++
[ hBox
[ txtLabel "Exclusive Size" <+> vSpace <+> renderBytes (GD.getSize $ _excSize cd)
]
]
renderClosureDetails ((LabelNode n)) = txt n
renderClosureDetails ((InfoDetails info')) = vLimit 8 $ vBox $ renderInfoInfo info'
renderClosureDetails (CCSDetails _ _ptr (Debug.CCSPayload{..})) = vLimit 8 $ vBox $
[ labelled "ID" $ vLimit 1 (str $ show ccsID)
] ++ renderCCPayload ccsCc
renderClosureDetails (CCDetails _ c) = vLimit 8 $ vBox $ renderCCPayload c
renderCCPayload :: CCPayload -> [Widget Name]
renderCCPayload Debug.CCPayload{..} =
[ labelled "Label" $ vLimit 1 (str ccLabel)
, labelled "CC ID" $ vLimit 1 (str $ show ccID)
, labelled "Module" $ vLimit 1 (str ccMod)
, labelled "Location" $ vLimit 1 (str ccLoc)
, labelled "Allocation" $ vLimit 1 (str $ show ccMemAlloc)
, labelled "Time Ticks" $ vLimit 1 (str $ show ccTimeTicks)
, labelled "Is CAF" $ vLimit 1 (str $ show ccIsCaf)
]
renderBytes :: Real a => a -> Widget n
renderBytes n =
str (getShortHand (getAppropriateUnits (ByteValue (realToFrac n) Bytes)))
footer :: Int -> Maybe Int -> FooterMode -> Widget Name
footer n m fmode = vLimit 1 $
case fmode of
FooterMessage t -> withAttr menuAttr $ hBox [txt t, fill ' ']
FooterInfo -> withAttr menuAttr $ hBox $ [padRight Brick.Max $ txt "(↑↓): select item | (→): expand | (←): collapse | (^p): command picker | (^g): invert filter | (?): full keybindings"]
++ [padLeft (Pad 1) $ str $
(show n <> " items/" <> maybe "∞" show m <> " max")]
FooterInput _im form -> renderForm form
footerInput :: FooterInputMode -> FooterMode
footerInput im =
FooterInput im (footerInputForm im)
footerInputForm :: FooterInputMode -> Form Text e Name
footerInputForm im =
newForm [(\w -> txtLabel (formatFooterMode im) <+> forceAttr inputAttr w) @@= editTextField id Footer (Just 1)] ""
updateListFrom :: MonadIO m =>
IO FilePath
-> GenericList n Seq.Seq SocketInfo
-> m (GenericList n Seq.Seq SocketInfo)
updateListFrom dirIO llist = liftIO $ do
dir :: FilePath <- dirIO
debuggeeSocketFiles :: [FilePath] <- listDirectory dir <|> return []
-- Sort the sockets by the time they have been created, newest
-- first.
debuggeeSockets <- List.sortBy (comparing Ord.Down)
<$> mapM (mkSocketInfo . (dir </>)) debuggeeSocketFiles
let currentSelectedPathMay :: Maybe SocketInfo
currentSelectedPathMay = fmap snd (listSelectedElement llist)
newSelection :: Maybe Int
newSelection = do
currentSelectedPath <- currentSelectedPathMay
List.findIndex ((currentSelectedPath ==)) debuggeeSockets
return $ listReplace
(Seq.fromList debuggeeSockets)
(newSelection <|> (if Prelude.null debuggeeSockets then Nothing else Just 0))
llist
myAppHandleEvent :: BrickEvent Name Event -> EventM Name AppState ()
myAppHandleEvent brickEvent = do
appState@(AppState majorState' eventChan) <- get
case brickEvent of
_ -> case majorState' of
Setup st knownDebuggees' knownSnapshots' -> case brickEvent of
VtyEvent (Vty.EvKey KEsc _) -> halt
VtyEvent event -> case event of
-- Connect to the selected debuggee
Vty.EvKey (KChar '\t') [] -> do
put $ appState & majorState . setupKind %~ toggleSetup
Vty.EvKey KEnter _ ->
case st of
Snapshot
| Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots'
-> do
debuggee' <- liftIO $ snapshotConnect (writeBChan eventChan . ProgressMessage) (view socketLocation socket)
put $ appState & majorState .~ Connected
{ _debuggeeSocket = socket
, _debuggee = debuggee'
, _mode = RunningMode -- TODO should we query the debuggee for this?
}
Socket
| Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees'
-> do
bracket
(liftIO $ debuggeeConnect (writeBChan eventChan . ProgressMessage) (view socketLocation socket))
(\debuggee' -> liftIO $ resume debuggee')
(\debuggee' ->
put $ appState & majorState .~ Connected
{ _debuggeeSocket = socket
, _debuggee = debuggee'
, _mode = RunningMode -- TODO should we query the debuggee for this?
})
_ -> return ()
-- Navigate through the list.
_ -> do
case st of
Snapshot -> do
zoom (majorState . knownSnapshots) (handleListEventVi handleListEvent event)
Socket -> do
zoom (majorState . knownDebuggees) (handleListEventVi handleListEvent event)
AppEvent event -> case event of
PollTick -> do
-- Poll for debuggees
knownDebuggees'' <- updateListFrom socketDirectory knownDebuggees'
knownSnapshots'' <- updateListFrom snapshotDirectory knownSnapshots'
put $ appState & majorState . knownDebuggees .~ knownDebuggees''
& majorState . knownSnapshots .~ knownSnapshots''
_ -> return ()
_ -> return ()
Connected _socket' debuggee' mode' -> case mode' of
RunningMode -> case brickEvent of
-- Exit
VtyEvent (Vty.EvKey KEsc _) ->
halt
-- Pause the debuggee
VtyEvent (Vty.EvKey (KChar 'p') []) -> do
liftIO $ pause debuggee'
ver <- liftIO $ GD.version debuggee'
(rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree
put (appState & majorState . mode .~
PausedMode
(OperationalState Nothing
Nothing
savedAndGCRoots
NoOverlay
FooterInfo
(DefaultRoots initRoots)
rootsTree
eventChan
(Just 100)
[]
ver))
_ -> return ()
PausedMode os -> case brickEvent of
_ -> case brickEvent of
-- Resume the debuggee if '^r', exit if ESC
VtyEvent (Vty.EvKey (KChar 'r') [Vty.MCtrl]) -> do
liftIO $ resume debuggee'
put (appState & majorState . mode .~ RunningMode)
VtyEvent (Vty.EvKey (KEsc) _) | NoOverlay <- view keybindingsMode os
, not (isFocusedFooter (view footerMode os)) -> do
case view running_task os of
Just tid -> do
liftIO $ killThread tid
put $ appState & majorState . mode . pausedMode . running_task .~ Nothing
& majorState . mode . pausedMode %~ resetFooter
Nothing -> do
liftIO $ resume debuggee'
put $ initialAppState (_appChan appState)
-- handle any other more local events; mostly key events
_ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee')
(brickEvent)
where
mkSavedAndGCRootsIOTree = do
raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures debuggee'
rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee') raw_roots
raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee'
savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee') raw_saved
return $ (mkIOTree debuggee' (savedClosures' ++ rootClosures') getChildren renderInlineClosureDesc id
, fmap toPtr <$> (raw_roots ++ raw_saved))
getChildren :: Debuggee -> ClosureDetails
-> IO [ClosureDetails]
getChildren _ LabelNode{} = return []
getChildren _ CCDetails {} = return []
getChildren _ InfoDetails {} = return []
getChildren d (ClosureDetails c _ _) = do
children <- closureReferences d c
children' <- traverse (traverse (fillListItem d)) children
mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children'
getChildren d (CCSDetails _ _ cp) = do
references <- zip [0 :: Int ..] <$> ccsReferences d cp
mapM (\(lbl, cc) -> getClosureDetails d (pack (show lbl)) cc) references
fillListItem :: Debuggee
-> ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr
-> IO (ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x
fillListItem d (ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd
fillListItem _ ListData = return ListData
fillListItem _ (ListCCS c1 c2) = return $ ListCCS c1 c2
fillListItem _ (ListCC c1) = return $ ListCC c1
mkIOTree :: Debuggee
-> [a]
-> (Debuggee -> a -> IO [a])
-> (a -> [Widget Name])
-- -> IO [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)])
-> ([a] -> [a])
-> IOTree a Name
mkIOTree debuggee' cs getChildrenGen renderNode sort = ioTree Connected_Paused_ClosureTree
(sort cs)
(\c -> sort <$> getChildrenGen debuggee' c
-- cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children
-- return (sort cDets)
)
-- rendering the row
(\state selected ctx depth closureDesc ->
let
body =
(if selected then visible . highlighted else id) $
hBox $
renderNode closureDesc
in
vdecorate state ctx depth body -- body (T.concat context)
)
era_colors :: [Vty.Color]
era_colors = [Vty.Color240 n | n <- [17..230]]
grey :: Vty.Color
grey = Vty.rgbColor (158 :: Int) 158 158
-- | Draw the tree structure around the row item. Inspired by the
-- 'border' functions in brick.
--
vdecorate :: RowState -> RowCtx -> [RowCtx] -> Widget n -> Widget n
vdecorate state ctx depth body =
Widget Fixed Fixed $ do
c <- getContext
let decorationWidth = 2 * length depth + 4
bodyResult <-
render $
hLimit (c ^. availWidthL - decorationWidth) $
vLimit (c ^. availHeightL) $
body
let leftTxt =
T.concat $
map
(\ x -> case x of
LastRow -> " "
NotLastRow -> "│ "
)
(List.reverse depth)
leftPart = withAttr treeAttr (vreplicate leftTxt)
middleTxt1 =
case ctx of
LastRow -> "└─"
NotLastRow -> "├─"
middleTxt1' =
case ctx of
LastRow -> " "
NotLastRow -> "│ "
middleTxt2 =
case state of
Expanded True -> "● " -- "⋅"
Expanded False -> "┐ "
Collapsed -> "┄ "
middleTxt2' =
case state of
Expanded True -> " "
Expanded False -> "│ "
Collapsed -> " "
middlePart =
withAttr treeAttr $
(txt middleTxt1 <=> vreplicate middleTxt1')
<+> (txt middleTxt2 <=> vreplicate middleTxt2')
rightPart = Widget Fixed Fixed $ return bodyResult
total = leftPart <+> middlePart <+> rightPart
render $
hLimit (bodyResult ^. imageL . to Vty.imageWidth + decorationWidth) $
vLimit (bodyResult ^. imageL . to Vty.imageHeight) $
total
vreplicate :: Text -> Widget n
vreplicate t =
Widget Fixed Greedy $ do
c <- getContext
return $ emptyResult & imageL .~ Vty.vertCat (replicate (c ^. availHeightL) (Vty.text' (c ^. attrL) t))
{-
hBox
[ withAttr treeAttr $ Widget Fixed Fixed $ do
c <- getContext
limitedResult <- render (hLimit (c ^. availWidthL - T.length t) $ vLimit (c ^. availHeightL) $ body)
return $ emptyResult & imageL .~ vertCat (replicate (limitedResult ^. imageL . to imageHeight) (text' (c ^. attrL) t))
, body
]
where
bodyWidth =
render (hLimit (c ^. availWidthL - (length depth * 2 + 4)) $ vLimit (c ^. availHeightL) $ body)
-}
renderInlineClosureDesc :: ClosureDetails -> [Widget n]
renderInlineClosureDesc (LabelNode t) = [txtLabel t]
renderInlineClosureDesc (InfoDetails info') =
[txtLabel (_labelInParent info'), vSpace, txt (_pretty info')]
renderInlineClosureDesc (CCSDetails clabel _cptr ccspayload) =
[ txtLabel clabel, vSpace, txt (prettyCCS ccspayload)]
renderInlineClosureDesc (CCDetails clabel cc) =
[ txtLabel clabel, vSpace, txt (prettyCC cc)]
renderInlineClosureDesc closureDesc@(ClosureDetails{}) =
[ txtLabel (_labelInParent (_info closureDesc))
, colorBar
, txt $ pack (closureShowAddress (_closure closureDesc))
, vSpace
, txtWrap $ _pretty (_info closureDesc)
]
where
colorBar =
case colorId of
Just {} -> padLeftRight 1 (colorEra (txt " "))
Nothing -> vSpace
colorId = _profHeaderInfo $ _info closureDesc
colorEra = case colorId of
Just (Debug.EraWord i) -> modifyDefAttr (flip Vty.withBackColor (era_colors !! (1 + (fromIntegral $ abs i) `mod` (length era_colors - 1))))
Just (Debug.LDVWord {state}) -> case state of
-- Used
True -> modifyDefAttr (flip Vty.withBackColor Vty.green)
-- Unused
False -> id
_ -> id
prettyCCS :: GenCCSPayload CCSPtr CCPayload -> Text
prettyCCS Debug.CCSPayload{ccsCc = cc} = prettyCC cc
prettyCC :: CCPayload -> Text
prettyCC Debug.CCPayload{..} =
T.pack ccLabel <> " " <> T.pack ccMod <> " " <> T.pack ccLoc
completeClosureDetails :: Debuggee -> (Text, DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)
-> IO ClosureDetails
completeClosureDetails dbg (label', clos) =
getClosureDetails dbg label' . ListFullClosure =<< fillConstrDesc dbg clos
getClosureDetails :: Debuggee
-> Text
-> ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> IO ClosureDetails
getClosureDetails debuggee' t (ListOnlyInfo info_ptr) = do
info' <- getInfoInfo debuggee' t info_ptr
return $ InfoDetails info'
getClosureDetails _ plabel (ListCCS ccs payload) = return $ CCSDetails plabel ccs payload
getClosureDetails _ plabel (ListCC cc) = return $ CCDetails plabel cc
getClosureDetails _ t ListData = return $ LabelNode t
getClosureDetails debuggee' label' (ListFullClosure c) = do
let excSize' = closureExclusiveSize c
sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c)
pretty' <- closurePretty debuggee' c
return ClosureDetails
{ _closure = c
, _info = InfoInfo {
_pretty = pack pretty'
, _labelInParent = label'
, _sourceLocation = sourceLoc
, _closureType = Just (T.pack $ show c)
, _constructor = Nothing
, _profHeaderInfo = case c of
Closure{_closureSized=c1} -> Debug.hp <$> Debug.profHeader (Debug.unDCS c1)
_ -> Nothing
}
, _excSize = excSize'
}
getInfoInfo :: Debuggee -> Text -> InfoTablePtr -> IO InfoInfo
getInfoInfo debuggee' label' infoPtr = do
sourceLoc <- infoSourceLocation debuggee' infoPtr
let pretty' = case sourceLoc of
Just loc -> pack (infoPosition loc)
Nothing -> ""
return $ InfoInfo {
_pretty = pretty'
, _labelInParent = label'
, _sourceLocation = sourceLoc
, _closureType = Nothing
, _constructor = Nothing
, _profHeaderInfo = Nothing
}
-- Event handling when the main window has focus
handleMain :: Debuggee -> Handler Event OperationalState
handleMain dbg e = do
os <- get
case e of
AppEvent event -> case event of
PollTick -> return ()
ProgressMessage t -> do
put $ footerMessage t os
ProgressFinished desc runtime ->
put $ os
& running_task .~ Nothing
& last_run_time .~ Just (desc, runtime)
& footerMode .~ FooterInfo
AsyncFinished action -> action
_ | Nothing <- view running_task os ->
case view keybindingsMode os of
KeybindingsShown ->
case e of
VtyEvent (Vty.EvKey _ _) -> put $ os & keybindingsMode .~ NoOverlay
_ -> put os
CommandPicker form cmd_list orig_cmds -> do
-- Overlapping commands are up/down so handle those just via list, otherwise both
let handle_form = nestEventM' form (handleFormEvent (() <$ e))
handle_list =
case e of
VtyEvent vty_e -> nestEventM' cmd_list (handleListEvent vty_e)
_ -> return cmd_list
k form' cmd_list' =
if (formState form /= formState form') then do
let filter_string = formState form'
new_elems = Seq.filter (\cmd -> T.toLower filter_string `T.isInfixOf` T.toLower (commandDescription cmd )) orig_cmds
cmd_list'' = cmd_list'
& listElementsL .~ new_elems
& listSelectedL .~ if Seq.null new_elems then Nothing else Just 0
modify $ keybindingsMode .~ CommandPicker form' cmd_list'' orig_cmds
else
modify $ keybindingsMode .~ CommandPicker form' cmd_list' orig_cmds
case e of
VtyEvent (Vty.EvKey Vty.KUp _) -> do
list' <- handle_list
k form list'
VtyEvent (Vty.EvKey Vty.KDown _) -> do
list' <- handle_list
k form list'
VtyEvent (Vty.EvKey Vty.KEsc _) ->
put $ os & keybindingsMode .~ NoOverlay
VtyEvent (Vty.EvKey Vty.KEnter _) -> do
case listSelectedElement cmd_list of
Just (_, cmd)
| isCmdDisabled (_version os) cmd ->
return () -- If the command is disabled, just ignore the key press
| otherwise -> do
modify $ keybindingsMode .~ NoOverlay
dispatchCommand cmd dbg
Nothing -> return ()
_ -> do
form' <- handle_form
list' <- handle_list
k form' list'
NoOverlay -> case view footerMode os of
FooterInput fm form -> inputFooterHandler dbg fm form (handleMainWindowEvent dbg) (() <$ e)
_ -> handleMainWindowEvent dbg (() <$ e)
_ -> return ()
commandPickerMode :: OverlayMode
commandPickerMode =
CommandPicker
(newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] "")
(list CommandPicker_List commandList 1)
commandList
savedAndGCRoots :: TreeMode
savedAndGCRoots = SavedAndGCRoots renderClosureDetails
-- ----------------------------------------------------------------------------
-- Commands and Shortcut constants
-- ----------------------------------------------------------------------------
invertFilterEvent :: Vty.Event
invertFilterEvent = Vty.EvKey (KChar 'g') [Vty.MCtrl]
isInvertFilterEvent :: Vty.Event -> Bool
isInvertFilterEvent = (invertFilterEvent ==)
-- All the commands which we support, these show up in keybindings and also the command picker
commandList :: Seq.Seq Command
commandList =
[ mkCommand "Show key bindings" (Vty.EvKey (KChar '?') []) (modify $ keybindingsMode .~ KeybindingsShown)
, mkCommand "Clear filters" (withCtrlKey 'w') (modify $ clearFilters)
, Command "Search with current filters" (Just $ withCtrlKey 'f') searchWithCurrentFilters NoReq
, mkCommand "Set search limit (default 100)" (withCtrlKey 'l') (setFooterInputMode FSetResultSize)
, mkCommand "Saved/GC Roots" (withCtrlKey 's') (modify $ treeMode .~ savedAndGCRoots)
, mkCommand "Find Address" (withCtrlKey 'a') (setFooterInputMode (FClosureAddress True False))
, mkCommand "Find Info Table" (withCtrlKey 't') (setFooterInputMode (FInfoTableAddress True False))
, mkCommand "Find Retainers" (withCtrlKey 'e') (setFooterInputMode (FConstructorName True False))
, mkCommand' "Find Retainers (Exact)" (setFooterInputMode (FClosureName True False))
, mkFilterCmd "Find closures by era" (withCtrlKey 'v') (setFooterInputMode (FFilterEras True False)) ReqErasProfiling
, mkCommand "Find Retainers of large ARR_WORDS" (withCtrlKey 'u') (setFooterInputMode FArrWordsSize)
, mkCommand "Dump ARR_WORDS payload" (withCtrlKey 'j') (setFooterInputMode FDumpArrWords)
, mkCommand "Write Profile" (withCtrlKey 'b') (setFooterInputMode (FProfile OneLevel))
, mkCommand' "Write Profile (2 level)" (setFooterInputMode (FProfile TwoLevel))
, Command "Thunk Analysis" Nothing thunkAnalysisAction NoReq
, mkCommand "Take Snapshot" (withCtrlKey 'x') (setFooterInputMode FSnapshot)
, Command "ARR_WORDS Count" Nothing arrWordsAction NoReq
, Command "Strings Count" Nothing stringsAction NoReq
] <> addFilterCommands
where
setFooterInputMode m = modify $ footerMode .~ footerInput m
addFilterCommands :: Seq.Seq Command
addFilterCommands =
[ mkCommand' "Add filter for address" (setFooterInputMode (FClosureAddress False False))
, mkCommand' "Add filter for info table ptr" (setFooterInputMode (FInfoTableAddress False False))
, mkCommand' "Add filter for constructor name" (setFooterInputMode (FConstructorName False False))
, mkCommand' "Add filter for closure name" (setFooterInputMode (FClosureName False False))
, mkFilterCmd' "Add filter for era" (setFooterInputMode (FFilterEras False False)) ReqErasProfiling
, mkFilterCmd' "Add filter for cost centre id" (setFooterInputMode (FFilterCcId False False)) ReqSomeProfiling
, mkCommand' "Add filter for closure size" (setFooterInputMode (FFilterClosureSize False))
, mkCommand' "Add filter for closure type" (setFooterInputMode (FFilterClosureType False))
, mkCommand' "Add exclusion for address" (setFooterInputMode (FClosureAddress False True))
, mkCommand' "Add exclusion for info table ptr" (setFooterInputMode (FInfoTableAddress False True))
, mkCommand' "Add exclusion for constructor name" (setFooterInputMode (FConstructorName False True))
, mkCommand' "Add exclusion for closure name" (setFooterInputMode (FClosureName False True))
, mkFilterCmd' "Add exclusion for era" (setFooterInputMode (FFilterEras False True)) ReqErasProfiling
, mkFilterCmd' "Add exclusion for cost centre id" (setFooterInputMode (FFilterCcId False True)) ReqSomeProfiling
, mkCommand' "Add exclusion for closure size" (setFooterInputMode (FFilterClosureSize True))
, mkCommand' "Add exclusion for closure type" (setFooterInputMode (FFilterClosureType True))
]
withCtrlKey char = Vty.EvKey (KChar char) [Vty.MCtrl]
findCommand :: Vty.Event -> Maybe Command
findCommand event = do
i <- Seq.findIndexL (\cmd -> commandKey cmd == Just event) commandList
Seq.lookup i commandList
-- ----------------------------------------------------------------------------
-- Window Management
-- ----------------------------------------------------------------------------
handleMainWindowEvent :: Debuggee
-> Handler () OperationalState
handleMainWindowEvent dbg brickEvent = do
os@(OperationalState _ _ treeMode' _kbMode _footerMode _curRoots rootsTree _ _ _ debuggeeVersion) <- get
case brickEvent of
VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) ->
put $ os & keybindingsMode .~ commandPickerMode
-- A generic event
VtyEvent event
| Just cmd <- findCommand event ->
if isCmdDisabled debuggeeVersion cmd
then return () -- Command is disabled, don't dispatch the command
else dispatchCommand cmd dbg
-- Navigate the tree of closures
VtyEvent event -> case treeMode' of
SavedAndGCRoots {} -> do
newTree <- handleIOTreeEvent event rootsTree
put (os & treeSavedAndGCRoots .~ newTree)
Retainer r t -> do
newTree <- handleIOTreeEvent event t
put (os & treeMode .~ Retainer r newTree)
Searched r t -> do
newTree <- handleIOTreeEvent event t
put (os & treeMode .~ Searched r newTree)
_ -> return ()
inputFooterHandler :: Debuggee
-> FooterInputMode
-> Form Text () Name
-> Handler () OperationalState
-> Handler () OperationalState
inputFooterHandler dbg m form _k re@(VtyEvent e) =
case e of
Vty.EvKey KEsc [] -> modify resetFooter
Vty.EvKey KEnter [] -> dispatchFooterInput dbg m form
_
| isInvertFilterEvent e ->
let m' = invertInput m in
modify (footerMode .~ (FooterInput m' (updateFormState (formState form) $ footerInputForm m')))
| otherwise -> do
zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re)
inputFooterHandler _ _ _ k re = k re
stringsAction :: Debuggee -> EventM n OperationalState ()
stringsAction dbg = do
outside_os <- get
-- TODO: Does not honour search limit at all
asyncAction "Counting strings" outside_os (stringsAnalysis Nothing dbg) $ \res -> do
os <- get
let cmp (k, v) = length k * (S.size v)
let sorted_res = maybe id take (_resultSize os) $ Prelude.reverse [(k, S.toList v ) | (k, v) <- (List.sortBy (comparing (S.size . snd)) (M.toList res))]
top_closure = [CountLine k (length k) (length v) | (k, v) <- sorted_res]
g_children d (CountLine b _ _) = do
let Just cs = M.lookup b res
cs' <- run dbg $ forM (S.toList cs) $ \c -> do
c' <- GD.dereferenceClosure c
return $ ListFullClosure $ Closure c c'
children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'
mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children'
g_children d (FieldLine c) = map FieldLine <$> getChildren d c
renderHeaderPane (CountLine k l n) = vBox
[ labelled "Count " $ vLimit 1 $ str (show n)
, labelled "Size " $ vLimit 1 $ renderBytes l
, labelled "Total Size" $ vLimit 1 $ renderBytes (n * l)
, strWrap (take 100 $ show k)
]
renderHeaderPane (FieldLine c) = renderClosureDetails c
tree = mkIOTree dbg top_closure g_children renderArrWordsLines id
put (os & resetFooter
& treeMode .~ Searched renderHeaderPane tree
)
data ArrWordsLine k = CountLine k Int Int | FieldLine ClosureDetails
renderArrWordsLines :: Show a => ArrWordsLine a -> [Widget n]
renderArrWordsLines (CountLine k l n) = [strLabel (show n), vSpace, renderBytes l, vSpace, strWrap (take 100 $ show k)]
renderArrWordsLines (FieldLine cd) = renderInlineClosureDesc cd
-- | Render a histogram with n lines which displays the number of elements in each bucket,
-- and how much they contribute to the total size.
histogram :: Int -> [GD.Size] -> Widget Name
histogram boxes m =
vBox $ map displayLine (bin 0 (map calcPercentage (List.sort m )))
where
Size maxSize = maximum m
calcPercentage (Size tot) =
(tot, (fromIntegral tot/ fromIntegral maxSize) * 100 :: Double)
displayLine (l, h, n, tot) =
str (show l) <+> txt "%-" <+> str (show h) <+> str "%: " <+> str (show n) <+> str " " <+> renderBytes tot
step = fromIntegral (ceiling @Double @Int (100 / fromIntegral boxes))
bin _ [] = []
bin k xs = case now of
[] -> bin (k + step) later
_ -> (k, k+step, length now, sum (map fst now)) : bin (k + step) later
where
(now, later) = span ((<= k + step) . snd) xs
-- | Vertical space used to separate elements on the same line.
--
-- This is standardised for a consistent UI.
vSpace :: Widget n
vSpace = txt " "
arrWordsAction :: Debuggee -> EventM n OperationalState ()
arrWordsAction dbg = do
outside_os <- get
asyncAction "Counting ARR_WORDS" outside_os (arrWordsAnalysis Nothing dbg) $ \res -> do
os <- get
let all_res = Prelude.reverse [(k, S.toList v ) | (k, v) <- (List.sortBy (comparing (\(k, v) -> fromIntegral (BS.length k) * S.size v)) (M.toList res))]
display_res = maybe id take (_resultSize os) all_res
top_closure = [CountLine k (fromIntegral (BS.length k)) (length v) | (k, v) <- display_res]
!words_histogram = histogram 8 (concatMap (\(k, bs) -> let sz = BS.length k in replicate (length bs) (Size (fromIntegral sz))) all_res)
g_children d (CountLine b _ _) = do
let Just cs = M.lookup b res
cs' <- run dbg $ forM (S.toList cs) $ \c -> do
c' <- GD.dereferenceClosure c
return $ ListFullClosure $ Closure c c'
children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'
mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children'
g_children d (FieldLine c) = map FieldLine <$> getChildren d c
renderHeaderPane (CountLine b l n) = vBox
[ labelled "Count" $ vLimit 1 $ str (show n)
, labelled "Size" $ vLimit 1 $ renderBytes l
, labelled "Total Size" $ vLimit 1 $ renderBytes (n * l)
, strWrap (take 100 $ show b)
]
renderHeaderPane (FieldLine c) = renderClosureDetails c
renderWithHistogram c = joinBorders (renderHeaderPane c <+>
(padRight (Pad 1) $ (padLeft Brick.Max $ borderWithLabel (txt "Histogram") $ hLimit 100 $ words_histogram)))
tree = mkIOTree dbg top_closure g_children renderArrWordsLines id
put (outside_os & resetFooter
& treeMode .~ Searched renderWithHistogram tree
)
data ThunkLine = ThunkLine (Maybe SourceInformation) Count
thunkAnalysisAction :: Debuggee -> EventM n OperationalState ()
thunkAnalysisAction dbg = do
outside_os <- get
-- TODO: Does not honour search limit at all
asyncAction "Counting thunks" outside_os (thunkAnalysis dbg) $ \res -> do
os <- get
let top_closure = Prelude.reverse [ ThunkLine k v | (k, v) <- (List.sortBy (comparing (getCount . snd)) (M.toList res))]
g_children _ (ThunkLine {}) = pure []
renderHeaderPane (ThunkLine sc c) = vBox $
maybe [txt "NoLoc"] renderSourceInformation sc
++ [ strWrap ("Count: " ++ show (getCount c)) ]
renderInline (ThunkLine msc (Count c)) =
[(case msc of
Just sc -> strLabel (infoPosition sc)
Nothing -> txtLabel "NoLoc"), txt " ", str (show c) ]
tree = mkIOTree dbg top_closure g_children renderInline id
put (os & resetFooter
& treeMode .~ Searched renderHeaderPane tree
)
searchWithCurrentFilters :: Debuggee -> EventM n OperationalState ()
searchWithCurrentFilters dbg = do
outside_os <- get
let mClosFilter = uiFiltersToFilter (_filters outside_os)
asyncAction "Searching for closures" outside_os (liftIO $ retainersOf (_resultSize outside_os) mClosFilter Nothing dbg) $ \cps -> do
os <- get
let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps
res <- liftIO $ mapM (mapM (completeClosureDetails dbg)) cps'
let tree = mkRetainerTree dbg res
put (os & resetFooter
& treeMode .~ Retainer renderClosureDetails tree
)
filterOrRun :: Debuggee -> Form Text () Name -> Bool -> (String -> Maybe a) -> (a -> [UIFilter]) -> EventM n OperationalState ()
filterOrRun dbg form doRun parse createFilter =
filterOrRunM dbg form doRun parse (pure . createFilter)
filterOrRunM :: Debuggee -> Form Text () Name -> Bool -> (String -> Maybe a) -> (a -> EventM n OperationalState [UIFilter]) -> EventM n OperationalState ()
filterOrRunM dbg form doRun parse createFilterM = do
case parse (T.unpack (formState form)) of
Just x
| doRun -> do
newFilter <- createFilterM x
modify $ setFilters newFilter
searchWithCurrentFilters dbg
| otherwise -> do
newFilter <- createFilterM x
modify $ (resetFooter . addFilters newFilter)
Nothing -> modify resetFooter
data ProfileLine = ProfileLine GDP.ProfileKey GDP.ProfileKeyArgs CensusStats | ClosureLine ClosureDetails
renderProfileLine :: ProfileLine -> [Widget Name]
renderProfileLine (ClosureLine c) = renderInlineClosureDesc c
renderProfileLine (ProfileLine k kargs c) =
[txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs kargs), txt " ", showLine c]
where
showLine :: CensusStats -> Widget Name
showLine (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _) =
hBox
[ withFontColor totalSizeColor $ str (show s), vSpace
, withFontColor countColor $ str (show n), vSpace
, withFontColor sizeColor $ str (show mn), vSpace
, withFontColor avgSizeColor $ str (Numeric.showFFloat @Double (Just 1) (fromIntegral s / fromIntegral n) "")
]
withFontColor color = modifyDefAttr (flip Vty.withForeColor color)
totalSizeColor = Vty.RGBColor 0x26 0x83 0xDE
countColor = Vty.RGBColor 0xDE 0x66 0x26
sizeColor = Vty.RGBColor 0x26 0xDE 0xD7
avgSizeColor = Vty.RGBColor 0xAB 0x4D 0xE0
-- | What happens when we press enter in footer input mode
dispatchFooterInput :: Debuggee
-> FooterInputMode
-> Form Text () Name
-> EventM n OperationalState ()
dispatchFooterInput dbg (FClosureAddress runf invert) form = filterOrRun dbg form runf readClosurePtr (pure . UIAddressFilter invert)
dispatchFooterInput dbg (FInfoTableAddress runf invert) form = filterOrRun dbg form runf readInfoTablePtr (pure . UIInfoAddressFilter invert)
dispatchFooterInput dbg (FConstructorName runf invert) form = filterOrRun dbg form runf Just (pure . UIConstructorFilter invert)
dispatchFooterInput dbg (FClosureName runf invert) form = filterOrRun dbg form runf Just (pure . UIInfoNameFilter invert)
dispatchFooterInput dbg FArrWordsSize form = filterOrRun dbg form True readMaybe (\size -> [UIClosureTypeFilter False Debug.ARR_WORDS, UISizeFilter False size])
dispatchFooterInput dbg (FFilterEras runf invert) form = filterOrRun dbg form runf (parseEraRange . T.pack) (pure . UIEraFilter invert)
dispatchFooterInput dbg (FFilterClosureSize invert) form = filterOrRun dbg form False readMaybe (pure . UISizeFilter invert)
dispatchFooterInput dbg (FFilterClosureType invert) form = filterOrRun dbg form False readMaybe (pure . UIClosureTypeFilter invert)
dispatchFooterInput dbg (FFilterCcId runf invert) form = filterOrRun dbg form runf readMaybe (pure . UICcId invert)
dispatchFooterInput dbg (FProfile lvl) form = do
outside_os <- get
asyncAction "Writing profile" outside_os (profile dbg lvl (T.unpack (formState form))) $ \res -> do
os <- get
let top_closure = Prelude.reverse [ProfileLine k kargs v | ((k, kargs), v) <- (List.sortBy (comparing (cssize . snd)) (M.toList res))]
total_stats = foldMap snd (M.toList res)
g_children d (ClosureLine c) = map ClosureLine <$> getChildren d c
g_children d (ProfileLine _ _ stats) = do
let cs = getSamples (sample stats)
cs' <- run dbg $ forM cs $ \c -> do
c' <- GD.dereferenceClosure c
return $ ListFullClosure $ Closure c c'
children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'
mapM (\(lbl, child) -> ClosureLine <$> getClosureDetails d (pack lbl) child) children'
renderHeaderPane (ClosureLine cs) = renderClosureDetails cs
renderHeaderPane (ProfileLine k args (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _)) = vBox $
[ txtLabel "Label " <+> vSpace <+> txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs args)
]
<>
(case k of
GDP.ProfileConstrDesc desc ->
[ txtLabel "Package " <+> vSpace <+> (txt (GDP.pkgsText desc))
, txtLabel "Module " <+> vSpace <+> (txt (GDP.modlText desc))
, txtLabel "Constructor" <+> vSpace <+> (txt (GDP.nameText desc))
]
_ -> []
)
<>
[ txtLabel "Count " <+> vSpace <+> str (show n)
, txtLabel "Size " <+> vSpace <+> renderBytes s
, txtLabel "Max " <+> vSpace <+> renderBytes mn
, txtLabel "Average " <+> vSpace <+> renderBytes @Double (fromIntegral s / fromIntegral n)
]
renderWithStats l = joinBorders $ renderHeaderPane l <+>
(padRight (Pad 1) $ (padLeft Brick.Max $ renderHeaderPane (ProfileLine (GDP.ProfileClosureDesc "Total") GDP.NoArgs total_stats)))
tree :: IOTree ProfileLine Name
tree = mkIOTree dbg top_closure g_children renderProfileLine id
put (os & resetFooter
& treeMode .~ Searched renderWithStats tree
)
dispatchFooterInput _ FDumpArrWords form = do
os <- get
let act node = asyncAction_ "dumping ARR_WORDS payload" os $
case node of
Just ClosureDetails{_closure = Closure{_closureSized = Debug.unDCS -> Debug.ArrWordsClosure{bytes, arrWords}}} ->
BS.writeFile (T.unpack $ formState form) $ arrWordsBS (take (fromIntegral bytes) arrWords)
_ -> pure ()
case view treeMode os of
Retainer _ iotree -> act (ioTreeSelection iotree)
SavedAndGCRoots _ -> act (ioTreeSelection (view treeSavedAndGCRoots os))
Searched {} -> put (os & footerMessage "Dump for search mode not implemented yet")
dispatchFooterInput _ FSetResultSize form = do
outside_os <- get
asyncAction "setting result size" outside_os (pure ()) $ \() -> do
os <- get
case readMaybe $ T.unpack (formState form) of
Just n
| n <= 0 -> put (os & resultSize .~ Nothing)
| otherwise -> put (os & resultSize .~ (Just n))
Nothing -> pure ()
dispatchFooterInput dbg FSnapshot form = do
os <- get
asyncAction_ "Taking snapshot" os $ snapshot dbg (T.unpack (formState form))
asyncAction_ :: Text -> OperationalState -> IO a -> EventM n OperationalState ()
asyncAction_ desc os action = asyncAction desc os action (\_ -> return ())
asyncAction :: Text -> OperationalState -> IO a -> (a -> EventM Name OperationalState ()) -> EventM n OperationalState ()
asyncAction desc os action final = do
tid <- (liftIO $ forkIO $ do
writeBChan eventChan (ProgressMessage desc)
start <- getCurrentTime
res <- action
end <- getCurrentTime
writeBChan eventChan (AsyncFinished (final res))
writeBChan eventChan (ProgressFinished desc (end `diffUTCTime` start)))
put $ os & running_task .~ Just tid
& resetFooter
where
eventChan = view event_chan os
mkRetainerTree :: Debuggee -> [[ClosureDetails]] -> IOTree ClosureDetails Name
mkRetainerTree dbg stacks = do
let stack_map = [ (cp, rest) | stack <- stacks, Just (cp, rest) <- [List.uncons stack]]
roots = map fst stack_map
info_map :: M.Map Ptr [(Text, (DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))]
info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((T.pack (show n)), (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map]
lookup_c dbg' dc'@(ClosureDetails dc _ _) = do
let ptr = toPtr dc
results = M.findWithDefault [] ptr info_map
-- We are also looking up the children of the object we are retaining,
-- and displaying them prior to the retainer stack
cs <- getChildren dbg' dc'
results' <- liftIO $ mapM (\(l, c) -> getClosureDetails dbg' l (ListFullClosure c)) results
return (cs ++ results')
-- And if it's not a closure, just do the normal thing
lookup_c dbg' dc' = getChildren dbg' dc'
mkIOTree dbg roots lookup_c renderInlineClosureDesc id
resetFooter :: OperationalState -> OperationalState
resetFooter l = (set footerMode FooterInfo l)
footerMessage :: Text -> OperationalState -> OperationalState
footerMessage t l = (set footerMode (FooterMessage t) l)
myAppStartEvent :: EventM Name AppState ()
myAppStartEvent = return ()
myAppAttrMap :: AppState -> AttrMap
myAppAttrMap _appState =
attrMap (Vty.withStyle (Vty.white `on` Vty.black) Vty.dim)
[ (menuAttr, Vty.withStyle (Vty.white `on` Vty.blue) Vty.bold)
, (inputAttr, Vty.black `on` Vty.green)
, (labelAttr, Vty.withStyle (fg Vty.white) Vty.bold)
, (highlightAttr, Vty.black `on` Vty.yellow)
, (treeAttr, fg Vty.red)
, (disabledMenuAttr, Vty.withStyle (grey `on` Vty.blue) Vty.bold)
]
menuAttr :: AttrName
menuAttr = attrName "menu"
inputAttr :: AttrName
inputAttr = attrName "input"
labelAttr :: AttrName
labelAttr = attrName "label"
treeAttr :: AttrName
treeAttr = attrName "tree"
highlightAttr :: AttrName
highlightAttr = attrName "highlighted"
disabledMenuAttr :: AttrName
disabledMenuAttr = attrName "disabledMenu"
txtLabel :: Text -> Widget n
txtLabel = withAttr labelAttr . txt
strLabel :: String -> Widget n
strLabel = withAttr labelAttr . str
highlighted :: Widget n -> Widget n
highlighted = forceAttr highlightAttr
disabledMenuItem :: Widget n -> Widget n
disabledMenuItem = forceAttr disabledMenuAttr
main :: IO ()
main = do
eventChan <- newBChan 10
_ <- forkIO $ forever $ do
writeBChan eventChan PollTick
-- 2s
threadDelay 2_000_000
let buildVty = Vty.mkVty Vty.defaultConfig
initialVty <- buildVty
let app :: App AppState Event Name
app = App
{ appDraw = myAppDraw
, appChooseCursor = showFirstCursor
, appHandleEvent = myAppHandleEvent
, appStartEvent = myAppStartEvent
, appAttrMap = myAppAttrMap
}
_finalState <- customMain initialVty buildVty
(Just eventChan) app (initialAppState eventChan)
return ()