{-# 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

    -- * Immutable messages
    , empty
    , singleSegment

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

    -- * Mutable Messages
    , newMessage

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

    -- ** Modifying messages
    , setSegment
    , setWord
    , write
    , setCap
    , appendCap

    , WriteCtx

    , Client
    , nullClient
    , withCapTable
    ) where

import {-# SOURCE #-} Capnp.Rpc.Untyped (Client, nullClient)

import Prelude hiding (read)

import Data.Bits (shiftL)

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.ByteString.Internal  (ByteString(..))
import Data.Bytes.Get            (getWord32le, runGetS)
import Data.Kind                 (Type)
import Data.Maybe                (fromJust)
import Data.Primitive            (MutVar, newMutVar, readMutVar, writeMutVar)
import Data.Word                 (Word32, Word64, byteSwap64)
import GHC.ByteOrder             (ByteOrder(..), targetByteOrder)
import System.IO                 (Handle, stdin, stdout)

import qualified Data.ByteString              as BS
import qualified Data.ByteString.Builder      as BB
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 Capnp.Address        (WordAddr(..))
import Capnp.Bits           (WordCount(..), hi, lo)
import Capnp.TraversalLimit (LimitT, MonadLimit(invoice), evalLimitT)
import Data.Mutable         (Mutable(..))
import Internal.AppendVec   (AppendVec)

import qualified Capnp.Errors       as E
import qualified Internal.AppendVec as AppendVec

swapIfBE64, fromLE64, toLE64 :: Word64 -> Word64
swapIfBE64 :: Word64 -> Word64
swapIfBE64 = case ByteOrder
targetByteOrder of
    ByteOrder
LittleEndian -> Word64 -> Word64
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 (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024


-- | 'Mutability' is used as a type parameter (with the DataKinds extension)
-- to indicate the mutability of some values in this library; 'Const' denotes
-- an immutable value, while @'Mut' s@ denotes a value that can be mutated
-- in the scope of the state token @s@.
data Mutability = Const | Mut Type

-- | 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.
    { WordPtr mut -> Message mut
pMessage :: !(Message mut)
    , WordPtr mut -> Segment mut
pSegment :: !(Segment mut)
    , WordPtr mut -> WordAddr
pAddr    :: !WordAddr
    }

-- | A Cap'n Proto message, parametrized over its mutability.
data Message (mut :: Mutability) where
    MsgConst :: !ConstMsg -> Message 'Const
    MsgMut :: !(MutMsg s) -> Message ('Mut s)

instance Eq (Message mut) where
    (MsgConst ConstMsg
x) == :: Message mut -> Message mut -> Bool
== (MsgConst ConstMsg
y) = ConstMsg
x ConstMsg -> ConstMsg -> Bool
forall a. Eq a => a -> a -> Bool
== ConstMsg
y
    (MsgMut MutMsg s
x) == (MsgMut MutMsg s
y)     = MutMsg s
x MutMsg s -> MutMsg s -> Bool
forall a. Eq a => a -> a -> Bool
== MutMsg s
MutMsg s
y

-- | A segment in a Cap'n Proto message.
data Segment (mut :: Mutability) where
    SegConst :: !ConstSegment -> Segment 'Const
    SegMut :: !(MutSegment s) -> Segment ('Mut s)

instance Eq (Segment mut)  where
    (SegConst ConstSegment
x) == :: Segment mut -> Segment mut -> Bool
== (SegConst ConstSegment
y) = ConstSegment
x ConstSegment -> ConstSegment -> Bool
forall a. Eq a => a -> a -> Bool
== ConstSegment
y
    (SegMut MutSegment s
x) == (SegMut MutSegment s
y)     = MutSegment s
x MutSegment s -> MutSegment s -> Bool
forall a. Eq a => a -> a -> Bool
== MutSegment s
MutSegment s
y

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

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 MutVar s WordCount -> MutVar s WordCount -> Bool
forall a. Eq a => a -> a -> Bool
== MutVar s WordCount
y

newtype ConstSegment = ConstSegment (SV.Vector Word64)
    deriving(ConstSegment -> ConstSegment -> Bool
(ConstSegment -> ConstSegment -> Bool)
-> (ConstSegment -> ConstSegment -> Bool) -> Eq ConstSegment
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
    -- | @'internalGetSeg' message index@ gets the segment at index 'index'
    -- in 'message'. Most callers should use the 'getSegment' wrapper, instead
    -- of calling this directly.
    internalGetSeg :: 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 (ConstSegment -> Segment 'Const) -> ConstSegment -> Segment 'Const
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> ConstSegment
ConstSegment (Vector Word8 -> Vector Word64
forall a b. (Storable a, Storable b) => Vector a -> Vector b
SV.unsafeCast (Vector Word8 -> Vector Word64) -> Vector Word8 -> Vector Word64
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> Vector Word8
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) = Vector Word8 -> (ForeignPtr Word8, Int, Int)
forall a. Storable a => Vector a -> (ForeignPtr a, Int, Int)
SV.unsafeToForeignPtr (Vector Word64 -> Vector Word8
forall a b. (Storable a, Storable b) => Vector a -> Vector b
SV.unsafeCast Vector Word64
vec)

-- | @'getSegment' message index@ fetches the given segment in the message.
-- It throws a 'E.BoundsError' if the address is out of bounds.
getSegment :: (MonadThrow m, MonadReadMessage mut m) => Message mut -> Int -> m (Segment mut)
getSegment :: Message mut -> Int -> m (Segment mut)
getSegment Message mut
msg Int
i = do
    Int -> Int -> m ()
forall a (m :: * -> *).
(Integral a, MonadThrow m) =>
a -> a -> m ()
checkIndex Int
i (Int -> m ()) -> m Int -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Message mut -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message mut
msg
    Message mut -> Int -> m (Segment mut)
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
internalGetSeg Message mut
msg Int
i

-- | @'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 (ConstMsg -> Message 'Const) -> ConstMsg -> Message 'Const
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

-- | @'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 :: Message mut -> Int -> m Client
getCap Message mut
msg Int
i = do
    Int
ncaps <- Message mut -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numCaps Message mut
msg
    if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
ncaps Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        then Client -> m Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
nullClient
        else Message mut
msg Message mut -> Int -> m Client
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m Client
`internalGetCap` Int
i

-- | @'getWord' msg addr@ returns the word at @addr@ within @msg@. It throws a
-- 'E.BoundsError' if the address is out of bounds.
getWord :: (MonadThrow m, MonadReadMessage mut m) => Message mut -> WordAddr -> m Word64
getWord :: Message mut -> WordAddr -> m Word64
getWord Message mut
msg WordAt{wordIndex :: WordAddr -> WordCount
wordIndex=WordCount
i, Int
segIndex :: WordAddr -> Int
segIndex :: Int
segIndex} = do
    Segment mut
seg <- Message mut -> Int -> m (Segment mut)
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
getSegment Message mut
msg Int
segIndex
    WordCount -> WordCount -> m ()
forall a (m :: * -> *).
(Integral a, MonadThrow m) =>
a -> a -> m ()
checkIndex WordCount
i (WordCount -> m ()) -> m WordCount -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Segment mut -> m WordCount
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords Segment mut
seg
    Segment mut
seg Segment mut -> WordCount -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
`read` WordCount
i

-- | @'setSegment' message index segment@ sets the segment at the given index
-- in the message. It throws a 'E.BoundsError' if the address is out of bounds.
setSegment :: WriteCtx m s => Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
setSegment :: Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
setSegment Message ('Mut s)
msg Int
i Segment ('Mut s)
seg = do
    Int -> Int -> m ()
forall a (m :: * -> *).
(Integral a, MonadThrow m) =>
a -> a -> m ()
checkIndex Int
i (Int -> m ()) -> m Int -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Message ('Mut s) -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message ('Mut s)
msg
    Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
internalSetSeg Message ('Mut s)
msg Int
i Segment ('Mut s)
seg

-- | @'setWord' message address value@ sets the word at @address@ in the
-- message to @value@. If the address is not valid in the message, a
-- 'E.BoundsError' will be thrown.
setWord :: WriteCtx m s => Message ('Mut s) -> WordAddr -> Word64 -> m ()
setWord :: Message ('Mut s) -> WordAddr -> Word64 -> m ()
setWord Message ('Mut s)
msg WordAt{wordIndex :: WordAddr -> WordCount
wordIndex=WordCount
i, Int
segIndex :: Int
segIndex :: WordAddr -> Int
segIndex} Word64
val = do
    Segment ('Mut s)
seg <- Message ('Mut s) -> Int -> m (Segment ('Mut s))
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
getSegment Message ('Mut s)
msg Int
segIndex
    WordCount -> WordCount -> m ()
forall a (m :: * -> *).
(Integral a, MonadThrow m) =>
a -> a -> m ()
checkIndex WordCount
i (WordCount -> m ()) -> m WordCount -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Segment ('Mut s) -> m WordCount
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords Segment ('Mut s)
seg
    Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
write Segment ('Mut s)
seg WordCount
i Word64
val

-- | @'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 :: 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
    Int -> Int -> m ()
forall a (m :: * -> *).
(Integral a, MonadThrow m) =>
a -> a -> m ()
checkIndex Int
i (Int -> m ()) -> m Int -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Message ('Mut s) -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numCaps Message ('Mut s)
msg
    MVector s Client
capTable <- AppendVec MVector s Client -> MVector s Client
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s Client -> MVector s Client)
-> m (AppendVec MVector s Client) -> m (MVector s Client)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState m) (AppendVec MVector s Client)
-> m (AppendVec MVector s Client)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
MutVar (PrimState m) (AppendVec MVector s Client)
mutCaps
    MVector (PrimState m) Client -> Int -> Client -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s Client
MVector (PrimState m) 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 :: 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 <- Message ('Mut s) -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numCaps Message ('Mut s)
msg
    AppendVec MVector s Client
capTable <- MutVar (PrimState m) (AppendVec MVector s Client)
-> m (AppendVec MVector s Client)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
MutVar (PrimState m) (AppendVec MVector s Client)
mutCaps
    AppendVec MVector s Client
capTable <- AppendVec MVector s Client
-> Int -> Int -> m (AppendVec MVector s Client)
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
    MutVar (PrimState m) (AppendVec MVector s Client)
-> AppendVec MVector s Client -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (AppendVec MVector s Client)
MutVar (PrimState m) (AppendVec MVector s Client)
mutCaps AppendVec MVector s Client
capTable
    Message ('Mut s) -> Int -> Client -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> Client -> m ()
setCap Message ('Mut s)
msg Int
i Client
cap
    Int -> m Int
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
(ConstMsg -> ConstMsg -> Bool)
-> (ConstMsg -> ConstMsg -> Bool) -> Eq ConstMsg
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}) = Int -> m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Vector (Segment 'Const) -> Int
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}) = Int -> m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Vector Client -> Int
forall a. Vector a -> Int
V.length Vector Client
constCaps
    internalGetSeg :: Message 'Const -> Int -> m (Segment 'Const)
internalGetSeg (MsgConst ConstMsg{Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: ConstMsg -> Vector (Segment 'Const)
constSegs}) Int
i = Vector (Segment 'Const)
constSegs Vector (Segment 'Const) -> Int -> m (Segment 'Const)
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 Vector Client -> Int -> m Client
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)) = WordCount -> m WordCount
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WordCount -> m WordCount) -> WordCount -> m WordCount
forall a b. (a -> b) -> a -> b
$ Int -> WordCount
WordCount (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> Int
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)) =
        Segment 'Const -> m (Segment 'Const)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment 'Const -> m (Segment 'Const))
-> Segment 'Const -> m (Segment 'Const)
forall a b. (a -> b) -> a -> b
$ ConstSegment -> Segment 'Const
SegConst (ConstSegment -> Segment 'Const) -> ConstSegment -> Segment 'Const
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> ConstSegment
ConstSegment (Int -> Int -> Vector Word64 -> Vector Word64
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 = Word64 -> m Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> m Word64) -> Word64 -> m Word64
forall a b. (a -> b) -> a -> b
$! Word64 -> Word64
fromLE64 (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$! Vector Word64
vec Vector Word64 -> Int -> Word64
forall a. Storable a => Vector a -> Int -> a
SV.! WordCount -> Int
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 :: ByteString -> m (Message 'Const)
decode ByteString
bytes = Segment 'Const -> m (Message 'Const)
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.
    Maybe Builder -> Builder
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Builder -> Builder) -> Maybe Builder -> Builder
forall a b. (a -> b) -> a -> b
$ WriterT Builder Maybe () -> Maybe Builder
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT Builder Maybe () -> Maybe Builder)
-> WriterT Builder Maybe () -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Message 'Const
-> (Word32 -> WriterT Builder Maybe ())
-> (Segment 'Const -> WriterT Builder Maybe ())
-> WriterT Builder Maybe ()
forall (m :: * -> *).
MonadThrow m =>
Message 'Const
-> (Word32 -> m ()) -> (Segment 'Const -> m ()) -> m ()
writeMessage
        Message 'Const
msg
        (Builder -> WriterT Builder Maybe ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> WriterT Builder Maybe ())
-> (Word32 -> Builder) -> Word32 -> WriterT Builder Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
BB.word32LE)
        (Builder -> WriterT Builder Maybe ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> WriterT Builder Maybe ())
-> (Segment 'Const -> Builder)
-> Segment 'Const
-> WriterT Builder Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BB.byteString (ByteString -> Builder)
-> (Segment 'Const -> ByteString) -> Segment 'Const -> Builder
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 :: Segment 'Const -> m (Message 'Const)
decodeSeg Segment 'Const
seg = do
    WordCount
len <- Segment 'Const -> m WordCount
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords Segment 'Const
seg
    (StateT (Maybe Word32, WordCount) m (Message 'Const)
 -> (Maybe Word32, WordCount) -> m (Message 'Const))
-> (Maybe Word32, WordCount)
-> StateT (Maybe Word32, WordCount) m (Message 'Const)
-> m (Message 'Const)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Maybe Word32, WordCount) m (Message 'Const)
-> (Maybe Word32, WordCount) -> m (Message 'Const)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Maybe Word32
forall a. Maybe a
Nothing, WordCount
0) (StateT (Maybe Word32, WordCount) m (Message 'Const)
 -> m (Message 'Const))
-> StateT (Maybe Word32, WordCount) m (Message 'Const)
-> m (Message 'Const)
forall a b. (a -> b) -> a -> b
$ WordCount
-> LimitT (StateT (Maybe Word32, WordCount) m) (Message 'Const)
-> StateT (Maybe Word32, WordCount) m (Message 'Const)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
len (LimitT (StateT (Maybe Word32, WordCount) m) (Message 'Const)
 -> StateT (Maybe Word32, WordCount) m (Message 'Const))
-> LimitT (StateT (Maybe Word32, WordCount) m) (Message 'Const)
-> StateT (Maybe Word32, WordCount) m (Message 'Const)
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.
        LimitT (StateT (Maybe Word32, WordCount) m) Word32
-> (WordCount
    -> LimitT (StateT (Maybe Word32, WordCount) m) (Segment 'Const))
-> LimitT (StateT (Maybe Word32, WordCount) m) (Message 'Const)
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) <- LimitT
  (StateT (Maybe Word32, WordCount) m) (Maybe Word32, WordCount)
forall s (m :: * -> *). MonadState s m => m s
get
        case Maybe Word32
cur of
            Just Word32
n -> do
                (Maybe Word32, WordCount)
-> LimitT (StateT (Maybe Word32, WordCount) m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Word32
forall a. Maybe a
Nothing, WordCount
idx)
                Word32 -> LimitT (StateT (Maybe Word32, WordCount) m) Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
n
            Maybe Word32
Nothing -> do
                Word64
word <- StateT (Maybe Word32, WordCount) m Word64
-> LimitT (StateT (Maybe Word32, WordCount) m) Word64
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Maybe Word32, WordCount) m Word64
 -> LimitT (StateT (Maybe Word32, WordCount) m) Word64)
-> StateT (Maybe Word32, WordCount) m Word64
-> LimitT (StateT (Maybe Word32, WordCount) m) Word64
forall a b. (a -> b) -> a -> b
$ m Word64 -> StateT (Maybe Word32, WordCount) m Word64
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Word64 -> StateT (Maybe Word32, WordCount) m Word64)
-> m Word64 -> StateT (Maybe Word32, WordCount) m Word64
forall a b. (a -> b) -> a -> b
$ Segment 'Const -> WordCount -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
read Segment 'Const
seg WordCount
idx
                (Maybe Word32, WordCount)
-> LimitT (StateT (Maybe Word32, WordCount) m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Word32 -> Maybe Word32
forall a. a -> Maybe a
Just (Word32 -> Maybe Word32) -> Word32 -> Maybe Word32
forall a b. (a -> b) -> a -> b
$ Word64 -> Word32
hi Word64
word, WordCount
idx WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
1)
                Word32 -> LimitT (StateT (Maybe Word32, WordCount) m) Word32
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) <- LimitT
  (StateT (Maybe Word32, WordCount) m) (Maybe Word32, WordCount)
forall s (m :: * -> *). MonadState s m => m s
get
        (Maybe Word32, WordCount)
-> LimitT (StateT (Maybe Word32, WordCount) m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Word32
cur, WordCount
idx WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
len)
        StateT (Maybe Word32, WordCount) m (Segment 'Const)
-> LimitT (StateT (Maybe Word32, WordCount) m) (Segment 'Const)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Maybe Word32, WordCount) m (Segment 'Const)
 -> LimitT (StateT (Maybe Word32, WordCount) m) (Segment 'Const))
-> StateT (Maybe Word32, WordCount) m (Segment 'Const)
-> LimitT (StateT (Maybe Word32, WordCount) m) (Segment 'Const)
forall a b. (a -> b) -> a -> b
$ m (Segment 'Const)
-> StateT (Maybe Word32, WordCount) m (Segment 'Const)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Segment 'Const)
 -> StateT (Maybe Word32, WordCount) m (Segment 'Const))
-> m (Segment 'Const)
-> StateT (Maybe Word32, WordCount) m (Segment 'Const)
forall a b. (a -> b) -> a -> b
$ WordCount -> WordCount -> Segment 'Const -> m (Segment 'Const)
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 :: m Word32 -> (WordCount -> m (Segment 'Const)) -> m (Message 'Const)
readMessage m Word32
read32 WordCount -> m (Segment 'Const)
readSegment = do
    WordCount -> m ()
forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice WordCount
1
    Word32
numSegs' <- m Word32
read32
    let numSegs :: Word32
numSegs = Word32
numSegs' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1
    WordCount -> m ()
forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice (Word32 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numSegs WordCount -> WordCount -> WordCount
forall a. Integral a => a -> a -> a
`div` WordCount
2)
    Vector Word32
segSizes <- Int -> m Word32 -> m (Vector Word32)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numSegs) m Word32
read32
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32 -> Bool
forall a. Integral a => a -> Bool
even Word32
numSegs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m Word32 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Word32
read32
    (Word32 -> m ()) -> Vector Word32 -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (WordCount -> m ()
forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice (WordCount -> m ()) -> (Word32 -> WordCount) -> Word32 -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Vector Word32
segSizes
    Vector (Segment 'Const)
constSegs <- (Word32 -> m (Segment 'Const))
-> Vector Word32 -> m (Vector (Segment 'Const))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (WordCount -> m (Segment 'Const)
readSegment (WordCount -> m (Segment 'Const))
-> (Word32 -> WordCount) -> Word32 -> m (Segment 'Const)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Vector Word32
segSizes
    Message 'Const -> m (Message 'Const)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message 'Const -> m (Message 'Const))
-> Message 'Const -> m (Message 'Const)
forall a b. (a -> b) -> a -> b
$ ConstMsg -> Message 'Const
MsgConst ConstMsg :: Vector (Segment 'Const) -> Vector Client -> ConstMsg
ConstMsg{Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs :: Vector (Segment 'Const)
constSegs, constCaps :: Vector Client
constCaps = Vector Client
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 :: 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 = Vector (Segment 'Const) -> Int
forall a. Vector a -> Int
V.length Vector (Segment 'Const)
constSegs
    Word32 -> m ()
write32 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numSegs Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1)
    Vector (Segment 'Const) -> (Segment 'Const -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (Segment 'Const)
constSegs ((Segment 'Const -> m ()) -> m ())
-> (Segment 'Const -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Segment 'Const
seg -> Word32 -> m ()
write32 (Word32 -> m ()) -> (WordCount -> Word32) -> WordCount -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordCount -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordCount -> m ()) -> m WordCount -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Segment 'Const -> m WordCount
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords Segment 'Const
seg
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
forall a. Integral a => a -> Bool
even Int
numSegs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> m ()
write32 Word32
0
    Vector (Segment 'Const) -> (Segment 'Const -> m ()) -> m ()
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 =
    WordCount -> LimitT IO (Message 'Const) -> IO (Message 'Const)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
size (LimitT IO (Message 'Const) -> IO (Message 'Const))
-> LimitT IO (Message 'Const) -> IO (Message 'Const)
forall a b. (a -> b) -> a -> b
$ LimitT IO Word32
-> (WordCount -> LimitT IO (Segment 'Const))
-> LimitT IO (Message 'Const)
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 = IO Word32 -> LimitT IO Word32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Word32 -> LimitT IO Word32) -> IO Word32 -> LimitT IO Word32
forall a b. (a -> b) -> a -> b
$ do
        ByteString
bytes <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
4
        case Get Word32 -> ByteString -> Either String Word32
forall a. Get a -> ByteString -> Either String a
runGetS Get Word32
forall (m :: * -> *). MonadGet m => m Word32
getWord32le ByteString
bytes of
            Left String
_ ->
                -- the only way this can happen is if we get < 4 bytes.
                Error -> IO Word32
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> IO Word32) -> Error -> IO Word32
forall a b. (a -> b) -> a -> b
$ String -> Error
E.InvalidDataError String
"Unexpected end of input"
            Right Word32
result ->
                Word32 -> IO Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
result
    readSegment :: WordCount -> LimitT IO (Segment 'Const)
readSegment WordCount
n =
        IO (Segment 'Const) -> LimitT IO (Segment 'Const)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteString -> Segment 'Const
fromByteString (ByteString -> Segment 'Const)
-> IO ByteString -> IO (Segment 'Const)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Int -> IO ByteString
BS.hGet Handle
handle (WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
n Int -> Int -> Int
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
    { MutMsg s -> MutVar s (AppendVec MVector s (Segment ('Mut s)))
mutSegs :: MutVar s (AppendVec MV.MVector s (Segment ('Mut s)))
    , MutMsg s -> MutVar s (AppendVec MVector s Client)
mutCaps :: MutVar s (AppendVec MV.MVector s Client)
    }
    deriving(MutMsg s -> MutMsg s -> Bool
(MutMsg s -> MutMsg s -> Bool)
-> (MutMsg s -> MutMsg s -> Bool) -> Eq (MutMsg s)
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}) = ST (PrimState m) WordCount -> m WordCount
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) WordCount -> m WordCount)
-> ST (PrimState m) WordCount -> m WordCount
forall a b. (a -> b) -> a -> b
$ MutVar (PrimState (ST s)) WordCount -> ST s WordCount
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
MutVar (PrimState (ST 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}) = ST (PrimState m) (Segment ('Mut s)) -> m (Segment ('Mut s))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) (Segment ('Mut s)) -> m (Segment ('Mut s)))
-> ST (PrimState m) (Segment ('Mut s)) -> m (Segment ('Mut s))
forall a b. (a -> b) -> a -> b
$ do
        WordCount Int
end <- MutVar (PrimState (ST s)) WordCount -> ST s WordCount
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
MutVar (PrimState (ST s)) WordCount
used
        let len' :: Int
len' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Int
len
        MutVar s WordCount
used' <- WordCount -> ST s (MutVar (PrimState (ST s)) WordCount)
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (WordCount -> ST s (MutVar (PrimState (ST s)) WordCount))
-> WordCount -> ST s (MutVar (PrimState (ST s)) WordCount)
forall a b. (a -> b) -> a -> b
$ Int -> WordCount
WordCount Int
len'
        Segment ('Mut s) -> ST s (Segment ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment ('Mut s) -> ST s (Segment ('Mut s)))
-> Segment ('Mut s) -> ST s (Segment ('Mut s))
forall a b. (a -> b) -> a -> b
$ MutSegment s -> Segment ('Mut s)
forall s. MutSegment s -> Segment ('Mut s)
SegMut MutSegment :: forall s. MVector s Word64 -> MutVar s WordCount -> MutSegment s
MutSegment
            { vec :: MVector s Word64
vec = Int -> Int -> MVector s Word64 -> MVector s Word64
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 = ST (PrimState m) Word64 -> m Word64
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) Word64 -> m Word64)
-> ST (PrimState m) Word64 -> m Word64
forall a b. (a -> b) -> a -> b
$
        Word64 -> Word64
fromLE64 (Word64 -> Word64) -> ST s Word64 -> ST s Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Word64 -> Int -> ST s Word64
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
SMV.read MVector s Word64
MVector (PrimState (ST s)) Word64
vec (WordCount -> Int
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}) =
        ST (PrimState m) Int -> m Int
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) Int -> m Int) -> ST (PrimState m) Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector s (Segment ('Mut s)) -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
GMV.length (MVector s (Segment ('Mut s)) -> Int)
-> (AppendVec MVector s (Segment ('Mut s))
    -> MVector s (Segment ('Mut s)))
-> AppendVec MVector s (Segment ('Mut s))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppendVec MVector s (Segment ('Mut s))
-> MVector s (Segment ('Mut s))
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s (Segment ('Mut s)) -> Int)
-> ST s (AppendVec MVector s (Segment ('Mut s))) -> ST s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState (ST s)) (AppendVec MVector s (Segment ('Mut s)))
-> ST s (AppendVec MVector s (Segment ('Mut s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
MutVar (PrimState (ST 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}) =
        ST (PrimState m) Int -> m Int
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) Int -> m Int) -> ST (PrimState m) Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector s Client -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
GMV.length (MVector s Client -> Int)
-> (AppendVec MVector s Client -> MVector s Client)
-> AppendVec MVector s Client
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppendVec MVector s Client -> MVector s Client
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s Client -> Int)
-> ST s (AppendVec MVector s Client) -> ST s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState (ST s)) (AppendVec MVector s Client)
-> ST s (AppendVec MVector s Client)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
MutVar (PrimState (ST s)) (AppendVec MVector s Client)
mutCaps
    internalGetSeg :: Message ('Mut s) -> Int -> m (Segment ('Mut s))
internalGetSeg (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 = ST (PrimState m) (Segment ('Mut s)) -> m (Segment ('Mut s))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) (Segment ('Mut s)) -> m (Segment ('Mut s)))
-> ST (PrimState m) (Segment ('Mut s)) -> m (Segment ('Mut s))
forall a b. (a -> b) -> a -> b
$ do
        MVector s (Segment ('Mut s))
segs <- AppendVec MVector s (Segment ('Mut s))
-> MVector s (Segment ('Mut s))
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s (Segment ('Mut s))
 -> MVector s (Segment ('Mut s)))
-> ST s (AppendVec MVector s (Segment ('Mut s)))
-> ST s (MVector s (Segment ('Mut s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState (ST s)) (AppendVec MVector s (Segment ('Mut s)))
-> ST s (AppendVec MVector s (Segment ('Mut s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
MutVar (PrimState (ST s)) (AppendVec MVector s (Segment ('Mut s)))
mutSegs
        MVector (PrimState (ST s)) (Segment ('Mut s))
-> Int -> ST s (Segment ('Mut s))
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s (Segment ('Mut s))
MVector (PrimState (ST 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 = ST (PrimState m) Client -> m Client
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) Client -> m Client)
-> ST (PrimState m) Client -> m Client
forall a b. (a -> b) -> a -> b
$ do
        MVector s Client
caps <- AppendVec MVector s Client -> MVector s Client
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s Client -> MVector s Client)
-> ST s (AppendVec MVector s Client) -> ST s (MVector s Client)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState (ST s)) (AppendVec MVector s Client)
-> ST s (AppendVec MVector s Client)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
MutVar (PrimState (ST s)) (AppendVec MVector s Client)
mutCaps
        MVector (PrimState (ST s)) Client -> Int -> ST s Client
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s Client
MVector (PrimState (ST s)) Client
caps Int
i


-- | @'internalSetSeg' message index segment@ sets the segment at the given
-- index in the message. Most callers should use the 'setSegment' wrapper,
-- instead of calling this directly.
internalSetSeg :: WriteCtx m s => Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
internalSetSeg :: Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
internalSetSeg (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
segIndex Segment ('Mut s)
seg = do
    MVector s (Segment ('Mut s))
segs <- AppendVec MVector s (Segment ('Mut s))
-> MVector s (Segment ('Mut s))
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s (Segment ('Mut s))
 -> MVector s (Segment ('Mut s)))
-> m (AppendVec MVector s (Segment ('Mut s)))
-> m (MVector s (Segment ('Mut s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState m) (AppendVec MVector s (Segment ('Mut s)))
-> m (AppendVec MVector s (Segment ('Mut s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
MutVar (PrimState m) (AppendVec MVector s (Segment ('Mut s)))
mutSegs
    MVector (PrimState m) (Segment ('Mut s))
-> Int -> Segment ('Mut s) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s (Segment ('Mut s))
MVector (PrimState m) (Segment ('Mut s))
segs Int
segIndex Segment ('Mut s)
Segment ('Mut s)
seg

-- | @'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 ()
write :: 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
    MVector (PrimState m) Word64 -> Int -> Word64 -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
SMV.write MVector s Word64
MVector (PrimState m) 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 :: 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
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WordCount
sizeHint WordCount -> WordCount -> Bool
forall a. Ord a => a -> a -> Bool
> WordCount
maxSegmentSize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Error -> m ()
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 <- Message ('Mut s) -> m Int
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 <- MutVar (PrimState m) (AppendVec MVector s (Segment ('Mut s)))
-> m (AppendVec MVector s (Segment ('Mut s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
MutVar (PrimState m) (AppendVec MVector s (Segment ('Mut s)))
mutSegs
    AppendVec MVector s (Segment ('Mut s))
segs <- AppendVec MVector s (Segment ('Mut s))
-> Int -> Int -> m (AppendVec MVector s (Segment ('Mut s)))
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
    MutVar (PrimState m) (AppendVec MVector s (Segment ('Mut s)))
-> AppendVec MVector s (Segment ('Mut s)) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (AppendVec MVector s (Segment ('Mut s)))
MutVar (PrimState m) (AppendVec MVector s (Segment ('Mut s)))
mutSegs AppendVec MVector s (Segment ('Mut s))
segs

    MVector s Word64
vec <- Int -> m (MVector (PrimState m) Word64)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
SMV.new (WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
sizeHint)
    MutVar s WordCount
used <- WordCount -> m (MutVar (PrimState m) WordCount)
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar WordCount
0
    let newSeg :: Segment ('Mut s)
newSeg = MutSegment s -> Segment ('Mut s)
forall s. MutSegment s -> Segment ('Mut s)
SegMut MutSegment :: forall s. MVector s Word64 -> MutVar s WordCount -> MutSegment s
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}
    Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()
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
    (Int, Segment ('Mut s)) -> m (Int, Segment ('Mut s))
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)))
allocInSeg :: 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 <- Message ('Mut s) -> Int -> m (Segment ('Mut s))
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow 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 <- MutVar (PrimState m) WordCount -> m WordCount
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
MutVar (PrimState m) WordCount
used
            if Int -> WordCount
WordCount (MVector s Word64 -> Int
forall a s. Storable a => MVector s a -> Int
SMV.length MVector s Word64
vec) WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
- WordCount
nextAlloc WordCount -> WordCount -> Bool
forall a. Ord a => a -> a -> Bool
< WordCount
size
                then Maybe (WordPtr ('Mut s)) -> m (Maybe (WordPtr ('Mut s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (WordPtr ('Mut s))
forall a. Maybe a
Nothing
                else (do
                    MutVar (PrimState m) WordCount -> WordCount -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s WordCount
MutVar (PrimState m) WordCount
used (WordCount -> m ()) -> WordCount -> m ()
forall a b. (a -> b) -> a -> b
$! WordCount
nextAlloc WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
size
                    Maybe (WordPtr ('Mut s)) -> m (Maybe (WordPtr ('Mut s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (WordPtr ('Mut s)) -> m (Maybe (WordPtr ('Mut s))))
-> Maybe (WordPtr ('Mut s)) -> m (Maybe (WordPtr ('Mut s)))
forall a b. (a -> b) -> a -> b
$ WordPtr ('Mut s) -> Maybe (WordPtr ('Mut s))
forall a. a -> Maybe a
Just WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
WordPtr
                        { pAddr :: WordAddr
pAddr = WordAt :: Int -> WordCount -> WordAddr
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))
alloc :: Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
alloc Message ('Mut s)
msg WordCount
size = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WordCount
size WordCount -> WordCount -> Bool
forall a. Ord a => a -> a -> Bool
> WordCount
maxSegmentSize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Error -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Error
E.SizeError
    Int
segIndex <- Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> m Int -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message ('Mut s)
msg
    Maybe (WordPtr ('Mut s))
existing <- Message ('Mut s)
-> Int -> WordCount -> m (Maybe (WordPtr ('Mut s)))
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 -> WordPtr ('Mut s) -> m (WordPtr ('Mut s))
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 <- [WordCount] -> WordCount
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([WordCount] -> WordCount) -> m [WordCount] -> m WordCount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                (Int -> m WordCount) -> [Int] -> m [WordCount]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Message ('Mut s) -> Int -> m (Segment ('Mut s))
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
getSegment Message ('Mut s)
msg (Int -> m (Segment ('Mut s)))
-> (Segment ('Mut s) -> m WordCount) -> Int -> m WordCount
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Segment ('Mut s) -> m WordCount
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
numWords) [Int
0..Int
segIndex]
            ( Int
newSegIndex, Segment ('Mut s)
_ ) <- Message ('Mut s) -> WordCount -> m (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 -> WordCount -> WordCount
forall a. Ord a => a -> a -> a
min (WordCount -> WordCount -> WordCount
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:
            Maybe (WordPtr ('Mut s)) -> WordPtr ('Mut s)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (WordPtr ('Mut s)) -> WordPtr ('Mut s))
-> m (Maybe (WordPtr ('Mut s))) -> m (WordPtr ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> Int -> WordCount -> m (Maybe (WordPtr ('Mut s)))
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

-- | '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 :: Vector (Segment 'Const) -> Vector Client -> ConstMsg
ConstMsg
    { constSegs :: Vector (Segment 'Const)
constSegs = [Segment 'Const] -> Vector (Segment 'Const)
forall a. [a] -> Vector a
V.fromList [ ConstSegment -> Segment 'Const
SegConst (ConstSegment -> Segment 'Const) -> ConstSegment -> Segment 'Const
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> ConstSegment
ConstSegment (Vector Word64 -> ConstSegment) -> Vector Word64 -> ConstSegment
forall a b. (a -> b) -> a -> b
$ [Word64] -> Vector Word64
forall a. Storable a => [a] -> Vector a
SV.fromList [Word64
0] ]
    , constCaps :: Vector Client
constCaps = Vector Client
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 :: Maybe WordCount -> m (Message ('Mut s))
newMessage Maybe WordCount
Nothing = Maybe WordCount -> m (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
newMessage (WordCount -> Maybe WordCount
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 <- Int -> m (MVector (PrimState m) (Segment ('Mut s)))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new Int
1 m (MVector s (Segment ('Mut s)))
-> (MVector s (Segment ('Mut s))
    -> m (MutVar s (AppendVec MVector s (Segment ('Mut s)))))
-> m (MutVar s (AppendVec MVector s (Segment ('Mut s))))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppendVec MVector s (Segment ('Mut s))
-> m (MutVar s (AppendVec MVector s (Segment ('Mut s))))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (AppendVec MVector s (Segment ('Mut s))
 -> m (MutVar s (AppendVec MVector s (Segment ('Mut s)))))
-> (MVector s (Segment ('Mut s))
    -> AppendVec MVector s (Segment ('Mut s)))
-> MVector s (Segment ('Mut s))
-> m (MutVar s (AppendVec MVector s (Segment ('Mut s))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s (Segment ('Mut s))
-> AppendVec MVector s (Segment ('Mut s))
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.makeEmpty
    MutVar s (AppendVec MVector s Client)
mutCaps <- Int -> m (MVector (PrimState m) Client)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new Int
0 m (MVector s Client)
-> (MVector s Client -> m (MutVar s (AppendVec MVector s Client)))
-> m (MutVar s (AppendVec MVector s Client))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppendVec MVector s Client
-> m (MutVar s (AppendVec MVector s Client))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (AppendVec MVector s Client
 -> m (MutVar s (AppendVec MVector s Client)))
-> (MVector s Client -> AppendVec MVector s Client)
-> MVector s Client
-> m (MutVar s (AppendVec MVector s Client))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s Client -> AppendVec MVector s Client
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.makeEmpty
    let msg :: Message ('Mut s)
msg = MutMsg s -> Message ('Mut s)
forall s. MutMsg s -> Message ('Mut s)
MsgMut MutMsg :: forall s.
MutVar s (AppendVec MVector s (Segment ('Mut s)))
-> MutVar s (AppendVec MVector s Client) -> MutMsg s
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))
_ <- Message ('Mut s) -> WordCount -> m (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)
_ <- Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
alloc Message ('Mut s)
msg WordCount
1
    Message ('Mut s) -> m (Message ('Mut s))
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 :: Vector (Segment 'Const) -> Vector Client -> ConstMsg
ConstMsg
    { constSegs :: Vector (Segment 'Const)
constSegs = Segment 'Const -> Vector (Segment 'Const)
forall a. a -> Vector a
V.singleton Segment 'Const
seg
    , constCaps :: Vector Client
constCaps = Vector Client
forall a. Vector a
V.empty
    }


instance Thaw (Segment 'Const) where
    type Mutable s (Segment 'Const) = Segment ('Mut s)

    thaw :: Segment 'Const -> m (Mutable s (Segment 'Const))
thaw         = (Vector Word64 -> m (MVector s Word64))
-> Segment 'Const -> m (Segment ('Mut s))
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)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
SV.thaw
    unsafeThaw :: Segment 'Const -> m (Mutable s (Segment 'Const))
unsafeThaw   = (Vector Word64 -> m (MVector s Word64))
-> Segment 'Const -> m (Segment ('Mut s))
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)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
SV.unsafeThaw
    freeze :: Mutable s (Segment 'Const) -> m (Segment 'Const)
freeze       = (MVector s Word64 -> m (Vector Word64))
-> Segment ('Mut s) -> m (Segment 'Const)
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)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
SV.freeze
    unsafeFreeze :: Mutable s (Segment 'Const) -> m (Segment 'Const)
unsafeFreeze = (MVector s Word64 -> m (Vector Word64))
-> Segment ('Mut s) -> m (Segment 'Const)
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)
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 :: (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 <- WordCount -> m (MutVar (PrimState m) WordCount)
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (WordCount -> m (MutVar (PrimState m) WordCount))
-> WordCount -> m (MutVar (PrimState m) WordCount)
forall a b. (a -> b) -> a -> b
$ Int -> WordCount
WordCount (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> Int
forall a. Storable a => Vector a -> Int
SV.length Vector Word64
vec
    Segment ('Mut s) -> m (Segment ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment ('Mut s) -> m (Segment ('Mut s)))
-> Segment ('Mut s) -> m (Segment ('Mut s))
forall a b. (a -> b) -> a -> b
$ MutSegment s -> Segment ('Mut s)
forall s. MutSegment s -> Segment ('Mut s)
SegMut MutSegment :: forall s. MVector s Word64 -> MutVar s WordCount -> MutSegment s
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 :: (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 <- MutVar (PrimState m) WordCount -> m WordCount
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s WordCount
MutVar (PrimState m) WordCount
used
    ConstSegment -> Segment 'Const
SegConst (ConstSegment -> Segment 'Const)
-> (Vector Word64 -> ConstSegment)
-> Vector Word64
-> Segment 'Const
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Vector Word64 -> ConstSegment
ConstSegment (Vector Word64 -> Segment 'Const)
-> m (Vector Word64) -> m (Segment 'Const)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector s Word64 -> m (Vector Word64)
freeze (Int -> MVector s Word64 -> MVector s Word64
forall a s. Storable a => Int -> MVector s a -> MVector s a
SMV.take Int
len MVector s Word64
vec)

instance Thaw (Message 'Const) where
    type Mutable s (Message 'Const) = Message ('Mut s)

    thaw :: Message 'Const -> m (Mutable s (Message 'Const))
thaw         = (Segment 'Const -> m (Segment ('Mut s)))
-> (Vector Client -> m (MVector s Client))
-> Message 'Const
-> m (Message ('Mut s))
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))
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw         Vector Client -> m (MVector s Client)
forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.thaw
    unsafeThaw :: Message 'Const -> m (Mutable s (Message 'Const))
unsafeThaw   = (Segment 'Const -> m (Segment ('Mut s)))
-> (Vector Client -> m (MVector s Client))
-> Message 'Const
-> m (Message ('Mut s))
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))
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
unsafeThaw   Vector Client -> m (MVector s Client)
forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.unsafeThaw
    freeze :: Mutable s (Message 'Const) -> m (Message 'Const)
freeze       = (Segment ('Mut s) -> m (Segment 'Const))
-> (MVector s Client -> m (Vector Client))
-> Message ('Mut s)
-> m (Message 'Const)
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)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze       MVector s Client -> m (Vector Client)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.freeze
    unsafeFreeze :: Mutable s (Message 'Const) -> m (Message 'Const)
unsafeFreeze = (Segment ('Mut s) -> m (Segment 'Const))
-> (MVector s Client -> m (Vector Client))
-> Message ('Mut s)
-> m (Message 'Const)
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)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
unsafeFreeze MVector s Client -> m (Vector Client)
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 :: (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 <- AppendVec MVector s (Segment ('Mut s))
-> m (MutVar s (AppendVec MVector s (Segment ('Mut s))))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (AppendVec MVector s (Segment ('Mut s))
 -> m (MutVar s (AppendVec MVector s (Segment ('Mut s)))))
-> (MVector s (Segment ('Mut s))
    -> AppendVec MVector s (Segment ('Mut s)))
-> MVector s (Segment ('Mut s))
-> m (MutVar s (AppendVec MVector s (Segment ('Mut s))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s (Segment ('Mut s))
-> AppendVec MVector s (Segment ('Mut s))
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.fromVector (MVector s (Segment ('Mut s))
 -> m (MutVar s (AppendVec MVector s (Segment ('Mut s)))))
-> m (MVector s (Segment ('Mut s)))
-> m (MutVar s (AppendVec MVector s (Segment ('Mut s))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Segment 'Const -> m (Segment ('Mut s)))
-> Vector (Segment 'Const) -> m (Vector (Segment ('Mut s)))
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 m (Vector (Segment ('Mut s)))
-> (Vector (Segment ('Mut s)) -> m (MVector s (Segment ('Mut s))))
-> m (MVector s (Segment ('Mut s)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Vector (Segment ('Mut s)) -> m (MVector s (Segment ('Mut s)))
forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.unsafeThaw)
    MutVar s (AppendVec MVector s Client)
mutCaps <- AppendVec MVector s Client
-> m (MutVar s (AppendVec MVector s Client))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (AppendVec MVector s Client
 -> m (MutVar s (AppendVec MVector s Client)))
-> (MVector s Client -> AppendVec MVector s Client)
-> MVector s Client
-> m (MutVar s (AppendVec MVector s Client))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s Client -> AppendVec MVector s Client
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.fromVector (MVector s Client -> m (MutVar s (AppendVec MVector s Client)))
-> m (MVector s Client)
-> m (MutVar s (AppendVec MVector s Client))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Vector Client -> m (MVector s Client)
thawCaps Vector Client
constCaps
    Message ('Mut s) -> m (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message ('Mut s) -> m (Message ('Mut s)))
-> Message ('Mut s) -> m (Message ('Mut s))
forall a b. (a -> b) -> a -> b
$ MutMsg s -> Message ('Mut s)
forall s. MutMsg s -> Message ('Mut s)
MsgMut MutMsg :: forall s.
MutVar s (AppendVec MVector s (Segment ('Mut s)))
-> MutVar s (AppendVec MVector s Client) -> MutMsg s
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 :: (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 <- Message ('Mut s) -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
numSegs Message ('Mut s)
msg
    Vector (Segment 'Const)
constSegs <- Int -> (Int -> m (Segment 'Const)) -> m (Vector (Segment 'Const))
forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM Int
len (Message ('Mut s) -> Int -> m (Segment ('Mut s))
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
internalGetSeg Message ('Mut s)
msg (Int -> m (Segment ('Mut s)))
-> (Segment ('Mut s) -> m (Segment 'Const))
-> Int
-> m (Segment 'Const)
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 (MVector s Client -> m (Vector Client))
-> (AppendVec MVector s Client -> MVector s Client)
-> AppendVec MVector s Client
-> m (Vector Client)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppendVec MVector s Client -> MVector s Client
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s Client -> m (Vector Client))
-> m (AppendVec MVector s Client) -> m (Vector Client)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MutVar (PrimState m) (AppendVec MVector s Client)
-> m (AppendVec MVector s Client)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s Client)
MutVar (PrimState m) (AppendVec MVector s Client)
mutCaps
    Message 'Const -> m (Message 'Const)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message 'Const -> m (Message 'Const))
-> Message 'Const -> m (Message 'Const)
forall a b. (a -> b) -> a -> b
$ ConstMsg -> Message 'Const
MsgConst ConstMsg :: Vector (Segment 'Const) -> Vector Client -> ConstMsg
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 :: (Integral a, MonadThrow m) => a -> a -> m ()
checkIndex :: a -> a -> m ()
checkIndex a
i a
len =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
|| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
len) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Error -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BoundsError :: Int -> Int -> Error
E.BoundsError
            { index :: Int
E.index = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i
            , maxIndex :: Int
E.maxIndex = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len
            }