ghc-debug-brick-0.2.0.0: src/Model.hs

{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}

module Model
  ( module Model
  , module Namespace
  , module Common
  ) where

import Data.Sequence as Seq
import Lens.Micro.Platform
import Data.Time
import System.Directory
import System.FilePath
import Data.Text(Text, pack)

import Brick.Widgets.List
import IOTree
import TextCursor

import Namespace
import Common
import Lib


initialAppState :: AppState
initialAppState = AppState
  { _majorState = Setup
      { _setupKind = Socket
      , _knownDebuggees = list Setup_KnownDebuggeesList [] 1
      , _knownSnapshots = list Setup_KnownSnapshotsList [] 1
      }
  }

data AppState = AppState
  { _majorState :: MajorState
  }

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 }

data ClosureDetails pap s c = ClosureDetails
  { _closure :: DebugClosure pap ConstrDesc s c
  , _retainerSize :: Maybe RetainerSize
  , _excSize :: Size
  , _info :: InfoInfo
  }
  | InfoDetails { _info :: InfoInfo }
  | LabelNode { _label :: Text }

data TreeMode = Dominator | SavedAndGCRoots | Reverse | Retainer (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name)

data FooterMode = FooterInfo
                | FooterMessage Text
                | FooterInput FooterInputMode TextCursor

data FooterInputMode = FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot

formatFooterMode :: FooterInputMode -> Text
formatFooterMode FSearch = "search: "
formatFooterMode FProfile = "filename: "
formatFooterMode FRetainer = "constructor name: "
formatFooterMode FRetainerExact = "closure name: "
formatFooterMode FSnapshot = "snapshot name: "

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
    { _treeMode :: TreeMode
    , _footerMode :: FooterMode
    , _rootsFrom  :: RootsOrigin
    , _treeDominator :: Maybe DominatorAnalysis
    -- ^ Tree corresponding to Dominator mode
    , _treeSavedAndGCRoots :: IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name
    -- ^ Tree corresponding to SavedAndGCRoots mode
    , _treeReverse :: Maybe ReverseAnalysis
    -- ^ Tree corresponding to Dominator mode
    , _heapGraph :: Maybe (HeapGraph Size)
    -- ^ Raw heap graph
    }

data DominatorAnalysis =
  DominatorAnalysis { _getDominatorAnalysis :: Analysis
                    , _getDominatorTree :: IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name
                    }

data ReverseAnalysis = ReverseAnalysis { _reverseIOTree :: IOTree (ClosureDetails PapHI StackHI (Maybe HeapGraphIndex)) Name
                                          , _convertPtr :: ClosurePtr -> Maybe (DebugClosure PapHI ConstrDesc StackHI (Maybe HeapGraphIndex)) }

pauseModeTree :: (forall pap s c . IOTree (ClosureDetails pap s c) Name -> r) -> OperationalState -> r
pauseModeTree k (OperationalState mode _ _footer dom roots reverseA _) = case mode of
  Dominator -> k $ maybe (error "DOMINATOR-DavidE is not ready") _getDominatorTree dom
  SavedAndGCRoots -> k roots
  Reverse -> k $ maybe (error "bop it, flip, reverse it, DavidE") _reverseIOTree reverseA
  Retainer r -> k r

makeLenses ''AppState
makeLenses ''MajorState
makeLenses ''ClosureDetails
makeLenses ''ConnectedMode
makeLenses ''OperationalState
makeLenses ''SocketInfo
makeLenses ''DominatorAnalysis
makeLenses ''ReverseAnalysis