Model.hs

{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}

module GHC.Debug.Brick.Model
  ( module GHC.Debug.Brick.Model
  , module GHC.Debug.Brick.Namespace
  , module GHC.Debug.Brick.Common
  ) where

import Brick (EventM, Widget)
import qualified Brick
import Brick.BChan
import Brick.Forms
import Brick.Widgets.IOTree
import Brick.Widgets.List
import Control.Concurrent.Async (Async)
import qualified Control.Exception as Exc
import Control.Monad.IO.Class (liftIO)
import Data.ByteString.Lazy (ByteString)
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.GADT.Compare
import Data.GADT.Compare.TH
import Data.Map.Strict (Map)
import Data.Sequence as Seq
import Data.Set (Set)
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Time
import GHC.Debug.Brick.Common
import GHC.Debug.Brick.Lib
import GHC.Debug.Brick.Namespace
import qualified Graphics.Vty as Vty
import Lens.Micro.Platform
import System.Directory
import System.FilePath
import Text.Read

import Brick.Widgets.ListPicker
import GHC.Debug.Brick.UI.Filter (UIFilter)
import qualified GHC.Debug.Profile as GD
import qualified GHC.Debug.Profile.Types as GD
import qualified GHC.Debug.Retainers as GD
import qualified GHC.Debug.Strings as GD
import qualified GHC.Debug.Thunks as GD
import qualified GHC.Debug.Types as GD
import qualified GHC.Debug.Types.Version as GD

data Event
  = PollTick  -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees
  | ProgressMessage Text
  | ProgressFinished Text NominalDiffTime
  | AsyncAborted Exc.SomeException
  | AsyncFinished (EventM Name OperationalState ())
  | NewSampleEvent SampleEvent
  -- ^ A sample event is a partial result of a heap traversal.
  | NavigatorEvent NavigatorEvent
  -- ^ Events that navigate the history.
  | DoSearch SomeSearchCmd
  -- ^ Search which doesn't push a new "page" onto the history.
  -- Primarily used for changing the view, for navigation.
  | DoSearchWithHistoryPush SomeSearchCmd
  -- ^ Perform a heap traversal search that pushes a new value
  -- onto the history. The history can be navigated via 'NavigatorEvent'.
  | forall a . CacheSearch (SearchCmd a) a
  -- ^ A final message that is sent when the result of a search query
  -- is finalised. Partial results are not expected here.
  | forall a . CachePartialSearch (SearchCmd a) a
  -- ^ Partial result that we can still use

-- | Wraps a 'SearchCmd' and hides the type variable.
data SomeSearchCmd = forall a . SomeSearchCmd (SearchCmd a)

-- | Messages that switch the view to a new 'TreeMode'.
-- These Messages and their respective result can be cached.
data SearchCmd a where
  -- | Find the garbage collector roots
  DoGcRootsSearch :: SearchCmd [ClosureDetails]
  -- | Perform a retainer search.
  -- We record the search limit in this constructor, because the result is obsolete
  -- when the search limit changes.
  -- This is strictly speaking only correct for when the search limit is increased,
  -- but at the moment we consider it too much work to behave correctly when the
  -- search limit is decreased.
  DoRetainerSearch :: GD.SearchLimit -> [UIFilter] -> SearchCmd RetainerMap
  DoProfileSearch :: ProfileLevel -> SearchCmd GD.CensusByClosureType
  DoStringSearch :: SearchCmd GD.CensusByStrings
  DoArrWordsSearch :: SearchCmd GD.CensusByByteString
  DoThunkSearch :: SearchCmd GD.ThunkCensusBySourceLocation

data SampleEvent
  = GcRootsSample [ClosureDetails]
  | RetainerSample [ClosureDetails]
  -- ^ A new retainer sample is available, and we need to update the retainer tree.
  | ProfileSample ProfileLevel GD.CensusByClosureType
  | StringSample GD.CensusByStrings
  | ArrWordsSample GD.CensusByByteString
  | ThunkSample GD.ThunkCensusBySourceLocation

initialAppState :: BChan Event -> AppState
initialAppState event = AppState
  { _majorState = Setup
      { _setupKind = Socket
      , _knownDebuggees = list Setup_KnownDebuggeesList [] 1
      , _knownSnapshots = list Setup_KnownSnapshotsList [] 1
      },
    _appChan = event
  }

data AppState = AppState
  { _majorState :: MajorState
  , _appChan    :: BChan Event
  }

mkSocketInfo :: FilePath -> IO SocketInfo
mkSocketInfo fp = SocketInfo fp <$> getModificationTime fp

socketName :: SocketInfo -> Text
socketName = pack . takeFileName . _socketLocation

renderSocketTime :: SocketInfo -> Text
renderSocketTime = pack . formatTime defaultTimeLocale "%c" . _socketCreated

data SocketInfo = SocketInfo
                    { _socketLocation :: FilePath -- ^ FilePath to socket, absolute path
                    , _socketCreated :: UTCTime  -- ^ Time of socket creation
                    } deriving Eq

instance Ord SocketInfo where
  compare (SocketInfo s1 t1) (SocketInfo s2 t2) =
    -- Compare time first
    compare t1 t2 <> compare s1 s2

type SnapshotInfo = SocketInfo

data SetupKind = Socket | Snapshot

toggleSetup :: SetupKind -> SetupKind
toggleSetup Socket = Snapshot
toggleSetup Snapshot = Socket

data MajorState
  -- | We have not yet connected to a debuggee.
  = Setup
    { _setupKind :: SetupKind
    , _knownDebuggees :: GenericList Name Seq SocketInfo
    , _knownSnapshots :: GenericList Name Seq SnapshotInfo
    }

  -- | Connected to a debuggee
  | Connected
    { _debuggeeSocket :: SocketInfo
    , _debuggee :: Debuggee
    , _mode     :: ConnectedMode
    }

data InfoInfo = InfoInfo
  {
    _labelInParent :: Text -- ^ A label describing the relationship to the parent
  -- Stuff  that requires IO to calculate
  , _pretty :: Text
  , _sourceLocation :: Maybe SourceInformation
  , _closureType :: Maybe Text
  , _constructor :: Maybe Text
  , _profHeaderInfo :: !(Maybe ProfHeaderWord)
  } deriving Show

data ClosureDetails = ClosureDetails
  { _closure :: DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
  , _excSize :: Size
  , _info :: InfoInfo
  }
  | InfoDetails { _info :: InfoInfo }
  | CCSDetails Text CCSPtr (GenCCSPayload CCSPtr CCPayload)
  | CCDetails Text CCPayload
  | StackFrameDetails
  { _tipe :: ClosureType
  , _frame :: GD.DebugStackFrame (GD.GenSrtPayload ClosurePtr) ClosurePtr
  , _info :: InfoInfo
  }
  | LabelNode { _label :: Text } deriving Show

data RetainerNode = RetainerStackRoot ClosureDetails -- ^ At the root, display the retainer stack as well
                  | RetainerStackChild ClosureDetails -- ^ Not at the root, just display normal closure details

retainerNodeClosure :: RetainerNode -> ClosureDetails
retainerNodeClosure (RetainerStackRoot dc) = dc
retainerNodeClosure (RetainerStackChild dc) = dc

data TreeMode = GcRoots (ClosureDetails -> Widget Name) (IOTree ClosureDetails Name)
              -- ^ Tree corresponding to SavedAndGCRoots mode
              | Retainer (RetainerNode -> Widget Name) (IOTree RetainerNode Name)
              | Profile (ProfileLine -> Widget Name) (IOTree ProfileLine Name)
              | Strings (StringCountLine -> Widget Name) (IOTree StringCountLine Name)
              | ArrWords (ArrWordsLine -> Widget Name) (IOTree ArrWordsLine Name)
              | Thunk (ThunkLine -> Widget Name) (IOTree ThunkLine Name)

data ThunkLine =
            ThunkLine (Maybe SourceInformation) GD.Count GD.Sample
          | ThunkClosureLine ClosureDetails

treeLength :: TreeMode -> Int
treeLength (GcRoots _ tree) = Prelude.length $ getIOTreeRoots tree
treeLength (Retainer _ tree) = Prelude.length $ getIOTreeRoots tree
treeLength (Profile _ tree) = Prelude.length $ getIOTreeRoots tree
treeLength (Strings _ tree) = Prelude.length $ getIOTreeRoots tree
treeLength (ArrWords _ tree) = Prelude.length $ getIOTreeRoots tree
treeLength (Thunk _ tree) = Prelude.length $ getIOTreeRoots tree

-- TODO: This should not be defined here
type RetainerMap = Map Ptr (ClosureDetails, [ClosureDetails])

-- TODO: should maybe not be defined here but rather in `Action.Profile`?
data ProfileLine
  = ProfileLine GD.ProfileKey GD.ProfileKeyArgs CensusStats
  | ClosureLine ClosureDetails

-- TODO: should maybe not be defined here but rather in `Action.ArrWords`?
data ArrWordsLine = ArrWordsCountLine ByteString Int Int (Set ClosurePtr) | ArrWordsFieldLine ClosureDetails

arrWordLineClosureDetails :: ArrWordsLine -> Maybe ClosureDetails
arrWordLineClosureDetails ArrWordsCountLine {} = Nothing
arrWordLineClosureDetails (ArrWordsFieldLine cd) = Just cd

data StringCountLine = StringCountLine String Int Int (Set ClosurePtr) | StringFieldLine ClosureDetails

stringLineClosureDetails :: StringCountLine -> Maybe ClosureDetails
stringLineClosureDetails StringCountLine {} = Nothing
stringLineClosureDetails (StringFieldLine cd) = Just cd

data FooterMode = FooterInfo
                | FooterMessage Text
                | FooterInput FooterInputMode (Form Text () Name)

isFocusedFooter :: FooterMode -> Bool
isFocusedFooter (FooterInput {}) = True
isFocusedFooter _ = False

data FooterInputMode = FClosureAddress {runNow :: Bool, invert :: Bool}
                     | FInfoTableAddress {runNow :: Bool, invert :: Bool}
                     | FConstructorName {runNow :: Bool, invert :: Bool}
                     | FClosureName {runNow :: Bool, invert :: Bool}
                     | FArrWordsSize
                     | FFilterEras {runNow :: Bool, invert :: Bool}
                     | FFilterClosureType {invert :: Bool}
                     | FFilterClosureSize {invert :: Bool}
                     | FFilterCcId {runNow :: Bool, invert :: Bool}
                     | FSnapshot
                     | FDumpArrWords
                     | FSetResultSize
                     | FSaveTree
                     deriving Show

-- | Profiling requirement for a command
data ProfilingReq
  = ReqSomeProfiling
  | ReqErasProfiling
  | NoReq

data Command = Command { commandDescription :: Text
                       , commandKey :: Maybe Vty.Event
                       , dispatchCommand :: EventM Name OperationalState ()
                       , commandRequiresProfMode :: ProfilingReq
                       -- ^ The command requires that the debuggee is in a specific
                       -- profiling mode.
                       -- For example, we can only filter by eras if the program
                       -- has era profiling enabled.
                       }

mkCommand :: Text -> Vty.Event -> EventM Name OperationalState () -> Command
mkCommand desc ev dispatch = Command desc (Just ev) dispatch NoReq

mkCommand' :: Text -> EventM Name OperationalState () -> Command
mkCommand' desc dispatch = Command desc Nothing dispatch NoReq

mkFilterCmd :: Text -> Vty.Event -> EventM Name OperationalState () -> ProfilingReq -> Command
mkFilterCmd desc ev dispatch profMode = Command desc (Just ev) dispatch profMode

mkFilterCmd' :: Text -> EventM Name OperationalState () -> ProfilingReq -> Command
mkFilterCmd' desc dispatch profMode = Command desc Nothing dispatch profMode

isCmdEnabled :: GD.Version -> Command -> Bool
isCmdEnabled debuggeeVersion cmd = case commandRequiresProfMode cmd of
  NoReq -> True
  ReqErasProfiling ->
    Just GD.EraProfiling == GD.v_profiling debuggeeVersion
  ReqSomeProfiling ->
    GD.isProfiledRTS debuggeeVersion

isCmdDisabled :: GD.Version -> Command -> Bool
isCmdDisabled v cmd = not $ isCmdEnabled v cmd

data OverlayMode
  = KeybindingsShown
  | CommandPicker (ListPicker Name OperationalState Event Command)
  | HistoryPicker (ListPicker Name OperationalState Event HistoryCommand)
  | NoOverlay

invertInput :: FooterInputMode -> FooterInputMode
invertInput x@FClosureAddress{invert} = x{invert = not invert}
invertInput x@FInfoTableAddress{invert} = x{invert = not invert}
invertInput x@FConstructorName{invert} = x{invert = not invert}
invertInput x@FClosureName{invert} = x{invert = not invert}
invertInput x@FFilterEras{invert} = x{invert = not invert}
invertInput x@FFilterClosureSize{invert} = x{invert = not invert}
invertInput x@FFilterClosureType{invert} = x{invert = not invert}
invertInput x@FFilterCcId{invert} = x{invert = not invert}
invertInput x = x

formatFooterMode :: FooterInputMode -> Text
formatFooterMode FClosureAddress{invert} = (if invert then "!" else "") <> "address (0x..): "
formatFooterMode FInfoTableAddress{invert} = (if invert then "!" else "") <> "info table pointer (0x..): "
formatFooterMode FConstructorName{invert} = (if invert then "!" else "") <> "constructor name: "
formatFooterMode FClosureName{invert} = (if invert then "!" else "") <> "closure name: "
formatFooterMode FFilterEras{invert} = (if invert then "!" else "") <> "era range (<era>/<start-era>-<end-era>): "
formatFooterMode FFilterClosureSize{invert} = (if invert then "!" else "") <> "closure size (bytes): "
formatFooterMode FFilterClosureType{invert} = (if invert then "!" else "") <> "closure type: "
formatFooterMode FFilterCcId{invert} = (if invert then "!" else "") <> "CC Id: "
formatFooterMode FArrWordsSize = "size (bytes)>= "
formatFooterMode FDumpArrWords = "dump payload to file: "
formatFooterMode FSetResultSize = "search result limit (0 for infinity): "
formatFooterMode FSnapshot = "snapshot name: "
formatFooterMode (FSaveTree {}) = "filename: "

data ConnectedMode
  -- | Debuggee is running
  = RunningMode
  -- | Debuggee is paused and we're exploring the heap
  | PausedMode { _pausedMode :: OperationalState }

data RootsOrigin = DefaultRoots [(Text, Ptr)]
                 | SearchedRoots [(Text, Ptr)]


currentRoots :: RootsOrigin -> [(Text, Ptr)]
currentRoots (DefaultRoots cp) = cp
currentRoots (SearchedRoots cp) = cp

data OperationalState = OperationalState
    { _running_task :: Maybe (Async ())
    , _last_run_time :: Maybe (Text, NominalDiffTime)
    , _treeMode :: TreeMode
    , _keybindingsMode :: OverlayMode
    , _footerMode :: FooterMode
    , _rootsFrom  :: RootsOrigin
    , _viewCache :: RequestCache SearchCmd
    , _navigator :: HistoryNavigator SomeSearchCmd
    , _event_chan :: BChan Event
    , _resultSize :: Maybe Int
    , _filters :: [UIFilter]
    , _asyncSamplingInterval :: !Int
    -- ^ Update period of asynchronous heap traversals in microseconds
    , _version :: GD.Version
    }

clearFilters :: OperationalState -> OperationalState
clearFilters os = os { _filters = [] }

setFilters :: [UIFilter] -> OperationalState -> OperationalState
setFilters fs os = os {_filters = fs}

addFilters :: [UIFilter] -> OperationalState -> OperationalState
addFilters fs os = os {_filters = fs ++ _filters os}

parseEraRange :: Text -> Maybe EraRange
parseEraRange range = case T.splitOn "-" range of
  [nstr] -> case readMaybe (T.unpack nstr) of
    Just n -> Just $ EraRange n n
    Nothing -> Nothing
  [start,end] -> case (T.unpack start, T.unpack end) of
    ("", "") -> Just $ EraRange 0 maxBound
    ("", readMaybe -> Just e) -> Just $ EraRange 0 e
    (readMaybe -> Just s, "") -> Just $ EraRange s maxBound
    (readMaybe -> Just s, readMaybe -> Just e) -> Just $ EraRange s e
    _ -> Nothing
  _ -> Nothing


osSize :: OperationalState -> Int
osSize os = treeLength (_treeMode os)

pauseModeTree :: (forall a . (a -> Widget Name) -> IOTree a Name -> r) -> OperationalState -> r
pauseModeTree k os = case _treeMode os of
  GcRoots render r -> k render r
  Retainer render r -> k render r
  Profile render r -> k render r
  Strings render r -> k render r
  ArrWords render r -> k render r
  Thunk render r -> k render r

sendEvent :: Event -> EventM n OperationalState ()
sendEvent ev = do
  os <- Brick.get
  liftIO $ writeBChan (_event_chan os) ev

-- ----------------------------------------------------------------------------
-- Command History Picker
-- ----------------------------------------------------------------------------

data HistoryCommand = HistoryCommand
  { _historyItem :: SomeSearchCmd
  }

historyCommandDispatch :: HistoryCommand -> EventM Name OperationalState ()
historyCommandDispatch (HistoryCommand searchCmd) =
  sendEvent $ DoSearch searchCmd

-- ----------------------------------------------------------------------------
-- Request Cache Layer
-- ----------------------------------------------------------------------------

data CacheResult a
  = Partial a
  | Complete a

cacheValue :: CacheResult a -> a
cacheValue = \ case
  Partial a -> a
  Complete a -> a

data RequestCache f = RequestCache
  { _requestCache :: DMap f CacheResult
  }

lookupCache :: (GCompare f) => f a -> RequestCache f -> Maybe (CacheResult a)
lookupCache key (RequestCache cache) =
  DMap.lookup key cache

insertCache :: (GCompare f) => f a -> CacheResult a -> RequestCache f -> RequestCache f
insertCache key value (RequestCache cache) =
  RequestCache (DMap.insertWith insertIfNotComplete key value cache)
 where
  -- only insert the new value if the old value isn't already complete
  insertIfNotComplete new old = case old of
    Complete _ -> old
    Partial _ -> new

emptyCache :: RequestCache f
emptyCache = RequestCache
  { _requestCache = DMap.empty
  }

-- ----------------------------------------------------------------------------
-- History Navigation
-- ----------------------------------------------------------------------------

data NavigatorEvent
  = GoOneBackwards
  | GoOneForwards
  deriving (Show, Eq, Ord)

data HistoryNavigator a = HistoryNavigator
  { _history :: [a]
  , _current :: a
  , _future :: [a]
  }

navBackwards :: HistoryNavigator a -> (Maybe a, HistoryNavigator a)
navBackwards orig@(HistoryNavigator history cur future) =
  case history of
    [] -> (Nothing, orig)
    (h:hs) -> (Just h, HistoryNavigator hs h (cur:future))

navForward :: HistoryNavigator a -> (Maybe a, HistoryNavigator a)
navForward orig@(HistoryNavigator history cur future) =
  case future of
    [] -> (Nothing, orig)
    (f:fs) -> (Just f, HistoryNavigator (cur:history) f fs)

navPush :: a -> HistoryNavigator a -> HistoryNavigator a
navPush value orig =
  HistoryNavigator
    { _history = _current orig : _history orig
    , _current = value
    , _future = []
    }

newHistoryNavigator :: a -> HistoryNavigator a
newHistoryNavigator value = HistoryNavigator
  { _history = []
  , _current = value
  , _future = []
  }

navList :: HistoryNavigator a -> [a]
navList nav = Prelude.reverse (_future nav) <> [_current nav] <> _history nav

-- | Get a list of the current history stack with the index pointing
-- to the '_current' element.
navListWithIndex :: HistoryNavigator a -> (Int, [a])
navListWithIndex nav = (Prelude.length (_future nav), navList nav)

-- ----------------------------------------------------------------------------
-- TH derivations
-- ----------------------------------------------------------------------------

makeLenses ''AppState
makeLenses ''MajorState
makeLenses ''ClosureDetails
makeLenses ''ConnectedMode
makeLenses ''OperationalState
makeLenses ''RequestCache
makeLenses ''HistoryNavigator
makeLenses ''SocketInfo
makeLenses ''OverlayMode

deriveGEq ''SearchCmd
deriveGCompare ''SearchCmd

resetFooter :: OperationalState -> OperationalState
resetFooter l = (set footerMode FooterInfo l)

footerMessage :: Text -> OperationalState -> OperationalState
footerMessage t l = (set footerMode (FooterMessage t) l)

-- ----------------------------------------------------------------------------
-- Cache Layer
-- ----------------------------------------------------------------------------

cachedOrRun :: Bool -> SearchCmd a -> (a -> EventM n OperationalState ()) -> EventM n OperationalState () -> EventM n OperationalState ()
cachedOrRun fullSearch query ifFound notFound = do
  lookupCacheForCmd query >>= \ case
    Nothing ->
      notFound
    Just cachedValue
      | fullSearch ->
          case cachedValue of
            Complete value ->
              ifFound value
            Partial _ ->
              notFound
      | otherwise ->
          ifFound (cacheValue cachedValue)

lookupCacheForCmd :: SearchCmd a -> EventM n OperationalState (Maybe (CacheResult a))
lookupCacheForCmd query = do
  os <- Brick.get
  pure $ lookupCache query (os ^. viewCache)

cacheCompleteResult :: SearchCmd a -> a -> EventM n OperationalState ()
cacheCompleteResult key value = do
  os <- Brick.get
  Brick.put (os &
    viewCache %~ insertCache key (Complete value)
    )

cachePartialResult :: SearchCmd a -> a -> EventM n OperationalState ()
cachePartialResult key value = do
  os <- Brick.get
  Brick.put (os &
    viewCache %~ insertCache key (Partial value)
    )