{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module: Capnp.Message
-- Description: Cap'N Proto messages
--
-- This module provides support for working directly with Cap'N Proto messages.
module Capnp.Message
  ( Message,
    Segment,
    Mutability (..),

    -- * Reading and writing messages
    hPutMsg,
    hGetMsg,
    putMsg,
    getMsg,
    readMessage,
    writeMessage,

    -- * Limits on message size
    maxSegmentSize,
    maxSegments,
    maxCaps,

    -- * Converting between messages and 'ByteString's
    encode,
    decode,
    toByteString,
    fromByteString,

    -- * Accessing underlying storage
    segToVecMut,

    -- * Immutable messages
    empty,
    singleSegment,

    -- * Reading data from messages
    MonadReadMessage (..),
    getCap,
    getCapTable,
    getWord,
    totalNumWords,

    -- * Mutable Messages
    newMessage,

    -- ** Allocating space in messages
    WordPtr (..),
    alloc,
    allocInSeg,
    newSegment,

    -- ** Modifying messages
    setSegment,
    write,
    setCap,
    appendCap,
    WriteCtx,
    Client,
    nullClient,
    invalidClient,
    withCapTable,
  )
where

import Capnp.Address (WordAddr (..))
import Capnp.Bits (WordCount (..), hi, lo)
import qualified Capnp.Errors as E
import Capnp.Mutability (MaybeMutable (..), Mutability (..))
import Capnp.TraversalLimit (LimitT, MonadLimit (invoice), evalLimitT)
import Control.Monad (void, when, (>=>))
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.Primitive (PrimMonad, PrimState, stToPrim)
import Control.Monad.State (evalStateT, get, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (execWriterT, tell)
import Data.Bits (shiftL)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import Data.ByteString.Internal (ByteString (..))
import Data.Bytes.Get (getWord32le, runGetS)
import Data.Maybe (fromJust)
import Data.Primitive (MutVar, newMutVar, readMutVar, writeMutVar)
import qualified Data.Vector as V
import qualified Data.Vector.Generic.Mutable as GMV
import qualified Data.Vector.Mutable as MV
import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Storable.Mutable as SMV
import Data.Word (Word32, Word64, byteSwap64)
import GHC.ByteOrder (ByteOrder (..), targetByteOrder)
import Internal.AppendVec (AppendVec)
import qualified Internal.AppendVec as AppendVec
import Internal.Rpc.Breaker (Client, invalidClient, nullClient)
import System.IO (Handle, stdin, stdout)
import Prelude hiding (read)

swapIfBE64, fromLE64, toLE64 :: Word64 -> Word64
swapIfBE64 :: Word64 -> Word64
swapIfBE64 = case ByteOrder
targetByteOrder of
  ByteOrder
LittleEndian -> forall a. a -> a
id
  ByteOrder
BigEndian -> Word64 -> Word64
byteSwap64
fromLE64 :: Word64 -> Word64
fromLE64 = Word64 -> Word64
swapIfBE64
toLE64 :: Word64 -> Word64
toLE64 = Word64 -> Word64
swapIfBE64

-- | The maximum size of a segment supported by this libarary, in words.
maxSegmentSize :: WordCount
maxSegmentSize :: WordCount
maxSegmentSize = Int -> WordCount
WordCount forall a b. (a -> b) -> a -> b
$ Int
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
28 -- 2 GiB.

-- | The maximum number of segments allowed in a message by this library.
maxSegments :: Int
maxSegments :: Int
maxSegments = Int
1024

-- | The maximum number of capabilities allowed in a message by this library.
maxCaps :: Int
maxCaps :: Int
maxCaps = Int
16 forall a. Num a => a -> a -> a
* Int
1024

-- | A pointer to a location in a message. This encodes the same
-- information as a 'WordAddr', but also includes direct references
-- to the segment and message, which can improve performance in very
-- low-level code.
data WordPtr mut = WordPtr
  -- invariants:
  --
  -- - pAddr's segment index refers to pSegment.
  -- - pSegment is in pMessage.
  { forall (mut :: Mutability). WordPtr mut -> Message mut
pMessage :: !(Message mut),
    forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment :: !(Segment mut),
    forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr :: {-# UNPACK #-} !WordAddr
  }

-- | A Cap'n Proto message, parametrized over its mutability.
data family Message (mut :: Mutability)

newtype instance Message 'Const = MsgConst ConstMsg
  deriving (Message 'Const -> Message 'Const -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message 'Const -> Message 'Const -> Bool
$c/= :: Message 'Const -> Message 'Const -> Bool
== :: Message 'Const -> Message 'Const -> Bool
$c== :: Message 'Const -> Message 'Const -> Bool
Eq)

newtype instance Message ('Mut s) = MsgMut (MutMsg s)
  deriving (Message ('Mut s) -> Message ('Mut s) -> Bool
forall s. Message ('Mut s) -> Message ('Mut s) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message ('Mut s) -> Message ('Mut s) -> Bool
$c/= :: forall s. Message ('Mut s) -> Message ('Mut s) -> Bool
== :: Message ('Mut s) -> Message ('Mut s) -> Bool
$c== :: forall s. Message ('Mut s) -> Message ('Mut s) -> Bool
Eq)

-- | A segment in a Cap'n Proto message.
data family Segment (mut :: Mutability)

newtype instance Segment 'Const = SegConst ConstSegment
  deriving (Segment 'Const -> Segment 'Const -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Segment 'Const -> Segment 'Const -> Bool
$c/= :: Segment 'Const -> Segment 'Const -> Bool
== :: Segment 'Const -> Segment 'Const -> Bool
$c== :: Segment 'Const -> Segment 'Const -> Bool
Eq)

newtype instance Segment ('Mut s) = SegMut (MutSegment s)
  deriving (Segment ('Mut s) -> Segment ('Mut s) -> Bool
forall s. Segment ('Mut s) -> Segment ('Mut s) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Segment ('Mut s) -> Segment ('Mut s) -> Bool
$c/= :: forall s. Segment ('Mut s) -> Segment ('Mut s) -> Bool
== :: Segment ('Mut s) -> Segment ('Mut s) -> Bool
$c== :: forall s. Segment ('Mut s) -> Segment ('Mut s) -> Bool
Eq)

data MutSegment s = MutSegment
  { forall s. MutSegment s -> MVector s Word64
vec :: SMV.MVector s Word64,
    forall s. MutSegment s -> MutVar s WordCount
used :: MutVar s WordCount
  }

-- | Return the underlying storage of a mutable segment, as a vector.
--
-- Note that the elements of the vector will be stored in little-endian form, regardless of
-- CPU endianness. This is a low level function that you should probably not use.
segToVecMut :: (PrimMonad m, PrimState m ~ s) => Segment ('Mut s) -> m (SMV.MVector s Word64)
segToVecMut :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Segment ('Mut s) -> m (MVector s Word64)
segToVecMut (SegMut MutSegment {MVector s Word64
vec :: MVector s Word64
vec :: forall s. MutSegment s -> MVector s Word64
vec, MutVar s WordCount
used :: MutVar s WordCount
used :: forall s. MutSegment s -> MutVar s WordCount
used}) = do
  WordCount
count <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
used
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a s. Storable a => Int -> MVector s a -> MVector s a
SMV.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
count) MVector s Word64
vec

instance Eq (MutSegment s) where
  MutSegment {used :: forall s. MutSegment s -> MutVar s WordCount
used = MutVar s WordCount
x} == :: MutSegment s -> MutSegment s -> Bool
== MutSegment {used :: forall s. MutSegment s -> MutVar s WordCount
used = MutVar s WordCount
y} = MutVar s WordCount
x forall a. Eq a => a -> a -> Bool
== MutVar s WordCount
y

newtype ConstSegment = ConstSegment (SV.Vector Word64)
  deriving (ConstSegment -> ConstSegment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstSegment -> ConstSegment -> Bool
$c/= :: ConstSegment -> ConstSegment -> Bool
== :: ConstSegment -> ConstSegment -> Bool
$c== :: ConstSegment -> ConstSegment -> Bool
Eq)

-- | A 'Message' is a (possibly read-only) capnproto message. It is
-- parameterized over a monad in which operations are performed.
class Monad m => MonadReadMessage mut m where
  -- | 'numSegs' gets the number of segments in a message.
  numSegs :: Message mut -> m Int

  -- | 'numWords' gets the number of words in a segment.
  numWords :: Segment mut -> m WordCount

  -- | 'numCaps' gets the number of capabilities in a message's capability
  -- table.
  numCaps :: Message mut -> m Int

  -- | @'getSegment' message index@ gets the segment at index 'index'
  -- in 'message'.
  getSegment :: Message mut -> Int -> m (Segment mut)

  -- | @'internalGetCap' cap index@ reads a capability from the message's
  -- capability table, returning the client. does not check bounds. Callers
  -- should use getCap instead.
  internalGetCap :: Message mut -> Int -> m Client

  -- | @'slice' start length segment@ extracts a sub-section of the segment,
  -- starting at index @start@, of length @length@.
  slice :: WordCount -> WordCount -> Segment mut -> m (Segment mut)

  -- | @'read' segment index@ reads a 64-bit word from the segement at the
  -- given index. Consider using 'getWord' on the message, instead of
  -- calling this directly.
  read :: Segment mut -> WordCount -> m Word64

-- | Convert a ByteString to a segment. O(1)
fromByteString :: ByteString -> Segment 'Const
-- FIXME: Verify that the pointer is actually 64-bit aligned before casting.
fromByteString :: ByteString -> Segment 'Const
fromByteString (PS ForeignPtr Word8
fptr Int
offset Int
len) =
  ConstSegment -> Segment 'Const
SegConst forall a b. (a -> b) -> a -> b
$ Vector Word64 -> ConstSegment
ConstSegment (forall a b. (Storable a, Storable b) => Vector a -> Vector b
SV.unsafeCast forall a b. (a -> b) -> a -> b
$ forall a. Storable a => ForeignPtr a -> Int -> Int -> Vector a
SV.unsafeFromForeignPtr ForeignPtr Word8
fptr Int
offset Int
len)

-- | Convert a segment to a byte string. O(1)
toByteString :: Segment 'Const -> ByteString
toByteString :: Segment 'Const -> ByteString
toByteString (SegConst (ConstSegment Vector Word64
vec)) = ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
fptr Int
offset Int
len
  where
    (ForeignPtr Word8
fptr, Int
offset, Int
len) = forall a. Vector a -> (ForeignPtr a, Int, Int)
SV.unsafeToForeignPtr (forall a b. (Storable a, Storable b) => Vector a -> Vector b
SV.unsafeCast Vector Word64
vec)

-- | @'withCapTable'@ replaces the capability table in the message.
withCapTable :: V.Vector Client -> Message 'Const -> Message 'Const
withCapTable :: Vector Client -> Message 'Const -> Message 'Const
withCapTable Vector Client
newCaps (MsgConst ConstMsg
msg) = ConstMsg -> Message 'Const
MsgConst forall a b. (a -> b) -> a -> b
$ ConstMsg
msg {constCaps :: Vector Client
constCaps = Vector Client
newCaps}

-- | 'getCapTable' gets the capability table from a 'ConstMsg'.
getCapTable :: Message 'Const -> V.Vector Client
getCapTable :: Message 'Const -> Vector Client
getCapTable (MsgConst ConstMsg {Vector Client
constCaps :: Vector Client
constCaps :: ConstMsg -> Vector Client
constCaps}) = Vector Client
constCaps

-- | 'getWord' gets the word referred to by the 'WordPtr'
getWord :: MonadReadMessage mut m => WordPtr mut -> m Word64
getWord :: forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
getWord WordPtr {Segment mut
pSegment :: Segment mut
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr = WordAt {WordCount
wordIndex :: WordAddr -> WordCount
wordIndex :: WordCount
wordIndex}} = forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
read Segment mut
pSegment WordCount
wordIndex

-- | @'getCap' message index@ gets the capability with the given index from
-- the message. throws 'E.BoundsError' if the index is out
-- of bounds.
getCap :: (MonadThrow m, MonadReadMessage mut m) => Message mut -> Int -> m Client
getCap :: forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m Client
getCap Message mut
msg Int
i = do
  Int
ncaps <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numCaps Message mut
msg
  if Int
i forall a. Ord a => a -> a -> Bool
>= Int
ncaps Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
< Int
0
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Client
invalidClient forall a b. (a -> b) -> a -> b
$ String
"capability index out of bounds: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i)
    else Message mut
msg forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m Client
`internalGetCap` Int
i

-- | @'setSegment' message index segment@ sets the segment at the given index
-- in the message.
setSegment :: WriteCtx m s => Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
setSegment :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
setSegment (MsgMut MutMsg {MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs}) Int
segIndex Segment ('Mut s)
seg = do
  MVector s (Segment ('Mut s))
segs <- forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs
  forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s (Segment ('Mut s))
segs Int
segIndex Segment ('Mut s)
seg

-- | @'setCap' message index cap@ sets the sets the capability at @index@ in
-- the message's capability table to @cap@. If the index is out of bounds, a
-- 'E.BoundsError' will be thrown.
setCap :: WriteCtx m s => Message ('Mut s) -> Int -> Client -> m ()
setCap :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> Client -> m ()
setCap msg :: Message ('Mut s)
msg@(MsgMut MutMsg {MutVar s (AppendVec MVector s Client)
mutCaps :: forall s. MutMsg s -> MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps}) Int
i Client
cap = do
  forall (m :: * -> *). MonadThrow m => Int -> Int -> m ()
checkIndex Int
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numCaps Message ('Mut s)
msg
  MVector s Client
capTable <- forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
mutCaps
  forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s Client
capTable Int
i Client
cap

-- | 'appendCap' appends a new capabilty to the end of a message's capability
-- table, returning its index.
appendCap :: WriteCtx m s => Message ('Mut s) -> Client -> m Int
appendCap :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m Int
appendCap msg :: Message ('Mut s)
msg@(MsgMut MutMsg {MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps :: forall s. MutMsg s -> MutVar s (AppendVec MVector s Client)
mutCaps}) Client
cap = do
  Int
i <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numCaps Message ('Mut s)
msg
  AppendVec MVector s Client
capTable <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
mutCaps
  AppendVec MVector s Client
capTable <- forall (m :: * -> *) s (v :: * -> * -> *) a.
(MonadThrow m, PrimMonad m, s ~ PrimState m, MVector v a) =>
AppendVec v s a -> Int -> Int -> m (AppendVec v s a)
AppendVec.grow AppendVec MVector s Client
capTable Int
1 Int
maxCaps
  forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (AppendVec MVector s Client)
mutCaps AppendVec MVector s Client
capTable
  forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> Client -> m ()
setCap Message ('Mut s)
msg Int
i Client
cap
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i

-- | A read-only capnproto message.
--
-- 'ConstMsg' is an instance of the generic 'Message' type class.
data ConstMsg = ConstMsg
  { ConstMsg -> Vector (Segment 'Const)
constSegs :: V.Vector (Segment 'Const),
    ConstMsg -> Vector Client
constCaps :: V.Vector Client
  }
  deriving (ConstMsg -> ConstMsg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstMsg -> ConstMsg -> Bool
$c/= :: ConstMsg -> ConstMsg -> Bool
== :: ConstMsg -> ConstMsg -> Bool
$c== :: ConstMsg -> ConstMsg -> Bool
Eq)

instance Monad m => MonadReadMessage 'Const m where
  numSegs :: Message 'Const -> m Int
numSegs (MsgConst ConstMsg {Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: ConstMsg -> Vector (Segment 'Const)
constSegs}) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
V.length Vector (Segment 'Const)
constSegs
  numCaps :: Message 'Const -> m Int
numCaps (MsgConst ConstMsg {Vector Client
constCaps :: Vector Client
constCaps :: ConstMsg -> Vector Client
constCaps}) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
V.length Vector Client
constCaps
  getSegment :: Message 'Const -> Int -> m (Segment 'Const)
getSegment (MsgConst ConstMsg {Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: ConstMsg -> Vector (Segment 'Const)
constSegs}) Int
i = Vector (Segment 'Const)
constSegs forall (m :: * -> *) a. Monad m => Vector a -> Int -> m a
`V.indexM` Int
i
  internalGetCap :: Message 'Const -> Int -> m Client
internalGetCap (MsgConst ConstMsg {Vector Client
constCaps :: Vector Client
constCaps :: ConstMsg -> Vector Client
constCaps}) Int
i = Vector Client
constCaps forall (m :: * -> *) a. Monad m => Vector a -> Int -> m a
`V.indexM` Int
i

  numWords :: Segment 'Const -> m WordCount
numWords (SegConst (ConstSegment Vector Word64
vec)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> WordCount
WordCount forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> Int
SV.length Vector Word64
vec
  slice :: WordCount -> WordCount -> Segment 'Const -> m (Segment 'Const)
slice (WordCount Int
start) (WordCount Int
len) (SegConst (ConstSegment Vector Word64
vec)) =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ConstSegment -> Segment 'Const
SegConst forall a b. (a -> b) -> a -> b
$ Vector Word64 -> ConstSegment
ConstSegment (forall a. Storable a => Int -> Int -> Vector a -> Vector a
SV.slice Int
start Int
len Vector Word64
vec)
  read :: Segment 'Const -> WordCount -> m Word64
read (SegConst (ConstSegment Vector Word64
vec)) WordCount
i = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Word64 -> Word64
fromLE64 forall a b. (a -> b) -> a -> b
$! Vector Word64
vec forall a. Storable a => Vector a -> Int -> a
SV.! forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
i

-- | 'decode' decodes a message from a bytestring.
--
-- The segments will not be copied; the resulting message will be a view into
-- the original bytestring. Runs in O(number of segments in the message).
decode :: MonadThrow m => ByteString -> m (Message 'Const)
decode :: forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
decode ByteString
bytes = forall (m :: * -> *).
MonadThrow m =>
Segment 'Const -> m (Message 'Const)
decodeSeg (ByteString -> Segment 'Const
fromByteString ByteString
bytes)

-- | 'encode' encodes a message as a bytestring builder.
encode :: Message 'Const -> BB.Builder
encode :: Message 'Const -> Builder
encode Message 'Const
msg =
  -- We use Maybe as the MonadThrow instance required by
  -- writeMessage/toByteString, but we know this can't actually fail,
  -- so we ignore errors.
  forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *).
MonadThrow m =>
Message 'Const
-> (Word32 -> m ()) -> (Segment 'Const -> m ()) -> m ()
writeMessage
        Message 'Const
msg
        (forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
BB.word32LE)
        (forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BB.byteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment 'Const -> ByteString
toByteString)

-- | 'decodeSeg' decodes a message from a segment, treating the segment as if
-- it were raw bytes.
--
-- this is mostly here as a helper for 'decode'.
decodeSeg :: MonadThrow m => Segment 'Const -> m (Message 'Const)
decodeSeg :: forall (m :: * -> *).
MonadThrow m =>
Segment 'Const -> m (Message 'Const)
decodeSeg Segment 'Const
seg = do
  WordCount
len <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords Segment 'Const
seg
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall a. Maybe a
Nothing, WordCount
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
len forall a b. (a -> b) -> a -> b
$
      -- Note: we use the traversal limit to avoid needing to do bounds checking
      -- here; since readMessage invoices the limit before reading, we can rely
      -- on it not to read past the end of the blob.
      --
      -- TODO: while this works, it means that we throw 'TraversalLimitError'
      -- on failure, which makes for a confusing API.
      forall (m :: * -> *).
(MonadThrow m, MonadLimit m) =>
m Word32 -> (WordCount -> m (Segment 'Const)) -> m (Message 'Const)
readMessage LimitT (StateT (Maybe Word32, WordCount) m) Word32
read32 WordCount
-> LimitT (StateT (Maybe Word32, WordCount) m) (Segment 'Const)
readSegment
  where
    read32 :: LimitT (StateT (Maybe Word32, WordCount) m) Word32
read32 = do
      (Maybe Word32
cur, WordCount
idx) <- forall s (m :: * -> *). MonadState s m => m s
get
      case Maybe Word32
cur of
        Just Word32
n -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall a. Maybe a
Nothing, WordCount
idx)
          forall (m :: * -> *) a. Monad m => a -> m a
return Word32
n
        Maybe Word32
Nothing -> do
          Word64
word <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
read Segment 'Const
seg WordCount
idx
          forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word64 -> Word32
hi Word64
word, WordCount
idx forall a. Num a => a -> a -> a
+ WordCount
1)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Word32
lo Word64
word)
    readSegment :: WordCount
-> LimitT (StateT (Maybe Word32, WordCount) m) (Segment 'Const)
readSegment WordCount
len = do
      (Maybe Word32
cur, WordCount
idx) <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Word32
cur, WordCount
idx forall a. Num a => a -> a -> a
+ WordCount
len)
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordCount -> WordCount -> Segment mut -> m (Segment mut)
slice WordCount
idx WordCount
len Segment 'Const
seg

-- | @'readMessage' read32 readSegment@ reads in a message using the
-- monadic context, which should manage the current read position,
-- into a message. read32 should read a 32-bit little-endian integer,
-- and @readSegment n@ should read a blob of @n@ 64-bit words.
-- The size of the message (in 64-bit words) is deducted from the traversal,
-- limit which can be used to set the maximum message size.
readMessage :: (MonadThrow m, MonadLimit m) => m Word32 -> (WordCount -> m (Segment 'Const)) -> m (Message 'Const)
readMessage :: forall (m :: * -> *).
(MonadThrow m, MonadLimit m) =>
m Word32 -> (WordCount -> m (Segment 'Const)) -> m (Message 'Const)
readMessage m Word32
read32 WordCount -> m (Segment 'Const)
readSegment = do
  forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice WordCount
1
  Word32
numSegs' <- m Word32
read32
  let numSegs :: Word32
numSegs = Word32
numSegs' forall a. Num a => a -> a -> a
+ Word32
1
  forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numSegs forall a. Integral a => a -> a -> a
`div` WordCount
2)
  Vector Word32
segSizes <- forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numSegs) m Word32
read32
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Integral a => a -> Bool
even Word32
numSegs) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void m Word32
read32
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Vector Word32
segSizes
  Vector (Segment 'Const)
constSegs <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (WordCount -> m (Segment 'Const)
readSegment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Vector Word32
segSizes
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ConstMsg -> Message 'Const
MsgConst ConstMsg {Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs, constCaps :: Vector Client
constCaps = forall a. Vector a
V.empty}

-- | @'writeMesage' write32 writeSegment@ writes out the message. @write32@
-- should write a 32-bit word in little-endian format to the output stream.
-- @writeSegment@ should write a blob.
writeMessage :: MonadThrow m => Message 'Const -> (Word32 -> m ()) -> (Segment 'Const -> m ()) -> m ()
writeMessage :: forall (m :: * -> *).
MonadThrow m =>
Message 'Const
-> (Word32 -> m ()) -> (Segment 'Const -> m ()) -> m ()
writeMessage (MsgConst ConstMsg {Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: ConstMsg -> Vector (Segment 'Const)
constSegs}) Word32 -> m ()
write32 Segment 'Const -> m ()
writeSegment = do
  let numSegs :: Int
numSegs = forall a. Vector a -> Int
V.length Vector (Segment 'Const)
constSegs
  Word32 -> m ()
write32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numSegs forall a. Num a => a -> a -> a
- Word32
1)
  forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (Segment 'Const)
constSegs forall a b. (a -> b) -> a -> b
$ \Segment 'Const
seg -> Word32 -> m ()
write32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords Segment 'Const
seg
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Integral a => a -> Bool
even Int
numSegs) forall a b. (a -> b) -> a -> b
$ Word32 -> m ()
write32 Word32
0
  forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (Segment 'Const)
constSegs Segment 'Const -> m ()
writeSegment

-- | @'hPutMsg' handle msg@ writes @msg@ to @handle@. If there is an exception,
-- it will be an 'IOError' raised by the underlying IO libraries.
hPutMsg :: Handle -> Message 'Const -> IO ()
hPutMsg :: Handle -> Message 'Const -> IO ()
hPutMsg Handle
handle Message 'Const
msg = Handle -> Builder -> IO ()
BB.hPutBuilder Handle
handle (Message 'Const -> Builder
encode Message 'Const
msg)

-- | Equivalent to @'hPutMsg' 'stdout'@
putMsg :: Message 'Const -> IO ()
putMsg :: Message 'Const -> IO ()
putMsg = Handle -> Message 'Const -> IO ()
hPutMsg Handle
stdout

-- | @'hGetMsg' handle limit@ reads a message from @handle@ that is at most
-- @limit@ 64-bit words in length.
hGetMsg :: Handle -> WordCount -> IO (Message 'Const)
hGetMsg :: Handle -> WordCount -> IO (Message 'Const)
hGetMsg Handle
handle WordCount
size =
  forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
size forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadThrow m, MonadLimit m) =>
m Word32 -> (WordCount -> m (Segment 'Const)) -> m (Message 'Const)
readMessage LimitT IO Word32
read32 WordCount -> LimitT IO (Segment 'Const)
readSegment
  where
    read32 :: LimitT IO Word32
    read32 :: LimitT IO Word32
read32 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
      ByteString
bytes <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
4
      case forall a. Get a -> ByteString -> Either String a
runGetS forall (m :: * -> *). MonadGet m => m Word32
getWord32le ByteString
bytes of
        Left String
_ ->
          -- the only way this can happen is if we get < 4 bytes.
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> Error
E.InvalidDataError String
"Unexpected end of input"
        Right Word32
result ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
result
    readSegment :: WordCount -> LimitT IO (Segment 'Const)
readSegment WordCount
n =
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteString -> Segment 'Const
fromByteString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Int -> IO ByteString
BS.hGet Handle
handle (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
n forall a. Num a => a -> a -> a
* Int
8))

-- | Equivalent to @'hGetMsg' 'stdin'@
getMsg :: WordCount -> IO (Message 'Const)
getMsg :: WordCount -> IO (Message 'Const)
getMsg = Handle -> WordCount -> IO (Message 'Const)
hGetMsg Handle
stdin

-- | A 'MutMsg' is a mutable capnproto message. The type parameter @s@ is the
-- state token for the instance of 'PrimMonad' in which the message may be
-- modified.
data MutMsg s = MutMsg
  { forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MV.MVector s (Segment ('Mut s))),
    forall s. MutMsg s -> MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MV.MVector s Client)
  }
  deriving (MutMsg s -> MutMsg s -> Bool
forall s. MutMsg s -> MutMsg s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MutMsg s -> MutMsg s -> Bool
$c/= :: forall s. MutMsg s -> MutMsg s -> Bool
== :: MutMsg s -> MutMsg s -> Bool
$c== :: forall s. MutMsg s -> MutMsg s -> Bool
Eq)

-- | 'WriteCtx' is the context needed for most write operations.
type WriteCtx m s = (PrimMonad m, s ~ PrimState m, MonadThrow m)

instance (PrimMonad m, s ~ PrimState m) => MonadReadMessage ('Mut s) m where
  numWords :: Segment ('Mut s) -> m WordCount
numWords (SegMut MutSegment {MutVar s WordCount
used :: MutVar s WordCount
used :: forall s. MutSegment s -> MutVar s WordCount
used}) = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
used
  slice :: WordCount -> WordCount -> Segment ('Mut s) -> m (Segment ('Mut s))
slice (WordCount Int
start) (WordCount Int
len) (SegMut MutSegment {MVector s Word64
vec :: MVector s Word64
vec :: forall s. MutSegment s -> MVector s Word64
vec, MutVar s WordCount
used :: MutVar s WordCount
used :: forall s. MutSegment s -> MutVar s WordCount
used}) = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim forall a b. (a -> b) -> a -> b
$ do
    WordCount Int
end <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
used
    let len' :: Int
len' = forall a. Ord a => a -> a -> a
min (Int
end forall a. Num a => a -> a -> a
- Int
start) Int
len
    MutVar s WordCount
used' <- forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar forall a b. (a -> b) -> a -> b
$ Int -> WordCount
WordCount Int
len'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall s. MutSegment s -> Segment ('Mut s)
SegMut
        MutSegment
          { vec :: MVector s Word64
vec = forall a s. Storable a => Int -> Int -> MVector s a -> MVector s a
SMV.slice Int
start Int
len' MVector s Word64
vec,
            used :: MutVar s WordCount
used = MutVar s WordCount
used'
          }
  read :: Segment ('Mut s) -> WordCount -> m Word64
read (SegMut MutSegment {MVector s Word64
vec :: MVector s Word64
vec :: forall s. MutSegment s -> MVector s Word64
vec}) WordCount
i =
    forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim forall a b. (a -> b) -> a -> b
$
      Word64 -> Word64
fromLE64 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
SMV.read MVector s Word64
vec (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
i)
  numSegs :: Message ('Mut s) -> m Int
numSegs (MsgMut MutMsg {MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs}) =
    forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim forall a b. (a -> b) -> a -> b
$ forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
GMV.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs
  numCaps :: Message ('Mut s) -> m Int
numCaps (MsgMut MutMsg {MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps :: forall s. MutMsg s -> MutVar s (AppendVec MVector s Client)
mutCaps}) =
    forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim forall a b. (a -> b) -> a -> b
$ forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
GMV.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
mutCaps
  getSegment :: Message ('Mut s) -> Int -> m (Segment ('Mut s))
getSegment (MsgMut MutMsg {MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs}) Int
i = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim forall a b. (a -> b) -> a -> b
$ do
    MVector s (Segment ('Mut s))
segs <- forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs
    forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s (Segment ('Mut s))
segs Int
i
  internalGetCap :: Message ('Mut s) -> Int -> m Client
internalGetCap (MsgMut MutMsg {MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps :: forall s. MutMsg s -> MutVar s (AppendVec MVector s Client)
mutCaps}) Int
i = forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim forall a b. (a -> b) -> a -> b
$ do
    MVector s Client
caps <- forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
mutCaps
    forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s Client
caps Int
i

-- | @'write' segment index value@ writes a value to the 64-bit word
-- at the provided index. Consider using 'setWord' on the message,
-- instead of calling this directly.
write :: WriteCtx m s => Segment ('Mut s) -> WordCount -> Word64 -> m ()
{-# INLINE write #-}
write :: forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
write (SegMut MutSegment {MVector s Word64
vec :: MVector s Word64
vec :: forall s. MutSegment s -> MVector s Word64
vec}) (WordCount Int
i) Word64
val = do
  forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
SMV.write MVector s Word64
vec Int
i (Word64 -> Word64
toLE64 Word64
val)

-- | @'newSegment' msg sizeHint@ allocates a new, initially empty segment in
-- @msg@ with a capacity of @sizeHint@ words. It returns the a pair of the
-- segment number and the segment itself. Amortized O(1).
newSegment :: WriteCtx m s => Message ('Mut s) -> WordCount -> m (Int, Segment ('Mut s))
newSegment :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (Int, Segment ('Mut s))
newSegment msg :: Message ('Mut s)
msg@(MsgMut MutMsg {MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs}) WordCount
sizeHint = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WordCount
sizeHint forall a. Ord a => a -> a -> Bool
> WordCount
maxSegmentSize) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Error
E.SizeError
  -- the next segment number will be equal to the *current* number of
  -- segments:
  Int
segIndex <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message ('Mut s)
msg

  -- make space for th new segment
  AppendVec MVector s (Segment ('Mut s))
segs <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs
  AppendVec MVector s (Segment ('Mut s))
segs <- forall (m :: * -> *) s (v :: * -> * -> *) a.
(MonadThrow m, PrimMonad m, s ~ PrimState m, MVector v a) =>
AppendVec v s a -> Int -> Int -> m (AppendVec v s a)
AppendVec.grow AppendVec MVector s (Segment ('Mut s))
segs Int
1 Int
maxSegments
  forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs AppendVec MVector s (Segment ('Mut s))
segs

  MVector s Word64
vec <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
SMV.new (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
sizeHint)
  MutVar s WordCount
used <- forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar WordCount
0
  let newSeg :: Segment ('Mut s)
newSeg = forall s. MutSegment s -> Segment ('Mut s)
SegMut MutSegment {MVector s Word64
vec :: MVector s Word64
vec :: MVector s Word64
vec, MutVar s WordCount
used :: MutVar s WordCount
used :: MutVar s WordCount
used}
  forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
setSegment Message ('Mut s)
msg Int
segIndex Segment ('Mut s)
newSeg
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
segIndex, Segment ('Mut s)
newSeg)

-- | Like 'alloc', but the second argument allows the caller to specify the
-- index of the segment in which to allocate the data. Returns 'Nothing' if there is
-- insufficient space in that segment..
allocInSeg :: WriteCtx m s => Message ('Mut s) -> Int -> WordCount -> m (Maybe (WordPtr ('Mut s)))
{-# INLINE allocInSeg #-}
allocInSeg :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Int -> WordCount -> m (Maybe (WordPtr ('Mut s)))
allocInSeg Message ('Mut s)
msg Int
segIndex WordCount
size = do
  -- GHC's type inference aparently isn't smart enough to figure
  -- out that the pattern irrefutable if we do seg@(SegMut ...) <- ...
  -- but this works:
  Segment ('Mut s)
seg <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
getSegment Message ('Mut s)
msg Int
segIndex
  case Segment ('Mut s)
seg of
    SegMut MutSegment {MVector s Word64
vec :: MVector s Word64
vec :: forall s. MutSegment s -> MVector s Word64
vec, MutVar s WordCount
used :: MutVar s WordCount
used :: forall s. MutSegment s -> MutVar s WordCount
used} -> do
      WordCount
nextAlloc <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
used
      if Int -> WordCount
WordCount (forall a s. Storable a => MVector s a -> Int
SMV.length MVector s Word64
vec) forall a. Num a => a -> a -> a
- WordCount
nextAlloc forall a. Ord a => a -> a -> Bool
< WordCount
size
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        else
          ( do
              forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s WordCount
used forall a b. (a -> b) -> a -> b
$! WordCount
nextAlloc forall a. Num a => a -> a -> a
+ WordCount
size
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                forall a. a -> Maybe a
Just
                  WordPtr
                    { pAddr :: WordAddr
pAddr =
                        WordAt
                          { Int
segIndex :: Int
segIndex :: Int
segIndex,
                            wordIndex :: WordCount
wordIndex = WordCount
nextAlloc
                          },
                      pSegment :: Segment ('Mut s)
pSegment = Segment ('Mut s)
seg,
                      pMessage :: Message ('Mut s)
pMessage = Message ('Mut s)
msg
                    }
          )

-- | @'alloc' size@ allocates 'size' words within a message. it returns the
-- starting address of the allocated memory, as well as a direct reference
-- to the segment. The latter is redundant information, but this is used
-- in low-level code where this can improve performance.
alloc :: WriteCtx m s => Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
{-# INLINEABLE alloc #-}
alloc :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
alloc Message ('Mut s)
msg WordCount
size = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WordCount
size forall a. Ord a => a -> a -> Bool
> WordCount
maxSegmentSize) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Error
E.SizeError
  Int
segIndex <- forall a. Enum a => a -> a
pred forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message ('Mut s)
msg
  Maybe (WordPtr ('Mut s))
existing <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Int -> WordCount -> m (Maybe (WordPtr ('Mut s)))
allocInSeg Message ('Mut s)
msg Int
segIndex WordCount
size
  case Maybe (WordPtr ('Mut s))
existing of
    Just WordPtr ('Mut s)
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure WordPtr ('Mut s)
res
    Maybe (WordPtr ('Mut s))
Nothing -> do
      -- Not enough space in the current segment; allocate a new one.
      -- the new segment's size should match the total size of existing segments
      -- but `maxSegmentSize` bounds how large it can get.
      WordCount
totalAllocation <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m WordCount
totalNumWords Message ('Mut s)
msg
      (Int
newSegIndex, Segment ('Mut s)
_) <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (Int, Segment ('Mut s))
newSegment Message ('Mut s)
msg (forall a. Ord a => a -> a -> a
min (forall a. Ord a => a -> a -> a
max WordCount
totalAllocation WordCount
size) WordCount
maxSegmentSize)
      -- This is guaranteed to succeed, since we just made a segment with
      -- at least size available space:
      forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Int -> WordCount -> m (Maybe (WordPtr ('Mut s)))
allocInSeg Message ('Mut s)
msg Int
newSegIndex WordCount
size

-- | Return the total number of words in the message, i.e. the sum of
-- the results of `numWords` on all segments.
totalNumWords :: MonadReadMessage mut m => Message mut -> m WordCount
totalNumWords :: forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m WordCount
totalNumWords Message mut
msg = do
  Int
lastSegIndex <- forall a. Enum a => a -> a
pred forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message mut
msg
  forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
getSegment Message mut
msg forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords) [Int
0 .. Int
lastSegIndex]

-- | 'empty' is an empty message, i.e. a minimal message with a null pointer as
-- its root object.
empty :: Message 'Const
empty :: Message 'Const
empty =
  ConstMsg -> Message 'Const
MsgConst
    ConstMsg
      { constSegs :: Vector (Segment 'Const)
constSegs = forall a. [a] -> Vector a
V.fromList [ConstSegment -> Segment 'Const
SegConst forall a b. (a -> b) -> a -> b
$ Vector Word64 -> ConstSegment
ConstSegment forall a b. (a -> b) -> a -> b
$ forall a. Storable a => [a] -> Vector a
SV.fromList [Word64
0]],
        constCaps :: Vector Client
constCaps = forall a. Vector a
V.empty
      }

-- | @'newMessage' sizeHint@ allocates a new empty message, with a single segment
-- having capacity @sizeHint@. If @sizeHint@ is 'Nothing', defaults to a sensible
-- value.
newMessage :: WriteCtx m s => Maybe WordCount -> m (Message ('Mut s))
newMessage :: forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
newMessage Maybe WordCount
Nothing = forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
newMessage (forall a. a -> Maybe a
Just WordCount
32)
-- The default value above is somewhat arbitrary, and just a guess -- we
-- should do some profiling to figure out what a good value is here.
newMessage (Just WordCount
sizeHint) = do
  MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new Int
1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.makeEmpty
  MutVar s (AppendVec MVector s Client)
mutCaps <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new Int
0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.makeEmpty
  let msg :: Message ('Mut s)
msg = forall s. MutMsg s -> Message ('Mut s)
MsgMut MutMsg {MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs, MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps}
  -- allocte the first segment, and make space for the root pointer:
  (Int, Segment ('Mut s))
_ <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (Int, Segment ('Mut s))
newSegment Message ('Mut s)
msg WordCount
sizeHint
  WordPtr ('Mut s)
_ <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
alloc Message ('Mut s)
msg WordCount
1
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg

-- | Create a message from a single segment.
singleSegment :: Segment 'Const -> Message 'Const
singleSegment :: Segment 'Const -> Message 'Const
singleSegment Segment 'Const
seg =
  ConstMsg -> Message 'Const
MsgConst
    ConstMsg
      { constSegs :: Vector (Segment 'Const)
constSegs = forall a. a -> Vector a
V.singleton Segment 'Const
seg,
        constCaps :: Vector Client
constCaps = forall a. Vector a
V.empty
      }

instance MaybeMutable Segment where
  thaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Segment 'Const -> m (Segment ('Mut s))
thaw = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Vector Word64 -> m (MVector s Word64))
-> Segment 'Const -> m (Segment ('Mut s))
thawSeg forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
SV.thaw
  unsafeThaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Segment 'Const -> m (Segment ('Mut s))
unsafeThaw = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Vector Word64 -> m (MVector s Word64))
-> Segment 'Const -> m (Segment ('Mut s))
thawSeg forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
SV.unsafeThaw
  freeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Segment ('Mut s) -> m (Segment 'Const)
freeze = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(MVector s Word64 -> m (Vector Word64))
-> Segment ('Mut s) -> m (Segment 'Const)
freezeSeg forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
SV.freeze
  unsafeFreeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Segment ('Mut s) -> m (Segment 'Const)
unsafeFreeze = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(MVector s Word64 -> m (Vector Word64))
-> Segment ('Mut s) -> m (Segment 'Const)
freezeSeg forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
SV.unsafeFreeze

-- Helpers for @Segment ConstMsg@'s Thaw instance.
thawSeg ::
  (PrimMonad m, s ~ PrimState m) =>
  (SV.Vector Word64 -> m (SMV.MVector s Word64)) ->
  Segment 'Const ->
  m (Segment ('Mut s))
thawSeg :: forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Vector Word64 -> m (MVector s Word64))
-> Segment 'Const -> m (Segment ('Mut s))
thawSeg Vector Word64 -> m (MVector s Word64)
thaw (SegConst (ConstSegment Vector Word64
vec)) = do
  MVector s Word64
mvec <- Vector Word64 -> m (MVector s Word64)
thaw Vector Word64
vec
  MutVar s WordCount
used <- forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar forall a b. (a -> b) -> a -> b
$ Int -> WordCount
WordCount forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> Int
SV.length Vector Word64
vec
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s. MutSegment s -> Segment ('Mut s)
SegMut MutSegment {vec :: MVector s Word64
vec = MVector s Word64
mvec, MutVar s WordCount
used :: MutVar s WordCount
used :: MutVar s WordCount
used}

freezeSeg ::
  (PrimMonad m, s ~ PrimState m) =>
  (SMV.MVector s Word64 -> m (SV.Vector Word64)) ->
  Segment ('Mut s) ->
  m (Segment 'Const)
freezeSeg :: forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(MVector s Word64 -> m (Vector Word64))
-> Segment ('Mut s) -> m (Segment 'Const)
freezeSeg MVector s Word64 -> m (Vector Word64)
freeze (SegMut MutSegment {MVector s Word64
vec :: MVector s Word64
vec :: forall s. MutSegment s -> MVector s Word64
vec, MutVar s WordCount
used :: MutVar s WordCount
used :: forall s. MutSegment s -> MutVar s WordCount
used}) = do
  WordCount Int
len <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
used
  ConstSegment -> Segment 'Const
SegConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word64 -> ConstSegment
ConstSegment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector s Word64 -> m (Vector Word64)
freeze (forall a s. Storable a => Int -> MVector s a -> MVector s a
SMV.take Int
len MVector s Word64
vec)

instance MaybeMutable Message where
  thaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Message 'Const -> m (Message ('Mut s))
thaw = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment 'Const -> m (Segment ('Mut s)))
-> (Vector Client -> m (MVector s Client))
-> Message 'Const
-> m (Message ('Mut s))
thawMsg forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
thaw forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.thaw
  unsafeThaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Message 'Const -> m (Message ('Mut s))
unsafeThaw = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment 'Const -> m (Segment ('Mut s)))
-> (Vector Client -> m (MVector s Client))
-> Message 'Const
-> m (Message ('Mut s))
thawMsg forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
unsafeThaw forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.unsafeThaw
  freeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Message ('Mut s) -> m (Message 'Const)
freeze = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment ('Mut s) -> m (Segment 'Const))
-> (MVector s Client -> m (Vector Client))
-> Message ('Mut s)
-> m (Message 'Const)
freezeMsg forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f ('Mut s) -> m (f 'Const)
freeze forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.freeze
  unsafeFreeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Message ('Mut s) -> m (Message 'Const)
unsafeFreeze = forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment ('Mut s) -> m (Segment 'Const))
-> (MVector s Client -> m (Vector Client))
-> Message ('Mut s)
-> m (Message 'Const)
freezeMsg forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f ('Mut s) -> m (f 'Const)
unsafeFreeze forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze

-- Helpers for ConstMsg's Thaw instance.
thawMsg ::
  (PrimMonad m, s ~ PrimState m) =>
  (Segment 'Const -> m (Segment ('Mut s))) ->
  (V.Vector Client -> m (MV.MVector s Client)) ->
  Message 'Const ->
  m (Message ('Mut s))
thawMsg :: forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment 'Const -> m (Segment ('Mut s)))
-> (Vector Client -> m (MVector s Client))
-> Message 'Const
-> m (Message ('Mut s))
thawMsg Segment 'Const -> m (Segment ('Mut s))
thawSeg Vector Client -> m (MVector s Client)
thawCaps (MsgConst ConstMsg {Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: ConstMsg -> Vector (Segment 'Const)
constSegs, Vector Client
constCaps :: Vector Client
constCaps :: ConstMsg -> Vector Client
constCaps}) = do
  MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs <- forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.fromVector forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM Segment 'Const -> m (Segment ('Mut s))
thawSeg Vector (Segment 'Const)
constSegs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.unsafeThaw)
  MutVar s (AppendVec MVector s Client)
mutCaps <- forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.fromVector forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Vector Client -> m (MVector s Client)
thawCaps Vector Client
constCaps
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s. MutMsg s -> Message ('Mut s)
MsgMut MutMsg {MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs, MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps}

freezeMsg ::
  (PrimMonad m, s ~ PrimState m) =>
  (Segment ('Mut s) -> m (Segment 'Const)) ->
  (MV.MVector s Client -> m (V.Vector Client)) ->
  Message ('Mut s) ->
  m (Message 'Const)
freezeMsg :: forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment ('Mut s) -> m (Segment 'Const))
-> (MVector s Client -> m (Vector Client))
-> Message ('Mut s)
-> m (Message 'Const)
freezeMsg Segment ('Mut s) -> m (Segment 'Const)
freezeSeg MVector s Client -> m (Vector Client)
freezeCaps msg :: Message ('Mut s)
msg@(MsgMut MutMsg {MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MVector s Client)
mutCaps :: forall s. MutMsg s -> MutVar s (AppendVec MVector s Client)
mutCaps}) = do
  Int
len <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message ('Mut s)
msg
  Vector (Segment 'Const)
constSegs <- forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM Int
len (forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
getSegment Message ('Mut s)
msg forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Segment ('Mut s) -> m (Segment 'Const)
freezeSeg)
  Vector Client
constCaps <- MVector s Client -> m (Vector Client)
freezeCaps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
mutCaps
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ConstMsg -> Message 'Const
MsgConst ConstMsg {Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs, Vector Client
constCaps :: Vector Client
constCaps :: Vector Client
constCaps}

-- | @'checkIndex' index length@ checkes that 'index' is in the range
-- [0, length), throwing a 'BoundsError' if not.
checkIndex :: MonadThrow m => Int -> Int -> m ()
checkIndex :: forall (m :: * -> *). MonadThrow m => Int -> Int -> m ()
checkIndex Int
i Int
len =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
>= Int
len) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
      E.BoundsError
        { index :: Int
E.index = Int
i,
          maxIndex :: Int
E.maxIndex = Int
len
        }