{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# 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 (
    -- * 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

    -- * Message type class
    , Message(..)

    -- * Immutable messages
    , ConstMsg
    , empty
    , singleSegment

    -- * Reading data from messages
    , getSegment
    , getWord
    , getCap
    , getCapTable

    -- * Mutable Messages
    , MutMsg
    , newMessage

    -- ** Allocating space in messages
    , alloc
    , allocInSeg
    , newSegment

    -- ** Modifying messages
    , setSegment
    , setWord
    , 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)
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.Maybe                (fromJust)
import Data.Primitive            (MutVar, newMutVar, readMutVar, writeMutVar)
import Data.Word                 (Word32, Word64)
import System.Endian             (fromLE64, toLE64)
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


-- | The maximum size of a segment supported by this libarary, in words.
maxSegmentSize :: Int
maxSegmentSize :: Int
maxSegmentSize = 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
512

-- | A 'Message' is a (possibly read-only) capnproto message. It is
-- parameterized over a monad in which operations are performed.
class Monad m => Message m msg where
    -- | The type of segments in the message.
    data Segment msg

    -- | 'numSegs' gets the number of segments in a message.
    numSegs :: msg -> m Int
    -- | 'numWords' gets the number of words in a segment.
    numWords :: Segment msg -> m WordCount
    -- | 'numCaps' gets the number of capabilities in a message's capability
    -- table.
    numCaps :: msg -> 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 :: msg -> Int -> m (Segment msg)
    -- | @'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 :: msg -> 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 msg -> m (Segment msg)
    -- | @'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 msg -> WordCount -> m Word64
    -- | Convert a ByteString to a segment.
    fromByteString :: ByteString -> m (Segment msg)
    -- | Convert a segment to a byte string.
    toByteString :: Segment msg -> m ByteString

-- | @'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, Message m msg) => msg -> Int -> m (Segment msg)
getSegment :: msg -> Int -> m (Segment msg)
getSegment msg
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
=<< msg -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numSegs msg
msg
    msg -> Int -> m (Segment msg)
forall (m :: * -> *) msg.
Message m msg =>
msg -> Int -> m (Segment msg)
internalGetSeg msg
msg Int
i

-- | @'withCapTable'@ replaces the capability table in the message.
withCapTable :: V.Vector Client -> ConstMsg -> ConstMsg
withCapTable :: Vector Client -> ConstMsg -> ConstMsg
withCapTable Vector Client
newCaps ConstMsg
msg = ConstMsg
msg { constCaps :: Vector Client
constCaps = Vector Client
newCaps }

-- | 'getCapTable' gets the capability table from a 'ConstMsg'.
getCapTable :: ConstMsg -> V.Vector Client
getCapTable :: ConstMsg -> Vector Client
getCapTable = ConstMsg -> 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, Message m msg) => msg -> Int -> m Client
getCap :: msg -> Int -> m Client
getCap msg
msg Int
i = do
    Int
ncaps <- msg -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numCaps msg
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 msg
msg msg -> Int -> m Client
forall (m :: * -> *) msg. Message m msg => msg -> 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, Message m msg) => msg -> WordAddr -> m Word64
getWord :: msg -> WordAddr -> m Word64
getWord msg
msg WordAt{wordIndex :: WordAddr -> WordCount
wordIndex=WordCount
i, Int
segIndex :: WordAddr -> Int
segIndex :: Int
segIndex} = do
    Segment msg
seg <- msg -> Int -> m (Segment msg)
forall (m :: * -> *) msg.
(MonadThrow m, Message m msg) =>
msg -> Int -> m (Segment msg)
getSegment msg
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 msg -> m WordCount
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> m WordCount
numWords Segment msg
seg
    Segment msg
seg Segment msg -> WordCount -> m Word64
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> 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, MonadThrow m) => MutMsg s -> Int -> Segment (MutMsg s) -> m ()
setSegment :: MutMsg s -> Int -> Segment (MutMsg s) -> m ()
setSegment MutMsg s
msg Int
i Segment (MutMsg 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
=<< MutMsg s -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numSegs MutMsg s
msg
    MutMsg s -> Int -> Segment (MutMsg s) -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Int -> Segment (MutMsg s) -> m ()
internalSetSeg MutMsg s
msg Int
i Segment (MutMsg 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, MonadThrow m) => MutMsg s -> WordAddr -> Word64 -> m ()
setWord :: MutMsg s -> WordAddr -> Word64 -> m ()
setWord MutMsg s
msg WordAt{wordIndex :: WordAddr -> WordCount
wordIndex=WordCount
i, Int
segIndex :: Int
segIndex :: WordAddr -> Int
segIndex} Word64
val = do
    Segment (MutMsg s)
seg <- MutMsg s -> Int -> m (Segment (MutMsg s))
forall (m :: * -> *) msg.
(MonadThrow m, Message m msg) =>
msg -> Int -> m (Segment msg)
getSegment MutMsg 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 (MutMsg s) -> m WordCount
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> m WordCount
numWords Segment (MutMsg s)
seg
    Segment (MutMsg s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment (MutMsg s) -> WordCount -> Word64 -> m ()
write Segment (MutMsg 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, MonadThrow m) => MutMsg s -> Int -> Client -> m ()
setCap :: MutMsg s -> Int -> Client -> m ()
setCap msg :: MutMsg s
msg@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
=<< MutMsg s -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numCaps MutMsg 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 => MutMsg s -> Client -> m Int
appendCap :: MutMsg s -> Client -> m Int
appendCap msg :: MutMsg s
msg@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 <- MutMsg s -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numCaps MutMsg 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
    MutMsg s -> Int -> Client -> m ()
forall (m :: * -> *) s.
(WriteCtx m s, MonadThrow m) =>
MutMsg s -> Int -> Client -> m ()
setCap MutMsg 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. its
-- implementations of 'toByteString' and 'fromByteString' are O(1);
-- the underlying bytes are not copied.
data ConstMsg = ConstMsg
    { ConstMsg -> Vector (Segment ConstMsg)
constSegs :: V.Vector (Segment ConstMsg)
    , 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 => Message m ConstMsg where
    newtype Segment ConstMsg = ConstSegment { Segment ConstMsg -> Vector Word64
constSegToVec :: SV.Vector Word64 }
        deriving(Segment ConstMsg -> Segment ConstMsg -> Bool
(Segment ConstMsg -> Segment ConstMsg -> Bool)
-> (Segment ConstMsg -> Segment ConstMsg -> Bool)
-> Eq (Segment ConstMsg)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Segment ConstMsg -> Segment ConstMsg -> Bool
$c/= :: Segment ConstMsg -> Segment ConstMsg -> Bool
== :: Segment ConstMsg -> Segment ConstMsg -> Bool
$c== :: Segment ConstMsg -> Segment ConstMsg -> Bool
Eq)

    numSegs :: ConstMsg -> m Int
numSegs ConstMsg{Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
constSegs :: ConstMsg -> Vector (Segment ConstMsg)
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 ConstMsg) -> Int
forall a. Vector a -> Int
V.length Vector (Segment ConstMsg)
constSegs
    numCaps :: ConstMsg -> m Int
numCaps 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 :: ConstMsg -> Int -> m (Segment ConstMsg)
internalGetSeg ConstMsg{Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
constSegs :: ConstMsg -> Vector (Segment ConstMsg)
constSegs} Int
i = Vector (Segment ConstMsg)
constSegs Vector (Segment ConstMsg) -> Int -> m (Segment ConstMsg)
forall (m :: * -> *) a. Monad m => Vector a -> Int -> m a
`V.indexM` Int
i
    internalGetCap :: ConstMsg -> Int -> m Client
internalGetCap 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 ConstMsg -> m WordCount
numWords (ConstSegment 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 ConstMsg -> m (Segment ConstMsg)
slice (WordCount Int
start) (WordCount Int
len) (ConstSegment vec) =
        Segment ConstMsg -> m (Segment ConstMsg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment ConstMsg -> m (Segment ConstMsg))
-> Segment ConstMsg -> m (Segment ConstMsg)
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> Segment ConstMsg
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 ConstMsg -> WordCount -> m Word64
read (ConstSegment vec) WordCount
i = Word64 -> Word64
fromLE64 (Word64 -> Word64) -> m Word64 -> m Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Word64
vec Vector Word64 -> Int -> m Word64
forall a (m :: * -> *).
(Storable a, Monad m) =>
Vector a -> Int -> m a
`SV.indexM` WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
i

    -- FIXME: Verify that the pointer is actually 64-bit aligned before casting.
    fromByteString :: ByteString -> m (Segment ConstMsg)
fromByteString (PS ForeignPtr Word8
fptr Int
offset Int
len) =
        Segment ConstMsg -> m (Segment ConstMsg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment ConstMsg -> m (Segment ConstMsg))
-> Segment ConstMsg -> m (Segment ConstMsg)
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> Segment ConstMsg
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)
    toByteString :: Segment ConstMsg -> m ByteString
toByteString (ConstSegment vec) = ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ 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)

-- | '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 ConstMsg
decode :: ByteString -> m ConstMsg
decode ByteString
bytes = ByteString -> m (Segment ConstMsg)
forall (m :: * -> *) msg.
Message m msg =>
ByteString -> m (Segment msg)
fromByteString ByteString
bytes m (Segment ConstMsg)
-> (Segment ConstMsg -> m ConstMsg) -> m ConstMsg
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Segment ConstMsg -> m ConstMsg
forall (m :: * -> *).
MonadThrow m =>
Segment ConstMsg -> m ConstMsg
decodeSeg

-- | 'encode' encodes a message as a bytestring builder.
encode :: Monad m => ConstMsg -> m BB.Builder
encode :: ConstMsg -> m Builder
encode ConstMsg
msg =
    -- We use Maybe as the MonadThrow instance required by
    -- writeMessage/toByteString, but we know this can't actually fail,
    -- so we ignore errors. TODO: we should get rid of the Monad constraint
    -- on this function and just have the tyep be ConstMsg -> BB.Builder,
    -- but that will have some cascading api effects, so we're deferring
    -- that for a bit.
    Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> m Builder) -> Builder -> m Builder
forall a b. (a -> b) -> a -> b
$ 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
$ ConstMsg
-> (Word32 -> WriterT Builder Maybe ())
-> (Segment ConstMsg -> WriterT Builder Maybe ())
-> WriterT Builder Maybe ()
forall (m :: * -> *).
MonadThrow m =>
ConstMsg -> (Word32 -> m ()) -> (Segment ConstMsg -> m ()) -> m ()
writeMessage
        ConstMsg
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)
        (Segment ConstMsg -> WriterT Builder Maybe ByteString
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> m ByteString
toByteString (Segment ConstMsg -> WriterT Builder Maybe ByteString)
-> (ByteString -> WriterT Builder Maybe ())
-> Segment ConstMsg
-> WriterT Builder Maybe ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Builder -> WriterT Builder Maybe ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> WriterT Builder Maybe ())
-> (ByteString -> Builder)
-> ByteString
-> WriterT Builder Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BB.byteString)

-- | '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 ConstMsg -> m ConstMsg
decodeSeg :: Segment ConstMsg -> m ConstMsg
decodeSeg Segment ConstMsg
seg = do
    WordCount
len <- Segment ConstMsg -> m WordCount
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> m WordCount
numWords Segment ConstMsg
seg
    (StateT (Maybe Word32, WordCount) m ConstMsg
 -> (Maybe Word32, WordCount) -> m ConstMsg)
-> (Maybe Word32, WordCount)
-> StateT (Maybe Word32, WordCount) m ConstMsg
-> m ConstMsg
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Maybe Word32, WordCount) m ConstMsg
-> (Maybe Word32, WordCount) -> m ConstMsg
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 ConstMsg -> m ConstMsg)
-> StateT (Maybe Word32, WordCount) m ConstMsg -> m ConstMsg
forall a b. (a -> b) -> a -> b
$ WordCount
-> LimitT (StateT (Maybe Word32, WordCount) m) ConstMsg
-> StateT (Maybe Word32, WordCount) m ConstMsg
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
len (LimitT (StateT (Maybe Word32, WordCount) m) ConstMsg
 -> StateT (Maybe Word32, WordCount) m ConstMsg)
-> LimitT (StateT (Maybe Word32, WordCount) m) ConstMsg
-> StateT (Maybe Word32, WordCount) m ConstMsg
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 ConstMsg))
-> LimitT (StateT (Maybe Word32, WordCount) m) ConstMsg
forall (m :: * -> *).
(MonadThrow m, MonadLimit m) =>
m Word32 -> (WordCount -> m (Segment ConstMsg)) -> m ConstMsg
readMessage LimitT (StateT (Maybe Word32, WordCount) m) Word32
read32 WordCount
-> LimitT (StateT (Maybe Word32, WordCount) m) (Segment ConstMsg)
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 ConstMsg -> WordCount -> m Word64
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> WordCount -> m Word64
read Segment ConstMsg
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 ConstMsg)
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 ConstMsg)
-> LimitT (StateT (Maybe Word32, WordCount) m) (Segment ConstMsg)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Maybe Word32, WordCount) m (Segment ConstMsg)
 -> LimitT (StateT (Maybe Word32, WordCount) m) (Segment ConstMsg))
-> StateT (Maybe Word32, WordCount) m (Segment ConstMsg)
-> LimitT (StateT (Maybe Word32, WordCount) m) (Segment ConstMsg)
forall a b. (a -> b) -> a -> b
$ m (Segment ConstMsg)
-> StateT (Maybe Word32, WordCount) m (Segment ConstMsg)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Segment ConstMsg)
 -> StateT (Maybe Word32, WordCount) m (Segment ConstMsg))
-> m (Segment ConstMsg)
-> StateT (Maybe Word32, WordCount) m (Segment ConstMsg)
forall a b. (a -> b) -> a -> b
$ WordCount -> WordCount -> Segment ConstMsg -> m (Segment ConstMsg)
forall (m :: * -> *) msg.
Message m msg =>
WordCount -> WordCount -> Segment msg -> m (Segment msg)
slice WordCount
idx WordCount
len Segment ConstMsg
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 ConstMsg)) -> m ConstMsg
readMessage :: m Word32 -> (WordCount -> m (Segment ConstMsg)) -> m ConstMsg
readMessage m Word32
read32 WordCount -> m (Segment ConstMsg)
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 ConstMsg)
constSegs <- (Word32 -> m (Segment ConstMsg))
-> Vector Word32 -> m (Vector (Segment ConstMsg))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (WordCount -> m (Segment ConstMsg)
readSegment (WordCount -> m (Segment ConstMsg))
-> (Word32 -> WordCount) -> Word32 -> m (Segment ConstMsg)
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
    ConstMsg -> m ConstMsg
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstMsg :: Vector (Segment ConstMsg) -> Vector Client -> ConstMsg
ConstMsg{Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
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 => ConstMsg -> (Word32 -> m ()) -> (Segment ConstMsg -> m ()) -> m ()
writeMessage :: ConstMsg -> (Word32 -> m ()) -> (Segment ConstMsg -> m ()) -> m ()
writeMessage ConstMsg{Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
constSegs :: ConstMsg -> Vector (Segment ConstMsg)
constSegs} Word32 -> m ()
write32 Segment ConstMsg -> m ()
writeSegment = do
    let numSegs :: Int
numSegs = Vector (Segment ConstMsg) -> Int
forall a. Vector a -> Int
V.length Vector (Segment ConstMsg)
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 ConstMsg) -> (Segment ConstMsg -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (Segment ConstMsg)
constSegs ((Segment ConstMsg -> m ()) -> m ())
-> (Segment ConstMsg -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Segment ConstMsg
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 ConstMsg -> m WordCount
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> m WordCount
numWords Segment ConstMsg
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 ConstMsg) -> (Segment ConstMsg -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (Segment ConstMsg)
constSegs Segment ConstMsg -> 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 -> ConstMsg -> IO ()
hPutMsg :: Handle -> ConstMsg -> IO ()
hPutMsg Handle
handle ConstMsg
msg = ConstMsg -> IO Builder
forall (m :: * -> *). Monad m => ConstMsg -> m Builder
encode ConstMsg
msg IO Builder -> (Builder -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> Builder -> IO ()
BB.hPutBuilder Handle
handle

-- | Equivalent to @'hPutMsg' 'stdout'@
putMsg :: ConstMsg -> IO ()
putMsg :: ConstMsg -> IO ()
putMsg = Handle -> ConstMsg -> 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 ConstMsg
hGetMsg :: Handle -> WordCount -> IO ConstMsg
hGetMsg Handle
handle WordCount
size =
    WordCount -> LimitT IO ConstMsg -> IO ConstMsg
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
size (LimitT IO ConstMsg -> IO ConstMsg)
-> LimitT IO ConstMsg -> IO ConstMsg
forall a b. (a -> b) -> a -> b
$ LimitT IO Word32
-> (WordCount -> LimitT IO (Segment ConstMsg))
-> LimitT IO ConstMsg
forall (m :: * -> *).
(MonadThrow m, MonadLimit m) =>
m Word32 -> (WordCount -> m (Segment ConstMsg)) -> m ConstMsg
readMessage LimitT IO Word32
read32 WordCount -> LimitT IO (Segment ConstMsg)
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 ConstMsg)
readSegment WordCount
n = IO (Segment ConstMsg) -> LimitT IO (Segment ConstMsg)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Segment ConstMsg) -> LimitT IO (Segment ConstMsg))
-> IO (Segment ConstMsg) -> LimitT IO (Segment ConstMsg)
forall a b. (a -> b) -> a -> 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) IO ByteString
-> (ByteString -> IO (Segment ConstMsg)) -> IO (Segment ConstMsg)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO (Segment ConstMsg)
forall (m :: * -> *) msg.
Message m msg =>
ByteString -> m (Segment msg)
fromByteString

-- | Equivalent to @'hGetMsg' 'stdin'@
getMsg :: WordCount -> IO ConstMsg
getMsg :: WordCount -> IO ConstMsg
getMsg = Handle -> WordCount -> IO ConstMsg
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.
--
-- Due to mutabilty, the implementations of 'toByteString' and 'fromByteString'
-- must make full copies, and so are O(n) in the length of the segment.
data MutMsg s = MutMsg
    { MutMsg s -> MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MV.MVector s (Segment (MutMsg 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) => Message m (MutMsg s) where
    newtype Segment (MutMsg s) = MutSegment (AppendVec SMV.MVector s Word64)

    numWords :: Segment (MutMsg s) -> m WordCount
numWords (MutSegment mseg) = 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
$ MVector s Word64 -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
GMV.length (AppendVec MVector s Word64 -> MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector AppendVec MVector s Word64
mseg)
    slice :: WordCount
-> WordCount -> Segment (MutMsg s) -> m (Segment (MutMsg s))
slice (WordCount Int
start) (WordCount Int
len) (MutSegment mseg) =
        Segment (MutMsg s) -> m (Segment (MutMsg s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment (MutMsg s) -> m (Segment (MutMsg s)))
-> Segment (MutMsg s) -> m (Segment (MutMsg s))
forall a b. (a -> b) -> a -> b
$ AppendVec MVector s Word64 -> Segment (MutMsg s)
forall s. AppendVec MVector s Word64 -> Segment (MutMsg s)
MutSegment (AppendVec MVector s Word64 -> Segment (MutMsg s))
-> AppendVec MVector s Word64 -> Segment (MutMsg s)
forall a b. (a -> b) -> a -> b
$ MVector s Word64 -> AppendVec MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.fromVector (MVector s Word64 -> AppendVec MVector s Word64)
-> MVector s Word64 -> AppendVec MVector s Word64
forall a b. (a -> b) -> a -> b
$
            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 (AppendVec MVector s Word64 -> MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector AppendVec MVector s Word64
mseg)
    read :: Segment (MutMsg s) -> WordCount -> m Word64
read (MutSegment mseg) WordCount
i = Word64 -> Word64
fromLE64 (Word64 -> Word64) -> m Word64 -> m Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState m) Word64 -> Int -> m Word64
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
SMV.read (AppendVec MVector s Word64 -> MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector AppendVec MVector s Word64
mseg) (WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
i)
    fromByteString :: ByteString -> m (Segment (MutMsg s))
fromByteString ByteString
bytes = do
        Vector Word64
vec <- Segment ConstMsg -> Vector Word64
constSegToVec (Segment ConstMsg -> Vector Word64)
-> m (Segment ConstMsg) -> m (Vector Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m (Segment ConstMsg)
forall (m :: * -> *) msg.
Message m msg =>
ByteString -> m (Segment msg)
fromByteString ByteString
bytes
        AppendVec MVector s Word64 -> Segment (MutMsg s)
forall s. AppendVec MVector s Word64 -> Segment (MutMsg s)
MutSegment (AppendVec MVector s Word64 -> Segment (MutMsg s))
-> (MVector s Word64 -> AppendVec MVector s Word64)
-> MVector s Word64
-> Segment (MutMsg s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s Word64 -> AppendVec MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.fromVector (MVector s Word64 -> Segment (MutMsg s))
-> m (MVector s Word64) -> m (Segment (MutMsg s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Word64 -> m (MVector (PrimState m) Word64)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
SV.thaw Vector Word64
vec
    toByteString :: Segment (MutMsg s) -> m ByteString
toByteString Segment (MutMsg s)
mseg = do
        Segment ConstMsg
seg <- Mutable s (Segment ConstMsg) -> m (Segment ConstMsg)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze Mutable s (Segment ConstMsg)
Segment (MutMsg s)
mseg
        Segment ConstMsg -> m ByteString
forall (m :: * -> *) msg.
Message m msg =>
Segment msg -> m ByteString
toByteString (Segment ConstMsg
seg :: Segment ConstMsg)

    numSegs :: MutMsg s -> m Int
numSegs MutMsg{MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs} = MVector s (Segment (MutMsg s)) -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
GMV.length (MVector s (Segment (MutMsg s)) -> Int)
-> (AppendVec MVector s (Segment (MutMsg s))
    -> MVector s (Segment (MutMsg s)))
-> AppendVec MVector s (Segment (MutMsg s))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppendVec MVector s (Segment (MutMsg s))
-> MVector s (Segment (MutMsg s))
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s (Segment (MutMsg s)) -> Int)
-> m (AppendVec MVector s (Segment (MutMsg s))) -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
-> m (AppendVec MVector s (Segment (MutMsg s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment (MutMsg s)))
MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
mutSegs
    numCaps :: MutMsg s -> m Int
numCaps 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} = 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)
-> m (AppendVec MVector s Client) -> m Int
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
    internalGetSeg :: MutMsg s -> Int -> m (Segment (MutMsg s))
internalGetSeg MutMsg{MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs} Int
i = do
        MVector s (Segment (MutMsg s))
segs <- AppendVec MVector s (Segment (MutMsg s))
-> MVector s (Segment (MutMsg s))
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s (Segment (MutMsg s))
 -> MVector s (Segment (MutMsg s)))
-> m (AppendVec MVector s (Segment (MutMsg s)))
-> m (MVector s (Segment (MutMsg s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
-> m (AppendVec MVector s (Segment (MutMsg s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment (MutMsg s)))
MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
mutSegs
        MVector (PrimState m) (Segment (MutMsg s))
-> Int -> m (Segment (MutMsg s))
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s (Segment (MutMsg s))
MVector (PrimState m) (Segment (MutMsg s))
segs Int
i
    internalGetCap :: MutMsg s -> Int -> m Client
internalGetCap 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 = 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)
-> 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 -> m Client
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s Client
MVector (PrimState m) 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 => MutMsg s -> Int -> Segment (MutMsg s) -> m ()
internalSetSeg :: MutMsg s -> Int -> Segment (MutMsg s) -> m ()
internalSetSeg MutMsg{MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs} Int
segIndex Segment (MutMsg s)
seg = do
    MVector s (Segment (MutMsg s))
segs <- AppendVec MVector s (Segment (MutMsg s))
-> MVector s (Segment (MutMsg s))
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector (AppendVec MVector s (Segment (MutMsg s))
 -> MVector s (Segment (MutMsg s)))
-> m (AppendVec MVector s (Segment (MutMsg s)))
-> m (MVector s (Segment (MutMsg s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
-> m (AppendVec MVector s (Segment (MutMsg s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment (MutMsg s)))
MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
mutSegs
    MVector (PrimState m) (Segment (MutMsg s))
-> Int -> Segment (MutMsg s) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s (Segment (MutMsg s))
MVector (PrimState m) (Segment (MutMsg s))
segs Int
segIndex Segment (MutMsg 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 (MutMsg s) -> WordCount -> Word64 -> m ()
write :: Segment (MutMsg s) -> WordCount -> Word64 -> m ()
write (MutSegment seg) (WordCount Int
i) Word64
val =
    MVector (PrimState m) Word64 -> Int -> Word64 -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
SMV.write (AppendVec MVector s Word64 -> MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector AppendVec MVector s Word64
seg) Int
i (Word64 -> Word64
toLE64 Word64
val)

-- | @'grow' segment amount@ grows the segment by the specified number
-- of 64-bit words. The original segment should not be used afterwards.
grow  :: WriteCtx m s => Segment (MutMsg s) -> Int -> m (Segment (MutMsg s))
grow :: Segment (MutMsg s) -> Int -> m (Segment (MutMsg s))
grow (MutSegment vec) Int
amount =
    AppendVec MVector s Word64 -> Segment (MutMsg s)
forall s. AppendVec MVector s Word64 -> Segment (MutMsg s)
MutSegment (AppendVec MVector s Word64 -> Segment (MutMsg s))
-> m (AppendVec MVector s Word64) -> m (Segment (MutMsg s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppendVec MVector s Word64
-> Int -> Int -> m (AppendVec MVector s Word64)
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 Word64
vec Int
amount Int
maxSegmentSize

-- | @'newSegment' msg sizeHint@ allocates a new, initially empty segment in
-- @msg@ with a capacity of @sizeHint@. It returns the a pair of the segment
-- number and the segment itself. Amortized O(1).
newSegment :: WriteCtx m s => MutMsg s -> Int -> m (Int, Segment (MutMsg s))
newSegment :: MutMsg s -> Int -> m (Int, Segment (MutMsg s))
newSegment msg :: MutMsg s
msg@MutMsg{MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs} Int
sizeHint = do
    -- the next segment number will be equal to the *current* number of
    -- segments:
    Int
segIndex <- MutMsg s -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numSegs MutMsg s
msg

    -- make space for th new segment
    AppendVec MVector s (Segment (MutMsg s))
segs <- MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
-> m (AppendVec MVector s (Segment (MutMsg s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s (AppendVec MVector s (Segment (MutMsg s)))
MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
mutSegs
    AppendVec MVector s (Segment (MutMsg s))
segs <- AppendVec MVector s (Segment (MutMsg s))
-> Int -> Int -> m (AppendVec MVector s (Segment (MutMsg 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 (MutMsg s))
segs Int
1 Int
maxSegments
    MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
-> AppendVec MVector s (Segment (MutMsg s)) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (AppendVec MVector s (Segment (MutMsg s)))
MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
mutSegs AppendVec MVector s (Segment (MutMsg s))
segs

    Segment (MutMsg s)
newSeg <- AppendVec MVector s Word64 -> Segment (MutMsg s)
forall s. AppendVec MVector s Word64 -> Segment (MutMsg s)
MutSegment (AppendVec MVector s Word64 -> Segment (MutMsg s))
-> (MVector s Word64 -> AppendVec MVector s Word64)
-> MVector s Word64
-> Segment (MutMsg s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s Word64 -> AppendVec MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.makeEmpty (MVector s Word64 -> Segment (MutMsg s))
-> m (MVector s Word64) -> m (Segment (MutMsg s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (MVector (PrimState m) Word64)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
SMV.new Int
sizeHint
    MutMsg s -> Int -> Segment (MutMsg s) -> m ()
forall (m :: * -> *) s.
(WriteCtx m s, MonadThrow m) =>
MutMsg s -> Int -> Segment (MutMsg s) -> m ()
setSegment MutMsg s
msg Int
segIndex Segment (MutMsg s)
newSeg
    (Int, Segment (MutMsg s)) -> m (Int, Segment (MutMsg s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
segIndex, Segment (MutMsg s)
newSeg)

-- | Like 'alloc', but the second argument allows the caller to specify the
-- index of the segment in which to allocate the data.
allocInSeg :: WriteCtx m s => MutMsg s -> Int -> WordCount -> m WordAddr
allocInSeg :: MutMsg s -> Int -> WordCount -> m WordAddr
allocInSeg MutMsg s
msg Int
segIndex (WordCount Int
size) = do
    oldSeg :: Segment (MutMsg s)
oldSeg@(MutSegment vec) <- MutMsg s -> Int -> m (Segment (MutMsg s))
forall (m :: * -> *) msg.
(MonadThrow m, Message m msg) =>
msg -> Int -> m (Segment msg)
getSegment MutMsg s
msg Int
segIndex
    let ret :: WordAddr
ret = WordAt :: Int -> WordCount -> WordAddr
WordAt
            { Int
segIndex :: Int
segIndex :: Int
segIndex
            , wordIndex :: WordCount
wordIndex = Int -> WordCount
WordCount (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$ MVector s Word64 -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
GMV.length (MVector s Word64 -> Int) -> MVector s Word64 -> Int
forall a b. (a -> b) -> a -> b
$ AppendVec MVector s Word64 -> MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector AppendVec MVector s Word64
vec
            }
    Segment (MutMsg s)
newSeg <- Segment (MutMsg s) -> Int -> m (Segment (MutMsg s))
forall (m :: * -> *) s.
WriteCtx m s =>
Segment (MutMsg s) -> Int -> m (Segment (MutMsg s))
grow Segment (MutMsg s)
oldSeg Int
size
    MutMsg s -> Int -> Segment (MutMsg s) -> m ()
forall (m :: * -> *) s.
(WriteCtx m s, MonadThrow m) =>
MutMsg s -> Int -> Segment (MutMsg s) -> m ()
setSegment MutMsg s
msg Int
segIndex Segment (MutMsg s)
newSeg
    WordAddr -> m WordAddr
forall (f :: * -> *) a. Applicative f => a -> f a
pure WordAddr
ret

-- | @'alloc' size@ allocates 'size' words within a message. it returns the
-- starting address of the allocated memory.
alloc :: WriteCtx m s => MutMsg s -> WordCount -> m WordAddr
alloc :: MutMsg s -> WordCount -> m WordAddr
alloc MutMsg s
msg size :: WordCount
size@(WordCount Int
sizeInt) = do
    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
<$> MutMsg s -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numSegs MutMsg s
msg
    MutSegment vec <- MutMsg s -> Int -> m (Segment (MutMsg s))
forall (m :: * -> *) msg.
(MonadThrow m, Message m msg) =>
msg -> Int -> m (Segment msg)
getSegment MutMsg s
msg Int
segIndex
    if AppendVec MVector s Word64 -> Int -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> Int -> Bool
AppendVec.canGrowWithoutCopy AppendVec MVector s Word64
vec Int
sizeInt
        then
            MutMsg s -> Int -> WordCount -> m WordAddr
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Int -> WordCount -> m WordAddr
allocInSeg MutMsg s
msg Int
segIndex WordCount
size
        else do
            AppendVec MVector s (Segment (MutMsg s))
segments <- MutVar (PrimState m) (AppendVec MVector s (Segment (MutMsg s)))
-> m (AppendVec MVector s (Segment (MutMsg s)))
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar (MutMsg s -> MutVar s (AppendVec MVector s (Segment (MutMsg s)))
forall s.
MutMsg s -> MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs MutMsg s
msg)
            Vector (Segment (MutMsg s))
segs <- MVector (PrimState m) (Segment (MutMsg s))
-> m (Vector (Segment (MutMsg s)))
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.freeze (AppendVec MVector s (Segment (MutMsg s))
-> MVector s (Segment (MutMsg s))
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> v s a
AppendVec.getVector AppendVec MVector s (Segment (MutMsg s))
segments)
            let totalAllocation :: Int
totalAllocation = Vector Int -> Int
forall a. Num a => Vector a -> a
V.sum (Vector Int -> Int) -> Vector Int -> Int
forall a b. (a -> b) -> a -> b
$ (Segment (MutMsg s) -> Int)
-> Vector (Segment (MutMsg s)) -> Vector Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(MutSegment vec) -> AppendVec MVector s Word64 -> Int
forall (v :: * -> * -> *) a s.
MVector v a =>
AppendVec v s a -> Int
AppendVec.getCapacity AppendVec MVector s Word64
vec) Vector (Segment (MutMsg s))
segs
            -- the new segment's size should match the total size of existing segments
            ( Int
newSegIndex, Segment (MutMsg s)
_ ) <- MutMsg s -> Int -> m (Int, Segment (MutMsg s))
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Int -> m (Int, Segment (MutMsg s))
newSegment MutMsg s
msg (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxSegmentSize (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
totalAllocation Int
sizeInt))
            MutMsg s -> Int -> WordCount -> m WordAddr
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Int -> WordCount -> m WordAddr
allocInSeg MutMsg 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 :: ConstMsg
empty :: ConstMsg
empty = ConstMsg :: Vector (Segment ConstMsg) -> Vector Client -> ConstMsg
ConstMsg
    { constSegs :: Vector (Segment ConstMsg)
constSegs = [Segment ConstMsg] -> Vector (Segment ConstMsg)
forall a. [a] -> Vector a
V.fromList [ Vector Word64 -> Segment ConstMsg
ConstSegment (Vector Word64 -> Segment ConstMsg)
-> Vector Word64 -> Segment ConstMsg
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 (MutMsg s)
newMessage :: Maybe WordCount -> m (MutMsg s)
newMessage Maybe WordCount
Nothing = Maybe WordCount -> m (MutMsg s)
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (MutMsg 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 Int
sizeHint)) = do
    MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs <- Int -> m (MVector (PrimState m) (Segment (MutMsg s)))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new Int
1 m (MVector s (Segment (MutMsg s)))
-> (MVector s (Segment (MutMsg s))
    -> m (MutVar s (AppendVec MVector s (Segment (MutMsg s)))))
-> m (MutVar s (AppendVec MVector s (Segment (MutMsg s))))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppendVec MVector s (Segment (MutMsg s))
-> m (MutVar s (AppendVec MVector s (Segment (MutMsg s))))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (AppendVec MVector s (Segment (MutMsg s))
 -> m (MutVar s (AppendVec MVector s (Segment (MutMsg s)))))
-> (MVector s (Segment (MutMsg s))
    -> AppendVec MVector s (Segment (MutMsg s)))
-> MVector s (Segment (MutMsg s))
-> m (MutVar s (AppendVec MVector s (Segment (MutMsg s))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s (Segment (MutMsg s))
-> AppendVec MVector s (Segment (MutMsg 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 :: MutMsg s
msg = MutMsg :: forall s.
MutVar s (AppendVec MVector s (Segment (MutMsg s)))
-> MutVar s (AppendVec MVector s Client) -> MutMsg s
MutMsg{MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg 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 (MutMsg s))
_ <- MutMsg s -> Int -> m (Int, Segment (MutMsg s))
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Int -> m (Int, Segment (MutMsg s))
newSegment MutMsg s
msg Int
sizeHint
    WordAddr
_ <- MutMsg s -> WordCount -> m WordAddr
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> WordCount -> m WordAddr
alloc MutMsg s
msg WordCount
1
    MutMsg s -> m (MutMsg s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutMsg s
msg

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


instance Thaw (Segment ConstMsg) where
    type Mutable s (Segment ConstMsg) = Segment (MutMsg s)

    thaw :: Segment ConstMsg -> m (Mutable s (Segment ConstMsg))
thaw         = (FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64))
-> Segment ConstMsg -> m (Segment (MutMsg s))
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64))
-> Segment ConstMsg -> m (Segment (MutMsg s))
thawSeg   FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw
    unsafeThaw :: Segment ConstMsg -> m (Mutable s (Segment ConstMsg))
unsafeThaw   = (FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64))
-> Segment ConstMsg -> m (Segment (MutMsg s))
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64))
-> Segment ConstMsg -> m (Segment (MutMsg s))
thawSeg   FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
unsafeThaw
    freeze :: Mutable s (Segment ConstMsg) -> m (Segment ConstMsg)
freeze       = (AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64))
-> Segment (MutMsg s) -> m (Segment ConstMsg)
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64))
-> Segment (MutMsg s) -> m (Segment ConstMsg)
freezeSeg AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze
    unsafeFreeze :: Mutable s (Segment ConstMsg) -> m (Segment ConstMsg)
unsafeFreeze = (AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64))
-> Segment (MutMsg s) -> m (Segment ConstMsg)
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64))
-> Segment (MutMsg s) -> m (Segment ConstMsg)
freezeSeg AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
unsafeFreeze

-- Helpers for @Segment ConstMsg@'s Thaw instance.
thawSeg
    :: (PrimMonad m, s ~ PrimState m)
    => (AppendVec.FrozenAppendVec SV.Vector Word64 -> m (AppendVec SMV.MVector s Word64))
    -> Segment ConstMsg
    -> m (Segment (MutMsg s))
thawSeg :: (FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64))
-> Segment ConstMsg -> m (Segment (MutMsg s))
thawSeg FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64)
thaw (ConstSegment vec) =
    AppendVec MVector s Word64 -> Segment (MutMsg s)
forall s. AppendVec MVector s Word64 -> Segment (MutMsg s)
MutSegment (AppendVec MVector s Word64 -> Segment (MutMsg s))
-> m (AppendVec MVector s Word64) -> m (Segment (MutMsg s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrozenAppendVec Vector Word64 -> m (AppendVec MVector s Word64)
thaw (Vector Word64 -> FrozenAppendVec Vector Word64
forall (v :: * -> *) a. v a -> FrozenAppendVec v a
AppendVec.FrozenAppendVec Vector Word64
vec)

freezeSeg
    :: (PrimMonad m, s ~ PrimState m)
    => (AppendVec SMV.MVector s Word64 -> m (AppendVec.FrozenAppendVec SV.Vector Word64))
    -> Segment (MutMsg s)
    -> m (Segment ConstMsg)
freezeSeg :: (AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64))
-> Segment (MutMsg s) -> m (Segment ConstMsg)
freezeSeg AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64)
freeze (MutSegment mvec) =
    Vector Word64 -> Segment ConstMsg
ConstSegment (Vector Word64 -> Segment ConstMsg)
-> (FrozenAppendVec Vector Word64 -> Vector Word64)
-> FrozenAppendVec Vector Word64
-> Segment ConstMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrozenAppendVec Vector Word64 -> Vector Word64
forall (v :: * -> *) a. FrozenAppendVec v a -> v a
AppendVec.getFrozenVector (FrozenAppendVec Vector Word64 -> Segment ConstMsg)
-> m (FrozenAppendVec Vector Word64) -> m (Segment ConstMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppendVec MVector s Word64 -> m (FrozenAppendVec Vector Word64)
freeze AppendVec MVector s Word64
mvec

instance Thaw ConstMsg where
    type Mutable s ConstMsg = MutMsg s

    thaw :: ConstMsg -> m (Mutable s ConstMsg)
thaw         = (Segment ConstMsg -> m (Segment (MutMsg s)))
-> (Vector Client -> m (MVector s Client))
-> ConstMsg
-> m (MutMsg s)
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment ConstMsg -> m (Segment (MutMsg s)))
-> (Vector Client -> m (MVector s Client))
-> ConstMsg
-> m (MutMsg s)
thawMsg   Segment ConstMsg -> m (Segment (MutMsg 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 :: ConstMsg -> m (Mutable s ConstMsg)
unsafeThaw   = (Segment ConstMsg -> m (Segment (MutMsg s)))
-> (Vector Client -> m (MVector s Client))
-> ConstMsg
-> m (MutMsg s)
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment ConstMsg -> m (Segment (MutMsg s)))
-> (Vector Client -> m (MVector s Client))
-> ConstMsg
-> m (MutMsg s)
thawMsg   Segment ConstMsg -> m (Segment (MutMsg 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 ConstMsg -> m ConstMsg
freeze       = (Segment (MutMsg s) -> m (Segment ConstMsg))
-> (MVector s Client -> m (Vector Client))
-> MutMsg s
-> m ConstMsg
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment (MutMsg s) -> m (Segment ConstMsg))
-> (MVector s Client -> m (Vector Client))
-> MutMsg s
-> m ConstMsg
freezeMsg Segment (MutMsg s) -> m (Segment ConstMsg)
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 ConstMsg -> m ConstMsg
unsafeFreeze = (Segment (MutMsg s) -> m (Segment ConstMsg))
-> (MVector s Client -> m (Vector Client))
-> MutMsg s
-> m ConstMsg
forall (m :: * -> *) s.
(PrimMonad m, s ~ PrimState m) =>
(Segment (MutMsg s) -> m (Segment ConstMsg))
-> (MVector s Client -> m (Vector Client))
-> MutMsg s
-> m ConstMsg
freezeMsg Segment (MutMsg s) -> m (Segment ConstMsg)
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 ConstMsg -> m (Segment (MutMsg s)))
    -> (V.Vector Client -> m (MV.MVector s Client))
    -> ConstMsg
    -> m (MutMsg s)
thawMsg :: (Segment ConstMsg -> m (Segment (MutMsg s)))
-> (Vector Client -> m (MVector s Client))
-> ConstMsg
-> m (MutMsg s)
thawMsg Segment ConstMsg -> m (Segment (MutMsg s))
thawSeg Vector Client -> m (MVector s Client)
thawCaps ConstMsg{Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
constSegs :: ConstMsg -> Vector (Segment ConstMsg)
constSegs, Vector Client
constCaps :: Vector Client
constCaps :: ConstMsg -> Vector Client
constCaps}= do
    MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs <- AppendVec MVector s (Segment (MutMsg s))
-> m (MutVar s (AppendVec MVector s (Segment (MutMsg s))))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (AppendVec MVector s (Segment (MutMsg s))
 -> m (MutVar s (AppendVec MVector s (Segment (MutMsg s)))))
-> (MVector s (Segment (MutMsg s))
    -> AppendVec MVector s (Segment (MutMsg s)))
-> MVector s (Segment (MutMsg s))
-> m (MutVar s (AppendVec MVector s (Segment (MutMsg s))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s (Segment (MutMsg s))
-> AppendVec MVector s (Segment (MutMsg s))
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> AppendVec v s a
AppendVec.fromVector (MVector s (Segment (MutMsg s))
 -> m (MutVar s (AppendVec MVector s (Segment (MutMsg s)))))
-> m (MVector s (Segment (MutMsg s)))
-> m (MutVar s (AppendVec MVector s (Segment (MutMsg s))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Segment ConstMsg -> m (Segment (MutMsg s)))
-> Vector (Segment ConstMsg) -> m (Vector (Segment (MutMsg s)))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM Segment ConstMsg -> m (Segment (MutMsg s))
thawSeg Vector (Segment ConstMsg)
constSegs m (Vector (Segment (MutMsg s)))
-> (Vector (Segment (MutMsg s))
    -> m (MVector s (Segment (MutMsg s))))
-> m (MVector s (Segment (MutMsg s)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Vector (Segment (MutMsg s)) -> m (MVector s (Segment (MutMsg 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
    MutMsg s -> m (MutMsg s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutMsg :: forall s.
MutVar s (AppendVec MVector s (Segment (MutMsg s)))
-> MutVar s (AppendVec MVector s Client) -> MutMsg s
MutMsg{MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg s)))
mutSegs :: MutVar s (AppendVec MVector s (Segment (MutMsg 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 (MutMsg s) -> m (Segment ConstMsg))
    -> (MV.MVector s Client -> m (V.Vector Client))
    -> MutMsg s
    -> m ConstMsg
freezeMsg :: (Segment (MutMsg s) -> m (Segment ConstMsg))
-> (MVector s Client -> m (Vector Client))
-> MutMsg s
-> m ConstMsg
freezeMsg Segment (MutMsg s) -> m (Segment ConstMsg)
freezeSeg MVector s Client -> m (Vector Client)
freezeCaps msg :: MutMsg s
msg@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 <- MutMsg s -> m Int
forall (m :: * -> *) msg. Message m msg => msg -> m Int
numSegs MutMsg s
msg
    Vector (Segment ConstMsg)
constSegs <- Int
-> (Int -> m (Segment ConstMsg)) -> m (Vector (Segment ConstMsg))
forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM Int
len (MutMsg s -> Int -> m (Segment (MutMsg s))
forall (m :: * -> *) msg.
Message m msg =>
msg -> Int -> m (Segment msg)
internalGetSeg MutMsg s
msg (Int -> m (Segment (MutMsg s)))
-> (Segment (MutMsg s) -> m (Segment ConstMsg))
-> Int
-> m (Segment ConstMsg)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Segment (MutMsg s) -> m (Segment ConstMsg)
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
    ConstMsg -> m ConstMsg
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstMsg :: Vector (Segment ConstMsg) -> Vector Client -> ConstMsg
ConstMsg{Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
constSegs :: Vector (Segment ConstMsg)
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
            }