{-# LANGUAGE ApplicativeDo              #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-|
Module: Capnp.Untyped
Description: Utilities for reading capnproto messages with no schema.

The types and functions in this module know about things like structs and
lists, but are not schema aware.

Each of the data types exported by this module is parametrized over the
mutability of the message it contains (see "Capnp.Message").
-}
module Capnp.Untyped
    ( Ptr(..), List(..), Struct, ListOf, Cap
    , structByteCount
    , structWordCount
    , structPtrCount
    , structListByteCount
    , structListWordCount
    , structListPtrCount
    , getData, getPtr
    , setData, setPtr
    , copyStruct
    , copyPtr
    , copyList
    , copyCap
    , copyListOf
    , getClient
    , get, index, length
    , setIndex
    , take
    , rootPtr
    , setRoot
    , rawBytes
    , ReadCtx
    , RWCtx
    , HasMessage(..), MessageDefault(..)
    , allocStruct
    , allocCompositeList
    , allocList0
    , allocList1
    , allocList8
    , allocList16
    , allocList32
    , allocList64
    , allocListPtr
    , appendCap

    , TraverseMsg(..)
    )
  where

import Prelude hiding (length, take)

import Data.Bits
import Data.Word

import Control.Exception.Safe    (impureThrow)
import Control.Monad             (forM_, unless)
import Control.Monad.Catch       (MonadCatch, MonadThrow(throwM))
import Control.Monad.Catch.Pure  (CatchT(runCatchT))
import Control.Monad.Primitive   (PrimMonad(..))
import Control.Monad.ST          (RealWorld)
import Control.Monad.Trans.Class (MonadTrans(lift))

import qualified Data.ByteString     as BS
import qualified Language.Haskell.TH as TH

import Capnp.Address        (OffsetError(..), WordAddr(..), pointerFrom)
import Capnp.Bits
    ( BitCount(..)
    , ByteCount(..)
    , Word1(..)
    , WordCount(..)
    , bitsToBytesCeil
    , bytesToWordsCeil
    , replaceBits
    , wordsToBytes
    )
import Capnp.Message        (Mutability(..))
import Capnp.Pointer        (ElementSize(..))
import Capnp.TraversalLimit (LimitT, MonadLimit(invoice))
import Data.Mutable         (Thaw(..))

import qualified Capnp.Errors  as E
import qualified Capnp.Message as M
import qualified Capnp.Pointer as P

-- | Type (constraint) synonym for the constraints needed for most read
-- operations.
type ReadCtx m mut = (M.MonadReadMessage mut m, MonadThrow m, MonadLimit m)

-- | Synonym for ReadCtx + WriteCtx
type RWCtx m s = (ReadCtx m ('Mut s), M.WriteCtx m s)

-- | A an absolute pointer to a value (of arbitrary type) in a message.
-- Note that there is no variant for far pointers, which don't make sense
-- with absolute addressing.
data Ptr mut
    = PtrCap (Cap mut)
    | PtrList (List mut)
    | PtrStruct (Struct mut)

-- | A list of values (of arbitrary type) in a message.
data List mut
    = List0 (ListOf mut ())
    | List1 (ListOf mut Bool)
    | List8 (ListOf mut Word8)
    | List16 (ListOf mut Word16)
    | List32 (ListOf mut Word32)
    | List64 (ListOf mut Word64)
    | ListPtr (ListOf mut (Maybe (Ptr mut)))
    | ListStruct (ListOf mut (Struct mut))

-- | A "normal" (non-composite) list.
data NormalList mut = NormalList
    { NormalList mut -> WordPtr mut
nPtr :: !(M.WordPtr mut)
    , NormalList mut -> Int
nLen :: !Int
    }

-- | A list of values of type 'a' in a message.
data ListOf mut a where
    ListOfStruct
        :: Struct mut -- First element. data/ptr sizes are the same for
                      -- all elements.
        -> !Int       -- Number of elements
        -> ListOf mut (Struct mut)
    ListOfVoid   :: !(NormalList mut) -> ListOf mut ()
    ListOfBool   :: !(NormalList mut) -> ListOf mut Bool
    ListOfWord8  :: !(NormalList mut) -> ListOf mut Word8
    ListOfWord16 :: !(NormalList mut) -> ListOf mut Word16
    ListOfWord32 :: !(NormalList mut) -> ListOf mut Word32
    ListOfWord64 :: !(NormalList mut) -> ListOf mut Word64
    ListOfPtr    :: !(NormalList mut) -> ListOf mut (Maybe (Ptr mut))

-- | A Capability in a message.
data Cap mut = Cap (M.Message mut) !Word32

-- | A struct value in a message.
data Struct mut
    = Struct
        !(M.WordPtr mut) -- Start of struct
        !Word16 -- Data section size.
        !Word16 -- Pointer section size.

-- | N.B. this should mostly be considered an implementation detail, but
-- it is exposed because it is used by generated code.
--
-- 'TraverseMsg' is similar to 'Traversable' from the prelude, but
-- the intent is that rather than conceptually being a "container",
-- the instance is a value backed by a message, and the point of the
-- type class is to be able to apply transformations to the underlying
-- message.
--
-- We don't just use 'Traversable' for this for two reasons:
--
-- 1. While algebraically it makes sense, it would be very unintuitive to
--    e.g. have the 'Traversable' instance for 'List' not traverse over the
--    *elements* of the list.
-- 2. For the instance for WordPtr, we actually need a stronger constraint than
--    Applicative in order for the implementation to type check. A previous
--    version of the library *did* have @tMsg :: Applicative m => ...@, but
--    performance considerations eventually forced us to open up the hood a
--    bit.
class TraverseMsg f where
    tMsg :: TraverseMsgCtx m mutA mutB => (M.Message mutA -> m (M.Message mutB)) -> f mutA -> m (f mutB)

type TraverseMsgCtx m mutA mutB =
    ( MonadThrow m
    , M.MonadReadMessage mutA m
    , M.MonadReadMessage mutB m
    )

instance TraverseMsg M.WordPtr where
    tMsg :: (Message mutA -> m (Message mutB))
-> WordPtr mutA -> m (WordPtr mutB)
tMsg Message mutA -> m (Message mutB)
f M.WordPtr{Message mutA
pMessage :: forall (mut :: Mutability). WordPtr mut -> Message mut
pMessage :: Message mutA
pMessage, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=pAddr :: WordAddr
pAddr@WordAt{Int
segIndex :: WordAddr -> Int
segIndex :: Int
segIndex}} = do
        Message mutB
msg' <- Message mutA -> m (Message mutB)
f Message mutA
pMessage
        Segment mutB
seg' <- Message mutB -> Int -> m (Segment mutB)
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mutB
msg' Int
segIndex
        pure WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr
            { pMessage :: Message mutB
pMessage = Message mutB
msg'
            , pSegment :: Segment mutB
pSegment = Segment mutB
seg'
            , WordAddr
pAddr :: WordAddr
pAddr :: WordAddr
pAddr
            }

instance TraverseMsg Ptr where
    tMsg :: (Message mutA -> m (Message mutB)) -> Ptr mutA -> m (Ptr mutB)
tMsg Message mutA -> m (Message mutB)
f = \case
        PtrCap Cap mutA
cap ->
            Cap mutB -> Ptr mutB
forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap (Cap mutB -> Ptr mutB) -> m (Cap mutB) -> m (Ptr mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB)) -> Cap mutA -> m (Cap mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f Cap mutA
cap
        PtrList List mutA
l ->
            List mutB -> Ptr mutB
forall (mut :: Mutability). List mut -> Ptr mut
PtrList (List mutB -> Ptr mutB) -> m (List mutB) -> m (Ptr mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB)) -> List mutA -> m (List mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f List mutA
l
        PtrStruct Struct mutA
s ->
            Struct mutB -> Ptr mutB
forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct (Struct mutB -> Ptr mutB) -> m (Struct mutB) -> m (Ptr mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> Struct mutA -> m (Struct mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f Struct mutA
s

instance TraverseMsg Cap where
    tMsg :: (Message mutA -> m (Message mutB)) -> Cap mutA -> m (Cap mutB)
tMsg Message mutA -> m (Message mutB)
f (Cap Message mutA
msg Word32
n) = Message mutB -> Word32 -> Cap mutB
forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
Cap (Message mutB -> Word32 -> Cap mutB)
-> m (Message mutB) -> m (Word32 -> Cap mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mutA -> m (Message mutB)
f Message mutA
msg m (Word32 -> Cap mutB) -> m Word32 -> m (Cap mutB)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word32 -> m Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
n

instance TraverseMsg Struct where
    tMsg :: (Message mutA -> m (Message mutB))
-> Struct mutA -> m (Struct mutB)
tMsg Message mutA -> m (Message mutB)
f (Struct WordPtr mutA
ptr Word16
dataSz Word16
ptrSz) = WordPtr mutB -> Word16 -> Word16 -> Struct mutB
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct
        (WordPtr mutB -> Word16 -> Word16 -> Struct mutB)
-> m (WordPtr mutB) -> m (Word16 -> Word16 -> Struct mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> WordPtr mutA -> m (WordPtr mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f WordPtr mutA
ptr
        m (Word16 -> Word16 -> Struct mutB)
-> m Word16 -> m (Word16 -> Struct mutB)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word16 -> m Word16
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
dataSz
        m (Word16 -> Struct mutB) -> m Word16 -> m (Struct mutB)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word16 -> m Word16
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
ptrSz

instance TraverseMsg List where
    tMsg :: (Message mutA -> m (Message mutB)) -> List mutA -> m (List mutB)
tMsg Message mutA -> m (Message mutB)
f = \case
        List0      ListOf mutA ()
l -> ListOf mutB () -> List mutB
forall (mut :: Mutability). ListOf mut () -> List mut
List0      (ListOf mutB () -> List mutB)
-> (FlipList () mutB -> ListOf mutB ())
-> FlipList () mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipList () mutB -> ListOf mutB ()
forall a (msg :: Mutability). FlipList a msg -> ListOf msg a
unflip  (FlipList () mutB -> List mutB)
-> m (FlipList () mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipList () mutA -> m (FlipList () mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA () -> FlipList () mutA
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList  ListOf mutA ()
l)
        List1      ListOf mutA Bool
l -> ListOf mutB Bool -> List mutB
forall (mut :: Mutability). ListOf mut Bool -> List mut
List1      (ListOf mutB Bool -> List mutB)
-> (FlipList Bool mutB -> ListOf mutB Bool)
-> FlipList Bool mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipList Bool mutB -> ListOf mutB Bool
forall a (msg :: Mutability). FlipList a msg -> ListOf msg a
unflip  (FlipList Bool mutB -> List mutB)
-> m (FlipList Bool mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipList Bool mutA -> m (FlipList Bool mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA Bool -> FlipList Bool mutA
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList  ListOf mutA Bool
l)
        List8      ListOf mutA Word8
l -> ListOf mutB Word8 -> List mutB
forall (mut :: Mutability). ListOf mut Word8 -> List mut
List8      (ListOf mutB Word8 -> List mutB)
-> (FlipList Word8 mutB -> ListOf mutB Word8)
-> FlipList Word8 mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipList Word8 mutB -> ListOf mutB Word8
forall a (msg :: Mutability). FlipList a msg -> ListOf msg a
unflip  (FlipList Word8 mutB -> List mutB)
-> m (FlipList Word8 mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipList Word8 mutA -> m (FlipList Word8 mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA Word8 -> FlipList Word8 mutA
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList  ListOf mutA Word8
l)
        List16     ListOf mutA Word16
l -> ListOf mutB Word16 -> List mutB
forall (mut :: Mutability). ListOf mut Word16 -> List mut
List16     (ListOf mutB Word16 -> List mutB)
-> (FlipList Word16 mutB -> ListOf mutB Word16)
-> FlipList Word16 mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipList Word16 mutB -> ListOf mutB Word16
forall a (msg :: Mutability). FlipList a msg -> ListOf msg a
unflip  (FlipList Word16 mutB -> List mutB)
-> m (FlipList Word16 mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipList Word16 mutA -> m (FlipList Word16 mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA Word16 -> FlipList Word16 mutA
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList  ListOf mutA Word16
l)
        List32     ListOf mutA Word32
l -> ListOf mutB Word32 -> List mutB
forall (mut :: Mutability). ListOf mut Word32 -> List mut
List32     (ListOf mutB Word32 -> List mutB)
-> (FlipList Word32 mutB -> ListOf mutB Word32)
-> FlipList Word32 mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipList Word32 mutB -> ListOf mutB Word32
forall a (msg :: Mutability). FlipList a msg -> ListOf msg a
unflip  (FlipList Word32 mutB -> List mutB)
-> m (FlipList Word32 mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipList Word32 mutA -> m (FlipList Word32 mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA Word32 -> FlipList Word32 mutA
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList  ListOf mutA Word32
l)
        List64     ListOf mutA Word64
l -> ListOf mutB Word64 -> List mutB
forall (mut :: Mutability). ListOf mut Word64 -> List mut
List64     (ListOf mutB Word64 -> List mutB)
-> (FlipList Word64 mutB -> ListOf mutB Word64)
-> FlipList Word64 mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipList Word64 mutB -> ListOf mutB Word64
forall a (msg :: Mutability). FlipList a msg -> ListOf msg a
unflip  (FlipList Word64 mutB -> List mutB)
-> m (FlipList Word64 mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipList Word64 mutA -> m (FlipList Word64 mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA Word64 -> FlipList Word64 mutA
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList  ListOf mutA Word64
l)
        ListPtr    ListOf mutA (Maybe (Ptr mutA))
l -> ListOf mutB (Maybe (Ptr mutB)) -> List mutB
forall (mut :: Mutability).
ListOf mut (Maybe (Ptr mut)) -> List mut
ListPtr    (ListOf mutB (Maybe (Ptr mutB)) -> List mutB)
-> (FlipListP mutB -> ListOf mutB (Maybe (Ptr mutB)))
-> FlipListP mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipListP mutB -> ListOf mutB (Maybe (Ptr mutB))
forall (msg :: Mutability).
FlipListP msg -> ListOf msg (Maybe (Ptr msg))
unflipP (FlipListP mutB -> List mutB)
-> m (FlipListP mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipListP mutA -> m (FlipListP mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA (Maybe (Ptr mutA)) -> FlipListP mutA
forall (msg :: Mutability).
ListOf msg (Maybe (Ptr msg)) -> FlipListP msg
FlipListP ListOf mutA (Maybe (Ptr mutA))
l)
        ListStruct ListOf mutA (Struct mutA)
l -> ListOf mutB (Struct mutB) -> List mutB
forall (mut :: Mutability). ListOf mut (Struct mut) -> List mut
ListStruct (ListOf mutB (Struct mutB) -> List mutB)
-> (FlipListS mutB -> ListOf mutB (Struct mutB))
-> FlipListS mutB
-> List mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipListS mutB -> ListOf mutB (Struct mutB)
forall (msg :: Mutability).
FlipListS msg -> ListOf msg (Struct msg)
unflipS (FlipListS mutB -> List mutB)
-> m (FlipListS mutB) -> m (List mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipListS mutA -> m (FlipListS mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA (Struct mutA) -> FlipListS mutA
forall (msg :: Mutability).
ListOf msg (Struct msg) -> FlipListS msg
FlipListS ListOf mutA (Struct mutA)
l)

instance TraverseMsg NormalList where
    tMsg :: (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList{Int
WordPtr mutA
nLen :: Int
nPtr :: WordPtr mutA
nLen :: forall (mut :: Mutability). NormalList mut -> Int
nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
..} = do
        WordPtr mutB
ptr <- (Message mutA -> m (Message mutB))
-> WordPtr mutA -> m (WordPtr mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f WordPtr mutA
nPtr
        pure NormalList :: forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList { nPtr :: WordPtr mutB
nPtr = WordPtr mutB
ptr, Int
nLen :: Int
nLen :: Int
.. }

-------------------------------------------------------------------------------
-- newtype wrappers for the purpose of implementing 'TraverseMsg'; these adjust
-- the shape of 'ListOf' so that we can define an instance. We need a couple
-- different wrappers depending on the shape of the element type.
-------------------------------------------------------------------------------

-- 'FlipList' wraps a @ListOf msg a@ where 'a' is of kind @*@.
newtype FlipList  a msg = FlipList  { FlipList a msg -> ListOf msg a
unflip  :: ListOf msg a                 }

-- 'FlipListS' wraps a @ListOf msg (Struct msg)@. We can't use 'FlipList' for
-- our instances, because we need both instances of the 'msg' parameter to stay
-- equal.
newtype FlipListS   msg = FlipListS { FlipListS msg -> ListOf msg (Struct msg)
unflipS :: ListOf msg (Struct msg)      }

-- 'FlipListP' wraps a @ListOf msg (Maybe (Ptr msg))@. Pointers can't use
-- 'FlipList' for the same reason as structs.
newtype FlipListP   msg = FlipListP { FlipListP msg -> ListOf msg (Maybe (Ptr msg))
unflipP :: ListOf msg (Maybe (Ptr msg)) }

-------------------------------------------------------------------------------
-- 'TraverseMsg' instances for 'FlipList'
-------------------------------------------------------------------------------

instance TraverseMsg (FlipList ()) where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipList () mutA -> m (FlipList () mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipList (ListOfVoid   NormalList mutA
nlist)) = ListOf mutB () -> FlipList () mutB
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList (ListOf mutB () -> FlipList () mutB)
-> (NormalList mutB -> ListOf mutB ())
-> NormalList mutB
-> FlipList () mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mutB -> ListOf mutB ()
forall (mut :: Mutability). NormalList mut -> ListOf mut ()
ListOfVoid (NormalList mutB -> FlipList () mutB)
-> m (NormalList mutB) -> m (FlipList () mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList mutA
nlist

instance TraverseMsg (FlipList Bool) where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipList Bool mutA -> m (FlipList Bool mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipList (ListOfBool   NormalList mutA
nlist)) = ListOf mutB Bool -> FlipList Bool mutB
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList (ListOf mutB Bool -> FlipList Bool mutB)
-> (NormalList mutB -> ListOf mutB Bool)
-> NormalList mutB
-> FlipList Bool mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mutB -> ListOf mutB Bool
forall (mut :: Mutability). NormalList mut -> ListOf mut Bool
ListOfBool   (NormalList mutB -> FlipList Bool mutB)
-> m (NormalList mutB) -> m (FlipList Bool mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList mutA
nlist

instance TraverseMsg (FlipList Word8) where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipList Word8 mutA -> m (FlipList Word8 mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipList (ListOfWord8  NormalList mutA
nlist)) = ListOf mutB Word8 -> FlipList Word8 mutB
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList (ListOf mutB Word8 -> FlipList Word8 mutB)
-> (NormalList mutB -> ListOf mutB Word8)
-> NormalList mutB
-> FlipList Word8 mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mutB -> ListOf mutB Word8
forall (mut :: Mutability). NormalList mut -> ListOf mut Word8
ListOfWord8  (NormalList mutB -> FlipList Word8 mutB)
-> m (NormalList mutB) -> m (FlipList Word8 mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList mutA
nlist

instance TraverseMsg (FlipList Word16) where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipList Word16 mutA -> m (FlipList Word16 mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipList (ListOfWord16 NormalList mutA
nlist)) = ListOf mutB Word16 -> FlipList Word16 mutB
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList (ListOf mutB Word16 -> FlipList Word16 mutB)
-> (NormalList mutB -> ListOf mutB Word16)
-> NormalList mutB
-> FlipList Word16 mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mutB -> ListOf mutB Word16
forall (mut :: Mutability). NormalList mut -> ListOf mut Word16
ListOfWord16 (NormalList mutB -> FlipList Word16 mutB)
-> m (NormalList mutB) -> m (FlipList Word16 mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList mutA
nlist

instance TraverseMsg (FlipList Word32) where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipList Word32 mutA -> m (FlipList Word32 mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipList (ListOfWord32 NormalList mutA
nlist)) = ListOf mutB Word32 -> FlipList Word32 mutB
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList (ListOf mutB Word32 -> FlipList Word32 mutB)
-> (NormalList mutB -> ListOf mutB Word32)
-> NormalList mutB
-> FlipList Word32 mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mutB -> ListOf mutB Word32
forall (mut :: Mutability). NormalList mut -> ListOf mut Word32
ListOfWord32 (NormalList mutB -> FlipList Word32 mutB)
-> m (NormalList mutB) -> m (FlipList Word32 mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList mutA
nlist

instance TraverseMsg (FlipList Word64) where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipList Word64 mutA -> m (FlipList Word64 mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipList (ListOfWord64 NormalList mutA
nlist)) = ListOf mutB Word64 -> FlipList Word64 mutB
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList (ListOf mutB Word64 -> FlipList Word64 mutB)
-> (NormalList mutB -> ListOf mutB Word64)
-> NormalList mutB
-> FlipList Word64 mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mutB -> ListOf mutB Word64
forall (mut :: Mutability). NormalList mut -> ListOf mut Word64
ListOfWord64 (NormalList mutB -> FlipList Word64 mutB)
-> m (NormalList mutB) -> m (FlipList Word64 mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList mutA
nlist

-------------------------------------------------------------------------------
-- 'TraverseMsg' instances for struct and pointer lists.
-------------------------------------------------------------------------------

instance TraverseMsg FlipListP where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipListP mutA -> m (FlipListP mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipListP (ListOfPtr NormalList mutA
nlist))   = ListOf mutB (Maybe (Ptr mutB)) -> FlipListP mutB
forall (msg :: Mutability).
ListOf msg (Maybe (Ptr msg)) -> FlipListP msg
FlipListP (ListOf mutB (Maybe (Ptr mutB)) -> FlipListP mutB)
-> (NormalList mutB -> ListOf mutB (Maybe (Ptr mutB)))
-> NormalList mutB
-> FlipListP mutB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mutB -> ListOf mutB (Maybe (Ptr mutB))
forall (mut :: Mutability).
NormalList mut -> ListOf mut (Maybe (Ptr mut))
ListOfPtr   (NormalList mutB -> FlipListP mutB)
-> m (NormalList mutB) -> m (FlipListP mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> NormalList mutA -> m (NormalList mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f NormalList mutA
nlist

instance TraverseMsg FlipListS where
    tMsg :: (Message mutA -> m (Message mutB))
-> FlipListS mutA -> m (FlipListS mutB)
tMsg Message mutA -> m (Message mutB)
f (FlipListS (ListOfStruct Struct mutA
tag Int
size)) =
        ListOf mutB (Struct mutB) -> FlipListS mutB
forall (msg :: Mutability).
ListOf msg (Struct msg) -> FlipListS msg
FlipListS (ListOf mutB (Struct mutB) -> FlipListS mutB)
-> m (ListOf mutB (Struct mutB)) -> m (FlipListS mutB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Struct mutB -> Int -> ListOf mutB (Struct mutB)
forall (mut :: Mutability).
Struct mut -> Int -> ListOf mut (Struct mut)
ListOfStruct (Struct mutB -> Int -> ListOf mutB (Struct mutB))
-> m (Struct mutB) -> m (Int -> ListOf mutB (Struct mutB))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> Struct mutA -> m (Struct mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f Struct mutA
tag m (Int -> ListOf mutB (Struct mutB))
-> m Int -> m (ListOf mutB (Struct mutB))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
size)

-- helpers for applying tMsg to a @ListOf@.
tFlip  :: (TraverseMsg (FlipList a), TraverseMsgCtx m mutA mutB)
    => (M.Message mutA -> m (M.Message mutB)) -> ListOf mutA a -> m (ListOf mutB a)
tFlipS :: TraverseMsgCtx m mutA mutB => (M.Message mutA -> m (M.Message mutB)) -> ListOf mutA (Struct mutA) -> m (ListOf mutB (Struct mutB ))
tFlipP :: TraverseMsgCtx m mutA mutB => (M.Message mutA -> m (M.Message mutB)) -> ListOf mutA (Maybe (Ptr mutA)) -> m (ListOf mutB (Maybe (Ptr mutB)))
tFlip :: (Message mutA -> m (Message mutB))
-> ListOf mutA a -> m (ListOf mutB a)
tFlip  Message mutA -> m (Message mutB)
f ListOf mutA a
list  = FlipList a mutB -> ListOf mutB a
forall a (msg :: Mutability). FlipList a msg -> ListOf msg a
unflip  (FlipList a mutB -> ListOf mutB a)
-> m (FlipList a mutB) -> m (ListOf mutB a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipList a mutA -> m (FlipList a mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA a -> FlipList a mutA
forall a (msg :: Mutability). ListOf msg a -> FlipList a msg
FlipList  ListOf mutA a
list)
tFlipS :: (Message mutA -> m (Message mutB))
-> ListOf mutA (Struct mutA) -> m (ListOf mutB (Struct mutB))
tFlipS Message mutA -> m (Message mutB)
f ListOf mutA (Struct mutA)
list  = FlipListS mutB -> ListOf mutB (Struct mutB)
forall (msg :: Mutability).
FlipListS msg -> ListOf msg (Struct msg)
unflipS (FlipListS mutB -> ListOf mutB (Struct mutB))
-> m (FlipListS mutB) -> m (ListOf mutB (Struct mutB))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipListS mutA -> m (FlipListS mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA (Struct mutA) -> FlipListS mutA
forall (msg :: Mutability).
ListOf msg (Struct msg) -> FlipListS msg
FlipListS ListOf mutA (Struct mutA)
list)
tFlipP :: (Message mutA -> m (Message mutB))
-> ListOf mutA (Maybe (Ptr mutA))
-> m (ListOf mutB (Maybe (Ptr mutB)))
tFlipP Message mutA -> m (Message mutB)
f ListOf mutA (Maybe (Ptr mutA))
list  = FlipListP mutB -> ListOf mutB (Maybe (Ptr mutB))
forall (msg :: Mutability).
FlipListP msg -> ListOf msg (Maybe (Ptr msg))
unflipP (FlipListP mutB -> ListOf mutB (Maybe (Ptr mutB)))
-> m (FlipListP mutB) -> m (ListOf mutB (Maybe (Ptr mutB)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message mutA -> m (Message mutB))
-> FlipListP mutA -> m (FlipListP mutB)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf mutA (Maybe (Ptr mutA)) -> FlipListP mutA
forall (msg :: Mutability).
ListOf msg (Maybe (Ptr msg)) -> FlipListP msg
FlipListP ListOf mutA (Maybe (Ptr mutA))
list)

-------------------------------------------------------------------------------
-- Boilerplate 'Thaw' instances.
--
-- These all just call the underlying methods on the message, using 'TraverseMsg'.
-------------------------------------------------------------------------------

instance Thaw a => Thaw (Maybe a) where
    type Mutable s (Maybe a) = Maybe (Mutable s a)

    thaw :: Maybe a -> m (Mutable s (Maybe a))
thaw         = (a -> m (Mutable s a)) -> Maybe a -> m (Maybe (Mutable s a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m (Mutable s a)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw
    freeze :: Mutable s (Maybe a) -> m (Maybe a)
freeze       = (Mutable s a -> m a) -> Maybe (Mutable s a) -> m (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Mutable s a -> m a
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze
    unsafeThaw :: Maybe a -> m (Mutable s (Maybe a))
unsafeThaw   = (a -> m (Mutable s a)) -> Maybe a -> m (Maybe (Mutable s a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m (Mutable s a)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
unsafeThaw
    unsafeFreeze :: Mutable s (Maybe a) -> m (Maybe a)
unsafeFreeze = (Mutable s a -> m a) -> Maybe (Mutable s a) -> m (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Mutable s a -> m a
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
unsafeFreeze

do
    let mkWrappedInstance name =
            let f = pure $ TH.ConT name in
            [d|instance Thaw ($f 'Const) where
                type Mutable s ($f 'Const) = $f ('Mut s)

                thaw         = runCatchImpure . tMsg thaw
                freeze       = runCatchImpure . tMsg freeze
                unsafeThaw   = runCatchImpure . tMsg unsafeThaw
                unsafeFreeze = runCatchImpure . tMsg unsafeFreeze
            |]
        mkListOfInstance t =
            [d|instance Thaw (ListOf 'Const $t) where
                type Mutable s (ListOf 'Const $t) = ListOf ('Mut s) $t

                thaw         = runCatchImpure . tFlip thaw
                freeze       = runCatchImpure . tFlip freeze
                unsafeThaw   = runCatchImpure . tFlip unsafeThaw
                unsafeFreeze = runCatchImpure . tFlip unsafeFreeze
            |]
    xs <- traverse mkWrappedInstance
        [ ''Ptr
        , ''List
        , ''NormalList
        , ''Struct
        ]
    ys <- traverse mkListOfInstance
        [ [t|()|]
        , [t|Bool|]
        , [t|Word8|]
        , [t|Word16|]
        , [t|Word32|]
        , [t|Word64|]
        ]
    pure $ concat $ xs ++ ys

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

    thaw :: ListOf 'Const (Struct 'Const)
-> m (Mutable s (ListOf 'Const (Struct 'Const)))
thaw         = CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s)))
-> m (ListOf ('Mut s) (Struct ('Mut s)))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s)))
 -> m (ListOf ('Mut s) (Struct ('Mut s))))
-> (ListOf 'Const (Struct 'Const)
    -> CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s))))
-> ListOf 'Const (Struct 'Const)
-> m (ListOf ('Mut s) (Struct ('Mut s)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message 'Const -> CatchTWrap m (Message ('Mut s)))
-> ListOf 'Const (Struct 'Const)
-> CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s)))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Struct mutA) -> m (ListOf mutB (Struct mutB))
tFlipS Message 'Const -> CatchTWrap m (Message ('Mut s))
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw
    freeze :: Mutable s (ListOf 'Const (Struct 'Const))
-> m (ListOf 'Const (Struct 'Const))
freeze       = CatchTWrap m (ListOf 'Const (Struct 'Const))
-> m (ListOf 'Const (Struct 'Const))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf 'Const (Struct 'Const))
 -> m (ListOf 'Const (Struct 'Const)))
-> (ListOf ('Mut s) (Struct ('Mut s))
    -> CatchTWrap m (ListOf 'Const (Struct 'Const)))
-> ListOf ('Mut s) (Struct ('Mut s))
-> m (ListOf 'Const (Struct 'Const))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message ('Mut s) -> CatchTWrap m (Message 'Const))
-> ListOf ('Mut s) (Struct ('Mut s))
-> CatchTWrap m (ListOf 'Const (Struct 'Const))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Struct mutA) -> m (ListOf mutB (Struct mutB))
tFlipS Message ('Mut s) -> CatchTWrap m (Message 'Const)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze
    unsafeThaw :: ListOf 'Const (Struct 'Const)
-> m (Mutable s (ListOf 'Const (Struct 'Const)))
unsafeThaw   = CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s)))
-> m (ListOf ('Mut s) (Struct ('Mut s)))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s)))
 -> m (ListOf ('Mut s) (Struct ('Mut s))))
-> (ListOf 'Const (Struct 'Const)
    -> CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s))))
-> ListOf 'Const (Struct 'Const)
-> m (ListOf ('Mut s) (Struct ('Mut s)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message 'Const -> CatchTWrap m (Message ('Mut s)))
-> ListOf 'Const (Struct 'Const)
-> CatchTWrap m (ListOf ('Mut s) (Struct ('Mut s)))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Struct mutA) -> m (ListOf mutB (Struct mutB))
tFlipS Message 'Const -> CatchTWrap m (Message ('Mut s))
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
unsafeThaw
    unsafeFreeze :: Mutable s (ListOf 'Const (Struct 'Const))
-> m (ListOf 'Const (Struct 'Const))
unsafeFreeze = CatchTWrap m (ListOf 'Const (Struct 'Const))
-> m (ListOf 'Const (Struct 'Const))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf 'Const (Struct 'Const))
 -> m (ListOf 'Const (Struct 'Const)))
-> (ListOf ('Mut s) (Struct ('Mut s))
    -> CatchTWrap m (ListOf 'Const (Struct 'Const)))
-> ListOf ('Mut s) (Struct ('Mut s))
-> m (ListOf 'Const (Struct 'Const))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message ('Mut s) -> CatchTWrap m (Message 'Const))
-> ListOf ('Mut s) (Struct ('Mut s))
-> CatchTWrap m (ListOf 'Const (Struct 'Const))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Struct mutA) -> m (ListOf mutB (Struct mutB))
tFlipS Message ('Mut s) -> CatchTWrap m (Message 'Const)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
unsafeFreeze

instance Thaw (ListOf 'Const (Maybe (Ptr 'Const))) where
    type Mutable s (ListOf 'Const (Maybe (Ptr 'Const))) =
        ListOf ('Mut s) (Maybe (Ptr ('Mut s)))

    thaw :: ListOf 'Const (Maybe (Ptr 'Const))
-> m (Mutable s (ListOf 'Const (Maybe (Ptr 'Const))))
thaw         = CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
-> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
 -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))))
-> (ListOf 'Const (Maybe (Ptr 'Const))
    -> CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))))
-> ListOf 'Const (Maybe (Ptr 'Const))
-> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message 'Const -> CatchTWrap m (Message ('Mut s)))
-> ListOf 'Const (Maybe (Ptr 'Const))
-> CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Maybe (Ptr mutA))
-> m (ListOf mutB (Maybe (Ptr mutB)))
tFlipP Message 'Const -> CatchTWrap m (Message ('Mut s))
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw
    freeze :: Mutable s (ListOf 'Const (Maybe (Ptr 'Const)))
-> m (ListOf 'Const (Maybe (Ptr 'Const)))
freeze       = CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const)))
-> m (ListOf 'Const (Maybe (Ptr 'Const)))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const)))
 -> m (ListOf 'Const (Maybe (Ptr 'Const))))
-> (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
    -> CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const))))
-> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
-> m (ListOf 'Const (Maybe (Ptr 'Const)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message ('Mut s) -> CatchTWrap m (Message 'Const))
-> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
-> CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const)))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Maybe (Ptr mutA))
-> m (ListOf mutB (Maybe (Ptr mutB)))
tFlipP Message ('Mut s) -> CatchTWrap m (Message 'Const)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze
    unsafeThaw :: ListOf 'Const (Maybe (Ptr 'Const))
-> m (Mutable s (ListOf 'Const (Maybe (Ptr 'Const))))
unsafeThaw   = CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
-> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
 -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))))
-> (ListOf 'Const (Maybe (Ptr 'Const))
    -> CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))))
-> ListOf 'Const (Maybe (Ptr 'Const))
-> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message 'Const -> CatchTWrap m (Message ('Mut s)))
-> ListOf 'Const (Maybe (Ptr 'Const))
-> CatchTWrap m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Maybe (Ptr mutA))
-> m (ListOf mutB (Maybe (Ptr mutB)))
tFlipP Message 'Const -> CatchTWrap m (Message ('Mut s))
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
unsafeThaw
    unsafeFreeze :: Mutable s (ListOf 'Const (Maybe (Ptr 'Const)))
-> m (ListOf 'Const (Maybe (Ptr 'Const)))
unsafeFreeze = CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const)))
-> m (ListOf 'Const (Maybe (Ptr 'Const)))
forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure (CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const)))
 -> m (ListOf 'Const (Maybe (Ptr 'Const))))
-> (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
    -> CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const))))
-> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
-> m (ListOf 'Const (Maybe (Ptr 'Const)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message ('Mut s) -> CatchTWrap m (Message 'Const))
-> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
-> CatchTWrap m (ListOf 'Const (Maybe (Ptr 'Const)))
forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf mutA (Maybe (Ptr mutA))
-> m (ListOf mutB (Maybe (Ptr mutB)))
tFlipP Message ('Mut s) -> CatchTWrap m (Message 'Const)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
unsafeFreeze

-------------------------------------------------------------------------------
-- Helpers for the above boilerplate Thaw instances
-------------------------------------------------------------------------------

-- trivial wrapaper around CatchT, so we can add a PrimMonad instance.
newtype CatchTWrap m a = CatchTWrap { CatchTWrap m a -> CatchT m a
runCatchTWrap :: CatchT m a }
    deriving(a -> CatchTWrap m b -> CatchTWrap m a
(a -> b) -> CatchTWrap m a -> CatchTWrap m b
(forall a b. (a -> b) -> CatchTWrap m a -> CatchTWrap m b)
-> (forall a b. a -> CatchTWrap m b -> CatchTWrap m a)
-> Functor (CatchTWrap m)
forall a b. a -> CatchTWrap m b -> CatchTWrap m a
forall a b. (a -> b) -> CatchTWrap m a -> CatchTWrap m b
forall (m :: * -> *) a b.
Monad m =>
a -> CatchTWrap m b -> CatchTWrap m a
forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> CatchTWrap m a -> CatchTWrap m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CatchTWrap m b -> CatchTWrap m a
$c<$ :: forall (m :: * -> *) a b.
Monad m =>
a -> CatchTWrap m b -> CatchTWrap m a
fmap :: (a -> b) -> CatchTWrap m a -> CatchTWrap m b
$cfmap :: forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> CatchTWrap m a -> CatchTWrap m b
Functor, Functor (CatchTWrap m)
a -> CatchTWrap m a
Functor (CatchTWrap m)
-> (forall a. a -> CatchTWrap m a)
-> (forall a b.
    CatchTWrap m (a -> b) -> CatchTWrap m a -> CatchTWrap m b)
-> (forall a b c.
    (a -> b -> c)
    -> CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m c)
-> (forall a b. CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b)
-> (forall a b. CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m a)
-> Applicative (CatchTWrap m)
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m a
CatchTWrap m (a -> b) -> CatchTWrap m a -> CatchTWrap m b
(a -> b -> c) -> CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m c
forall a. a -> CatchTWrap m a
forall a b. CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m a
forall a b. CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
forall a b.
CatchTWrap m (a -> b) -> CatchTWrap m a -> CatchTWrap m b
forall a b c.
(a -> b -> c) -> CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m c
forall (m :: * -> *). Monad m => Functor (CatchTWrap m)
forall (m :: * -> *) a. Monad m => a -> CatchTWrap m a
forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m a
forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m (a -> b) -> CatchTWrap m a -> CatchTWrap m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m a
*> :: CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
liftA2 :: (a -> b -> c) -> CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m c
<*> :: CatchTWrap m (a -> b) -> CatchTWrap m a -> CatchTWrap m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m (a -> b) -> CatchTWrap m a -> CatchTWrap m b
pure :: a -> CatchTWrap m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> CatchTWrap m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (CatchTWrap m)
Applicative, Applicative (CatchTWrap m)
a -> CatchTWrap m a
Applicative (CatchTWrap m)
-> (forall a b.
    CatchTWrap m a -> (a -> CatchTWrap m b) -> CatchTWrap m b)
-> (forall a b. CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b)
-> (forall a. a -> CatchTWrap m a)
-> Monad (CatchTWrap m)
CatchTWrap m a -> (a -> CatchTWrap m b) -> CatchTWrap m b
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
forall a. a -> CatchTWrap m a
forall a b. CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
forall a b.
CatchTWrap m a -> (a -> CatchTWrap m b) -> CatchTWrap m b
forall (m :: * -> *). Monad m => Applicative (CatchTWrap m)
forall (m :: * -> *) a. Monad m => a -> CatchTWrap m a
forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> (a -> CatchTWrap m b) -> CatchTWrap m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> CatchTWrap m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> CatchTWrap m a
>> :: CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> CatchTWrap m b -> CatchTWrap m b
>>= :: CatchTWrap m a -> (a -> CatchTWrap m b) -> CatchTWrap m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
CatchTWrap m a -> (a -> CatchTWrap m b) -> CatchTWrap m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (CatchTWrap m)
Monad, m a -> CatchTWrap m a
(forall (m :: * -> *) a. Monad m => m a -> CatchTWrap m a)
-> MonadTrans CatchTWrap
forall (m :: * -> *) a. Monad m => m a -> CatchTWrap m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> CatchTWrap m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> CatchTWrap m a
MonadTrans, Monad (CatchTWrap m)
e -> CatchTWrap m a
Monad (CatchTWrap m)
-> (forall e a. Exception e => e -> CatchTWrap m a)
-> MonadThrow (CatchTWrap m)
forall e a. Exception e => e -> CatchTWrap m a
forall (m :: * -> *). Monad m => Monad (CatchTWrap m)
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall (m :: * -> *) e a.
(Monad m, Exception e) =>
e -> CatchTWrap m a
throwM :: e -> CatchTWrap m a
$cthrowM :: forall (m :: * -> *) e a.
(Monad m, Exception e) =>
e -> CatchTWrap m a
$cp1MonadThrow :: forall (m :: * -> *). Monad m => Monad (CatchTWrap m)
MonadThrow, MonadThrow (CatchTWrap m)
MonadThrow (CatchTWrap m)
-> (forall e a.
    Exception e =>
    CatchTWrap m a -> (e -> CatchTWrap m a) -> CatchTWrap m a)
-> MonadCatch (CatchTWrap m)
CatchTWrap m a -> (e -> CatchTWrap m a) -> CatchTWrap m a
forall e a.
Exception e =>
CatchTWrap m a -> (e -> CatchTWrap m a) -> CatchTWrap m a
forall (m :: * -> *). Monad m => MonadThrow (CatchTWrap m)
forall (m :: * -> *) e a.
(Monad m, Exception e) =>
CatchTWrap m a -> (e -> CatchTWrap m a) -> CatchTWrap m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: CatchTWrap m a -> (e -> CatchTWrap m a) -> CatchTWrap m a
$ccatch :: forall (m :: * -> *) e a.
(Monad m, Exception e) =>
CatchTWrap m a -> (e -> CatchTWrap m a) -> CatchTWrap m a
$cp1MonadCatch :: forall (m :: * -> *). Monad m => MonadThrow (CatchTWrap m)
MonadCatch)

instance PrimMonad m => PrimMonad (CatchTWrap m) where
    type PrimState (CatchTWrap m) = PrimState m
    primitive :: (State# (PrimState (CatchTWrap m))
 -> (# State# (PrimState (CatchTWrap m)), a #))
-> CatchTWrap m a
primitive = m a -> CatchTWrap m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CatchTWrap m a)
-> ((State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> (State# (PrimState m) -> (# State# (PrimState m), a #))
-> CatchTWrap m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive

-- | @runCatchImpure m@ runs @m@, and if it throws, raises the
-- exception with 'impureThrow'.
runCatchImpure :: Monad m => CatchTWrap m a -> m a
runCatchImpure :: CatchTWrap m a -> m a
runCatchImpure CatchTWrap m a
m = do
    Either SomeException a
res <- CatchT m a -> m (Either SomeException a)
forall (m :: * -> *) a. CatchT m a -> m (Either SomeException a)
runCatchT (CatchT m a -> m (Either SomeException a))
-> CatchT m a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ CatchTWrap m a -> CatchT m a
forall (m :: * -> *) a. CatchTWrap m a -> CatchT m a
runCatchTWrap CatchTWrap m a
m
    pure $ case Either SomeException a
res of
        Left SomeException
e  -> SomeException -> a
forall e a. Exception e => e -> a
impureThrow SomeException
e
        Right a
v -> a
v

-------------------------------------------------------------------------------

-- | Types @a@ whose storage is owned by a message..
class HasMessage a mut | a -> mut where
    -- | Get the message in which the @a@ is stored.
    message :: a -> M.Message mut

-- | Types which have a "default" value, but require a message
-- to construct it.
--
-- The default is usually conceptually zero-size. This is mostly useful
-- for generated code, so that it can use standard decoding techniques
-- on default values.
class HasMessage a mut => MessageDefault a mut where
    messageDefault :: ReadCtx m mut => M.Message mut -> m a

instance HasMessage (M.WordPtr mut) mut where
    message :: WordPtr mut -> Message mut
message M.WordPtr{Message mut
pMessage :: Message mut
pMessage :: forall (mut :: Mutability). WordPtr mut -> Message mut
pMessage} = Message mut
pMessage

instance HasMessage (Ptr mut) mut where
    message :: Ptr mut -> Message mut
message (PtrCap Cap mut
cap)       = Cap mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message Cap mut
cap
    message (PtrList List mut
list)     = List mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message List mut
list
    message (PtrStruct Struct mut
struct) = Struct mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message Struct mut
struct

instance HasMessage (Cap mut) mut where
    message :: Cap mut -> Message mut
message (Cap Message mut
msg Word32
_) = Message mut
msg

instance HasMessage (Struct mut) mut where
    message :: Struct mut -> Message mut
message (Struct WordPtr mut
ptr Word16
_ Word16
_) = WordPtr mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message WordPtr mut
ptr

instance MessageDefault (Struct mut) mut where
    messageDefault :: Message mut -> m (Struct mut)
messageDefault Message mut
msg = do
        Segment mut
pSegment <- Message mut -> Int -> m (Segment mut)
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
msg Int
0
        pure $ WordPtr mut -> Word16 -> Word16 -> Struct mut
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr{pMessage :: Message mut
pMessage = Message mut
msg, Segment mut
pSegment :: Segment mut
pSegment :: Segment mut
pSegment, pAddr :: WordAddr
pAddr = Int -> WordCount -> WordAddr
WordAt Int
0 WordCount
0} Word16
0 Word16
0

instance HasMessage (List mut) mut where
    message :: List mut -> Message mut
message (List0 ListOf mut ()
list)      = ListOf mut () -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut ()
list
    message (List1 ListOf mut Bool
list)      = ListOf mut Bool -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut Bool
list
    message (List8 ListOf mut Word8
list)      = ListOf mut Word8 -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut Word8
list
    message (List16 ListOf mut Word16
list)     = ListOf mut Word16 -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut Word16
list
    message (List32 ListOf mut Word32
list)     = ListOf mut Word32 -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut Word32
list
    message (List64 ListOf mut Word64
list)     = ListOf mut Word64 -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut Word64
list
    message (ListPtr ListOf mut (Maybe (Ptr mut))
list)    = ListOf mut (Maybe (Ptr mut)) -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut (Maybe (Ptr mut))
list
    message (ListStruct ListOf mut (Struct mut)
list) = ListOf mut (Struct mut) -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf mut (Struct mut)
list

instance HasMessage (ListOf mut a) mut where
    message :: ListOf mut a -> Message mut
message (ListOfStruct Struct mut
tag Int
_) = Struct mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message Struct mut
tag
    message (ListOfVoid NormalList mut
list)    = NormalList mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message NormalList mut
list
    message (ListOfBool NormalList mut
list)    = NormalList mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message NormalList mut
list
    message (ListOfWord8 NormalList mut
list)   = NormalList mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message NormalList mut
list
    message (ListOfWord16 NormalList mut
list)  = NormalList mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message NormalList mut
list
    message (ListOfWord32 NormalList mut
list)  = NormalList mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message NormalList mut
list
    message (ListOfWord64 NormalList mut
list)  = NormalList mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message NormalList mut
list
    message (ListOfPtr NormalList mut
list)     = NormalList mut -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message NormalList mut
list

instance MessageDefault (ListOf mut ()) mut where
    messageDefault :: Message mut -> m (ListOf mut ())
messageDefault Message mut
msg = NormalList mut -> ListOf mut ()
forall (mut :: Mutability). NormalList mut -> ListOf mut ()
ListOfVoid (NormalList mut -> ListOf mut ())
-> m (NormalList mut) -> m (ListOf mut ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (NormalList mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
instance MessageDefault (ListOf mut (Struct mut)) mut where
    messageDefault :: Message mut -> m (ListOf mut (Struct mut))
messageDefault Message mut
msg = (Struct mut -> Int -> ListOf mut (Struct mut))
-> Int -> Struct mut -> ListOf mut (Struct mut)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Struct mut -> Int -> ListOf mut (Struct mut)
forall (mut :: Mutability).
Struct mut -> Int -> ListOf mut (Struct mut)
ListOfStruct Int
0 (Struct mut -> ListOf mut (Struct mut))
-> m (Struct mut) -> m (ListOf mut (Struct mut))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (Struct mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
instance MessageDefault (ListOf mut Bool) mut where
    messageDefault :: Message mut -> m (ListOf mut Bool)
messageDefault Message mut
msg = NormalList mut -> ListOf mut Bool
forall (mut :: Mutability). NormalList mut -> ListOf mut Bool
ListOfBool (NormalList mut -> ListOf mut Bool)
-> m (NormalList mut) -> m (ListOf mut Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (NormalList mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
instance MessageDefault (ListOf mut Word8) mut where
    messageDefault :: Message mut -> m (ListOf mut Word8)
messageDefault Message mut
msg = NormalList mut -> ListOf mut Word8
forall (mut :: Mutability). NormalList mut -> ListOf mut Word8
ListOfWord8 (NormalList mut -> ListOf mut Word8)
-> m (NormalList mut) -> m (ListOf mut Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (NormalList mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
instance MessageDefault (ListOf mut Word16) mut where
    messageDefault :: Message mut -> m (ListOf mut Word16)
messageDefault Message mut
msg = NormalList mut -> ListOf mut Word16
forall (mut :: Mutability). NormalList mut -> ListOf mut Word16
ListOfWord16 (NormalList mut -> ListOf mut Word16)
-> m (NormalList mut) -> m (ListOf mut Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (NormalList mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
instance MessageDefault (ListOf mut Word32) mut where
    messageDefault :: Message mut -> m (ListOf mut Word32)
messageDefault Message mut
msg = NormalList mut -> ListOf mut Word32
forall (mut :: Mutability). NormalList mut -> ListOf mut Word32
ListOfWord32 (NormalList mut -> ListOf mut Word32)
-> m (NormalList mut) -> m (ListOf mut Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (NormalList mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
instance MessageDefault (ListOf mut Word64) mut where
    messageDefault :: Message mut -> m (ListOf mut Word64)
messageDefault Message mut
msg = NormalList mut -> ListOf mut Word64
forall (mut :: Mutability). NormalList mut -> ListOf mut Word64
ListOfWord64 (NormalList mut -> ListOf mut Word64)
-> m (NormalList mut) -> m (ListOf mut Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (NormalList mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
instance MessageDefault (ListOf mut (Maybe (Ptr mut))) mut where
    messageDefault :: Message mut -> m (ListOf mut (Maybe (Ptr mut)))
messageDefault Message mut
msg = NormalList mut -> ListOf mut (Maybe (Ptr mut))
forall (mut :: Mutability).
NormalList mut -> ListOf mut (Maybe (Ptr mut))
ListOfPtr (NormalList mut -> ListOf mut (Maybe (Ptr mut)))
-> m (NormalList mut) -> m (ListOf mut (Maybe (Ptr mut)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (NormalList mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg

instance HasMessage (NormalList mut) mut where
    message :: NormalList mut -> Message mut
message = WordPtr mut -> Message mut
forall (mut :: Mutability). WordPtr mut -> Message mut
M.pMessage (WordPtr mut -> Message mut)
-> (NormalList mut -> WordPtr mut) -> NormalList mut -> Message mut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalList mut -> WordPtr mut
forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr

instance MessageDefault (NormalList mut) mut where
    messageDefault :: Message mut -> m (NormalList mut)
messageDefault Message mut
msg = do
        Segment mut
pSegment <- Message mut -> Int -> m (Segment mut)
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
msg Int
0
        pure NormalList :: forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList
            { nPtr :: WordPtr mut
nPtr = WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr { pMessage :: Message mut
pMessage = Message mut
msg, Segment mut
pSegment :: Segment mut
pSegment :: Segment mut
pSegment, pAddr :: WordAddr
pAddr = Int -> WordCount -> WordAddr
WordAt Int
0 WordCount
0 }
            , nLen :: Int
nLen = Int
0
            }

-- | Extract a client (indepedent of the messsage) from the capability.
getClient :: ReadCtx m mut => Cap mut -> m M.Client
getClient :: Cap mut -> m Client
getClient (Cap Message mut
msg Word32
idx) = Message mut -> Int -> m Client
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m Client
M.getCap Message mut
msg (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
idx)

-- | @get ptr@ returns the Ptr stored at @ptr@.
-- Deducts 1 from the quota for each word read (which may be multiple in the
-- case of far pointers).
get :: ReadCtx m mut => M.WordPtr mut -> m (Maybe (Ptr mut))
{-# SPECIALIZE get :: M.WordPtr ('Mut RealWorld) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-}
get :: WordPtr mut -> m (Maybe (Ptr mut))
get ptr :: WordPtr mut
ptr@M.WordPtr{Message mut
pMessage :: Message mut
pMessage :: forall (mut :: Mutability). WordPtr mut -> Message mut
pMessage, WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr} = do
    Word64
word <- WordPtr mut -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
getWord WordPtr mut
ptr
    case Word64 -> Maybe Ptr
P.parsePtr Word64
word of
        Maybe Ptr
Nothing -> Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ptr mut)
forall a. Maybe a
Nothing
        Just Ptr
p -> case Ptr
p of
            P.CapPtr Word32
cap -> Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ptr mut) -> m (Maybe (Ptr mut)))
-> Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall a b. (a -> b) -> a -> b
$ Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Ptr mut -> Maybe (Ptr mut)) -> Ptr mut -> Maybe (Ptr mut)
forall a b. (a -> b) -> a -> b
$ Cap mut -> Ptr mut
forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap (Message mut -> Word32 -> Cap mut
forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
Cap Message mut
pMessage Word32
cap)
            P.StructPtr Int32
off Word16
dataSz Word16
ptrSz -> Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ptr mut) -> m (Maybe (Ptr mut)))
-> Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall a b. (a -> b) -> a -> b
$ Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Ptr mut -> Maybe (Ptr mut)) -> Ptr mut -> Maybe (Ptr mut)
forall a b. (a -> b) -> a -> b
$ Struct mut -> Ptr mut
forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct (Struct mut -> Ptr mut) -> Struct mut -> Ptr mut
forall a b. (a -> b) -> a -> b
$
                WordPtr mut -> Word16 -> Word16 -> Struct mut
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct WordPtr mut
ptr { pAddr :: WordAddr
M.pAddr = WordAddr -> Int32 -> WordAddr
forall a. Integral a => WordAddr -> a -> WordAddr
resolveOffset WordAddr
pAddr Int32
off } Word16
dataSz Word16
ptrSz
            P.ListPtr Int32
off EltSpec
eltSpec -> Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Ptr mut -> Maybe (Ptr mut)) -> m (Ptr mut) -> m (Maybe (Ptr mut))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                WordPtr mut -> EltSpec -> m (Ptr mut)
forall (f :: * -> *) (mut :: Mutability).
(MonadReadMessage mut f, MonadThrow f) =>
WordPtr mut -> EltSpec -> f (Ptr mut)
getList WordPtr mut
ptr { pAddr :: WordAddr
M.pAddr = WordAddr -> Int32 -> WordAddr
forall a. Integral a => WordAddr -> a -> WordAddr
resolveOffset WordAddr
pAddr Int32
off } EltSpec
eltSpec
            P.FarPtr Bool
twoWords Word32
offset Word32
segment -> do
                Segment mut
landingSegment <- Message mut -> Int -> m (Segment mut)
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
pMessage (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
segment)
                let addr' :: WordAddr
addr' = WordAt :: Int -> WordCount -> WordAddr
WordAt { wordIndex :: WordCount
wordIndex = Word32 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
offset
                                   , segIndex :: Int
segIndex = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
segment
                                   }
                let landingPtr :: WordPtr mut
landingPtr = WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr
                        { Message mut
pMessage :: Message mut
pMessage :: Message mut
pMessage
                        , pSegment :: Segment mut
pSegment = Segment mut
landingSegment
                        , pAddr :: WordAddr
pAddr = WordAddr
addr'
                        }
                if Bool -> Bool
not Bool
twoWords
                    then do
                        -- XXX: invoice so we don't open ourselves up to DoS
                        -- in the case of a chain of far pointers -- but a
                        -- better solution would be to just reject after the
                        -- first chain since this isn't actually legal. TODO
                        -- refactor (and then get rid of the MonadLimit
                        -- constraint).
                        WordCount -> m ()
forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice WordCount
1
                        WordPtr mut -> m (Maybe (Ptr mut))
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> m (Maybe (Ptr mut))
get WordPtr mut
landingPtr
                    else do
                        Word64
landingPad <- WordPtr mut -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
getWord WordPtr mut
landingPtr
                        case Word64 -> Maybe Ptr
P.parsePtr Word64
landingPad of
                            Just (P.FarPtr Bool
False Word32
off Word32
seg) -> do
                                let segIndex :: Int
segIndex = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
seg
                                Segment mut
finalSegment <- Message mut -> Int -> m (Segment mut)
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
pMessage Int
segIndex
                                Word64
tagWord <- WordPtr mut -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
getWord WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr
                                    { Message mut
pMessage :: Message mut
pMessage :: Message mut
pMessage
                                    , pSegment :: Segment mut
pSegment = Segment mut
landingSegment
                                    , pAddr :: WordAddr
M.pAddr = WordAddr
addr' { wordIndex :: WordCount
wordIndex = WordAddr -> WordCount
wordIndex WordAddr
addr' WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
1 }
                                    }
                                let finalPtr :: WordPtr mut
finalPtr = WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr
                                        { Message mut
pMessage :: Message mut
pMessage :: Message mut
pMessage
                                        , pSegment :: Segment mut
pSegment = Segment mut
finalSegment
                                        , pAddr :: WordAddr
pAddr = WordAt :: Int -> WordCount -> WordAddr
WordAt
                                            { wordIndex :: WordCount
wordIndex = Word32 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
off
                                            , Int
segIndex :: Int
segIndex :: Int
segIndex
                                            }
                                        }
                                case Word64 -> Maybe Ptr
P.parsePtr Word64
tagWord of
                                    Just (P.StructPtr Int32
0 Word16
dataSz Word16
ptrSz) ->
                                        Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ptr mut) -> m (Maybe (Ptr mut)))
-> Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall a b. (a -> b) -> a -> b
$ Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Ptr mut -> Maybe (Ptr mut)) -> Ptr mut -> Maybe (Ptr mut)
forall a b. (a -> b) -> a -> b
$ Struct mut -> Ptr mut
forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct (Struct mut -> Ptr mut) -> Struct mut -> Ptr mut
forall a b. (a -> b) -> a -> b
$
                                            WordPtr mut -> Word16 -> Word16 -> Struct mut
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct WordPtr mut
finalPtr Word16
dataSz Word16
ptrSz
                                    Just (P.ListPtr Int32
0 EltSpec
eltSpec) ->
                                        Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Ptr mut -> Maybe (Ptr mut)) -> m (Ptr mut) -> m (Maybe (Ptr mut))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WordPtr mut -> EltSpec -> m (Ptr mut)
forall (f :: * -> *) (mut :: Mutability).
(MonadReadMessage mut f, MonadThrow f) =>
WordPtr mut -> EltSpec -> f (Ptr mut)
getList WordPtr mut
finalPtr EltSpec
eltSpec
                                    -- TODO: I'm not sure whether far pointers to caps are
                                    -- legal; it's clear how they would work, but I don't
                                    -- see a use, and the spec is unclear. Should check
                                    -- how the reference implementation does this, copy
                                    -- that, and submit a patch to the spec.
                                    Just (P.CapPtr Word32
cap) ->
                                        Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ptr mut) -> m (Maybe (Ptr mut)))
-> Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall a b. (a -> b) -> a -> b
$ Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Ptr mut -> Maybe (Ptr mut)) -> Ptr mut -> Maybe (Ptr mut)
forall a b. (a -> b) -> a -> b
$ Cap mut -> Ptr mut
forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap (Message mut -> Word32 -> Cap mut
forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
Cap Message mut
pMessage Word32
cap)
                                    Maybe Ptr
ptr -> Error -> m (Maybe (Ptr mut))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> m (Maybe (Ptr mut))) -> Error -> m (Maybe (Ptr mut))
forall a b. (a -> b) -> a -> b
$ String -> Error
E.InvalidDataError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                                        String
"The tag word of a far pointer's " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                        String
"2-word landing pad should be an intra " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                        String
"segment pointer with offset 0, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                        String
"we read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Ptr -> String
forall a. Show a => a -> String
show Maybe Ptr
ptr
                            Maybe Ptr
ptr -> Error -> m (Maybe (Ptr mut))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> m (Maybe (Ptr mut))) -> Error -> m (Maybe (Ptr mut))
forall a b. (a -> b) -> a -> b
$ String -> Error
E.InvalidDataError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                                String
"The first word of a far pointer's 2-word " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                String
"landing pad should be another far pointer " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                String
"(with a one-word landing pad), but we read " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                Maybe Ptr -> String
forall a. Show a => a -> String
show Maybe Ptr
ptr

  where
    getWord :: WordPtr mut -> m Word64
getWord M.WordPtr{Segment mut
pSegment :: Segment mut
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}} =
        Segment mut -> WordCount -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
M.read Segment mut
pSegment WordCount
wordIndex
    resolveOffset :: WordAddr -> a -> WordAddr
resolveOffset addr :: WordAddr
addr@WordAt{Int
WordCount
wordIndex :: WordCount
segIndex :: Int
wordIndex :: WordAddr -> WordCount
segIndex :: WordAddr -> Int
..} a
off =
        WordAddr
addr { wordIndex :: WordCount
wordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ a -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
off WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
1 }
    getList :: WordPtr mut -> EltSpec -> f (Ptr mut)
getList ptr :: WordPtr mut
ptr@M.WordPtr{pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=addr :: WordAddr
addr@WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}} EltSpec
eltSpec = List mut -> Ptr mut
forall (mut :: Mutability). List mut -> Ptr mut
PtrList (List mut -> Ptr mut) -> f (List mut) -> f (Ptr mut)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        case EltSpec
eltSpec of
            P.EltNormal ElementSize
sz Word32
len -> List mut -> f (List mut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (List mut -> f (List mut)) -> List mut -> f (List mut)
forall a b. (a -> b) -> a -> b
$ case ElementSize
sz of
                ElementSize
Sz0   -> ListOf mut () -> List mut
forall (mut :: Mutability). ListOf mut () -> List mut
List0  (NormalList mut -> ListOf mut ()
forall (mut :: Mutability). NormalList mut -> ListOf mut ()
ListOfVoid    NormalList mut
nlist)
                ElementSize
Sz1   -> ListOf mut Bool -> List mut
forall (mut :: Mutability). ListOf mut Bool -> List mut
List1  (NormalList mut -> ListOf mut Bool
forall (mut :: Mutability). NormalList mut -> ListOf mut Bool
ListOfBool    NormalList mut
nlist)
                ElementSize
Sz8   -> ListOf mut Word8 -> List mut
forall (mut :: Mutability). ListOf mut Word8 -> List mut
List8  (NormalList mut -> ListOf mut Word8
forall (mut :: Mutability). NormalList mut -> ListOf mut Word8
ListOfWord8   NormalList mut
nlist)
                ElementSize
Sz16  -> ListOf mut Word16 -> List mut
forall (mut :: Mutability). ListOf mut Word16 -> List mut
List16 (NormalList mut -> ListOf mut Word16
forall (mut :: Mutability). NormalList mut -> ListOf mut Word16
ListOfWord16  NormalList mut
nlist)
                ElementSize
Sz32  -> ListOf mut Word32 -> List mut
forall (mut :: Mutability). ListOf mut Word32 -> List mut
List32 (NormalList mut -> ListOf mut Word32
forall (mut :: Mutability). NormalList mut -> ListOf mut Word32
ListOfWord32  NormalList mut
nlist)
                ElementSize
Sz64  -> ListOf mut Word64 -> List mut
forall (mut :: Mutability). ListOf mut Word64 -> List mut
List64 (NormalList mut -> ListOf mut Word64
forall (mut :: Mutability). NormalList mut -> ListOf mut Word64
ListOfWord64  NormalList mut
nlist)
                ElementSize
SzPtr -> ListOf mut (Maybe (Ptr mut)) -> List mut
forall (mut :: Mutability).
ListOf mut (Maybe (Ptr mut)) -> List mut
ListPtr (NormalList mut -> ListOf mut (Maybe (Ptr mut))
forall (mut :: Mutability).
NormalList mut -> ListOf mut (Maybe (Ptr mut))
ListOfPtr NormalList mut
nlist)
              where
                nlist :: NormalList mut
nlist = WordPtr mut -> Int -> NormalList mut
forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList WordPtr mut
ptr (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)
            P.EltComposite Int32
_ -> do
                Word64
tagWord <- WordPtr mut -> f Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
getWord WordPtr mut
ptr
                case Word64 -> Ptr
P.parsePtr' Word64
tagWord of
                    P.StructPtr Int32
numElts Word16
dataSz Word16
ptrSz ->
                        List mut -> f (List mut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (List mut -> f (List mut)) -> List mut -> f (List mut)
forall a b. (a -> b) -> a -> b
$ ListOf mut (Struct mut) -> List mut
forall (mut :: Mutability). ListOf mut (Struct mut) -> List mut
ListStruct (ListOf mut (Struct mut) -> List mut)
-> ListOf mut (Struct mut) -> List mut
forall a b. (a -> b) -> a -> b
$ Struct mut -> Int -> ListOf mut (Struct mut)
forall (mut :: Mutability).
Struct mut -> Int -> ListOf mut (Struct mut)
ListOfStruct
                            (WordPtr mut -> Word16 -> Word16 -> Struct mut
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct WordPtr mut
ptr { pAddr :: WordAddr
M.pAddr = WordAddr
addr { wordIndex :: WordCount
wordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
1 } }
                                    Word16
dataSz
                                    Word16
ptrSz)
                            (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
numElts)
                    Ptr
tag -> Error -> f (List mut)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> f (List mut)) -> Error -> f (List mut)
forall a b. (a -> b) -> a -> b
$ String -> Error
E.InvalidDataError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                        String
"Composite list tag was not a struct-" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
"formatted word: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr -> String
forall a. Show a => a -> String
show Ptr
tag

-- | Return the EltSpec needed for a pointer to the given list.
listEltSpec :: List msg -> P.EltSpec
listEltSpec :: List msg -> EltSpec
listEltSpec (ListStruct list :: ListOf msg (Struct msg)
list@(ListOfStruct (Struct WordPtr msg
_ Word16
dataSz Word16
ptrSz) Int
_)) =
    Int32 -> EltSpec
P.EltComposite (Int32 -> EltSpec) -> Int32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg (Struct msg) -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg (Struct msg)
list) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* (Word16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Word16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz)
listEltSpec (List0 ListOf msg ()
list)   = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
Sz0 (Word32 -> EltSpec) -> Word32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg () -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg ()
list)
listEltSpec (List1 ListOf msg Bool
list)   = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
Sz1 (Word32 -> EltSpec) -> Word32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg Bool -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg Bool
list)
listEltSpec (List8 ListOf msg Word8
list)   = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
Sz8 (Word32 -> EltSpec) -> Word32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg Word8 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg Word8
list)
listEltSpec (List16 ListOf msg Word16
list)  = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
Sz16 (Word32 -> EltSpec) -> Word32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg Word16 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg Word16
list)
listEltSpec (List32 ListOf msg Word32
list)  = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
Sz32 (Word32 -> EltSpec) -> Word32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg Word32 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg Word32
list)
listEltSpec (List64 ListOf msg Word64
list)  = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
Sz64 (Word32 -> EltSpec) -> Word32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg Word64 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg Word64
list)
listEltSpec (ListPtr ListOf msg (Maybe (Ptr msg))
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
SzPtr (Word32 -> EltSpec) -> Word32 -> EltSpec
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ListOf msg (Maybe (Ptr msg)) -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg (Maybe (Ptr msg))
list)

-- | Return the starting address of the list.
listAddr :: List msg -> WordAddr
listAddr :: List msg -> WordAddr
listAddr (ListStruct (ListOfStruct (Struct M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr} Word16
_ Word16
_) Int
_)) =
    -- pAddr is the address of the first element of the list, but
    -- composite lists start with a tag word:
    WordAddr
pAddr { wordIndex :: WordCount
wordIndex = WordAddr -> WordCount
wordIndex WordAddr
pAddr WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
- WordCount
1 }
listAddr (List0 (ListOfVoid NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}})) = WordAddr
pAddr
listAddr (List1 (ListOfBool NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}})) = WordAddr
pAddr
listAddr (List8 (ListOfWord8 NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}})) = WordAddr
pAddr
listAddr (List16 (ListOfWord16 NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}})) = WordAddr
pAddr
listAddr (List32 (ListOfWord32 NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}})) = WordAddr
pAddr
listAddr (List64 (ListOfWord64 NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}})) = WordAddr
pAddr
listAddr (ListPtr (ListOfPtr NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}})) = WordAddr
pAddr

-- | Return the address of the pointer's target. It is illegal to call this on
-- a pointer which targets a capability.
ptrAddr :: Ptr msg -> WordAddr
ptrAddr :: Ptr msg -> WordAddr
ptrAddr (PtrCap Cap msg
_) = String -> WordAddr
forall a. HasCallStack => String -> a
error String
"ptrAddr called on a capability pointer."
ptrAddr (PtrStruct (Struct M.WordPtr{WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr}Word16
_ Word16
_)) = WordAddr
pAddr
ptrAddr (PtrList List msg
list) = List msg -> WordAddr
forall (msg :: Mutability). List msg -> WordAddr
listAddr List msg
list

-- | @'setIndex value i list@ Set the @i@th element of @list@ to @value@.
setIndex :: RWCtx m s => a -> Int -> ListOf ('Mut s) a -> m ()
{-# SPECIALIZE setIndex :: a -> Int -> ListOf ('Mut RealWorld) a -> LimitT IO () #-}
setIndex :: a -> Int -> ListOf ('Mut s) a -> m ()
setIndex a
_ Int
i ListOf ('Mut s) a
list | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| ListOf ('Mut s) a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut s) a
list Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i =
    Error -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BoundsError :: Int -> Int -> Error
E.BoundsError { index :: Int
E.index = Int
i, maxIndex :: Int
E.maxIndex = ListOf ('Mut s) a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut s) a
list }
setIndex a
value Int
i ListOf ('Mut s) a
list = case ListOf ('Mut s) a
list of
    ListOfVoid NormalList ('Mut s)
_       -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ListOfBool NormalList ('Mut s)
nlist   -> NormalList ('Mut s) -> Int -> Word1 -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, Bounded a, Integral a) =>
NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList ('Mut s)
nlist Int
64 (Bool -> Word1
Word1 a
Bool
value)
    ListOfWord8 NormalList ('Mut s)
nlist  -> NormalList ('Mut s) -> Int -> a -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, Bounded a, Integral a) =>
NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList ('Mut s)
nlist Int
8 a
value
    ListOfWord16 NormalList ('Mut s)
nlist -> NormalList ('Mut s) -> Int -> a -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, Bounded a, Integral a) =>
NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList ('Mut s)
nlist Int
4 a
value
    ListOfWord32 NormalList ('Mut s)
nlist -> NormalList ('Mut s) -> Int -> a -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, Bounded a, Integral a) =>
NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList ('Mut s)
nlist Int
2 a
value
    ListOfWord64 NormalList ('Mut s)
nlist -> NormalList ('Mut s) -> Int -> a -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, Bounded a, Integral a) =>
NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList ('Mut s)
nlist Int
1 a
value
    ListOfPtr NormalList ('Mut s)
nlist -> case a
value of
        Just p | Ptr ('Mut s) -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message Ptr ('Mut s)
p Message ('Mut s) -> Message ('Mut s) -> Bool
forall a. Eq a => a -> a -> Bool
/= ListOf ('Mut s) a -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf ('Mut s) a
list -> do
            Maybe (Ptr ('Mut s))
newPtr <- Message ('Mut s)
-> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
copyPtr (ListOf ('Mut s) a -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
message ListOf ('Mut s) a
list) a
Maybe (Ptr ('Mut s))
value
            Maybe (Ptr ('Mut s))
-> Int -> ListOf ('Mut s) (Maybe (Ptr ('Mut s))) -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
a -> Int -> ListOf ('Mut s) a -> m ()
setIndex Maybe (Ptr ('Mut s))
newPtr Int
i ListOf ('Mut s) a
ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
list
        a
Nothing                -> NormalList ('Mut s) -> Int -> Word64 -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, Bounded a, Integral a) =>
NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList ('Mut s)
nlist Int
1 (Maybe Ptr -> Word64
P.serializePtr Maybe Ptr
forall a. Maybe a
Nothing)
        Just (PtrCap (Cap _ cap))    -> NormalList ('Mut s) -> Int -> Word64 -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, Bounded a, Integral a) =>
NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList ('Mut s)
nlist Int
1 (Maybe Ptr -> Word64
P.serializePtr (Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just (Word32 -> Ptr
P.CapPtr Word32
cap)))
        Just p@(PtrList ptrList)     ->
            NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
setPtrIndex NormalList ('Mut s)
nlist Ptr ('Mut s)
p (Ptr -> m ()) -> Ptr -> m ()
forall a b. (a -> b) -> a -> b
$ Int32 -> EltSpec -> Ptr
P.ListPtr Int32
0 (List ('Mut s) -> EltSpec
forall (msg :: Mutability). List msg -> EltSpec
listEltSpec List ('Mut s)
ptrList)
        Just p@(PtrStruct (Struct _ dataSz ptrSz)) ->
            NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
setPtrIndex NormalList ('Mut s)
nlist Ptr ('Mut s)
p (Ptr -> m ()) -> Ptr -> m ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Word16 -> Word16 -> Ptr
P.StructPtr Int32
0 Word16
dataSz Word16
ptrSz
    list :: ListOf ('Mut s) a
list@(ListOfStruct Struct ('Mut s)
_ Int
_) -> do
        a
dest <- Int -> ListOf ('Mut s) a -> m a
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
Int -> ListOf mut a -> m a
index Int
i ListOf ('Mut s) a
list
        Struct ('Mut s) -> Struct ('Mut s) -> m ()
forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Struct ('Mut s) -> m ()
copyStruct a
Struct ('Mut s)
dest a
Struct ('Mut s)
value
  where
    setNIndex :: (RWCtx m s, Bounded a, Integral a) => NormalList ('Mut s) -> Int -> a -> m ()
    setNIndex :: NormalList ('Mut s) -> Int -> a -> m ()
setNIndex NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=M.WordPtr{Segment ('Mut s)
pSegment :: Segment ('Mut s)
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}}} Int
eltsPerWord a
value = do
        let eltWordIndex :: WordCount
eltWordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
        Word64
word <- Segment ('Mut s) -> WordCount -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
M.read Segment ('Mut s)
pSegment WordCount
eltWordIndex
        let shift :: Int
shift = (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
eltsPerWord) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
64 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
        Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
pSegment WordCount
eltWordIndex (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Word64 -> Int -> Word64
forall a. (Bounded a, Integral a) => a -> Word64 -> Int -> Word64
replaceBits a
value Word64
word Int
shift
    setPtrIndex :: RWCtx m s => NormalList ('Mut s) -> Ptr ('Mut s) -> P.Ptr -> m ()
    setPtrIndex :: NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
setPtrIndex NormalList{nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr=nPtr :: WordPtr ('Mut s)
nPtr@M.WordPtr{pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=addr :: WordAddr
addr@WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}}} Ptr ('Mut s)
absPtr Ptr
relPtr =
        let srcPtr :: WordPtr ('Mut s)
srcPtr = WordPtr ('Mut s)
nPtr { pAddr :: WordAddr
M.pAddr = WordAddr
addr { wordIndex :: WordCount
wordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount Int
i } }
        in WordPtr ('Mut s) -> WordAddr -> Ptr -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
WordPtr ('Mut s) -> WordAddr -> Ptr -> m ()
setPointerTo WordPtr ('Mut s)
srcPtr (Ptr ('Mut s) -> WordAddr
forall (msg :: Mutability). Ptr msg -> WordAddr
ptrAddr Ptr ('Mut s)
absPtr) Ptr
relPtr

-- | @'setPointerTo' msg srcLoc dstAddr relPtr@ sets the word at @srcLoc@ in @msg@ to a
-- pointer like @relPtr@, but pointing to @dstAddr@. @relPtr@ should not be a far pointer.
-- If the two addresses are in different segments, a landing pad will be allocated and
-- @srcLoc@ will contain a far pointer.
setPointerTo :: M.WriteCtx m s => M.WordPtr ('Mut s) -> WordAddr -> P.Ptr -> m ()
{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut RealWorld) -> WordAddr -> P.Ptr -> LimitT IO () #-}
setPointerTo :: WordPtr ('Mut s) -> WordAddr -> Ptr -> m ()
setPointerTo
        M.WordPtr
            { pMessage :: forall (mut :: Mutability). WordPtr mut -> Message mut
pMessage = Message ('Mut s)
msg
            , pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment=Segment ('Mut s)
srcSegment
            , pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=srcAddr :: WordAddr
srcAddr@WordAt{wordIndex :: WordAddr -> WordCount
wordIndex=WordCount
srcWordIndex}
            }
        WordAddr
dstAddr
        Ptr
relPtr
    | P.StructPtr Int32
_ Word16
0 Word16
0 <- Ptr
relPtr =
        -- We special case zero-sized structs, since (1) we don't have to
        -- really point at the correct offset, since they can "fit" anywhere,
        -- and (2) they cause problems with double-far pointers, where part
        -- of the landing pad needs to have a zero offset, but that makes it
        -- look like a null pointer... so we just avoid that case by cutting
        -- it off here.
        Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$
            Maybe Ptr -> Word64
P.serializePtr (Maybe Ptr -> Word64) -> Maybe Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just (Ptr -> Maybe Ptr) -> Ptr -> Maybe Ptr
forall a b. (a -> b) -> a -> b
$ Int32 -> Word16 -> Word16 -> Ptr
P.StructPtr (-Int32
1) Word16
0 Word16
0
    | Bool
otherwise = case WordAddr -> WordAddr -> Ptr -> Either OffsetError Ptr
pointerFrom WordAddr
srcAddr WordAddr
dstAddr Ptr
relPtr of
        Right Ptr
absPtr ->
            Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Ptr -> Word64
P.serializePtr (Maybe Ptr -> Word64) -> Maybe Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just Ptr
absPtr
        Left OffsetError
OutOfRange ->
            String -> m ()
forall a. HasCallStack => String -> a
error String
"BUG: segment is too large to set the pointer."
        Left OffsetError
DifferentSegments -> do
            -- We need a far pointer; allocate a landing pad in the target segment,
            -- set it to point to the final destination, an then set the source pointer
            -- pointer to point to the landing pad.
            let WordAt{Int
segIndex :: Int
segIndex :: WordAddr -> Int
segIndex} = WordAddr
dstAddr
            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)))
M.allocInSeg Message ('Mut s)
msg Int
segIndex WordCount
1 m (Maybe (WordPtr ('Mut s)))
-> (Maybe (WordPtr ('Mut s)) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just M.WordPtr{pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment=Segment ('Mut s)
landingPadSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAddr
landingPadAddr} ->
                    case WordAddr -> WordAddr -> Ptr -> Either OffsetError Ptr
pointerFrom WordAddr
landingPadAddr WordAddr
dstAddr Ptr
relPtr of
                        Right Ptr
landingPad -> do
                            let WordAt{Int
segIndex :: Int
segIndex :: WordAddr -> Int
segIndex,WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex} = WordAddr
landingPadAddr
                            Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
landingPadSegment WordCount
wordIndex (Maybe Ptr -> Word64
P.serializePtr (Maybe Ptr -> Word64) -> Maybe Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just Ptr
landingPad)
                            Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$
                                Maybe Ptr -> Word64
P.serializePtr (Maybe Ptr -> Word64) -> Maybe Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just (Ptr -> Maybe Ptr) -> Ptr -> Maybe Ptr
forall a b. (a -> b) -> a -> b
$ Bool -> Word32 -> Word32 -> Ptr
P.FarPtr Bool
False (WordCount -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
wordIndex) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
segIndex)
                        Left OffsetError
DifferentSegments ->
                            String -> m ()
forall a. HasCallStack => String -> a
error String
"BUG: allocated a landing pad in the wrong segment!"
                        Left OffsetError
OutOfRange ->
                            String -> m ()
forall a. HasCallStack => String -> a
error String
"BUG: segment is too large to set the pointer."
                Maybe (WordPtr ('Mut s))
Nothing -> do
                    -- The target segment is full. We need to do a double-far pointer.
                    -- First allocate the 2-word landing pad, wherever it will fit:
                    M.WordPtr
                        { pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment = Segment ('Mut s)
landingPadSegment
                        , pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr = WordAt
                            { wordIndex :: WordAddr -> WordCount
wordIndex = WordCount
landingPadOffset
                            , segIndex :: WordAddr -> Int
segIndex = Int
landingPadSegIndex
                            }
                        } <- Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
M.alloc Message ('Mut s)
msg WordCount
2
                    -- Next, point the source pointer at the landing pad:
                    Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$
                        Maybe Ptr -> Word64
P.serializePtr (Maybe Ptr -> Word64) -> Maybe Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just (Ptr -> Maybe Ptr) -> Ptr -> Maybe Ptr
forall a b. (a -> b) -> a -> b
$ Bool -> Word32 -> Word32 -> Ptr
P.FarPtr Bool
True
                            (WordCount -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
landingPadOffset)
                            (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
landingPadSegIndex)
                    -- Finally, fill in the landing pad itself.
                    --
                    -- The first word is a far pointer whose offset is the
                    -- starting address of our target object:
                    Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
landingPadSegment WordCount
landingPadOffset (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$
                        let WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex, Int
segIndex :: Int
segIndex :: WordAddr -> Int
segIndex} = WordAddr
dstAddr in
                        Maybe Ptr -> Word64
P.serializePtr (Maybe Ptr -> Word64) -> Maybe Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just (Ptr -> Maybe Ptr) -> Ptr -> Maybe Ptr
forall a b. (a -> b) -> a -> b
$ Bool -> Word32 -> Word32 -> Ptr
P.FarPtr Bool
False
                            (WordCount -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
wordIndex)
                            (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
segIndex)
                    -- The second word is a pointer of the right "shape"
                    -- for the target, but with a zero offset:
                    Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
landingPadSegment (WordCount
landingPadOffset WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
1) (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$
                        Maybe Ptr -> Word64
P.serializePtr (Maybe Ptr -> Word64) -> Maybe Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just (Ptr -> Maybe Ptr) -> Ptr -> Maybe Ptr
forall a b. (a -> b) -> a -> b
$ case Ptr
relPtr of
                            P.StructPtr Int32
_ Word16
nWords Word16
nPtrs -> Int32 -> Word16 -> Word16 -> Ptr
P.StructPtr Int32
0 Word16
nWords Word16
nPtrs
                            P.ListPtr Int32
_ EltSpec
eltSpec -> Int32 -> EltSpec -> Ptr
P.ListPtr Int32
0 EltSpec
eltSpec
                            Ptr
_ -> Ptr
relPtr

-- | Make a copy of a capability inside the target message.
copyCap :: RWCtx m s => M.Message ('Mut s) -> Cap ('Mut s) -> m (Cap ('Mut s))
copyCap :: Message ('Mut s) -> Cap ('Mut s) -> m (Cap ('Mut s))
copyCap Message ('Mut s)
dest Cap ('Mut s)
cap = Cap ('Mut s) -> m Client
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
getClient Cap ('Mut s)
cap m Client -> (Client -> m (Cap ('Mut s))) -> m (Cap ('Mut s))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message ('Mut s) -> Client -> m (Cap ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m (Cap ('Mut s))
appendCap Message ('Mut s)
dest

-- | Make a copy of the value at the pointer, in the target message.
copyPtr :: RWCtx m s => M.Message ('Mut s) -> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
{-# SPECIALIZE copyPtr :: M.Message ('Mut RealWorld) -> Maybe (Ptr ('Mut RealWorld)) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-}
copyPtr :: Message ('Mut s)
-> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
copyPtr Message ('Mut s)
_ Maybe (Ptr ('Mut s))
Nothing                = Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ptr ('Mut s))
forall a. Maybe a
Nothing
copyPtr Message ('Mut s)
dest (Just (PtrCap Cap ('Mut s)
cap))    = Ptr ('Mut s) -> Maybe (Ptr ('Mut s))
forall a. a -> Maybe a
Just (Ptr ('Mut s) -> Maybe (Ptr ('Mut s)))
-> (Cap ('Mut s) -> Ptr ('Mut s))
-> Cap ('Mut s)
-> Maybe (Ptr ('Mut s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cap ('Mut s) -> Ptr ('Mut s)
forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap (Cap ('Mut s) -> Maybe (Ptr ('Mut s)))
-> m (Cap ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> Cap ('Mut s) -> m (Cap ('Mut s))
forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s) -> Cap ('Mut s) -> m (Cap ('Mut s))
copyCap Message ('Mut s)
dest Cap ('Mut s)
cap
copyPtr Message ('Mut s)
dest (Just (PtrList List ('Mut s)
src))   = Ptr ('Mut s) -> Maybe (Ptr ('Mut s))
forall a. a -> Maybe a
Just (Ptr ('Mut s) -> Maybe (Ptr ('Mut s)))
-> (List ('Mut s) -> Ptr ('Mut s))
-> List ('Mut s)
-> Maybe (Ptr ('Mut s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List ('Mut s) -> Ptr ('Mut s)
forall (mut :: Mutability). List mut -> Ptr mut
PtrList (List ('Mut s) -> Maybe (Ptr ('Mut s)))
-> m (List ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> List ('Mut s) -> m (List ('Mut s))
forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s) -> List ('Mut s) -> m (List ('Mut s))
copyList Message ('Mut s)
dest List ('Mut s)
src
copyPtr Message ('Mut s)
dest (Just (PtrStruct Struct ('Mut s)
src)) = Ptr ('Mut s) -> Maybe (Ptr ('Mut s))
forall a. a -> Maybe a
Just (Ptr ('Mut s) -> Maybe (Ptr ('Mut s)))
-> (Struct ('Mut s) -> Ptr ('Mut s))
-> Struct ('Mut s)
-> Maybe (Ptr ('Mut s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct ('Mut s) -> Ptr ('Mut s)
forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct (Struct ('Mut s) -> Maybe (Ptr ('Mut s)))
-> m (Struct ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Struct ('Mut s)
destStruct <- Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
allocStruct
            Message ('Mut s)
dest
            (WordCount -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordCount -> Word16) -> WordCount -> Word16
forall a b. (a -> b) -> a -> b
$ Struct ('Mut s) -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structWordCount Struct ('Mut s)
src)
            (Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Struct ('Mut s) -> Word16
forall (msg :: Mutability). Struct msg -> Word16
structPtrCount Struct ('Mut s)
src)
    Struct ('Mut s) -> Struct ('Mut s) -> m ()
forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Struct ('Mut s) -> m ()
copyStruct Struct ('Mut s)
destStruct Struct ('Mut s)
src
    pure Struct ('Mut s)
destStruct

-- | Make a copy of the list, in the target message.
copyList :: RWCtx m s => M.Message ('Mut s) -> List ('Mut s) -> m (List ('Mut s))
{-# SPECIALIZE copyList :: M.Message ('Mut RealWorld) -> List ('Mut RealWorld) -> LimitT IO (List ('Mut RealWorld)) #-}
copyList :: Message ('Mut s) -> List ('Mut s) -> m (List ('Mut s))
copyList Message ('Mut s)
dest List ('Mut s)
src = case List ('Mut s)
src of
    List0 ListOf ('Mut s) ()
src      -> ListOf ('Mut s) () -> List ('Mut s)
forall (mut :: Mutability). ListOf mut () -> List mut
List0 (ListOf ('Mut s) () -> List ('Mut s))
-> m (ListOf ('Mut s) ()) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> Int -> m (ListOf ('Mut s) ())
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) ())
allocList0 Message ('Mut s)
dest (ListOf ('Mut s) () -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut s) ()
src)
    List1 ListOf ('Mut s) Bool
src      -> ListOf ('Mut s) Bool -> List ('Mut s)
forall (mut :: Mutability). ListOf mut Bool -> List mut
List1 (ListOf ('Mut s) Bool -> List ('Mut s))
-> m (ListOf ('Mut s) Bool) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> ListOf ('Mut s) Bool
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) Bool))
-> m (ListOf ('Mut s) Bool)
forall (m :: * -> *) s a.
RWCtx m s =>
Message ('Mut s)
-> ListOf ('Mut s) a
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
-> m (ListOf ('Mut s) a)
copyNewListOf Message ('Mut s)
dest ListOf ('Mut s) Bool
src Message ('Mut s) -> Int -> m (ListOf ('Mut s) Bool)
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Bool)
allocList1
    List8 ListOf ('Mut s) Word8
src      -> ListOf ('Mut s) Word8 -> List ('Mut s)
forall (mut :: Mutability). ListOf mut Word8 -> List mut
List8 (ListOf ('Mut s) Word8 -> List ('Mut s))
-> m (ListOf ('Mut s) Word8) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> ListOf ('Mut s) Word8
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word8))
-> m (ListOf ('Mut s) Word8)
forall (m :: * -> *) s a.
RWCtx m s =>
Message ('Mut s)
-> ListOf ('Mut s) a
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
-> m (ListOf ('Mut s) a)
copyNewListOf Message ('Mut s)
dest ListOf ('Mut s) Word8
src Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word8)
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word8)
allocList8
    List16 ListOf ('Mut s) Word16
src     -> ListOf ('Mut s) Word16 -> List ('Mut s)
forall (mut :: Mutability). ListOf mut Word16 -> List mut
List16 (ListOf ('Mut s) Word16 -> List ('Mut s))
-> m (ListOf ('Mut s) Word16) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> ListOf ('Mut s) Word16
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word16))
-> m (ListOf ('Mut s) Word16)
forall (m :: * -> *) s a.
RWCtx m s =>
Message ('Mut s)
-> ListOf ('Mut s) a
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
-> m (ListOf ('Mut s) a)
copyNewListOf Message ('Mut s)
dest ListOf ('Mut s) Word16
src Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word16)
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word16)
allocList16
    List32 ListOf ('Mut s) Word32
src     -> ListOf ('Mut s) Word32 -> List ('Mut s)
forall (mut :: Mutability). ListOf mut Word32 -> List mut
List32 (ListOf ('Mut s) Word32 -> List ('Mut s))
-> m (ListOf ('Mut s) Word32) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> ListOf ('Mut s) Word32
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word32))
-> m (ListOf ('Mut s) Word32)
forall (m :: * -> *) s a.
RWCtx m s =>
Message ('Mut s)
-> ListOf ('Mut s) a
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
-> m (ListOf ('Mut s) a)
copyNewListOf Message ('Mut s)
dest ListOf ('Mut s) Word32
src Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word32)
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word32)
allocList32
    List64 ListOf ('Mut s) Word64
src     -> ListOf ('Mut s) Word64 -> List ('Mut s)
forall (mut :: Mutability). ListOf mut Word64 -> List mut
List64 (ListOf ('Mut s) Word64 -> List ('Mut s))
-> m (ListOf ('Mut s) Word64) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> ListOf ('Mut s) Word64
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word64))
-> m (ListOf ('Mut s) Word64)
forall (m :: * -> *) s a.
RWCtx m s =>
Message ('Mut s)
-> ListOf ('Mut s) a
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
-> m (ListOf ('Mut s) a)
copyNewListOf Message ('Mut s)
dest ListOf ('Mut s) Word64
src Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word64)
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word64)
allocList64
    ListPtr ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
src    -> ListOf ('Mut s) (Maybe (Ptr ('Mut s))) -> List ('Mut s)
forall (mut :: Mutability).
ListOf mut (Maybe (Ptr mut)) -> List mut
ListPtr (ListOf ('Mut s) (Maybe (Ptr ('Mut s))) -> List ('Mut s))
-> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
-> (Message ('Mut s)
    -> Int -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s)))))
-> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall (m :: * -> *) s a.
RWCtx m s =>
Message ('Mut s)
-> ListOf ('Mut s) a
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
-> m (ListOf ('Mut s) a)
copyNewListOf Message ('Mut s)
dest ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
src Message ('Mut s)
-> Int -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Int -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
allocListPtr
    ListStruct ListOf ('Mut s) (Struct ('Mut s))
src -> ListOf ('Mut s) (Struct ('Mut s)) -> List ('Mut s)
forall (mut :: Mutability). ListOf mut (Struct mut) -> List mut
ListStruct (ListOf ('Mut s) (Struct ('Mut s)) -> List ('Mut s))
-> m (ListOf ('Mut s) (Struct ('Mut s))) -> m (List ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        ListOf ('Mut s) (Struct ('Mut s))
destList <- Message ('Mut s)
-> Word16 -> Word16 -> Int -> m (ListOf ('Mut s) (Struct ('Mut s)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Word16 -> Word16 -> Int -> m (ListOf ('Mut s) (Struct ('Mut s)))
allocCompositeList
            Message ('Mut s)
dest
            (WordCount -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordCount -> Word16) -> WordCount -> Word16
forall a b. (a -> b) -> a -> b
$ ListOf ('Mut s) (Struct ('Mut s)) -> WordCount
forall (msg :: Mutability). ListOf msg (Struct msg) -> WordCount
structListWordCount ListOf ('Mut s) (Struct ('Mut s))
src)
            (ListOf ('Mut s) (Struct ('Mut s)) -> Word16
forall (msg :: Mutability). ListOf msg (Struct msg) -> Word16
structListPtrCount ListOf ('Mut s) (Struct ('Mut s))
src)
            (ListOf ('Mut s) (Struct ('Mut s)) -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut s) (Struct ('Mut s))
src)
        ListOf ('Mut s) (Struct ('Mut s))
-> ListOf ('Mut s) (Struct ('Mut s)) -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
ListOf ('Mut s) a -> ListOf ('Mut s) a -> m ()
copyListOf ListOf ('Mut s) (Struct ('Mut s))
destList ListOf ('Mut s) (Struct ('Mut s))
src
        pure ListOf ('Mut s) (Struct ('Mut s))
destList

copyNewListOf
    :: RWCtx m s
    => M.Message ('Mut s)
    -> ListOf ('Mut s) a
    -> (M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
    -> m (ListOf ('Mut s) a)
{-# INLINE copyNewListOf #-}
copyNewListOf :: Message ('Mut s)
-> ListOf ('Mut s) a
-> (Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))
-> m (ListOf ('Mut s) a)
copyNewListOf Message ('Mut s)
destMsg ListOf ('Mut s) a
src Message ('Mut s) -> Int -> m (ListOf ('Mut s) a)
new = do
    ListOf ('Mut s) a
dest <- Message ('Mut s) -> Int -> m (ListOf ('Mut s) a)
new Message ('Mut s)
destMsg (ListOf ('Mut s) a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut s) a
src)
    ListOf ('Mut s) a -> ListOf ('Mut s) a -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
ListOf ('Mut s) a -> ListOf ('Mut s) a -> m ()
copyListOf ListOf ('Mut s) a
dest ListOf ('Mut s) a
src
    pure ListOf ('Mut s) a
dest


-- | Make a copy of the list, in the target message.
copyListOf :: RWCtx m s => ListOf ('Mut s) a -> ListOf ('Mut s) a -> m ()
{-# SPECIALIZE copyListOf :: ListOf ('Mut RealWorld) a -> ListOf ('Mut RealWorld) a -> LimitT IO () #-}
copyListOf :: ListOf ('Mut s) a -> ListOf ('Mut s) a -> m ()
copyListOf ListOf ('Mut s) a
dest ListOf ('Mut s) a
src =
    [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..ListOf ('Mut s) a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut s) a
src Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
        a
value <- Int -> ListOf ('Mut s) a -> m a
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
Int -> ListOf mut a -> m a
index Int
i ListOf ('Mut s) a
src
        a -> Int -> ListOf ('Mut s) a -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
a -> Int -> ListOf ('Mut s) a -> m ()
setIndex a
value Int
i ListOf ('Mut s) a
dest

-- | @'copyStruct' dest src@ copies the source struct to the destination struct.
copyStruct :: RWCtx m s => Struct ('Mut s) -> Struct ('Mut s) -> m ()
{-# SPECIALIZE copyStruct :: Struct ('Mut RealWorld) -> Struct ('Mut RealWorld) -> LimitT IO () #-}
copyStruct :: Struct ('Mut s) -> Struct ('Mut s) -> m ()
copyStruct Struct ('Mut s)
dest Struct ('Mut s)
src = do
    -- We copy both the data and pointer sections from src to dest,
    -- padding the tail of the destination section with zeros/null
    -- pointers as necessary. If the destination section is
    -- smaller than the source section, this will raise a BoundsError.
    --
    -- TODO: possible enhancement: allow the destination section to be
    -- smaller than the source section if and only if the tail of the
    -- source section is all zeros (default values).
    ListOf ('Mut (PrimState m)) Word64
-> ListOf ('Mut (PrimState m)) Word64 -> Word64 -> m ()
forall (m :: * -> *) a.
(PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf ('Mut (PrimState m)) a
-> ListOf ('Mut (PrimState m)) a -> a -> m ()
copySection (Struct ('Mut s) -> ListOf ('Mut s) Word64
forall (msg :: Mutability). Struct msg -> ListOf msg Word64
dataSection Struct ('Mut s)
dest) (Struct ('Mut s) -> ListOf ('Mut s) Word64
forall (msg :: Mutability). Struct msg -> ListOf msg Word64
dataSection Struct ('Mut s)
src) Word64
0
    ListOf ('Mut (PrimState m)) (Maybe (Ptr ('Mut s)))
-> ListOf ('Mut (PrimState m)) (Maybe (Ptr ('Mut s)))
-> Maybe (Ptr ('Mut s))
-> m ()
forall (m :: * -> *) a.
(PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf ('Mut (PrimState m)) a
-> ListOf ('Mut (PrimState m)) a -> a -> m ()
copySection (Struct ('Mut s) -> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
forall (msg :: Mutability).
Struct msg -> ListOf msg (Maybe (Ptr msg))
ptrSection  Struct ('Mut s)
dest) (Struct ('Mut s) -> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
forall (msg :: Mutability).
Struct msg -> ListOf msg (Maybe (Ptr msg))
ptrSection  Struct ('Mut s)
src) Maybe (Ptr ('Mut s))
forall a. Maybe a
Nothing
  where
    copySection :: ListOf ('Mut (PrimState m)) a
-> ListOf ('Mut (PrimState m)) a -> a -> m ()
copySection ListOf ('Mut (PrimState m)) a
dest ListOf ('Mut (PrimState m)) a
src a
pad = do
        -- Copy the source section to the destination section:
        ListOf ('Mut (PrimState m)) a
-> ListOf ('Mut (PrimState m)) a -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
ListOf ('Mut s) a -> ListOf ('Mut s) a -> m ()
copyListOf ListOf ('Mut (PrimState m)) a
dest ListOf ('Mut (PrimState m)) a
src
        -- Pad the remainder with zeros/default values:
        [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ListOf ('Mut (PrimState m)) a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut (PrimState m)) a
src..ListOf ('Mut (PrimState m)) a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf ('Mut (PrimState m)) a
dest Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            a -> Int -> ListOf ('Mut (PrimState m)) a -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
a -> Int -> ListOf ('Mut s) a -> m ()
setIndex a
pad Int
i ListOf ('Mut (PrimState m)) a
dest


-- | @index i list@ returns the ith element in @list@. Deducts 1 from the quota
index :: ReadCtx m mut => Int -> ListOf mut a -> m a
{-# SPECIALIZE index :: Int -> ListOf 'Const a -> LimitT IO a #-}
{-# SPECIALIZE index :: Int -> ListOf ('Mut RealWorld) a -> LimitT IO a #-}
index :: Int -> ListOf mut a -> m a
index Int
i ListOf mut a
list
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ListOf mut a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut a
list =
        Error -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BoundsError :: Int -> Int -> Error
E.BoundsError { index :: Int
E.index = Int
i, maxIndex :: Int
E.maxIndex = ListOf mut a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut a
list Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 }
    | Bool
otherwise = ListOf mut a -> m a
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m a
index' ListOf mut a
list
  where
    index' :: ReadCtx m mut => ListOf mut a -> m a
    index' :: ListOf mut a -> m a
index' (ListOfVoid NormalList mut
_) = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    index' (ListOfStruct (Struct ptr :: WordPtr mut
ptr@M.WordPtr{pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=addr :: WordAddr
addr@WordAt{Int
WordCount
wordIndex :: WordCount
segIndex :: Int
wordIndex :: WordAddr -> WordCount
segIndex :: WordAddr -> Int
..}} Word16
dataSz Word16
ptrSz) Int
_) = do
        let offset :: WordCount
offset = Int -> WordCount
WordCount (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz)
        let addr' :: WordAddr
addr' = WordAddr
addr { wordIndex :: WordCount
wordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
offset }
        Struct mut -> m (Struct mut)
forall (m :: * -> *) a. Monad m => a -> m a
return (Struct mut -> m (Struct mut)) -> Struct mut -> m (Struct mut)
forall a b. (a -> b) -> a -> b
$ WordPtr mut -> Word16 -> Word16 -> Struct mut
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct WordPtr mut
ptr { pAddr :: WordAddr
M.pAddr = WordAddr
addr' } Word16
dataSz Word16
ptrSz
    index' (ListOfBool   NormalList mut
nlist) = do
        Word1 Bool
val <- NormalList mut -> Int -> m Word1
forall (m :: * -> *) (mut :: Mutability) a.
(ReadCtx m mut, Integral a) =>
NormalList mut -> Int -> m a
indexNList NormalList mut
nlist Int
64
        Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
val
    index' (ListOfWord8  NormalList mut
nlist) = NormalList mut -> Int -> m a
forall (m :: * -> *) (mut :: Mutability) a.
(ReadCtx m mut, Integral a) =>
NormalList mut -> Int -> m a
indexNList NormalList mut
nlist Int
8
    index' (ListOfWord16 NormalList mut
nlist) = NormalList mut -> Int -> m a
forall (m :: * -> *) (mut :: Mutability) a.
(ReadCtx m mut, Integral a) =>
NormalList mut -> Int -> m a
indexNList NormalList mut
nlist Int
4
    index' (ListOfWord32 NormalList mut
nlist) = NormalList mut -> Int -> m a
forall (m :: * -> *) (mut :: Mutability) a.
(ReadCtx m mut, Integral a) =>
NormalList mut -> Int -> m a
indexNList NormalList mut
nlist Int
2
    index' (ListOfWord64 (NormalList M.WordPtr{Segment mut
pSegment :: Segment mut
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}} Int
_)) =
        Segment mut -> WordCount -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
M.read Segment mut
pSegment (WordCount -> m Word64) -> WordCount -> m Word64
forall a b. (a -> b) -> a -> b
$ WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount Int
i
    index' (ListOfPtr (NormalList ptr :: WordPtr mut
ptr@M.WordPtr{pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=addr :: WordAddr
addr@WordAt{Int
WordCount
wordIndex :: WordCount
segIndex :: Int
wordIndex :: WordAddr -> WordCount
segIndex :: WordAddr -> Int
..}} Int
_)) =
        WordPtr mut -> m (Maybe (Ptr mut))
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> m (Maybe (Ptr mut))
get WordPtr mut
ptr { pAddr :: WordAddr
M.pAddr = WordAddr
addr { wordIndex :: WordCount
wordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount Int
i } }
    indexNList :: (ReadCtx m mut, Integral a) => NormalList mut -> Int -> m a
    indexNList :: NormalList mut -> Int -> m a
indexNList (NormalList M.WordPtr{Segment mut
pSegment :: Segment mut
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAt{Int
WordCount
wordIndex :: WordCount
segIndex :: Int
wordIndex :: WordAddr -> WordCount
segIndex :: WordAddr -> Int
..}} Int
_) Int
eltsPerWord = do
        let wordIndex' :: WordCount
wordIndex' = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
        Word64
word <- Segment mut -> WordCount -> m Word64
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> WordCount -> m Word64
M.read Segment mut
pSegment WordCount
wordIndex'
        let shift :: Int
shift = (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
eltsPerWord) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
64 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
        a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> a) -> Word64 -> a
forall a b. (a -> b) -> a -> b
$ Word64
word Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
shift

-- | Returns the length of a list
length :: ListOf msg a -> Int
length :: ListOf msg a -> Int
length (ListOfStruct Struct msg
_ Int
len) = Int
len
length (ListOfVoid   NormalList msg
nlist) = NormalList msg -> Int
forall (mut :: Mutability). NormalList mut -> Int
nLen NormalList msg
nlist
length (ListOfBool   NormalList msg
nlist) = NormalList msg -> Int
forall (mut :: Mutability). NormalList mut -> Int
nLen NormalList msg
nlist
length (ListOfWord8  NormalList msg
nlist) = NormalList msg -> Int
forall (mut :: Mutability). NormalList mut -> Int
nLen NormalList msg
nlist
length (ListOfWord16 NormalList msg
nlist) = NormalList msg -> Int
forall (mut :: Mutability). NormalList mut -> Int
nLen NormalList msg
nlist
length (ListOfWord32 NormalList msg
nlist) = NormalList msg -> Int
forall (mut :: Mutability). NormalList mut -> Int
nLen NormalList msg
nlist
length (ListOfWord64 NormalList msg
nlist) = NormalList msg -> Int
forall (mut :: Mutability). NormalList mut -> Int
nLen NormalList msg
nlist
length (ListOfPtr    NormalList msg
nlist) = NormalList msg -> Int
forall (mut :: Mutability). NormalList mut -> Int
nLen NormalList msg
nlist

-- | Return a prefix of the list, of the given length.
take :: MonadThrow m => Int -> ListOf msg a -> m (ListOf msg a)
take :: Int -> ListOf msg a -> m (ListOf msg a)
take Int
count ListOf msg a
list
    | ListOf msg a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg a
list Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
count =
        Error -> m (ListOf msg a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BoundsError :: Int -> Int -> Error
E.BoundsError { index :: Int
E.index = Int
count, maxIndex :: Int
E.maxIndex = ListOf msg a -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf msg a
list Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 }
    | Bool
otherwise = ListOf msg a -> m (ListOf msg a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ListOf msg a -> m (ListOf msg a))
-> ListOf msg a -> m (ListOf msg a)
forall a b. (a -> b) -> a -> b
$ ListOf msg a -> ListOf msg a
go ListOf msg a
list
  where
    go :: ListOf msg a -> ListOf msg a
go (ListOfStruct Struct msg
tag Int
_) = Struct msg -> Int -> ListOf msg (Struct msg)
forall (mut :: Mutability).
Struct mut -> Int -> ListOf mut (Struct mut)
ListOfStruct Struct msg
tag Int
count
    go (ListOfVoid NormalList msg
nlist)   = NormalList msg -> ListOf msg ()
forall (mut :: Mutability). NormalList mut -> ListOf mut ()
ListOfVoid (NormalList msg -> ListOf msg ())
-> NormalList msg -> ListOf msg ()
forall a b. (a -> b) -> a -> b
$ NormalList msg -> NormalList msg
forall (msg :: Mutability). NormalList msg -> NormalList msg
nTake NormalList msg
nlist
    go (ListOfBool NormalList msg
nlist)   = NormalList msg -> ListOf msg Bool
forall (mut :: Mutability). NormalList mut -> ListOf mut Bool
ListOfBool (NormalList msg -> ListOf msg Bool)
-> NormalList msg -> ListOf msg Bool
forall a b. (a -> b) -> a -> b
$ NormalList msg -> NormalList msg
forall (msg :: Mutability). NormalList msg -> NormalList msg
nTake NormalList msg
nlist
    go (ListOfWord8 NormalList msg
nlist)  = NormalList msg -> ListOf msg Word8
forall (mut :: Mutability). NormalList mut -> ListOf mut Word8
ListOfWord8 (NormalList msg -> ListOf msg Word8)
-> NormalList msg -> ListOf msg Word8
forall a b. (a -> b) -> a -> b
$ NormalList msg -> NormalList msg
forall (msg :: Mutability). NormalList msg -> NormalList msg
nTake NormalList msg
nlist
    go (ListOfWord16 NormalList msg
nlist) = NormalList msg -> ListOf msg Word16
forall (mut :: Mutability). NormalList mut -> ListOf mut Word16
ListOfWord16 (NormalList msg -> ListOf msg Word16)
-> NormalList msg -> ListOf msg Word16
forall a b. (a -> b) -> a -> b
$ NormalList msg -> NormalList msg
forall (msg :: Mutability). NormalList msg -> NormalList msg
nTake NormalList msg
nlist
    go (ListOfWord32 NormalList msg
nlist) = NormalList msg -> ListOf msg Word32
forall (mut :: Mutability). NormalList mut -> ListOf mut Word32
ListOfWord32 (NormalList msg -> ListOf msg Word32)
-> NormalList msg -> ListOf msg Word32
forall a b. (a -> b) -> a -> b
$ NormalList msg -> NormalList msg
forall (msg :: Mutability). NormalList msg -> NormalList msg
nTake NormalList msg
nlist
    go (ListOfWord64 NormalList msg
nlist) = NormalList msg -> ListOf msg Word64
forall (mut :: Mutability). NormalList mut -> ListOf mut Word64
ListOfWord64 (NormalList msg -> ListOf msg Word64)
-> NormalList msg -> ListOf msg Word64
forall a b. (a -> b) -> a -> b
$ NormalList msg -> NormalList msg
forall (msg :: Mutability). NormalList msg -> NormalList msg
nTake NormalList msg
nlist
    go (ListOfPtr NormalList msg
nlist)    = NormalList msg -> ListOf msg (Maybe (Ptr msg))
forall (mut :: Mutability).
NormalList mut -> ListOf mut (Maybe (Ptr mut))
ListOfPtr (NormalList msg -> ListOf msg (Maybe (Ptr msg)))
-> NormalList msg -> ListOf msg (Maybe (Ptr msg))
forall a b. (a -> b) -> a -> b
$ NormalList msg -> NormalList msg
forall (msg :: Mutability). NormalList msg -> NormalList msg
nTake NormalList msg
nlist

    nTake :: NormalList msg -> NormalList msg
    nTake :: NormalList msg -> NormalList msg
nTake NormalList{Int
WordPtr msg
nLen :: Int
nPtr :: WordPtr msg
nLen :: forall (mut :: Mutability). NormalList mut -> Int
nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
..} = NormalList :: forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList { nLen :: Int
nLen = Int
count, WordPtr msg
nPtr :: WordPtr msg
nPtr :: WordPtr msg
.. }

-- | The data section of a struct, as a list of Word64
dataSection :: Struct msg -> ListOf msg Word64
{-# INLINE dataSection #-}
dataSection :: Struct msg -> ListOf msg Word64
dataSection (Struct WordPtr msg
ptr Word16
dataSz Word16
_) =
    NormalList msg -> ListOf msg Word64
forall (mut :: Mutability). NormalList mut -> ListOf mut Word64
ListOfWord64 (NormalList msg -> ListOf msg Word64)
-> NormalList msg -> ListOf msg Word64
forall a b. (a -> b) -> a -> b
$ WordPtr msg -> Int -> NormalList msg
forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList WordPtr msg
ptr (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz)

-- | The pointer section of a struct, as a list of Ptr
ptrSection :: Struct msg -> ListOf msg (Maybe (Ptr msg))
{-# INLINE ptrSection #-}
ptrSection :: Struct msg -> ListOf msg (Maybe (Ptr msg))
ptrSection (Struct ptr :: WordPtr msg
ptr@M.WordPtr{pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=addr :: WordAddr
addr@WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}} Word16
dataSz Word16
ptrSz) =
    NormalList msg -> ListOf msg (Maybe (Ptr msg))
forall (mut :: Mutability).
NormalList mut -> ListOf mut (Maybe (Ptr mut))
ListOfPtr (NormalList msg -> ListOf msg (Maybe (Ptr msg)))
-> NormalList msg -> ListOf msg (Maybe (Ptr msg))
forall a b. (a -> b) -> a -> b
$ NormalList :: forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList
        { nPtr :: WordPtr msg
nPtr = WordPtr msg
ptr { pAddr :: WordAddr
M.pAddr = WordAddr
addr { wordIndex :: WordCount
wordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Word16 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz } }
        , nLen :: Int
nLen = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz
        }

-- | Get the size (in words) of a struct's data section.
structWordCount :: Struct msg -> WordCount
structWordCount :: Struct msg -> WordCount
structWordCount (Struct WordPtr msg
_ptr Word16
dataSz Word16
_ptrSz) = Word16 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz

-- | Get the size (in bytes) of a struct's data section.
structByteCount :: Struct msg -> ByteCount
structByteCount :: Struct msg -> ByteCount
structByteCount = WordCount -> ByteCount
wordsToBytes (WordCount -> ByteCount)
-> (Struct msg -> WordCount) -> Struct msg -> ByteCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct msg -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structWordCount

-- | Get the size of a struct's pointer section.
structPtrCount  :: Struct msg -> Word16
structPtrCount :: Struct msg -> Word16
structPtrCount (Struct WordPtr msg
_ptr Word16
_dataSz Word16
ptrSz) = Word16
ptrSz

-- | Get the size (in words) of the data sections in a struct list.
structListWordCount :: ListOf msg (Struct msg) -> WordCount
structListWordCount :: ListOf msg (Struct msg) -> WordCount
structListWordCount (ListOfStruct Struct msg
s Int
_) = Struct msg -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structWordCount Struct msg
s

-- | Get the size (in words) of the data sections in a struct list.
structListByteCount :: ListOf msg (Struct msg) -> ByteCount
structListByteCount :: ListOf msg (Struct msg) -> ByteCount
structListByteCount (ListOfStruct Struct msg
s Int
_) = Struct msg -> ByteCount
forall (msg :: Mutability). Struct msg -> ByteCount
structByteCount Struct msg
s

-- | Get the size of the pointer sections in a struct list.
structListPtrCount  :: ListOf msg (Struct msg) -> Word16
structListPtrCount :: ListOf msg (Struct msg) -> Word16
structListPtrCount  (ListOfStruct Struct msg
s Int
_) = Struct msg -> Word16
forall (msg :: Mutability). Struct msg -> Word16
structPtrCount Struct msg
s

-- | @'getData' i struct@ gets the @i@th word from the struct's data section,
-- returning 0 if it is absent.
getData :: ReadCtx m msg => Int -> Struct msg -> m Word64
{-# INLINE getData #-}
getData :: Int -> Struct msg -> m Word64
getData Int
i Struct msg
struct
    | WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Struct msg -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structWordCount Struct msg
struct) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i = Word64 -> m Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
0
    | Bool
otherwise = Int -> ListOf msg Word64 -> m Word64
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
Int -> ListOf mut a -> m a
index Int
i (Struct msg -> ListOf msg Word64
forall (msg :: Mutability). Struct msg -> ListOf msg Word64
dataSection Struct msg
struct)

-- | @'getPtr' i struct@ gets the @i@th word from the struct's pointer section,
-- returning Nothing if it is absent.
getPtr :: ReadCtx m msg => Int -> Struct msg -> m (Maybe (Ptr msg))
{-# INLINE getPtr #-}
getPtr :: Int -> Struct msg -> m (Maybe (Ptr msg))
getPtr Int
i Struct msg
struct
    | Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Struct msg -> Word16
forall (msg :: Mutability). Struct msg -> Word16
structPtrCount Struct msg
struct) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i = do
        WordCount -> m ()
forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice WordCount
1
        pure Maybe (Ptr msg)
forall a. Maybe a
Nothing
    | Bool
otherwise = do
        Maybe (Ptr msg)
ptr <- Int -> ListOf msg (Maybe (Ptr msg)) -> m (Maybe (Ptr msg))
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
Int -> ListOf mut a -> m a
index Int
i (Struct msg -> ListOf msg (Maybe (Ptr msg))
forall (msg :: Mutability).
Struct msg -> ListOf msg (Maybe (Ptr msg))
ptrSection Struct msg
struct)
        Maybe (Ptr msg) -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Maybe (Ptr mut) -> m ()
checkPtr Maybe (Ptr msg)
ptr
        Maybe (Ptr msg) -> m ()
forall (m :: * -> *) (mut :: Mutability).
MonadLimit m =>
Maybe (Ptr mut) -> m ()
invoicePtr Maybe (Ptr msg)
ptr
        pure Maybe (Ptr msg)
ptr

checkPtr :: ReadCtx m mut => Maybe (Ptr mut) -> m ()
checkPtr :: Maybe (Ptr mut) -> m ()
checkPtr Maybe (Ptr mut)
Nothing              = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkPtr (Just (PtrCap Cap mut
c))    = Cap mut -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m ()
checkCap Cap mut
c
checkPtr (Just (PtrList List mut
l))   = List mut -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
List mut -> m ()
checkList List mut
l
checkPtr (Just (PtrStruct Struct mut
s)) = Struct mut -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Struct mut -> m ()
checkStruct Struct mut
s

checkCap :: ReadCtx m mut => Cap mut -> m ()
checkCap :: Cap mut -> m ()
checkCap (Cap Message mut
_ Word32
_ ) = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- No need to do anything here; an out of bounds index is just treated
    -- as null.

checkList :: ReadCtx m mut => List mut -> m ()
checkList :: List mut -> m ()
checkList (List0 ListOf mut ()
l)      = ListOf mut () -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut ()
l
checkList (List1 ListOf mut Bool
l)      = ListOf mut Bool -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut Bool
l
checkList (List8 ListOf mut Word8
l)      = ListOf mut Word8 -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut Word8
l
checkList (List16 ListOf mut Word16
l)     = ListOf mut Word16 -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut Word16
l
checkList (List32 ListOf mut Word32
l)     = ListOf mut Word32 -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut Word32
l
checkList (List64 ListOf mut Word64
l)     = ListOf mut Word64 -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut Word64
l
checkList (ListPtr ListOf mut (Maybe (Ptr mut))
l)    = ListOf mut (Maybe (Ptr mut)) -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut (Maybe (Ptr mut))
l
checkList (ListStruct ListOf mut (Struct mut)
l) = ListOf mut (Struct mut) -> m ()
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
ListOf mut a -> m ()
checkListOf ListOf mut (Struct mut)
l

checkListOf :: ReadCtx m mut => ListOf mut a -> m ()
checkListOf :: ListOf mut a -> m ()
checkListOf (ListOfStruct s :: Struct mut
s@(Struct WordPtr mut
ptr Word16
_ Word16
_) Int
len) =
    WordPtr mut -> WordCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> WordCount -> m ()
checkPtrOffset WordPtr mut
ptr (Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
* Struct mut -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structSize Struct mut
s)
checkListOf (ListOfVoid NormalList mut
_) = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkListOf (ListOfBool NormalList mut
l) = NormalList mut -> BitCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList NormalList mut
l BitCount
1
checkListOf (ListOfWord8 NormalList mut
l) = NormalList mut -> BitCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList NormalList mut
l BitCount
8
checkListOf (ListOfWord16 NormalList mut
l) = NormalList mut -> BitCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList NormalList mut
l BitCount
16
checkListOf (ListOfWord32 NormalList mut
l) = NormalList mut -> BitCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList NormalList mut
l BitCount
32
checkListOf (ListOfWord64 NormalList mut
l) = NormalList mut -> BitCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList NormalList mut
l BitCount
64
checkListOf (ListOfPtr NormalList mut
l) = NormalList mut -> BitCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList NormalList mut
l BitCount
64

checkNormalList :: ReadCtx m mut => NormalList mut -> BitCount -> m ()
checkNormalList :: NormalList mut -> BitCount -> m ()
checkNormalList NormalList{WordPtr mut
nPtr :: WordPtr mut
nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr, Int
nLen :: Int
nLen :: forall (mut :: Mutability). NormalList mut -> Int
nLen} BitCount
eltSize =
    let nBits :: BitCount
nBits = Int -> BitCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nLen BitCount -> BitCount -> BitCount
forall a. Num a => a -> a -> a
* BitCount
eltSize
        nWords :: WordCount
nWords = ByteCount -> WordCount
bytesToWordsCeil (ByteCount -> WordCount) -> ByteCount -> WordCount
forall a b. (a -> b) -> a -> b
$ BitCount -> ByteCount
bitsToBytesCeil BitCount
nBits
    in
    WordPtr mut -> WordCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> WordCount -> m ()
checkPtrOffset WordPtr mut
nPtr WordCount
nWords

checkStruct :: ReadCtx m mut => Struct mut -> m ()
checkStruct :: Struct mut -> m ()
checkStruct s :: Struct mut
s@(Struct WordPtr mut
ptr Word16
_ Word16
_) =
    WordPtr mut -> WordCount -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> WordCount -> m ()
checkPtrOffset WordPtr mut
ptr (Struct mut -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structSize Struct mut
s)

checkPtrOffset :: ReadCtx m mut => M.WordPtr mut -> WordCount -> m ()
checkPtrOffset :: WordPtr mut -> WordCount -> m ()
checkPtrOffset M.WordPtr{Segment mut
pSegment :: Segment mut
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}} WordCount
size = do
    WordCount
segWords <- Segment mut -> m WordCount
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
M.numWords Segment mut
pSegment
    let maxIndex :: Int
maxIndex = WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
segWords Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WordCount
wordIndex WordCount -> WordCount -> Bool
forall a. Ord a => a -> a -> Bool
>= WordCount
0) (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
index = WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
wordIndex, Int
maxIndex :: Int
maxIndex :: Int
maxIndex }
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
size WordCount -> WordCount -> Bool
forall a. Ord a => a -> a -> Bool
<= WordCount
segWords) (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
index = WordCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
size) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            , Int
maxIndex :: Int
maxIndex :: Int
maxIndex
            }

structSize :: Struct mut -> WordCount
structSize :: Struct mut -> WordCount
structSize Struct mut
s = Struct mut -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structWordCount Struct mut
s WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Word16 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Struct mut -> Word16
forall (msg :: Mutability). Struct msg -> Word16
structPtrCount Struct mut
s)

-- | Invoice the traversal limit for all data reachable via the pointer
-- directly, i.e. without following further pointers.
--
-- The minimum possible cost is 1, and for lists will always be proportional
-- to the length of the list, even if the size of the elements is zero.
invoicePtr :: MonadLimit m => Maybe (Ptr mut) -> m ()
{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut RealWorld)) -> LimitT IO () #-}
invoicePtr :: Maybe (Ptr mut) -> m ()
invoicePtr Maybe (Ptr mut)
p = WordCount -> m ()
forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice (WordCount -> m ()) -> WordCount -> m ()
forall a b. (a -> b) -> a -> b
$! Maybe (Ptr mut) -> WordCount
forall (mut :: Mutability). Maybe (Ptr mut) -> WordCount
ptrInvoiceSize Maybe (Ptr mut)
p

ptrInvoiceSize :: Maybe (Ptr mut) -> WordCount
ptrInvoiceSize :: Maybe (Ptr mut) -> WordCount
ptrInvoiceSize = \case
    Maybe (Ptr mut)
Nothing            -> WordCount
1
    Just (PtrCap Cap mut
_)    -> WordCount
1
    Just (PtrStruct Struct mut
s) -> Struct mut -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structInvoiceSize Struct mut
s
    Just (PtrList List mut
l)   -> List mut -> WordCount
forall (mut :: Mutability). List mut -> WordCount
listInvoiceSize List mut
l
listInvoiceSize :: List mut -> WordCount
listInvoiceSize :: List mut -> WordCount
listInvoiceSize List mut
l = WordCount -> WordCount -> WordCount
forall a. Ord a => a -> a -> a
max WordCount
1 (WordCount -> WordCount) -> WordCount -> WordCount
forall a b. (a -> b) -> a -> b
$! case List mut
l of
    List0 ListOf mut ()
l   -> Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$! ListOf mut () -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut ()
l
    List1 ListOf mut Bool
l   -> Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$! ListOf mut Bool -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut Bool
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
64
    List8 ListOf mut Word8
l   -> Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$! ListOf mut Word8 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut Word8
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div`  Int
8
    List16 ListOf mut Word16
l  -> Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$! ListOf mut Word16 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut Word16
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div`  Int
4
    List32 ListOf mut Word32
l  -> Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$! ListOf mut Word32 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut Word32
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div`  Int
2
    List64 ListOf mut Word64
l  -> Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$! ListOf mut Word64 -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut Word64
l
    ListPtr ListOf mut (Maybe (Ptr mut))
l -> Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$! ListOf mut (Maybe (Ptr mut)) -> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
length ListOf mut (Maybe (Ptr mut))
l
    ListStruct (ListOfStruct Struct mut
s Int
len) ->
        Struct mut -> WordCount
forall (msg :: Mutability). Struct msg -> WordCount
structInvoiceSize Struct mut
s WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
* Int -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
structInvoiceSize :: Struct mut -> WordCount
structInvoiceSize :: Struct mut -> WordCount
structInvoiceSize (Struct WordPtr mut
_ Word16
dataSz Word16
ptrSz) =
    WordCount -> WordCount -> WordCount
forall a. Ord a => a -> a -> a
max WordCount
1 (Word16 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Word16 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz)

-- | @'setData' value i struct@ sets the @i@th word in the struct's data section
-- to @value@.
{-# INLINE setData #-}
setData :: (ReadCtx m ('Mut s), M.WriteCtx m s)
    => Word64 -> Int -> Struct ('Mut s) -> m ()
setData :: Word64 -> Int -> Struct ('Mut s) -> m ()
setData Word64
value Int
i = Word64 -> Int -> ListOf ('Mut s) Word64 -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
a -> Int -> ListOf ('Mut s) a -> m ()
setIndex Word64
value Int
i (ListOf ('Mut s) Word64 -> m ())
-> (Struct ('Mut s) -> ListOf ('Mut s) Word64)
-> Struct ('Mut s)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct ('Mut s) -> ListOf ('Mut s) Word64
forall (msg :: Mutability). Struct msg -> ListOf msg Word64
dataSection

-- | @'setData' value i struct@ sets the @i@th pointer in the struct's pointer
-- section to @value@.
setPtr :: (ReadCtx m ('Mut s), M.WriteCtx m s) => Maybe (Ptr ('Mut s)) -> Int -> Struct ('Mut s) -> m ()
{-# INLINE setPtr #-}
setPtr :: Maybe (Ptr ('Mut s)) -> Int -> Struct ('Mut s) -> m ()
setPtr Maybe (Ptr ('Mut s))
value Int
i = Maybe (Ptr ('Mut s))
-> Int -> ListOf ('Mut s) (Maybe (Ptr ('Mut s))) -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
a -> Int -> ListOf ('Mut s) a -> m ()
setIndex Maybe (Ptr ('Mut s))
value Int
i (ListOf ('Mut s) (Maybe (Ptr ('Mut s))) -> m ())
-> (Struct ('Mut s) -> ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
-> Struct ('Mut s)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct ('Mut s) -> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
forall (msg :: Mutability).
Struct msg -> ListOf msg (Maybe (Ptr msg))
ptrSection

-- | 'rawBytes' returns the raw bytes corresponding to the list.
rawBytes :: ReadCtx m 'Const => ListOf 'Const Word8 -> m BS.ByteString
-- TODO: we can get away with a more lax context than ReadCtx, maybe even make
-- this non-monadic.
rawBytes :: ListOf 'Const Word8 -> m ByteString
rawBytes (ListOfWord8 (NormalList M.WordPtr{Segment 'Const
pSegment :: Segment 'Const
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}} Int
len)) = do
    let bytes :: ByteString
bytes = Segment 'Const -> ByteString
M.toByteString Segment 'Const
pSegment
    let ByteCount Int
byteOffset = WordCount -> ByteCount
wordsToBytes WordCount
wordIndex
    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
$ Int -> ByteString -> ByteString
BS.take Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
byteOffset ByteString
bytes


-- | Returns the root pointer of a message.
rootPtr :: ReadCtx m mut => M.Message mut -> m (Struct mut)
rootPtr :: Message mut -> m (Struct mut)
rootPtr Message mut
msg = 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)
M.getSegment Message mut
msg Int
0
    Maybe (Ptr mut)
root <- WordPtr mut -> m (Maybe (Ptr mut))
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> m (Maybe (Ptr mut))
get WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr
        { pMessage :: Message mut
pMessage = Message mut
msg
        , pSegment :: Segment mut
pSegment = Segment mut
seg
        , pAddr :: WordAddr
pAddr = Int -> WordCount -> WordAddr
WordAt Int
0 WordCount
0
        }
    Maybe (Ptr mut) -> m ()
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Maybe (Ptr mut) -> m ()
checkPtr Maybe (Ptr mut)
root
    Maybe (Ptr mut) -> m ()
forall (m :: * -> *) (mut :: Mutability).
MonadLimit m =>
Maybe (Ptr mut) -> m ()
invoicePtr Maybe (Ptr mut)
root
    case Maybe (Ptr mut)
root of
        Just (PtrStruct Struct mut
struct) -> Struct mut -> m (Struct mut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct mut
struct
        Maybe (Ptr mut)
Nothing -> Message mut -> m (Struct mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
messageDefault Message mut
msg
        Maybe (Ptr mut)
_ -> Error -> m (Struct mut)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> m (Struct mut)) -> Error -> m (Struct mut)
forall a b. (a -> b) -> a -> b
$ String -> Error
E.SchemaViolationError
                String
"Unexpected root type; expected struct."


-- | Make the given struct the root object of its message.
setRoot :: M.WriteCtx m s => Struct ('Mut s) -> m ()
setRoot :: Struct ('Mut s) -> m ()
setRoot (Struct M.WordPtr{Message ('Mut s)
pMessage :: Message ('Mut s)
pMessage :: forall (mut :: Mutability). WordPtr mut -> Message mut
pMessage, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=WordAddr
addr} Word16
dataSz Word16
ptrSz) = do
    Segment ('Mut s)
pSegment <- Message ('Mut s) -> Int -> m (Segment ('Mut s))
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message ('Mut s)
pMessage Int
0
    let rootPtr :: WordPtr ('Mut s)
rootPtr = WordPtr :: forall (mut :: Mutability).
Message mut -> Segment mut -> WordAddr -> WordPtr mut
M.WordPtr{Message ('Mut s)
pMessage :: Message ('Mut s)
pMessage :: Message ('Mut s)
pMessage, Segment ('Mut s)
pSegment :: Segment ('Mut s)
pSegment :: Segment ('Mut s)
pSegment, pAddr :: WordAddr
pAddr = Int -> WordCount -> WordAddr
WordAt Int
0 WordCount
0}
    WordPtr ('Mut s) -> WordAddr -> Ptr -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
WordPtr ('Mut s) -> WordAddr -> Ptr -> m ()
setPointerTo WordPtr ('Mut s)
rootPtr WordAddr
addr (Int32 -> Word16 -> Word16 -> Ptr
P.StructPtr Int32
0 Word16
dataSz Word16
ptrSz)

-- | Allocate a struct in the message.
allocStruct :: M.WriteCtx m s => M.Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
allocStruct :: Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
allocStruct Message ('Mut s)
msg Word16
dataSz Word16
ptrSz = do
    let totalSz :: WordCount
totalSz = Word16 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ Word16 -> WordCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz
    WordPtr ('Mut s)
ptr <- Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
M.alloc Message ('Mut s)
msg WordCount
totalSz
    pure $ WordPtr ('Mut s) -> Word16 -> Word16 -> Struct ('Mut s)
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct WordPtr ('Mut s)
ptr Word16
dataSz Word16
ptrSz

-- | Allocate a composite list.
allocCompositeList
    :: M.WriteCtx m s
    => M.Message ('Mut s) -- ^ The message to allocate in.
    -> Word16     -- ^ The size of the data section
    -> Word16     -- ^ The size of the pointer section
    -> Int        -- ^ The length of the list in elements.
    -> m (ListOf ('Mut s) (Struct ('Mut s)))
allocCompositeList :: Message ('Mut s)
-> Word16 -> Word16 -> Int -> m (ListOf ('Mut s) (Struct ('Mut s)))
allocCompositeList Message ('Mut s)
msg Word16
dataSz Word16
ptrSz Int
len = do
    let eltSize :: Int
eltSize = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz
    ptr :: WordPtr ('Mut s)
ptr@M.WordPtr{Segment ('Mut s)
pSegment :: Segment ('Mut s)
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr=addr :: WordAddr
addr@WordAt{WordCount
wordIndex :: WordCount
wordIndex :: WordAddr -> WordCount
wordIndex}}
        <- Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
M.alloc Message ('Mut s)
msg (Int -> WordCount
WordCount (Int -> WordCount) -> Int -> WordCount
forall a b. (a -> b) -> a -> b
$ Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
eltSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) -- + 1 for the tag word.
    Segment ('Mut s) -> WordCount -> Word64 -> m ()
forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
pSegment WordCount
wordIndex (Word64 -> m ()) -> Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr -> Word64
P.serializePtr' (Ptr -> Word64) -> Ptr -> Word64
forall a b. (a -> b) -> a -> b
$ Int32 -> Word16 -> Word16 -> Ptr
P.StructPtr (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Word16
dataSz Word16
ptrSz
    let firstStruct :: Struct ('Mut s)
firstStruct = WordPtr ('Mut s) -> Word16 -> Word16 -> Struct ('Mut s)
forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
Struct
            WordPtr ('Mut s)
ptr { pAddr :: WordAddr
M.pAddr = WordAddr
addr { wordIndex :: WordCount
wordIndex = WordCount
wordIndex WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
1 } }
            Word16
dataSz
            Word16
ptrSz
    ListOf ('Mut s) (Struct ('Mut s))
-> m (ListOf ('Mut s) (Struct ('Mut s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ListOf ('Mut s) (Struct ('Mut s))
 -> m (ListOf ('Mut s) (Struct ('Mut s))))
-> ListOf ('Mut s) (Struct ('Mut s))
-> m (ListOf ('Mut s) (Struct ('Mut s)))
forall a b. (a -> b) -> a -> b
$ Struct ('Mut s) -> Int -> ListOf ('Mut s) (Struct ('Mut s))
forall (mut :: Mutability).
Struct mut -> Int -> ListOf mut (Struct mut)
ListOfStruct Struct ('Mut s)
firstStruct Int
len

-- | Allocate a list of capnproto @Void@ values.
allocList0   :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) ())

-- | Allocate a list of booleans
allocList1   :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Bool)

-- | Allocate a list of 8-bit values.
allocList8   :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word8)

-- | Allocate a list of 16-bit values.
allocList16  :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word16)

-- | Allocate a list of 32-bit values.
allocList32  :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word32)

-- | Allocate a list of 64-bit words.
allocList64  :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word64)

-- | Allocate a list of pointers.
allocListPtr :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))

allocList0 :: Message ('Mut s) -> Int -> m (ListOf ('Mut s) ())
allocList0   Message ('Mut s)
msg Int
len = NormalList ('Mut s) -> ListOf ('Mut s) ()
forall (mut :: Mutability). NormalList mut -> ListOf mut ()
ListOfVoid   (NormalList ('Mut s) -> ListOf ('Mut s) ())
-> m (NormalList ('Mut s)) -> m (ListOf ('Mut s) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
0  Message ('Mut s)
msg Int
len
allocList1 :: Message ('Mut s) -> Int -> m (ListOf ('Mut s) Bool)
allocList1   Message ('Mut s)
msg Int
len = NormalList ('Mut s) -> ListOf ('Mut s) Bool
forall (mut :: Mutability). NormalList mut -> ListOf mut Bool
ListOfBool   (NormalList ('Mut s) -> ListOf ('Mut s) Bool)
-> m (NormalList ('Mut s)) -> m (ListOf ('Mut s) Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
1  Message ('Mut s)
msg Int
len
allocList8 :: Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word8)
allocList8   Message ('Mut s)
msg Int
len = NormalList ('Mut s) -> ListOf ('Mut s) Word8
forall (mut :: Mutability). NormalList mut -> ListOf mut Word8
ListOfWord8  (NormalList ('Mut s) -> ListOf ('Mut s) Word8)
-> m (NormalList ('Mut s)) -> m (ListOf ('Mut s) Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
8  Message ('Mut s)
msg Int
len
allocList16 :: Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word16)
allocList16  Message ('Mut s)
msg Int
len = NormalList ('Mut s) -> ListOf ('Mut s) Word16
forall (mut :: Mutability). NormalList mut -> ListOf mut Word16
ListOfWord16 (NormalList ('Mut s) -> ListOf ('Mut s) Word16)
-> m (NormalList ('Mut s)) -> m (ListOf ('Mut s) Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
16 Message ('Mut s)
msg Int
len
allocList32 :: Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word32)
allocList32  Message ('Mut s)
msg Int
len = NormalList ('Mut s) -> ListOf ('Mut s) Word32
forall (mut :: Mutability). NormalList mut -> ListOf mut Word32
ListOfWord32 (NormalList ('Mut s) -> ListOf ('Mut s) Word32)
-> m (NormalList ('Mut s)) -> m (ListOf ('Mut s) Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
32 Message ('Mut s)
msg Int
len
allocList64 :: Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word64)
allocList64  Message ('Mut s)
msg Int
len = NormalList ('Mut s) -> ListOf ('Mut s) Word64
forall (mut :: Mutability). NormalList mut -> ListOf mut Word64
ListOfWord64 (NormalList ('Mut s) -> ListOf ('Mut s) Word64)
-> m (NormalList ('Mut s)) -> m (ListOf ('Mut s) Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
64 Message ('Mut s)
msg Int
len
allocListPtr :: Message ('Mut s)
-> Int -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
allocListPtr Message ('Mut s)
msg Int
len = NormalList ('Mut s) -> ListOf ('Mut s) (Maybe (Ptr ('Mut s)))
forall (mut :: Mutability).
NormalList mut -> ListOf mut (Maybe (Ptr mut))
ListOfPtr    (NormalList ('Mut s) -> ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
-> m (NormalList ('Mut s))
-> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
64 Message ('Mut s)
msg Int
len

-- | Allocate a NormalList
allocNormalList
    :: M.WriteCtx m s
    => Int                  -- ^ The number bits per element
    -> M.Message ('Mut s) -- ^ The message to allocate in
    -> Int                  -- ^ The number of elements in the list.
    -> m (NormalList ('Mut s))
allocNormalList :: Int -> Message ('Mut s) -> Int -> m (NormalList ('Mut s))
allocNormalList Int
bitsPerElt Message ('Mut s)
msg Int
len = do
    -- round 'len' up to the nearest word boundary.
    let totalBits :: BitCount
totalBits = Int -> BitCount
BitCount (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bitsPerElt)
        totalWords :: WordCount
totalWords = ByteCount -> WordCount
bytesToWordsCeil (ByteCount -> WordCount) -> ByteCount -> WordCount
forall a b. (a -> b) -> a -> b
$ BitCount -> ByteCount
bitsToBytesCeil BitCount
totalBits
    WordPtr ('Mut s)
ptr <- Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
M.alloc Message ('Mut s)
msg WordCount
totalWords
    pure NormalList :: forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList { nPtr :: WordPtr ('Mut s)
nPtr = WordPtr ('Mut s)
ptr, nLen :: Int
nLen = Int
len }

appendCap :: M.WriteCtx m s => M.Message ('Mut s) -> M.Client -> m (Cap ('Mut s))
appendCap :: Message ('Mut s) -> Client -> m (Cap ('Mut s))
appendCap Message ('Mut s)
msg Client
client = do
    Int
i <- Message ('Mut s) -> Client -> m Int
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m Int
M.appendCap Message ('Mut s)
msg Client
client
    pure $ Message ('Mut s) -> Word32 -> Cap ('Mut s)
forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
Cap Message ('Mut s)
msg (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)