{-# 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 #-} module Main where import Brick import Brick.BChan import Brick.Forms import Brick.Widgets.Border import Brick.Widgets.Center (centerLayer, hCenter) import Brick.Widgets.List import Control.Applicative import Control.Monad (forever) import Control.Monad.IO.Class 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 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 qualified Data.Map as M import Data.Maybe import qualified Data.Foldable as F import IOTree import Lib as GD import Model 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" $ vBox [ txtWrap "There is nothing you can do until the process is paused by pressing (p) ..." , fill ' ' , withAttr menuAttr $ vLimit 1 $ hBox [txt "(p): Pause | (ESC): Exit", fill ' '] ]] (PausedMode os@(OperationalState _ treeMode' kbmode fmode _ _ _)) -> let in kbOverlay kbmode $ [mainBorder "ghc-debug - Paused" $ vBox [ -- Current closure details joinBorders $ borderWithLabel (txt "Closure Details") $ vLimit 9 $ pauseModeTree (renderClosureDetails . ioTreeSelection) os <=> fill ' ' , -- Tree joinBorders $ borderWithLabel (txt $ case treeMode' of SavedAndGCRoots -> "Root Closures" Retainer {} -> "Retainers" Searched {} -> "Search Results" ) (pauseModeTree renderIOTree os) , footer fmode ]] where kbOverlay :: OverlayMode -> [Widget Name] -> [Widget Name] kbOverlay KeybindingsShown ws = centerLayer kbWindow : ws kbOverlay (CommandPicker inp cmd_list) ws = centerLayer (cpWindow inp cmd_list) : ws kbOverlay NoOverlay ws = ws cpWindow :: Form Text () Name -> GenericList Name Seq.Seq Command -> Widget Name cpWindow 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 else renderCommand) False cmd_list] kbWindow :: Widget Name kbWindow = withAttr menuAttr $ borderWithLabel (txt "Keybindings") $ vBox $ map renderCommandDesc all_keys all_keys = [ ("Resume", Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl]) , ("Parent", Vty.EvKey KLeft []) , ("Child", Vty.EvKey KRight []) , ("Command Picker", Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]) ] ++ [(commandDescription cmd, commandKey cmd) | cmd <- F.toList commandList ] ++ [ ("Exit", 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 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 = "�" renderCommand cmd = renderCommandDesc (commandDescription cmd, commandKey cmd) renderCommandDesc :: (Text, Vty.Event) -> Widget Name renderCommandDesc (desc, k) = txt (desc <> T.replicate padding " " <> renderKey k) where key = renderKey k padding = (actual_width - T.length desc - T.length key) renderClosureDetails :: Maybe ClosureDetails -> Widget Name renderClosureDetails (Just cd@(ClosureDetails {})) = vLimit 9 $ -- viewport Connected_Paused_ClosureDetails Both $ vBox $ renderInfoInfo (_info cd) ++ [ hBox [ txtLabel $ "Exclusive Size " <> maybe "" (pack . show @Int . GD.getSize) (Just $ _excSize cd) <> " bytes" ] ] renderClosureDetails Nothing = emptyWidget renderClosureDetails (Just (LabelNode n)) = txt n renderClosureDetails (Just (InfoDetails info')) = vLimit 9 $ vBox $ renderInfoInfo info' renderInfoInfo :: InfoInfo -> [Widget Name] renderInfoInfo info' = maybe [] renderSourceInformation (_sourceLocation info') -- TODO these aren't actually implemented yet -- , txt $ "Type " -- <> fromMaybe "" (_closureType =<< cd) -- , txt $ "Constructor " -- <> fromMaybe "" (_constructor =<< cd) 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 lbl w = hLimit 17 (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ') footer :: FooterMode -> Widget Name footer m = vLimit 1 $ case m of FooterMessage t -> withAttr menuAttr $ hBox [txt t, fill ' '] FooterInfo -> withAttr menuAttr $ hBox [txt "(↑↓): select item | (→): expand | (←): collapse | (^p): command picker | (?): full keybindings", fill ' '] FooterInput _im form -> renderForm form footerInput :: FooterInputMode -> FooterMode footerInput im = FooterInput im (footerInputForm im) footerInputForm :: FooterInputMode -> Form Text e Name footerInputForm im = newForm [(\w -> txtLabel (formatFooterMode im) <+> forceAttr inputAttr w) @@= editTextField id Footer (Just 1)] "" updateListFrom :: MonadIO m => IO FilePath -> GenericList n Seq.Seq SocketInfo -> 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 . error . show) (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' (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree Nothing put (appState & majorState . mode .~ PausedMode (OperationalState Nothing SavedAndGCRoots NoOverlay FooterInfo (DefaultRoots initRoots) rootsTree eventChan )) _ -> 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 manalysis = do raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures debuggee' rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_roots raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee' savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_saved return $ (mkIOTree debuggee' manalysis (savedClosures' ++ rootClosures') getChildren id , fmap toPtr <$> (raw_roots ++ raw_saved)) where getChildren :: Debuggee -> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)] getChildren d c = do children <- closureReferences d c traverse (traverse (fillListItem d)) children fillListItem :: Debuggee -> ListItem SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr -> IO (ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr) fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd fillListItem _ ListData = return ListData mkIOTree :: Debuggee -> Maybe Analysis -> [ClosureDetails] -> (Debuggee -> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)]) -> ([ClosureDetails] -> [ClosureDetails]) -> IOTree ClosureDetails Name mkIOTree debuggee' manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree (sort cs) (\c -> do case c of LabelNode {} -> return [] InfoDetails {} -> return [] _ -> do children <- getChildren debuggee' (_closure 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 $ renderInlineClosureDesc closureDesc in vdecorate state ctx depth body -- body (T.concat context) ) -- | Draw the tree structure around the row item. Inspired by the -- 'border' functions in brick. -- vdecorate :: RowState -> RowCtx -> [RowCtx] -> Widget n -> Widget n vdecorate state ctx depth body = Widget Fixed Fixed $ do c <- getContext let decorationWidth = 2 * length depth + 4 bodyResult <- render $ hLimit (c ^. availWidthL - decorationWidth) $ vLimit (c ^. availHeightL) $ body let leftTxt = T.concat $ map (\ x -> case x of LastRow -> " " NotLastRow -> "│ " ) (List.reverse depth) leftPart = withAttr treeAttr (vreplicate leftTxt) middleTxt1 = case ctx of LastRow -> "└─" NotLastRow -> "├─" middleTxt1' = case ctx of LastRow -> " " NotLastRow -> "│ " middleTxt2 = case state of Expanded True -> "● " -- "⋅" Expanded False -> "┐ " Collapsed -> "┄ " middleTxt2' = case state of Expanded True -> " " Expanded False -> "│ " Collapsed -> " " middlePart = withAttr treeAttr $ (txt middleTxt1 <=> vreplicate middleTxt1') <+> (txt middleTxt2 <=> vreplicate middleTxt2') rightPart = Widget Fixed Fixed $ return bodyResult total = leftPart <+> middlePart <+> rightPart render $ hLimit (bodyResult ^. imageL . to Vty.imageWidth + decorationWidth) $ vLimit (bodyResult ^. imageL . to Vty.imageHeight) $ total vreplicate :: Text -> Widget n vreplicate t = Widget Fixed Greedy $ do c <- getContext return $ emptyResult & imageL .~ Vty.vertCat (replicate (c ^. availHeightL) (Vty.text' (c ^. attrL) t)) {- 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'), txt " ", txt (_pretty info')] renderInlineClosureDesc closureDesc = [ txtLabel (_labelInParent (_info closureDesc)) , txt " " , txtWrap $ pack (closureShowAddress (_closure closureDesc)) <> " " <> _pretty (_info closureDesc) ] completeClosureDetails :: Debuggee -> Maybe Analysis -> (Text, DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) -> IO ClosureDetails completeClosureDetails dbg manalysis (label', clos) = getClosureDetails dbg manalysis label' . ListFullClosure =<< fillConstrDesc dbg clos getClosureDetails :: Debuggee -> Maybe Analysis -> Text -> ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO ClosureDetails getClosureDetails debuggee' _ t (ListOnlyInfo info_ptr) = do info' <- getInfoInfo debuggee' t info_ptr return $ InfoDetails info' getClosureDetails _ _ t ListData = return $ LabelNode t getClosureDetails debuggee' manalysis label' (ListFullClosure c) = do let excSize' = closureExclusiveSize c retSize' = closureRetainerSize <$> manalysis <*> pure 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 = Nothing , _constructor = Nothing } , _excSize = excSize' , _retainerSize = retSize' } 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 } -- 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 -> put $ os & running_task .~ Nothing & resetFooter 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 -> 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 )) commandList cmd_list'' = cmd_list' & listElementsL .~ new_elems & listSelectedL .~ if Seq.null new_elems then Nothing else Just 0 modify $ keybindingsMode .~ (CommandPicker form' cmd_list'') else modify $ keybindingsMode .~ (CommandPicker form' cmd_list') case e of VtyEvent (Vty.EvKey Vty.KUp _) -> do list' <- handle_list k form list' VtyEvent (Vty.EvKey Vty.KDown _) -> do list' <- handle_list k form list' VtyEvent (Vty.EvKey Vty.KEsc _) -> put $ os & keybindingsMode .~ NoOverlay VtyEvent (Vty.EvKey Vty.KEnter _) -> do case listSelectedElement cmd_list of Just (_, cmd) -> do modify $ keybindingsMode .~ NoOverlay dispatchCommand cmd 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) -- All the commands which we support, these show up in keybindings and also the command picker commandList :: Seq.Seq Command commandList = [ Command "Show key bindings" (Vty.EvKey (KChar '?') []) (modify $ keybindingsMode .~ KeybindingsShown) , Command "Saved/GC Roots" (Vty.EvKey (KChar 's') [Vty.MCtrl]) (modify $ treeMode .~ SavedAndGCRoots) , Command "Find Closures (Exact)" (Vty.EvKey (KChar 'c') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FSearch) , Command "Find Address" (Vty.EvKey (KChar 'a') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FAddress) , Command "Write Profile" (Vty.EvKey (KChar 'w') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FProfile) , Command "Find Retainers" (Vty.EvKey (KChar 'f') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FRetainer) , Command "Find Retainers (Exact)" (Vty.EvKey (KChar 'e') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FRetainerExact) , Command "Take Snapshot" (Vty.EvKey (KChar 'x') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FSnapshot) ] findCommand :: Vty.Event -> Maybe Command findCommand event = do i <- Seq.findIndexL (\cmd -> commandKey cmd == event) commandList Seq.lookup i commandList handleMainWindowEvent :: Debuggee -> Handler () OperationalState handleMainWindowEvent _dbg brickEvent = do os@(OperationalState _ treeMode' _kbMode _footerMode _curRoots rootsTree _) <- get case brickEvent of VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) -> put $ os & keybindingsMode .~ commandPickerMode -- A generic event VtyEvent event | Just cmd <- findCommand event -> dispatchCommand cmd -- Navigate the tree of closures VtyEvent event -> case treeMode' of SavedAndGCRoots -> do newTree <- handleIOTreeEvent event rootsTree put (os & treeSavedAndGCRoots .~ newTree) Retainer t -> do newTree <- handleIOTreeEvent event t put (os & treeMode .~ Retainer newTree) Searched t -> do newTree <- handleIOTreeEvent event t put (os & treeMode .~ Searched 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 _ -> do zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re) inputFooterHandler _ _ _ k re = k re -- | What happens when we press enter in footer input mode dispatchFooterInput :: Debuggee -> FooterInputMode -> Form Text () Name -> EventM n OperationalState () dispatchFooterInput dbg FSearch form = do os <- get asyncAction "Searching for closures" os (map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (formState form)))) $ \cps -> do let cps' = (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps' let tree = mkIOTree dbg Nothing res getChildren id put (os & resetFooter & treeMode .~ Searched tree ) dispatchFooterInput dbg FAddress form = do os <- get let address = T.unpack (formState form) case readClosurePtr address of Just cp -> do asyncAction "Finding address" os (map head <$> (liftIO $ retainersOfAddress Nothing dbg [cp])) $ \cps -> do let cps' = (zipWith (\n cp' -> (T.pack (show n),cp')) [0 :: Int ..]) cps res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps' let tree = mkIOTree dbg Nothing res getChildren id put (os & resetFooter & treeMode .~ Searched tree ) Nothing -> put (os & resetFooter) dispatchFooterInput dbg FProfile form = do os <- get asyncAction_ "Writing profile" os $ profile dbg (T.unpack (formState form)) dispatchFooterInput dbg FRetainer form = do os <- get let roots = mapMaybe go (map snd (currentRoots (view rootsFrom os))) go (CP p) = Just p go (SP _) = Nothing asyncAction "Finding retainers" os (retainersOfConstructor (Just roots) dbg (T.unpack (formState form))) $ \cps -> do let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps' let tree = mkRetainerTree dbg res put (os & resetFooter & treeMode .~ Retainer tree) dispatchFooterInput dbg FRetainerExact form = do os <- get asyncAction "Finding exact retainers" os (retainersOfConstructorExact dbg (T.unpack (formState form))) $ \cps -> do let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps' let tree = mkRetainerTree dbg res put (os & resetFooter & treeMode .~ Retainer tree) 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) res <- action writeBChan eventChan (AsyncFinished (final res)) writeBChan eventChan ProgressFinished) 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 [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)] info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((show n), ListFullClosure (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map] lookup_c dbg' dc = do let ptr = toPtr dc results = M.findWithDefault [] ptr info_map -- We are also looking up the children of the object we are retaining, -- and displaying them prior to the retainer stack cs <- getChildren dbg' dc return (cs ++ results) mkIOTree dbg Nothing roots lookup_c id resetFooter :: OperationalState -> OperationalState resetFooter l = (set footerMode FooterInfo l) 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) ] menuAttr :: AttrName menuAttr = attrName "menu" inputAttr :: AttrName inputAttr = attrName "input" labelAttr :: AttrName labelAttr = attrName "label" treeAttr :: AttrName treeAttr = attrName "tree" highlightAttr :: AttrName highlightAttr = attrName "highlighted" txtLabel :: Text -> Widget n txtLabel = withAttr labelAttr . txt highlighted :: Widget n -> Widget n highlighted = forceAttr highlightAttr main :: IO () main = do eventChan <- newBChan 10 _ <- 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 ()