{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-error=deprecations #-}

-- |
-- 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
  ( -- * Type-level descriptions of wire representations.
    Repr (..),
    PtrRepr (..),
    ListRepr (..),
    NormalListRepr (..),
    DataSz (..),

    -- * Mapping representations to value types.
    Untyped,
    UntypedData,
    UntypedPtr,
    UntypedSomePtr,
    UntypedList,
    UntypedSomeList,
    IgnoreMut (..),
    MaybePtr (..),
    Unwrapped,

    -- * Relating the representations of lists & their elements.
    Element (..),
    ListItem (..),
    ElemRepr,
    ListReprFor,

    -- * Working with pointers
    IsPtrRepr (..),
    IsListPtrRepr (..),

    -- * Allocating values
    Allocate (..),
    AllocateNormalList (..),
    Ptr (..),
    List (..),
    Struct,
    ListOf,
    Cap,
    structByteCount,
    structWordCount,
    structPtrCount,
    structListByteCount,
    structListWordCount,
    structListPtrCount,
    getData,
    getPtr,
    setData,
    setPtr,
    copyStruct,
    copyPtr,
    copyList,
    copyCap,
    getClient,
    get,
    index,
    setIndex,
    take,
    rootPtr,
    setRoot,
    rawBytes,
    ReadCtx,
    RWCtx,
    HasMessage (..),
    MessageDefault (..),
    allocStruct,
    allocCompositeList,
    allocList0,
    allocList1,
    allocList8,
    allocList16,
    allocList32,
    allocList64,
    allocListPtr,
    appendCap,
    TraverseMsg (..),
  )
where

import Capnp.Address
  ( OffsetError (..),
    WordAddr (..),
    pointerFrom,
    resolveOffset,
  )
import Capnp.Bits
  ( BitCount (..),
    ByteCount (..),
    Word1 (..),
    WordCount (..),
    bitsToBytesCeil,
    bytesToWordsCeil,
    replaceBits,
    wordsToBytes,
  )
import qualified Capnp.Errors as E
import qualified Capnp.Message as M
import Capnp.Mutability (MaybeMutable (..), Mutability (..))
import qualified Capnp.Pointer as P
import Capnp.TraversalLimit (LimitT, MonadLimit (invoice))
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 Data.Bits
import qualified Data.ByteString as BS
import Data.Coerce (coerce)
import Data.Function ((&))
import Data.Kind (Type)
import qualified Data.Vector.Storable.Mutable as SMV
import Data.Word
import Internal.BuildPure (PureBuilder)
import qualified Language.Haskell.TH as TH
import Prelude hiding (length, take)

-------------------------------------------------------------------------------
-- Untyped refernces to values in a message.
-------------------------------------------------------------------------------

-- | 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 ('Data 'Sz0) mut)
  | List1 (ListOf ('Data 'Sz1) mut)
  | List8 (ListOf ('Data 'Sz8) mut)
  | List16 (ListOf ('Data 'Sz16) mut)
  | List32 (ListOf ('Data 'Sz32) mut)
  | List64 (ListOf ('Data 'Sz64) mut)
  | ListPtr (ListOf ('Ptr 'Nothing) mut)
  | ListStruct (ListOf ('Ptr ('Just 'Struct)) mut)

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

data StructList mut = StructList
  { -- | First element. data/ptr sizes are the same for
    -- all elements.
    forall (mut :: Mutability). StructList mut -> Struct mut
slFirst :: Struct mut,
    -- | Number of elements
    forall (mut :: Mutability). StructList mut -> Int
slLen :: !Int
  }

-- | A list of values with representation 'r' in a message.
newtype ListOf r mut = ListOf (ListRepOf r mut)

type family ListRepOf (r :: Repr) :: Mutability -> Type where
  ListRepOf ('Ptr ('Just 'Struct)) = StructList
  ListRepOf r = NormalList

-- | @'ListItem' r@ indicates that @r@ is a representation for elements of some list
-- type. Not every representation is covered; instances exist only for @r@ where
-- @'ElemRepr' ('ListReprFor' r) ~ r@.
class Element r => ListItem (r :: Repr) where
  -- | Returns the length of a list
  length :: ListOf r mut -> Int

  -- underlying implementations of index, setIndex and take, but
  -- without bounds checking. Don't call these directly.
  unsafeIndex :: ReadCtx m mut => Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
  unsafeSetIndex ::
    (RWCtx m s, a ~ Unwrapped (Untyped r ('Mut s))) =>
    a ->
    Int ->
    ListOf r ('Mut s) ->
    m ()
  unsafeTake :: Int -> ListOf r mut -> ListOf r mut

  checkListOf :: ReadCtx m mut => ListOf r mut -> m ()

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

  default length :: (ListRepOf r ~ NormalList) => ListOf r mut -> Int
  length (ListOf ListRepOf r mut
nlist) = forall (mut :: Mutability). NormalList mut -> Int
nLen ListRepOf r mut
nlist
  {-# INLINE length #-}

  default unsafeIndex ::
    forall m mut.
    ( ReadCtx m mut,
      Integral (Unwrapped (Untyped r mut)),
      ListRepOf r ~ NormalList,
      FiniteBits (Unwrapped (Untyped r mut))
    ) =>
    Int ->
    ListOf r mut ->
    m (Unwrapped (Untyped r mut))
  unsafeIndex Int
i (ListOf ListRepOf r mut
nlist) =
    forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, FiniteBits a, Integral a) =>
Int -> NormalList mut -> m a
unsafeIndexBits @(Unwrapped (Untyped r mut)) Int
i ListRepOf r mut
nlist
  {-# INLINE unsafeIndex #-}

  default unsafeSetIndex ::
    forall m s a.
    ( RWCtx m s,
      a ~ Unwrapped (Untyped r ('Mut s)),
      ListRepOf r ~ NormalList,
      Integral a,
      Bounded a,
      FiniteBits a
    ) =>
    a ->
    Int ->
    ListOf r ('Mut s) ->
    m ()
  unsafeSetIndex a
value Int
i (ListOf ListRepOf r ('Mut s)
nlist) =
    forall a (m :: * -> *) s.
(RWCtx m s, Bounded a, FiniteBits a, Integral a) =>
a -> Int -> NormalList ('Mut s) -> m ()
unsafeSetIndexBits @(Unwrapped (Untyped r ('Mut s))) a
value Int
i ListRepOf r ('Mut s)
nlist
  {-# INLINE unsafeSetIndex #-}

  default unsafeTake :: ListRepOf r ~ NormalList => Int -> ListOf r mut -> ListOf r mut
  unsafeTake Int
count (ListOf NormalList {Int
WordPtr mut
nLen :: Int
nPtr :: WordPtr mut
nLen :: forall (mut :: Mutability). NormalList mut -> Int
nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
..}) = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList {nLen :: Int
nLen = Int
count, WordPtr mut
nPtr :: WordPtr mut
nPtr :: WordPtr mut
..}
  {-# INLINE unsafeTake #-}

  default checkListOf ::
    forall m mut.
    ( ReadCtx m mut,
      ListRepOf r ~ NormalList,
      FiniteBits (Untyped r mut)
    ) =>
    ListOf r mut ->
    m ()
  checkListOf (ListOf ListRepOf r mut
l) =
    forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList
      ListRepOf r mut
l
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall b. FiniteBits b => b -> Int
finiteBitSize (forall a. HasCallStack => a
undefined :: Untyped r mut))
  {-# INLINE checkListOf #-}

unsafeIndexBits ::
  forall a m mut.
  ( ReadCtx m mut,
    FiniteBits a,
    Integral a
  ) =>
  Int ->
  NormalList mut ->
  m a
{-# INLINE unsafeIndexBits #-}
unsafeIndexBits :: forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, FiniteBits a, Integral a) =>
Int -> NormalList mut -> m a
unsafeIndexBits Int
i NormalList mut
nlist =
  forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, Integral a) =>
Int -> NormalList mut -> Int -> m a
indexNList @a Int
i NormalList mut
nlist (Int
64 forall a. Integral a => a -> a -> a
`div` forall b. FiniteBits b => b -> Int
finiteBitSize (forall a. HasCallStack => a
undefined :: a))

unsafeSetIndexBits ::
  forall a m s.
  ( RWCtx m s,
    Bounded a,
    FiniteBits a,
    Integral a
  ) =>
  a ->
  Int ->
  NormalList ('Mut s) ->
  m ()
{-# INLINE unsafeSetIndexBits #-}
unsafeSetIndexBits :: forall a (m :: * -> *) s.
(RWCtx m s, Bounded a, FiniteBits a, Integral a) =>
a -> Int -> NormalList ('Mut s) -> m ()
unsafeSetIndexBits a
value Int
i NormalList ('Mut s)
nlist =
  forall a (m :: * -> *) s.
(RWCtx m s, Bounded a, Integral a) =>
Int -> NormalList ('Mut s) -> Int -> a -> m ()
setNIndex @a Int
i NormalList ('Mut s)
nlist (Int
64 forall a. Integral a => a -> a -> a
`div` forall b. FiniteBits b => b -> Int
finiteBitSize a
value) a
value

indexNList ::
  forall a m mut.
  (ReadCtx m mut, Integral a) =>
  Int ->
  NormalList mut ->
  Int ->
  m a
{-# INLINE indexNList #-}
indexNList :: forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, Integral a) =>
Int -> NormalList mut -> Int -> m a
indexNList Int
i (NormalList M.WordPtr {Segment mut
pSegment :: forall (mut :: Mutability). WordPtr mut -> Segment mut
pSegment :: Segment mut
pSegment, pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr = WordAt {Int
WordCount
wordIndex :: WordAddr -> WordCount
segIndex :: WordAddr -> Int
wordIndex :: WordCount
segIndex :: Int
..}} Int
_) Int
eltsPerWord = do
  let wordIndex' :: WordCount
wordIndex' = WordCount
wordIndex forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount (Int
i forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
  Word64
word <- 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 forall a. Integral a => a -> a -> a
`mod` Int
eltsPerWord) forall a. Num a => a -> a -> a
* (Int
64 forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
word forall a. Bits a => a -> Int -> a
`shiftR` Int
shift

setNIndex ::
  forall a m s.
  (RWCtx m s, Bounded a, Integral a) =>
  Int ->
  NormalList ('Mut s) ->
  Int ->
  a ->
  m ()
{-# INLINE setNIndex #-}
setNIndex :: forall a (m :: * -> *) s.
(RWCtx m s, Bounded a, Integral a) =>
Int -> NormalList ('Mut s) -> Int -> a -> m ()
setNIndex Int
i 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 forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount (Int
i forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
  Word64
word <- 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 forall a. Integral a => a -> a -> a
`mod` Int
eltsPerWord) forall a. Num a => a -> a -> a
* (Int
64 forall a. Integral a => a -> a -> a
`div` Int
eltsPerWord)
  forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
pSegment WordCount
eltWordIndex forall a b. (a -> b) -> a -> b
$ forall a. (Bounded a, Integral a) => a -> Word64 -> Int -> Word64
replaceBits a
value Word64
word Int
shift

setPtrIndex :: RWCtx m s => Int -> NormalList ('Mut s) -> Ptr ('Mut s) -> P.Ptr -> m ()
{-# INLINE setPtrIndex #-}
setPtrIndex :: forall (m :: * -> *) s.
RWCtx m s =>
Int -> NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
setPtrIndex Int
i 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 forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount Int
i}}
   in forall (m :: * -> *) s.
WriteCtx m s =>
WordPtr ('Mut s) -> WordAddr -> Ptr -> m ()
setPointerTo WordPtr ('Mut s)
srcPtr (forall (msg :: Mutability). Ptr msg -> WordAddr
ptrAddr Ptr ('Mut s)
absPtr) Ptr
relPtr

instance ListItem ('Ptr ('Just 'Struct)) where
  length :: forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> Int
length (ListOf (StructList Struct mut
_ Int
len)) = Int
len
  {-# INLINE length #-}
  unsafeIndex :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Int
-> ListOf ('Ptr ('Just 'Struct)) mut
-> m (Unwrapped (Untyped ('Ptr ('Just 'Struct)) mut))
unsafeIndex Int
i (ListOf (StructList (StructAt 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 forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz)
    let addr' :: WordAddr
addr' = WordAddr
addr {wordIndex :: WordCount
wordIndex = WordCount
wordIndex forall a. Num a => a -> a -> a
+ WordCount
offset}
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
StructAt WordPtr mut
ptr {pAddr :: WordAddr
M.pAddr = WordAddr
addr'} Word16
dataSz Word16
ptrSz
  {-# INLINE unsafeIndex #-}
  unsafeSetIndex :: forall (m :: * -> *) s a.
(RWCtx m s,
 a ~ Unwrapped (Untyped ('Ptr ('Just 'Struct)) ('Mut s))) =>
a -> Int -> ListOf ('Ptr ('Just 'Struct)) ('Mut s) -> m ()
unsafeSetIndex a
value Int
i ListOf ('Ptr ('Just 'Struct)) ('Mut s)
list = do
    Struct ('Mut s)
dest <- forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
unsafeIndex Int
i ListOf ('Ptr ('Just 'Struct)) ('Mut s)
list
    forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Struct ('Mut s) -> m ()
copyStruct Struct ('Mut s)
dest a
value
  unsafeTake :: forall (mut :: Mutability).
Int
-> ListOf ('Ptr ('Just 'Struct)) mut
-> ListOf ('Ptr ('Just 'Struct)) mut
unsafeTake Int
count (ListOf (StructList Struct mut
s Int
_)) = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf (forall (mut :: Mutability). Struct mut -> Int -> StructList mut
StructList Struct mut
s Int
count)
  {-# INLINE unsafeTake #-}

  checkListOf :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
ListOf ('Ptr ('Just 'Struct)) mut -> m ()
checkListOf (ListOf (StructList s :: Struct mut
s@(StructAt WordPtr mut
ptr Word16
_ Word16
_) Int
len)) =
    forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> WordCount -> m ()
checkPtrOffset WordPtr mut
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len forall a. Num a => a -> a -> a
* forall (mut :: Mutability). Struct mut -> WordCount
structSize Struct mut
s)
  {-# INLINE checkListOf #-}

instance ListItem ('Data 'Sz0) where
  unsafeIndex :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Int
-> ListOf ('Data 'Sz0) mut
-> m (Unwrapped (Untyped ('Data 'Sz0) mut))
unsafeIndex Int
_ ListOf ('Data 'Sz0) mut
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  {-# INLINE unsafeIndex #-}
  unsafeSetIndex :: forall (m :: * -> *) s a.
(RWCtx m s, a ~ Unwrapped (Untyped ('Data 'Sz0) ('Mut s))) =>
a -> Int -> ListOf ('Data 'Sz0) ('Mut s) -> m ()
unsafeSetIndex a
_ Int
_ ListOf ('Data 'Sz0) ('Mut s)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  {-# INLINE unsafeSetIndex #-}
  checkListOf :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
ListOf ('Data 'Sz0) mut -> m ()
checkListOf ListOf ('Data 'Sz0) mut
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  {-# INLINE checkListOf #-}
  copyListOf :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Data 'Sz0) ('Mut s)
-> ListOf ('Data 'Sz0) ('Mut s) -> m ()
copyListOf ListOf ('Data 'Sz0) ('Mut s)
_ ListOf ('Data 'Sz0) ('Mut s)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  {-# INLINE copyListOf #-}

instance ListItem ('Data 'Sz1) where
  unsafeIndex :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Int
-> ListOf ('Data 'Sz1) mut
-> m (Unwrapped (Untyped ('Data 'Sz1) mut))
unsafeIndex Int
i (ListOf ListRepOf ('Data 'Sz1) mut
nlist) = do
    Word1 Bool
val <- forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, FiniteBits a, Integral a) =>
Int -> NormalList mut -> m a
unsafeIndexBits @Word1 Int
i ListRepOf ('Data 'Sz1) mut
nlist
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
val
  {-# INLINE unsafeIndex #-}
  unsafeSetIndex :: forall (m :: * -> *) s a.
(RWCtx m s, a ~ Unwrapped (Untyped ('Data 'Sz1) ('Mut s))) =>
a -> Int -> ListOf ('Data 'Sz1) ('Mut s) -> m ()
unsafeSetIndex a
value Int
i (ListOf ListRepOf ('Data 'Sz1) ('Mut s)
nlist) =
    forall a (m :: * -> *) s.
(RWCtx m s, Bounded a, FiniteBits a, Integral a) =>
a -> Int -> NormalList ('Mut s) -> m ()
unsafeSetIndexBits @Word1 (Bool -> Word1
Word1 a
value) Int
i ListRepOf ('Data 'Sz1) ('Mut s)
nlist
  {-# INLINE unsafeSetIndex #-}
  checkListOf :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
ListOf ('Data 'Sz1) mut -> m ()
checkListOf (ListOf ListRepOf ('Data 'Sz1) mut
l) = forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList ListRepOf ('Data 'Sz1) mut
l BitCount
1
  {-# INLINE copyListOf #-}
  copyListOf :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Data 'Sz1) ('Mut s)
-> ListOf ('Data 'Sz1) ('Mut s) -> m ()
copyListOf (ListOf ListRepOf ('Data 'Sz1) ('Mut s)
dest) (ListOf ListRepOf ('Data 'Sz1) ('Mut s)
src) = forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m ()
copyDataList ListRepOf ('Data 'Sz1) ('Mut s)
dest ListRepOf ('Data 'Sz1) ('Mut s)
src BitCount
1

instance ListItem ('Data 'Sz8) where
  {-# INLINE copyListOf #-}
  copyListOf :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Data 'Sz8) ('Mut s)
-> ListOf ('Data 'Sz8) ('Mut s) -> m ()
copyListOf (ListOf ListRepOf ('Data 'Sz8) ('Mut s)
dest) (ListOf ListRepOf ('Data 'Sz8) ('Mut s)
src) = forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m ()
copyDataList ListRepOf ('Data 'Sz8) ('Mut s)
dest ListRepOf ('Data 'Sz8) ('Mut s)
src BitCount
8

instance ListItem ('Data 'Sz16) where
  {-# INLINE copyListOf #-}
  copyListOf :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Data 'Sz16) ('Mut s)
-> ListOf ('Data 'Sz16) ('Mut s) -> m ()
copyListOf (ListOf ListRepOf ('Data 'Sz16) ('Mut s)
dest) (ListOf ListRepOf ('Data 'Sz16) ('Mut s)
src) = forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m ()
copyDataList ListRepOf ('Data 'Sz16) ('Mut s)
dest ListRepOf ('Data 'Sz16) ('Mut s)
src BitCount
16

instance ListItem ('Data 'Sz32) where
  {-# INLINE copyListOf #-}
  copyListOf :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Data 'Sz32) ('Mut s)
-> ListOf ('Data 'Sz32) ('Mut s) -> m ()
copyListOf (ListOf ListRepOf ('Data 'Sz32) ('Mut s)
dest) (ListOf ListRepOf ('Data 'Sz32) ('Mut s)
src) = forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m ()
copyDataList ListRepOf ('Data 'Sz32) ('Mut s)
dest ListRepOf ('Data 'Sz32) ('Mut s)
src BitCount
32

instance ListItem ('Data 'Sz64) where
  {-# INLINE copyListOf #-}
  copyListOf :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Data 'Sz64) ('Mut s)
-> ListOf ('Data 'Sz64) ('Mut s) -> m ()
copyListOf (ListOf ListRepOf ('Data 'Sz64) ('Mut s)
dest) (ListOf ListRepOf ('Data 'Sz64) ('Mut s)
src) = forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m ()
copyDataList ListRepOf ('Data 'Sz64) ('Mut s)
dest ListRepOf ('Data 'Sz64) ('Mut s)
src BitCount
64

instance ListItem ('Ptr 'Nothing) where
  unsafeIndex :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Int
-> ListOf ('Ptr 'Nothing) mut
-> m (Unwrapped (Untyped ('Ptr 'Nothing) mut))
unsafeIndex Int
i (ListOf (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
_)) =
    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 forall a. Num a => a -> a -> a
+ Int -> WordCount
WordCount Int
i}}
  {-# INLINE unsafeIndex #-}
  unsafeSetIndex :: forall (m :: * -> *) s a.
(RWCtx m s, a ~ Unwrapped (Untyped ('Ptr 'Nothing) ('Mut s))) =>
a -> Int -> ListOf ('Ptr 'Nothing) ('Mut s) -> m ()
unsafeSetIndex a
value Int
i list :: ListOf ('Ptr 'Nothing) ('Mut s)
list@(ListOf ListRepOf ('Ptr 'Nothing) ('Mut s)
nlist) = case a
value of
    Just Ptr ('Mut s)
p | forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @Ptr Ptr ('Mut s)
p forall a. Eq a => a -> a -> Bool
/= forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Ptr 'Nothing)) ListOf ('Ptr 'Nothing) ('Mut s)
list -> do
      Maybe (Ptr ('Mut s))
newPtr <- forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
copyPtr (forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Ptr 'Nothing)) ListOf ('Ptr 'Nothing) ('Mut s)
list) a
value
      forall (r :: Repr) (m :: * -> *) s a.
(ListItem r, RWCtx m s, a ~ Unwrapped (Untyped r ('Mut s))) =>
a -> Int -> ListOf r ('Mut s) -> m ()
unsafeSetIndex Maybe (Ptr ('Mut s))
newPtr Int
i ListOf ('Ptr 'Nothing) ('Mut s)
list
    a
Maybe (Ptr ('Mut s))
Nothing ->
      forall a (m :: * -> *) s.
(RWCtx m s, Bounded a, Integral a) =>
Int -> NormalList ('Mut s) -> Int -> a -> m ()
setNIndex Int
i ListRepOf ('Ptr 'Nothing) ('Mut s)
nlist Int
1 (Maybe Ptr -> Word64
P.serializePtr forall a. Maybe a
Nothing)
    Just (PtrCap (CapAt Message ('Mut s)
_ Word32
cap)) ->
      forall a (m :: * -> *) s.
(RWCtx m s, Bounded a, Integral a) =>
Int -> NormalList ('Mut s) -> Int -> a -> m ()
setNIndex Int
i ListRepOf ('Ptr 'Nothing) ('Mut s)
nlist Int
1 (Maybe Ptr -> Word64
P.serializePtr (forall a. a -> Maybe a
Just (Word32 -> Ptr
P.CapPtr Word32
cap)))
    Just p :: Ptr ('Mut s)
p@(PtrList List ('Mut s)
ptrList) ->
      forall (m :: * -> *) s.
RWCtx m s =>
Int -> NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
setPtrIndex Int
i ListRepOf ('Ptr 'Nothing) ('Mut s)
nlist Ptr ('Mut s)
p forall a b. (a -> b) -> a -> b
$ Int32 -> EltSpec -> Ptr
P.ListPtr Int32
0 (forall (msg :: Mutability). List msg -> EltSpec
listEltSpec List ('Mut s)
ptrList)
    Just p :: Ptr ('Mut s)
p@(PtrStruct (StructAt WordPtr ('Mut s)
_ Word16
dataSz Word16
ptrSz)) ->
      forall (m :: * -> *) s.
RWCtx m s =>
Int -> NormalList ('Mut s) -> Ptr ('Mut s) -> Ptr -> m ()
setPtrIndex Int
i ListRepOf ('Ptr 'Nothing) ('Mut s)
nlist Ptr ('Mut s)
p forall a b. (a -> b) -> a -> b
$ Int32 -> Word16 -> Word16 -> Ptr
P.StructPtr Int32
0 Word16
dataSz Word16
ptrSz
  {-# INLINEABLE unsafeSetIndex #-}

  checkListOf :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
ListOf ('Ptr 'Nothing) mut -> m ()
checkListOf (ListOf ListRepOf ('Ptr 'Nothing) mut
l) = forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
NormalList mut -> BitCount -> m ()
checkNormalList ListRepOf ('Ptr 'Nothing) mut
l BitCount
64
  {-# INLINE checkListOf #-}

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

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

-- | 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 'Repr' describes a wire representation for a value. This is
-- mostly used at the type level (using DataKinds); types are
-- parametrized over representations.
data Repr
  = -- | Pointer type. 'Nothing' indicates an AnyPointer, 'Just' describes
    -- a more specific pointer type.
    Ptr (Maybe PtrRepr)
  | -- | Non-pointer type.
    Data DataSz
  deriving (Int -> Repr -> ShowS
[Repr] -> ShowS
Repr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Repr] -> ShowS
$cshowList :: [Repr] -> ShowS
show :: Repr -> String
$cshow :: Repr -> String
showsPrec :: Int -> Repr -> ShowS
$cshowsPrec :: Int -> Repr -> ShowS
Show)

-- | Information about the representation of a pointer type
data PtrRepr
  = -- | Capability pointer.
    Cap
  | -- | List pointer. 'Nothing' describes an AnyList, 'Just' describes
    -- more specific list types.
    List (Maybe ListRepr)
  | -- | A struct (or group).
    Struct
  deriving (Int -> PtrRepr -> ShowS
[PtrRepr] -> ShowS
PtrRepr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PtrRepr] -> ShowS
$cshowList :: [PtrRepr] -> ShowS
show :: PtrRepr -> String
$cshow :: PtrRepr -> String
showsPrec :: Int -> PtrRepr -> ShowS
$cshowsPrec :: Int -> PtrRepr -> ShowS
Show)

-- | Information about the representation of a list type.
data ListRepr where
  -- | A "normal" list
  ListNormal :: NormalListRepr -> ListRepr
  -- | A composite (struct) list
  ListComposite :: ListRepr
  deriving (Int -> ListRepr -> ShowS
[ListRepr] -> ShowS
ListRepr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ListRepr] -> ShowS
$cshowList :: [ListRepr] -> ShowS
show :: ListRepr -> String
$cshow :: ListRepr -> String
showsPrec :: Int -> ListRepr -> ShowS
$cshowsPrec :: Int -> ListRepr -> ShowS
Show)

-- | Information about the representation of a normal (non-composite) list.
data NormalListRepr where
  NormalListData :: DataSz -> NormalListRepr
  NormalListPtr :: NormalListRepr
  deriving (Int -> NormalListRepr -> ShowS
[NormalListRepr] -> ShowS
NormalListRepr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormalListRepr] -> ShowS
$cshowList :: [NormalListRepr] -> ShowS
show :: NormalListRepr -> String
$cshow :: NormalListRepr -> String
showsPrec :: Int -> NormalListRepr -> ShowS
$cshowsPrec :: Int -> NormalListRepr -> ShowS
Show)

-- | The size of a non-pointer type. @SzN@ represents an @N@-bit value.
data DataSz = Sz0 | Sz1 | Sz8 | Sz16 | Sz32 | Sz64
  deriving (Int -> DataSz -> ShowS
[DataSz] -> ShowS
DataSz -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataSz] -> ShowS
$cshowList :: [DataSz] -> ShowS
show :: DataSz -> String
$cshow :: DataSz -> String
showsPrec :: Int -> DataSz -> ShowS
$cshowsPrec :: Int -> DataSz -> ShowS
Show)

-- | Wrapper for use with 'Untyped'; see docs for 'Untyped'
newtype IgnoreMut a (mut :: Mutability) = IgnoreMut a
  deriving (Int -> IgnoreMut a mut -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a (mut :: Mutability).
Show a =>
Int -> IgnoreMut a mut -> ShowS
forall a (mut :: Mutability). Show a => [IgnoreMut a mut] -> ShowS
forall a (mut :: Mutability). Show a => IgnoreMut a mut -> String
showList :: [IgnoreMut a mut] -> ShowS
$cshowList :: forall a (mut :: Mutability). Show a => [IgnoreMut a mut] -> ShowS
show :: IgnoreMut a mut -> String
$cshow :: forall a (mut :: Mutability). Show a => IgnoreMut a mut -> String
showsPrec :: Int -> IgnoreMut a mut -> ShowS
$cshowsPrec :: forall a (mut :: Mutability).
Show a =>
Int -> IgnoreMut a mut -> ShowS
Show, ReadPrec [IgnoreMut a mut]
ReadPrec (IgnoreMut a mut)
ReadS [IgnoreMut a mut]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a (mut :: Mutability). Read a => ReadPrec [IgnoreMut a mut]
forall a (mut :: Mutability). Read a => ReadPrec (IgnoreMut a mut)
forall a (mut :: Mutability).
Read a =>
Int -> ReadS (IgnoreMut a mut)
forall a (mut :: Mutability). Read a => ReadS [IgnoreMut a mut]
readListPrec :: ReadPrec [IgnoreMut a mut]
$creadListPrec :: forall a (mut :: Mutability). Read a => ReadPrec [IgnoreMut a mut]
readPrec :: ReadPrec (IgnoreMut a mut)
$creadPrec :: forall a (mut :: Mutability). Read a => ReadPrec (IgnoreMut a mut)
readList :: ReadS [IgnoreMut a mut]
$creadList :: forall a (mut :: Mutability). Read a => ReadS [IgnoreMut a mut]
readsPrec :: Int -> ReadS (IgnoreMut a mut)
$creadsPrec :: forall a (mut :: Mutability).
Read a =>
Int -> ReadS (IgnoreMut a mut)
Read, IgnoreMut a mut -> IgnoreMut a mut -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a (mut :: Mutability).
Eq a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
/= :: IgnoreMut a mut -> IgnoreMut a mut -> Bool
$c/= :: forall a (mut :: Mutability).
Eq a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
== :: IgnoreMut a mut -> IgnoreMut a mut -> Bool
$c== :: forall a (mut :: Mutability).
Eq a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
Eq, IgnoreMut a mut -> IgnoreMut a mut -> Bool
IgnoreMut a mut -> IgnoreMut a mut -> Ordering
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {mut :: Mutability}. Ord a => Eq (IgnoreMut a mut)
forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> Ordering
forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
min :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$cmin :: forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
max :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$cmax :: forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
>= :: IgnoreMut a mut -> IgnoreMut a mut -> Bool
$c>= :: forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
> :: IgnoreMut a mut -> IgnoreMut a mut -> Bool
$c> :: forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
<= :: IgnoreMut a mut -> IgnoreMut a mut -> Bool
$c<= :: forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
< :: IgnoreMut a mut -> IgnoreMut a mut -> Bool
$c< :: forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> Bool
compare :: IgnoreMut a mut -> IgnoreMut a mut -> Ordering
$ccompare :: forall a (mut :: Mutability).
Ord a =>
IgnoreMut a mut -> IgnoreMut a mut -> Ordering
Ord, Int -> IgnoreMut a mut
IgnoreMut a mut -> Int
IgnoreMut a mut -> [IgnoreMut a mut]
IgnoreMut a mut -> IgnoreMut a mut
IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
IgnoreMut a mut
-> IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
forall a (mut :: Mutability). Enum a => Int -> IgnoreMut a mut
forall a (mut :: Mutability). Enum a => IgnoreMut a mut -> Int
forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> [IgnoreMut a mut]
forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> IgnoreMut a mut
forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut
-> IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
enumFromThenTo :: IgnoreMut a mut
-> IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
$cenumFromThenTo :: forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut
-> IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
enumFromTo :: IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
$cenumFromTo :: forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
enumFromThen :: IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
$cenumFromThen :: forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> IgnoreMut a mut -> [IgnoreMut a mut]
enumFrom :: IgnoreMut a mut -> [IgnoreMut a mut]
$cenumFrom :: forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> [IgnoreMut a mut]
fromEnum :: IgnoreMut a mut -> Int
$cfromEnum :: forall a (mut :: Mutability). Enum a => IgnoreMut a mut -> Int
toEnum :: Int -> IgnoreMut a mut
$ctoEnum :: forall a (mut :: Mutability). Enum a => Int -> IgnoreMut a mut
pred :: IgnoreMut a mut -> IgnoreMut a mut
$cpred :: forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> IgnoreMut a mut
succ :: IgnoreMut a mut -> IgnoreMut a mut
$csucc :: forall a (mut :: Mutability).
Enum a =>
IgnoreMut a mut -> IgnoreMut a mut
Enum, IgnoreMut a mut
forall a. a -> a -> Bounded a
forall a (mut :: Mutability). Bounded a => IgnoreMut a mut
maxBound :: IgnoreMut a mut
$cmaxBound :: forall a (mut :: Mutability). Bounded a => IgnoreMut a mut
minBound :: IgnoreMut a mut
$cminBound :: forall a (mut :: Mutability). Bounded a => IgnoreMut a mut
Bounded, Integer -> IgnoreMut a mut
IgnoreMut a mut -> IgnoreMut a mut
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
forall a (mut :: Mutability). Num a => Integer -> IgnoreMut a mut
forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut
forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
fromInteger :: Integer -> IgnoreMut a mut
$cfromInteger :: forall a (mut :: Mutability). Num a => Integer -> IgnoreMut a mut
signum :: IgnoreMut a mut -> IgnoreMut a mut
$csignum :: forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut
abs :: IgnoreMut a mut -> IgnoreMut a mut
$cabs :: forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut
negate :: IgnoreMut a mut -> IgnoreMut a mut
$cnegate :: forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut
* :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$c* :: forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
- :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$c- :: forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
+ :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$c+ :: forall a (mut :: Mutability).
Num a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
Num, IgnoreMut a mut -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
forall {a} {mut :: Mutability}. Real a => Num (IgnoreMut a mut)
forall {a} {mut :: Mutability}. Real a => Ord (IgnoreMut a mut)
forall a (mut :: Mutability). Real a => IgnoreMut a mut -> Rational
toRational :: IgnoreMut a mut -> Rational
$ctoRational :: forall a (mut :: Mutability). Real a => IgnoreMut a mut -> Rational
Real, IgnoreMut a mut -> Integer
IgnoreMut a mut
-> IgnoreMut a mut -> (IgnoreMut a mut, IgnoreMut a mut)
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
forall {a} {mut :: Mutability}.
Integral a =>
Enum (IgnoreMut a mut)
forall {a} {mut :: Mutability}.
Integral a =>
Real (IgnoreMut a mut)
forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut -> Integer
forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut
-> IgnoreMut a mut -> (IgnoreMut a mut, IgnoreMut a mut)
forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
toInteger :: IgnoreMut a mut -> Integer
$ctoInteger :: forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut -> Integer
divMod :: IgnoreMut a mut
-> IgnoreMut a mut -> (IgnoreMut a mut, IgnoreMut a mut)
$cdivMod :: forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut
-> IgnoreMut a mut -> (IgnoreMut a mut, IgnoreMut a mut)
quotRem :: IgnoreMut a mut
-> IgnoreMut a mut -> (IgnoreMut a mut, IgnoreMut a mut)
$cquotRem :: forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut
-> IgnoreMut a mut -> (IgnoreMut a mut, IgnoreMut a mut)
mod :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$cmod :: forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
div :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$cdiv :: forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
rem :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$crem :: forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
quot :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$cquot :: forall a (mut :: Mutability).
Integral a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
Integral, IgnoreMut a mut
Int -> IgnoreMut a mut
IgnoreMut a mut -> Bool
IgnoreMut a mut -> Int
IgnoreMut a mut -> Maybe Int
IgnoreMut a mut -> IgnoreMut a mut
IgnoreMut a mut -> Int -> Bool
IgnoreMut a mut -> Int -> IgnoreMut a mut
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
forall a.
Eq a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> a
-> (Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> Bool)
-> (a -> Maybe Int)
-> (a -> Int)
-> (a -> Bool)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int)
-> Bits a
forall {a} {mut :: Mutability}. Bits a => Eq (IgnoreMut a mut)
forall a (mut :: Mutability). Bits a => IgnoreMut a mut
forall a (mut :: Mutability). Bits a => Int -> IgnoreMut a mut
forall a (mut :: Mutability). Bits a => IgnoreMut a mut -> Bool
forall a (mut :: Mutability). Bits a => IgnoreMut a mut -> Int
forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Maybe Int
forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> IgnoreMut a mut
forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> Bool
forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
popCount :: IgnoreMut a mut -> Int
$cpopCount :: forall a (mut :: Mutability). Bits a => IgnoreMut a mut -> Int
rotateR :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$crotateR :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
rotateL :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$crotateL :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
unsafeShiftR :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$cunsafeShiftR :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
shiftR :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$cshiftR :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
unsafeShiftL :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$cunsafeShiftL :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
shiftL :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$cshiftL :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
isSigned :: IgnoreMut a mut -> Bool
$cisSigned :: forall a (mut :: Mutability). Bits a => IgnoreMut a mut -> Bool
bitSize :: IgnoreMut a mut -> Int
$cbitSize :: forall a (mut :: Mutability). Bits a => IgnoreMut a mut -> Int
bitSizeMaybe :: IgnoreMut a mut -> Maybe Int
$cbitSizeMaybe :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Maybe Int
testBit :: IgnoreMut a mut -> Int -> Bool
$ctestBit :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> Bool
complementBit :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$ccomplementBit :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
clearBit :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$cclearBit :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
setBit :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$csetBit :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
bit :: Int -> IgnoreMut a mut
$cbit :: forall a (mut :: Mutability). Bits a => Int -> IgnoreMut a mut
zeroBits :: IgnoreMut a mut
$czeroBits :: forall a (mut :: Mutability). Bits a => IgnoreMut a mut
rotate :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$crotate :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
shift :: IgnoreMut a mut -> Int -> IgnoreMut a mut
$cshift :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> Int -> IgnoreMut a mut
complement :: IgnoreMut a mut -> IgnoreMut a mut
$ccomplement :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> IgnoreMut a mut
xor :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$cxor :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
.|. :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$c.|. :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
.&. :: IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
$c.&. :: forall a (mut :: Mutability).
Bits a =>
IgnoreMut a mut -> IgnoreMut a mut -> IgnoreMut a mut
Bits, IgnoreMut a mut -> Int
forall b.
Bits b -> (b -> Int) -> (b -> Int) -> (b -> Int) -> FiniteBits b
forall {a} {mut :: Mutability}.
FiniteBits a =>
Bits (IgnoreMut a mut)
forall a (mut :: Mutability).
FiniteBits a =>
IgnoreMut a mut -> Int
countTrailingZeros :: IgnoreMut a mut -> Int
$ccountTrailingZeros :: forall a (mut :: Mutability).
FiniteBits a =>
IgnoreMut a mut -> Int
countLeadingZeros :: IgnoreMut a mut -> Int
$ccountLeadingZeros :: forall a (mut :: Mutability).
FiniteBits a =>
IgnoreMut a mut -> Int
finiteBitSize :: IgnoreMut a mut -> Int
$cfiniteBitSize :: forall a (mut :: Mutability).
FiniteBits a =>
IgnoreMut a mut -> Int
FiniteBits)

-- | Wrapper for use with 'Untyped'; see docs for 'Untyped'.
newtype MaybePtr (mut :: Mutability) = MaybePtr (Maybe (Ptr mut))

-- | Normalizes types returned by 'Untyped'; see docs for 'Untyped'.
type family Unwrapped a where
  Unwrapped (IgnoreMut a mut) = a
  Unwrapped (MaybePtr mut) = Maybe (Ptr mut)
  Unwrapped a = a

-- | @Untyped r mut@ is an untyped value with representation @r@ stored in
-- a message with mutability @mut@.
--
-- Note that the return type of this type family has kind
-- @'Mutability' -> 'Type'@. This is important, as it allows us
-- to define instances on @'Untyped' r@, and use @'Untyped' r@
-- in constraints.
--
-- This introduces some awkwardnesses though -- we really want
-- this to be @(Maybe (Ptr mut))@ for @'Ptr 'Nothing@, and
-- Int types/Bool/() for @'Data sz@. But we can't because these
-- are the wrong kind.
--
-- So, we hack around this by introducing two newtypes, 'IgnoreMut'
-- and 'MaybePtr', and a type family 'Unwrapped', which lets us
-- use @'Unwrapped' ('Untyped' r mut)@ as the type we really want
-- in some places, though we can't curry it then.
--
-- All this is super super awkward, but this is a low level
-- mostly-internal API; most users will intract with this through
-- the Raw type in "Capnp.Repr", which hides all of this...
type family Untyped (r :: Repr) :: Mutability -> Type where
  Untyped ('Data sz) = IgnoreMut (UntypedData sz)
  Untyped ('Ptr ptr) = UntypedPtr ptr

-- | @UntypedData sz@ is an untyped value with size @sz@.
type family UntypedData (sz :: DataSz) :: Type where
  UntypedData 'Sz0 = ()
  UntypedData 'Sz1 = Bool
  UntypedData 'Sz8 = Word8
  UntypedData 'Sz16 = Word16
  UntypedData 'Sz32 = Word32
  UntypedData 'Sz64 = Word64

-- | Like 'Untyped', but for pointers only.
type family UntypedPtr (r :: Maybe PtrRepr) :: Mutability -> Type where
  UntypedPtr 'Nothing = MaybePtr
  UntypedPtr ('Just r) = UntypedSomePtr r

-- | Like 'UntypedPtr', but doesn't allow AnyPointers.
type family UntypedSomePtr (r :: PtrRepr) :: Mutability -> Type where
  UntypedSomePtr 'Struct = Struct
  UntypedSomePtr 'Cap = Cap
  UntypedSomePtr ('List r) = UntypedList r

-- | Like 'Untyped', but for lists only.
type family UntypedList (r :: Maybe ListRepr) :: Mutability -> Type where
  UntypedList 'Nothing = List
  UntypedList ('Just r) = UntypedSomeList r

-- | Like 'UntypedList', but doesn't allow AnyLists.
type family UntypedSomeList (r :: ListRepr) :: Mutability -> Type where
  UntypedSomeList r = ListOf (ElemRepr r)

-- | @ElemRepr r@ is the representation of elements of lists with
-- representation @r@.
type family ElemRepr (rl :: ListRepr) :: Repr where
  ElemRepr 'ListComposite = 'Ptr ('Just 'Struct)
  ElemRepr ('ListNormal 'NormalListPtr) = 'Ptr 'Nothing
  ElemRepr ('ListNormal ('NormalListData sz)) = 'Data sz

-- | @ListReprFor e@ is the representation of lists with elements
-- whose representation is @e@.
type family ListReprFor (e :: Repr) :: ListRepr where
  ListReprFor ('Data sz) = 'ListNormal ('NormalListData sz)
  ListReprFor ('Ptr ('Just 'Struct)) = 'ListComposite
  ListReprFor ('Ptr a) = 'ListNormal 'NormalListPtr

-- | 'Element' supports converting between values of representation
-- @'ElemRepr' ('ListReprFor' r)@ and values of representation @r@.
--
-- At a glance, you might expect this to just be a no-op, but it is actually
-- *not* always the case that @'ElemRepr' ('ListReprFor' r) ~ r@; in the
-- case of pointer types, @'ListReprFor' r@ can contain arbitrary pointers,
-- so information is lost, and it is possible for the list to contain pointers
-- of the incorrect type. In this case, 'fromElement' will throw an error.
--
-- 'toElement' is more trivial.
class Element (r :: Repr) where
  fromElement ::
    forall m mut.
    ReadCtx m mut =>
    M.Message mut ->
    Unwrapped (Untyped (ElemRepr (ListReprFor r)) mut) ->
    m (Unwrapped (Untyped r mut))
  toElement :: Unwrapped (Untyped r mut) -> Unwrapped (Untyped (ElemRepr (ListReprFor r)) mut)

-- | Operations on types with pointer representations.
class IsPtrRepr (r :: Maybe PtrRepr) where
  toPtr :: Unwrapped (Untyped ('Ptr r) mut) -> Maybe (Ptr mut)
  -- ^ Convert an untyped value of this representation to an AnyPointer.

  fromPtr :: ReadCtx m mut => M.Message mut -> Maybe (Ptr mut) -> m (Unwrapped (Untyped ('Ptr r) mut))
  -- ^ Extract a value with this representation from an AnyPointer, failing
  -- if the pointer is the wrong type for this representation.

-- | Operations on types with list representations.
class IsListPtrRepr (r :: ListRepr) where
  rToList :: UntypedSomeList r mut -> List mut
  -- ^ Convert an untyped value of this representation to an AnyList.

  rFromList :: ReadCtx m mut => List mut -> m (UntypedSomeList r mut)
  -- ^ Extract a value with this representation from an AnyList, failing
  -- if the list is the wrong type for this representation.

  rFromListMsg :: ReadCtx m mut => M.Message mut -> m (UntypedSomeList r mut)
  -- ^ Create a zero-length value with this representation, living in the
  -- provided message.

-- helper function for throwing SchemaViolationError "expected ..."
expected :: MonadThrow m => String -> m a
expected :: forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
msg = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> Error
E.SchemaViolationError forall a b. (a -> b) -> a -> b
$ String
"expected " forall a. [a] -> [a] -> [a]
++ String
msg

-------------------------------------------------------------------------------
-- 'Element' instances
-------------------------------------------------------------------------------

instance Element ('Data sz) where
  fromElement :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Unwrapped (Untyped (ElemRepr (ListReprFor ('Data sz))) mut)
-> m (Unwrapped (Untyped ('Data sz) mut))
fromElement Message mut
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  toElement :: forall (mut :: Mutability).
Unwrapped (Untyped ('Data sz) mut)
-> Unwrapped (Untyped (ElemRepr (ListReprFor ('Data sz))) mut)
toElement = forall a. a -> a
id
  {-# INLINE fromElement #-}
  {-# INLINE toElement #-}

instance Element ('Ptr ('Just 'Struct)) where
  fromElement :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Unwrapped
     (Untyped (ElemRepr (ListReprFor ('Ptr ('Just 'Struct)))) mut)
-> m (Unwrapped (Untyped ('Ptr ('Just 'Struct)) mut))
fromElement Message mut
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  toElement :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr ('Just 'Struct)) mut)
-> Unwrapped
     (Untyped (ElemRepr (ListReprFor ('Ptr ('Just 'Struct)))) mut)
toElement = forall a. a -> a
id
  {-# INLINE fromElement #-}
  {-# INLINE toElement #-}

instance Element ('Ptr 'Nothing) where
  fromElement :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Unwrapped (Untyped (ElemRepr (ListReprFor ('Ptr 'Nothing))) mut)
-> m (Unwrapped (Untyped ('Ptr 'Nothing) mut))
fromElement Message mut
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  toElement :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr 'Nothing) mut)
-> Unwrapped (Untyped (ElemRepr (ListReprFor ('Ptr 'Nothing))) mut)
toElement = forall a. a -> a
id
  {-# INLINE fromElement #-}
  {-# INLINE toElement #-}

instance Element ('Ptr ('Just 'Cap)) where
  fromElement :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Unwrapped
     (Untyped (ElemRepr (ListReprFor ('Ptr ('Just 'Cap)))) mut)
-> m (Unwrapped (Untyped ('Ptr ('Just 'Cap)) mut))
fromElement = forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut
-> Maybe (Ptr mut) -> m (Unwrapped (Untyped ('Ptr r) mut))
fromPtr @('Just 'Cap)
  toElement :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr ('Just 'Cap)) mut)
-> Unwrapped
     (Untyped (ElemRepr (ListReprFor ('Ptr ('Just 'Cap)))) mut)
toElement = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap
  {-# INLINE fromElement #-}
  {-# INLINE toElement #-}

instance IsPtrRepr ('Just ('List a)) => Element ('Ptr ('Just ('List a))) where
  fromElement :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Unwrapped
     (Untyped (ElemRepr (ListReprFor ('Ptr ('Just ('List a))))) mut)
-> m (Unwrapped (Untyped ('Ptr ('Just ('List a))) mut))
fromElement = forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut
-> Maybe (Ptr mut) -> m (Unwrapped (Untyped ('Ptr r) mut))
fromPtr @('Just ('List a))
  toElement :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr ('Just ('List a))) mut)
-> Unwrapped
     (Untyped (ElemRepr (ListReprFor ('Ptr ('Just ('List a))))) mut)
toElement = forall (r :: Maybe PtrRepr) (mut :: Mutability).
IsPtrRepr r =>
Unwrapped (Untyped ('Ptr r) mut) -> Maybe (Ptr mut)
toPtr @('Just ('List a))
  {-# INLINE fromElement #-}
  {-# INLINE toElement #-}

-------------------------------------------------------------------------------
-- 'IsPtrRepr' instances
-------------------------------------------------------------------------------

instance IsPtrRepr 'Nothing where
  toPtr :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr 'Nothing) mut) -> Maybe (Ptr mut)
toPtr Unwrapped (Untyped ('Ptr 'Nothing) mut)
p = Unwrapped (Untyped ('Ptr 'Nothing) mut)
p
  fromPtr :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Maybe (Ptr mut) -> m (Unwrapped (Untyped ('Ptr 'Nothing) mut))
fromPtr Message mut
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE toPtr #-}
  {-# INLINE fromPtr #-}

instance IsPtrRepr ('Just 'Struct) where
  toPtr :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr ('Just 'Struct)) mut) -> Maybe (Ptr mut)
toPtr Unwrapped (Untyped ('Ptr ('Just 'Struct)) mut)
s = forall a. a -> Maybe a
Just (forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct Unwrapped (Untyped ('Ptr ('Just 'Struct)) mut)
s)
  fromPtr :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Maybe (Ptr mut)
-> m (Unwrapped (Untyped ('Ptr ('Just 'Struct)) mut))
fromPtr Message mut
msg Maybe (Ptr mut)
Nothing = forall (f :: Mutability -> *) (m :: * -> *) (mut :: Mutability).
(MessageDefault f, ReadCtx m mut) =>
Message mut -> m (Unwrapped (f mut))
messageDefault @Struct Message mut
msg
  fromPtr Message mut
_ (Just (PtrStruct Struct mut
s)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct mut
s
  fromPtr Message mut
_ Maybe (Ptr mut)
_ = forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to struct"
  {-# INLINE toPtr #-}
  {-# INLINE fromPtr #-}

instance IsPtrRepr ('Just 'Cap) where
  toPtr :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr ('Just 'Cap)) mut) -> Maybe (Ptr mut)
toPtr Unwrapped (Untyped ('Ptr ('Just 'Cap)) mut)
c = forall a. a -> Maybe a
Just (forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap Unwrapped (Untyped ('Ptr ('Just 'Cap)) mut)
c)
  fromPtr :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Maybe (Ptr mut)
-> m (Unwrapped (Untyped ('Ptr ('Just 'Cap)) mut))
fromPtr Message mut
_ Maybe (Ptr mut)
Nothing = forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to capability"
  fromPtr Message mut
_ (Just (PtrCap Cap mut
c)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Cap mut
c
  fromPtr Message mut
_ Maybe (Ptr mut)
_ = forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to capability"
  {-# INLINE toPtr #-}
  {-# INLINE fromPtr #-}

instance IsPtrRepr ('Just ('List 'Nothing)) where
  toPtr :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr ('Just ('List 'Nothing))) mut)
-> Maybe (Ptr mut)
toPtr Unwrapped (Untyped ('Ptr ('Just ('List 'Nothing))) mut)
l = forall a. a -> Maybe a
Just (forall (mut :: Mutability). List mut -> Ptr mut
PtrList Unwrapped (Untyped ('Ptr ('Just ('List 'Nothing))) mut)
l)
  fromPtr :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Maybe (Ptr mut)
-> m (Unwrapped (Untyped ('Ptr ('Just ('List 'Nothing))) mut))
fromPtr Message mut
_ Maybe (Ptr mut)
Nothing = forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to list"
  fromPtr Message mut
_ (Just (PtrList List mut
l)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure List mut
l
  fromPtr Message mut
_ (Just Ptr mut
_) = forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to list"
  {-# INLINE toPtr #-}
  {-# INLINE fromPtr #-}

instance IsListPtrRepr r => IsPtrRepr ('Just ('List ('Just r))) where
  toPtr :: forall (mut :: Mutability).
Unwrapped (Untyped ('Ptr ('Just ('List ('Just r)))) mut)
-> Maybe (Ptr mut)
toPtr Unwrapped (Untyped ('Ptr ('Just ('List ('Just r)))) mut)
l = forall a. a -> Maybe a
Just (forall (mut :: Mutability). List mut -> Ptr mut
PtrList (forall (r :: ListRepr) (mut :: Mutability).
IsListPtrRepr r =>
UntypedSomeList r mut -> List mut
rToList @r Unwrapped (Untyped ('Ptr ('Just ('List ('Just r)))) mut)
l))
  fromPtr :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut
-> Maybe (Ptr mut)
-> m (Unwrapped (Untyped ('Ptr ('Just ('List ('Just r)))) mut))
fromPtr Message mut
msg Maybe (Ptr mut)
Nothing = forall (r :: ListRepr) (m :: * -> *) (mut :: Mutability).
(IsListPtrRepr r, ReadCtx m mut) =>
Message mut -> m (UntypedSomeList r mut)
rFromListMsg @r Message mut
msg
  fromPtr Message mut
_ (Just (PtrList List mut
l)) = forall (r :: ListRepr) (m :: * -> *) (mut :: Mutability).
(IsListPtrRepr r, ReadCtx m mut) =>
List mut -> m (UntypedSomeList r mut)
rFromList @r List mut
l
  fromPtr Message mut
_ (Just Ptr mut
_) = forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to list"
  {-# INLINE toPtr #-}
  {-# INLINE fromPtr #-}

-- | 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 :: forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(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 :: Int
segIndex :: WordAddr -> Int
segIndex}} = do
    Message mutB
msg' <- Message mutA -> m (Message mutB)
f Message mutA
pMessage
    Segment mutB
seg' <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mutB
msg' Int
segIndex
    pure
      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 :: forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB)) -> Ptr mutA -> m (Ptr mutB)
tMsg Message mutA -> m (Message mutB)
f = \case
    PtrCap Cap mutA
cap ->
      forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ->
      forall (mut :: Mutability). List mut -> Ptr mut
PtrList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ->
      forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB)) -> Cap mutA -> m (Cap mutB)
tMsg Message mutA -> m (Message mutB)
f (CapAt Message mutA
msg Word32
n) = forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
CapAt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mutA -> m (Message mutB)
f Message mutA
msg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
n

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

instance TraverseMsg List where
  tMsg :: forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB)) -> List mutA -> m (List mutB)
tMsg Message mutA -> m (Message mutB)
f = \case
    List0 ListOf ('Data 'Sz0) mutA
l -> forall (mut :: Mutability). ListOf ('Data 'Sz0) mut -> List mut
List0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Data 'Sz0) mutA
l
    List1 ListOf ('Data 'Sz1) mutA
l -> forall (mut :: Mutability). ListOf ('Data 'Sz1) mut -> List mut
List1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Data 'Sz1) mutA
l
    List8 ListOf ('Data 'Sz8) mutA
l -> forall (mut :: Mutability). ListOf ('Data 'Sz8) mut -> List mut
List8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Data 'Sz8) mutA
l
    List16 ListOf ('Data 'Sz16) mutA
l -> forall (mut :: Mutability). ListOf ('Data 'Sz16) mut -> List mut
List16 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Data 'Sz16) mutA
l
    List32 ListOf ('Data 'Sz32) mutA
l -> forall (mut :: Mutability). ListOf ('Data 'Sz32) mut -> List mut
List32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Data 'Sz32) mutA
l
    List64 ListOf ('Data 'Sz64) mutA
l -> forall (mut :: Mutability). ListOf ('Data 'Sz64) mut -> List mut
List64 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Data 'Sz64) mutA
l
    ListPtr ListOf ('Ptr 'Nothing) mutA
l -> forall (mut :: Mutability). ListOf ('Ptr 'Nothing) mut -> List mut
ListPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Ptr 'Nothing) mutA
l
    ListStruct ListOf ('Ptr ('Just 'Struct)) mutA
l -> forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> List mut
ListStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ('Ptr ('Just 'Struct)) mutA
l

instance TraverseMsg (ListRepOf r) => TraverseMsg (ListOf r) where
  tMsg :: forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> ListOf r mutA -> m (ListOf r mutB)
tMsg Message mutA -> m (Message mutB)
f (ListOf ListRepOf r mutA
l) = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ListRepOf r mutA
l

instance TraverseMsg NormalList where
  tMsg :: forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(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 <- 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 {nPtr :: WordPtr mutB
nPtr = WordPtr mutB
ptr, Int
nLen :: Int
nLen :: Int
..}

instance TraverseMsg StructList where
  tMsg :: forall (m :: * -> *) (mutA :: Mutability) (mutB :: Mutability).
TraverseMsgCtx m mutA mutB =>
(Message mutA -> m (Message mutB))
-> StructList mutA -> m (StructList mutB)
tMsg Message mutA -> m (Message mutB)
f StructList {Int
Struct mutA
slLen :: Int
slFirst :: Struct mutA
slLen :: forall (mut :: Mutability). StructList mut -> Int
slFirst :: forall (mut :: Mutability). StructList mut -> Struct mut
..} = do
    Struct mutB
s <- 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
slFirst
    pure StructList {slFirst :: Struct mutB
slFirst = Struct mutB
s, Int
slLen :: Int
slLen :: Int
..}

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

-- | Types whose storage is owned by a message..
class HasMessage (f :: Mutability -> Type) where
  -- | Get the message in which the value is stored.
  message :: Unwrapped (f mut) -> 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 f => MessageDefault f where
  messageDefault :: ReadCtx m mut => M.Message mut -> m (Unwrapped (f mut))

instance HasMessage M.WordPtr where
  message :: forall (mut :: Mutability). Unwrapped (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 where
  message :: forall (mut :: Mutability). Unwrapped (Ptr mut) -> Message mut
message (PtrCap Cap mut
cap) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @Cap Cap mut
cap
  message (PtrList List mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @List List mut
list
  message (PtrStruct Struct mut
struct) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @Struct Struct mut
struct

instance HasMessage Cap where
  message :: forall (mut :: Mutability). Unwrapped (Cap mut) -> Message mut
message (CapAt Message mut
msg Word32
_) = Message mut
msg

instance HasMessage Struct where
  message :: forall (mut :: Mutability). Unwrapped (Struct mut) -> Message mut
message (StructAt WordPtr mut
ptr Word16
_ Word16
_) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @M.WordPtr WordPtr mut
ptr

instance MessageDefault Struct where
  messageDefault :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Unwrapped (Struct mut))
messageDefault Message mut
msg = do
    Segment mut
pSegment <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
msg Int
0
    pure $ forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
StructAt 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 where
  message :: forall (mut :: Mutability). Unwrapped (List mut) -> Message mut
message (List0 ListOf ('Data 'Sz0) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Data 'Sz0)) ListOf ('Data 'Sz0) mut
list
  message (List1 ListOf ('Data 'Sz1) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Data 'Sz1)) ListOf ('Data 'Sz1) mut
list
  message (List8 ListOf ('Data 'Sz8) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Data 'Sz8)) ListOf ('Data 'Sz8) mut
list
  message (List16 ListOf ('Data 'Sz16) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Data 'Sz16)) ListOf ('Data 'Sz16) mut
list
  message (List32 ListOf ('Data 'Sz32) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Data 'Sz32)) ListOf ('Data 'Sz32) mut
list
  message (List64 ListOf ('Data 'Sz64) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Data 'Sz64)) ListOf ('Data 'Sz64) mut
list
  message (ListPtr ListOf ('Ptr 'Nothing) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Ptr 'Nothing)) ListOf ('Ptr 'Nothing) mut
list
  message (ListStruct ListOf ('Ptr ('Just 'Struct)) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @(ListOf ('Ptr ('Just 'Struct))) ListOf ('Ptr ('Just 'Struct)) mut
list

instance HasMessage (ListOf ('Ptr ('Just 'Struct))) where
  message :: forall (mut :: Mutability).
Unwrapped (ListOf ('Ptr ('Just 'Struct)) mut) -> Message mut
message (ListOf ListRepOf ('Ptr ('Just 'Struct)) mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @StructList ListRepOf ('Ptr ('Just 'Struct)) mut
list

instance MessageDefault (ListOf ('Ptr ('Just 'Struct))) where
  messageDefault :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Unwrapped (ListOf ('Ptr ('Just 'Struct)) mut))
messageDefault Message mut
msg = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Mutability -> *) (m :: * -> *) (mut :: Mutability).
(MessageDefault f, ReadCtx m mut) =>
Message mut -> m (Unwrapped (f mut))
messageDefault @StructList Message mut
msg

instance {-# OVERLAPS #-} ListRepOf r ~ NormalList => HasMessage (ListOf r) where
  message :: forall (mut :: Mutability). Unwrapped (ListOf r mut) -> Message mut
message (ListOf ListRepOf r mut
list) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @NormalList ListRepOf r mut
list

instance {-# OVERLAPS #-} ListRepOf r ~ NormalList => MessageDefault (ListOf r) where
  messageDefault :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Unwrapped (ListOf r mut))
messageDefault Message mut
msg = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Mutability -> *) (m :: * -> *) (mut :: Mutability).
(MessageDefault f, ReadCtx m mut) =>
Message mut -> m (Unwrapped (f mut))
messageDefault @NormalList Message mut
msg

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

instance MessageDefault NormalList where
  messageDefault :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Unwrapped (NormalList mut))
messageDefault Message mut
msg = do
    Segment mut
pSegment <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
msg Int
0
    pure
      NormalList
        { nPtr :: WordPtr mut
nPtr = 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
        }

instance HasMessage StructList where
  message :: forall (mut :: Mutability).
Unwrapped (StructList mut) -> Message mut
message (StructList Struct mut
s Int
_) = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
message @Struct Struct mut
s

instance MessageDefault StructList where
  messageDefault :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Unwrapped (StructList mut))
messageDefault Message mut
msg =
    forall (mut :: Mutability). Struct mut -> Int -> StructList mut
StructList
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Mutability -> *) (m :: * -> *) (mut :: Mutability).
(MessageDefault f, ReadCtx m mut) =>
Message mut -> m (Unwrapped (f mut))
messageDefault @Struct Message mut
msg
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0

-- | Extract a client (indepedent of the messsage) from the capability.
getClient :: ReadCtx m mut => Cap mut -> m M.Client
{-# INLINEABLE getClient #-}
getClient :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
getClient (CapAt Message mut
msg Word32
idx) = forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m Client
M.getCap Message mut
msg (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))
{-# INLINEABLE get #-}
{-# SPECIALIZE get :: M.WordPtr ('Mut RealWorld) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-}
{-# SPECIALIZE get :: M.WordPtr ('Mut s) -> PureBuilder s (Maybe (Ptr ('Mut s))) #-}
get :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> m (Maybe (Ptr mut))
get WordPtr mut
ptr = do
  Word64
word <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
M.getWord WordPtr mut
ptr
  case Word64 -> Maybe Ptr
P.parsePtr Word64
word of
    Just (P.FarPtr Bool
twoWords Word32
offset Word32
segment) -> forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> Bool -> Word32 -> Word32 -> m (Maybe (Ptr mut))
getFar WordPtr mut
ptr Bool
twoWords Word32
offset Word32
segment
    Maybe Ptr
v -> forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> Maybe Ptr -> m (Maybe (Ptr mut))
getNear WordPtr mut
ptr Maybe Ptr
v

getFar :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> Bool -> Word32 -> Word32 -> m (Maybe (Ptr mut))
getFar :: forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> Bool -> Word32 -> Word32 -> m (Maybe (Ptr mut))
getFar M.WordPtr {Message mut
pMessage :: Message mut
pMessage :: forall (mut :: Mutability). WordPtr mut -> Message mut
pMessage} Bool
twoWords Word32
offset Word32
segment = do
  Segment mut
landingSegment <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
pMessage (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
segment)
  let addr' :: WordAddr
addr' =
        WordAt
          { wordIndex :: WordCount
wordIndex = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
offset,
            segIndex :: Int
segIndex = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
segment
          }
  let landingPtr :: WordPtr mut
landingPtr =
        M.WordPtr
          { Message mut
pMessage :: Message mut
pMessage :: Message mut
pMessage,
            pSegment :: Segment mut
pSegment = Segment mut
landingSegment,
            pAddr :: WordAddr
pAddr = WordAddr
addr'
          }
  Word64
landingPad <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
M.getWord WordPtr mut
landingPtr
  if Bool -> Bool
not Bool
twoWords
    then forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> Maybe Ptr -> m (Maybe (Ptr mut))
getNear WordPtr mut
landingPtr (Word64 -> Maybe Ptr
P.parsePtr Word64
landingPad)
    else do
      case Word64 -> Maybe Ptr
P.parsePtr Word64
landingPad of
        Just (P.FarPtr Bool
False Word32
off Word32
seg) -> do
          let segIndex :: Int
segIndex = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
seg
          Segment mut
finalSegment <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
pMessage Int
segIndex
          Word64
tagWord <-
            forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
M.getWord
              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' forall a. Num a => a -> a -> a
+ WordCount
1}
                }
          let finalPtr :: WordPtr mut
finalPtr =
                M.WordPtr
                  { Message mut
pMessage :: Message mut
pMessage :: Message mut
pMessage,
                    pSegment :: Segment mut
pSegment = Segment mut
finalSegment,
                    pAddr :: WordAddr
pAddr =
                      WordAt
                        { wordIndex :: WordCount
wordIndex = 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) ->
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                  forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct forall a b. (a -> b) -> a -> b
$
                    forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
StructAt WordPtr mut
finalPtr Word16
dataSz Word16
ptrSz
            Just (P.ListPtr Int32
0 EltSpec
eltSpec) ->
              forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). List mut -> Ptr mut
PtrList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> EltSpec -> m (List 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) ->
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap (forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
CapAt Message mut
pMessage Word32
cap)
            Maybe Ptr
ptr ->
              forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
                String -> Error
E.InvalidDataError forall a b. (a -> b) -> a -> b
$
                  String
"The tag word of a far pointer's "
                    forall a. [a] -> [a] -> [a]
++ String
"2-word landing pad should be an intra "
                    forall a. [a] -> [a] -> [a]
++ String
"segment pointer with offset 0, but "
                    forall a. [a] -> [a] -> [a]
++ String
"we read "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe Ptr
ptr
        Maybe Ptr
ptr ->
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
            String -> Error
E.InvalidDataError forall a b. (a -> b) -> a -> b
$
              String
"The first word of a far pointer's 2-word "
                forall a. [a] -> [a] -> [a]
++ String
"landing pad should be another far pointer "
                forall a. [a] -> [a] -> [a]
++ String
"(with a one-word landing pad), but we read "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe Ptr
ptr

getNear :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> Maybe P.Ptr -> m (Maybe (Ptr mut))
getNear :: forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> Maybe Ptr -> m (Maybe (Ptr mut))
getNear 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} = \case
  Maybe Ptr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  Just Ptr
p -> case Ptr
p of
    P.CapPtr Word32
cap -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap (forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
CapAt Message mut
pMessage Word32
cap)
    P.StructPtr Int32
off Word16
dataSz Word16
ptrSz ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct forall a b. (a -> b) -> a -> b
$
            forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
StructAt WordPtr mut
ptr {pAddr :: WordAddr
M.pAddr = WordAddr -> Int32 -> WordAddr
resolveOffset WordAddr
pAddr Int32
off} Word16
dataSz Word16
ptrSz
    P.ListPtr Int32
off EltSpec
eltSpec ->
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). List mut -> Ptr mut
PtrList
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> EltSpec -> m (List mut)
getList WordPtr mut
ptr {pAddr :: WordAddr
M.pAddr = WordAddr -> Int32 -> WordAddr
resolveOffset WordAddr
pAddr Int32
off} EltSpec
eltSpec
    P.FarPtr {} ->
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
        String -> Error
E.InvalidDataError
          String
"Unexpected far pointer where only near pointers were expected."

getList :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> P.EltSpec -> m (List mut)
getList :: forall (mut :: Mutability) (m :: * -> *).
(MonadReadMessage mut m, MonadThrow m) =>
WordPtr mut -> EltSpec -> m (List 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 =
  case EltSpec
eltSpec of
    P.EltNormal ElementSize
sz Word32
len -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case ElementSize
sz of
      ElementSize
P.Sz0 -> forall (mut :: Mutability). ListOf ('Data 'Sz0) mut -> List mut
List0 (forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList mut
nlist)
      ElementSize
P.Sz1 -> forall (mut :: Mutability). ListOf ('Data 'Sz1) mut -> List mut
List1 (forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList mut
nlist)
      ElementSize
P.Sz8 -> forall (mut :: Mutability). ListOf ('Data 'Sz8) mut -> List mut
List8 (forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList mut
nlist)
      ElementSize
P.Sz16 -> forall (mut :: Mutability). ListOf ('Data 'Sz16) mut -> List mut
List16 (forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList mut
nlist)
      ElementSize
P.Sz32 -> forall (mut :: Mutability). ListOf ('Data 'Sz32) mut -> List mut
List32 (forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList mut
nlist)
      ElementSize
P.Sz64 -> forall (mut :: Mutability). ListOf ('Data 'Sz64) mut -> List mut
List64 (forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList mut
nlist)
      ElementSize
P.SzPtr -> forall (mut :: Mutability). ListOf ('Ptr 'Nothing) mut -> List mut
ListPtr (forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf NormalList mut
nlist)
      where
        nlist :: NormalList mut
nlist = forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList WordPtr mut
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)
    P.EltComposite Int32
_ -> do
      Word64
tagWord <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
WordPtr mut -> m Word64
M.getWord WordPtr mut
ptr
      case Word64 -> Ptr
P.parsePtr' Word64
tagWord of
        P.StructPtr Int32
numElts Word16
dataSz Word16
ptrSz ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> List mut
ListStruct forall a b. (a -> b) -> a -> b
$
              forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall a b. (a -> b) -> a -> b
$
                forall (mut :: Mutability). Struct mut -> Int -> StructList mut
StructList
                  ( forall (mut :: Mutability).
WordPtr mut -> Word16 -> Word16 -> Struct mut
StructAt
                      WordPtr mut
ptr {pAddr :: WordAddr
M.pAddr = WordAddr
addr {wordIndex :: WordCount
wordIndex = WordCount
wordIndex forall a. Num a => a -> a -> a
+ WordCount
1}}
                      Word16
dataSz
                      Word16
ptrSz
                  )
                  (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
numElts)
        Ptr
tag ->
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
            String -> Error
E.InvalidDataError forall a b. (a -> b) -> a -> b
$
              String
"Composite list tag was not a struct-"
                forall a. [a] -> [a] -> [a]
++ String
"formatted word: "
                forall a. [a] -> [a] -> [a]
++ 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 :: forall (msg :: Mutability). List msg -> EltSpec
listEltSpec (ListStruct list :: ListOf ('Ptr ('Just 'Struct)) msg
list@(ListOf (StructList (StructAt WordPtr msg
_ Word16
dataSz Word16
ptrSz) Int
_))) =
  Int32 -> EltSpec
P.EltComposite forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Ptr ('Just 'Struct)) msg
list) forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ptrSz)
listEltSpec (List0 ListOf ('Data 'Sz0) msg
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
P.Sz0 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz0) msg
list)
listEltSpec (List1 ListOf ('Data 'Sz1) msg
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
P.Sz1 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz1) msg
list)
listEltSpec (List8 ListOf ('Data 'Sz8) msg
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
P.Sz8 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz8) msg
list)
listEltSpec (List16 ListOf ('Data 'Sz16) msg
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
P.Sz16 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz16) msg
list)
listEltSpec (List32 ListOf ('Data 'Sz32) msg
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
P.Sz32 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz32) msg
list)
listEltSpec (List64 ListOf ('Data 'Sz64) msg
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
P.Sz64 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz64) msg
list)
listEltSpec (ListPtr ListOf ('Ptr 'Nothing) msg
list) = ElementSize -> Word32 -> EltSpec
P.EltNormal ElementSize
P.SzPtr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Ptr 'Nothing) msg
list)

-- | Return the starting address of the list.
listAddr :: List msg -> WordAddr
listAddr :: forall (msg :: Mutability). List msg -> WordAddr
listAddr (ListStruct (ListOf (StructList (StructAt 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 forall a. Num a => a -> a -> a
- WordCount
1}
listAddr (List0 (ListOf 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 (ListOf 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 (ListOf 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 (ListOf 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 (ListOf 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 (ListOf 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 (ListOf 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 :: forall (msg :: Mutability). Ptr msg -> WordAddr
ptrAddr (PtrCap Cap msg
_) = forall a. HasCallStack => String -> a
error String
"ptrAddr called on a capability pointer."
ptrAddr (PtrStruct (StructAt M.WordPtr {WordAddr
pAddr :: WordAddr
pAddr :: forall (mut :: Mutability). WordPtr mut -> WordAddr
pAddr} Word16
_ Word16
_)) = WordAddr
pAddr
ptrAddr (PtrList List msg
list) = 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, ListItem r) =>
  Unwrapped (Untyped r ('Mut s)) ->
  Int ->
  ListOf r ('Mut s) ->
  m ()
{-# INLINE setIndex #-}
{-# SPECIALIZE setIndex ::
  ListItem r =>
  Unwrapped (Untyped r ('Mut RealWorld)) ->
  Int ->
  ListOf r ('Mut RealWorld) ->
  LimitT IO ()
  #-}
{-# SPECIALIZE setIndex ::
  ListItem r =>
  Unwrapped (Untyped r ('Mut s)) ->
  Int ->
  ListOf r ('Mut s) ->
  PureBuilder s ()
  #-}
setIndex :: forall (m :: * -> *) s (r :: Repr).
(RWCtx m s, ListItem r) =>
Unwrapped (Untyped r ('Mut s)) -> Int -> ListOf r ('Mut s) -> m ()
setIndex Unwrapped (Untyped r ('Mut s))
_ Int
i ListOf r ('Mut s)
list
  | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r ('Mut s)
list forall a. Ord a => a -> a -> Bool
<= Int
i =
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM E.BoundsError {index :: Int
E.index = Int
i, maxIndex :: Int
E.maxIndex = forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r ('Mut s)
list}
setIndex Unwrapped (Untyped r ('Mut s))
value Int
i ListOf r ('Mut s)
list = forall (r :: Repr) (m :: * -> *) s a.
(ListItem r, RWCtx m s, a ~ Unwrapped (Untyped r ('Mut s))) =>
a -> Int -> ListOf r ('Mut s) -> m ()
unsafeSetIndex Unwrapped (Untyped r ('Mut s))
value Int
i ListOf r ('Mut s)
list

-- | @'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 ()
{-# INLINEABLE setPointerTo #-}
{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut RealWorld) -> WordAddr -> P.Ptr -> LimitT IO () #-}
{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut s) -> WordAddr -> P.Ptr -> PureBuilder s () #-}
setPointerTo :: forall (m :: * -> *) s.
WriteCtx m s =>
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.
        forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex forall a b. (a -> b) -> a -> b
$
          Maybe Ptr -> Word64
P.serializePtr forall a b. (a -> b) -> a -> b
$
            forall a. a -> Maybe a
Just 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 ->
          forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex forall a b. (a -> b) -> a -> b
$ Maybe Ptr -> Word64
P.serializePtr forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Ptr
absPtr
        Left OffsetError
OutOfRange ->
          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
          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 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
                  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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Ptr
landingPad)
                  forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex forall a b. (a -> b) -> a -> b
$
                    Maybe Ptr -> Word64
P.serializePtr forall a b. (a -> b) -> a -> b
$
                      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                        Bool -> Word32 -> Word32 -> Ptr
P.FarPtr Bool
False (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
wordIndex) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
segIndex)
                Left OffsetError
DifferentSegments ->
                  forall a. HasCallStack => String -> a
error String
"BUG: allocated a landing pad in the wrong segment!"
                Left OffsetError
OutOfRange ->
                  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
                      }
                } <-
                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:
              forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
srcSegment WordCount
srcWordIndex forall a b. (a -> b) -> a -> b
$
                Maybe Ptr -> Word64
P.serializePtr forall a b. (a -> b) -> a -> b
$
                  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    Bool -> Word32 -> Word32 -> Ptr
P.FarPtr
                      Bool
True
                      (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
landingPadOffset)
                      (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:
              forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
landingPadSegment WordCount
landingPadOffset 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 forall a b. (a -> b) -> a -> b
$
                      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                        Bool -> Word32 -> Word32 -> Ptr
P.FarPtr
                          Bool
False
                          (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
wordIndex)
                          (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:
              forall (m :: * -> *) s.
WriteCtx m s =>
Segment ('Mut s) -> WordCount -> Word64 -> m ()
M.write Segment ('Mut s)
landingPadSegment (WordCount
landingPadOffset forall a. Num a => a -> a -> a
+ WordCount
1) forall a b. (a -> b) -> a -> b
$
                Maybe Ptr -> Word64
P.serializePtr forall a b. (a -> b) -> a -> b
$
                  forall a. a -> Maybe a
Just 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))
{-# INLINEABLE copyCap #-}
copyCap :: 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 = forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
getClient Cap ('Mut s)
cap forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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)))
{-# INLINEABLE copyPtr #-}
{-# SPECIALIZE copyPtr :: M.Message ('Mut RealWorld) -> Maybe (Ptr ('Mut RealWorld)) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-}
{-# SPECIALIZE copyPtr :: M.Message ('Mut s) -> Maybe (Ptr ('Mut s)) -> PureBuilder s (Maybe (Ptr ('Mut s))) #-}
copyPtr :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
copyPtr Message ('Mut s)
_ Maybe (Ptr ('Mut s))
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
copyPtr Message ('Mut s)
dest (Just (PtrCap Cap ('Mut s)
cap)) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). Cap mut -> Ptr mut
PtrCap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). List mut -> Ptr mut
PtrList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)) =
  forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). Struct mut -> Ptr mut
PtrStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Struct ('Mut s)
destStruct <-
      forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
allocStruct
        Message ('Mut s)
dest
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Struct mut -> WordCount
structWordCount Struct ('Mut s)
src)
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Struct mut -> Word16
structPtrCount Struct ('Mut s)
src)
    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))
{-# INLINEABLE copyList #-}
{-# SPECIALIZE copyList :: M.Message ('Mut RealWorld) -> List ('Mut RealWorld) -> LimitT IO (List ('Mut RealWorld)) #-}
{-# SPECIALIZE copyList :: M.Message ('Mut s) -> List ('Mut s) -> PureBuilder s (List ('Mut s)) #-}
copyList :: 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 = case List ('Mut s)
src of
  List0 ListOf ('Data 'Sz0) ('Mut s)
src -> forall (mut :: Mutability). ListOf ('Data 'Sz0) mut -> List mut
List0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz0) ('Mut s))
allocList0 Message ('Mut s)
dest (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz0) ('Mut s)
src)
  List1 ListOf ('Data 'Sz1) ('Mut s)
src -> forall (mut :: Mutability). ListOf ('Data 'Sz1) mut -> List mut
List1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
Message ('Mut s)
-> ListOf r ('Mut s)
-> (Message ('Mut s) -> Int -> m (ListOf r ('Mut s)))
-> m (ListOf r ('Mut s))
copyNewListOf Message ('Mut s)
dest ListOf ('Data 'Sz1) ('Mut s)
src forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz1) ('Mut s))
allocList1
  List8 ListOf ('Data 'Sz8) ('Mut s)
src -> forall (mut :: Mutability). ListOf ('Data 'Sz8) mut -> List mut
List8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
Message ('Mut s)
-> ListOf r ('Mut s)
-> (Message ('Mut s) -> Int -> m (ListOf r ('Mut s)))
-> m (ListOf r ('Mut s))
copyNewListOf Message ('Mut s)
dest ListOf ('Data 'Sz8) ('Mut s)
src forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz8) ('Mut s))
allocList8
  List16 ListOf ('Data 'Sz16) ('Mut s)
src -> forall (mut :: Mutability). ListOf ('Data 'Sz16) mut -> List mut
List16 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
Message ('Mut s)
-> ListOf r ('Mut s)
-> (Message ('Mut s) -> Int -> m (ListOf r ('Mut s)))
-> m (ListOf r ('Mut s))
copyNewListOf Message ('Mut s)
dest ListOf ('Data 'Sz16) ('Mut s)
src forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz16) ('Mut s))
allocList16
  List32 ListOf ('Data 'Sz32) ('Mut s)
src -> forall (mut :: Mutability). ListOf ('Data 'Sz32) mut -> List mut
List32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
Message ('Mut s)
-> ListOf r ('Mut s)
-> (Message ('Mut s) -> Int -> m (ListOf r ('Mut s)))
-> m (ListOf r ('Mut s))
copyNewListOf Message ('Mut s)
dest ListOf ('Data 'Sz32) ('Mut s)
src forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz32) ('Mut s))
allocList32
  List64 ListOf ('Data 'Sz64) ('Mut s)
src -> forall (mut :: Mutability). ListOf ('Data 'Sz64) mut -> List mut
List64 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
Message ('Mut s)
-> ListOf r ('Mut s)
-> (Message ('Mut s) -> Int -> m (ListOf r ('Mut s)))
-> m (ListOf r ('Mut s))
copyNewListOf Message ('Mut s)
dest ListOf ('Data 'Sz64) ('Mut s)
src forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz64) ('Mut s))
allocList64
  ListPtr ListOf ('Ptr 'Nothing) ('Mut s)
src -> forall (mut :: Mutability). ListOf ('Ptr 'Nothing) mut -> List mut
ListPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
Message ('Mut s)
-> ListOf r ('Mut s)
-> (Message ('Mut s) -> Int -> m (ListOf r ('Mut s)))
-> m (ListOf r ('Mut s))
copyNewListOf Message ('Mut s)
dest ListOf ('Ptr 'Nothing) ('Mut s)
src forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Ptr 'Nothing) ('Mut s))
allocListPtr
  ListStruct ListOf ('Ptr ('Just 'Struct)) ('Mut s)
src ->
    forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> List mut
ListStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      ListOf ('Ptr ('Just 'Struct)) ('Mut s)
destList <-
        forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Word16
-> Word16
-> Int
-> m (ListOf ('Ptr ('Just 'Struct)) ('Mut s))
allocCompositeList
          Message ('Mut s)
dest
          (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> WordCount
structListWordCount ListOf ('Ptr ('Just 'Struct)) ('Mut s)
src)
          (forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> Word16
structListPtrCount ListOf ('Ptr ('Just 'Struct)) ('Mut s)
src)
          (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Ptr ('Just 'Struct)) ('Mut s)
src)
      forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
ListOf r ('Mut s) -> ListOf r ('Mut s) -> m ()
copyListOf ListOf ('Ptr ('Just 'Struct)) ('Mut s)
destList ListOf ('Ptr ('Just 'Struct)) ('Mut s)
src
      pure ListOf ('Ptr ('Just 'Struct)) ('Mut s)
destList

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

-- | @copyDataList dest src bits@ copies n elements of @src@ to @dest@, where n
-- is the length of the smaller list. @bits@ is the number of bits per element
-- in the two lists.
--
-- This should only used for non-pointer types, as it does not do a deep copy and
-- just copies the raw bytes.
--
-- Warning: if you get the @bits@ argument wrong, you may trample over data outside
-- the intended bounds.
copyDataList :: RWCtx m s => NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m ()
copyDataList :: forall (m :: * -> *) s.
RWCtx m s =>
NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m ()
copyDataList NormalList ('Mut s)
dest NormalList ('Mut s)
src BitCount
bits = do
  let unpack :: NormalList mut -> (Int, WordCount, Segment mut)
unpack NormalList {Int
nLen :: Int
nLen :: forall (mut :: Mutability). NormalList mut -> Int
nLen, nPtr :: forall (mut :: Mutability). NormalList mut -> WordPtr mut
nPtr = 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
nLen, WordCount
wordIndex, Segment mut
pSegment)

      (Int
srcLen, WordCount
srcOff, Segment ('Mut s)
srcSeg) = forall {mut :: Mutability}.
NormalList mut -> (Int, WordCount, Segment mut)
unpack NormalList ('Mut s)
src
      (Int
destLen, WordCount
destOff, Segment ('Mut s)
destSeg) = forall {mut :: Mutability}.
NormalList mut -> (Int, WordCount, Segment mut)
unpack NormalList ('Mut s)
dest

      len :: Int
len = forall a. Ord a => a -> a -> a
min Int
destLen Int
srcLen
      lenWords :: WordCount
lenWords =
        forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len forall a. Num a => a -> a -> a
* BitCount
bits
          forall a b. a -> (a -> b) -> b
& BitCount -> ByteCount
bitsToBytesCeil
          forall a b. a -> (a -> b) -> b
& ByteCount -> WordCount
bytesToWordsCeil

      sliceVec :: WordCount -> MVector s Word64 -> MVector s Word64
sliceVec WordCount
off =
        forall a s. Storable a => Int -> Int -> MVector s a -> MVector s a
SMV.slice (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
off) (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
lenWords)
  MVector s Word64
srcVec <- forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Segment ('Mut s) -> m (MVector s Word64)
M.segToVecMut Segment ('Mut s)
srcSeg
  MVector s Word64
destVec <- forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Segment ('Mut s) -> m (MVector s Word64)
M.segToVecMut Segment ('Mut s)
destSeg
  forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> MVector (PrimState m) a -> m ()
SMV.copy
    (WordCount -> MVector s Word64 -> MVector s Word64
sliceVec WordCount
destOff MVector s Word64
destVec)
    (WordCount -> MVector s Word64 -> MVector s Word64
sliceVec WordCount
srcOff MVector s Word64
srcVec)

-- | @'copyStruct' dest src@ copies the source struct to the destination struct.
copyStruct :: RWCtx m s => Struct ('Mut s) -> Struct ('Mut s) -> m ()
{-# INLINEABLE copyStruct #-}
{-# SPECIALIZE copyStruct :: Struct ('Mut RealWorld) -> Struct ('Mut RealWorld) -> LimitT IO () #-}
{-# SPECIALIZE copyStruct :: Struct ('Mut s) -> Struct ('Mut s) -> PureBuilder s () #-}
copyStruct :: forall (m :: * -> *) s.
RWCtx m s =>
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).
  forall {r :: Repr} {m :: * -> *}.
(ListItem r, PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> Unwrapped (Untyped r ('Mut (PrimState m)))
-> m ()
copySection (forall (mut :: Mutability). Struct mut -> ListOf ('Data 'Sz64) mut
dataSection Struct ('Mut s)
dest) (forall (mut :: Mutability). Struct mut -> ListOf ('Data 'Sz64) mut
dataSection Struct ('Mut s)
src) Word64
0
  forall {r :: Repr} {m :: * -> *}.
(ListItem r, PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> Unwrapped (Untyped r ('Mut (PrimState m)))
-> m ()
copySection (forall (mut :: Mutability).
Struct mut -> ListOf ('Ptr 'Nothing) mut
ptrSection Struct ('Mut s)
dest) (forall (mut :: Mutability).
Struct mut -> ListOf ('Ptr 'Nothing) mut
ptrSection Struct ('Mut s)
src) forall a. Maybe a
Nothing
  where
    copySection :: ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> Unwrapped (Untyped r ('Mut (PrimState m)))
-> m ()
copySection ListOf r ('Mut (PrimState m))
dest ListOf r ('Mut (PrimState m))
src Unwrapped (Untyped r ('Mut (PrimState m)))
pad = do
      -- Copy the source section to the destination section:
      forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
ListOf r ('Mut s) -> ListOf r ('Mut s) -> m ()
copyListOf ListOf r ('Mut (PrimState m))
dest ListOf r ('Mut (PrimState m))
src
      -- Pad the remainder with zeros/default values:
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r ('Mut (PrimState m))
src .. forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r ('Mut (PrimState m))
dest forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i ->
        forall (m :: * -> *) s (r :: Repr).
(RWCtx m s, ListItem r) =>
Unwrapped (Untyped r ('Mut s)) -> Int -> ListOf r ('Mut s) -> m ()
setIndex Unwrapped (Untyped r ('Mut (PrimState m)))
pad Int
i ListOf r ('Mut (PrimState m))
dest

-- | @index i list@ returns the ith element in @list@. Deducts 1 from the quota
index :: (ReadCtx m mut, ListItem r) => Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
{-# INLINE index #-}
{-# SPECIALIZE index :: ListItem r => Int -> ListOf r 'Const -> LimitT IO (Unwrapped (Untyped r 'Const)) #-}
{-# SPECIALIZE index :: ListItem r => Int -> ListOf r ('Mut RealWorld) -> LimitT IO (Unwrapped (Untyped r ('Mut RealWorld))) #-}
{-# SPECIALIZE index :: ListItem r => Int -> ListOf r 'Const -> PureBuilder s (Unwrapped (Untyped r 'Const)) #-}
{-# SPECIALIZE index :: ListItem r => Int -> ListOf r ('Mut s) -> PureBuilder s (Unwrapped (Untyped r ('Mut s))) #-}
index :: forall (m :: * -> *) (mut :: Mutability) (r :: Repr).
(ReadCtx m mut, ListItem r) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
index Int
i ListOf r mut
list
  | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
>= forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r mut
list =
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM E.BoundsError {index :: Int
E.index = Int
i, maxIndex :: Int
E.maxIndex = forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r mut
list forall a. Num a => a -> a -> a
- Int
1}
  | Bool
otherwise = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
unsafeIndex Int
i ListOf r mut
list

-- | Return a prefix of the list, of the given length.
{-# INLINEABLE take #-}
take :: (ListItem r, MonadThrow m) => Int -> ListOf r mut -> m (ListOf r mut)
take :: forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, MonadThrow m) =>
Int -> ListOf r mut -> m (ListOf r mut)
take Int
count ListOf r mut
list
  | forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r mut
list forall a. Ord a => a -> a -> Bool
< Int
count =
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM E.BoundsError {index :: Int
E.index = Int
count, maxIndex :: Int
E.maxIndex = forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf r mut
list forall a. Num a => a -> a -> a
- Int
1}
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (r :: Repr) (mut :: Mutability).
ListItem r =>
Int -> ListOf r mut -> ListOf r mut
unsafeTake Int
count ListOf r mut
list

-- | The data section of a struct, as a list of Word64
dataSection :: Struct mut -> ListOf ('Data 'Sz64) mut
{-# INLINE dataSection #-}
dataSection :: forall (mut :: Mutability). Struct mut -> ListOf ('Data 'Sz64) mut
dataSection (StructAt WordPtr mut
ptr Word16
dataSz Word16
_) =
  forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). WordPtr mut -> Int -> NormalList mut
NormalList WordPtr mut
ptr (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 mut -> ListOf ('Ptr 'Nothing) mut
{-# INLINE ptrSection #-}
ptrSection :: forall (mut :: Mutability).
Struct mut -> ListOf ('Ptr 'Nothing) mut
ptrSection (StructAt 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}} Word16
dataSz Word16
ptrSz) =
  forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall a b. (a -> b) -> a -> b
$
    NormalList
      { nPtr :: WordPtr mut
nPtr = WordPtr mut
ptr {pAddr :: WordAddr
M.pAddr = WordAddr
addr {wordIndex :: WordCount
wordIndex = WordCount
wordIndex forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz}},
        nLen :: Int
nLen = 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 mut -> WordCount
structWordCount :: forall (mut :: Mutability). Struct mut -> WordCount
structWordCount (StructAt WordPtr mut
_ptr Word16
dataSz Word16
_ptrSz) = 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 mut -> ByteCount
structByteCount :: forall (mut :: Mutability). Struct mut -> ByteCount
structByteCount = WordCount -> ByteCount
wordsToBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). Struct mut -> WordCount
structWordCount

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

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

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

-- | Get the size of the pointer sections in a struct list.
structListPtrCount :: ListOf ('Ptr ('Just 'Struct)) mut -> Word16
structListPtrCount :: forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> Word16
structListPtrCount (ListOf (StructList Struct mut
s Int
_)) = forall (mut :: Mutability). Struct mut -> Word16
structPtrCount Struct mut
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 :: forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m Word64
getData Int
i Struct msg
struct
  | forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (mut :: Mutability). Struct mut -> WordCount
structWordCount Struct msg
struct) forall a. Ord a => a -> a -> Bool
<= Int
i = forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
0
  | Bool
otherwise = forall (m :: * -> *) (mut :: Mutability) (r :: Repr).
(ReadCtx m mut, ListItem r) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
index Int
i (forall (mut :: Mutability). Struct mut -> ListOf ('Data 'Sz64) mut
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 :: forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m (Maybe (Ptr msg))
getPtr Int
i Struct msg
struct
  | forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (mut :: Mutability). Struct mut -> Word16
structPtrCount Struct msg
struct) forall a. Ord a => a -> a -> Bool
<= Int
i = do
      forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice WordCount
1
      pure forall a. Maybe a
Nothing
  | Bool
otherwise = do
      Maybe (Ptr msg)
ptr <- forall (m :: * -> *) (mut :: Mutability) (r :: Repr).
(ReadCtx m mut, ListItem r) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
index Int
i (forall (mut :: Mutability).
Struct mut -> ListOf ('Ptr 'Nothing) mut
ptrSection Struct msg
struct)
      forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Maybe (Ptr mut) -> m ()
checkPtr Maybe (Ptr msg)
ptr
      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 ()
{-# INLINEABLE checkPtr #-}
checkPtr :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Maybe (Ptr mut) -> m ()
checkPtr Maybe (Ptr mut)
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkPtr (Just (PtrCap Cap mut
c)) = forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m ()
checkCap Cap mut
c
checkPtr (Just (PtrList List mut
l)) = forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
List mut -> m ()
checkList List mut
l
checkPtr (Just (PtrStruct Struct mut
s)) = forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Struct mut -> m ()
checkStruct Struct mut
s

checkCap :: ReadCtx m mut => Cap mut -> m ()
{-# INLINEABLE checkCap #-}
checkCap :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m ()
checkCap (CapAt Message mut
_ Word32
_) = 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 ()
{-# INLINEABLE checkList #-}
checkList :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
List mut -> m ()
checkList (List0 ListOf ('Data 'Sz0) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Data 'Sz0) ListOf ('Data 'Sz0) mut
l
checkList (List1 ListOf ('Data 'Sz1) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Data 'Sz1) ListOf ('Data 'Sz1) mut
l
checkList (List8 ListOf ('Data 'Sz8) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Data 'Sz8) ListOf ('Data 'Sz8) mut
l
checkList (List16 ListOf ('Data 'Sz16) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Data 'Sz16) ListOf ('Data 'Sz16) mut
l
checkList (List32 ListOf ('Data 'Sz32) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Data 'Sz32) ListOf ('Data 'Sz32) mut
l
checkList (List64 ListOf ('Data 'Sz64) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Data 'Sz64) ListOf ('Data 'Sz64) mut
l
checkList (ListPtr ListOf ('Ptr 'Nothing) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Ptr 'Nothing) ListOf ('Ptr 'Nothing) mut
l
checkList (ListStruct ListOf ('Ptr ('Just 'Struct)) mut
l) = forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(ListItem r, ReadCtx m mut) =>
ListOf r mut -> m ()
checkListOf @('Ptr ('Just 'Struct)) ListOf ('Ptr ('Just 'Struct)) mut
l

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

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

checkPtrOffset :: ReadCtx m mut => M.WordPtr mut -> WordCount -> m ()
{-# INLINEABLE checkPtrOffset #-}
checkPtrOffset :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
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 <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
M.numWords Segment mut
pSegment
  let maxIndex :: Int
maxIndex = forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
segWords forall a. Num a => a -> a -> a
- Int
1
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WordCount
wordIndex forall a. Ord a => a -> a -> Bool
>= WordCount
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM E.BoundsError {index :: Int
index = forall a b. (Integral a, Num b) => a -> b
fromIntegral WordCount
wordIndex, Int
maxIndex :: Int
maxIndex :: Int
maxIndex}
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WordCount
wordIndex forall a. Num a => a -> a -> a
+ WordCount
size forall a. Ord a => a -> a -> Bool
<= WordCount
segWords) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
      E.BoundsError
        { index :: Int
index = forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordCount
wordIndex forall a. Num a => a -> a -> a
+ WordCount
size) forall a. Num a => a -> a -> a
- Int
1,
          Int
maxIndex :: Int
maxIndex :: Int
maxIndex
        }

structSize :: Struct mut -> WordCount
structSize :: forall (mut :: Mutability). Struct mut -> WordCount
structSize Struct mut
s = forall (mut :: Mutability). Struct mut -> WordCount
structWordCount Struct mut
s forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (mut :: Mutability). Struct mut -> 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 ()
{-# INLINEABLE invoicePtr #-}
{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut RealWorld)) -> LimitT IO () #-}
{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut s)) -> PureBuilder s () #-}
invoicePtr :: forall (m :: * -> *) (mut :: Mutability).
MonadLimit m =>
Maybe (Ptr mut) -> m ()
invoicePtr Maybe (Ptr mut)
p = forall (m :: * -> *). MonadLimit m => WordCount -> m ()
invoice forall a b. (a -> b) -> a -> b
$! forall (mut :: Mutability). Maybe (Ptr mut) -> WordCount
ptrInvoiceSize Maybe (Ptr mut)
p

ptrInvoiceSize :: Maybe (Ptr mut) -> WordCount
{-# INLINEABLE ptrInvoiceSize #-}
ptrInvoiceSize :: forall (mut :: Mutability). Maybe (Ptr mut) -> WordCount
ptrInvoiceSize = \case
  Maybe (Ptr mut)
Nothing -> WordCount
1
  Just (PtrCap Cap mut
_) -> WordCount
1
  Just (PtrStruct Struct mut
s) -> forall (mut :: Mutability). Struct mut -> WordCount
structInvoiceSize Struct mut
s
  Just (PtrList List mut
l) -> forall (mut :: Mutability). List mut -> WordCount
listInvoiceSize List mut
l

listInvoiceSize :: List mut -> WordCount
{-# INLINEABLE listInvoiceSize #-}
listInvoiceSize :: forall (mut :: Mutability). List mut -> WordCount
listInvoiceSize List mut
l =
  forall a. Ord a => a -> a -> a
max WordCount
1 forall a b. (a -> b) -> a -> b
$! case List mut
l of
    List0 ListOf ('Data 'Sz0) mut
l -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$! forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz0) mut
l
    List1 ListOf ('Data 'Sz1) mut
l -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$! forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz1) mut
l forall a. Integral a => a -> a -> a
`div` Int
64
    List8 ListOf ('Data 'Sz8) mut
l -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$! forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz8) mut
l forall a. Integral a => a -> a -> a
`div` Int
8
    List16 ListOf ('Data 'Sz16) mut
l -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$! forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz16) mut
l forall a. Integral a => a -> a -> a
`div` Int
4
    List32 ListOf ('Data 'Sz32) mut
l -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$! forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz32) mut
l forall a. Integral a => a -> a -> a
`div` Int
2
    List64 ListOf ('Data 'Sz64) mut
l -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$! forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Data 'Sz64) mut
l
    ListPtr ListOf ('Ptr 'Nothing) mut
l -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$! forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
length ListOf ('Ptr 'Nothing) mut
l
    ListStruct (ListOf (StructList Struct mut
s Int
len)) ->
      forall (mut :: Mutability). Struct mut -> WordCount
structInvoiceSize Struct mut
s forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len

structInvoiceSize :: Struct mut -> WordCount
{-# INLINEABLE structInvoiceSize #-}
structInvoiceSize :: forall (mut :: Mutability). Struct mut -> WordCount
structInvoiceSize (StructAt WordPtr mut
_ Word16
dataSz Word16
ptrSz) =
  forall a. Ord a => a -> a -> a
max WordCount
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
dataSz forall a. Num a => a -> a -> a
+ 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 :: forall (m :: * -> *) s.
(ReadCtx m ('Mut s), WriteCtx m s) =>
Word64 -> Int -> Struct ('Mut s) -> m ()
setData Word64
value Int
i = forall (m :: * -> *) s (r :: Repr).
(RWCtx m s, ListItem r) =>
Unwrapped (Untyped r ('Mut s)) -> Int -> ListOf r ('Mut s) -> m ()
setIndex Word64
value Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). Struct mut -> ListOf ('Data 'Sz64) mut
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 :: forall (m :: * -> *) s.
(ReadCtx m ('Mut s), WriteCtx m s) =>
Maybe (Ptr ('Mut s)) -> Int -> Struct ('Mut s) -> m ()
setPtr Maybe (Ptr ('Mut s))
value Int
i = forall (m :: * -> *) s (r :: Repr).
(RWCtx m s, ListItem r) =>
Unwrapped (Untyped r ('Mut s)) -> Int -> ListOf r ('Mut s) -> m ()
setIndex Maybe (Ptr ('Mut s))
value Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability).
Struct mut -> ListOf ('Ptr 'Nothing) mut
ptrSection

-- | 'rawBytes' returns the raw bytes corresponding to the list.
rawBytes :: ReadCtx m 'Const => ListOf ('Data 'Sz8) 'Const -> m BS.ByteString
{-# INLINEABLE rawBytes #-}
-- TODO: we can get away with a more lax context than ReadCtx, maybe even make
-- this non-monadic.
rawBytes :: forall (m :: * -> *).
ReadCtx m 'Const =>
ListOf ('Data 'Sz8) 'Const -> m ByteString
rawBytes (ListOf (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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
len 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)
{-# INLINEABLE rootPtr #-}
rootPtr :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Struct mut)
rootPtr Message mut
msg = do
  Segment mut
seg <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
msg Int
0
  Maybe (Ptr mut)
root <-
    forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
WordPtr mut -> m (Maybe (Ptr mut))
get
      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
        }
  forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Maybe (Ptr mut) -> m ()
checkPtr Maybe (Ptr mut)
root
  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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct mut
struct
    Maybe (Ptr mut)
Nothing -> forall (f :: Mutability -> *) (m :: * -> *) (mut :: Mutability).
(MessageDefault f, ReadCtx m mut) =>
Message mut -> m (Unwrapped (f mut))
messageDefault @Struct Message mut
msg
    Maybe (Ptr mut)
_ ->
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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 ()
{-# INLINEABLE setRoot #-}
setRoot :: forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
setRoot (StructAt 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 <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message ('Mut s)
pMessage Int
0
  let rootPtr :: WordPtr ('Mut s)
rootPtr = 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}
  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)

-- | An instace of @'Allocate'@ specifies how to allocate a value with a given representation.
-- This only makes sense for pointers of course, so it is defined on PtrRepr. Of the well-kinded
-- types, only @'List 'Nothing@ is missing an instance.
class Allocate (r :: PtrRepr) where
  -- | Extra information needed to allocate a value:
  --
  -- * For structs, the sizes of the sections.
  -- * For capabilities, the client to attach to the messages.
  -- * For lists, the length, and for composite lists, the struct sizes as well.
  type AllocHint r

  -- | Allocate a value of the given type.
  alloc :: RWCtx m s => M.Message ('Mut s) -> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s)))

instance Allocate 'Struct where
  type AllocHint 'Struct = (Word16, Word16)
  alloc :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> AllocHint 'Struct
-> m (Unwrapped (UntypedSomePtr 'Struct ('Mut s)))
alloc Message ('Mut s)
msg = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
allocStruct Message ('Mut s)
msg)

instance Allocate 'Cap where
  type AllocHint 'Cap = M.Client
  alloc :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> AllocHint 'Cap -> m (Unwrapped (UntypedSomePtr 'Cap ('Mut s)))
alloc = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m (Cap ('Mut s))
appendCap

instance Allocate ('List ('Just 'ListComposite)) where
  type AllocHint ('List ('Just 'ListComposite)) = (Int, AllocHint 'Struct)
  alloc :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> AllocHint ('List ('Just 'ListComposite))
-> m (Unwrapped
        (UntypedSomePtr ('List ('Just 'ListComposite)) ('Mut s)))
alloc Message ('Mut s)
msg (Int
len, (Word16
nWords, Word16
nPtrs)) = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Word16
-> Word16
-> Int
-> m (ListOf ('Ptr ('Just 'Struct)) ('Mut s))
allocCompositeList Message ('Mut s)
msg Word16
nWords Word16
nPtrs Int
len

instance AllocateNormalList r => Allocate ('List ('Just ('ListNormal r))) where
  type AllocHint ('List ('Just ('ListNormal r))) = Int
  alloc :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> AllocHint ('List ('Just ('ListNormal r)))
-> m (Unwrapped
        (UntypedSomePtr ('List ('Just ('ListNormal r))) ('Mut s)))
alloc = forall (r :: NormalListRepr) (m :: * -> *) s.
(AllocateNormalList r, RWCtx m s) =>
Message ('Mut s)
-> Int -> m (UntypedSomeList ('ListNormal r) ('Mut s))
allocNormalList @r

-- | Like 'Allocate', but specialized to normal (non-composite) lists.
--
-- Instead of an 'AllocHint' type family, the hint is always an 'Int',
-- which is the number of elements.
class AllocateNormalList (r :: NormalListRepr) where
  allocNormalList ::
    RWCtx m s =>
    M.Message ('Mut s) ->
    Int ->
    m (UntypedSomeList ('ListNormal r) ('Mut s))

instance AllocateNormalList ('NormalListData 'Sz0) where allocNormalList :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Int
-> m (UntypedSomeList
        ('ListNormal ('NormalListData 'Sz0)) ('Mut s))
allocNormalList = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz0) ('Mut s))
allocList0

instance AllocateNormalList ('NormalListData 'Sz1) where allocNormalList :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Int
-> m (UntypedSomeList
        ('ListNormal ('NormalListData 'Sz1)) ('Mut s))
allocNormalList = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz1) ('Mut s))
allocList1

instance AllocateNormalList ('NormalListData 'Sz8) where allocNormalList :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Int
-> m (UntypedSomeList
        ('ListNormal ('NormalListData 'Sz8)) ('Mut s))
allocNormalList = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz8) ('Mut s))
allocList8

instance AllocateNormalList ('NormalListData 'Sz16) where allocNormalList :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Int
-> m (UntypedSomeList
        ('ListNormal ('NormalListData 'Sz16)) ('Mut s))
allocNormalList = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz16) ('Mut s))
allocList16

instance AllocateNormalList ('NormalListData 'Sz32) where allocNormalList :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Int
-> m (UntypedSomeList
        ('ListNormal ('NormalListData 'Sz32)) ('Mut s))
allocNormalList = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz32) ('Mut s))
allocList32

instance AllocateNormalList ('NormalListData 'Sz64) where allocNormalList :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Int
-> m (UntypedSomeList
        ('ListNormal ('NormalListData 'Sz64)) ('Mut s))
allocNormalList = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz64) ('Mut s))
allocList64

instance AllocateNormalList 'NormalListPtr where allocNormalList :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s)
-> Int -> m (UntypedSomeList ('ListNormal 'NormalListPtr) ('Mut s))
allocNormalList = forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Ptr 'Nothing) ('Mut s))
allocListPtr

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

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

-- | Allocate a list of booleans
allocList1 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz1) ('Mut s))
{-# INLINEABLE allocList1 #-}

-- | Allocate a list of 8-bit values.
allocList8 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz8) ('Mut s))
{-# INLINEABLE allocList8 #-}

-- | Allocate a list of 16-bit values.
allocList16 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz16) ('Mut s))
{-# INLINEABLE allocList16 #-}

-- | Allocate a list of 32-bit values.
allocList32 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz32) ('Mut s))
{-# INLINEABLE allocList32 #-}

-- | Allocate a list of 64-bit words.
allocList64 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz64) ('Mut s))
{-# INLINEABLE allocList64 #-}

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

allocList0 :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz0) ('Mut s))
allocList0 Message ('Mut s)
msg Int
len = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz1) ('Mut s))
allocList1 Message ('Mut s)
msg Int
len = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz8) ('Mut s))
allocList8 Message ('Mut s)
msg Int
len = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz16) ('Mut s))
allocList16 Message ('Mut s)
msg Int
len = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz32) ('Mut s))
allocList32 Message ('Mut s)
msg Int
len = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz64) ('Mut s))
allocList64 Message ('Mut s)
msg Int
len = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Ptr 'Nothing) ('Mut s))
allocListPtr Message ('Mut s)
msg Int
len = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =>
  -- | The number bits per element
  Int ->
  -- | The message to allocate in
  M.Message ('Mut s) ->
  -- | The number of elements in the list.
  Int ->
  m (NormalList ('Mut s))
{-# INLINEABLE allocNormalList' #-}
allocNormalList' :: forall (m :: * -> *) s.
WriteCtx m s =>
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 forall a. Num a => a -> a -> a
* Int
bitsPerElt)
      totalWords :: WordCount
totalWords = ByteCount -> WordCount
bytesToWordsCeil forall a b. (a -> b) -> a -> b
$ BitCount -> ByteCount
bitsToBytesCeil BitCount
totalBits
  WordPtr ('Mut s)
ptr <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s))
M.alloc Message ('Mut s)
msg WordCount
totalWords
  pure 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))
{-# INLINEABLE appendCap #-}
appendCap :: forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m (Cap ('Mut s))
appendCap Message ('Mut s)
msg Client
client = do
  Int
i <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m Int
M.appendCap Message ('Mut s)
msg Client
client
  pure $ forall (mut :: Mutability). Message mut -> Word32 -> Cap mut
CapAt Message ('Mut s)
msg (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

instance MaybeMutable (ListRepOf r) => MaybeMutable (ListOf r) where
  thaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
ListOf r 'Const -> m (ListOf r ('Mut s))
thaw (ListOf ListRepOf r 'Const
l) = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
thaw ListRepOf r 'Const
l
  freeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
ListOf r ('Mut s) -> m (ListOf r 'Const)
freeze (ListOf ListRepOf r ('Mut s)
l) = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f ('Mut s) -> m (f 'Const)
freeze ListRepOf r ('Mut s)
l
  unsafeThaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
ListOf r 'Const -> m (ListOf r ('Mut s))
unsafeThaw (ListOf ListRepOf r 'Const
l) = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
unsafeThaw ListRepOf r 'Const
l
  unsafeFreeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
ListOf r ('Mut s) -> m (ListOf r 'Const)
unsafeFreeze (ListOf ListRepOf r ('Mut s)
l) = forall (r :: Repr) (mut :: Mutability).
ListRepOf r mut -> ListOf r mut
ListOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f ('Mut s) -> m (f 'Const)
unsafeFreeze ListRepOf r ('Mut s)
l

-------------------------------------------------------------------------------
-- Helpers generated MaybeMutable instances
-------------------------------------------------------------------------------

-- trivial wrapaper around CatchT, so we can add a PrimMonad instance.
newtype CatchTWrap m a = CatchTWrap {forall (m :: * -> *) a. CatchTWrap m a -> CatchT m a
runCatchTWrap :: CatchT m a}
  deriving (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
<$ :: forall a b. a -> CatchTWrap m b -> CatchTWrap m a
$c<$ :: forall (m :: * -> *) a b.
Monad m =>
a -> CatchTWrap m b -> CatchTWrap m a
fmap :: forall a b. (a -> b) -> CatchTWrap m a -> CatchTWrap m b
$cfmap :: forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> CatchTWrap m a -> CatchTWrap m b
Functor, 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
<* :: forall a b. 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
*> :: forall a b. 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 :: forall a b c.
(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
<*> :: forall a b.
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 :: forall a. a -> CatchTWrap m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> CatchTWrap m a
Applicative, 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 :: forall a. a -> CatchTWrap m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> CatchTWrap m a
>> :: forall a b. 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
>>= :: forall a 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
Monad, 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 :: forall (m :: * -> *) a. Monad m => m a -> CatchTWrap m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> CatchTWrap m a
MonadTrans, 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 :: forall e a. Exception e => e -> CatchTWrap m a
$cthrowM :: forall (m :: * -> *) e a.
(Monad m, Exception e) =>
e -> CatchTWrap m a
MonadThrow, 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 :: forall e a.
Exception e =>
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
MonadCatch)

instance PrimMonad m => PrimMonad (CatchTWrap m) where
  type PrimState (CatchTWrap m) = PrimState m
  primitive :: forall a.
(State# (PrimState (CatchTWrap m))
 -> (# State# (PrimState (CatchTWrap m)), a #))
-> CatchTWrap m a
primitive = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
{-# INLINEABLE runCatchImpure #-}
runCatchImpure :: forall (m :: * -> *) a. Monad m => CatchTWrap m a -> m a
runCatchImpure CatchTWrap m a
m = do
  Either SomeException a
res <- forall (m :: * -> *) a. CatchT m a -> m (Either SomeException a)
runCatchT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. CatchTWrap m a -> CatchT m a
runCatchTWrap CatchTWrap m a
m
  pure $ case Either SomeException a
res of
    Left SomeException
e -> forall e a. Exception e => e -> a
impureThrow SomeException
e
    Right a
v -> a
v

-------------------------------------------------------------------------------
-- Generated MaybeMutable instances
-------------------------------------------------------------------------------

do
  let mkWrappedInstance name =
        let f = pure $ TH.ConT name
         in [d|
              instance MaybeMutable $f where
                thaw = runCatchImpure . tMsg thaw
                freeze = runCatchImpure . tMsg freeze
                unsafeThaw = runCatchImpure . tMsg unsafeThaw
                unsafeFreeze = runCatchImpure . tMsg unsafeFreeze
              |]
  concat
    <$> traverse
      mkWrappedInstance
      [ ''Ptr,
        ''List,
        ''Cap,
        ''Struct,
        ''NormalList,
        ''StructList
      ]

do
  let mkIsListPtrRepr (r, listC, str) =
        [d|
          instance IsListPtrRepr $r where
            rToList = $(pure $ TH.ConE listC)
            rFromList $(pure $ TH.ConP listC [] [TH.VarP (TH.mkName "l")]) = pure l
            rFromList _ = expected $(pure $ TH.LitE $ TH.StringL $ "pointer to " ++ str)
            rFromListMsg = messageDefault @(Untyped ('Ptr ('Just ('List ('Just $r)))))
          |]
  concat
    <$> traverse
      mkIsListPtrRepr
      [ ( [t|'ListNormal ('NormalListData 'Sz0)|],
          'List0,
          "List(Void)"
        ),
        ( [t|'ListNormal ('NormalListData 'Sz1)|],
          'List1,
          "List(Bool)"
        ),
        ( [t|'ListNormal ('NormalListData 'Sz8)|],
          'List8,
          "List(UInt8)"
        ),
        ( [t|'ListNormal ('NormalListData 'Sz16)|],
          'List16,
          "List(UInt16)"
        ),
        ( [t|'ListNormal ('NormalListData 'Sz32)|],
          'List32,
          "List(UInt32)"
        ),
        ( [t|'ListNormal ('NormalListData 'Sz64)|],
          'List64,
          "List(UInt64)"
        ),
        ( [t|'ListNormal 'NormalListPtr|],
          'ListPtr,
          "List(AnyPointer)"
        ),
        ( [t|'ListComposite|],
          'ListStruct,
          "composite list"
        )
      ]

instance MaybeMutable (IgnoreMut a) where
  thaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
IgnoreMut a 'Const -> m (IgnoreMut a ('Mut s))
thaw = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce
  freeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
IgnoreMut a ('Mut s) -> m (IgnoreMut a 'Const)
freeze = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce

instance MaybeMutable MaybePtr where
  thaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
MaybePtr 'Const -> m (MaybePtr ('Mut s))
thaw (MaybePtr Maybe (Ptr 'Const)
p) = forall (mut :: Mutability). Maybe (Ptr mut) -> MaybePtr mut
MaybePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
thaw Maybe (Ptr 'Const)
p
  freeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
MaybePtr ('Mut s) -> m (MaybePtr 'Const)
freeze (MaybePtr Maybe (Ptr ('Mut s))
p) = forall (mut :: Mutability). Maybe (Ptr mut) -> MaybePtr mut
MaybePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f ('Mut s) -> m (f 'Const)
freeze Maybe (Ptr ('Mut s))
p
  unsafeThaw :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
MaybePtr 'Const -> m (MaybePtr ('Mut s))
unsafeThaw (MaybePtr Maybe (Ptr 'Const)
p) = forall (mut :: Mutability). Maybe (Ptr mut) -> MaybePtr mut
MaybePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
unsafeThaw Maybe (Ptr 'Const)
p
  unsafeFreeze :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
MaybePtr ('Mut s) -> m (MaybePtr 'Const)
unsafeFreeze (MaybePtr Maybe (Ptr ('Mut s))
p) = forall (mut :: Mutability). Maybe (Ptr mut) -> MaybePtr mut
MaybePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f ('Mut s) -> m (f 'Const)
unsafeFreeze Maybe (Ptr ('Mut s))
p