Thunk.hs

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module GHC.Debug.Brick.Action.Thunk (
  thunkAnalysisActionAsync,
  thunkTreeMode,
  thunkTree,
  ) where

import Brick
import Brick.Widgets.IOTree (IOTree, setIOTreeRoots)
import Control.Monad (forM)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Ord as Ord
import Data.Text (pack)
import Lens.Micro.Platform

import GHC.Debug.Brick.Action.Async
import GHC.Debug.Brick.ClosureDetails
import GHC.Debug.Brick.IOTree
import GHC.Debug.Brick.Lib as GD
import GHC.Debug.Brick.Model
import GHC.Debug.Brick.Render.Closure
import GHC.Debug.Brick.Render.Utils
import GHC.Debug.Profile.Types
import GHC.Debug.Retainers (SearchLimit)
import qualified GHC.Debug.Thunks as GD

thunkAnalysisActionAsync :: Debuggee -> EventM n OperationalState ()
thunkAnalysisActionAsync dbg = do
  outside_os <- get

  put $ outside_os
    & treeMode .~ thunkTreeMode (_resultSize outside_os) (thunkTree dbg) Map.empty

  runWithAsyncSampleReporter dbg "Counting thunks" ThunkSample
    (thunkAnalysisAsync dbg)
    (\ result -> do
      sendEvent $ CacheSearch DoThunkSearch result
      os <- get
      put (os & resetFooter))

thunkTreeMode :: SearchLimit -> IOTree ThunkLine Name -> GD.ThunkCensusBySourceLocation -> TreeMode
thunkTreeMode _limit tree census =
  let
    top_closures = [ ThunkLine k (cscount v) (sample v) | (k, v) <- (List.sortOn (Ord.Down . (cscount . snd)) (Map.toList census))]
  in
    Thunk renderHeaderPane (setIOTreeRoots top_closures tree)

-- | Create a retainer tree which we can incrementally add retainer samples to when we receive them.
thunkTree :: Debuggee -> IOTree ThunkLine Name
thunkTree dbg =
  mkIOTree dbg [] getChildrenOfThunkLine renderInline id

getChildrenOfThunkLine :: Debuggee -> ThunkLine -> IO [ThunkLine]
getChildrenOfThunkLine dbg (ThunkLine _ _ smp) = do
  cs' <- run dbg $ forM (getSamples smp) $ \c -> do
    c' <- GD.dereferenceClosure c
    return $ ListFullClosure $ Closure c c'
  children <- traverse (traverse (fillListItem dbg)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'
  mapM (\(lbl, child) -> ThunkClosureLine <$> getClosureDetails dbg (pack lbl) child) children
getChildrenOfThunkLine dbg (ThunkClosureLine c) = map ThunkClosureLine <$> getChildren dbg c

renderHeaderPane :: ThunkLine -> Widget Name
renderHeaderPane (ThunkLine sc c _smp) = vBox $
  maybe [txt "NoLoc"] renderSourceInformation sc
  ++ [ strWrap ("Count: " ++ show (getCount c)) ]
renderHeaderPane (ThunkClosureLine cd) = renderClosureDetails cd

renderInline :: ThunkLine -> [Widget n]
renderInline (ThunkLine msc (Count c) _smp) =
  [ case msc of
      Just sc -> strLabel (infoPosition sc)
      Nothing -> txtLabel "NoLoc"
  , txt " "
  , str (show c)
  ]
renderInline (ThunkClosureLine cd) = renderInlineClosureDesc cd