{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Prof.Parser
  ( profile

  , timestamp
  , title
  , commandLine
  , totalTime
  , totalAlloc
  , topCostCentres
  , aggregatedCostCentre
  , costCentres
  , costCentre
  ) where
import Control.Applicative (Alternative((<|>)), optional)
import Control.Monad
import Data.Char (isDigit, isSpace)
import Data.Foldable (asum, foldl')
import Data.Maybe
import Data.Time

import Data.Text (Text)
import Data.Attoparsec.Text as A
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Read as TR

import Control.Monad.Extras (seqM)
import GHC.Prof.Types

#if MIN_VERSION_containers(0, 5, 0)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map.Strict as Map
#else
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
#endif

-- | Parse a GHC time-allocation profiling report
profile :: Parser Profile
profile :: Parser Profile
profile = do
  Parser ()
skipHorizontalSpace
  LocalTime
profileTimestamp <- Parser LocalTime
timestamp; Parser ()
skipSpace
  forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Text
title; Parser ()
skipSpace
  Text
profileCommandLine <- Parser Text
commandLine; Parser ()
skipSpace
  TotalTime
profileTotalTime <- Parser TotalTime
totalTime; Parser ()
skipSpace
  TotalAlloc
profileTotalAlloc <- Parser TotalAlloc
totalAlloc; Parser ()
skipSpace
  [AggregatedCostCentre]
profileTopCostCentres <- Parser [AggregatedCostCentre]
topCostCentres; Parser ()
skipSpace
  CostCentreTree
profileCostCentreTree <- Parser CostCentreTree
costCentres; Parser ()
skipSpace
  forall t. Chunk t => Parser t ()
endOfInput
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Profile {[AggregatedCostCentre]
Text
LocalTime
CostCentreTree
TotalAlloc
TotalTime
profileCostCentreTree :: CostCentreTree
profileTopCostCentres :: [AggregatedCostCentre]
profileTotalAlloc :: TotalAlloc
profileTotalTime :: TotalTime
profileCommandLine :: Text
profileTimestamp :: LocalTime
profileCostCentreTree :: CostCentreTree
profileTopCostCentres :: [AggregatedCostCentre]
profileTotalAlloc :: TotalAlloc
profileTotalTime :: TotalTime
profileCommandLine :: Text
profileTimestamp :: LocalTime
..}

-- | Parse the timestamp in a header as local time
timestamp :: Parser LocalTime
timestamp :: Parser LocalTime
timestamp = do
  Parser Text
parseDayOfTheWeek forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipSpace
  Int
month <- Parser Text Int
parseMonth; Parser ()
skipSpace
  Int
day <- Parser Text Int
parseDay; Parser ()
skipSpace
  TimeOfDay
tod <- Parser Text TimeOfDay
parseTimeOfDay; Parser ()
skipSpace
  Integer
year <- Parser Integer
parseYear; Parser ()
skipSpace
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! LocalTime
    { localDay :: Day
localDay = Integer -> Int -> Int -> Day
fromGregorian Integer
year Int
month Int
day
    , localTimeOfDay :: TimeOfDay
localTimeOfDay = TimeOfDay
tod
    }
  where
    parseYear :: Parser Integer
parseYear = forall a. Integral a => Parser a
decimal
    parseMonth :: Parser Text Int
parseMonth = Int -> Parser Text
A.take Int
3 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {m :: * -> *} {a}.
(Eq a, IsString a, Num a, MonadFail m, Show a) =>
a -> m a
nameToInt
      where
        nameToInt :: a -> m a
nameToInt a
name = case a
name of
          a
"Jan" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
1; a
"Feb" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
2; a
"Mar" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
3
          a
"Apr" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
4; a
"May" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
5; a
"Jun" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
6
          a
"Jul" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
7; a
"Aug" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
8; a
"Sep" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
9
          a
"Oct" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
10; a
"Nov" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
11; a
"Dec" -> forall (m :: * -> *) a. Monad m => a -> m a
return a
12
          a
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"timestamp.toNum: invalid month - " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
name
    parseDay :: Parser Text Int
parseDay = forall a. Integral a => Parser a
decimal
    parseTimeOfDay :: Parser Text TimeOfDay
parseTimeOfDay = Int -> Int -> Pico -> TimeOfDay
TimeOfDay
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
":"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Integral a => Parser a
decimal
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pico
0
    parseDayOfTheWeek :: Parser Text
parseDayOfTheWeek = (Char -> Bool) -> Parser Text
takeTill Char -> Bool
isSpace

title :: Parser Text
title :: Parser Text
title = Text -> Parser Text
string Text
"Time and Allocation Profiling Report  (Final)"

commandLine :: Parser Text
commandLine :: Parser Text
commandLine = (Char -> Bool) -> Parser Text
A.takeWhile forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isEndOfLine

totalTime :: Parser TotalTime
totalTime :: Parser TotalTime
totalTime = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
string Text
"total time  ="; Parser ()
skipSpace
  DiffTime
elapsed <- forall a. Fractional a => Parser a
rational
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
string Text
" secs"; Parser ()
skipSpace
  (Integer
ticks, Integer
resolution, Maybe Int
processors) <- forall a. Parser a -> Parser a
parens forall a b. (a -> b) -> a -> b
$ (,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
" ticks @ "
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Integer
picoSeconds
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
string Text
", " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Char -> Parser Char
notChar Char
')'))
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TotalTime
    { totalTimeElapsed :: DiffTime
totalTimeElapsed = DiffTime
elapsed
    , totalTimeTicks :: Integer
totalTimeTicks = Integer
ticks
    , totalTimeResolution :: DiffTime
totalTimeResolution = Integer -> DiffTime
picosecondsToDiffTime Integer
resolution
    , totalTimeProcessors :: Maybe Int
totalTimeProcessors = Maybe Int
processors
    }
  where
    picoSeconds :: Parser Integer
picoSeconds = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ ((Integer
10 Integer -> Int -> Integer
`pow` Int
3)forall a. Num a => a -> a -> a
*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
" us"
      , ((Integer
10 Integer -> Int -> Integer
`pow` Int
6)forall a. Num a => a -> a -> a
*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
" ms"
      ]
    pow :: Integer -> Int -> Integer
    pow :: Integer -> Int -> Integer
pow = forall a b. (Num a, Integral b) => a -> b -> a
(^)

totalAlloc :: Parser TotalAlloc
totalAlloc :: Parser TotalAlloc
totalAlloc = do
  Text -> Parser Text
string Text
"total alloc =" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipSpace
  !Integer
n <- Parser Integer
groupedDecimal
  Text -> Parser Text
string Text
" bytes" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipSpace
  forall a. Parser a -> Parser a
parens forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
string Text
"excludes profiling overheads"
  forall (m :: * -> *) a. Monad m => a -> m a
return TotalAlloc { totalAllocBytes :: Integer
totalAllocBytes = Integer
n }
  where
    groupedDecimal :: Parser Integer
groupedDecimal = do
      [Integer]
ds <- forall a. Integral a => Parser a
decimal forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Char
char Char
','
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
go Integer
0 [Integer]
ds
      where
        go :: a -> a -> a
go a
z a
n = a
z forall a. Num a => a -> a -> a
* a
1000 forall a. Num a => a -> a -> a
+ a
n

newtype HeaderParams = HeaderParams
  { HeaderParams -> Bool
headerHasSrc :: Bool -- ^ SRC column exists
  } deriving Int -> HeaderParams -> ShowS
[HeaderParams] -> ShowS
HeaderParams -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HeaderParams] -> ShowS
$cshowList :: [HeaderParams] -> ShowS
show :: HeaderParams -> [Char]
$cshow :: HeaderParams -> [Char]
showsPrec :: Int -> HeaderParams -> ShowS
$cshowsPrec :: Int -> HeaderParams -> ShowS
Show

header :: Parser HeaderParams
header :: Parser HeaderParams
header = do
  forall a. Parser a -> Parser ()
optional_ forall a b. (a -> b) -> a -> b
$ do
    Text -> Parser Text
string Text
"individual" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
    Text -> Parser Text
string Text
"inherited" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipSpace
  Text -> Parser Text
string Text
"COST CENTRE" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  Text -> Parser Text
string Text
"MODULE" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  Bool
headerHasSrc <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Bool
False forall a b. (a -> b) -> a -> b
$ Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"SRC"; Parser ()
skipHorizontalSpace
  forall a. Parser a -> Parser ()
optional_ forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
string Text
"no." forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  forall a. Parser a -> Parser ()
optional_ forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
string Text
"entries" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  Text -> Parser Text
string Text
"%time" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  Text -> Parser Text
string Text
"%alloc" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  forall a. Parser a -> Parser ()
optional_ forall a b. (a -> b) -> a -> b
$ do
    Text -> Parser Text
string Text
"%time" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
    Text -> Parser Text
string Text
"%alloc" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  forall a. Parser a -> Parser ()
optional_ forall a b. (a -> b) -> a -> b
$ do
    Text -> Parser Text
string Text
"ticks" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
    Text -> Parser Text
string Text
"bytes" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipHorizontalSpace
  forall (m :: * -> *) a. Monad m => a -> m a
return HeaderParams
    {Bool
headerHasSrc :: Bool
headerHasSrc :: Bool
..}

topCostCentres :: Parser [AggregatedCostCentre]
topCostCentres :: Parser [AggregatedCostCentre]
topCostCentres = do
  HeaderParams
params <- Parser HeaderParams
header; Parser ()
skipSpace
  HeaderParams -> Parser AggregatedCostCentre
aggregatedCostCentre HeaderParams
params forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
endOfLine

aggregatedCostCentre :: HeaderParams -> Parser AggregatedCostCentre
aggregatedCostCentre :: HeaderParams -> Parser AggregatedCostCentre
aggregatedCostCentre HeaderParams {Bool
headerHasSrc :: Bool
headerHasSrc :: HeaderParams -> Bool
..} = Text
-> Text
-> Maybe Text
-> Maybe Integer
-> Scientific
-> Scientific
-> Maybe Integer
-> Maybe Integer
-> AggregatedCostCentre
AggregatedCostCentre
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
symbol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace -- name
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
symbol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace -- module
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text (Maybe Text)
source forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace -- src
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing -- entries
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Scientific
scientific forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace -- %time
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Scientific
scientific forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace -- %alloc
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace -- ticks
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace -- bytes
  where
    source :: Parser Text (Maybe Text)
source
      | Bool
headerHasSrc = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
sourceSpan
      | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

costCentres :: Parser CostCentreTree
costCentres :: Parser CostCentreTree
costCentres = do
  HeaderParams
params <- Parser HeaderParams
header; Parser ()
skipSpace
  HeaderParams -> Parser CostCentreTree
costCentreTree HeaderParams
params

costCentre :: HeaderParams -> Parser CostCentre
costCentre :: HeaderParams -> Parser CostCentre
costCentre HeaderParams
params = do
  Text
name <- Parser Text
symbol; Parser ()
skipHorizontalSpace
  (Text
modName, Maybe Text
src, Int
no, (Integer
entries, Scientific
indTime, Scientific
indAlloc, Scientific
inhTime, Scientific
inhAlloc, Maybe (Integer, Integer)
optInfo))
    <- forall {c}.
Integral c =>
HeaderParams
-> Parser
     Text
     (Text, Maybe Text, c,
      (Integer, Scientific, Scientific, Scientific, Scientific,
       Maybe (Integer, Integer)))
validCostCentre HeaderParams
params forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}.
Parser
  Text
  (Text, Maybe a, Int,
   (Integer, Scientific, Scientific, Scientific, Scientific,
    Maybe (Integer, Integer)))
jammedCostCentre
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! CostCentre
    { costCentreName :: Text
costCentreName = Text
name
    , costCentreModule :: Text
costCentreModule = Text
modName
    , costCentreSrc :: Maybe Text
costCentreSrc = Maybe Text
src
    , costCentreNo :: Int
costCentreNo = Int
no
    , costCentreEntries :: Integer
costCentreEntries = Integer
entries
    , costCentreIndTime :: Scientific
costCentreIndTime = Scientific
indTime
    , costCentreIndAlloc :: Scientific
costCentreIndAlloc = Scientific
indAlloc
    , costCentreInhTime :: Scientific
costCentreInhTime = Scientific
inhTime
    , costCentreInhAlloc :: Scientific
costCentreInhAlloc = Scientific
inhAlloc
    , costCentreTicks :: Maybe Integer
costCentreTicks = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Integer, Integer)
optInfo
    , costCentreBytes :: Maybe Integer
costCentreBytes = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Integer, Integer)
optInfo
    }
  where
    validCostCentre :: HeaderParams
-> Parser
     Text
     (Text, Maybe Text, c,
      (Integer, Scientific, Scientific, Scientific, Scientific,
       Maybe (Integer, Integer)))
validCostCentre HeaderParams {Bool
headerHasSrc :: Bool
headerHasSrc :: HeaderParams -> Bool
..} = do
      Text
modName <- Parser Text
symbol; Parser ()
skipHorizontalSpace
      Maybe Text
src <- if Bool
headerHasSrc
        then do
          !Text
sym <- Parser Text
sourceSpan
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
sym
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Parser ()
skipHorizontalSpace
      c
no <- forall a. Integral a => Parser a
decimal; Parser ()
skipHorizontalSpace
      (Integer, Scientific, Scientific, Scientific, Scientific,
 Maybe (Integer, Integer))
vals <- Parser
  Text
  (Integer, Scientific, Scientific, Scientific, Scientific,
   Maybe (Integer, Integer))
metrics
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text
modName, Maybe Text
src, c
no, (Integer, Scientific, Scientific, Scientific, Scientific,
 Maybe (Integer, Integer))
vals)
    -- Workaround for https://ghc.haskell.org/trac/ghc/ticket/8811.
    -- This bug had been fixed before the SRC column was implemented so
    -- @sourceSpan@ isn't parsed here.
    -- Caveat: This parser can be confused if module name contains digits and
    -- the digits are jammed with the cost centre number. In such cases, all
    -- the digits are parsed as a number of entries.
    jammedCostCentre :: Parser
  Text
  (Text, Maybe a, Int,
   (Integer, Scientific, Scientific, Scientific, Scientific,
    Maybe (Integer, Integer)))
jammedCostCentre = do
      Text
jammed <- Parser Text
symbol; Parser ()
skipHorizontalSpace
      let modName :: Text
modName = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isDigit Text
jammed
      Int
no <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. Integral a => Reader a
TR.decimal forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd Char -> Bool
isDigit Text
jammed
      (Integer, Scientific, Scientific, Scientific, Scientific,
 Maybe (Integer, Integer))
vals <- Parser
  Text
  (Integer, Scientific, Scientific, Scientific, Scientific,
   Maybe (Integer, Integer))
metrics
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text
modName, forall a. Maybe a
Nothing, Int
no, (Integer, Scientific, Scientific, Scientific, Scientific,
 Maybe (Integer, Integer))
vals)
    metrics :: Parser
  Text
  (Integer, Scientific, Scientific, Scientific, Scientific,
   Maybe (Integer, Integer))
metrics = do
      Integer
entries <- forall a. Integral a => Parser a
decimal; Parser ()
skipHorizontalSpace
      Scientific
indTime <- Parser Scientific
scientific; Parser ()
skipHorizontalSpace
      Scientific
indAlloc <- Parser Scientific
scientific; Parser ()
skipHorizontalSpace
      Scientific
inhTime <- Parser Scientific
scientific; Parser ()
skipHorizontalSpace
      Scientific
inhAlloc <- Parser Scientific
scientific; Parser ()
skipHorizontalSpace
      Maybe (Integer, Integer)
optInfo <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ do
        !Integer
ticks <- forall a. Integral a => Parser a
decimal; Parser ()
skipHorizontalSpace
        !Integer
bytes <- forall a. Integral a => Parser a
decimal
        forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
ticks, Integer
bytes)
      forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
entries, Scientific
indTime, Scientific
indAlloc, Scientific
inhTime, Scientific
inhAlloc, Maybe (Integer, Integer)
optInfo)

costCentreTree :: HeaderParams -> Parser CostCentreTree
costCentreTree :: HeaderParams -> Parser CostCentreTree
costCentreTree HeaderParams
params = [(Int, CostCentre)] -> CostCentreTree
buildTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text [(Int, CostCentre)]
costCentreList
  where
    costCentreList :: Parser Text [(Int, CostCentre)]
costCentreList = Parser Text (Int, CostCentre)
nestedCostCentre forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
endOfLine
    nestedCostCentre :: Parser Text (Int, CostCentre)
nestedCostCentre = (,)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
nestLevel
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeaderParams -> Parser CostCentre
costCentre HeaderParams
params
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHorizontalSpace
    nestLevel :: Parser Text Int
nestLevel = forall a. Parser a -> Parser Text Int
howMany Parser Char
space

type Level = Int

-- | TreePath represents a path to a node in a cost centre tree.
--
-- Invariant: @'treePathLevel' == length 'treePath'@
data TreePath = TreePath
  { TreePath -> Int
treePathLevel :: !Level
  -- ^ Current depth of the path
  , TreePath -> [Int]
treePath :: [CostCentreNo]
  -- ^ Path to the node
  }

push :: CostCentreNo -> TreePath -> TreePath
push :: Int -> TreePath -> TreePath
push Int
ccNo path :: TreePath
path@TreePath {Int
[Int]
treePath :: [Int]
treePathLevel :: Int
treePath :: TreePath -> [Int]
treePathLevel :: TreePath -> Int
..} = TreePath
path
  { treePathLevel :: Int
treePathLevel = Int
treePathLevel forall a. Num a => a -> a -> a
+ Int
1
  , treePath :: [Int]
treePath = Int
ccNoforall a. a -> [a] -> [a]
:[Int]
treePath
  }

popTo :: Level -> TreePath -> TreePath
popTo :: Int -> TreePath -> TreePath
popTo Int
level path :: TreePath
path@TreePath {Int
[Int]
treePath :: [Int]
treePathLevel :: Int
treePath :: TreePath -> [Int]
treePathLevel :: TreePath -> Int
..} = TreePath
path
  { treePathLevel :: Int
treePathLevel = Int
level
  , treePath :: [Int]
treePath = forall a. Int -> [a] -> [a]
drop (Int
treePathLevel forall a. Num a => a -> a -> a
- Int
level) [Int]
treePath
  }

currentNo :: TreePath -> Maybe CostCentreNo
currentNo :: TreePath -> Maybe Int
currentNo TreePath {[Int]
treePath :: [Int]
treePath :: TreePath -> [Int]
treePath} = forall a. [a] -> Maybe a
listToMaybe [Int]
treePath

buildTree :: [(Level, CostCentre)] -> CostCentreTree
buildTree :: [(Int, CostCentre)] -> CostCentreTree
buildTree = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (TreePath, CostCentreTree)
-> (Int, CostCentre) -> (TreePath, CostCentreTree)
go (Int -> [Int] -> TreePath
TreePath Int
0 [], CostCentreTree
emptyCostCentreTree)
  where
    go
      :: (TreePath, CostCentreTree)
      -> (Level, CostCentre)
      -> (TreePath, CostCentreTree)
    go :: (TreePath, CostCentreTree)
-> (Int, CostCentre) -> (TreePath, CostCentreTree)
go (!TreePath
path, !CostCentreTree {IntMap Int
IntMap (Set CostCentre)
IntMap CostCentre
Map (Text, Text) (Set CostCentre)
Map Text (Map Text AggregatedCostCentre)
costCentreAggregate :: CostCentreTree -> Map Text (Map Text AggregatedCostCentre)
costCentreCallSites :: CostCentreTree -> Map (Text, Text) (Set CostCentre)
costCentreChildren :: CostCentreTree -> IntMap (Set CostCentre)
costCentreParents :: CostCentreTree -> IntMap Int
costCentreNodes :: CostCentreTree -> IntMap CostCentre
costCentreAggregate :: Map Text (Map Text AggregatedCostCentre)
costCentreCallSites :: Map (Text, Text) (Set CostCentre)
costCentreChildren :: IntMap (Set CostCentre)
costCentreParents :: IntMap Int
costCentreNodes :: IntMap CostCentre
..}) (Int
level, CostCentre
node) = (TreePath
path', CostCentreTree
tree')
      where
        ccNo :: Int
ccNo = CostCentre -> Int
costCentreNo CostCentre
node
        parentPath :: TreePath
parentPath = Int -> TreePath -> TreePath
popTo Int
level TreePath
path
        parentNo :: Maybe Int
parentNo = TreePath -> Maybe Int
currentNo TreePath
parentPath
        path' :: TreePath
path' = Int -> TreePath -> TreePath
push Int
ccNo TreePath
parentPath
        tree' :: CostCentreTree
tree' = CostCentreTree
          { costCentreNodes :: IntMap CostCentre
costCentreNodes = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
ccNo CostCentre
node IntMap CostCentre
costCentreNodes
          , costCentreParents :: IntMap Int
costCentreParents = forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntMap Int
costCentreParents
            (\Int
parent -> forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
ccNo Int
parent IntMap Int
costCentreParents)
            Maybe Int
parentNo
          , costCentreChildren :: IntMap (Set CostCentre)
costCentreChildren = forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntMap (Set CostCentre)
costCentreChildren
            (\Int
parent -> forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith forall a. Ord a => Set a -> Set a -> Set a
Set.union Int
parent
              (forall a. a -> Set a
Set.singleton CostCentre
node)
              IntMap (Set CostCentre)
costCentreChildren)
            Maybe Int
parentNo
          , costCentreCallSites :: Map (Text, Text) (Set CostCentre)
costCentreCallSites = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Ord a => Set a -> Set a -> Set a
Set.union
            (CostCentre -> Text
costCentreName CostCentre
node, CostCentre -> Text
costCentreModule CostCentre
node)
            (forall a. a -> Set a
Set.singleton CostCentre
node)
            Map (Text, Text) (Set CostCentre)
costCentreCallSites
          , costCentreAggregate :: Map Text (Map Text AggregatedCostCentre)
costCentreAggregate = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter
            (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Map Text AggregatedCostCentre)
-> Map Text AggregatedCostCentre
updateCostCentre)
            (CostCentre -> Text
costCentreModule CostCentre
node)
            Map Text (Map Text AggregatedCostCentre)
costCentreAggregate
          }
        aggregate :: AggregatedCostCentre
aggregate = AggregatedCostCentre
          { aggregatedCostCentreName :: Text
aggregatedCostCentreName = CostCentre -> Text
costCentreName CostCentre
node
          , aggregatedCostCentreModule :: Text
aggregatedCostCentreModule = CostCentre -> Text
costCentreModule CostCentre
node
          , aggregatedCostCentreSrc :: Maybe Text
aggregatedCostCentreSrc = CostCentre -> Maybe Text
costCentreSrc CostCentre
node
          , aggregatedCostCentreEntries :: Maybe Integer
aggregatedCostCentreEntries = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! CostCentre -> Integer
costCentreEntries CostCentre
node
          , aggregatedCostCentreTime :: Scientific
aggregatedCostCentreTime = CostCentre -> Scientific
costCentreIndTime CostCentre
node
          , aggregatedCostCentreAlloc :: Scientific
aggregatedCostCentreAlloc = CostCentre -> Scientific
costCentreIndAlloc CostCentre
node
          , aggregatedCostCentreTicks :: Maybe Integer
aggregatedCostCentreTicks = CostCentre -> Maybe Integer
costCentreTicks CostCentre
node
          , aggregatedCostCentreBytes :: Maybe Integer
aggregatedCostCentreBytes = CostCentre -> Maybe Integer
costCentreBytes CostCentre
node
          }
        updateCostCentre
          :: Maybe (Map.Map Text AggregatedCostCentre)
          -> Map.Map Text AggregatedCostCentre
        updateCostCentre :: Maybe (Map Text AggregatedCostCentre)
-> Map Text AggregatedCostCentre
updateCostCentre = \case
          Maybe (Map Text AggregatedCostCentre)
Nothing -> forall k a. k -> a -> Map k a
Map.singleton (CostCentre -> Text
costCentreName CostCentre
node) AggregatedCostCentre
aggregate
          Just Map Text AggregatedCostCentre
costCentreByName ->
            forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith
              AggregatedCostCentre
-> AggregatedCostCentre -> AggregatedCostCentre
addCostCentre
              (CostCentre -> Text
costCentreName CostCentre
node)
              AggregatedCostCentre
aggregate
              Map Text AggregatedCostCentre
costCentreByName
        addCostCentre :: AggregatedCostCentre
-> AggregatedCostCentre -> AggregatedCostCentre
addCostCentre AggregatedCostCentre
x AggregatedCostCentre
y = AggregatedCostCentre
x
          { aggregatedCostCentreEntries :: Maybe Integer
aggregatedCostCentreEntries = forall (m :: * -> *) a. Monad m => m a -> m a
seqM forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
(+)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AggregatedCostCentre -> Maybe Integer
aggregatedCostCentreEntries AggregatedCostCentre
x
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AggregatedCostCentre -> Maybe Integer
aggregatedCostCentreEntries AggregatedCostCentre
y
          , aggregatedCostCentreTime :: Scientific
aggregatedCostCentreTime =
            AggregatedCostCentre -> Scientific
aggregatedCostCentreTime AggregatedCostCentre
x forall a. Num a => a -> a -> a
+ AggregatedCostCentre -> Scientific
aggregatedCostCentreTime AggregatedCostCentre
y
          , aggregatedCostCentreAlloc :: Scientific
aggregatedCostCentreAlloc =
            AggregatedCostCentre -> Scientific
aggregatedCostCentreAlloc AggregatedCostCentre
x forall a. Num a => a -> a -> a
+ AggregatedCostCentre -> Scientific
aggregatedCostCentreAlloc AggregatedCostCentre
y
          , aggregatedCostCentreTicks :: Maybe Integer
aggregatedCostCentreTicks = forall (m :: * -> *) a. Monad m => m a -> m a
seqM forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
(+)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AggregatedCostCentre -> Maybe Integer
aggregatedCostCentreTicks AggregatedCostCentre
x
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AggregatedCostCentre -> Maybe Integer
aggregatedCostCentreTicks AggregatedCostCentre
y
          , aggregatedCostCentreBytes :: Maybe Integer
aggregatedCostCentreBytes = forall (m :: * -> *) a. Monad m => m a -> m a
seqM forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
(+)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AggregatedCostCentre -> Maybe Integer
aggregatedCostCentreBytes AggregatedCostCentre
x
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AggregatedCostCentre -> Maybe Integer
aggregatedCostCentreBytes AggregatedCostCentre
y
          }

howMany :: Parser a -> Parser Int
howMany :: forall a. Parser a -> Parser Text Int
howMany Parser a
p = forall {a}. Enum a => a -> Parser Text a
loop Int
0
  where
    loop :: a -> Parser Text a
loop !a
n = (Parser a
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Parser Text a
loop (forall a. Enum a => a -> a
succ a
n)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return a
n

parens :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens Parser a
p = Text -> Parser Text
string Text
"(" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
")"

symbol :: Parser Text
symbol :: Parser Text
symbol = (Char -> Bool) -> Parser Text
A.takeWhile forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace

sourceSpan :: Parser Text
sourceSpan :: Parser Text
sourceSpan = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
  [ [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text [Char]
angleBrackets
  , Parser Text
symbol
  ]
  where
    angleBrackets :: Parser Text [Char]
angleBrackets = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Char
char Char
'<' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
manyTill Parser Char
anyChar (Char -> Parser Char
char Char
'>')

skipHorizontalSpace :: Parser ()
skipHorizontalSpace :: Parser ()
skipHorizontalSpace = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
isHorizontalSpace

optional_ :: Parser a -> Parser ()
optional_ :: forall a. Parser a -> Parser ()
optional_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional