ghc-stack-profiler-core 0.4.0.0 → 0.5.0.0

raw patch · 15 files changed

+1597/−1095 lines, 15 filesdep +tasty-hunitdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• ghc-stack-profiler-core.cabal +21/−11
• src/GHC/Stack/Profiler/Core.hs +94/−0
• src/GHC/Stack/Profiler/Core/Eventlog.hs +0/−298
• src/GHC/Stack/Profiler/Core/Internal.hs +53/−0
• src/GHC/Stack/Profiler/Core/Internal/CallStack.hs +37/−0
• src/GHC/Stack/Profiler/Core/Internal/Dehydrate.hs +299/−0
• src/GHC/Stack/Profiler/Core/Internal/Eventlog.hs +598/−0
• src/GHC/Stack/Profiler/Core/Internal/Hydrate.hs +154/−0
• src/GHC/Stack/Profiler/Core/Internal/Util.hs +84/−0
• src/GHC/Stack/Profiler/Core/SourceLocation.hs +0/−13
• src/GHC/Stack/Profiler/Core/SymbolTable.hs +0/−247
• src/GHC/Stack/Profiler/Core/ThreadSample.hs +0/−336
• src/GHC/Stack/Profiler/Core/Util.hs +0/−104
• test/Main.hs +247/−86

@@ -1,5 +1,15 @@ # Revision history for ghc-stack-profiler-core +## 0.5.0.0 -- 2026-09-15++Major revision of the public API.++- Add a `ProtocolVersion` message to detect protocol incompatibility.+- Change the format of `ThreadId` in the protocol to `Word64`.+  This matches the `uint64_t` used by the RTS.+- Change the format of `CapabilityId` in memory to `Word32`.+  This matches the `uint32_t` used by the RTS.+ ## 0.4.0.0 -- 2026-07-14  Major version number changed to match `ghc-stack-profiler-speedscope`.

@@ -1,15 +1,18 @@ cabal-version: 3.8 name: ghc-stack-profiler-core-version: 0.4.0.0+version: 0.5.0.0 license: BSD-3-Clause author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering maintainer: hannes@well-typed.com build-type: Simple-synopsis: Thread sample types and serialisation logic for `ghc-stack-profiler`.+synopsis:+  The eventlog protocol used by ghc-stack-profiler+ description:-  Thread sample types and serialisation logic for `ghc-stack-profiler`.-  Defines the interface and serialisation logic to turn an RTS Callstack into a binary message suitable for the eventlog.+  The eventlog protocol used by @ghc-stack-profiler@. +  For details, see [@ghc-stack-profiler@](https://hackage.haskell.org/package/ghc-stack-profiler).+ extra-doc-files: CHANGELOG.md category: Profiling, Benchmarking, Development tested-with:@@ -28,6 +31,7 @@     LambdaCase     NamedFieldPuns     NoImportQualifiedPost+    PatternSynonyms     ViewPatterns  library@@ -35,14 +39,18 @@     warnings, exts    exposed-modules:-    GHC.Stack.Profiler.Core.Eventlog-    GHC.Stack.Profiler.Core.SourceLocation-    GHC.Stack.Profiler.Core.SymbolTable-    GHC.Stack.Profiler.Core.ThreadSample-    GHC.Stack.Profiler.Core.Util+    GHC.Stack.Profiler.Core+    GHC.Stack.Profiler.Core.Internal +  other-modules:+    GHC.Stack.Profiler.Core.Internal.CallStack+    GHC.Stack.Profiler.Core.Internal.Dehydrate+    GHC.Stack.Profiler.Core.Internal.Eventlog+    GHC.Stack.Profiler.Core.Internal.Hydrate+    GHC.Stack.Profiler.Core.Internal.Util+   build-depends:-    base >=4.17 && <4.23,+    base >=4.17 && <5,     binary >=0.8.9.3 && <0.11,     bytestring >=0.11 && <0.13,     containers >=0.6.8 && <0.9,@@ -54,7 +62,7 @@    default-language: GHC2021 -test-suite ghc-stack-profiler-core-tests+test-suite ghc-stack-profiler-tests   import: warnings, exts   type: exitcode-stdio-1.0   hs-source-dirs: test@@ -65,7 +73,9 @@     bytestring,     ghc-stack-profiler-core,     tasty >=1.5.4 && <1.6,+    tasty-hunit,     tasty-quickcheck >=0.10 && <0.12,+    text >=2 && <2.2,    default-language: GHC2021 

@@ -0,0 +1,94 @@+module GHC.Stack.Profiler.Core (+  -- * Eventlog Protocol Messages+  CallStack (..),+  ThreadId (..),+  CapabilityId (..),+  StackItem (..),+  IpeId (..),+  SourceLocation (..),++  -- * Binary Eventlog Protocol Messages+  Message (..),+  ProtocolVersion (MkProtocolVersion, MyProtocolVersion),+  ProtocolVersionMismatch (..),+  CallStackChunk (..),+  StringDef (..),+  SourceLocationDef (..),+  CallStackFrame (..),+  StringId (..),+  SourceLocationId (..),++  -- * Decode++  -- ** Deserialise+  deserializeEventlogMessage,+  joinCallStackChunks,++  -- ** Hydrate+  hydrateEventlogCallStackMessage,+  BinaryCallStackDecodeError (..),++  -- *** Symbol Table+  SymbolTableReader (..),+  IntMapTable,+  mkIntMapSymbolTableReader,+  emptyIntMapTable,+  insertTextMessage,+  insertSourceLocationMessage,+  MissingKeyError (..),++  -- * Encode++  -- ** Serialise++  -- ** Dehydrate+  dehydrateCallStack,++  -- *** Symbol Table+  SymbolTableWriter (..),+  emptyMapSymbolTableWriter,+  MapTable,+  getKnownStrings,+  getKnownSourceLocations,+) where++import GHC.Stack.Profiler.Core.Internal.CallStack (+  CallStack (..),+  SourceLocation (..),+  StackItem (..),+ )+import GHC.Stack.Profiler.Core.Internal.Dehydrate (+  MapTable,+  SymbolTableWriter (..),+  dehydrateCallStack,+  emptyMapSymbolTableWriter,+  getKnownSourceLocations,+  getKnownStrings,+ )+import GHC.Stack.Profiler.Core.Internal.Eventlog (+  CallStackChunk (..),+  CallStackFrame (..),+  CapabilityId (..),+  IpeId (..),+  Message (..),+  ProtocolVersion (MkProtocolVersion, MyProtocolVersion),+  ProtocolVersionMismatch (..),+  SourceLocationDef (..),+  SourceLocationId (..),+  StringDef (..),+  StringId (..),+  ThreadId (..),+  deserializeEventlogMessage,+  joinCallStackChunks,+ )+import GHC.Stack.Profiler.Core.Internal.Hydrate (+  BinaryCallStackDecodeError (..),+  IntMapTable,+  MissingKeyError (..),+  SymbolTableReader (..),+  emptyIntMapTable,+  hydrateEventlogCallStackMessage,+  insertSourceLocationMessage,+  insertTextMessage,+  mkIntMapSymbolTableReader,+ )

@@ -1,298 +0,0 @@-module GHC.Stack.Profiler.Core.Eventlog (-  -- * Eventlgog Message types-  BinaryEventlogMessage (..),-  BinaryCallStackMessage (..),-  BinaryStringMessage (..),-  BinarySourceLocationMessage (..),-  BinaryStackItem (..),-  CapabilityId (..),-  StringId (..),-  incrementStringLocationId,-  SourceLocationId (..),-  incrementSourceLocationId,-  IpeId (..),--  -- * Eventlog constants-  callStackFinalMessageTag,-  callStackPartialMessageTag,-  callStackStringMessageTag,-  callStackSourceLocationMessageTag,-  callStackMessageTags,-  callStackSizeLimit,-  callStackSizeLimit_,-  byteSizeOf,-  eventlogBufferSize,-  stringLengthLimit,-) where--import Control.Monad (replicateM)-import Data.Binary-import Data.Coerce (coerce)-import qualified Data.List as List-import Data.Text (Text)-import GHC.Generics--import GHC.Stack.Profiler.Core.Util---- ------------------------------------------------------------------------------- Eventlog Messages--- -------------------------------------------------------------------------------- | Efficient serialisation format of the GHC RTS callstack.------ Message format:------ @--- MESSAGE---  := FF CA (stack: STACK>---   | FF CB (prefix: STACK>---   | FF CC (stringId: 'Word64') (string: CStringLen)---   | FF CD (srcLocId: 'Word64') (row: 'Word32') (col: 'Word32') (functionId: 'Word64') (filename: 'Word64')------ STACK---  := (capability: 'Word32') (threadId: 'Word32') (length: 'Int16') (ENTRY)+---   # check that length < (2^16-8) / 9------ ENTRY---  := 01 (ipe: 'Word64')---   | 02 (stringId: 'Word64')---   | 03 (stringId: 'Word64') (srcLocId: 'Word64')------ CStringLen---   := (length: 'Int16') (Char)+---    # check that length < 2^16-8--- @-data BinaryEventlogMessage-  = CallStackFinal !BinaryCallStackMessage-  | CallStackChunk !BinaryCallStackMessage-  | StringDef !BinaryStringMessage-  | SourceLocationDef !BinarySourceLocationMessage-  deriving (Eq, Ord, Show, Read, Generic)--data BinaryCallStackMessage = MkBinaryCallStackMessage-  { binaryCallThreadId :: !Word64-  , binaryCallCapabilityId :: !CapabilityId-  , binaryCallStack :: ![BinaryStackItem]-  }-  deriving (Eq, Ord, Show, Read, Generic)--data BinaryStringMessage = MkBinaryStringMessage-  { binaryStringMessageId :: !StringId-  , binaryStringMessage :: !Text-  }-  deriving (Eq, Ord, Show, Read, Generic)--data BinarySourceLocationMessage = MkBinarySourceLocationMessage-  { binarySourceLocationMessageId :: {-# UNPACK #-} !SourceLocationId-  , binarySourceLocationRow :: {-# UNPACK #-} !Word32-  , binarySourceLocationColumn :: {-# UNPACK #-} !Word32-  , binarySourceLocationFilename :: {-# UNPACK #-} !StringId-  }-  deriving (Eq, Ord, Show, Read, Generic)--data BinaryStackItem-  = BinaryIpe {-# UNPACK #-} !IpeId-  | BinaryMessage-      {-# UNPACK #-} !StringId-      {-# UNPACK #-} !(Maybe SourceLocationId)-  deriving (Eq, Ord, Show, Read, Generic)---- | Simple newtype for the ID of a capability.-newtype CapabilityId-  = MkCapabilityId-  { getCapabilityId :: Word64-  }-  deriving (Show, Eq, Ord, Read, Generic)--newtype StringId = MkStringId-  { getStringId :: Word64-  }-  deriving (Eq, Ord, Show, Read, Generic)--incrementStringLocationId :: StringId -> StringId-incrementStringLocationId (MkStringId sid) = MkStringId (sid + 1)--newtype SourceLocationId = MkSourceLocationId-  { getSourceLocationId :: Word64-  }-  deriving (Eq, Ord, Show, Read, Generic)--incrementSourceLocationId :: SourceLocationId -> SourceLocationId-incrementSourceLocationId (MkSourceLocationId slId) = MkSourceLocationId (slId + 1)--newtype IpeId = MkIpeId-  { getIpeId :: Word64-  }-  deriving (Eq, Ord, Show, Read, Generic)---- ------------------------------------------------------------------------------- Binary instances--- ------------------------------------------------------------------------------callStackFinalMessageTag :: Word16-callStackFinalMessageTag = 0xFFCA--callStackPartialMessageTag :: Word16-callStackPartialMessageTag = 0xFFCB--callStackStringMessageTag :: Word16-callStackStringMessageTag = 0xFFCC--callStackSourceLocationMessageTag :: Word16-callStackSourceLocationMessageTag = 0xFFCD--callStackMessageTags :: [Word16]-callStackMessageTags =-  [ callStackFinalMessageTag-  , callStackPartialMessageTag-  , callStackStringMessageTag-  , callStackSourceLocationMessageTag-  ]---- | Each message in the eventlog can be at most 2^16 bytes-eventlogBufferSize :: Word64-eventlogBufferSize = (2 :: Word64) ^ (16 :: Word64)---- | Size limit of strings that can occur in the eventlog.-stringLengthLimit :: Word16-stringLengthLimit =-  word64ToWord16 $-    eventlogBufferSize-      - 2 {- 0xFFCC -}-      - 8 {- Word64 of 'StringId' -}-      - 2 {- Word16 for the length of the string to serialise -}---- | The limit of stack items that can go in one eventlog message in bytes.-callStackSizeLimit :: Word16-callStackSizeLimit =-  callStackSizeLimit_ eventlogBufferSize---- | The limit of stack items that can go in one eventlog message in bytes--- with configurable the eventlog message size.-callStackSizeLimit_ :: Word64 -> Word16-callStackSizeLimit_ eventlogSize =-  word64ToWord16-    ( eventlogSize-        - 2 {- 0xFFCA or 0xFFCB -}-        - 4 {- Word32 of 'CapabilityId' -}-        - 4 {- Word32 of 'ThreadId' -}-        - 2 {- Word16 for the length of stack entry -}-    )---- | Size in bytes of the given 'BinaryStackItem'-byteSizeOf :: BinaryStackItem -> Word16-byteSizeOf = \case-  BinaryIpe{} -> 1 + 8 {- 0x1 + Word64 of 'IpeId' -}-  BinaryMessage _ Nothing -> 1 + 8 {- 0x2 + Word64 of 'StringId' -}-  BinaryMessage _ (Just _) -> 1 + 8 + 8 {- 0x3 + Word64 of 'StringId' + Word64 of 'SourceLocationId' -}--instance Binary BinaryEventlogMessage where-  put = \case-    CallStackFinal msg ->-      putWithTag callStackFinalMessageTag msg-    CallStackChunk msg ->-      putWithTag callStackPartialMessageTag msg-    StringDef msg ->-      putWithTag callStackStringMessageTag msg-    SourceLocationDef msg ->-      putWithTag callStackSourceLocationMessageTag msg-   where-    putWithTag t msg = putWord16 t >> put msg--  get = do-    tag <- getWord16-    case tag of-      _-        | tag == callStackFinalMessageTag ->-            CallStackFinal <$> get-        | tag == callStackPartialMessageTag ->-            CallStackChunk <$> get-        | tag == callStackStringMessageTag ->-            StringDef <$> get-        | tag == callStackSourceLocationMessageTag ->-            SourceLocationDef <$> get-        | otherwise ->-            fail $-              "BinaryEventlogMessage.get: Unknown tag expected one of "-                ++ tags-                ++ " but got "-                ++ showAsHex tag-   where-    tags = List.intercalate ", " $ map showAsHex callStackMessageTags--instance Binary BinaryCallStackMessage where-  put msg = do-    putWord32 $ word64ToWord32 $ getCapabilityId $ binaryCallCapabilityId msg-    putWord32 $ word64ToWord32 $ binaryCallThreadId msg-    let-      items = binaryCallStack msg-    putWord16 $ intToWord16 $ length items-    mapM_ put items--  get = do-    capId <- getWord32-    tid <- getWord32-    len <- getWord16-    items <- replicateM (word16ToInt len) get-    pure-      MkBinaryCallStackMessage-        { binaryCallThreadId = word32ToWord64 tid-        , binaryCallCapabilityId = MkCapabilityId $ word32ToWord64 capId-        , binaryCallStack = items-        }--instance Binary BinaryStackItem where-  put = \case-    BinaryIpe ipeId -> do-      putWord8 0x1-      put ipeId-    BinaryMessage sid Nothing -> do-      putWord8 0x2-      put sid-    BinaryMessage sid (Just lid) -> do-      putWord8 0x3-      put sid-      put lid--  get = do-    getWord8 >>= \case-      0x1 -> BinaryIpe <$> get-      0x2 -> BinaryMessage <$> get <*> pure Nothing-      0x3 -> BinaryMessage <$> get <*> (Just <$> get)-      n -> fail $ "StackItem: Unexpected tag byte encounter: " <> show n--instance Binary BinarySourceLocationMessage where-  put msg = do-    put $ binarySourceLocationMessageId msg-    putWord32 (binarySourceLocationRow msg)-    putWord32 (binarySourceLocationColumn msg)-    put (binarySourceLocationFilename msg)--  get = do-    MkBinarySourceLocationMessage-      <$> get-      <*> getWord32-      <*> getWord32-      <*> get--instance Binary BinaryStringMessage where-  put msg = do-    put $ binaryStringMessageId msg-    putTextWord16 stringLengthLimit (binaryStringMessage msg)--  get = do-    MkBinaryStringMessage-      <$> get-      <*> getTextWord16--instance Binary SourceLocationId where-  put = putWord64 . coerce-  get = coerce getWord64--instance Binary StringId where-  put = putWord64 . coerce-  get = coerce getWord64--instance Binary IpeId where-  put = putWord64 . coerce-  get = coerce getWord64

@@ -0,0 +1,53 @@+{-# OPTIONS_HADDOCK hide #-}++module GHC.Stack.Profiler.Core.Internal (+  CallStackFrameTag (..),+  MessageTag (..),+  ShortText (..),+  callStackFrameMaxSize,+  callStackFrameSize,+  callStackFrameTagSize,+  callStackMaxLen,+  callStackMaxLen',+  capabilityIdSize,+  ipeIdSize,+  messageMaxSize,+  messageMinSize,+  messageTagSize,+  sourceLocationDefSize,+  sourceLocationIdSize,+  stringDefBodyMaxSize,+  stringIdSize,+  threadIdSize,+  toShortText,+  truncateTextToByteLimit,+  chunkCallStack,+  chunkCallStack_,+) where++import GHC.Stack.Profiler.Core.Internal.Dehydrate (+  chunkCallStack,+  chunkCallStack_,+ )+import GHC.Stack.Profiler.Core.Internal.Eventlog (+  CallStackFrameTag (..),+  MessageTag (..),+  ShortText (..),+  callStackFrameMaxSize,+  callStackFrameSize,+  callStackFrameTagSize,+  callStackMaxLen,+  callStackMaxLen',+  capabilityIdSize,+  ipeIdSize,+  messageMaxSize,+  messageMinSize,+  messageTagSize,+  sourceLocationDefSize,+  sourceLocationIdSize,+  stringDefBodyMaxSize,+  stringIdSize,+  threadIdSize,+  toShortText,+  truncateTextToByteLimit,+ )

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module GHC.Stack.Profiler.Core.Internal.CallStack (+  CallStack (..),+  StackItem (..),+  SourceLocation (..),+) where++import Data.Text (Text)+import Data.Word (Word32)+import GHC.Generics+import GHC.Stack.Profiler.Core.Internal.Eventlog++-- ----------------------------------------------------------------------------+-- Decoded RTS CallStack+-- ----------------------------------------------------------------------------++-- | A decoded rts callstack that can be serialised to the EventLog.+data CallStack = MkCallStack+  { callThreadId :: !ThreadId+  , callCapabilityId :: !CapabilityId+  , callStack :: [StackItem]+  }+  deriving (Eq, Ord, Show, Generic)++data StackItem+  = IpeId !IpeId+  | UserAnnotation !String !(Maybe SourceLocation)+  deriving (Eq, Ord, Show, Generic)++-- | A Haskell source location.+data SourceLocation = MkSourceLocation+  { line :: !Word32+  , column :: !Word32+  , fileName :: !Text+  }+  deriving (Eq, Ord, Show, Generic)

@@ -0,0 +1,299 @@+module GHC.Stack.Profiler.Core.Internal.Dehydrate where++import Control.Monad (when)+import Control.Monad.Trans.State.Strict (State, runState)+import qualified Control.Monad.Trans.State.Strict as State+import qualified Data.List as List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Tuple as Tuple+import GHC.Generics+import GHC.Stack.Profiler.Core.Internal.CallStack+import GHC.Stack.Profiler.Core.Internal.Eventlog++-- | Generic implementation to turn 'CallStack' into '[Message]'.+--+-- Replaces already encountered text or source location information with unique ids.+-- If new text or source location messages are encountered, they are inserted into+-- the 'SymbolTableWriter'.+--+-- All new string values and source location messages are before 'CallStackChunk' and+-- 'CallStackFinal' messages.+-- For the result list @r :: ['Message']@, the following holds:+--+-- * 'StringDef' messages are the first elements in @r@. There might not be any.+-- * 'SourceLocationDef' are after 'StringDef' messages and before any 'CallStackChunk' or+--    'CallStackFinal' messages. There might not be any such messages.+-- * Then 'CallStackChunk' follow if there are any.+-- * The last message is always a 'CallStackFinal' message and it occurs exactly once in @r@.+dehydrateCallStack ::+  forall table.+  SymbolTableWriter table ->+  CallStack ->+  ([Message], SymbolTableWriter table)+dehydrateCallStack msgTbl0 msg =+  let+    (stackItems, finalState) =+      runWithEncodingState+        (newEncodingState msgTbl0)+        (mapM go (callStack msg))++    stringDefs =+      map StringDef $ stringMessages finalState++    sourceLocDefs =+      map SourceLocationDef $ sourceLocMessages finalState++    stackMsgChunks =+      chunkCallStack+        MkCallStackChunk+          { callStackChunkThreadId = callThreadId msg+          , callStackChunkCapabilityId = callCapabilityId msg+          , callStackChunk = stackItems+          }+  in+    ( stringDefs ++ sourceLocDefs ++ stackMsgChunks+    , symbolTableWriter finalState+    )+ where+  go :: StackItem -> State (EncodingState tbl) CallStackFrame+  go = \case+    IpeId ipeId ->+      pure $ CallStackFrameIpe ipeId+    UserAnnotation s mSrcLoc -> do+      srcLocId <- case mSrcLoc of+        Nothing -> pure Nothing+        Just srcLoc -> Just <$> lookupSourceLocationMessage srcLoc+      CallStackFrameAnn <$> lookupTextMessage (Text.pack s) <*> pure srcLocId++-- | Chunk the 'callStackChunk' of the 'CallStackChunk' by the given 'Int'.+-- If there are no items in 'CallStackChunk', then a singleton list is returned containing+-- the original element.+--+-- Post-condition for the result @r@:+--+-- * all elements in @init r @ are 'CallStackChunk's+-- * the element returned by @last r@ is a 'CallStackFinal' Message.+--+-- The resulting 'CallStackChunk' are in reverse order and so are the chunks themselves.+--+-- This means, for a stack @[1,2,3,4,5,6]@ and an assumed chunk size of 2,+-- we produce @[[6,5],[4,3],[2,1]]@.+chunkCallStack :: CallStackChunk -> [Message]+chunkCallStack = chunkCallStack_ callStackMaxLen++-- | Same as 'chunkCallStack', but allows to set the chunking size in bytes.+chunkCallStack_ :: Int -> CallStackChunk -> [Message]+chunkCallStack_ chunkLimit msg0 =+  let+    items = callStackChunk msg0+    chunked =+      let+        go (!size, curChunk, restChunk) item =+          let+            !bytes = callStackFrameSize item+          in+            if (size + bytes) < chunkLimit+              then (size + bytes, item : curChunk, restChunk)+              else (bytes, [item], curChunk : restChunk)+        (_, lastChunk, initChunk) = List.foldl' go (0, [], []) items+      in+        lastChunk : initChunk+  in+    mkEventlogMessages chunked+ where+  mkCallStack chunk =+    MkCallStackChunk+      { callStackChunkThreadId = callStackChunkThreadId msg0+      , callStackChunkCapabilityId = callStackChunkCapabilityId msg0+      , callStackChunk = chunk+      }++  mkEventlogMessages :: [[CallStackFrame]] -> [Message]+  mkEventlogMessages [] =+    -- If there are no chunks, we simply return the original message+    [ CallStackFinal msg0+    ]+  mkEventlogMessages [chunk] =+    [ CallStackFinal $ mkCallStack chunk+    ]+  mkEventlogMessages (chunk : chunks) =+    CallStackChunk (mkCallStack chunk) : mkEventlogMessages chunks++-- ----------------------------------------------------------------------------+-- Helper types and functions to implement the conversion to the binary+-- representation.+-- ----------------------------------------------------------------------------++data EncodingState tbl = MkEncodingState+  { symbolTableWriter :: !(SymbolTableWriter tbl)+  , stringMessages :: ![StringDef]+  , sourceLocMessages :: ![SourceLocationDef]+  }+  deriving (Generic)++runWithEncodingState :: EncodingState tbl -> State (EncodingState tbl) a -> (a, EncodingState tbl)+runWithEncodingState encodingState encoder =+  runState encoder encodingState++newEncodingState :: SymbolTableWriter tbl -> EncodingState tbl+newEncodingState msgTbl0 =+  MkEncodingState+    { symbolTableWriter = msgTbl0+    , stringMessages = []+    , sourceLocMessages = []+    }++setSymbolTableWriter :: tbl -> State.State (EncodingState tbl) ()+setSymbolTableWriter tbl = State.modify' (\st -> st{symbolTableWriter = (symbolTableWriter st){writerTable = tbl}})++addStringMessage :: StringDef -> State.State (EncodingState tbl) ()+addStringMessage msg = State.modify' (\st -> st{stringMessages = msg : stringMessages st})++addSourceLocationMessage :: SourceLocationDef -> State.State (EncodingState tbl) ()+addSourceLocationMessage msg = State.modify' (\st -> st{sourceLocMessages = msg : sourceLocMessages st})++lookupOrInsertTextMessage :: forall tbl. Text -> State (EncodingState tbl) (StringId, Bool)+lookupOrInsertTextMessage s = do+  tbl <- State.gets symbolTableWriter+  let+    (sid, new, tbl1) = lookupOrInsertText tbl (writerTable tbl) s+  setSymbolTableWriter tbl1+  pure (sid, new)++lookupOrInsertSrcLocMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) (SourceLocationId, Bool)+lookupOrInsertSrcLocMessage s = do+  tbl <- State.gets symbolTableWriter+  let+    (sid, new, tbl1) = lookupOrInsertSourceLocation tbl (writerTable tbl) s+  setSymbolTableWriter tbl1+  pure (sid, new)++lookupTextMessage :: forall tbl. Text -> State (EncodingState tbl) StringId+lookupTextMessage s = do+  (sid, new) <- lookupOrInsertTextMessage s+  when new $+    addStringMessage $+      MkStringDef sid s+  pure sid++lookupSourceLocationMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) SourceLocationId+lookupSourceLocationMessage s = do+  (sid, new) <- lookupOrInsertSrcLocMessage s+  when new $ do+    fileId <- lookupTextMessage $ fileName s+    addSourceLocationMessage $+      MkSourceLocationDef+        { sourceLocationDefId = sid+        , sourceLocationDefRow = line s+        , sourceLocationDefColumn = column s+        , sourceLocationDefFilename = fileId+        }+  pure sid++-- | Implementation agnostic symbol table supposed to be used to deduplicate symbols+-- in 'CallStack'.+--+-- When transforming 'CallStack' to ['Message'] we replace some+-- symbols with identifiers.+-- In particular arbitrary length symbols, such as 'Text's and 'SourceLocation's.+-- As these symbols are discovered while encoding the callstack, the 'SymbolTableWriter'+-- needs to be extended, which is why we thread the 'tbl' parameter through the+-- lookup or insertion operations.+data SymbolTableWriter tbl = MkSymbolTableWriter+  { writerTable :: !tbl+  -- ^ Symbol table for symbols we replace with unique identifiers.+  , lookupOrInsertText :: tbl -> Text -> (StringId, Bool, tbl)+  -- ^ Lookup up the given 'Text' in the 'tbl' Symbol table.+  -- If the 'Text' can't be found, we insert it into the table and generate a+  -- new 'StringId.+  -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise.+  , lookupOrInsertSourceLocation :: tbl -> SourceLocation -> (SourceLocationId, Bool, tbl)+  -- ^ Lookup up the given 'SourceLocation' in the 'tbl' Symbol table.+  -- If the 'SourceLocation' can't be found, we insert it into the table and generate a+  -- new 'SourceLocationId.+  -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise.+  }+  deriving (Generic)++data MapTable = MkMapTable+  { stringTable :: !(Map Text StringId)+  , srcLocTable :: !(Map SourceLocation SourceLocationId)+  , stringUniqueSupply :: {-# UNPACK #-} !StringId+  , srcLocUniqueSupply :: {-# UNPACK #-} !SourceLocationId+  }+  deriving (Show, Eq, Ord, Generic)++{-# INLINEABLE emptyMapSymbolTableWriter #-}+emptyMapSymbolTableWriter :: SymbolTableWriter MapTable+emptyMapSymbolTableWriter =+  MkSymbolTableWriter+    { writerTable =+        MkMapTable+          { stringTable = Map.empty+          , srcLocTable = Map.empty+          , stringUniqueSupply = MkStringId 0+          , srcLocUniqueSupply = MkSourceLocationId 0+          }+    , lookupOrInsertText = alterStringMap+    , lookupOrInsertSourceLocation = alterSrcLocTable+    }+ where+  nextSrcLocUnique tbl =+    ( srcLocUniqueSupply tbl+    , tbl+        { srcLocUniqueSupply =+            nextSourceLocationId $ srcLocUniqueSupply tbl+        }+    )++  nextStringUnique tbl =+    ( stringUniqueSupply tbl+    , tbl+        { stringUniqueSupply =+            nextStringId $ stringUniqueSupply tbl+        }+    )++  updateEntry tbl0 nextKey Nothing =+    let+      (sid, tbl) = nextKey tbl0+    in+      ((sid, True, tbl), Just sid)+  updateEntry tbl _ (Just val) =+    ((val, False, tbl), Just val)++  swapAround set ((sid, new, tbl), hm) =+    (sid, new, set tbl hm)++  alterStringMap = \tbl str ->+    swapAround setStringTable $+      Map.alterF (updateEntry tbl nextStringUnique) str (stringTable tbl)++  alterSrcLocTable = \tbl srcLoc ->+    swapAround setSourceLocationTable $+      Map.alterF (updateEntry tbl nextSrcLocUnique) srcLoc (srcLocTable tbl)++setSourceLocationTable :: MapTable -> Map SourceLocation SourceLocationId -> MapTable+setSourceLocationTable tbl hm =+  tbl+    { srcLocTable = hm+    }++setStringTable :: MapTable -> Map Text StringId -> MapTable+setStringTable tbl hm =+  tbl+    { stringTable = hm+    }++getKnownStrings :: MapTable -> [(StringId, Text)]+{-# INLINEABLE getKnownStrings #-}+getKnownStrings table =+  List.map Tuple.swap $ Map.assocs (stringTable table)++getKnownSourceLocations :: MapTable -> [(SourceLocationId, SourceLocation)]+{-# INLINEABLE getKnownSourceLocations #-}+getKnownSourceLocations table =+  List.map Tuple.swap $ Map.assocs (srcLocTable table)

@@ -0,0 +1,598 @@+{-# LANGUAGE MultiWayIf #-}++module GHC.Stack.Profiler.Core.Internal.Eventlog (+  -- * Eventlog Message types+  Message (..),+  ProtocolVersion (MkProtocolVersion, MyProtocolVersion),+  ProtocolVersionMismatch (..),+  CallStackChunk (..),+  StringDef (..),+  SourceLocationDef (..),+  CallStackFrame (..),+  ThreadId (..),+  CapabilityId (..),+  StringId (..),+  nextStringId,+  SourceLocationId (..),+  nextSourceLocationId,+  IpeId (..),+  deserializeEventlogMessage,+  joinCallStackChunks,++  -- * Low-level API+  MessageTag (..),+  messageTagSize,+  CallStackFrameTag (..),+  ipeIdSize,+  stringIdSize,+  sourceLocationIdSize,+  messageMaxSize,+  messageMinSize,+  stringDefBodyMaxSize,+  sourceLocationDefSize,+  ShortText (..),+  toShortText,+  truncateTextToByteLimit,+  callStackFrameTagSize,+  callStackMaxLen,+  callStackMaxLen',+  callStackFrameSize,+  callStackFrameMaxSize,+  capabilityIdSize,+  threadIdSize,+) where++import Control.Exception (Exception (..), assert, throw)+import Control.Monad (replicateM, when)+import Data.Binary+import Data.Binary.Get (getByteString, runGetOrFail)+import Data.Binary.Put (putByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Coerce (coerce)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Foreign as TF+import GHC.Generics+import GHC.Stack.Profiler.Core.Internal.Util+import Text.Printf (printf)++-- ----------------------------------------------------------------------------+-- Eventlog Messages+-- ----------------------------------------------------------------------------++-- | Efficient serialisation format of the GHC RTS callstack.+--+-- Message format:+--+-- @+-- 'Message'+--  := FF CA (stackFinal: 'CallStackChunk')+--   | FF CB (stackChunk: 'CallStackChunk')+--   | FF CC (stringDef: 'StringDef')+--   | FF CD (sourceLocationDef: 'SourceLocationDef')+--+-- 'CallStackChunk'+--  := (capabilityId: 'Word32') (threadId: 'Word32') (callStackLen: 'Word16') (callStack: 'CallStackFrame'{callStackLen})+--  -- NOTE: callStackLen must be smaller than (2^16 - 8) / 9+--+-- 'CallStackFrame'+--  := 01 (ipe: 'Word64')+--   | 02 (stringId: 'Word64')+--   | 03 (stringId: 'Word64') (sourceLocationId: 'Word64')+--+-- 'StringDef'+--  := (stringId: 'Word64') (stringLen: 'Word16') (string: 'Char'{stringLen})+--  -- NOTE: stringLen must be smaller than 2^16 - 8+--+-- 'SourceLocationDef'+--  := (sourceLocationId: 'Word64') (row: 'Word32') (column: 'Word32') (functionId: 'Word64') (filename: 'Word64')+-- @+data Message+  = -- | The version of the protocol.+    ProtocolVersion !ProtocolVersion+  | -- | A chunk of the call-stack, indicated by the prefix @FF CA@.+    --+    --   This variant indicates that no further 'CallStackChunk' or 'CallStackFinal' will follow.+    CallStackFinal !CallStackChunk+  | -- | A chunk of the call-stack, indicated by the prefix @FF CB@.+    --+    --   This variant indicates that another 'CallStackChunk' or 'CallStackFinal' will follow.+    CallStackChunk !CallStackChunk+  | -- | A string definition, indicated by the prefix @FF CC@.+    --+    --   This messages associates the string ID @stringId@ with the string+    --   @strLen@, for future use in call-stack messages and source location+    --   definitions.+    StringDef !StringDef+  | -- | A source location definition, indicated by the prefix @FF CD@.+    --+    --   This message associates the source location ID @srcLocId@ with the+    --   source location specified by @row@, @col@, @functionId@, and+    --   @filename@, for future use in call-stack messages.+    SourceLocationDef !SourceLocationDef+  deriving (Eq, Ord, Show, Read, Generic)++-- | The version of the protocol implemented by the `Message` type.+newtype ProtocolVersion+  = MkProtocolVersion {getProtocolVersion :: Word8}+  deriving (Eq, Ord, Show, Read, Generic)+  deriving newtype (Binary)++-- | The version of the protocol implemented by this package.+--+--   __Note:__ This should always match the super-major version number of the+--             @ghc-stack-profiler-core@ package. If the package version is+--             @A.B.C.D@, the protocol version is @A@.+pattern MyProtocolVersion :: ProtocolVersion+pattern MyProtocolVersion = MkProtocolVersion 0++data ProtocolVersionMismatch+  = MkProtocolVersionMismatch+  { expectProtocolVersion :: !ProtocolVersion+  , actualProtocolVersion :: !ProtocolVersion+  }+  deriving (Eq, Ord, Show, Read, Generic)++instance Exception ProtocolVersionMismatch where+  displayException :: ProtocolVersionMismatch -> String+  displayException e =+    let+      expect = getProtocolVersion (expectProtocolVersion e)+      actual = getProtocolVersion (actualProtocolVersion e)+    in+      concat+        [ "The protocol version of the input ("+        , show actual+        , ") does not match the version implemented by this package ("+        , show expect+        , ")."+        ]++data CallStackChunk = MkCallStackChunk+  { callStackChunkThreadId :: !ThreadId+  , callStackChunkCapabilityId :: !CapabilityId+  , callStackChunk :: ![CallStackFrame]+  }+  deriving (Eq, Ord, Show, Read, Generic)++data StringDef = MkStringDef+  { stringDefId :: !StringId+  , stringDefBody :: !Text+  }+  deriving (Eq, Ord, Show, Read, Generic)++data SourceLocationDef = MkSourceLocationDef+  { sourceLocationDefId :: {-# UNPACK #-} !SourceLocationId+  , sourceLocationDefRow :: {-# UNPACK #-} !Word32+  , sourceLocationDefColumn :: {-# UNPACK #-} !Word32+  , sourceLocationDefFilename :: {-# UNPACK #-} !StringId+  }+  deriving (Eq, Ord, Show, Read, Generic)++data CallStackFrame+  = CallStackFrameIpe {-# UNPACK #-} !IpeId+  | CallStackFrameAnn {-# UNPACK #-} !StringId {-# UNPACK #-} !(Maybe SourceLocationId)+  deriving (Eq, Ord, Show, Read, Generic)++-- | The ID of a thread.+newtype ThreadId+  = MkThreadId+  { getThreadId :: Word64+  }+  deriving (Show, Eq, Ord, Read, Generic)+  deriving newtype (Binary)++-- | The ID of a capability.+newtype CapabilityId+  = MkCapabilityId+  { getCapabilityId :: Word32+  }+  deriving (Show, Eq, Ord, Read, Generic)+  deriving newtype (Binary)++newtype StringId = MkStringId+  { getStringId :: Word64+  }+  deriving (Eq, Ord, Show, Read, Generic)++nextStringId :: StringId -> StringId+nextStringId (MkStringId sid) = MkStringId (sid + 1)++newtype SourceLocationId = MkSourceLocationId+  { getSourceLocationId :: Word64+  }+  deriving (Eq, Ord, Show, Read, Generic)++nextSourceLocationId :: SourceLocationId -> SourceLocationId+nextSourceLocationId (MkSourceLocationId slId) = MkSourceLocationId (slId + 1)++newtype IpeId = MkIpeId+  { getIpeId :: Word64+  }+  deriving (Eq, Ord, Show, Read, Generic)++-- | Deserialise a `Message`.+--+--   __Warning:__ This function may throw `ProtocolVersionMismatch`.+deserializeEventlogMessage :: LBS.ByteString -> Either String Message+deserializeEventlogMessage msg = case runGetOrFail get msg of+  Left (_, _, errMsg) -> Left errMsg+  Right (_, _, callStackMessage) -> Right callStackMessage++-- | Combine all 'CallStackChunk's into a single 'CallStackChunk'.+-- We assume that all 'CallStackChunk' only differ in their 'callStackChunk' values.+--+-- 'joinCallStackChunks' is the conceptually inverse of 'chunkCallStack'.+joinCallStackChunks :: NonEmpty CallStackChunk -> CallStackChunk+joinCallStackChunks msgs =+  MkCallStackChunk+    { callStackChunkThreadId = callStackChunkThreadId $ NonEmpty.head msgs+    , callStackChunkCapabilityId = callStackChunkCapabilityId $ NonEmpty.head msgs+    , callStackChunk = concatMap (reverse . callStackChunk) . reverse $ NonEmpty.toList msgs+    }++-------------------------------------------------------------------------------+-- Binary instances+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Message Tags++data MessageTag+  = ProtocolVersionTag+  | CallStackFinalTag+  | CallStackChunkTag+  | StringDefTag+  | SourceLocationDefTag+  deriving (Bounded, Enum, Eq, Show)++messageTagSize :: Int+messageTagSize = 2++messageTagToWord16 :: MessageTag -> Word16+messageTagToWord16 = \case+  ProtocolVersionTag -> 0xFFC0+  CallStackFinalTag -> 0xFFCA+  CallStackChunkTag -> 0xFFCB+  StringDefTag -> 0xFFCC+  SourceLocationDefTag -> 0xFFCD++instance Binary MessageTag where+  put :: MessageTag -> Put+  put = putWord16 . messageTagToWord16++  get :: Get MessageTag+  get =+    getWord16 >>= \case+      0xFFC0 -> pure ProtocolVersionTag+      0xFFCA -> pure CallStackFinalTag+      0xFFCB -> pure CallStackChunkTag+      0xFFCC -> pure StringDefTag+      0xFFCD -> pure SourceLocationDefTag+      badTag ->+        fail $+          printf+            "Found invalid message tag %s. Expected one of %s."+            (showAsHex badTag)+            (List.intercalate ", " messageTags)+   where+    messageTags :: [String]+    messageTags = [showAsHex (messageTagToWord16 tag) | tag <- [minBound .. maxBound]]++-------------------------------------------------------------------------------+-- Messages++-- | __Warning:__ `get` may throw `ProtocolVersionMismatch`.+instance Binary Message where+  put :: Message -> Put+  put = \case+    ProtocolVersion protocolVersion -> do+      put ProtocolVersionTag+      put protocolVersion+    CallStackFinal callStackChunk -> do+      put CallStackFinalTag+      put callStackChunk+    CallStackChunk callStackChunk -> do+      put CallStackChunkTag+      put callStackChunk+    StringDef stringDef -> do+      put StringDefTag+      put stringDef+    SourceLocationDef sourceLocationDef -> do+      put SourceLocationDefTag+      put sourceLocationDef++  get :: Get Message+  get =+    get >>= \case+      ProtocolVersionTag -> do+        protocolVersion <- get+        when (protocolVersion /= MyProtocolVersion) $+          throw $+            MkProtocolVersionMismatch MyProtocolVersion protocolVersion+        pure $ ProtocolVersion protocolVersion+      CallStackFinalTag ->+        CallStackFinal <$> get+      CallStackChunkTag ->+        CallStackChunk <$> get+      StringDefTag ->+        StringDef <$> get+      SourceLocationDefTag ->+        SourceLocationDef <$> get++messageMaxSize :: Int+messageMaxSize =+  fromIntegral (maxBound @Word16)++messageMinSize :: Int+messageMinSize =+  messageTagSize+    + minimum+      [ {- CallStackChunk/CallStackFinal -}+        capabilityIdSize + threadIdSize + callStackLenSize+      , {- StringDef -}+        stringIdSize + stringDefBodyLenSize+      , {- SourceLocationDef -}+        sourceLocationDefSize+      ]++-------------------------------------------------------------------------------+-- CallStackChunks++instance Binary CallStackChunk where+  put :: CallStackChunk -> Put+  put MkCallStackChunk{callStackChunkCapabilityId, callStackChunkThreadId, callStackChunk} = do+    put callStackChunkCapabilityId+    put callStackChunkThreadId+    let+      callStackChunkLength = length callStackChunk+    putWord16 $ fromIntegral callStackChunkLength+    mapM_ put callStackChunk++  get :: Get CallStackChunk+  get = do+    callStackChunkCapabilityId <- get+    callStackChunkThreadId <- get+    callStackChunkLength <- fromIntegral <$> getWord16+    callStackChunk <- replicateM callStackChunkLength get+    pure MkCallStackChunk{callStackChunkThreadId, callStackChunkCapabilityId, callStackChunk}++-------------------------------------------------------------------------------+-- CallStackFrameTags++data CallStackFrameTag+  = CallStackFrameIpeTag+  | CallStackFrameAnnWithNothingTag+  | CallStackFrameAnnWithJustSourceLocationTag+  deriving (Bounded, Enum, Eq, Show)++callStackFrameTagSize :: Int+callStackFrameTagSize = 1++callStackFrameTagToWord8 :: CallStackFrameTag -> Word8+callStackFrameTagToWord8 = \case+  CallStackFrameIpeTag -> 0x1+  CallStackFrameAnnWithNothingTag -> 0x2+  CallStackFrameAnnWithJustSourceLocationTag -> 0x3++instance Binary CallStackFrameTag where+  put :: CallStackFrameTag -> Put+  put = putWord8 . callStackFrameTagToWord8++  get :: Get CallStackFrameTag+  get =+    getWord8 >>= \case+      0x1 -> pure CallStackFrameIpeTag+      0x2 -> pure CallStackFrameAnnWithNothingTag+      0x3 -> pure CallStackFrameAnnWithJustSourceLocationTag+      badTag ->+        fail $+          printf+            "Found invalid call-stack frame tag %s. Expected one of %s."+            (showAsHex badTag)+            (List.intercalate ", " callStackFrameTags)+   where+    callStackFrameTags :: [String]+    callStackFrameTags = [showAsHex (callStackFrameTagToWord8 tag) | tag <- [minBound .. maxBound]]++-------------------------------------------------------------------------------+-- CallStackFrames++instance Binary IpeId where+  put :: IpeId -> Put+  put = putWord64 . coerce++  get :: Get IpeId+  get = coerce getWord64++ipeIdSize :: Int+ipeIdSize = 8++instance Binary CallStackFrame where+  put :: CallStackFrame -> Put+  put = \case+    CallStackFrameIpe ipeId -> do+      put CallStackFrameIpeTag+      put ipeId+    CallStackFrameAnn stringId Nothing -> do+      put CallStackFrameAnnWithNothingTag+      put stringId+    CallStackFrameAnn stringId (Just sourceLocationId) -> do+      put CallStackFrameAnnWithJustSourceLocationTag+      put stringId+      put sourceLocationId++  get :: Get CallStackFrame+  get = do+    get >>= \case+      CallStackFrameIpeTag ->+        CallStackFrameIpe <$> get+      CallStackFrameAnnWithNothingTag ->+        CallStackFrameAnn <$> get <*> pure Nothing+      CallStackFrameAnnWithJustSourceLocationTag ->+        CallStackFrameAnn <$> get <*> (Just <$> get)++-------------------------------------------------------------------------------+-- StringDefs++instance Binary StringId where+  put :: StringId -> Put+  put = putWord64 . coerce++  get :: Get StringId+  get = coerce getWord64++stringIdSize :: Int+stringIdSize = 8++instance Binary StringDef where+  put :: StringDef -> Put+  put MkStringDef{stringDefId, stringDefBody} = do+    put stringDefId+    put $ MkUnsafeShortText (truncateTextToByteLimit stringDefBodyMaxSize stringDefBody)++  get :: Get StringDef+  get = do+    stringDefId <- get+    -- NOTE: This allows reading stringDefBody with a lengthWord8 of up to+    --       the maxBound of Word16, which is bigger than stringDefBodyMaxSize.+    --       This causes a slight mismatch between the size of stringDefBody+    --       read by get and written by put, which means that get followed by+    --       put is not the identity. However, this would only truncate the+    --       stringDefBody if that binary representation was created manually,+    --     rather than via put, so this is likely not an issue.+    MkUnsafeShortText stringDefBody <- get+    pure MkStringDef{stringDefId, stringDefBody}++stringDefBodyLenSize :: Int+stringDefBodyLenSize = 2++stringDefBodyMaxSize :: Int+stringDefBodyMaxSize =+  messageMaxSize+    - messageTagSize+    - stringIdSize+    - stringDefBodyLenSize++-------------------------------------------------------------------------------+-- SourceLocationDefs++instance Binary SourceLocationId where+  put :: SourceLocationId -> Put+  put = putWord64 . coerce++  get :: Get SourceLocationId+  get = coerce getWord64++sourceLocationIdSize :: Int+sourceLocationIdSize = 8++instance Binary SourceLocationDef where+  put :: SourceLocationDef -> Put+  put msg = do+    put $ sourceLocationDefId msg+    putWord32 (sourceLocationDefRow msg)+    putWord32 (sourceLocationDefColumn msg)+    put (sourceLocationDefFilename msg)++  get :: Get SourceLocationDef+  get = MkSourceLocationDef <$> get <*> getWord32 <*> getWord32 <*> get++sourceLocationDefSize :: Int+sourceLocationDefSize =+  sourceLocationIdSize {- sourceLocationDefId -}+    + 4 {- sourceLocationDefRow -}+    + 4 {- sourceLocationDefColumn -}+    + stringIdSize {- sourceLocationDefFilename -}++-------------------------------------------------------------------------------+-- Trim Text to a byte-size limit++-- | A 'Text' whose 'TF.lengthWord8' is at most @'maxBound' :: 'Word16'@ bytes.+newtype ShortText = MkUnsafeShortText Text+  deriving (Eq, Show)++toShortText :: Text -> ShortText+toShortText text =+  MkUnsafeShortText (truncateTextToByteLimit maxBoundWord16 text)+ where+  maxBoundWord16 = fromIntegral (maxBound @Word16)++instance Binary ShortText where+  put :: ShortText -> Put+  put (MkUnsafeShortText text) = do+    putWord16 (fromIntegral (TF.lengthWord8 text))+    putByteString (TE.encodeUtf8 text)++  get :: Get ShortText+  get = do+    lengthWord8 <- fromIntegral <$> getWord16+    bytes <- getByteString lengthWord8+    pure $ MkUnsafeShortText (TE.decodeUtf8Lenient bytes)++-- | @'truncateTextToByteLimit' byteLimit text@ truncates @text@ such that its+--   UTF-8 serialisation fits within @byteLimit@ bytes.+truncateTextToByteLimit :: Int -> Text -> Text+truncateTextToByteLimit byteLimit text+  | TF.lengthWord8 text <= byteLimit = text+  | TF.lengthWord8 text' <= byteLimit = text'+  | otherwise =+      -- @'takeWord8' n@ takes the first n bytes and _expands_ to complete the+      -- last code point, which means it may return up to n+3 bytes. Hence, if+      -- this happens, we drop the final code point.+      assert (byteLimit < TF.lengthWord8 text' && TF.lengthWord8 text' <= byteLimit + 3) $+        T.dropEnd 1 text'+ where+  text' = TF.takeWord8 (fromIntegral byteLimit) text++-------------------------------------------------------------------------------+-- Size Invariants++callStackLenSize :: Int+callStackLenSize = 2++-- | The maximum number of `CallStackFrame`s in a single `Message`.+callStackMaxLen :: Int+callStackMaxLen = callStackMaxLen' messageMaxSize++-- | The size of a serialised `CapabilityId`.+capabilityIdSize :: Int+capabilityIdSize = 4++-- | The size of a serialised `ThreadId`.+threadIdSize :: Int+threadIdSize = 8++-- | The maximum number of `CallStackFrame`s in a single `Message`,+--   with a variable `messageMaxSize`. Used for testing.+callStackMaxLen' :: Int -> Int+callStackMaxLen' messageMaxSize' =+  fromIntegral+    ( messageMaxSize'+        - messageTagSize+        - capabilityIdSize+        - threadIdSize+        - callStackLenSize+    )++-- | Size in bytes of the given 'CallStackFrame'+callStackFrameSize :: CallStackFrame -> Int+callStackFrameSize = \case+  CallStackFrameIpe{} ->+    1 {- CallStackFrameTag -}+      + 8 {- IpeId -}+  CallStackFrameAnn _ Nothing ->+    1 {- CallStackFrameTag -}+      + 8 {- StringId -}+  CallStackFrameAnn _ (Just _) ->+    1 {- CallStackFrameTag -}+      + 8 {- StringId -}+      + 8 {- SourceLocationId -}++callStackFrameMaxSize :: Int+callStackFrameMaxSize =+  17 {- see case for CallStackFrameAnn in callStackFrameSize -}

@@ -0,0 +1,154 @@+module GHC.Stack.Profiler.Core.Internal.Hydrate where++import Control.Exception+import Data.Either (partitionEithers)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics+import GHC.Stack.Profiler.Core.Internal.CallStack+import GHC.Stack.Profiler.Core.Internal.Eventlog+import GHC.Stack.Profiler.Core.Internal.Util++data BinaryCallStackDecodeError+  = StringIdNotFound StringId+  | SourceLocationIdNotFound SourceLocationId+  deriving (Show)++instance Exception BinaryCallStackDecodeError where+  displayException = \case+    StringIdNotFound sid ->+      "Failed to decode a CallStackChunk. Failed to find a String with the key: " ++ show (getStringId sid)+    SourceLocationIdNotFound sid ->+      "Failed to decode a CallStackChunk. Failed to find a SourceLocation with the key: " ++ show (getSourceLocationId sid)++-- | Generic implementation to turn 'CallStackChunk' into the much richer+-- 'CallStack'.+hydrateEventlogCallStackMessage :: SymbolTableReader -> CallStackChunk -> (CallStack, [BinaryCallStackDecodeError])+hydrateEventlogCallStackMessage decodeTable msg =+  let+    decodeItem :: CallStackFrame -> Either BinaryCallStackDecodeError StackItem+    decodeItem = \case+      CallStackFrameIpe ipeId ->+        Right $ IpeId ipeId+      CallStackFrameAnn stringId mSrcLocId -> do+        str <-+          maybe+            (Left $ StringIdNotFound stringId)+            (Right . Text.unpack)+            (lookupStringId decodeTable stringId)+        srcLoc <- case mSrcLocId of+          Nothing -> pure Nothing+          Just srcLocId ->+            maybe+              (Left $ SourceLocationIdNotFound srcLocId)+              (Right . Just)+              (lookupSourceLocationId decodeTable srcLocId)+        pure $ UserAnnotation str srcLoc++    itemsOrErrors = map decodeItem (callStackChunk msg)+    (errors, items) = partitionEithers itemsOrErrors+  in+    ( MkCallStack+        { callCapabilityId = callStackChunkCapabilityId msg+        , callThreadId = callStackChunkThreadId msg+        , callStack = items+        }+    , errors+    )++-- | Implementation agnostic symbol table reader helping consumers to decode+-- 'Message's into a 'CallStack'.+--+-- As during deserialisation, we do not discover new Messages, the abstract 'SymbolTableReader'+-- doesn't need to thread the implementation through the lookup operations.+data SymbolTableReader = MkSymbolTableReader+  { lookupStringId :: StringId -> Maybe Text+  -- ^ Lookup the 'StringId' in the symbol table.+  -- This operation throws an exception if the 'StringId' is unknown.+  , lookupSourceLocationId :: SourceLocationId -> Maybe SourceLocation+  -- ^ Lookup the 'SourceLocationId' in the symbol table.+  -- This operation throws an exception if the 'SourceLocationId' is unknown.+  }+  deriving (Generic)++data MissingKeyError+  = -- | We failed to find the 'StringId' to fully decode the 'SourceLocationId'.+    KeyStringIdNotFound SourceLocationId StringId+  deriving (Show)++instance Exception MissingKeyError where+  displayException = \case+    KeyStringIdNotFound srcLocId stringId ->+      "While decoding the Source Location ("+        ++ show (getSourceLocationId srcLocId)+        ++ "), "+        ++ "the String ("+        ++ show (getStringId stringId)+        ++ ") couldn't be found"++data IntMapTable = MkIntMapTable+  { stringLookupTable :: !(IntMap Text)+  , srcLocLookupTable :: !(IntMap SourceLocation)+  }+  deriving (Eq, Ord, Show, Generic)++emptyIntMapTable :: IntMapTable+emptyIntMapTable =+  MkIntMapTable+    { stringLookupTable = IntMap.empty+    , srcLocLookupTable = IntMap.empty+    }++mkIntMapSymbolTableReader :: IntMapTable -> SymbolTableReader+mkIntMapSymbolTableReader tbl =+  MkSymbolTableReader+    { lookupStringId = flip lookupTextMessage tbl+    , lookupSourceLocationId = flip lookupSourceLocationMessage tbl+    }++{-# INLINEABLE insertTextMessage #-}+insertTextMessage :: StringDef -> IntMapTable -> IntMapTable+insertTextMessage msg tbl =+  tbl+    { stringLookupTable =+        IntMap.insert+          (idToInt $ stringDefId msg)+          (stringDefBody msg)+          (stringLookupTable tbl)+    }++{-# INLINEABLE insertSourceLocationMessage #-}+insertSourceLocationMessage :: SourceLocationDef -> IntMapTable -> Either MissingKeyError IntMapTable+insertSourceLocationMessage msg tbl = do+  let+    srcLocId = sourceLocationDefId msg+    fileId = sourceLocationDefFilename msg++  fileName <-+    maybe (Left $ KeyStringIdNotFound srcLocId fileId) Right $ lookupTextMessage fileId tbl++  pure+    tbl+      { srcLocLookupTable =+          IntMap.insert+            (idToInt srcLocId)+            (mkSourceLocation fileName)+            (srcLocLookupTable tbl)+      }+ where+  mkSourceLocation fileName =+    MkSourceLocation+      { line = sourceLocationDefRow msg+      , column = sourceLocationDefColumn msg+      , fileName = fileName+      }++{-# INLINEABLE lookupTextMessage #-}+lookupTextMessage :: StringId -> IntMapTable -> Maybe Text+lookupTextMessage sid tbl = IntMap.lookup (idToInt sid) (stringLookupTable tbl)++{-# INLINEABLE lookupSourceLocationMessage #-}+lookupSourceLocationMessage :: SourceLocationId -> IntMapTable -> Maybe SourceLocation+lookupSourceLocationMessage sid tbl = IntMap.lookup (idToInt sid) (srcLocLookupTable tbl)

@@ -0,0 +1,84 @@+module GHC.Stack.Profiler.Core.Internal.Util (+  idToInt,+  showAsHex,+  putWord64,+  putWord32,+  putWord16,+  getWord64,+  getWord32,+  getWord16,+  word64ToWord32,+  word32ToWord64,+  word64ToWord16,+  word32ToInt,+  word64ToInt,+  intToWord64,+  intToWord32,+  intToWord16,+  word16ToInt,+  intToWord8,+  word8ToInt,+) where++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Coerce (Coercible, coerce)+import qualified Numeric++idToInt :: (Coercible a Word64) => a -> Int+idToInt = word64ToInt . coerce++showAsHex :: (Integral a) => a -> String+showAsHex d = "0x" ++ Numeric.showHex d ""++putWord64 :: Word64 -> Put+putWord64 = putWord64be++putWord32 :: Word32 -> Put+putWord32 = putWord32be++putWord16 :: Word16 -> Put+putWord16 = putWord16be++getWord64 :: Get Word64+getWord64 = getWord64be++getWord32 :: Get Word32+getWord32 = getWord32be++getWord16 :: Get Word16+getWord16 = getWord16be++word64ToWord32 :: Word64 -> Word32+word64ToWord32 = fromIntegral++word32ToWord64 :: Word32 -> Word64+word32ToWord64 = fromIntegral++word64ToWord16 :: Word64 -> Word16+word64ToWord16 = fromIntegral++word32ToInt :: Word32 -> Int+word32ToInt = fromIntegral++word64ToInt :: Word64 -> Int+word64ToInt = fromIntegral++intToWord64 :: Int -> Word64+intToWord64 = fromIntegral++intToWord32 :: Int -> Word32+intToWord32 = fromIntegral++intToWord16 :: Int -> Word16+intToWord16 = fromIntegral++word16ToInt :: Word16 -> Int+word16ToInt = fromIntegral++intToWord8 :: Int -> Word8+intToWord8 = fromIntegral++word8ToInt :: Word8 -> Int+word8ToInt = fromIntegral

@@ -1,13 +0,0 @@-module GHC.Stack.Profiler.Core.SourceLocation where--import Data.Text (Text)-import Data.Word (Word32)-import GHC.Generics (Generic)---- | A Haskell source location.-data SourceLocation = MkSourceLocation-  { line :: !Word32-  , column :: !Word32-  , fileName :: !Text-  }-  deriving (Eq, Ord, Show, Generic)

@@ -1,247 +0,0 @@-module GHC.Stack.Profiler.Core.SymbolTable (-  -- * Abstract interfaces for transforming 'CallStackMessage's and--  -- 'BinaryEventlogMessage' into each other.-  SymbolTableWriter (..),-  SymbolTableReader (..),--  -- * A 'Map' implementation for the 'SymbolTableWriter' interface.-  MapTable,-  emptyMapSymbolTableWriter,-  getKnownStrings,-  getKnownSourceLocations,--  -- * An 'IntMap' implementation for the 'SymbolTableReader' interface.-  IntMapTable,-  MissingKeyError (..),-  mkIntMapSymbolTableReader,-  emptyIntMapTable,-  insertSourceLocationMessage,-  insertTextMessage,-) where--import Control.Exception-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap-import qualified Data.List as List-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Text (Text)-import qualified Data.Tuple as Tuple-import GHC.Generics (Generic)-import GHC.Stack.Profiler.Core.Eventlog-import GHC.Stack.Profiler.Core.SourceLocation-import GHC.Stack.Profiler.Core.Util---- ------------------------------------------------------------------------------- Abstract interfaces for writing and reading to the symbol tables for deduplicating--- the symbols for 'Text' and 'SourceLocation'.--- -------------------------------------------------------------------------------- | Implementation agnostic symbol table supposed to be used to deduplicate symbols--- in 'CallStackMessage'.------ When transforming 'CallStackMessage' to ['BinaryEventlogMessage'] we replace some--- symbols with identifiers.--- In particular arbitrary length symbols, such as 'Text's and 'SourceLocation's.--- As these symbols are discovered while encoding the callstack, the 'SymbolTableWriter'--- needs to be extended, which is why we thread the 'tbl' parameter through the--- lookup or insertion operations.-data SymbolTableWriter tbl = MkSymbolTableWriter-  { writerTable :: !tbl-  -- ^ Symbol table for symbols we replace with unique identifiers.-  , lookupOrInsertText :: tbl -> Text -> (StringId, Bool, tbl)-  -- ^ Lookup up the given 'Text' in the 'tbl' Symbol table.-  -- If the 'Text' can't be found, we insert it into the table and generate a-  -- new 'StringId.-  -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise.-  , lookupOrInsertSourceLocation :: tbl -> SourceLocation -> (SourceLocationId, Bool, tbl)-  -- ^ Lookup up the given 'SourceLocation' in the 'tbl' Symbol table.-  -- If the 'SourceLocation' can't be found, we insert it into the table and generate a-  -- new 'SourceLocationId.-  -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise.-  }-  deriving (Generic)---- | Implementation agnostic symbol table reader helping consumers to decode--- 'BinaryEventlogMessage's into a 'CallStackMessage'.------ As during deserialisation, we do not discover new Messages, the abstract 'SymbolTableReader'--- doesn't need to thread the implementation through the lookup operations.-data SymbolTableReader = MkSymbolTableReader-  { lookupStringId :: StringId -> Maybe Text-  -- ^ Lookup the 'StringId' in the symbol table.-  -- This operation throws an exception if the 'StringId' is unknown.-  , lookupSourceLocationId :: SourceLocationId -> Maybe SourceLocation-  -- ^ Lookup the 'SourceLocationId' in the symbol table.-  -- This operation throws an exception if the 'SourceLocationId' is unknown.-  }-  deriving (Generic)---- ------------------------------------------------------------------------------- Implementation backend for 'SymbolTableWriter'--- ------------------------------------------------------------------------------data MapTable = MkMapTable-  { stringTable :: !(Map Text StringId)-  , srcLocTable :: !(Map SourceLocation SourceLocationId)-  , stringUniqueSupply :: {-# UNPACK #-} !StringId-  , srcLocUniqueSupply :: {-# UNPACK #-} !SourceLocationId-  }-  deriving (Show, Eq, Ord, Generic)--{-# INLINEABLE emptyMapSymbolTableWriter #-}-emptyMapSymbolTableWriter :: SymbolTableWriter MapTable-emptyMapSymbolTableWriter =-  MkSymbolTableWriter-    { writerTable =-        MkMapTable-          { stringTable = Map.empty-          , srcLocTable = Map.empty-          , stringUniqueSupply = MkStringId 0-          , srcLocUniqueSupply = MkSourceLocationId 0-          }-    , lookupOrInsertText = alterStringMap-    , lookupOrInsertSourceLocation = alterSrcLocTable-    }- where-  nextSrcLocUnique tbl =-    ( srcLocUniqueSupply tbl-    , tbl-        { srcLocUniqueSupply =-            incrementSourceLocationId $ srcLocUniqueSupply tbl-        }-    )--  nextStringUnique tbl =-    ( stringUniqueSupply tbl-    , tbl-        { stringUniqueSupply =-            incrementStringLocationId $ stringUniqueSupply tbl-        }-    )--  updateEntry tbl0 nextKey Nothing =-    let-      (sid, tbl) = nextKey tbl0-    in-      ((sid, True, tbl), Just sid)-  updateEntry tbl _ (Just val) =-    ((val, False, tbl), Just val)--  swapAround set ((sid, new, tbl), hm) =-    (sid, new, set tbl hm)--  alterStringMap = \tbl str ->-    swapAround setStringTable $-      Map.alterF (updateEntry tbl nextStringUnique) str (stringTable tbl)--  alterSrcLocTable = \tbl srcLoc ->-    swapAround setSourceLocationTable $-      Map.alterF (updateEntry tbl nextSrcLocUnique) srcLoc (srcLocTable tbl)--setSourceLocationTable :: MapTable -> Map SourceLocation SourceLocationId -> MapTable-setSourceLocationTable tbl hm =-  tbl-    { srcLocTable = hm-    }--setStringTable :: MapTable -> Map Text StringId -> MapTable-setStringTable tbl hm =-  tbl-    { stringTable = hm-    }--getKnownStrings :: MapTable -> [(StringId, Text)]-{-# INLINEABLE getKnownStrings #-}-getKnownStrings table =-  List.map Tuple.swap $ Map.assocs (stringTable table)--getKnownSourceLocations :: MapTable -> [(SourceLocationId, SourceLocation)]-{-# INLINEABLE getKnownSourceLocations #-}-getKnownSourceLocations table =-  List.map Tuple.swap $ Map.assocs (srcLocTable table)---- ------------------------------------------------------------------------------- Implementation backend for 'SymbolTableReader'--- ------------------------------------------------------------------------------data MissingKeyError-  = -- | We failed to find the 'StringId' to fully decode the 'SourceLocationId'.-    KeyStringIdNotFound SourceLocationId StringId-  deriving (Show)--instance Exception MissingKeyError where-  displayException = \case-    KeyStringIdNotFound srcLocId stringId ->-      "While decoding the Source Location ("-        ++ show (getSourceLocationId srcLocId)-        ++ "), "-        ++ "the String ("-        ++ show (getStringId stringId)-        ++ ") couldn't be found"--data IntMapTable = MkIntMapTable-  { stringLookupTable :: !(IntMap Text)-  , srcLocLookupTable :: !(IntMap SourceLocation)-  }-  deriving (Eq, Ord, Show, Generic)--emptyIntMapTable :: IntMapTable-emptyIntMapTable =-  MkIntMapTable-    { stringLookupTable = IntMap.empty-    , srcLocLookupTable = IntMap.empty-    }--mkIntMapSymbolTableReader :: IntMapTable -> SymbolTableReader-mkIntMapSymbolTableReader tbl =-  MkSymbolTableReader-    { lookupStringId = flip lookupTextMessage tbl-    , lookupSourceLocationId = flip lookupSourceLocationMessage tbl-    }--{-# INLINEABLE insertTextMessage #-}-insertTextMessage :: BinaryStringMessage -> IntMapTable -> IntMapTable-insertTextMessage msg tbl =-  tbl-    { stringLookupTable =-        IntMap.insert-          (idToInt $ binaryStringMessageId msg)-          (binaryStringMessage msg)-          (stringLookupTable tbl)-    }--{-# INLINEABLE insertSourceLocationMessage #-}-insertSourceLocationMessage :: BinarySourceLocationMessage -> IntMapTable -> Either MissingKeyError IntMapTable-insertSourceLocationMessage msg tbl = do-  let-    srcLocId = binarySourceLocationMessageId msg-    fileId = binarySourceLocationFilename msg--  fileName <--    maybe (Left $ KeyStringIdNotFound srcLocId fileId) Right $ lookupTextMessage fileId tbl--  pure-    tbl-      { srcLocLookupTable =-          IntMap.insert-            (idToInt srcLocId)-            (mkSourceLocation fileName)-            (srcLocLookupTable tbl)-      }- where-  mkSourceLocation fileName =-    MkSourceLocation-      { line = binarySourceLocationRow msg-      , column = binarySourceLocationColumn msg-      , fileName = fileName-      }--{-# INLINEABLE lookupTextMessage #-}-lookupTextMessage :: StringId -> IntMapTable -> Maybe Text-lookupTextMessage sid tbl = IntMap.lookup (idToInt sid) (stringLookupTable tbl)--{-# INLINEABLE lookupSourceLocationMessage #-}-lookupSourceLocationMessage :: SourceLocationId -> IntMapTable -> Maybe SourceLocation-lookupSourceLocationMessage sid tbl = IntMap.lookup (idToInt sid) (srcLocLookupTable tbl)

@@ -1,336 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module GHC.Stack.Profiler.Core.ThreadSample (-  -- * High-level API-  ThreadSample (..),-  deserializeEventlogMessage,--  -- * Serialisable 'ThreadSample'-  CallStackMessage (..),-  StackItem (..),-  SourceLocation (..),--  -- * Serialisation of 'CallStackMessage'-  SymbolTableWriter (..),-  SymbolTableReader (..),-  dehydrateCallStackMessage,-  BinaryCallStackDecodeError (..),-  hydrateEventlogCallStackMessage,-  catCallStackMessage,-  chunkCallStackMessage,-  chunkCallStackMessage_,--  -- * Message dehydration helpers-  EncodingState,-  runWithEncodingState,-  newEncodingState,-  lookupSourceLocationMessage,-  lookupTextMessage,-) where--import Control.Concurrent-import Control.Exception (Exception (..))-import Control.Monad (when)-import Control.Monad.Trans.State.Strict (State, runState)-import qualified Control.Monad.Trans.State.Strict as State-import Data.Binary-import Data.Binary.Get-import qualified Data.ByteString.Lazy as LBS-import Data.Either (partitionEithers)-import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Text (Text)-import qualified Data.Text as Text-import GHC.Generics--import GHC.Stack.CloneStack (StackSnapshot)-import GHC.Stack.Profiler.Core.Eventlog-import GHC.Stack.Profiler.Core.SourceLocation-import GHC.Stack.Profiler.Core.SymbolTable-import GHC.Stack.Profiler.Core.Util (word16ToInt)---- ------------------------------------------------------------------------------- Thread Sample--- -------------------------------------------------------------------------------- | A 'ThreadSample' is a snapshot of a threads RTS callstack.--- This callstack is a copy of the original callstack, so can be traversed and--- decoded without affecting the running thread.------ The 'StackSnapshot' is a boxed value and needs to be garbage collected.--- Note, as long as 'StackSnapshot' is alive, you keep the full callstack--- alive, which might be quite expensive.-data ThreadSample = ThreadSample-  { threadSampleId :: !ThreadId-  , threadSampleCapability :: !CapabilityId-  , threadSampleStackSnapshot :: !StackSnapshot-  }-  deriving (Generic)--deserializeEventlogMessage :: LBS.ByteString -> Either String BinaryEventlogMessage-deserializeEventlogMessage msg = case runGetOrFail get msg of-  Left (_, _, errMsg) -> Left errMsg-  Right (_, _, callStackMessage) -> Right callStackMessage---- ------------------------------------------------------------------------------- Decoded RTS CallStack--- -------------------------------------------------------------------------------- | A decoded rts callstack that can be serialised to the EventLog.-data CallStackMessage = MkCallStackMessage-  { callThreadId :: !Word64-  , callCapabilityId :: !CapabilityId-  , callStack :: [StackItem]-  }-  deriving (Eq, Ord, Show, Generic)--data StackItem-  = IpeId !IpeId-  | UserAnnotation !String !(Maybe SourceLocation)-  deriving (Eq, Ord, Show, Generic)---- ------------------------------------------------------------------------------- Turning a 'CallStackMessage' into '[BinaryEventlogMessage]'--- -------------------------------------------------------------------------------- | Generic implementation to turn 'CallStackMessage' into '[BinaryEventlogMessage]'.------ Replaces already encountered text or source location information with unique ids.--- If new text or source location messages are encountered, they are inserted into--- the 'SymbolTableWriter'.------ All new string values and source location messages are before 'CallStackChunk' and--- 'CallStackFinal' messages.--- For the result list @r :: ['BinaryEventlogMessage']@, the following holds:------ * 'StringDef' messages are the first elements in @r@. There might not be any.--- * 'SourceLocationDef' are after 'StringDef' messages and before any 'CallStackChunk' or---    'CallStackFinal' messages. There might not be any such messages.--- * Then 'CallStackChunk' follow if there are any.--- * The last message is always a 'CallStackFinal' message and it occurs exactly once in @r@.-dehydrateCallStackMessage ::-  forall table.-  SymbolTableWriter table ->-  CallStackMessage ->-  ([BinaryEventlogMessage], SymbolTableWriter table)-dehydrateCallStackMessage msgTbl0 msg =-  let-    (stackItems, finalState) =-      runWithEncodingState-        (newEncodingState msgTbl0)-        (mapM go (callStack msg))--    stringDefs =-      map StringDef $ stringMessages finalState--    sourceLocDefs =-      map SourceLocationDef $ sourceLocMessages finalState--    -- TODO: this needs to be fixed-    stackMsgChunks =-      chunkCallStackMessage-        MkBinaryCallStackMessage-          { binaryCallThreadId = callThreadId msg-          , binaryCallCapabilityId = callCapabilityId msg-          , binaryCallStack = stackItems-          }-  in-    ( stringDefs ++ sourceLocDefs ++ stackMsgChunks-    , symbolTableWriter finalState-    )- where-  go :: StackItem -> State (EncodingState tbl) BinaryStackItem-  go = \case-    IpeId ipeId ->-      pure $ BinaryIpe ipeId-    UserAnnotation s mSrcLoc -> do-      srcLocId <- case mSrcLoc of-        Nothing -> pure Nothing-        Just srcLoc -> Just <$> lookupSourceLocationMessage srcLoc-      BinaryMessage <$> lookupTextMessage (Text.pack s) <*> pure srcLocId--data BinaryCallStackDecodeError-  = StringIdNotFound StringId-  | SourceLocationIdNotFound SourceLocationId-  deriving (Show)--instance Exception BinaryCallStackDecodeError where-  displayException = \case-    StringIdNotFound sid ->-      "Failed to decode a BinaryCallStackMessage. Failed to find a String with the key: " ++ show (getStringId sid)-    SourceLocationIdNotFound sid ->-      "Failed to decode a BinaryCallStackMessage. Failed to find a SourceLocation with the key: " ++ show (getSourceLocationId sid)---- | Generic implementation to turn 'BinaryCallStackMessage' into the much richer--- 'CallStackMessage'.-hydrateEventlogCallStackMessage :: SymbolTableReader -> BinaryCallStackMessage -> (CallStackMessage, [BinaryCallStackDecodeError])-hydrateEventlogCallStackMessage decodeTable msg =-  let-    decodeItem :: BinaryStackItem -> Either BinaryCallStackDecodeError StackItem-    decodeItem = \case-      BinaryIpe ipeId ->-        Right $ IpeId ipeId-      BinaryMessage stringId mSrcLocId -> do-        str <--          maybe-            (Left $ StringIdNotFound stringId)-            (Right . Text.unpack)-            (lookupStringId decodeTable stringId)-        srcLoc <- case mSrcLocId of-          Nothing -> pure Nothing-          Just srcLocId ->-            maybe-              (Left $ SourceLocationIdNotFound srcLocId)-              (Right . Just)-              (lookupSourceLocationId decodeTable srcLocId)-        pure $ UserAnnotation str srcLoc--    itemsOrErros = map decodeItem (binaryCallStack msg)-    (errors, items) = partitionEithers itemsOrErros-  in-    ( MkCallStackMessage-        { callCapabilityId = binaryCallCapabilityId msg-        , callThreadId = binaryCallThreadId msg-        , callStack = items-        }-    , errors-    )---- | Combine all 'BinaryCallStackMessage's into a single 'BinaryCallStackMessage'.--- We assume that all 'BinaryCallStackMessage' only differ in their 'binaryCallStack' values.------ 'catCallStackMessage' is the conceptually inverse of 'chunkCallStackMessage'.-catCallStackMessage :: NonEmpty BinaryCallStackMessage -> BinaryCallStackMessage-catCallStackMessage msgs =-  MkBinaryCallStackMessage-    { binaryCallThreadId = binaryCallThreadId $ NonEmpty.head msgs-    , binaryCallCapabilityId = binaryCallCapabilityId $ NonEmpty.head msgs-    , binaryCallStack = concatMap (reverse . binaryCallStack) . reverse $ NonEmpty.toList msgs-    }---- | Chunk the 'binaryCallStack' of the 'BinaryCallStackMessage' by the given 'Word16'.--- If there are no items in 'BinaryCallStackMessage', then a singleton list is returned containing--- the original element.------ Post-condition for the result @r@:------ * all elements in @init r @ are 'CallStackChunk's--- * the element returned by @last r@ is a 'CallStackFinal' BinaryEventlogMessage.------ The resulting 'CallStackChunk' are in reverse order and so are the chunks themselves.------ This means, for a stack @[1,2,3,4,5,6]@ and an assumed chunk size of 2,--- we produce @[[6,5],[4,3],[2,1]]@.-chunkCallStackMessage :: BinaryCallStackMessage -> [BinaryEventlogMessage]-chunkCallStackMessage = chunkCallStackMessage_ callStackSizeLimit---- | Same as 'chunkCallStackMessage', but allows to set the chunking size in bytes.-chunkCallStackMessage_ :: Word16 -> BinaryCallStackMessage -> [BinaryEventlogMessage]-chunkCallStackMessage_ chunkLimit16 msg0 =-  let-    chunkLimitInt = word16ToInt chunkLimit16-    items = binaryCallStack msg0-    chunked =-      let-        go (!size, curChunk, restChunk) item =-          let-            !bytes = word16ToInt $ byteSizeOf item-          in-            if (size + bytes) < chunkLimitInt-              then (size + bytes, item : curChunk, restChunk)-              else (bytes, [item], curChunk : restChunk)-        (_, lastChunk, initChunk) = List.foldl' go (0, [], []) items-      in-        lastChunk : initChunk-  in-    mkEventlogMessages chunked- where-  mkCallStack chunk =-    MkBinaryCallStackMessage-      { binaryCallThreadId = binaryCallThreadId msg0-      , binaryCallCapabilityId = binaryCallCapabilityId msg0-      , binaryCallStack = chunk-      }--  mkEventlogMessages :: [[BinaryStackItem]] -> [BinaryEventlogMessage]-  mkEventlogMessages [] =-    -- If there are no chunks, we simply return the original message-    [ CallStackFinal msg0-    ]-  mkEventlogMessages [chunk] =-    [ CallStackFinal $ mkCallStack chunk-    ]-  mkEventlogMessages (chunk : chunks) =-    CallStackChunk (mkCallStack chunk) : mkEventlogMessages chunks---- ------------------------------------------------------------------------------- Helper types and functions to implement the conversion to the binary--- representation.--- ------------------------------------------------------------------------------data EncodingState tbl = MkEncodingState-  { symbolTableWriter :: !(SymbolTableWriter tbl)-  , stringMessages :: ![BinaryStringMessage]-  , sourceLocMessages :: ![BinarySourceLocationMessage]-  }-  deriving (Generic)--runWithEncodingState :: EncodingState tbl -> State (EncodingState tbl) a -> (a, EncodingState tbl)-runWithEncodingState encodingState encoder =-  runState encoder encodingState--newEncodingState :: SymbolTableWriter tbl -> EncodingState tbl-newEncodingState msgTbl0 =-  MkEncodingState-    { symbolTableWriter = msgTbl0-    , stringMessages = []-    , sourceLocMessages = []-    }--setSymbolTableWriter :: tbl -> State.State (EncodingState tbl) ()-setSymbolTableWriter tbl = State.modify' (\st -> st{symbolTableWriter = (symbolTableWriter st){writerTable = tbl}})--addStringMessage :: BinaryStringMessage -> State.State (EncodingState tbl) ()-addStringMessage msg = State.modify' (\st -> st{stringMessages = msg : stringMessages st})--addSourceLocationMessage :: BinarySourceLocationMessage -> State.State (EncodingState tbl) ()-addSourceLocationMessage msg = State.modify' (\st -> st{sourceLocMessages = msg : sourceLocMessages st})--lookupOrInsertTextMessage :: forall tbl. Text -> State (EncodingState tbl) (StringId, Bool)-lookupOrInsertTextMessage s = do-  tbl <- State.gets symbolTableWriter-  let-    (sid, new, tbl1) = lookupOrInsertText tbl (writerTable tbl) s-  setSymbolTableWriter tbl1-  pure (sid, new)--lookupOrInsertSrcLocMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) (SourceLocationId, Bool)-lookupOrInsertSrcLocMessage s = do-  tbl <- State.gets symbolTableWriter-  let-    (sid, new, tbl1) = lookupOrInsertSourceLocation tbl (writerTable tbl) s-  setSymbolTableWriter tbl1-  pure (sid, new)--lookupTextMessage :: forall tbl. Text -> State (EncodingState tbl) StringId-lookupTextMessage s = do-  (sid, new) <- lookupOrInsertTextMessage s-  when new $-    addStringMessage $-      MkBinaryStringMessage sid s-  pure sid--lookupSourceLocationMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) SourceLocationId-lookupSourceLocationMessage s = do-  (sid, new) <- lookupOrInsertSrcLocMessage s-  when new $ do-    fileId <- lookupTextMessage $ fileName s-    addSourceLocationMessage $-      MkBinarySourceLocationMessage-        { binarySourceLocationMessageId = sid-        , binarySourceLocationRow = line s-        , binarySourceLocationColumn = column s-        , binarySourceLocationFilename = fileId-        }-  pure sid

@@ -1,104 +0,0 @@-module GHC.Stack.Profiler.Core.Util (-  idToInt,-  putTextWord16,-  getTextWord16,-  showAsHex,-  putWord64,-  putWord32,-  putWord16,-  getWord64,-  getWord32,-  getWord16,-  word64ToWord32,-  word32ToWord64,-  word64ToWord16,-  word32ToInt,-  word64ToInt,-  intToWord64,-  intToWord32,-  intToWord16,-  word16ToInt,-  intToWord8,-  word8ToInt,-) where--import Control.Monad (replicateM)-import Data.Binary-import Data.Binary.Get-import Data.Binary.Put-import Data.Coerce (Coercible, coerce)-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Numeric--idToInt :: (Coercible a Word64) => a -> Int-idToInt = word64ToInt . coerce--putTextWord16 :: Word16 -> Text -> Put-putTextWord16 bound msg =-  putWord16 len <> putStringUtf8 (Text.unpack msg)- where-  shortName = Text.take (word16ToInt bound) msg-  -- this is safe as 'bound' is a 'Word16' itself-  -- so the short string can be at most have a length of 'Word16'-  len = intToWord16 $ Text.length shortName--getTextWord16 :: Get Text-getTextWord16 = do-  len <- getWord16-  s <- replicateM (word16ToInt len) get-  pure $ Text.pack s--showAsHex :: (Integral a) => a -> String-showAsHex d = "0x" ++ Numeric.showHex d ""--putWord64 :: Word64 -> Put-putWord64 = putWord64be--putWord32 :: Word32 -> Put-putWord32 = putWord32be--putWord16 :: Word16 -> Put-putWord16 = putWord16be--getWord64 :: Get Word64-getWord64 = getWord64be--getWord32 :: Get Word32-getWord32 = getWord32be--getWord16 :: Get Word16-getWord16 = getWord16be--word64ToWord32 :: Word64 -> Word32-word64ToWord32 = fromIntegral--word32ToWord64 :: Word32 -> Word64-word32ToWord64 = fromIntegral--word64ToWord16 :: Word64 -> Word16-word64ToWord16 = fromIntegral--word32ToInt :: Word32 -> Int-word32ToInt = fromIntegral--word64ToInt :: Word64 -> Int-word64ToInt = fromIntegral--intToWord64 :: Int -> Word64-intToWord64 = fromIntegral--intToWord32 :: Int -> Word32-intToWord32 = fromIntegral--intToWord16 :: Int -> Word16-intToWord16 = fromIntegral--word16ToInt :: Word16 -> Int-word16ToInt = fromIntegral--intToWord8 :: Int -> Word8-intToWord8 = fromIntegral--word8ToInt :: Word8 -> Int-word8ToInt = fromIntegral

@@ -1,115 +1,276 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Main where -import Data.Binary-import Data.Binary.Put-import qualified Data.ByteString.Lazy as LBS+import Data.Binary (Binary, Word16, Word32, decode, encode)+import qualified Data.ByteString.Lazy as BSL import qualified Data.List.NonEmpty as NonEmpty-import Data.Maybe-import GHC.Stack.Profiler.Core.Eventlog-import GHC.Stack.Profiler.Core.ThreadSample-import GHC.Stack.Profiler.Core.Util (word32ToWord64)+import Data.Maybe (mapMaybe)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Foreign as TF+import GHC.Stack.Profiler.Core+import GHC.Stack.Profiler.Core.Internal import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options (IsOption (..)) import Test.Tasty.QuickCheck+import Text.Printf (printf)  main :: IO ()-main = defaultMain tests+main =+  defaultMain $+    adjustOption increaseDefaultMaxSize $+      testGroup "Tests" $+        [ testGroup "Size" $+            [ test_encodeSize "MessageTag" (Proxy @MessageTag) messageTagSize+            , test_encodeSize "CallStackFrameTag" (Proxy @CallStackFrameTag) callStackFrameTagSize+            , prop_encodeSizeInv "IpeId" (Proxy @IpeId) (== ipeIdSize)+            , prop_encodeSizeInv "ThreadId" (Proxy @ThreadId) (== threadIdSize)+            , prop_encodeSizeInv "CapabilityId" (Proxy @CapabilityId) (== capabilityIdSize)+            , prop_encodeSizeInv "CallStackFrame" (Proxy @CallStackFrame) (<= callStackFrameMaxSize)+            , prop_chunkCallStackSizeInv+            , let+                gen =+                  -- Generate a callStack, divide it into chunks, then pick one of the messages.+                  elements . chunkCallStack =<< arbitrary+              in+                prop_encodeSizeInv' "CallStackChunk/CallStackFinal" gen show Nothing (<= messageMaxSize)+            , prop_encodeSizeInv "StringId" (Proxy @StringId) (== stringIdSize)+            , let+                gen =+                  StringDef <$> arbitrary+                showFor msg@(StringDef MkStringDef{stringDefId, stringDefBody}) =+                  printf+                    "stringDefId == %d && length stringDefBody == %d && %s"+                    (getStringId stringDefId)+                    (T.length stringDefBody)+                    (labelFor msg)+                labelFor (StringDef MkStringDef{stringDefBody}) =+                  if fromIntegral (T.length stringDefBody) > stringDefBodyMaxSize+                    then "length stringDefBody >  stringDefBodyMaxSize"+                    else "length stringDefBody <= stringDefBodyMaxSize"+              in+                prop_encodeSizeInv' "StringDef" gen showFor (Just labelFor) (<= messageMaxSize)+            , prop_encodeSizeInv "SourceLocationId" (Proxy @SourceLocationId) (== sourceLocationIdSize)+            , prop_encodeSizeInv "SourceLocationDef" (Proxy @SourceLocationDef) (== sourceLocationDefSize)+            , prop_encodeSizeInv "ShortText" (Proxy @ShortText) (<= maxBoundWord16 + 2)+            , prop_truncateTextToByteLimit+            ]+        , testGroup "Encode/Decode" $+            [ test_encodeDecode "MessageTag" (Proxy @MessageTag)+            , test_encodeDecode "CallStackFrameTag" (Proxy @CallStackFrameTag)+            , prop_encodeDecode "IpeId" (Proxy @IpeId)+            , prop_encodeDecode "ThreadId" (Proxy @ThreadId)+            , prop_encodeDecode "CapabilityId" (Proxy @CapabilityId)+            , prop_encodeDecode "CallStackFrame" (Proxy @CallStackFrame)+            , prop_chunkAndJoinCallStack+            , let+                to :: CallStackChunk -> [Message]+                to = chunkCallStack+                from :: [Message] -> CallStackChunk+                from = joinCallStackChunks . NonEmpty.fromList . mapMaybe getCallStackFrame+              in+                prop_encodeDecodeVia' "CallStackChunk/CallStackFinal" arbitrary show Nothing to from+            , prop_encodeDecode "StringId" (Proxy @StringId)+            , let+                -- The roundtrip property only holds if the byte length of stringDefBody+                -- is less than stringDefBodyMaxSize, otherwise it's truncated.+                gen = do+                  MkStringDef{stringDefId, stringDefBody} <- arbitrary+                  let+                    stringDefBody' = truncateTextToByteLimit stringDefBodyMaxSize stringDefBody+                  pure $ StringDef MkStringDef{stringDefId, stringDefBody = stringDefBody'}+              in+                prop_encodeDecode' "StringDef" gen show Nothing+            , prop_encodeDecode "SourceLocationId" (Proxy @SourceLocationId)+            , prop_encodeDecode "SourceLocationDef" (Proxy @SourceLocationDef)+            , prop_encodeDecode "ShortText" (Proxy @ShortText)+            ]+        ]+ where+  increaseDefaultMaxSize :: QuickCheckMaxSize -> QuickCheckMaxSize+  increaseDefaultMaxSize v@(QuickCheckMaxSize _) =+    if v /= defaultValue then v else QuickCheckMaxSize (2 * maxBoundWord16) -tests :: TestTree-tests =-  testGroup-    "tests"-    [ properties+--------------------------------------------------------------------------------+-- Tests+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- Tests - Size Invariants++-- | Test a size invariant on the result of `encode` using `Enum`.+test_encodeSize :: (Binary a, Bounded a, Enum a, Eq a, Show a) => TestName -> Proxy a -> Int -> TestTree+test_encodeSize testName (_pa :: Proxy a) size =+  testGroup testName $+    [ testCase (printf "length (encode %s) == %d" (show a) size) $ do+        fromIntegral (BSL.length (encode a)) @?= size+    | (a :: a) <- [minBound .. maxBound]     ] -properties :: TestTree-properties =-  testGroup-    "property"-    [ testProperty "chunkCallStackMessage . catCallStackMessage" $-        withNumTests 500 $-          withMaxSize (fromIntegral callStackSizeLimit * 3) $-            chunkingRoundTrip_prop callStackSizeLimit-    , testProperty "chunkCallStackMessage size < chunkCallStackMessage" $-        withNumTests 500 $ do-          withMaxSize (fromIntegral callStackSizeLimit * 3) $-            messageChunkSize_prop eventlogBufferSize callStackSizeLimit-    , testProperty "chunkCallStackMessage_ n . catCallStackMessage" $-        withNumTests 500 $-          withEventlogSizeGen $ \eventlogSize ->-            withMaxSize (fromIntegral eventlogSize * 20) $-              chunkingRoundTrip_prop (callStackSizeLimit_ eventlogSize)-    , testProperty "chunkCallStackMessage_ n < size" $-        withNumTests 500 $ do-          withEventlogSizeGen $ \eventlogSize ->-            withMaxSize (fromIntegral eventlogSize * 5) $-              messageChunkSize_prop eventlogSize (callStackSizeLimit_ eventlogSize)+-- | Test a size invariant on the result of `encode` using QuickCheck.+prop_encodeSizeInv :: (Arbitrary a, Binary a, Eq a, Show a) => TestName -> Proxy a -> (Int -> Bool) -> TestTree+prop_encodeSizeInv testName (_pa :: Proxy a) sizeInv =+  testProperty testName $ \(a :: a) ->+    sizeInv (fromIntegral (BSL.length (encode a)))++-- | Variant of `prop_encodeSizeInv` that accepts a custom generator, show function, and label function.+prop_encodeSizeInv' :: (Binary a, Eq a) => TestName -> Gen a -> (a -> String) -> Maybe (a -> String) -> (Int -> Bool) -> TestTree+prop_encodeSizeInv' testName gen showFor maybeLabelFor sizeInv =+  testProperty testName $+    forAllShow gen showFor $ \a ->+      maybe property (label . ($ a)) maybeLabelFor $+        sizeInv (fromIntegral (BSL.length (encode a)))++--------------------------------------------------------------------------------+-- Tests - Encode/Decode Roundtrips++-- | Test that an `encode`/`decode` roundtrip using a `Binary` instance is the identity using `Enum`.+test_encodeDecode :: (Binary a, Bounded a, Enum a, Eq a, Show a) => TestName -> Proxy a -> TestTree+test_encodeDecode testName (_pa :: Proxy a) =+  testGroup testName $+    [ testCase (printf "decode (encode %s) == %s" (show a) (show a)) $ do+        decode (encode a) @?= a+    | (a :: a) <- [minBound .. maxBound]     ]++-- | Test that an `encode`/`decode` roundtrip using a `Binary` instance is the identity using QuickCheck.+prop_encodeDecode :: (Arbitrary a, Binary a, Eq a, Show a) => TestName -> Proxy a -> TestTree+prop_encodeDecode testName (_pa :: Proxy a) =+  testProperty testName $ \(a :: a) ->+    decode (encode a) == a++-- | Variant of `prop_encodeDecode` that accepts a custom generator, show function, and label function.+prop_encodeDecode' :: (Binary a, Eq a) => TestName -> Gen a -> (a -> String) -> Maybe (a -> String) -> TestTree+prop_encodeDecode' testName gen showFor maybeLabelFor =+  prop_encodeDecodeVia' testName gen showFor maybeLabelFor id id++-- | Variant of `prop_encodeDecode` that accepts conversions to/from a type with a `Binary` instance.+prop_encodeDecodeVia :: (Arbitrary a, Eq a, Show a, Binary b) => TestName -> (a -> b) -> (b -> a) -> TestTree+prop_encodeDecodeVia testName to from =+  prop_encodeDecodeVia' testName arbitrary show Nothing to from++-- | Variant of `prop_encodeDecodeVia'` that accepts conversions to/from a type with a `Binary` instance.+prop_encodeDecodeVia' :: (Eq a, Binary b) => TestName -> Gen a -> (a -> String) -> Maybe (a -> String) -> (a -> b) -> (b -> a) -> TestTree+prop_encodeDecodeVia' testName gen showFor maybeLabelFor to from =+  testProperty testName $+    forAllShow gen showFor $ \a ->+      maybe property (label . ($ a)) maybeLabelFor $+        from (decode (encode (to a))) == a++--------------------------------------------------------------------------------+-- Tests - Auxilliary++-- | Test that `chunkCallStack_` works as advertised.+prop_chunkCallStackSizeInv :: TestTree+prop_chunkCallStackSizeInv =+  testProperty "length (encode message) <= messageMaxSize | message <- chunkCallStack callStack" $ \callStack ->+    forAll (choose (messageMinSize, 2 * messageMaxSize)) $ \messageMaxSize' ->+      conjoin+        [ BSL.length (encode message) <= fromIntegral messageMaxSize'+        | message <- chunkCallStack_ (callStackMaxLen' messageMaxSize') callStack+        ]++-- | Test that `chunkCallStack_` and `joinCallStackChunks` are inverses.+prop_chunkAndJoinCallStack :: TestTree+prop_chunkAndJoinCallStack =+  testProperty "joinCallStackChunks (chunkCallStack_ n callStack) == callStack" $+    \(Positive n) callStack ->+      case NonEmpty.nonEmpty (mapMaybe getCallStackFrame (chunkCallStack_ n callStack)) of+        Nothing -> True+        Just callStackChunks -> joinCallStackChunks callStackChunks == callStack++-- | Test that `truncateTextToByteLimit` works as advertised.+prop_truncateTextToByteLimit :: TestTree+prop_truncateTextToByteLimit =+  testProperty "lengthWord8 (truncateTextToByteLimit byteLimit text) <= byteLimit" $+    \(NonNegative byteLimit) (UnicodeString (T.pack -> text)) ->+      label (labelFor byteLimit text) $+        let+          text' = truncateTextToByteLimit byteLimit text+        in+          if TF.lengthWord8 text <= byteLimit+            then+              -- If the original text fit within the byteLimit, the text should be unchanged.+              text == text'+            else+              -- Otherwise:+              and+                [ -- 1. The new text length should be within 3 byte of the byteLimit.+                  byteLimit - 3 <= TF.lengthWord8 text' && TF.lengthWord8 text' <= byteLimit+                , -- 2. The new text should be a prefix of the old text.+                  text' `T.isPrefixOf` text+                ]  where-  chunkingRoundTrip_prop stackSizeLimit message =-    let-      msgs = mapMaybe go (chunkCallStackMessage_ stackSizeLimit message)-      go = \case-        CallStackChunk csm -> Just csm-        CallStackFinal csm -> Just csm-        _ -> Nothing-    in-      catCallStackMessage (NonEmpty.fromList msgs) === message+  labelFor :: Int -> Text -> String+  labelFor byteLimit text+    | TF.lengthWord8 text <= byteLimit = "lengthWord8 text <= byteLimit"+    | otherwise = "lengthWord8 text >  byteLimit" -  messageChunkSize_prop eventlogSize stackSizeLimit message =-    let-      msgs = mapMaybe go (chunkCallStackMessage_ stackSizeLimit message)-      go = \case-        CallStackChunk csm -> Just csm-        CallStackFinal csm -> Just csm-        _ -> Nothing-    in-      conjoin $-        map (eventlogMessageSmallerThanStackSizeLimit_prop (fromIntegral eventlogSize)) msgs+--------------------------------------------------------------------------------+-- Helpers -  eventlogMessageSmallerThanStackSizeLimit_prop :: Word -> BinaryCallStackMessage -> Property-  eventlogMessageSmallerThanStackSizeLimit_prop eventlogLimit chunk =-    let-      -- We need either 'CallStackFinal' or 'CallStackChunk' to add the leading '0xFFCA' or '0xFFCB'.-      -- This way, the eventlogLimit length is the correct thing to check.-      msg = runPut (put $ CallStackFinal chunk)-    in-      (LBS.length msg <= fromIntegral eventlogLimit) === True+-- | Get the `CallStackChunk` from a `Message`.+getCallStackFrame :: Message -> Maybe CallStackChunk+getCallStackFrame = \case+  CallStackFinal callStackChunk -> Just callStackChunk+  CallStackChunk callStackChunk -> Just callStackChunk+  _otherwise -> Nothing -withEventlogSizeGen :: (Word64 -> Property) -> Property-withEventlogSizeGen k =-  -- 29 bytes is minimum possible eventlog size.-  -- 12 bytes need to be subtracted for message overhead.-  -- The largest stack item is 17 bytes.-  forAll (choose (29, 1000)) k+maxBoundWord16 :: Int+maxBoundWord16 = fromIntegral (maxBound @Word16) -instance Arbitrary BinaryCallStackMessage where-  arbitrary =-    MkBinaryCallStackMessage-      <$> (word32ToWord64 <$> arbitrary)-      <*> arbitrary-      <*> arbitrary+--------------------------------------------------------------------------------+-- Generators +instance Arbitrary IpeId where+  arbitrary :: Gen IpeId+  arbitrary = MkIpeId <$> arbitrary++instance Arbitrary ThreadId where+  arbitrary :: Gen ThreadId+  arbitrary = MkThreadId . fromIntegral <$> arbitrary @Word32+ instance Arbitrary CapabilityId where-  arbitrary =-    MkCapabilityId <$> word32ToWord64 <$> arbitrary+  arbitrary :: Gen CapabilityId+  arbitrary = MkCapabilityId . fromIntegral <$> arbitrary @Word32 -instance Arbitrary BinaryStackItem where+instance Arbitrary CallStackFrame where+  arbitrary :: Gen CallStackFrame   arbitrary =     oneof-      [ BinaryIpe <$> arbitrary-      , BinaryMessage <$> arbitrary <*> arbitrary+      [ CallStackFrameIpe <$> arbitrary+      , CallStackFrameAnn <$> arbitrary <*> arbitrary       ] -instance Arbitrary IpeId where-  arbitrary =-    MkIpeId <$> arbitrary+instance Arbitrary CallStackChunk where+  arbitrary :: Gen CallStackChunk+  arbitrary = MkCallStackChunk <$> arbitrary <*> arbitrary <*> (NonEmpty.toList <$> arbitrary)  instance Arbitrary StringId where-  arbitrary =-    MkStringId <$> arbitrary+  arbitrary :: Gen StringId+  arbitrary = MkStringId <$> arbitrary +instance Arbitrary StringDef where+  arbitrary :: Gen StringDef+  arbitrary = MkStringDef <$> arbitrary <*> arbitraryUnicodeText+ instance Arbitrary SourceLocationId where-  arbitrary =-    MkSourceLocationId <$> arbitrary+  arbitrary :: Gen SourceLocationId+  arbitrary = MkSourceLocationId <$> arbitrary++instance Arbitrary SourceLocationDef where+  arbitrary :: Gen SourceLocationDef+  arbitrary = MkSourceLocationDef <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ShortText where+  arbitrary :: Gen ShortText+  arbitrary = toShortText <$> arbitraryUnicodeText++arbitraryUnicodeText :: Gen Text+arbitraryUnicodeText = T.pack . getUnicodeString <$> arbitrary