{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Eventlog.Data
( generateJson
, generateJsonValidate
, generateJsonData
, EventlogType(..)
, HeapProfileData(..)
, TickyProfileData(..)
) where
import Prelude hiding (readFile)
import Data.Aeson ((.=), object)
import qualified Data.Map as Map
import Data.Maybe
import Eventlog.Args (Args(..))
import Eventlog.Bands (bands)
import qualified Eventlog.Events as E
import qualified Eventlog.HeapProf as H
import Eventlog.Prune
import Eventlog.Vega
import Eventlog.Types
import Data.List
import Data.Ord
import Eventlog.Trie
import Eventlog.Detailed
import Eventlog.Ticky
generateJsonData :: Args -> ProfData -> HeapProfileData
generateJsonData :: Args -> ProfData -> HeapProfileData
generateJsonData Args
a (ProfData Header
h Map Bucket BucketInfo
binfo Map Word32 CostCentre
ccMap [Frame]
fs [Trace]
traces HeapInfo
heap_info Map InfoTablePtr InfoTableLoc
ipes Map TickyCounterId TickyCounter
_ticky_counter [TickySample]
_ticky_samples Word64
_total_allocs) =
let keeps :: Map Bucket (Int, BucketInfo)
keeps = Args -> Map Bucket BucketInfo -> Map Bucket (Int, BucketInfo)
pruneBands Args
a Map Bucket BucketInfo
binfo
bs :: (UArray Int Double, UArray (Int, Int) Double)
bs = Header
-> Map Bucket Int
-> [Frame]
-> (UArray Int Double, UArray (Int, Int) Double)
bands Header
h (((Int, BucketInfo) -> Int)
-> Map Bucket (Int, BucketInfo) -> Map Bucket Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int, BucketInfo) -> Int
forall a b. (a, b) -> a
fst Map Bucket (Int, BucketInfo)
keeps) [Frame]
fs
combinedJson :: Value
combinedJson = [Pair] -> Value
object [
Key
"samples" Key -> [VegaEntry] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (BucketInfo -> Text)
-> Map Bucket (Int, BucketInfo)
-> (UArray Int Double, UArray (Int, Int) Double)
-> [VegaEntry]
bandsToVega BucketInfo -> Text
bucket_desc Map Bucket (Int, BucketInfo)
keeps (UArray Int Double, UArray (Int, Int) Double)
bs
, Key
"traces" Key -> [VegaTrace] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Trace] -> [VegaTrace]
tracesToVega [Trace]
traces
, Key
"heap" Key -> [VegaHeap] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeapInfo -> [VegaHeap]
heapToVega HeapInfo
heap_info
]
mdescs :: [(Bucket, (Int, BucketInfo))]
mdescs =
((Bucket, (Int, BucketInfo))
-> (Bucket, (Int, BucketInfo)) -> Ordering)
-> [(Bucket, (Int, BucketInfo))] -> [(Bucket, (Int, BucketInfo))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Bucket, (Int, BucketInfo))
-> (Bucket, (Int, BucketInfo)) -> Ordering)
-> (Bucket, (Int, BucketInfo))
-> (Bucket, (Int, BucketInfo))
-> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Bucket, (Int, BucketInfo)) -> Int)
-> (Bucket, (Int, BucketInfo))
-> (Bucket, (Int, BucketInfo))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Int, BucketInfo) -> Int
forall a b. (a, b) -> a
fst ((Int, BucketInfo) -> Int)
-> ((Bucket, (Int, BucketInfo)) -> (Int, BucketInfo))
-> (Bucket, (Int, BucketInfo))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bucket, (Int, BucketInfo)) -> (Int, BucketInfo)
forall a b. (a, b) -> b
snd))) ([(Bucket, (Int, BucketInfo))] -> [(Bucket, (Int, BucketInfo))])
-> [(Bucket, (Int, BucketInfo))] -> [(Bucket, (Int, BucketInfo))]
forall a b. (a -> b) -> a -> b
$ Map Bucket (Int, BucketInfo) -> [(Bucket, (Int, BucketInfo))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Bucket (Int, BucketInfo)
keeps
cc_descs :: Maybe Value
cc_descs = case Header -> Maybe HeapProfBreakdown
hHeapProfileType Header
h of
Just HeapProfBreakdown
HeapProfBreakdownCostCentre -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Map Word32 CostCentre -> [(Bucket, (Int, BucketInfo))] -> Value
outputTree Map Word32 CostCentre
ccMap [(Bucket, (Int, BucketInfo))]
mdescs)
Maybe HeapProfBreakdown
_ -> Maybe Value
forall a. Maybe a
Nothing
use_ipes :: Maybe (Map InfoTablePtr InfoTableLoc)
use_ipes = case Header -> Maybe HeapProfBreakdown
hHeapProfileType Header
h of
Just HeapProfBreakdown
HeapProfBreakdownInfoTable -> Map InfoTablePtr InfoTableLoc
-> Maybe (Map InfoTablePtr InfoTableLoc)
forall a. a -> Maybe a
Just Map InfoTablePtr InfoTableLoc
ipes
Maybe HeapProfBreakdown
_ -> Maybe (Map InfoTablePtr InfoTableLoc)
forall a. Maybe a
Nothing
bucket_desc :: BucketInfo -> Text
bucket_desc BucketInfo
bucket_info = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
desc (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
Map InfoTablePtr InfoTableLoc
ipe_map <- Maybe (Map InfoTablePtr InfoTableLoc)
use_ipes
InfoTablePtr
iptr <- Bucket -> Maybe InfoTablePtr
toItblPointer_maybe (Text -> Bucket
Bucket Text
desc)
InfoTableLoc
itl <- InfoTablePtr -> Map InfoTablePtr InfoTableLoc -> Maybe InfoTableLoc
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup InfoTablePtr
iptr Map InfoTablePtr InfoTableLoc
ipe_map
Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InfoTableLoc -> Text
itlName InfoTableLoc
itl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
where
desc :: Text
desc = BucketInfo -> Text
shortDescription BucketInfo
bucket_info
desc_buckets :: Map Bucket (Int, BucketInfo)
desc_buckets = Args -> Map Bucket BucketInfo -> Map Bucket (Int, BucketInfo)
pruneDetailed Args
a Map Bucket BucketInfo
binfo
bs' :: (UArray Int Double, UArray (Int, Int) Double)
bs' = Header
-> Map Bucket Int
-> [Frame]
-> (UArray Int Double, UArray (Int, Int) Double)
bands Header
h (((Int, BucketInfo) -> Int)
-> Map Bucket (Int, BucketInfo) -> Map Bucket Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int, BucketInfo) -> Int
forall a b. (a, b) -> a
fst Map Bucket (Int, BucketInfo)
desc_buckets) [Frame]
fs
closure_table :: Maybe Html
closure_table =
case Args -> Maybe Int
detailedLimit Args
a of
Just Int
0 -> Maybe Html
forall a. Maybe a
Nothing
Maybe Int
_ | Map Bucket (Int, BucketInfo) -> Bool
forall a. Map Bucket a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Bucket (Int, BucketInfo)
desc_buckets -> Maybe Html
forall a. Maybe a
Nothing
Maybe Int
_ -> Html -> Maybe Html
forall a. a -> Maybe a
Just ((UArray Int Double, UArray (Int, Int) Double)
-> Maybe (Map InfoTablePtr InfoTableLoc)
-> Map Bucket (Int, BucketInfo)
-> Html
renderClosureInfo (UArray Int Double, UArray (Int, Int) Double)
bs' Maybe (Map InfoTablePtr InfoTableLoc)
use_ipes Map Bucket (Int, BucketInfo)
desc_buckets)
in Value -> Maybe Value -> Maybe Html -> HeapProfileData
HeapProfileData Value
combinedJson Maybe Value
cc_descs Maybe Html
closure_table
generateJson :: FilePath -> Args -> IO EventlogType
generateJson :: FilePath -> Args -> IO EventlogType
generateJson = (ProfData -> IO ()) -> FilePath -> Args -> IO EventlogType
generateJsonValidate (IO () -> ProfData -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
generateJsonValidate :: (ProfData -> IO ()) -> FilePath
-> Args -> IO EventlogType
generateJsonValidate :: (ProfData -> IO ()) -> FilePath -> Args -> IO EventlogType
generateJsonValidate ProfData -> IO ()
validate FilePath
file Args
a = do
let chunk :: FilePath -> IO ProfData
chunk = if Args -> Bool
heapProfile Args
a then FilePath -> IO ProfData
H.chunk else Args -> FilePath -> IO ProfData
E.chunk Args
a
ProfData
dat <- FilePath -> IO ProfData
chunk FilePath
file
ProfData -> IO ()
validate ProfData
dat
EventlogType -> IO EventlogType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EventlogType -> IO EventlogType)
-> EventlogType -> IO EventlogType
forall a b. (a -> b) -> a -> b
$ Header
-> Maybe HeapProfileData -> Maybe TickyProfileData -> EventlogType
EventlogType (ProfData -> Header
profHeader ProfData
dat)
(HeapProfileData -> Maybe HeapProfileData
forall a. a -> Maybe a
Just (Args -> ProfData -> HeapProfileData
generateJsonData Args
a ProfData
dat))
(if Bool -> Bool
not ([TickySample] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ProfData -> [TickySample]
profTickySamples ProfData
dat)) then TickyProfileData -> Maybe TickyProfileData
forall a. a -> Maybe a
Just (ProfData -> TickyProfileData
generateTickyData ProfData
dat) else Maybe TickyProfileData
forall a. Maybe a
Nothing)
generateTickyData :: ProfData -> TickyProfileData
generateTickyData :: ProfData -> TickyProfileData
generateTickyData ProfData
dat =
let (Double
percen, Html
html) = Word64
-> Map TickyCounterId TickyCounter
-> Map InfoTablePtr InfoTableLoc
-> [TickySample]
-> (Double, Html)
renderTicky (ProfData -> Word64
profTotalAllocations ProfData
dat) (ProfData -> Map TickyCounterId TickyCounter
profTickyCounters ProfData
dat) (ProfData -> Map InfoTablePtr InfoTableLoc
profItl ProfData
dat) (ProfData -> [TickySample]
profTickySamples ProfData
dat)
in Word64 -> Double -> Html -> TickyProfileData
TickyProfileData (ProfData -> Word64
profTotalAllocations ProfData
dat) Double
percen Html
html