{-# 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

    -- * Setting the root of a message
    , setRoot

    -- * 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.Bits
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.Bits
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 t 'Const -> m p
    -- ^ Parse a value from a constant message
    encode :: U.RWCtx m s => M.Message ('Mut s) -> p -> m (R.Raw t ('Mut s))
    -- ^ 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 t ('Mut s))
    encode Message ('Mut s)
msg p
value = do
        Raw t ('Mut s)
raw <- AllocHint t -> Message ('Mut s) -> m (Raw t ('Mut s))
forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new (p -> AllocHint t
forall t p. EstimateAlloc t p => p -> AllocHint t
estimateAlloc p
value) Message ('Mut s)
msg
        Raw t ('Mut s) -> p -> m ()
forall t p (m :: * -> *) s.
(Marshal t p, RWCtx m s) =>
Raw t ('Mut s) -> p -> m ()
marshalInto Raw t ('Mut s)
raw p
value
        Raw t ('Mut s) -> m (Raw t ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raw t ('Mut s)
raw
    {-# INLINABLE encode #-}

-- | 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
_ = ()
    {-# INLINABLE estimateAlloc #-}

-- | 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 a ('Mut s))
{-# INLINABLE newFromRepr #-}
newFromRepr :: AllocHint r -> Message ('Mut s) -> m (Raw a ('Mut s))
newFromRepr AllocHint r
hint Message ('Mut s)
msg = Unwrapped (UntypedSomePtr r ('Mut s)) -> Raw a ('Mut s)
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw (Unwrapped (UntypedSomePtr r ('Mut s)) -> Raw a ('Mut s))
-> m (Unwrapped (UntypedSomePtr r ('Mut s))) -> m (Raw a ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s)))
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, RWCtx m s) =>
Message ('Mut s)
-> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s)))
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 a ('Mut s))
    -- ^ @'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 a ('Mut s))
    -- 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 a ('Mut s))
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, 'Ptr ('Just r) ~ ReprFor a, RWCtx m s) =>
AllocHint r -> Message ('Mut s) -> m (Raw a ('Mut s))
newFromRepr @a
    {-# INLINABLE new #-}

-- | 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 (R.List a) ('Mut s))
    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 (R.List a) ('Mut s))
    newList ListAllocHint a
hint Message ('Mut s)
msg = ListOf (ElemRepr lr) ('Mut s) -> Raw (List a) ('Mut s)
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw (ListOf (ElemRepr lr) ('Mut s) -> Raw (List a) ('Mut s))
-> m (ListOf (ElemRepr lr) ('Mut s)) -> m (Raw (List a) ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s)))
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, RWCtx m s) =>
Message ('Mut s)
-> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s)))
R.alloc @r Message ('Mut s)
msg AllocHint r
ListAllocHint a
hint
    {-# INLINABLE newList #-}

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

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 a ('Mut s))
{-# INLINABLE newTypedStruct #-}
newTypedStruct :: Message ('Mut s) -> m (Raw a ('Mut s))
newTypedStruct = AllocHint 'Struct -> Message ('Mut s) -> m (Raw a ('Mut s))
forall a (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, 'Ptr ('Just r) ~ ReprFor a, RWCtx m s) =>
AllocHint r -> Message ('Mut s) -> m (Raw a ('Mut s))
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 (R.List a) ('Mut s))
{-# INLINABLE newTypedStructList #-}
newTypedStructList :: Int -> Message ('Mut s) -> m (Raw (List a) ('Mut s))
newTypedStructList Int
i Message ('Mut s)
msg = ListOf ('Ptr ('Just 'Struct)) ('Mut s) -> Raw (List a) ('Mut s)
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw (ListOf ('Ptr ('Just 'Struct)) ('Mut s) -> Raw (List a) ('Mut s))
-> m (ListOf ('Ptr ('Just 'Struct)) ('Mut s))
-> m (Raw (List a) ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s)
-> AllocHint ('List ('Just 'ListComposite))
-> m (Unwrapped
        (UntypedSomePtr ('List ('Just 'ListComposite)) ('Mut s)))
forall (r :: PtrRepr) (m :: * -> *) s.
(Allocate r, RWCtx m s) =>
Message ('Mut s)
-> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s)))
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 t ('Mut s) -> 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)
{-# INLINABLE structSizes #-}
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 a ('Mut s))
{-# INLINABLE newRoot #-}
newRoot :: AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
newRoot AllocHint a
hint Message ('Mut s)
msg = do
    Raw a ('Mut s)
raw <- AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new @a AllocHint a
hint Message ('Mut s)
msg
    Raw a ('Mut s) -> m ()
forall (m :: * -> *) s a.
(RWCtx m s, IsStruct a) =>
Raw a ('Mut s) -> m ()
setRoot Raw a ('Mut s)
raw
    Raw a ('Mut s) -> m (Raw a ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raw a ('Mut s)
raw

-- | Sets the struct to be the root of its containing message.
setRoot :: (U.RWCtx m s, R.IsStruct a) => R.Raw a ('Mut s) -> m ()
{-# INLINABLE setRoot #-}
setRoot :: Raw a ('Mut s) -> m ()
setRoot (R.Raw Unwrapped (Untyped (ReprFor a) ('Mut s))
struct) = Struct ('Mut s) -> m ()
forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
U.setRoot Unwrapped (Untyped (ReprFor a) ('Mut s))
Struct ('Mut s)
struct


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

parseId :: (R.Untyped (R.ReprFor a) mut ~ U.IgnoreMut a mut, U.ReadCtx m mut) => R.Raw a mut -> m a
{-# INLINABLE parseId #-}
parseId :: Raw a mut -> m a
parseId (R.Raw Unwrapped (Untyped (ReprFor a) mut)
v) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Unwrapped (Untyped (ReprFor a) mut)
v

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

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

instance Parse Double Double where
    parse :: Raw Double 'Const -> m Double
parse = Double -> m Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> m Double)
-> (Raw Double 'Const -> Double) -> Raw Double 'Const -> m Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
F.castWord64ToDouble (Word64 -> Double)
-> (Raw Double 'Const -> Word64) -> Raw Double 'Const -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw Double 'Const -> Word64
forall a (mut :: Mutability).
Raw a mut -> Unwrapped (Untyped (ReprFor a) mut)
R.fromRaw
    encode :: Message ('Mut s) -> Double -> m (Raw Double ('Mut s))
encode Message ('Mut s)
_ = Raw Double ('Mut s) -> m (Raw Double ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Raw Double ('Mut s) -> m (Raw Double ('Mut s)))
-> (Double -> Raw Double ('Mut s))
-> Double
-> m (Raw Double ('Mut s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Raw Double ('Mut s)
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw (Word64 -> Raw Double ('Mut s))
-> (Double -> Word64) -> Double -> Raw Double ('Mut s)
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 (List a) ('Mut s) -> Vector ap -> m ()
marshalInto Raw (List a) ('Mut s)
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 (List a) ('Mut s) -> Int -> ap -> m ()
forall a ap (m :: * -> *) s.
(RWCtx m s, MarshalElement a ap) =>
Raw (List a) ('Mut s) -> Int -> ap -> m ()
marshalElement Raw (List a) ('Mut s)
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 (List a) 'Const -> m (Vector ap)
parse Raw (List a) 'Const
rawV =
        Int -> (Int -> m ap) -> m (Vector ap)
forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM (Raw (List a) 'Const -> Int
forall a (mut :: Mutability). ListElem a => Raw (List a) mut -> Int
R.length Raw (List a) 'Const
rawV) ((Int -> m ap) -> m (Vector ap)) -> (Int -> m ap) -> m (Vector ap)
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            Int -> Raw (List a) 'Const -> m (Raw a 'Const)
forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut,
 HasMessage (ListOf (ElemRepr (ListReprFor (ReprFor a)))),
 ListElem a) =>
Int -> Raw (List a) mut -> m (Raw a mut)
R.index Int
i Raw (List a) 'Const
rawV m (Raw a 'Const) -> (Raw a 'Const -> m ap) -> m ap
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Raw a 'Const -> m ap
forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> 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)
    , U.ListItem (R.ElemRepr (R.ListReprFor (R.ReprFor a)))
    , U.HasMessage (U.ListOf (R.ElemRepr (R.ListReprFor (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
    U.HasMessage (U.ListOf ('R.Ptr ('Just ('R.List ('Just lr)))))
    => MarshalElementByRepr (lr :: R.ListRepr)
  where
    marshalElementByRepr ::
        ( U.RWCtx m s
        , R.ListReprFor (R.ReprFor a) ~ lr
        , MarshalElement a ap
        ) => R.Raw (R.List a) ('Mut s) -> 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 (List a) ('Mut s) -> Int -> ap -> m ()
marshalElementByRepr Raw (List a) ('Mut s)
rawList Int
i ap
parsed = do
        Raw a ('Mut s)
rawElt <- Int -> Raw (List a) ('Mut s) -> m (Raw a ('Mut s))
forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut,
 HasMessage (ListOf (ElemRepr (ListReprFor (ReprFor a)))),
 ListElem a) =>
Int -> Raw (List a) mut -> m (Raw a mut)
R.index Int
i Raw (List a) ('Mut s)
rawList
        Raw a ('Mut s) -> ap -> m ()
forall t p (m :: * -> *) s.
(Marshal t p, RWCtx m s) =>
Raw t ('Mut s) -> p -> m ()
marshalInto Raw a ('Mut s)
rawElt ap
parsed
    {-# INLINABLE marshalElementByRepr #-}

instance
    ( U.HasMessage (U.ListOf (R.ElemRepr ('R.ListNormal l)))
    , U.ListItem (R.ElemRepr ('R.ListNormal l))
    ) => MarshalElementByRepr ('R.ListNormal l)
  where
    marshalElementByRepr :: Raw (List a) ('Mut s) -> Int -> ap -> m ()
marshalElementByRepr rawList :: Raw (List a) ('Mut s)
rawList@(R.Raw Unwrapped (Untyped (ReprFor (List a)) ('Mut s))
ulist) Int
i ap
parsed = do
        Raw a ('Mut s)
rawElt <- Message ('Mut s) -> ap -> m (Raw a ('Mut s))
forall t p (m :: * -> *) s.
(Parse t p, RWCtx m s) =>
Message ('Mut s) -> p -> m (Raw t ('Mut s))
encode
            (Unwrapped
  (Untyped ('Ptr ('Just ('List ('Just ('ListNormal l))))) ('Mut s))
-> Message ('Mut s)
forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
U.message @(U.Untyped ('R.Ptr ('Just ('R.List ('Just ('R.ListNormal l)))))) Unwrapped
  (Untyped ('Ptr ('Just ('List ('Just ('ListNormal l))))) ('Mut s))
Unwrapped (Untyped (ReprFor (List a)) ('Mut s))
ulist)
            ap
parsed
        Raw a ('Mut s) -> Int -> Raw (List a) ('Mut s) -> m ()
forall a (m :: * -> *) s.
(RWCtx m s, ListItem (ElemRepr (ListReprFor (ReprFor a))),
 Element (ReprFor a)) =>
Raw a ('Mut s) -> Int -> Raw (List a) ('Mut s) -> m ()
R.setIndex Raw a ('Mut s)
rawElt Int
i Raw (List a) ('Mut s)
rawList
    {-# INLINABLE marshalElementByRepr #-}

marshalElement ::
  forall a ap m s.
  ( U.RWCtx m s
  , MarshalElement a ap
  ) => R.Raw (R.List a) ('Mut s) -> Int -> ap -> m ()
{-# INLINABLE marshalElement #-}
marshalElement :: Raw (List a) ('Mut s) -> 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 (List a) ('Mut s) -> Int -> ap -> m ()
forall (lr :: ListRepr) (m :: * -> *) s a ap.
(MarshalElementByRepr lr, RWCtx m s, ListReprFor (ReprFor a) ~ lr,
 MarshalElement a ap) =>
Raw (List a) ('Mut s) -> 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
    {-# INLINABLE estimateListAlloc #-}

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
    {-# INLINABLE estimateAlloc #-}

-- | 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 a 'Const), 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 a 'Const -> LimitT Maybe (Parsed a)
forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse @a Raw a 'Const
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."
    {-# INLINABLE def #-}

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

                instance EstimateListAlloc $ty $ty where
                    estimateListAlloc = V.length
                    {-# INLINABLE estimateListAlloc #-}
            |]

        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
        ]

-- | Types that can be converted to and from a 64-bit word.
--
-- Anything that goes in the data section of a struct will have
-- an instance of this.
class IsWord a where
    -- | Convert from a 64-bit words Truncates the word if the
    -- type has less than 64 bits.
    fromWord :: Word64 -> a

    -- | Convert to a 64-bit word.
    toWord :: a -> Word64

------- IsWord instances. TODO: fold into TH above. -------

instance IsWord Bool where
    fromWord :: Word64 -> Bool
fromWord Word64
n = (Word64
n Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
1) Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
1
    {-# INLINABLE fromWord #-}
    toWord :: Bool -> Word64
toWord Bool
True  = Word64
1
    toWord Bool
False = Word64
0
    {-# INLINABLE toWord #-}

instance IsWord Word1 where
    fromWord :: Word64 -> Word1
fromWord = Bool -> Word1
Word1 (Bool -> Word1) -> (Word64 -> Bool) -> Word64 -> Word1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Bool
forall a. IsWord a => Word64 -> a
fromWord
    {-# INLINABLE fromWord #-}
    toWord :: Word1 -> Word64
toWord = Bool -> Word64
forall a. IsWord a => a -> Word64
toWord (Bool -> Word64) -> (Word1 -> Bool) -> Word1 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word1 -> Bool
word1ToBool
    {-# INLINABLE toWord #-}

-- IsWord instances for integral types; they're all the same.
do
    let mkInstance t =
            [d|instance IsWord $t where
                fromWord = fromIntegral
                {-# INLINABLE fromWord #-}
                toWord = fromIntegral
                {-# INLINABLE toWord #-}
            |]
    concat <$> traverse mkInstance
        [ [t|Int8|]
        , [t|Int16|]
        , [t|Int32|]
        , [t|Int64|]
        , [t|Word8|]
        , [t|Word16|]
        , [t|Word32|]
        , [t|Word64|]
        ]

instance IsWord Float where
    fromWord :: Word64 -> Float
fromWord = Word32 -> Float
F.castWord32ToFloat (Word32 -> Float) -> (Word64 -> Word32) -> Word64 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    {-# INLINABLE fromWord #-}
    toWord :: Float -> Word64
toWord = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> (Float -> Word32) -> Float -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
F.castFloatToWord32
    {-# INLINABLE toWord #-}
instance IsWord Double where
    fromWord :: Word64 -> Double
fromWord = Word64 -> Double
F.castWord64ToDouble
    {-# INLINABLE fromWord #-}
    toWord :: Double -> Word64
toWord = Double -> Word64
F.castDoubleToWord64
    {-# INLINABLE toWord #-}