{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE BangPatterns #-}
module Eventlog.HeapProf (chunk) where

import Prelude hiding (init, lookup, lines, words, drop, length, readFile)
import Data.Text (Text, lines, init, drop, length, isPrefixOf, unpack, words, pack)
import Data.Text.IO (readFile)
import Data.Attoparsec.Text (parseOnly, double)
import qualified Data.Map as Map

import Eventlog.Total
import Eventlog.Types

chunk :: FilePath -> IO ProfData
chunk :: FilePath -> IO ProfData
chunk FilePath
f = do
  (Int -> Header
ph, [Frame]
fs) <- Text -> (Int -> Header, [Frame])
chunkT (Text -> (Int -> Header, [Frame]))
-> IO Text -> IO (Int -> Header, [Frame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
readFile FilePath
f
  let (Int
counts, Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals) = [Frame]
-> (Int,
    Map Bucket (Double, Double, Maybe (Double, Double, Double)))
total [Frame]
fs
      -- Heap profiles don't contain any other information than the simple bucket name
      binfo :: Map Bucket BucketInfo
binfo = (Bucket
 -> (Double, Double, Maybe (Double, Double, Double)) -> BucketInfo)
-> Map Bucket (Double, Double, Maybe (Double, Double, Double))
-> Map Bucket BucketInfo
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\(Bucket Text
k) (Double
t,Double
s,Maybe (Double, Double, Double)
g) -> Text
-> Maybe [Word32]
-> Double
-> Double
-> Maybe (Double, Double, Double)
-> BucketInfo
BucketInfo Text
k Maybe [Word32]
forall a. Maybe a
Nothing Double
t Double
s Maybe (Double, Double, Double)
g) Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals
  -- Heap profiles do not support traces
  ProfData -> IO ProfData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Header
-> Map Bucket BucketInfo
-> Map Word32 CostCentre
-> [Frame]
-> [Trace]
-> HeapInfo
-> Map InfoTablePtr InfoTableLoc
-> ProfData
ProfData (Int -> Header
ph Int
counts) Map Bucket BucketInfo
binfo Map Word32 CostCentre
forall a. Monoid a => a
mempty [Frame]
fs [] ([HeapSample] -> [HeapSample] -> [HeapSample] -> HeapInfo
HeapInfo [] [] []) Map InfoTablePtr InfoTableLoc
forall a. Monoid a => a
mempty)

chunkT :: Text -> (Int -> Header, [Frame])
chunkT :: Text -> (Int -> Header, [Frame])
chunkT Text
s =
  let ls :: [Text]
ls = Text -> [Text]
lines Text
s
      ([Text]
hs, [Text]
ss) = Int -> [Text] -> ([Text], [Text])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
4 [Text]
ls
      [Text
job, Text
date, Text
smpU, Text
valU] =
        (Text -> Text -> Text) -> [Text] -> [Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Text -> Text
header [Text
sJOB, Text
sDATE, Text
sSAMPLE_UNIT, Text
sVALUE_UNIT] [Text]
hs
      fs :: [Frame]
fs = [Text] -> [Frame]
chunkSamples [Text]
ss
  in  (\Int
v -> Text
-> Text
-> Maybe HeapProfBreakdown
-> Text
-> Text
-> Text
-> Int
-> Maybe FilePath
-> Header
Header Text
job Text
date Maybe HeapProfBreakdown
forall a. Maybe a
Nothing (FilePath -> Text
pack FilePath
"") Text
smpU Text
valU Int
v Maybe FilePath
forall a. Maybe a
Nothing
      ,  [Frame]
fs
      )

header :: Text -> Text -> Text
header :: Text -> Text -> Text
header Text
name Text
h =
  if Text
name Text -> Text -> Bool
`isPrefixOf` Text
h
  then HasCallStack => Text -> Text
Text -> Text
init (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
drop (Text -> Int
length Text
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
h -- drop the name and the quotes
  else FilePath -> Text
forall a. HasCallStack => FilePath -> a
error (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Parse.header: expected " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
name

chunkSamples :: [Text] -> [Frame]
chunkSamples :: [Text] -> [Frame]
chunkSamples [] = []
chunkSamples (Text
x:[Text]
xs)
  | Text
sBEGIN_SAMPLE Text -> Text -> Bool
`isPrefixOf` Text
x =
      let ([Text]
ys, [Text]
zs) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
sEND_SAMPLE Text -> Text -> Bool
`isPrefixOf`) [Text]
xs
      in  case [Text]
zs of
            [] -> [] -- discard incomplete sample
            (Text
_:[Text]
ws) -> Text -> [Text] -> Frame
parseFrame Text
x [Text]
ys Frame -> [Frame] -> [Frame]
forall a. a -> [a] -> [a]
: [Text] -> [Frame]
chunkSamples [Text]
ws
  | Bool
otherwise = [] -- expected BEGIN_SAMPLE or EOF...

parseFrame :: Text -> [Text] -> Frame
parseFrame :: Text -> [Text] -> Frame
parseFrame Text
l [Text]
ls =
  let !time :: Double
time = Text -> Text -> Double
sampleTime Text
sBEGIN_SAMPLE Text
l
      ss :: [Sample]
ss = (Text -> Sample) -> [Text] -> [Sample]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Sample
parseSample [Text]
ls
  in Double -> [Sample] -> Frame
Frame Double
time [Sample]
ss

parseSample :: Text -> Sample
parseSample :: Text -> Sample
parseSample Text
s =
  let [Text
k,Text
vs] = Text -> [Text]
words Text
s
      !v :: Double
v = Text -> Double
readDouble Text
vs
  in Bucket -> Double -> Sample
Sample (Text -> Bucket
Bucket Text
k) Double
v


sampleTime :: Text -> Text -> Double
sampleTime :: Text -> Text -> Double
sampleTime Text
name Text
h =
  if Text
name Text -> Text -> Bool
`isPrefixOf` Text
h
  then Text -> Double
readDouble (Text -> Double) -> (Text -> Text) -> Text -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Int -> Text -> Text
drop (Text -> Int
length Text
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text -> Double) -> Text -> Double
forall a b. (a -> b) -> a -> b
$ Text
h
  else FilePath -> Double
forall a. HasCallStack => FilePath -> a
error (FilePath -> Double) -> FilePath -> Double
forall a b. (a -> b) -> a -> b
$ FilePath
"Parse.sampleTime: expected " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" but got " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
h

readDouble :: Text -> Double
readDouble :: Text -> Double
readDouble Text
s = case Parser Double -> Text -> Either FilePath Double
forall a. Parser a -> Text -> Either FilePath a
parseOnly Parser Double
double Text
s of
  Right Double
x -> Double
x
  Either FilePath Double
_ -> FilePath -> Double
forall a. HasCallStack => FilePath -> a
error (FilePath -> Double) -> FilePath -> Double
forall a b. (a -> b) -> a -> b
$ FilePath
"Parse.readDouble: no parse " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
s

sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT, sBEGIN_SAMPLE, sEND_SAMPLE :: Text
sJOB :: Text
sJOB = FilePath -> Text
pack FilePath
"JOB"
sDATE :: Text
sDATE = FilePath -> Text
pack FilePath
"DATE"
sSAMPLE_UNIT :: Text
sSAMPLE_UNIT = FilePath -> Text
pack FilePath
"SAMPLE_UNIT"
sVALUE_UNIT :: Text
sVALUE_UNIT = FilePath -> Text
pack FilePath
"VALUE_UNIT"
sBEGIN_SAMPLE :: Text
sBEGIN_SAMPLE = FilePath -> Text
pack FilePath
"BEGIN_SAMPLE"
sEND_SAMPLE :: Text
sEND_SAMPLE = FilePath -> Text
pack FilePath
"END_SAMPLE"