Types.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Eventlog.Types(module Eventlog.Types, HeapProfBreakdown(..), ClosureType) where

import Data.Text (Text)
import Data.Map (Map)
import Data.Aeson
import Data.Hashable
import Data.Word
import GHC.RTS.Events (HeapProfBreakdown(..))
import GHC.Exts.Heap.ClosureTypes
import Numeric
import qualified Data.Text as T
import qualified Data.Map as Map
import Text.Blaze.Html

data Header =
  Header
  { hJob         :: Text
  , hDate        :: Text
  , hHeapProfileType :: ProfileType
  , hSamplingRate :: Text
  , hSampleUnit  :: Text
  , hValueUnit   :: Text
  , hCount       :: Int
  , hProgPath    :: Maybe FilePath
  } deriving Show

data ProfileType = FromHPFile | FromEventlog (Maybe HeapProfBreakdown) deriving Show


-- The bucket is a key to uniquely identify a band
newtype Bucket = Bucket Text
                  deriving (Show, Ord, Eq)
                  deriving newtype (ToJSON, Hashable)


data BucketInfo = BucketInfo { shortDescription :: Text -- For the legend and hover
                             , longDescription :: Maybe [Word32]
                             , bucketTotal :: Double
                             , bucketStddev :: Double
                             , bucketGradient :: !(Maybe (Double, Double, Double))
                             } deriving Show

data CostCentre = CC { cid :: Word32
                     , label :: Text
                     , modul :: Text
                     , loc :: Text } deriving Show

data Sample = Sample Bucket Double deriving Show

data HeapSample = HeapSample Double Word64 deriving Show

data Frame = Frame Double [Sample] deriving Show

-- | A trace we also want to show on the graph
data Trace = Trace Double Text deriving Show

data HeapInfo = HeapInfo { heapSizeSamples :: [HeapSample]
                         , blocksSizeSamples :: [HeapSample]
                         , liveBytesSamples :: [HeapSample]
                         } deriving Show

data ProfData = ProfData { profHeader :: Header
                         , profTotals :: Map Bucket BucketInfo
                         , profCCMap  :: Map Word32 CostCentre
                         , profFrames :: [Frame]
                         , profTraces :: [Trace]
                         , profHeap   :: HeapInfo
                         , profItl    :: Map InfoTablePtr InfoTableLoc
                         , profTickyCounters :: Map TickyCounterId TickyCounter
                         , profTickySamples  :: [TickySample]
                         , profTotalAllocations :: Word64
                         } deriving Show

newtype TickyCounterId = TickyCounterId Word64 deriving (Ord, Eq, Show)

data TickyCounterArgs = TickyCounterArgs { tickyCounterType :: Text
                                         , tickyCounterFVs  :: [Char]
                                         , tickyCounterArgs :: [Char]
                                         } deriving Show

instance FromJSON TickyCounterArgs where
  parseJSON = withObject "TickyCounterArgs" $ \v -> TickyCounterArgs
                <$> v .: "type"
                <*> (T.unpack <$> v .: "fvs")
                <*> (T.unpack <$> v .: "args")

data TickyCounter = TickyCounter { tickyCtrId :: Word64, tickyCtrArity :: Word16, tickyCtrArgs :: TickyCounterArgs , tickyCtrName :: Text, tickyCtrInfo :: InfoTablePtr }
  deriving Show

data TickySample = TickySample { tickyCtrSampleId, tickyCtrEntries, tickyCtrAllocs, tickyCtrAllocd :: Word64, tickySampleTime :: Double }
  deriving Show

data InfoTableLoc = InfoTableLoc { itlName :: !Text
                                 , itlClosureDesc :: !ClosureType
                                 , itlTyDesc :: !Text
                                 , itlLbl :: !Text
                                 , itlModule :: !Text
                                 , itlSrcLoc :: !Text } deriving Show

data InfoTablePtr = InfoTablePtr Word64 deriving (Eq, Ord)

instance Show InfoTablePtr where
  show (InfoTablePtr p) =  "0x" ++ showHex p ""

toItblPointer :: Bucket -> InfoTablePtr
toItblPointer = either error id . toItblPointer_either

toItblPointer_maybe :: Bucket -> Maybe InfoTablePtr
toItblPointer_maybe = either (const Nothing) Just . toItblPointer_either

toItblPointer_either :: Bucket -> Either String InfoTablePtr
toItblPointer_either (Bucket t) =
    let s = drop 2 (T.unpack t)
        w64 = case readHex s of
                ((n, ""):_) -> pure (InfoTablePtr n)
                _ -> Left (show t)
    in w64

data InfoTableLocStatus = None -- None of the entries have InfoTableLoc
                        | Missing -- This one is just missing
                        | Here InfoTableLoc -- Here is is

mkMissing :: Maybe InfoTableLoc -> InfoTableLocStatus
mkMissing = maybe Missing Here


mkClosureInfo :: (k -> a -> InfoTablePtr)
              -> Map.Map k a
              -> Map.Map InfoTablePtr InfoTableLoc
              -> Map.Map k (InfoTableLocStatus, a)
mkClosureInfo f b ipes =
  Map.mapWithKey (\k v -> (mkMissing $ Map.lookup (f k v) ipes, v)) b


data EventlogType =
    EventlogType
        { eventlogHeader       :: Header
        , eventlogHeapProfile  :: Maybe HeapProfileData
        , eventlogTickyProfile :: Maybe TickyProfileData
        }

data HeapProfileData = HeapProfileData Value (Maybe Value) (Maybe Html)

data TickyProfileData = TickyProfileData Word64 Double Html