{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}
-- | Module: Capnp.New.Classes
-- Description: Misc. type classes
--
-- This module contains several type classes (and related utilities)
-- useful for operating over Cap'n Proto values.
module Capnp.New.Classes
    ( -- * Encoding and decoding parsed forms of values
      Parse(..)
    , Parsed
    , Marshal(..)
    , MarshalElement

    -- * Allocating values in messages
    , Allocate(..)
    , newRoot
    , AllocateList(..)
    , EstimateAlloc(..)
    , EstimateListAlloc(..)
    , newFromRepr

    -- * Working with Cap'n Proto types
    , HasTypeId(..)

    -- ** Typed Structs
    , TypedStruct(..)
    , newTypedStruct
    , newTypedStructList
    , structSizes

    -- ** Inheritance
    , Super

    -- * Values that go in a struct's data section
    , IsWord(..)
    ) where

import           Capnp.Classes        (IsWord(..))
import           Capnp.Message        (Mutability(..))
import qualified Capnp.Message        as M
import qualified Capnp.Repr           as R
import           Capnp.TraversalLimit (evalLimitT)
import qualified Capnp.Untyped        as U
import           Data.Default         (Default(..))
import           Data.Foldable        (for_)
import           Data.Int
import qualified Data.Vector          as V
import           Data.Word
import qualified GHC.Float            as F
import qualified Language.Haskell.TH  as TH

-- | Capnp types that can be parsed into a more "natural" Haskell form.
--
-- * @t@ is the capnproto type.
-- * @p@ is the type of the parsed value.
class Parse t p | t -> p, p -> t where
    parse :: U.ReadCtx m 'Const => R.Raw 'Const t -> m p
    -- ^ Parse a value from a constant message
    encode :: U.RWCtx m s => M.Message ('Mut s) -> p -> m (R.Raw ('Mut s) t)
    -- ^ Encode a value into 'R.Raw' form, using the message as storage.

    default encode
        :: (U.RWCtx m s, EstimateAlloc t p, Marshal t p)
        => M.Message ('Mut s) -> p -> m (R.Raw ('Mut s) t)
    encode Message ('Mut s)
msg p
value = do
        Raw ('Mut s) t
raw <- AllocHint t -> Message ('Mut s) -> m (Raw ('Mut s) t)
forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw ('Mut s) a)
new (p -> AllocHint t
forall t p. EstimateAlloc t p => p -> AllocHint t
estimateAlloc p
value) Message ('Mut s)
msg
        Raw ('Mut s) t -> p -> m ()
forall t p (m :: * -> *) s.
(Marshal t p, RWCtx m s) =>
Raw ('Mut s) t -> p -> m ()
marshalInto Raw ('Mut s) t
raw p
value
        Raw ('Mut s) t -> m (Raw ('Mut s) t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raw ('Mut s) t
raw

-- | Types where the necessary allocation is inferrable from the parsed form.
--
-- ...this is most types.
class (Parse t p, Allocate t) => EstimateAlloc t p where
    -- | Determine the appropriate hint needed to allocate space
    -- for the serialied form of the value.
    estimateAlloc :: p -> AllocHint t

    default estimateAlloc :: AllocHint t ~ () => p -> AllocHint t
    estimateAlloc p
_ = ()

-- | Implementation of 'new' valid for types whose 'AllocHint' is
-- the same as that of their underlying representation.
newFromRepr
    :: forall a r m s.
    ( R.Allocate r
    , 'R.Ptr ('Just r) ~ R.ReprFor a
    , U.RWCtx m s
    )
    => R.AllocHint r -> M.Message ('Mut s) -> m (R.Raw ('Mut s) a)
newFromRepr :: AllocHint r -> Message ('Mut s) -> m (Raw ('Mut s) a)
newFromRepr AllocHint r
hint Message ('Mut s)
msg = UntypedSomePtr ('Mut s) r -> Raw ('Mut s) a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (UntypedSomePtr ('Mut s) r -> Raw ('Mut s) a)
-> m (UntypedSomePtr ('Mut s) r) -> m (Raw ('Mut s) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> AllocHint r -> m (UntypedSomePtr ('Mut s) r)
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, RWCtx m s) =>
Message ('Mut s) -> AllocHint r -> m (UntypedSomePtr ('Mut s) r)
R.alloc @r Message ('Mut s)
msg AllocHint r
hint
    -- TODO(cleanup): new and alloc really ought to have the same argument order...


-- | Types which may be allocated directly inside a message.
class Allocate a where
    type AllocHint a
    -- ^ Extra information needed to allocate a value of this type, e.g. the
    -- length for a list. May be () if no extra info is needed.

    new :: U.RWCtx m s => AllocHint a -> M.Message ('Mut s) -> m (R.Raw ('Mut s) a)
    -- ^ @'new' hint msg@ allocates a new value of type @a@ inside @msg@.

    default new ::
        ( R.ReprFor a ~ 'R.Ptr ('Just pr)
        , R.Allocate pr
        , AllocHint a ~ R.AllocHint pr
        , U.RWCtx m s
        ) => AllocHint a -> M.Message ('Mut s) -> m (R.Raw ('Mut s) a)
    -- If the AllocHint is the same as that of the underlying Repr, then
    -- we can just use that implementation.
    new = forall a (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, 'Ptr ('Just r) ~ ReprFor a, RWCtx m s) =>
AllocHint r -> Message ('Mut s) -> m (Raw ('Mut s) a)
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, 'Ptr ('Just r) ~ ReprFor a, RWCtx m s) =>
AllocHint r -> Message ('Mut s) -> m (Raw ('Mut s) a)
newFromRepr @a

-- | Like 'Allocate', but for allocating *lists* of @a@.
class AllocateList a where
    type ListAllocHint a
    -- ^ Extra information needed to allocate a list of @a@s.

    newList :: U.RWCtx m s => ListAllocHint a -> M.Message ('Mut s) -> m (R.Raw ('Mut s) (R.List a))
    default newList ::
        forall m s lr r.
        ( U.RWCtx m s
        , lr ~ R.ListReprFor (R.ReprFor a)
        , r ~ 'R.List ('Just lr)
        , R.Allocate r
        , R.AllocHint r ~ ListAllocHint a
        ) => ListAllocHint a -> M.Message ('Mut s) -> m (R.Raw ('Mut s) (R.List a))
    newList ListAllocHint a
hint Message ('Mut s)
msg = ListOf ('Mut s) (Untyped ('Mut s) (ElemRepr lr))
-> Raw ('Mut s) (List a)
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (ListOf ('Mut s) (Untyped ('Mut s) (ElemRepr lr))
 -> Raw ('Mut s) (List a))
-> m (ListOf ('Mut s) (Untyped ('Mut s) (ElemRepr lr)))
-> m (Raw ('Mut s) (List a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> AllocHint r -> m (UntypedSomePtr ('Mut s) r)
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, RWCtx m s) =>
Message ('Mut s) -> AllocHint r -> m (UntypedSomePtr ('Mut s) r)
R.alloc @r Message ('Mut s)
msg AllocHint r
ListAllocHint a
hint

instance AllocateList a => Allocate (R.List a) where
    type AllocHint (R.List a) = ListAllocHint a
    new :: AllocHint (List a) -> Message ('Mut s) -> m (Raw ('Mut s) (List a))
new = forall (m :: * -> *) s.
(AllocateList a, RWCtx m s) =>
ListAllocHint a -> Message ('Mut s) -> m (Raw ('Mut s) (List a))
forall a (m :: * -> *) s.
(AllocateList a, RWCtx m s) =>
ListAllocHint a -> Message ('Mut s) -> m (Raw ('Mut s) (List a))
newList @a

instance AllocateList (R.List a) where
    type ListAllocHint (R.List a) = Int

instance
    ( Parse (R.List a) (V.Vector ap)
    , Allocate (R.List a)
    ) => EstimateListAlloc (R.List a) (V.Vector ap)

-- | Allocate a new typed struct. Mainly used as the value for 'new' for in generated
-- instances of 'Allocate'.
newTypedStruct :: forall a m s. (TypedStruct a, U.RWCtx m s) => M.Message ('Mut s) -> m (R.Raw ('Mut s) a)
newTypedStruct :: Message ('Mut s) -> m (Raw ('Mut s) a)
newTypedStruct = AllocHint 'Struct -> Message ('Mut s) -> m (Raw ('Mut s) a)
forall a (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, 'Ptr ('Just r) ~ ReprFor a, RWCtx m s) =>
AllocHint r -> Message ('Mut s) -> m (Raw ('Mut s) a)
newFromRepr (TypedStruct a => (Word16, Word16)
forall a. TypedStruct a => (Word16, Word16)
structSizes @a)

-- | Like 'newTypedStruct', but for lists.
newTypedStructList
    :: forall a m s. (TypedStruct a, U.RWCtx m s)
    => Int -> M.Message ('Mut s) -> m (R.Raw ('Mut s) (R.List a))
newTypedStructList :: Int -> Message ('Mut s) -> m (Raw ('Mut s) (List a))
newTypedStructList Int
i Message ('Mut s)
msg = ListOf ('Mut s) (Struct ('Mut s)) -> Raw ('Mut s) (List a)
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (ListOf ('Mut s) (Struct ('Mut s)) -> Raw ('Mut s) (List a))
-> m (ListOf ('Mut s) (Struct ('Mut s)))
-> m (Raw ('Mut s) (List a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> AllocHint ('List ('Just 'ListComposite))
-> m (UntypedSomePtr ('Mut s) ('List ('Just 'ListComposite)))
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, RWCtx m s) =>
Message ('Mut s) -> AllocHint r -> m (UntypedSomePtr ('Mut s) r)
R.alloc
    @('R.List ('Just 'R.ListComposite))
    Message ('Mut s)
msg
    (Int
i, TypedStruct a => (Word16, Word16)
forall a. TypedStruct a => (Word16, Word16)
structSizes @a)

-- | An instance of marshal allows a parsed value to be inserted into
-- pre-allocated space in a message.
class Parse t p => Marshal t p where
    marshalInto :: U.RWCtx m s => R.Raw ('Mut s) t -> p -> m ()
    -- ^ Marshal a value into the pre-allocated object inside the message.
    --
    -- Note that caller must arrange for the object to be of the correct size.
    -- This is is not necessarily guaranteed; for example, list types must
    -- coordinate the length of the list.

-- | Get the maximum word and pointer counts needed for a struct type's fields.
structSizes :: forall a. TypedStruct a => (Word16, Word16)
structSizes :: (Word16, Word16)
structSizes = (TypedStruct a => Word16
forall a. TypedStruct a => Word16
numStructWords @a, TypedStruct a => Word16
forall a. TypedStruct a => Word16
numStructPtrs @a)

-- | Types which have a numeric type-id defined in a capnp schema.
class HasTypeId a where
    -- | The node id for this type. You will generally want to use the
    -- @TypeApplications@ extension to specify the type.
    typeId :: Word64

-- | Operations on typed structs.
class (R.IsStruct a, Allocate a, HasTypeId a, AllocHint a ~ ()) => TypedStruct a where
    -- Get the size of  the struct's word and pointer sections, respectively.
    numStructWords :: Word16
    numStructPtrs  :: Word16


-- | Like 'new', but also sets the value as the root of the message.
newRoot
    :: forall a m s. (U.RWCtx m s, R.IsStruct a, Allocate a)
    => AllocHint a -> M.Message ('Mut s) -> m (R.Raw ('Mut s) a)
newRoot :: AllocHint a -> Message ('Mut s) -> m (Raw ('Mut s) a)
newRoot AllocHint a
hint Message ('Mut s)
msg = do
    raw :: Raw ('Mut s) a
raw@(R.Raw Untyped ('Mut s) (ReprFor a)
struct) <- AllocHint a -> Message ('Mut s) -> m (Raw ('Mut s) a)
forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw ('Mut s) a)
new @a AllocHint a
hint Message ('Mut s)
msg
    Struct ('Mut s) -> m ()
forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
U.setRoot Struct ('Mut s)
Untyped ('Mut s) (ReprFor a)
struct
    Raw ('Mut s) a -> m (Raw ('Mut s) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raw ('Mut s) a
raw


------ Instances for basic types -------

parseId :: (R.Untyped mut (R.ReprFor a) ~ a, U.ReadCtx m mut) => R.Raw mut a -> m a
parseId :: Raw mut a -> m a
parseId = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (Raw mut a -> a) -> Raw mut a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw mut a -> a
forall (mut :: Mutability) a. Raw mut a -> Untyped mut (ReprFor a)
R.fromRaw

parseInt ::
    ( Integral a
    , Integral (R.Untyped mut (R.ReprFor a))
    , U.ReadCtx m mut
    ) => R.Raw mut a -> m a
parseInt :: Raw mut a -> m a
parseInt = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (Raw mut a -> a) -> Raw mut a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Untyped mut (ReprFor a) -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Untyped mut (ReprFor a) -> a)
-> (Raw mut a -> Untyped mut (ReprFor a)) -> Raw mut a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw mut a -> Untyped mut (ReprFor a)
forall (mut :: Mutability) a. Raw mut a -> Untyped mut (ReprFor a)
R.fromRaw

instance Parse Float Float where
    parse :: Raw 'Const Float -> m Float
parse = Float -> m Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> m Float)
-> (Raw 'Const Float -> Float) -> Raw 'Const Float -> m Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Float
F.castWord32ToFloat (Word32 -> Float)
-> (Raw 'Const Float -> Word32) -> Raw 'Const Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw 'Const Float -> Word32
forall (mut :: Mutability) a. Raw mut a -> Untyped mut (ReprFor a)
R.fromRaw
    encode :: Message ('Mut s) -> Float -> m (Raw ('Mut s) Float)
encode Message ('Mut s)
_ = Raw ('Mut s) Float -> m (Raw ('Mut s) Float)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Raw ('Mut s) Float -> m (Raw ('Mut s) Float))
-> (Float -> Raw ('Mut s) Float) -> Float -> m (Raw ('Mut s) Float)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Raw ('Mut s) Float
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (Word32 -> Raw ('Mut s) Float)
-> (Float -> Word32) -> Float -> Raw ('Mut s) Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
F.castFloatToWord32

instance Parse Double Double where
    parse :: Raw 'Const Double -> m Double
parse = Double -> m Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> m Double)
-> (Raw 'Const Double -> Double) -> Raw 'Const Double -> m Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
F.castWord64ToDouble (Word64 -> Double)
-> (Raw 'Const Double -> Word64) -> Raw 'Const Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw 'Const Double -> Word64
forall (mut :: Mutability) a. Raw mut a -> Untyped mut (ReprFor a)
R.fromRaw
    encode :: Message ('Mut s) -> Double -> m (Raw ('Mut s) Double)
encode Message ('Mut s)
_ = Raw ('Mut s) Double -> m (Raw ('Mut s) Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Raw ('Mut s) Double -> m (Raw ('Mut s) Double))
-> (Double -> Raw ('Mut s) Double)
-> Double
-> m (Raw ('Mut s) Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Raw ('Mut s) Double
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (Word64 -> Raw ('Mut s) Double)
-> (Double -> Word64) -> Double -> Raw ('Mut s) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
F.castDoubleToWord64

instance MarshalElement a ap => Marshal (R.List a) (V.Vector ap) where
    marshalInto :: Raw ('Mut s) (List a) -> Vector ap -> m ()
marshalInto Raw ('Mut s) (List a)
raw Vector ap
value =
        [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0..Vector ap -> Int
forall a. Vector a -> Int
V.length Vector ap
value Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            Raw ('Mut s) (List a) -> Int -> ap -> m ()
forall a ap (m :: * -> *) s.
(RWCtx m s, MarshalElement a ap) =>
Raw ('Mut s) (List a) -> Int -> ap -> m ()
marshalElement Raw ('Mut s) (List a)
raw Int
i (Vector ap
value Vector ap -> Int -> ap
forall a. Vector a -> Int -> a
V.! Int
i)

instance MarshalElement a ap => Parse (R.List a) (V.Vector ap) where
    parse :: Raw 'Const (List a) -> m (Vector ap)
parse Raw 'Const (List a)
rawV =
        Int -> (Int -> m ap) -> m (Vector ap)
forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM (Raw 'Const (List a) -> Int
forall (mut :: Mutability) a. Raw mut (List a) -> Int
R.length Raw 'Const (List a)
rawV) ((Int -> m ap) -> m (Vector ap)) -> (Int -> m ap) -> m (Vector ap)
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            Int -> Raw 'Const (List a) -> m (Raw 'Const a)
forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, Element (ReprFor a)) =>
Int -> Raw mut (List a) -> m (Raw mut a)
R.index Int
i Raw 'Const (List a)
rawV m (Raw 'Const a) -> (Raw 'Const a -> m ap) -> m ap
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Raw 'Const a -> m ap
forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw 'Const t -> m p
parse

-- | Type alias capturing the constraints on a type needed by
-- 'marshalElement'
type MarshalElement a ap =
    ( Parse a ap
    , EstimateListAlloc a ap
    , R.Element (R.ReprFor a)
    , MarshalElementByRepr (R.ListReprFor (R.ReprFor a))
    , MarshalElementReprConstraints (R.ListReprFor (R.ReprFor a)) a ap
    )

-- | Constraints needed by marshalElement that are specific to a list repr.
type family MarshalElementReprConstraints (lr :: R.ListRepr) a ap where
    MarshalElementReprConstraints 'R.ListComposite  a ap = Marshal a ap
    MarshalElementReprConstraints ('R.ListNormal r) a ap = Parse a ap

class MarshalElementByRepr (lr :: R.ListRepr) where
    marshalElementByRepr ::
        ( U.RWCtx m s
        , R.ListReprFor (R.ReprFor a) ~ lr
        , MarshalElement a ap
        ) => R.Raw ('Mut s) (R.List a) -> Int -> ap -> m ()

-- | An instance @'Super' p c@ indicates that the interface @c@ extends
-- the interface @p@.
class (R.IsCap p, R.IsCap c) => Super p c

instance MarshalElementByRepr 'R.ListComposite where
    marshalElementByRepr :: Raw ('Mut s) (List a) -> Int -> ap -> m ()
marshalElementByRepr Raw ('Mut s) (List a)
rawList Int
i ap
parsed = do
        Raw ('Mut s) a
rawElt <- Int -> Raw ('Mut s) (List a) -> m (Raw ('Mut s) a)
forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, Element (ReprFor a)) =>
Int -> Raw mut (List a) -> m (Raw mut a)
R.index Int
i Raw ('Mut s) (List a)
rawList
        Raw ('Mut s) a -> ap -> m ()
forall t p (m :: * -> *) s.
(Marshal t p, RWCtx m s) =>
Raw ('Mut s) t -> p -> m ()
marshalInto Raw ('Mut s) a
rawElt ap
parsed

instance MarshalElementByRepr ('R.ListNormal l) where
    marshalElementByRepr :: Raw ('Mut s) (List a) -> Int -> ap -> m ()
marshalElementByRepr Raw ('Mut s) (List a)
rawList Int
i ap
parsed = do
        Raw ('Mut s) a
rawElt <- Message ('Mut s) -> ap -> m (Raw ('Mut s) a)
forall t p (m :: * -> *) s.
(Parse t p, RWCtx m s) =>
Message ('Mut s) -> p -> m (Raw ('Mut s) t)
encode (Raw ('Mut s) (List a) -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
U.message Raw ('Mut s) (List a)
rawList) ap
parsed
        Raw ('Mut s) a -> Int -> Raw ('Mut s) (List a) -> m ()
forall a (m :: * -> *) s.
(RWCtx m s, Element (ReprFor a)) =>
Raw ('Mut s) a -> Int -> Raw ('Mut s) (List a) -> m ()
R.setIndex Raw ('Mut s) a
rawElt Int
i Raw ('Mut s) (List a)
rawList

marshalElement ::
  forall a ap m s.
  ( U.RWCtx m s
  , MarshalElement a ap
  ) => R.Raw ('Mut s) (R.List a) -> Int -> ap -> m ()
marshalElement :: Raw ('Mut s) (List a) -> Int -> ap -> m ()
marshalElement = forall (m :: * -> *) s a ap.
(MarshalElementByRepr (ListReprFor (ReprFor a)), RWCtx m s,
 ListReprFor (ReprFor a) ~ ListReprFor (ReprFor a),
 MarshalElement a ap) =>
Raw ('Mut s) (List a) -> Int -> ap -> m ()
forall (lr :: ListRepr) (m :: * -> *) s a ap.
(MarshalElementByRepr lr, RWCtx m s, ListReprFor (ReprFor a) ~ lr,
 MarshalElement a ap) =>
Raw ('Mut s) (List a) -> Int -> ap -> m ()
marshalElementByRepr @(R.ListReprFor (R.ReprFor a))

class (Parse a ap, Allocate (R.List a)) => EstimateListAlloc a ap where
    estimateListAlloc :: V.Vector ap -> AllocHint (R.List a)

    default estimateListAlloc :: (AllocHint (R.List a) ~ Int) => V.Vector ap -> AllocHint (R.List a)
    estimateListAlloc = Vector ap -> AllocHint (List a)
forall a. Vector a -> Int
V.length

instance MarshalElement a ap => EstimateAlloc (R.List a) (V.Vector ap) where
    estimateAlloc :: Vector ap -> AllocHint (List a)
estimateAlloc = forall ap.
EstimateListAlloc a ap =>
Vector ap -> AllocHint (List a)
forall a ap.
EstimateListAlloc a ap =>
Vector ap -> AllocHint (List a)
estimateListAlloc @a

-- | If @a@ is a capnproto type, then @Parsed a@ is an ADT representation of that
-- type. If this is defined for a type @a@ then there should also be an instance
-- @'Parse' a ('Parsed' a)@, but note that the converse is not true: if there is
-- an instance @'Parse' a b@, then @'Parsed' a@ needn't be defined, and @b@ can
-- be something else.
data family Parsed a

instance (Default (R.Raw 'Const a), Parse a (Parsed a)) => Default (Parsed a) where
    def :: Parsed a
def = case WordCount -> LimitT Maybe (Parsed a) -> Maybe (Parsed a)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
forall a. Bounded a => a
maxBound (Raw 'Const a -> LimitT Maybe (Parsed a)
forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw 'Const t -> m p
parse @a Raw 'Const a
forall a. Default a => a
def) of
        Just Parsed a
v  -> Parsed a
v
        Maybe (Parsed a)
Nothing -> [Char] -> Parsed a
forall a. HasCallStack => [Char] -> a
error [Char]
"Parsing default value failed."

do
    let mkId ty =
            [d| instance Parse $ty $ty where
                    parse = parseId
                    encode _ = pure . R.Raw
            |]
        mkInt ty =
            [d| instance Parse $ty $ty where
                    parse = parseInt
                    encode _ = pure . R.Raw . fromIntegral
            |]
        mkAll ty =
            [d| instance AllocateList $ty where
                    type ListAllocHint $ty = Int

                instance EstimateListAlloc $ty $ty where
                    estimateListAlloc = V.length
            |]

        nameTy name = pure (TH.ConT name)

        ids      = [t| () |] : map nameTy [''Bool, ''Word8, ''Word16, ''Word32, ''Word64]
        ints     = map nameTy [''Int8, ''Int16, ''Int32, ''Int64]
        floats   = map nameTy [''Float, ''Double]
        allTys   = ids ++ ints ++ floats

        merge :: [TH.Q [a]] -> TH.Q [a]
        merge xs = concat <$> sequenceA xs
    merge
        [ merge $ map mkId ids
        , merge $ map mkInt ints
        , merge $ map mkAll allTys
        ]