--
-- ParseProfile.hs
--
-- This module parses the profile file generated when a program
-- is run with the +RTS -px -RTS flag.  The result is a Profile
-- record that contains all of the information from the file.
--

module ParseProfile (
        CostCenter(..),
        CostCenterStack(..),
        CostCenterReport(..),
        Profile(..),
        parseProfile
) where


import Data.IntMap
import Data.List as L
import Text.ParserCombinators.Parsec


data CostCenter = CostCenter { ccName   :: String,
                               ccModule :: String }
                deriving (Show)

data CostCenterStack = CostCenterStack { stackCCID   :: Int,
                                         parentStack :: [ Int ] }
                     deriving (Show)

data CostCenterReport = CostCenterReport { reportCount :: Integer,
                                           reportTicks :: Integer,
                                           reportAlloc :: Integer }
                      deriving (Show)

data Profile = Profile { timestamp    :: String,
                         tickInterval :: String,
                         profileTicks :: Integer,
                         centers      :: IntMap CostCenter,
                         stacks       :: IntMap CostCenterStack,
                         reports      :: IntMap CostCenterReport }
             deriving (Show)


costCenterCode :: Parser Char
costCenterCode      = char '1'

costCenterStackCode :: Parser Char
costCenterStackCode = char '2'

timeUpdateCode :: Parser Char
timeUpdateCode      = char '5'


natural :: Parser Int
natural = do
  digits <- many1 digit
  return ((read digits) :: Int)

naturalLong :: Parser Integer
naturalLong = do
  digits <- many1 digit
  return ((read digits) :: Integer)

quotedString :: Parser String
quotedString = do
  char '"'
  manyTill anyChar (try (char '"'))

headerStr :: Parser String
headerStr =  do 
  header <- quotedString; newline
  return header

costCenter :: Parser (Int, CostCenter)
costCenter = do
  costCenterCode; space
  ccId  <- natural; space
  name  <- quotedString; space
  modul <- quotedString; newline
  return (ccId, CostCenter { ccName   = name,
                             ccModule = modul })

costCenterStack :: Parser (Int, CostCenterStack)
costCenterStack = do
  costCenterStackCode; space
  ccsId     <- natural; space
  stackCode <- oneOf "12"; space
  cc        <- natural
  prev      <- do if stackCode == '1'
                      then return []
                      else do
                        space
                        p <- natural
                        return [p]
  newline
  return (ccsId, CostCenterStack { stackCCID   = cc,
                                   parentStack = prev })


fixupCCS :: [ (Int, CostCenterStack) ] -> [ (Int, CostCenterStack) ]
fixupCCS ccss = let
        fixup :: (Int, CostCenterStack) -> Bool
        fixup (ccsId, ccs) = if L.null (parentStack ccs)
                                 then True
                                 else ccsId > head (parentStack ccs)
        in
          L.filter fixup ccss


ccsReport :: Parser (Int, CostCenterReport)
ccsReport = do
  char '1'; space
  ccsId <- natural; space
  calls <- naturalLong; space
  ticks <- naturalLong; space
  alloc <- naturalLong; space
  return (ccsId, CostCenterReport { reportCount = calls,
                                    reportTicks = ticks,
                                    reportAlloc = alloc })


totalTicks :: Parser Integer
totalTicks = do
  timeUpdateCode; space
  ticks <- naturalLong; space
  return ticks


profile :: Parser Profile
profile = do
  stamp            <- headerStr
  step             <- headerStr
  costCenters      <- many costCenter
  costCenterStacks <- many costCenterStack
  ticks            <- totalTicks
  times            <- manyTill ccsReport (try (char '0'))
  return Profile { timestamp    = stamp,
                   tickInterval = step,
                   profileTicks = ticks,
                   centers      = fromList costCenters,
                   stacks       = fromList (fixupCCS costCenterStacks),
                   reports      = fromList times }


parseProfile :: FilePath -> String -> Maybe Profile
parseProfile name input =
        case parse profile name input of
            Left  _    -> Nothing
            Right prof -> Just prof