{-# 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.Classes
-- Description: Misc. type classes
--
-- This module contains several type classes (and related utilities)
-- useful for operating over Cap'n Proto values.
module Capnp.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 <- forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new (forall t p. EstimateAlloc t p => p -> AllocHint t
estimateAlloc p
value) Message ('Mut s)
msg
    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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Raw t ('Mut s)
raw
  {-# INLINEABLE 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
_ = ()
  {-# INLINEABLE 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))
{-# INLINEABLE newFromRepr #-}
newFromRepr :: 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 AllocHint r
hint Message ('Mut s)
msg = forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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))
newFromRepr @a
  {-# INLINEABLE 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 = forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ListAllocHint a
hint
  {-# INLINEABLE newList #-}

instance AllocateList a => Allocate (R.List a) where
  type AllocHint (R.List a) = ListAllocHint a
  new :: forall (m :: * -> *) s.
RWCtx m s =>
AllocHint (List a) -> Message ('Mut s) -> m (Raw (List a) ('Mut s))
new = forall a (m :: * -> *) s.
(AllocateList a, RWCtx m s) =>
ListAllocHint a -> Message ('Mut s) -> m (Raw (List a) ('Mut s))
newList @a
  {-# INLINEABLE 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))
{-# INLINEABLE newTypedStruct #-}
newTypedStruct :: forall a (m :: * -> *) s.
(TypedStruct a, RWCtx m s) =>
Message ('Mut s) -> m (Raw a ('Mut s))
newTypedStruct = 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 (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))
{-# INLINEABLE newTypedStructList #-}
newTypedStructList :: forall a (m :: * -> *) s.
(TypedStruct a, RWCtx m s) =>
Int -> Message ('Mut s) -> m (Raw (List a) ('Mut s))
newTypedStructList Int
i Message ('Mut s)
msg =
  forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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, 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)
{-# INLINEABLE structSizes #-}
structSizes :: forall a. TypedStruct a => (Word16, Word16)
structSizes = (forall a. TypedStruct a => Word16
numStructWords @a, 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))
{-# INLINEABLE newRoot #-}
newRoot :: forall a (m :: * -> *) s.
(RWCtx m s, IsStruct a, Allocate a) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
newRoot AllocHint a
hint Message ('Mut s)
msg = do
  Raw a ('Mut s)
raw <- 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
  forall (m :: * -> *) s a.
(RWCtx m s, IsStruct a) =>
Raw a ('Mut s) -> m ()
setRoot Raw a ('Mut s)
raw
  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 ()
{-# INLINEABLE setRoot #-}
setRoot :: forall (m :: * -> *) s a.
(RWCtx m s, IsStruct a) =>
Raw a ('Mut s) -> m ()
setRoot (R.Raw Unwrapped (Untyped (ReprFor a) ('Mut s))
struct) = forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
U.setRoot Unwrapped (Untyped (ReprFor a) ('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
{-# INLINEABLE parseId #-}
parseId :: forall a (mut :: Mutability) (m :: * -> *).
(Untyped (ReprFor a) mut ~ IgnoreMut a mut, ReadCtx m mut) =>
Raw a mut -> m a
parseId (R.Raw Unwrapped (Untyped (ReprFor a) mut)
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
{-# INLINEABLE parseInt #-}
parseInt :: forall a (mut :: Mutability) (m :: * -> *).
(Integral a, Integral (Unwrapped (Untyped (ReprFor a) mut)),
 ReadCtx m mut) =>
Raw a mut -> m a
parseInt = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (mut :: Mutability).
Raw a mut -> Unwrapped (Untyped (ReprFor a) mut)
R.fromRaw

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

instance Parse Double Double where
  parse :: forall (m :: * -> *).
ReadCtx m 'Const =>
Raw Double 'Const -> m Double
parse = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
F.castWord64ToDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (mut :: Mutability).
Raw a mut -> Unwrapped (Untyped (ReprFor a) mut)
R.fromRaw
  encode :: forall (m :: * -> *) s.
RWCtx m s =>
Message ('Mut s) -> Double -> m (Raw Double ('Mut s))
encode Message ('Mut s)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw 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 :: forall (m :: * -> *) s.
RWCtx m s =>
Raw (List a) ('Mut s) -> Vector ap -> m ()
marshalInto Raw (List a) ('Mut s)
raw Vector ap
value =
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. forall a. Vector a -> Int
V.length Vector ap
value forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i ->
      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 forall a. Vector a -> Int -> a
V.! Int
i)

instance MarshalElement a ap => Parse (R.List a) (V.Vector ap) where
  parse :: forall (m :: * -> *).
ReadCtx m 'Const =>
Raw (List a) 'Const -> m (Vector ap)
parse Raw (List a) 'Const
rawV =
    forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM (forall a (mut :: Mutability). ListElem a => Raw (List a) mut -> Int
R.length Raw (List a) 'Const
rawV) forall a b. (a -> b) -> a -> b
$ \Int
i ->
      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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall (m :: * -> *) s a ap.
(RWCtx m s, ListReprFor (ReprFor a) ~ 'ListComposite,
 MarshalElement a ap) =>
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 <- 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
    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
  {-# INLINEABLE marshalElementByRepr #-}

instance
  ( U.HasMessage (U.ListOf (R.ElemRepr ('R.ListNormal l))),
    U.ListItem (R.ElemRepr ('R.ListNormal l))
  ) =>
  MarshalElementByRepr ('R.ListNormal l)
  where
  marshalElementByRepr :: forall (m :: * -> *) s a ap.
(RWCtx m s, ListReprFor (ReprFor a) ~ 'ListNormal l,
 MarshalElement a ap) =>
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 <-
      forall t p (m :: * -> *) s.
(Parse t p, RWCtx m s) =>
Message ('Mut s) -> p -> m (Raw t ('Mut s))
encode
        (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 (ReprFor (List a)) ('Mut s))
ulist)
        ap
parsed
    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
  {-# INLINEABLE marshalElementByRepr #-}

marshalElement ::
  forall a ap m s.
  ( U.RWCtx m s,
    MarshalElement a ap
  ) =>
  R.Raw (R.List a) ('Mut s) ->
  Int ->
  ap ->
  m ()
{-# INLINEABLE marshalElement #-}
marshalElement :: forall a ap (m :: * -> *) s.
(RWCtx m s, MarshalElement a ap) =>
Raw (List a) ('Mut s) -> Int -> ap -> m ()
marshalElement = 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 = forall a. Vector a -> Int
V.length
  {-# INLINEABLE estimateListAlloc #-}

instance MarshalElement a ap => EstimateAlloc (R.List a) (V.Vector ap) where
  estimateAlloc :: Vector ap -> AllocHint (List a)
estimateAlloc = forall a ap.
EstimateListAlloc a ap =>
Vector ap -> AllocHint (List a)
estimateListAlloc @a
  {-# INLINEABLE 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 forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT forall a. Bounded a => a
maxBound (forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse @a forall a. Default a => a
def) of
    Just Parsed a
v -> Parsed a
v
    Maybe (Parsed a)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Parsing default value failed."
  {-# INLINEABLE def #-}

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

          instance EstimateListAlloc $ty $ty where
            estimateListAlloc = V.length
            {-# INLINEABLE 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 forall a. Bits a => a -> a -> a
.&. Word64
1) forall a. Eq a => a -> a -> Bool
== Word64
1
  {-# INLINEABLE fromWord #-}
  toWord :: Bool -> Word64
toWord Bool
True = Word64
1
  toWord Bool
False = Word64
0
  {-# INLINEABLE toWord #-}

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

-- IsWord instances for integral types; they're all the same.
do
  let mkInstance t =
        [d|
          instance IsWord $t where
            fromWord = fromIntegral
            {-# INLINEABLE fromWord #-}
            toWord = fromIntegral
            {-# INLINEABLE 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  {-# INLINEABLE fromWord #-}
  toWord :: Float -> Word64
toWord = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
F.castFloatToWord32
  {-# INLINEABLE toWord #-}

instance IsWord Double where
  fromWord :: Word64 -> Double
fromWord = Word64 -> Double
F.castWord64ToDouble
  {-# INLINEABLE fromWord #-}
  toWord :: Double -> Word64
toWord = Double -> Word64
F.castDoubleToWord64
  {-# INLINEABLE toWord #-}