{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}

module GHC.RTS.Events.Incremental
  ( -- * Incremental API
    Decoder(..)
  , decodeHeader
  , decodeEvents
  , decodeEventLog

  -- * Lazy API
  , readHeader
  , readEvents
  , readEvents'
  , readEventLog
  , readEventLogOrFail
  ) where
import Control.Monad
import Data.Either
import Data.Maybe
import Prelude

import qualified Data.Binary.Get as G
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Internal as BL
import qualified Data.IntMap.Strict as IM

import GHC.RTS.EventParserUtils
import GHC.RTS.EventTypes
import GHC.RTS.Events.Binary

#define EVENTLOG_CONSTANTS_ONLY
#include "EventLogFormat.h"

-- | The unfolding of the decoding process.
data Decoder a
  = Consume (B.ByteString -> Decoder a)
  -- ^ The decoder has consumed all the available input and needs more to
  -- continue.
  | Produce !a (Decoder a)
  -- ^ The decoder has returned a decoded value and the next decoder state to
  -- continue.
  | Done B.ByteString
  -- ^ The decoder has ended with leftover input.
  | Error B.ByteString String
  -- ^ The decoder has encountered an error with leftover input and an error
  -- message.

-- | Push an input chunk to the decoder
pushChunk :: Decoder a -> B.ByteString -> Decoder a
pushChunk :: forall a. Decoder a -> ByteString -> Decoder a
pushChunk Decoder a
decoder ByteString
chunk = case Decoder a
decoder of
  Consume ByteString -> Decoder a
k -> ByteString -> Decoder a
k ByteString
chunk
  Produce a
a Decoder a
decoder' -> forall a. a -> Decoder a -> Decoder a
Produce a
a forall a b. (a -> b) -> a -> b
$ Decoder a
decoder' forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
chunk
  Done ByteString
leftover -> forall a. ByteString -> Decoder a
Done forall a b. (a -> b) -> a -> b
$ ByteString
leftover ByteString -> ByteString -> ByteString
`B.append` ByteString
chunk
  Error ByteString
leftover String
err -> forall a. ByteString -> String -> Decoder a
Error (ByteString
leftover ByteString -> ByteString -> ByteString
`B.append` ByteString
chunk) String
err

-- | Decode a header and continue with the provided decoder
withHeader
  :: (Header -> B.ByteString -> Decoder r)
  -- ^ Continuation
  -> Decoder r
withHeader :: forall r. (Header -> ByteString -> Decoder r) -> Decoder r
withHeader Header -> ByteString -> Decoder r
f = Decoder Header -> Decoder r
go forall a b. (a -> b) -> a -> b
$ forall a. Get a -> Decoder a
G.runGetIncremental Get Header
getHeader
  where
    go :: Decoder Header -> Decoder r
go Decoder Header
decoder = case Decoder Header
decoder of
      G.Done ByteString
leftover ByteOffset
_ Header
header -> Header -> ByteString -> Decoder r
f Header
header ByteString
leftover
      G.Partial Maybe ByteString -> Decoder Header
k -> forall a. (ByteString -> Decoder a) -> Decoder a
Consume forall a b. (a -> b) -> a -> b
$ \ByteString
chunk -> Decoder Header -> Decoder r
go forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Decoder Header
k forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
chunk
      G.Fail ByteString
leftover ByteOffset
_ String
err -> forall a. ByteString -> String -> Decoder a
Error ByteString
leftover String
err

-- | Decode a header
decodeHeader :: Decoder Header
decodeHeader :: Decoder Header
decodeHeader = forall r. (Header -> ByteString -> Decoder r) -> Decoder r
withHeader forall a b. (a -> b) -> a -> b
$ \Header
header ByteString
leftover -> forall a. a -> Decoder a -> Decoder a
Produce Header
header forall a b. (a -> b) -> a -> b
$ forall a. ByteString -> Decoder a
Done ByteString
leftover

-- | Decode events
decodeEvents :: Header -> Decoder Event
decodeEvents :: Header -> Decoder Event
decodeEvents Header
header = forall {t}.
(Ord t, Num t) =>
t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go (Int
0 :: Int) forall a. Maybe a
Nothing Decoder (Maybe Event)
decoder0
  where
    decoder0 :: Decoder (Maybe Event)
decoder0 = Header -> Decoder (Maybe Event)
mkEventDecoder Header
header
    go :: t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go !t
remaining !Maybe Int
blockCap Decoder (Maybe Event)
decoder = case Decoder (Maybe Event)
decoder of
      G.Done ByteString
leftover ByteOffset
consumed Maybe Event
r -> do
        let !decoder' :: Decoder (Maybe Event)
decoder' = Decoder (Maybe Event)
decoder0 forall a. Decoder a -> ByteString -> Decoder a
`G.pushChunk` ByteString
leftover
        case Maybe Event
r of
          Just Event
event -> case Event -> EventInfo
evSpec Event
event of
            EventBlock {Int
BlockSize
Timestamp
block_size :: EventInfo -> BlockSize
cap :: EventInfo -> Int
end_time :: EventInfo -> Timestamp
block_size :: BlockSize
cap :: Int
end_time :: Timestamp
..} ->
              t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go (forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockSize
block_size) (Int -> Maybe Int
mkCap Int
cap) Decoder (Maybe Event)
decoder'
            EventInfo
_ -> do
              let
                !remaining' :: t
remaining' = t
remaining forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
consumed
                !blockCap' :: Maybe Int
blockCap' = if t
remaining' forall a. Ord a => a -> a -> Bool
> t
0 then Maybe Int
blockCap else forall a. Maybe a
Nothing
                !event' :: Event
event' = Event
event { evCap :: Maybe Int
evCap = Maybe Int
blockCap }
              forall a. a -> Decoder a -> Decoder a
Produce Event
event' forall a b. (a -> b) -> a -> b
$ t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go t
remaining' Maybe Int
blockCap' Decoder (Maybe Event)
decoder'
          Maybe Event
Nothing -> t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go t
remaining Maybe Int
blockCap Decoder (Maybe Event)
decoder'
      G.Partial Maybe ByteString -> Decoder (Maybe Event)
k ->
        forall a. (ByteString -> Decoder a) -> Decoder a
Consume forall a b. (a -> b) -> a -> b
$ \ByteString
chunk -> t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go t
remaining Maybe Int
blockCap forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Decoder (Maybe Event)
k forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
chunk
      G.Fail ByteString
leftover ByteOffset
_ String
err ->
        forall a. ByteString -> String -> Decoder a
Error ByteString
leftover String
err

-- | Decode a header and events
decodeEventLog :: Decoder Event
decodeEventLog :: Decoder Event
decodeEventLog = forall r. (Header -> ByteString -> Decoder r) -> Decoder r
withHeader forall a b. (a -> b) -> a -> b
$ \Header
header ByteString
leftover ->
  Header -> Decoder Event
decodeEvents Header
header forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
leftover

-- | Read a header from a lazy bytestring and return the header and the
-- leftover input for subsequent decoding.
--
-- Note that the input must contain a whole header in one go. If incremental
-- parsing of a header is necessary, use 'decodeHeader' instead.
readHeader :: BL.ByteString -> Either String (Header, BL.ByteString)
readHeader :: ByteString -> Either String (Header, ByteString)
readHeader = forall {b}.
Either (Decoder b) b -> ByteString -> Either String (b, ByteString)
go forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Decoder Header
decodeHeader
  where
    go :: Either (Decoder b) b -> ByteString -> Either String (b, ByteString)
go Either (Decoder b) b
r ByteString
bytes = case Either (Decoder b) b
r of
      Left Decoder b
decoder -> case Decoder b
decoder of
        Produce b
header Decoder b
decoder' -> case Decoder b
decoder' of
          Done ByteString
leftover -> forall a b. b -> Either a b
Right (b
header, ByteString -> ByteString -> ByteString
BL.Chunk ByteString
leftover ByteString
bytes)
          Decoder b
_ -> forall a b. a -> Either a b
Left String
"readHeader: unexpected decoder"
        Consume ByteString -> Decoder b
k -> case ByteString
bytes of
          ByteString
BL.Empty -> forall a b. a -> Either a b
Left String
"readHeader: not enough bytes"
          BL.Chunk ByteString
chunk ByteString
chunks -> Either (Decoder b) b -> ByteString -> Either String (b, ByteString)
go (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$! ByteString -> Decoder b
k ByteString
chunk) ByteString
chunks
        Done ByteString
_ -> forall a b. a -> Either a b
Left String
"readHeader: unexpected termination"
        Error ByteString
_ String
err -> forall a b. a -> Either a b
Left String
err
      Right b
header -> forall a b. b -> Either a b
Right (b
header, ByteString
bytes)


-- | Read events from a lazy bytestring. It returns an error message if it
-- encounters an error while decoding the header.
--
-- Note that it doesn't fail if it consumes all input in the middle of decoding
-- of an event.
readEvents :: Header -> BL.ByteString -> ([Event], Maybe String)
readEvents :: Header -> ByteString -> ([Event], Maybe String)
readEvents Header
header = forall {a} {b} {a} {b}.
([Either a b], [Either a b]) -> ([b], Maybe a)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
break forall a b. Either a b -> Bool
isLeft forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> ByteString -> [Either String Event]
readEvents' Header
header
  where
    f :: ([Either a b], [Either a b]) -> ([b], Maybe a)
f ([Either a b]
rs, [Either a b]
ls) = (forall a b. [Either a b] -> [b]
rights [Either a b]
rs, forall a. [a] -> Maybe a
listToMaybe (forall a b. [Either a b] -> [a]
lefts [Either a b]
ls))
#if !MIN_VERSION_base(4, 7, 0)
    isLeft (Left _) = True
    isLeft _ = False
#endif

-- | Read events from a lazy bytestring. It returns an error message if it
-- encounters an error while decoding the header.
--
-- Note that it doesn't fail if it consumes all input in the middle of decoding
-- of an event.
readEvents' :: Header -> BL.ByteString -> [Either String Event]
readEvents' :: Header -> ByteString -> [Either String Event]
readEvents' Header
header = Decoder Event -> ByteString -> [Either String Event]
go (Header -> Decoder Event
decodeEvents Header
header)
  where
    go :: Decoder Event -> BL.ByteString -> [Either String Event]
    go :: Decoder Event -> ByteString -> [Either String Event]
go Decoder Event
decoder ByteString
bytes = case Decoder Event
decoder of
      Produce Event
event Decoder Event
decoder' -> forall a b. b -> Either a b
Right Event
event forall a. a -> [a] -> [a]
: Decoder Event -> ByteString -> [Either String Event]
go Decoder Event
decoder' ByteString
bytes
      Consume ByteString -> Decoder Event
k -> case ByteString
bytes of
        ByteString
BL.Empty -> []
        BL.Chunk ByteString
chunk ByteString
chunks -> Decoder Event -> ByteString -> [Either String Event]
go (ByteString -> Decoder Event
k ByteString
chunk) ByteString
chunks
      Done {} -> []
      Error ByteString
_ String
err -> [forall a b. a -> Either a b
Left String
err]

-- | Read an entire event log from a lazy bytestring. It returns an error message if it
-- encounters an error while decoding.
--
-- Note that it doesn't fail if it consumes all input in the middle of decoding
-- of an event.
readEventLog :: BL.ByteString -> Either String (EventLog, Maybe String)
readEventLog :: ByteString -> Either String (EventLog, Maybe String)
readEventLog ByteString
bytes = do
  (Header
header, ByteString
bytes') <- ByteString -> Either String (Header, ByteString)
readHeader ByteString
bytes
  case Header -> ByteString -> ([Event], Maybe String)
readEvents Header
header ByteString
bytes' of
    ([Event]
events, Maybe String
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> Data -> EventLog
EventLog Header
header ([Event] -> Data
Data [Event]
events), Maybe String
err)

-- | Read an entire event log from a lazy bytestring. It returns an error message if it
-- encounters an error while decoding.
--
-- This will raise an error if a malformed event is encountered during decoding.
readEventLogOrFail :: BL.ByteString -> Either String EventLog
readEventLogOrFail :: ByteString -> Either String EventLog
readEventLogOrFail ByteString
bytes = do
    (Header
header, ByteString
bs') <- ByteString -> Either String (Header, ByteString)
readHeader ByteString
bytes
    let events :: [Event]
events = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Either String Event -> Event
idOrThrowErr [Int
1..] (Header -> ByteString -> [Either String Event]
readEvents' Header
header ByteString
bs')
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Header -> Data -> EventLog
EventLog Header
header ([Event] -> Data
Data [Event]
events)
  where
    idOrThrowErr :: Int -> Either String Event -> Event
    idOrThrowErr :: Int -> Either String Event -> Event
idOrThrowErr Int
i (Left String
err) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"readEventLogOrFail: error deserialising event " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
err
    idOrThrowErr Int
_ (Right Event
ev) = Event
ev

-- | Makes a decoder with all the required parsers when given a Header
mkEventDecoder :: Header -> G.Decoder (Maybe Event)
mkEventDecoder :: Header -> Decoder (Maybe Event)
mkEventDecoder Header
header = forall a. Get a -> Decoder a
G.runGetIncremental forall a b. (a -> b) -> a -> b
$ EventParsers -> Get (Maybe Event)
getEvent EventParsers
parsers
  where
    imap :: IntMap EventType
imap = forall a. [(Int, a)] -> IntMap a
IM.fromList [(forall a b. (Integral a, Num b) => a -> b
fromIntegral (EventType -> EventTypeNum
num EventType
t), EventType
t) | EventType
t <- Header -> [EventType]
eventTypes Header
header]

    event_parsers :: [EventParser EventInfo]
event_parsers = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [EventParser EventInfo]
standardParsers
        , EventTypeNum -> [EventParser EventInfo]
parRTSParsers EventTypeNum
sz_tid
        , [EventParser EventInfo]
mercuryParsers
        , [EventParser EventInfo]
perfParsers
        , [EventParser EventInfo]
heapProfParsers
        , [EventParser EventInfo]
timeProfParsers
        , [EventParser EventInfo]
binaryEventParsers
        , [EventParser EventInfo]
tickyParsers
        ]
    parsers :: EventParsers
parsers = Array Int (Get EventInfo) -> EventParsers
EventParsers forall a b. (a -> b) -> a -> b
$ IntMap EventType
-> [EventParser EventInfo] -> Array Int (Get EventInfo)
mkEventTypeParsers IntMap EventType
imap [EventParser EventInfo]
event_parsers