{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Capnproto message canonicalization, per:
--
-- https://capnproto.org/encoding.html#canonicalization
module Capnp.Canonicalize
  ( canonicalize,
    canonicalizeMut,
  )
where

-- Note [Allocation strategy]
--
-- The implementation makes use of knowledge of how we allocate values inside
-- a message; in particular, we assume objects are allocated sequentially,
-- and that if the first segment is big enough we will never allocate a second
-- segment.
--
-- If we ever make the allocator plugable, we will have to revisit this and
-- ensure that our assumptions still hold.

-- Note [Other assumptions]
--
-- This code relies on the fact that Capnp.Pointer.serializePointer does the
-- canonicalization of zero-sized struct pointers for us; see the comments there
-- for more details.

-- import qualified Language.Haskell.TH as TH

import Capnp.Bits (WordCount)
import qualified Capnp.Message as M
import Capnp.Mutability (Mutability (..), unsafeThaw)
import Capnp.TraversalLimit (LimitT)
import qualified Capnp.Untyped as U
import Control.Monad.ST (RealWorld)
import Data.Foldable (for_)
import Data.Maybe (isNothing)
import Data.Traversable (for)
import Data.Word
import Internal.BuildPure (PureBuilder)

-- | Return a canonicalized message with a copy of the given struct as its
-- root. returns a (message, segment) pair, where the segment is the first
-- and only segment of the returned message.
--
-- In addition to the usual reasons for failure when reading a message (traversal limit,
-- malformed messages), this can fail if the message does not fit in a single segment,
-- as the canonical form requires single-segment messages.
canonicalize :: U.RWCtx m s => U.Struct 'Const -> m (M.Message ('Mut s), M.Segment ('Mut s))
canonicalize :: forall (m :: * -> *) s.
RWCtx m s =>
Struct 'Const -> m (Message ('Mut s), Segment ('Mut s))
canonicalize Struct 'Const
s = forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
unsafeThaw Struct 'Const
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> m (Message ('Mut s), Segment ('Mut s))
canonicalizeMut
{-# SPECIALIZE canonicalize :: U.Struct 'Const -> LimitT IO (M.Message ('Mut RealWorld), M.Segment ('Mut RealWorld)) #-}
{-# SPECIALIZE canonicalize :: U.Struct 'Const -> PureBuilder s (M.Message ('Mut s), M.Segment ('Mut s)) #-}

canonicalizeMut :: U.RWCtx m s => U.Struct ('Mut s) -> m (M.Message ('Mut s), M.Segment ('Mut s))
canonicalizeMut :: forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> m (Message ('Mut s), Segment ('Mut s))
canonicalizeMut Struct ('Mut s)
rootStructIn = do
  let msgIn :: Message ('Mut s)
msgIn = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
U.message @U.Struct Struct ('Mut s)
rootStructIn
  -- Note [Allocation strategy]
  WordCount
words <- forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m WordCount
totalWords Message ('Mut s)
msgIn
  Message ('Mut s)
msgOut <- forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
M.newMessage forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just WordCount
words
  Struct ('Mut s)
rootStructOut <- forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Message ('Mut s) -> m (Struct ('Mut s))
cloneCanonicalStruct Struct ('Mut s)
rootStructIn Message ('Mut s)
msgOut
  forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
U.setRoot Struct ('Mut s)
rootStructOut
  Segment ('Mut s)
segOut <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message ('Mut s)
msgOut Int
0
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message ('Mut s)
msgOut, Segment ('Mut s)
segOut)
{-# SPECIALIZE canonicalizeMut :: U.Struct ('Mut RealWorld) -> LimitT IO (M.Message ('Mut RealWorld), M.Segment ('Mut RealWorld)) #-}
{-# SPECIALIZE canonicalizeMut :: U.Struct ('Mut s) -> PureBuilder s (M.Message ('Mut s), M.Segment ('Mut s)) #-}

totalWords :: U.ReadCtx m mut => M.Message mut -> m WordCount
totalWords :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m WordCount
totalWords Message mut
msg = do
  -- Note [Allocation strategy]
  Int
segCount <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
M.numSegs Message mut
msg
  [WordCount]
sizes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Int
0 .. Int
segCount forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Segment mut
seg <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
msg Int
i
    forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
M.numWords Segment mut
seg
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [WordCount]
sizes

cloneCanonicalStruct :: U.RWCtx m s => U.Struct ('Mut s) -> M.Message ('Mut s) -> m (U.Struct ('Mut s))
{-# SPECIALIZE cloneCanonicalStruct :: U.Struct ('Mut RealWorld) -> M.Message ('Mut RealWorld) -> LimitT IO (U.Struct ('Mut RealWorld)) #-}
{-# SPECIALIZE cloneCanonicalStruct :: U.Struct ('Mut s) -> M.Message ('Mut s) -> PureBuilder s (U.Struct ('Mut s)) #-}
cloneCanonicalStruct :: forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Message ('Mut s) -> m (Struct ('Mut s))
cloneCanonicalStruct Struct ('Mut s)
structIn Message ('Mut s)
msgOut = do
  (Word16
nWords, Word16
nPtrs) <- forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Struct mut -> m (Word16, Word16)
findCanonicalSectionCounts Struct ('Mut s)
structIn
  Struct ('Mut s)
structOut <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
U.allocStruct Message ('Mut s)
msgOut (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
nWords) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
nPtrs)
  forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Struct ('Mut s) -> m ()
copyCanonicalStruct Struct ('Mut s)
structIn Struct ('Mut s)
structOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct ('Mut s)
structOut

copyCanonicalStruct :: U.RWCtx m s => U.Struct ('Mut s) -> U.Struct ('Mut s) -> m ()
{-# SPECIALIZE copyCanonicalStruct :: U.Struct ('Mut RealWorld) -> U.Struct ('Mut RealWorld) -> LimitT IO () #-}
{-# SPECIALIZE copyCanonicalStruct :: U.Struct ('Mut s) -> U.Struct ('Mut s) -> PureBuilder s () #-}
copyCanonicalStruct :: forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Struct ('Mut s) -> m ()
copyCanonicalStruct Struct ('Mut s)
structIn Struct ('Mut s)
structOut = do
  let nWords :: Int
nWords = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Struct mut -> WordCount
U.structWordCount Struct ('Mut s)
structOut
      nPtrs :: Int
nPtrs = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Struct mut -> Word16
U.structPtrCount Struct ('Mut s)
structOut
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. Int
nWords forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Word64
word <- forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m Word64
U.getData Int
i Struct ('Mut s)
structIn
    forall (m :: * -> *) s.
(ReadCtx m ('Mut s), WriteCtx m s) =>
Word64 -> Int -> Struct ('Mut s) -> m ()
U.setData Word64
word Int
i Struct ('Mut s)
structOut
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. Int
nPtrs forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Maybe (Ptr ('Mut s))
ptrIn <- forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m (Maybe (Ptr msg))
U.getPtr Int
i Struct ('Mut s)
structIn
    Maybe (Ptr ('Mut s))
ptrOut <- forall (m :: * -> *) s.
RWCtx m s =>
Maybe (Ptr ('Mut s))
-> Message ('Mut s) -> m (Maybe (Ptr ('Mut s)))
cloneCanonicalPtr Maybe (Ptr ('Mut s))
ptrIn (forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
U.message @U.Struct Struct ('Mut s)
structOut)
    forall (m :: * -> *) s.
(ReadCtx m ('Mut s), WriteCtx m s) =>
Maybe (Ptr ('Mut s)) -> Int -> Struct ('Mut s) -> m ()
U.setPtr Maybe (Ptr ('Mut s))
ptrOut Int
i Struct ('Mut s)
structOut

findCanonicalSectionCounts :: U.ReadCtx m mut => U.Struct mut -> m (Word16, Word16)
{-# SPECIALIZE findCanonicalSectionCounts :: U.Struct ('Mut RealWorld) -> LimitT IO (Word16, Word16) #-}
{-# SPECIALIZE findCanonicalSectionCounts :: U.Struct ('Mut s) -> PureBuilder s (Word16, Word16) #-}
findCanonicalSectionCounts :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Struct mut -> m (Word16, Word16)
findCanonicalSectionCounts Struct mut
struct = do
  Word16
nWords <- forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (Int -> m a) -> Int -> m Word16
canonicalSectionCount (forall a. Eq a => a -> a -> Bool
== Word64
0) (forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m Word64
`U.getData` Struct mut
struct) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Struct mut -> WordCount
U.structWordCount Struct mut
struct)
  Word16
nPtrs <- forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (Int -> m a) -> Int -> m Word16
canonicalSectionCount forall a. Maybe a -> Bool
isNothing (forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m (Maybe (Ptr msg))
`U.getPtr` Struct mut
struct) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Struct mut -> Word16
U.structPtrCount Struct mut
struct)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16
nWords, Word16
nPtrs)

canonicalSectionCount :: Monad m => (a -> Bool) -> (Int -> m a) -> Int -> m Word16
canonicalSectionCount :: forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (Int -> m a) -> Int -> m Word16
canonicalSectionCount a -> Bool
_ Int -> m a
_ Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
0
canonicalSectionCount a -> Bool
isDefault Int -> m a
getIndex Int
total = do
  a
value <- Int -> m a
getIndex (Int
total forall a. Num a => a -> a -> a
- Int
1)
  if a -> Bool
isDefault a
value
    then forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (Int -> m a) -> Int -> m Word16
canonicalSectionCount a -> Bool
isDefault Int -> m a
getIndex (Int
total forall a. Num a => a -> a -> a
- Int
1)
    else 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 Int
total

cloneCanonicalPtr :: U.RWCtx m s => Maybe (U.Ptr ('Mut s)) -> M.Message ('Mut s) -> m (Maybe (U.Ptr ('Mut s)))
{-# SPECIALIZE cloneCanonicalPtr :: Maybe (U.Ptr ('Mut RealWorld)) -> M.Message ('Mut RealWorld) -> LimitT IO (Maybe (U.Ptr ('Mut RealWorld))) #-}
{-# SPECIALIZE cloneCanonicalPtr :: Maybe (U.Ptr ('Mut s)) -> M.Message ('Mut s) -> PureBuilder s (Maybe (U.Ptr ('Mut s))) #-}
cloneCanonicalPtr :: forall (m :: * -> *) s.
RWCtx m s =>
Maybe (Ptr ('Mut s))
-> Message ('Mut s) -> m (Maybe (Ptr ('Mut s)))
cloneCanonicalPtr Maybe (Ptr ('Mut s))
ptrIn Message ('Mut s)
msgOut =
  case Maybe (Ptr ('Mut s))
ptrIn of
    Maybe (Ptr ('Mut s))
Nothing ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (U.PtrCap Cap ('Mut s)
cap) -> do
      Client
client <- forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
U.getClient 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
U.PtrCap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m (Cap ('Mut s))
U.appendCap Message ('Mut s)
msgOut Client
client
    Just (U.PtrStruct Struct ('Mut s)
struct) ->
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). Struct mut -> Ptr mut
U.PtrStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Message ('Mut s) -> m (Struct ('Mut s))
cloneCanonicalStruct Struct ('Mut s)
struct Message ('Mut s)
msgOut
    Just (U.PtrList List ('Mut s)
list) ->
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mut :: Mutability). List mut -> Ptr mut
U.PtrList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s.
RWCtx m s =>
List ('Mut s) -> Message ('Mut s) -> m (List ('Mut s))
cloneCanonicalList List ('Mut s)
list Message ('Mut s)
msgOut

cloneCanonicalList :: U.RWCtx m s => U.List ('Mut s) -> M.Message ('Mut s) -> m (U.List ('Mut s))
{-# SPECIALIZE cloneCanonicalList :: U.List ('Mut RealWorld) -> M.Message ('Mut RealWorld) -> LimitT IO (U.List ('Mut RealWorld)) #-}
{-# SPECIALIZE cloneCanonicalList :: U.List ('Mut s) -> M.Message ('Mut s) -> PureBuilder s (U.List ('Mut s)) #-}
cloneCanonicalList :: forall (m :: * -> *) s.
RWCtx m s =>
List ('Mut s) -> Message ('Mut s) -> m (List ('Mut s))
cloneCanonicalList List ('Mut s)
listIn Message ('Mut s)
msgOut =
  case List ('Mut s)
listIn of
    U.List0 ListOf ('Data 'Sz0) ('Mut s)
l -> forall (mut :: Mutability). ListOf ('Data 'Sz0) mut -> List mut
U.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))
U.allocList0 Message ('Mut s)
msgOut (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Data 'Sz0) ('Mut s)
l)
    U.List1 ListOf ('Data 'Sz1) ('Mut s)
l -> forall (mut :: Mutability). ListOf ('Data 'Sz1) mut -> List mut
U.List1 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 'Sz1) ('Mut s))
U.allocList1 Message ('Mut s)
msgOut (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Data 'Sz1) ('Mut s)
l) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {r :: Repr} {m :: * -> *}.
(ListItem r, PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> m (ListOf r ('Mut (PrimState m)))
copyCanonicalDataList ListOf ('Data 'Sz1) ('Mut s)
l)
    U.List8 ListOf ('Data 'Sz8) ('Mut s)
l -> forall (mut :: Mutability). ListOf ('Data 'Sz8) mut -> List mut
U.List8 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 'Sz8) ('Mut s))
U.allocList8 Message ('Mut s)
msgOut (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Data 'Sz8) ('Mut s)
l) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {r :: Repr} {m :: * -> *}.
(ListItem r, PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> m (ListOf r ('Mut (PrimState m)))
copyCanonicalDataList ListOf ('Data 'Sz8) ('Mut s)
l)
    U.List16 ListOf ('Data 'Sz16) ('Mut s)
l -> forall (mut :: Mutability). ListOf ('Data 'Sz16) mut -> List mut
U.List16 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 'Sz16) ('Mut s))
U.allocList16 Message ('Mut s)
msgOut (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Data 'Sz16) ('Mut s)
l) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {r :: Repr} {m :: * -> *}.
(ListItem r, PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> m (ListOf r ('Mut (PrimState m)))
copyCanonicalDataList ListOf ('Data 'Sz16) ('Mut s)
l)
    U.List32 ListOf ('Data 'Sz32) ('Mut s)
l -> forall (mut :: Mutability). ListOf ('Data 'Sz32) mut -> List mut
U.List32 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 'Sz32) ('Mut s))
U.allocList32 Message ('Mut s)
msgOut (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Data 'Sz32) ('Mut s)
l) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {r :: Repr} {m :: * -> *}.
(ListItem r, PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> m (ListOf r ('Mut (PrimState m)))
copyCanonicalDataList ListOf ('Data 'Sz32) ('Mut s)
l)
    U.List64 ListOf ('Data 'Sz64) ('Mut s)
l -> forall (mut :: Mutability). ListOf ('Data 'Sz64) mut -> List mut
U.List64 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 'Sz64) ('Mut s))
U.allocList64 Message ('Mut s)
msgOut (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Data 'Sz64) ('Mut s)
l) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {r :: Repr} {m :: * -> *}.
(ListItem r, PrimMonad m, MonadThrow m, MonadLimit m) =>
ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> m (ListOf r ('Mut (PrimState m)))
copyCanonicalDataList ListOf ('Data 'Sz64) ('Mut s)
l)
    U.ListPtr ListOf ('Ptr 'Nothing) ('Mut s)
l -> forall (mut :: Mutability). ListOf ('Ptr 'Nothing) mut -> List mut
U.ListPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Ptr 'Nothing) ('Mut s))
U.allocListPtr Message ('Mut s)
msgOut (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Ptr 'Nothing) ('Mut s)
l) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Ptr 'Nothing) ('Mut s)
-> ListOf ('Ptr 'Nothing) ('Mut s)
-> m (ListOf ('Ptr 'Nothing) ('Mut s))
copyCanonicalPtrList ListOf ('Ptr 'Nothing) ('Mut s)
l)
    U.ListStruct ListOf ('Ptr ('Just 'Struct)) ('Mut s)
l -> forall (mut :: Mutability).
ListOf ('Ptr ('Just 'Struct)) mut -> List mut
U.ListStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Ptr ('Just 'Struct)) ('Mut s)
-> Message ('Mut s) -> m (ListOf ('Ptr ('Just 'Struct)) ('Mut s))
cloneCanonicalStructList ListOf ('Ptr ('Just 'Struct)) ('Mut s)
l Message ('Mut s)
msgOut

copyCanonicalDataList :: ListOf r ('Mut (PrimState m))
-> ListOf r ('Mut (PrimState m))
-> m (ListOf r ('Mut (PrimState m)))
copyCanonicalDataList ListOf r ('Mut (PrimState m))
lin ListOf r ('Mut (PrimState m))
lout = do
  forall (r :: Repr) (m :: * -> *) s.
(ListItem r, RWCtx m s) =>
ListOf r ('Mut s) -> ListOf r ('Mut s) -> m ()
U.copyListOf ListOf r ('Mut (PrimState m))
lout ListOf r ('Mut (PrimState m))
lin
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ListOf r ('Mut (PrimState m))
lout

copyCanonicalPtrList ::
  U.RWCtx m s =>
  U.ListOf ('U.Ptr 'Nothing) ('Mut s) ->
  U.ListOf ('U.Ptr 'Nothing) ('Mut s) ->
  m (U.ListOf ('U.Ptr 'Nothing) ('Mut s))
{-# SPECIALIZE copyCanonicalPtrList ::
  U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld) ->
  U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld) ->
  LimitT IO (U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld))
  #-}
{-# SPECIALIZE copyCanonicalPtrList ::
  U.ListOf ('U.Ptr 'Nothing) ('Mut s) ->
  U.ListOf ('U.Ptr 'Nothing) ('Mut s) ->
  PureBuilder s (U.ListOf ('U.Ptr 'Nothing) ('Mut s))
  #-}
copyCanonicalPtrList :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Ptr 'Nothing) ('Mut s)
-> ListOf ('Ptr 'Nothing) ('Mut s)
-> m (ListOf ('Ptr 'Nothing) ('Mut s))
copyCanonicalPtrList ListOf ('Ptr 'Nothing) ('Mut s)
listIn ListOf ('Ptr 'Nothing) ('Mut s)
listOut = do
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Ptr 'Nothing) ('Mut s)
listIn forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Maybe (Ptr ('Mut s))
ptrIn <- forall (m :: * -> *) (mut :: Mutability) (r :: Repr).
(ReadCtx m mut, ListItem r) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
U.index Int
i ListOf ('Ptr 'Nothing) ('Mut s)
listIn
    Maybe (Ptr ('Mut s))
ptrOut <- forall (m :: * -> *) s.
RWCtx m s =>
Maybe (Ptr ('Mut s))
-> Message ('Mut s) -> m (Maybe (Ptr ('Mut s)))
cloneCanonicalPtr Maybe (Ptr ('Mut s))
ptrIn (forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
U.message @(U.ListOf ('U.Ptr 'Nothing)) ListOf ('Ptr 'Nothing) ('Mut s)
listOut)
    forall (m :: * -> *) s (r :: Repr).
(RWCtx m s, ListItem r) =>
Unwrapped (Untyped r ('Mut s)) -> Int -> ListOf r ('Mut s) -> m ()
U.setIndex Maybe (Ptr ('Mut s))
ptrOut Int
i ListOf ('Ptr 'Nothing) ('Mut s)
listOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ListOf ('Ptr 'Nothing) ('Mut s)
listOut

cloneCanonicalStructList ::
  U.RWCtx m s =>
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) ->
  M.Message ('Mut s) ->
  m (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s))
{-# SPECIALIZE cloneCanonicalStructList ::
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) ->
  M.Message ('Mut RealWorld) ->
  LimitT IO (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld))
  #-}
{-# SPECIALIZE cloneCanonicalStructList ::
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) ->
  M.Message ('Mut s) ->
  PureBuilder s (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s))
  #-}
cloneCanonicalStructList :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Ptr ('Just 'Struct)) ('Mut s)
-> Message ('Mut s) -> m (ListOf ('Ptr ('Just 'Struct)) ('Mut s))
cloneCanonicalStructList ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listIn Message ('Mut s)
msgOut = do
  (Word16
nWords, Word16
nPtrs) <- forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
ListOf ('Ptr ('Just 'Struct)) mut -> m (Word16, Word16)
findCanonicalListSectionCounts ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listIn
  ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listOut <- forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Word16
-> Word16
-> Int
-> m (ListOf ('Ptr ('Just 'Struct)) ('Mut s))
U.allocCompositeList Message ('Mut s)
msgOut Word16
nWords Word16
nPtrs (forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listIn)
  forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Ptr ('Just 'Struct)) ('Mut s)
-> ListOf ('Ptr ('Just 'Struct)) ('Mut s) -> m ()
copyCanonicalStructList ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listIn ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listOut

copyCanonicalStructList ::
  U.RWCtx m s =>
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) ->
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) ->
  m ()
{-# SPECIALIZE copyCanonicalStructList ::
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) ->
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) ->
  LimitT IO ()
  #-}
{-# SPECIALIZE copyCanonicalStructList ::
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) ->
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) ->
  PureBuilder s ()
  #-}
copyCanonicalStructList :: forall (m :: * -> *) s.
RWCtx m s =>
ListOf ('Ptr ('Just 'Struct)) ('Mut s)
-> ListOf ('Ptr ('Just 'Struct)) ('Mut s) -> m ()
copyCanonicalStructList ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listIn ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listOut =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listIn forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Struct ('Mut s)
structIn <- forall (m :: * -> *) (mut :: Mutability) (r :: Repr).
(ReadCtx m mut, ListItem r) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
U.index Int
i ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listIn
    Struct ('Mut s)
structOut <- forall (m :: * -> *) (mut :: Mutability) (r :: Repr).
(ReadCtx m mut, ListItem r) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
U.index Int
i ListOf ('Ptr ('Just 'Struct)) ('Mut s)
listOut
    forall (m :: * -> *) s.
RWCtx m s =>
Struct ('Mut s) -> Struct ('Mut s) -> m ()
copyCanonicalStruct Struct ('Mut s)
structIn Struct ('Mut s)
structOut

findCanonicalListSectionCounts ::
  U.ReadCtx m mut =>
  U.ListOf ('U.Ptr ('Just 'U.Struct)) mut ->
  m (Word16, Word16)
{-# SPECIALIZE findCanonicalListSectionCounts ::
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) -> LimitT IO (Word16, Word16)
  #-}
{-# SPECIALIZE findCanonicalListSectionCounts ::
  U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> PureBuilder s (Word16, Word16)
  #-}
findCanonicalListSectionCounts :: forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
ListOf ('Ptr ('Just 'Struct)) mut -> m (Word16, Word16)
findCanonicalListSectionCounts ListOf ('Ptr ('Just 'Struct)) mut
list = Int -> Word16 -> Word16 -> m (Word16, Word16)
go Int
0 Word16
0 Word16
0
  where
    go :: Int -> Word16 -> Word16 -> m (Word16, Word16)
go Int
i !Word16
nWords !Word16
nPtrs
      | Int
i forall a. Ord a => a -> a -> Bool
>= forall (r :: Repr) (mut :: Mutability).
ListItem r =>
ListOf r mut -> Int
U.length ListOf ('Ptr ('Just 'Struct)) mut
list =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16
nWords, Word16
nPtrs)
      | Bool
otherwise = do
          Struct mut
struct <- forall (m :: * -> *) (mut :: Mutability) (r :: Repr).
(ReadCtx m mut, ListItem r) =>
Int -> ListOf r mut -> m (Unwrapped (Untyped r mut))
U.index Int
i ListOf ('Ptr ('Just 'Struct)) mut
list
          (Word16
nWords', Word16
nPtrs') <- forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Struct mut -> m (Word16, Word16)
findCanonicalSectionCounts Struct mut
struct
          Int -> Word16 -> Word16 -> m (Word16, Word16)
go (Int
i forall a. Num a => a -> a -> a
+ Int
1) (forall a. Ord a => a -> a -> a
max Word16
nWords Word16
nWords') (forall a. Ord a => a -> a -> a
max Word16
nPtrs Word16
nPtrs')

{-
do
    -- Generate specializations for various functions above.
    --
    -- TODO: Figure out why this version doesn't seem to be taking
    -- effect; having the explicit SPECIALIZE pragmas written out
    -- literally results in a 15-20% speedup vs. trying to generate
    -- them with template haskell. But ew.
    --
    -- TODO(cleanup): find some way to group the signature & the specialization together
    -- without duplicating everything.
    let specializations :: [(TH.Name, [TH.TypeQ])]
        specializations =
            [ ( 'copyCanonicalStructList
              , each $ \mutIn mutOut m ->
                    [t| U.ListOf $mutIn (U.Struct $mutIn)
                        -> U.ListOf $mutOut (U.Struct $mutOut) -> $m ()
                    |]
              )
            , ( 'copyCanonicalDataList
              , each $ \mutIn mutOut m -> do
                    a <- pure . TH.VarT <$> TH.newName "a"
                    [t| U.ListOf $mutIn $a -> U.ListOf $mutOut $a -> $m (U.ListOf $mutOut $a) |]
              )
            , ( 'copyCanonicalPtrList
              , each $ \mutIn mutOut m ->
                    [t| U.ListOf $mutIn (Maybe (U.Ptr $mutIn))
                        -> U.ListOf $mutOut (Maybe (U.Ptr $mutOut))
                        -> $m (U.ListOf $mutOut (Maybe (U.Ptr $mutOut)))
                    |]
              )
            , ( 'cloneCanonicalPtr
              , each $ \mutIn mutOut m ->
                    [t| Maybe (U.Ptr $mutIn) -> M.Message $mutOut -> $m (Maybe (U.Ptr $mutOut)) |]
              )
            , ( 'cloneCanonicalList
              , each $ \mutIn mutOut m ->
                    [t| U.List $mutIn -> M.Message $mutOut -> $m (U.List $mutOut) |]
              )
            , ( 'cloneCanonicalStruct
              , each $ \mutIn mutOut m ->
                    [t| U.Struct $mutIn -> M.Message $mutOut -> $m (U.Struct $mutOut) |]
              )
            , ( 'copyCanonicalStruct
              , each $ \mutIn mutOut m ->
                    [t| U.Struct $mutIn -> U.Struct $mutOut -> $m () |]
              )
            ]
        each f = do
            let s = pure $ TH.VarT (TH.mkName "s")
            (m, s) <- [ ( [t| LimitT IO |], [t| RealWorld |] )
                      , ( [t| PureBuilder $s |], s )
                      ]
            mutIn <- [ [t| 'Const |], [t| 'Mut $s |] ]
            pure $ f mutIn [t| 'Mut $s |] m
{-
            map
                (\t -> f t [t| 'Mut RealWorld |] [t| LimitT IO |])
                [ [t| 'Const |], [t| 'Mut RealWorld |] ]
-}
    concat <$> for specializations (\(name, types) -> do
        for types $ \mkType -> do
            t <- mkType
            pure $ TH.PragmaD $ TH.SpecialiseP name t Nothing TH.AllPhases)
-}