Closure.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module GHC.Debug.Brick.Render.Closure where

import Brick
import qualified Graphics.Vty as Vty
import Data.Text (Text, pack)
import qualified Data.Text as T

import qualified GHC.Debug.Types.Ptr as GD
import qualified GHC.Debug.Types.Closures as GD

import qualified GHC.Debug.Types.Closures as Debug
import GHC.Debug.Brick.Lib as GD
import GHC.Debug.Brick.Model
import GHC.Debug.Brick.Render.Utils

era_colors :: [Vty.Color]
era_colors = [Vty.Color240 n | n <- [17..230]]

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

prettyInfoTablePtr :: InfoTablePtr -> Text
prettyInfoTablePtr (GD.InfoTablePtr addr) = T.pack $ GD.prettyAddr addr

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)
    ]

renderInlineSourceInformation :: SourceInformation -> Widget n
renderInlineSourceInformation (SourceInformation _name _cty _ty label' modu loc) =
    str label' <+> vSpace <+> str modu <+> txt ":" <+> str loc

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
renderClosureDetails (StackFrameDetails _ _ info') = vLimit 8 $ vBox $ concat
  [ [ labelled "Label" $ vLimit 1 $ txtLabel (_labelInParent info')
    ]
  , renderInfoInfo info'
  ]

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)
  ]


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)

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 (StackFrameDetails frameTipe f info') = concat $
  [ [ txtLabel (_labelInParent info')
    , vSpace, txt $ T.pack $ show frameTipe
    , vSpace, txt $ prettyInfoTablePtr $ GD.tableId $ GD.frame_info f
    ]
  , if T.null (_pretty info')
      then []
      else [ vSpace, txt (_pretty info') ]
  , case _sourceLocation info' of
      Nothing -> []
      Just sourceInfo -> [ vSpace, renderInlineSourceInformation sourceInfo ]
  ]
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