{-# 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 ('Ptr ('Just 'Struct))
FieldLoc 'Group (ReprFor b)
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 ('Data 'Sz0)
FieldLoc 'Slot (ReprFor b)
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 a mut -> m (R.Raw b mut)
readVariant :: Variant k a b -> Raw a mut -> m (Raw b mut)
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 a mut -> m (Raw b mut)
forall (k :: FieldKind) a b (mut :: Mutability) (m :: * -> *).
(IsStruct a, ReadCtx m mut) =>
Field k a b -> Raw a mut -> m (Raw b mut)
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 a ('Mut s))
newStruct :: () -> Message ('Mut s) -> m (Raw a ('Mut s))
newStruct () Message ('Mut s)
msg = Struct ('Mut s) -> Raw a ('Mut s)
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw (Struct ('Mut s) -> Raw a ('Mut s))
-> (Raw AnyStruct ('Mut s) -> Struct ('Mut s))
-> Raw AnyStruct ('Mut s)
-> Raw a ('Mut s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw AnyStruct ('Mut s) -> Struct ('Mut s)
forall a (mut :: Mutability).
Raw a mut -> Unwrapped (Untyped (ReprFor a) mut)
R.fromRaw (Raw AnyStruct ('Mut s) -> Raw a ('Mut s))
-> m (Raw AnyStruct ('Mut s)) -> m (Raw a ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AllocHint AnyStruct
-> Message ('Mut s) -> m (Raw AnyStruct ('Mut s))
forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
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 a 'Const -> m a
parseEnum :: Raw a 'Const -> m a
parseEnum (R.Raw Unwrapped (Untyped (ReprFor a) 'Const)
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
Unwrapped (Untyped (ReprFor a) 'Const)
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 a ('Mut s))
encodeEnum :: Message ('Mut s) -> a -> m (Raw a ('Mut s))
encodeEnum Message ('Mut s)
_msg a
value = Raw a ('Mut s) -> m (Raw a ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Raw a ('Mut s) -> m (Raw a ('Mut s)))
-> Raw a ('Mut s) -> m (Raw a ('Mut s))
forall a b. (a -> b) -> a -> b
$ Unwrapped (Untyped (ReprFor a) ('Mut s)) -> Raw a ('Mut s)
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw (Unwrapped (Untyped (ReprFor a) ('Mut s)) -> Raw a ('Mut s))
-> Unwrapped (Untyped (ReprFor a) ('Mut s)) -> Raw a ('Mut s)
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 a 'Const
getPtrConst :: ByteString -> Raw a 'Const
getPtrConst ByteString
bytes = Maybe (Raw a 'Const) -> Raw a 'Const
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Raw a 'Const) -> Raw a 'Const)
-> Maybe (Raw a 'Const) -> Raw a 'Const
forall a b. (a -> b) -> a -> b
$ WordCount -> LimitT Maybe (Raw a 'Const) -> Maybe (Raw a 'Const)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
forall a. Bounded a => a
maxBound (LimitT Maybe (Raw a 'Const) -> Maybe (Raw a 'Const))
-> LimitT Maybe (Raw a 'Const) -> Maybe (Raw a 'Const)
forall a b. (a -> b) -> a -> b
$ do
    R.Raw Unwrapped (Untyped (ReprFor AnyStruct) 'Const)
root <- ByteString -> LimitT Maybe (Raw AnyStruct 'Const)
forall a (m :: * -> *).
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw a 'Const)
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 Unwrapped (Untyped (ReprFor AnyStruct) 'Const)
Struct 'Const
root
        LimitT Maybe (Maybe (Ptr 'Const))
-> (Maybe (Ptr 'Const)
    -> LimitT
         Maybe (Unwrapped (UntypedPtr (PtrReprFor (ReprFor a)) 'Const)))
-> LimitT
     Maybe (Unwrapped (UntypedPtr (PtrReprFor (ReprFor a)) 'Const))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message 'Const
-> Maybe (Ptr 'Const)
-> LimitT
     Maybe (Unwrapped (Untyped ('Ptr (PtrReprFor (ReprFor a))) 'Const))
forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut
-> Maybe (Ptr mut) -> m (Unwrapped (Untyped ('Ptr r) mut))
R.fromPtr @(R.PtrReprFor (R.ReprFor a)) (Unwrapped (Struct 'Const) -> Message 'Const
forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
U.message @U.Struct Unwrapped (Untyped (ReprFor AnyStruct) 'Const)
Unwrapped (Struct 'Const)
root)
        LimitT
  Maybe (Unwrapped (UntypedPtr (PtrReprFor (ReprFor a)) 'Const))
-> (Unwrapped (UntypedPtr (PtrReprFor (ReprFor a)) 'Const)
    -> Raw a 'Const)
-> LimitT Maybe (Raw a 'Const)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Unwrapped (UntypedPtr (PtrReprFor (ReprFor a)) 'Const)
-> Raw a 'Const
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw