{-# 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 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 = 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 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
  forall (m :: * -> *) a. Monad m => a -> m a
return (Header
-> Map Bucket BucketInfo
-> Map Word32 CostCentre
-> [Frame]
-> [Trace]
-> HeapInfo
-> Map InfoTablePtr InfoTableLoc
-> Map TickyCounterId TickyCounter
-> [TickySample]
-> Word64
-> ProfData
ProfData (Int -> Header
ph Int
counts) Map Bucket BucketInfo
binfo forall a. Monoid a => a
mempty [Frame]
fs [] ([HeapSample] -> [HeapSample] -> [HeapSample] -> HeapInfo
HeapInfo [] [] []) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Word64
0)

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) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
4 [Text]
ls
      [Text
job, Text
date, Text
smpU, Text
valU] =
        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 forall a. Maybe a
Nothing (FilePath -> Text
pack FilePath
"") Text
smpU Text
valU Int
v 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 Text -> Text
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
drop (Text -> Int
length Text
name forall a. Num a => a -> a -> a
+ Int
2) forall a b. (a -> b) -> a -> b
$ Text
h -- drop the name and the quotes
  else forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Parse.header: expected " 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) = 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 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Int -> Text -> Text
drop (Text -> Int
length Text
name forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ Text
h
  else forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Parse.sampleTime: expected " forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
name forall a. [a] -> [a] -> [a]
++ FilePath
" but got " forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
h

readDouble :: Text -> Double
readDouble :: Text -> Double
readDouble Text
s = case forall a. Parser a -> Text -> Either FilePath a
parseOnly Parser Double
double Text
s of
  Right Double
x -> Double
x
  Either FilePath Double
_ -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Parse.readDouble: no parse " 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"