    {-# 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' -> a -> Decoder a -> Decoder a
    forall a. a -> Decoder a -> Decoder a
    Produce a
    a (Decoder a -> Decoder a) -> Decoder a -> Decoder a
    forall a b. (a -> b) -> a -> b
    $ Decoder a
    decoder' Decoder a -> ByteString -> Decoder a
    forall a. Decoder a -> ByteString -> Decoder a
    `pushChunk` ByteString
    chunk
      Done ByteString
    leftover -> ByteString -> Decoder a
    forall a. ByteString -> Decoder a
    Done (ByteString -> Decoder a) -> ByteString -> Decoder a
    forall a b. (a -> b) -> a -> b
    $ ByteString
    leftover ByteString -> ByteString -> ByteString
    `B.append` ByteString
    chunk
      Error ByteString
    leftover String
    err -> ByteString -> String -> Decoder a
    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 (Decoder Header -> Decoder r) -> Decoder Header -> Decoder r
    forall a b. (a -> b) -> a -> b
    $ Get Header -> Decoder Header
    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 -> (ByteString -> Decoder r) -> Decoder r
    forall a. (ByteString -> Decoder a) -> Decoder a
    Consume ((ByteString -> Decoder r) -> Decoder r)
    -> (ByteString -> Decoder r) -> Decoder r
    forall a b. (a -> b) -> a -> b
    $ \ByteString
    chunk -> Decoder Header -> Decoder r
    go (Decoder Header -> Decoder r) -> Decoder Header -> Decoder r
    forall a b. (a -> b) -> a -> b
    $ Maybe ByteString -> Decoder Header
    k (Maybe ByteString -> Decoder Header)
    -> Maybe ByteString -> Decoder Header
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just ByteString
    chunk
          G.Fail ByteString
    leftover ByteOffset
    _ String
    err -> ByteString -> String -> Decoder r
    forall a. ByteString -> String -> Decoder a
    Error ByteString
    leftover String
    err

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

    -- | Decode events
    decodeEvents :: Header -> Decoder Event
    decodeEvents :: Header -> Decoder Event
    decodeEvents Header
    header = Int -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
    forall {t}.
    (Ord t, Num t) =>
    t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
    go (Int
    0 :: Int) Maybe 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 Decoder (Maybe Event) -> ByteString -> Decoder (Maybe Event)
    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
    end_time :: Timestamp
    cap :: Int
    block_size :: BlockSize
    block_size :: EventInfo -> BlockSize
    cap :: EventInfo -> Int
    end_time :: EventInfo -> Timestamp
    ..} ->
                  t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
    go (BlockSize -> t
    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 t -> t -> t
    forall a. Num a => a -> a -> a
    - ByteOffset -> t
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral ByteOffset
    consumed
                    !blockCap' :: Maybe Int
    blockCap' = if t
    remaining' t -> t -> Bool
    forall a. Ord a => a -> a -> Bool
    > t
    0 then Maybe Int
    blockCap else Maybe Int
    forall a. Maybe a
    Nothing
                    !event' :: Event
    event' = Event
    event { evCap = blockCap }
                  Event -> Decoder Event -> Decoder Event
    forall a. a -> Decoder a -> Decoder a
    Produce Event
    event' (Decoder Event -> Decoder Event) -> Decoder Event -> Decoder 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 ->
            (ByteString -> Decoder Event) -> Decoder Event
    forall a. (ByteString -> Decoder a) -> Decoder a
    Consume ((ByteString -> Decoder Event) -> Decoder Event)
    -> (ByteString -> Decoder Event) -> Decoder Event
    forall a b. (a -> b) -> a -> b
    $ \ByteString
    chunk -> t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
    go t
    remaining Maybe Int
    blockCap (Decoder (Maybe Event) -> Decoder Event)
    -> Decoder (Maybe Event) -> Decoder Event
    forall a b. (a -> b) -> a -> b
    $ Maybe ByteString -> Decoder (Maybe Event)
    k (Maybe ByteString -> Decoder (Maybe Event))
    -> Maybe ByteString -> Decoder (Maybe Event)
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just ByteString
    chunk
          G.Fail ByteString
    leftover ByteOffset
    _ String
    err ->
            ByteString -> String -> Decoder Event
    forall a. ByteString -> String -> Decoder a
    Error ByteString
    leftover String
    err

    -- | Decode a header and events
    decodeEventLog :: Decoder Event
    decodeEventLog :: Decoder Event
    decodeEventLog = (Header -> ByteString -> Decoder Event) -> Decoder Event
    forall r. (Header -> ByteString -> Decoder r) -> Decoder r
    withHeader ((Header -> ByteString -> Decoder Event) -> Decoder Event)
    -> (Header -> ByteString -> Decoder Event) -> Decoder Event
    forall a b. (a -> b) -> a -> b
    $ \Header
    header ByteString
    leftover ->
      Header -> Decoder Event
    decodeEvents Header
    header Decoder Event -> ByteString -> Decoder Event
    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 = Either (Decoder Header) Header
    -> ByteString -> Either String (Header, ByteString)
    forall {b}.
    Either (Decoder b) b -> ByteString -> Either String (b, ByteString)
    go (Either (Decoder Header) Header
     -> ByteString -> Either String (Header, ByteString))
    -> Either (Decoder Header) Header
    -> ByteString
    -> Either String (Header, ByteString)
    forall a b. (a -> b) -> a -> b
    $ Decoder Header -> Either (Decoder Header) Header
    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 -> (b, ByteString) -> Either String (b, ByteString)
    forall a b. b -> Either a b
    Right (b
    header, ByteString -> ByteString -> ByteString
    BL.Chunk ByteString
    leftover ByteString
    bytes)
              Decoder b
    _ -> String -> Either String (b, ByteString)
    forall a b. a -> Either a b
    Left String
    "readHeader: unexpected decoder"
            Consume ByteString -> Decoder b
    k -> case ByteString
    bytes of
              ByteString
    BL.Empty -> String -> Either String (b, ByteString)
    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 (Decoder b -> Either (Decoder b) b
    forall a b. a -> Either a b
    Left (Decoder b -> Either (Decoder b) b)
    -> Decoder b -> Either (Decoder b) b
    forall a b. (a -> b) -> a -> b
    $! ByteString -> Decoder b
    k ByteString
    chunk) ByteString
    chunks
            Done ByteString
    _ -> String -> Either String (b, ByteString)
    forall a b. a -> Either a b
    Left String
    "readHeader: unexpected termination"
            Error ByteString
    _ String
    err -> String -> Either String (b, ByteString)
    forall a b. a -> Either a b
    Left String
    err
          Right b
    header -> (b, ByteString) -> Either String (b, ByteString)
    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 = ([Either String Event], [Either String Event])
    -> ([Event], Maybe String)
    forall {a} {b} {a} {b}.
    ([Either a b], [Either a b]) -> ([b], Maybe a)
    f (([Either String Event], [Either String Event])
     -> ([Event], Maybe String))
    -> (ByteString -> ([Either String Event], [Either String Event]))
    -> ByteString
    -> ([Event], Maybe String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Either String Event -> Bool)
    -> [Either String Event]
    -> ([Either String Event], [Either String Event])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break Either String Event -> Bool
    forall a b. Either a b -> Bool
    isLeft ([Either String Event]
     -> ([Either String Event], [Either String Event]))
    -> (ByteString -> [Either String Event])
    -> ByteString
    -> ([Either String Event], [Either String Event])
    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) = ([Either a b] -> [b]
    forall a b. [Either a b] -> [b]
    rights [Either a b]
    rs, [a] -> Maybe a
    forall a. [a] -> Maybe a
    listToMaybe ([Either a b] -> [a]
    forall a b. [Either a b] -> [a]
    lefts [Either a b]
    ls))

    -- | 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' -> Event -> Either String Event
    forall a b. b -> Either a b
    Right Event
    event Either String Event
    -> [Either String Event] -> [Either String 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 -> [String -> Either String Event
    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, bytes') <- ByteString -> Either String (Header, ByteString)
    readHeader ByteString
    bytes
      case readEvents header bytes' of
        ([Event]
    events, Maybe String
    err) -> (EventLog, Maybe String) -> Either String (EventLog, Maybe String)
    forall a. a -> Either String a
    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, bs') <- ByteString -> Either String (Header, ByteString)
    readHeader ByteString
    bytes
        let events = (Int -> Either String Event -> Event)
    -> [Int] -> [Either String Event] -> [Event]
    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')
        return $ EventLog header (Data events)
      where
        idOrThrowErr :: Int -> Either String Event -> Event
        idOrThrowErr :: Int -> Either String Event -> Event
    idOrThrowErr Int
    i (Left String
    err) = String -> Event
    forall a. HasCallStack => String -> a
    error (String -> Event) -> String -> Event
    forall a b. (a -> b) -> a -> b
    $ String
    "readEventLogOrFail: error deserialising event " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    i String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> String -> 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 = Get (Maybe Event) -> Decoder (Maybe Event)
    forall a. Get a -> Decoder a
    G.runGetIncremental (Get (Maybe Event) -> Decoder (Maybe Event))
    -> Get (Maybe Event) -> Decoder (Maybe Event)
    forall a b. (a -> b) -> a -> b
    $ EventParsers -> Get (Maybe Event)
    getEvent EventParsers
    parsers
      where
        imap :: IntMap EventType
    imap = [(Int, EventType)] -> IntMap EventType
    forall a. [(Int, a)] -> IntMap a
    IM.fromList [(EventTypeNum -> Int
    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 = [[EventParser EventInfo]] -> [EventParser EventInfo]
    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 (Array Int (Get EventInfo) -> EventParsers)
    -> Array Int (Get EventInfo) -> EventParsers
    forall a b. (a -> b) -> a -> b
    $ IntMap EventType
    -> [EventParser EventInfo] -> Array Int (Get EventInfo)
    mkEventTypeParsers IntMap EventType
    imap [EventParser EventInfo]
    event_parsers