{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
module Capnp.GenHelpers.New
    ( dataField
    , ptrField
    , groupField
    , voidField
    , readVariant
    , Mutability(..)
    , TypeParam
    , newStruct
    , parseEnum
    , encodeEnum
    , getPtrConst
    , BS.ByteString
    , module F
    , module Capnp.New.Accessors

    -- * Re-exports from the standard library.
    , Proxy(..)
    ) where



import           Capnp.Bits
import           Capnp.Convert         (bsToRaw)
import           Capnp.Fields          as F
import           Capnp.Message         (Mutability(..))
import qualified Capnp.Message         as M
import           Capnp.New.Accessors
import qualified Capnp.New.Basics      as NB
import qualified Capnp.New.Classes     as NC
import           Capnp.New.Constraints (TypeParam)
import qualified Capnp.Repr            as R
import           Capnp.TraversalLimit  (evalLimitT)
import qualified Capnp.Untyped         as U
import           Data.Bits
import qualified Data.ByteString       as BS
import           Data.Functor          ((<&>))
import           Data.Maybe            (fromJust)
import           Data.Proxy            (Proxy(..))
import           Data.Word

dataField
    :: forall b a sz.
    ( R.ReprFor b ~ 'R.Data sz
    , NC.IsWord (R.UntypedData sz)
    )
    => BitCount -> Word16 -> BitCount -> Word64 -> F.Field 'F.Slot a b
dataField :: BitCount -> Word16 -> BitCount -> Word64 -> Field 'Slot a b
dataField BitCount
shift Word16
index BitCount
nbits Word64
defaultValue = FieldLoc 'Slot (ReprFor b) -> Field 'Slot a b
forall (k :: FieldKind) a b. FieldLoc k (ReprFor b) -> Field k a b
F.Field (FieldLoc 'Slot (ReprFor b) -> Field 'Slot a b)
-> FieldLoc 'Slot (ReprFor b) -> Field 'Slot a b
forall a b. (a -> b) -> a -> b
$ DataFieldLoc sz -> FieldLoc 'Slot ('Data sz)
forall (a :: DataSz).
IsWord (UntypedData a) =>
DataFieldLoc a -> FieldLoc 'Slot ('Data a)
F.DataField @sz DataFieldLoc :: forall (sz :: DataSz).
BitCount -> Word16 -> Word64 -> Word64 -> DataFieldLoc sz
F.DataFieldLoc
    { BitCount
shift :: BitCount
shift :: BitCount
shift
    , Word16
index :: Word16
index :: Word16
index
    , mask :: Word64
mask = ((Word64
1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` BitCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BitCount
nbits) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` BitCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BitCount
shift
    , Word64
defaultValue :: Word64
defaultValue :: Word64
defaultValue
    }

ptrField :: forall a b. R.IsPtr b => Word16 -> F.Field 'F.Slot a b
ptrField :: Word16 -> Field 'Slot a b
ptrField = FieldLoc 'Slot ('Ptr (PtrReprFor (ReprFor b))) -> Field 'Slot a b
forall (k :: FieldKind) a b. FieldLoc k (ReprFor b) -> Field k a b
F.Field (FieldLoc 'Slot ('Ptr (PtrReprFor (ReprFor b))) -> Field 'Slot a b)
-> (Word16 -> FieldLoc 'Slot ('Ptr (PtrReprFor (ReprFor b))))
-> Word16
-> Field 'Slot a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsPtrRepr (PtrReprFor (ReprFor b)) =>
Word16 -> FieldLoc 'Slot ('Ptr (PtrReprFor (ReprFor b)))
forall (a :: Maybe PtrRepr).
IsPtrRepr a =>
Word16 -> FieldLoc 'Slot ('Ptr a)
F.PtrField @(R.PtrReprFor (R.ReprFor b))

groupField :: (R.ReprFor b ~ 'R.Ptr ('Just 'R.Struct)) => F.Field 'F.Group a b
groupField :: Field 'Group a b
groupField = FieldLoc 'Group (ReprFor b) -> Field 'Group a b
forall (k :: FieldKind) a b. FieldLoc k (ReprFor b) -> Field k a b
F.Field FieldLoc 'Group (ReprFor b)
FieldLoc 'Group ('Ptr ('Just 'Struct))
F.GroupField

voidField :: (R.ReprFor b ~ 'R.Data 'R.Sz0) => F.Field 'F.Slot a b
voidField :: Field 'Slot a b
voidField = FieldLoc 'Slot (ReprFor b) -> Field 'Slot a b
forall (k :: FieldKind) a b. FieldLoc k (ReprFor b) -> Field k a b
F.Field FieldLoc 'Slot (ReprFor b)
FieldLoc 'Slot ('Data 'Sz0)
F.VoidField

-- | Like 'readField', but accepts a variant. Warning: *DOES NOT CHECK* that the
-- variant is the one that is set. This should only be used by generated code.
readVariant
    ::  forall k a b mut m.
        ( R.IsStruct a
        , U.ReadCtx m mut
        )
    => F.Variant k a b -> R.Raw mut a -> m (R.Raw mut b)
readVariant :: Variant k a b -> Raw mut a -> m (Raw mut b)
readVariant F.Variant{Field k a b
field :: forall (k :: FieldKind) a b. Variant k a b -> Field k a b
field :: Field k a b
field} = Field k a b -> Raw mut a -> m (Raw mut b)
forall (k :: FieldKind) a b (mut :: Mutability) (m :: * -> *).
(IsStruct a, ReadCtx m mut) =>
Field k a b -> Raw mut a -> m (Raw mut b)
readField Field k a b
field

newStruct :: forall a m s. (U.RWCtx m s, NC.TypedStruct a) => () -> M.Message ('Mut s) -> m (R.Raw ('Mut s) a)
newStruct :: () -> Message ('Mut s) -> m (Raw ('Mut s) a)
newStruct () Message ('Mut s)
msg = Struct ('Mut s) -> Raw ('Mut s) a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (Struct ('Mut s) -> Raw ('Mut s) a)
-> (Raw ('Mut s) AnyStruct -> Struct ('Mut s))
-> Raw ('Mut s) AnyStruct
-> Raw ('Mut s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw ('Mut s) AnyStruct -> Struct ('Mut s)
forall (mut :: Mutability) a. Raw mut a -> Untyped mut (ReprFor a)
R.fromRaw (Raw ('Mut s) AnyStruct -> Raw ('Mut s) a)
-> m (Raw ('Mut s) AnyStruct) -> m (Raw ('Mut s) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AllocHint AnyStruct
-> Message ('Mut s) -> m (Raw ('Mut s) AnyStruct)
forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw ('Mut s) a)
NC.new @NB.AnyStruct (TypedStruct a => Word16
forall a. TypedStruct a => Word16
NC.numStructWords @a, TypedStruct a => Word16
forall a. TypedStruct a => Word16
NC.numStructPtrs @a) Message ('Mut s)
msg


parseEnum :: (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, Applicative m)
    => R.Raw 'Const a -> m a
parseEnum :: Raw 'Const a -> m a
parseEnum (R.Raw Untyped 'Const (ReprFor a)
n) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
Untyped 'Const (ReprFor a)
n

encodeEnum :: forall a m s. (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, U.RWCtx m s)
    => M.Message ('Mut s) -> a -> m (R.Raw ('Mut s) a)
encodeEnum :: Message ('Mut s) -> a -> m (Raw ('Mut s) a)
encodeEnum Message ('Mut s)
_msg a
value = Raw ('Mut s) a -> m (Raw ('Mut s) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Raw ('Mut s) a -> m (Raw ('Mut s) a))
-> Raw ('Mut s) a -> m (Raw ('Mut s) a)
forall a b. (a -> b) -> a -> b
$ Untyped ('Mut s) (ReprFor a) -> Raw ('Mut s) a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (Untyped ('Mut s) (ReprFor a) -> Raw ('Mut s) a)
-> Untyped ('Mut s) (ReprFor a) -> Raw ('Mut s) a
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum @a a
value

-- | Get a pointer from a ByteString, where the root object is a struct with
-- one pointer, which is the pointer we will retrieve. This is only safe for
-- trusted inputs; it reads the message with a traversal limit of 'maxBound'
-- (and so is suseptable to denial of service attacks), and it calls 'error'
-- if decoding is not successful.
--
-- The purpose of this is for defining constants of pointer type from a schema.
getPtrConst :: forall a. R.IsPtr a => BS.ByteString -> R.Raw 'Const a
getPtrConst :: ByteString -> Raw 'Const a
getPtrConst ByteString
bytes = Maybe (Raw 'Const a) -> Raw 'Const a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Raw 'Const a) -> Raw 'Const a)
-> Maybe (Raw 'Const a) -> Raw 'Const a
forall a b. (a -> b) -> a -> b
$ WordCount -> LimitT Maybe (Raw 'Const a) -> Maybe (Raw 'Const a)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
forall a. Bounded a => a
maxBound (LimitT Maybe (Raw 'Const a) -> Maybe (Raw 'Const a))
-> LimitT Maybe (Raw 'Const a) -> Maybe (Raw 'Const a)
forall a b. (a -> b) -> a -> b
$ do
    R.Raw Untyped 'Const (ReprFor AnyStruct)
root <- ByteString -> LimitT Maybe (Raw 'Const AnyStruct)
forall a (m :: * -> *).
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw 'Const a)
bsToRaw @NB.AnyStruct ByteString
bytes
    Int -> Struct 'Const -> LimitT Maybe (Maybe (Ptr 'Const))
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m (Maybe (Ptr msg))
U.getPtr Int
0 Struct 'Const
Untyped 'Const (ReprFor AnyStruct)
root
        LimitT Maybe (Maybe (Ptr 'Const))
-> (Maybe (Ptr 'Const)
    -> LimitT Maybe (UntypedPtr 'Const (PtrReprFor (ReprFor a))))
-> LimitT Maybe (UntypedPtr 'Const (PtrReprFor (ReprFor a)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message 'Const
-> Maybe (Ptr 'Const)
-> LimitT Maybe (Untyped 'Const ('Ptr (PtrReprFor (ReprFor a))))
forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut -> Maybe (Ptr mut) -> m (Untyped mut ('Ptr r))
R.fromPtr @(R.PtrReprFor (R.ReprFor a)) (Struct 'Const -> Message 'Const
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
U.message Struct 'Const
Untyped 'Const (ReprFor AnyStruct)
root)
        LimitT Maybe (UntypedPtr 'Const (PtrReprFor (ReprFor a)))
-> (UntypedPtr 'Const (PtrReprFor (ReprFor a)) -> Raw 'Const a)
-> LimitT Maybe (Raw 'Const a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UntypedPtr 'Const (PtrReprFor (ReprFor a)) -> Raw 'Const a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw