Profile.hs

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Debug.Brick.Action.Profile (
  profileAction,
  profileTreeMode,
  profileTree,
  renderProfileHeader,
) where

import Brick
import Brick.Widgets.IOTree
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Ord as Ord
import qualified Data.Semigroup
import qualified Data.Text as T
import Data.Traversable
import GHC.Debug.Brick.Action.Async
import GHC.Debug.Brick.ClosureDetails
import GHC.Debug.Brick.IOTree
import GHC.Debug.Brick.Lib
import qualified GHC.Debug.Brick.Lib as GD
import GHC.Debug.Brick.Model
import GHC.Debug.Brick.Render.Closure
import GHC.Debug.Brick.Render.Header (renderHeaderWithSummary)
import GHC.Debug.Brick.Render.Utils
import GHC.Debug.Profile
import qualified GHC.Debug.Profile as GD
import qualified GHC.Debug.Profile as GDP
import GHC.Debug.Profile.Types
import GHC.Debug.Retainers (SearchLimit)
import qualified Graphics.Vty as Vty
import Lens.Micro
import qualified Numeric

profileAction :: Debuggee -> ProfileLevel -> EventM n OperationalState ()
profileAction dbg lvl = do
  outside_os <- get
  let

  put (outside_os
      & resetFooter
      & treeMode .~ profileTreeMode (_resultSize outside_os) (profileTree dbg) Map.empty
      )

  runWithAsyncSampleReporter dbg "Profile" (ProfileSample lvl)
    (profileAsync dbg lvl)
    (\ result -> do
      -- write the final result to disk
      -- liftIO $ GD.writeCensusByClosureType fp finalRes
      sendEvent $ CacheSearch (DoProfileSearch lvl) result
      os <- get
      put (os & resetFooter)
    )

profileTreeMode :: SearchLimit -> IOTree ProfileLine Name -> GD.CensusByClosureType -> TreeMode
profileTreeMode _limit tree census =
  let
    top_closure = [ProfileLine k kargs v  | ((k, kargs), v) <- (List.sortOn (Ord.Down . (cssize . snd)) (Map.toList census))]
    total_stats = foldMap snd (Map.toList census)
  in
    Profile (renderProfileHeader total_stats) (setIOTreeRoots top_closure tree)

profileTree :: Debuggee -> IOTree ProfileLine Name
profileTree dbg =
  let
    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 (T.pack lbl) child) children'
  in
    mkIOTree dbg [] g_children renderProfileLine id

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

renderProfileHeader :: CensusStats -> ProfileLine -> Widget Name
renderProfileHeader total_stats l =
  renderHeaderWithSummary
    (renderHeaderPane l)
    (renderHeaderPane (ProfileLine (GDP.ProfileClosureDesc "Total") GDP.NoArgs total_stats))

renderHeaderPane :: ProfileLine -> Widget Name
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)
  ]