ClosureDetails.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Debug.Brick.ClosureDetails where

import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text as T

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

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
getChildren d (StackFrameDetails _ sframe _) = do
  children <- stackFrameReferences d sframe
  children' <- traverse (traverse (fillListItem d)) children
  mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children'

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
fillListItem _ (ListStackFrame s) = return $ ListStackFrame s

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'
    }
getClosureDetails debuggee' label' (ListStackFrame c) = do
  let stackFrameTypeOf = Debug.tipe . Debug.decodedTable . Debug.frame_info
      tipe' = stackFrameTypeOf c
  sourceLoc <- infoSourceLocation debuggee' (Debug.tableId $ Debug.frame_info c)
  mPrettyClos <- case tipe' of
    Debug.ANN_FRAME -> do
      case Debug.values c of
        [Debug.SPtr annPtr] -> do
          (dbgClosure, mPayload) <- dereferenceStackAnnotation debuggee' annPtr
          payload <- case mPayload of
            Nothing -> pure dbgClosure
            Just stackAnnoClos -> do
              payloadClos <- dereferencePtr debuggee' (CP $ GD.stackAnno_payload stackAnnoClos)
              fillConstrDesc debuggee' payloadClos
          prettyClos <- closurePretty debuggee' payload
          pure $ Just $ pack prettyClos
        vals ->
          -- If this is not 'SomeStackAnnotation', just display the arguments
          pure $ Just $ T.unwords $ fmap (showStackValue (pack . show)) vals
    _ -> pure Nothing
  return $ StackFrameDetails
    { _tipe = tipe'
    , _frame = c
    , _info = InfoInfo
      { _labelInParent = label'
      , _pretty = fromMaybe T.empty mPrettyClos
      , _sourceLocation = sourceLoc
      , _closureType = Just $ pack $ show tipe'
      , _constructor = Nothing
      , _profHeaderInfo =
          -- This is a stack closure, there is no profHeader.
          Nothing
      }
    }

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
      }

showStackValue :: (b -> Text) -> Debug.FieldValue b -> Text
showStackValue f = \ case
  Debug.SPtr b -> f b
  Debug.SNonPtr v -> pack $ show v