{-# 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
(
Parse(..)
, Parsed
, Marshal(..)
, MarshalElement
, Allocate(..)
, newRoot
, AllocateList(..)
, EstimateAlloc(..)
, EstimateListAlloc(..)
, newFromRepr
, setRoot
, HasTypeId(..)
, TypedStruct(..)
, newTypedStruct
, newTypedStructList
, structSizes
, Super
, 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
class Parse t p | t -> p, p -> t where
parse :: U.ReadCtx m 'Const => R.Raw t 'Const -> m p
encode :: U.RWCtx m s => M.Message ('Mut s) -> p -> m (R.Raw t ('Mut s))
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 #-}
class (Parse t p, Allocate t) => EstimateAlloc t p where
estimateAlloc :: p -> AllocHint t
default estimateAlloc :: AllocHint t ~ () => p -> AllocHint t
estimateAlloc p
_ = ()
{-# INLINABLE estimateAlloc #-}
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
class Allocate a where
type AllocHint a
new :: U.RWCtx m s => AllocHint a -> M.Message ('Mut s) -> m (R.Raw a ('Mut s))
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))
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 #-}
class AllocateList a where
type ListAllocHint a
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)
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)
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)
class Parse t p => Marshal t p where
marshalInto :: U.RWCtx m s => R.Raw t ('Mut s) -> p -> m ()
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)
class HasTypeId a where
typeId :: Word64
class (R.IsStruct a, Allocate a, HasTypeId a, AllocHint a ~ ()) => TypedStruct a where
numStructWords :: Word16
numStructPtrs :: Word16
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
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
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 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
)
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 ()
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 #-}
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
]
class IsWord a where
fromWord :: Word64 -> a
toWord :: a -> Word64
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 #-}
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 #-}