{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
-- | Module: Capnp.Repr
-- Description: Type-level plumbing for wire-representations.
--
-- This module provides facilities for working with the wire
-- representations of capnproto objects at the type level. The most
-- central part of this module is the 'Repr' type.
--
-- Recommended reading: https://capnproto.org/encoding.html
module Capnp.Repr
    (
    -- * Type-level descriptions of wire representations.
      Repr(..)
    , PtrRepr(..)
    , ListRepr(..)
    , NormalListRepr(..)
    , DataSz(..)

    -- * Mapping representations to value types from "Capnp.Untyped"
    , Untyped
    , UntypedData
    , UntypedPtr
    , UntypedSomePtr
    , UntypedList
    , UntypedSomeList

    -- * Mapping types to their wire representations.
    , ReprFor
    , PtrReprFor

    -- * Relating the representations of lists & their elements.
    , ElemRepr
    , ListReprFor
    , Element(..)

    -- * Working with wire-encoded values
    , Raw(..)

    -- * Working with lists
    , List
    , length
    , index
    , setIndex

    -- * Working with pointers
    , IsPtrRepr(..)
    , IsListPtrRepr(..)

    -- * Allocating values
    , Allocate(..)

    -- * Shorthands for types
    , IsStruct
    , IsCap
    , IsPtr
    ) where

import Prelude hiding (length)

import qualified Capnp.Classes        as C
import qualified Capnp.Errors         as E
import           Capnp.Message        (Mutability(..))
import qualified Capnp.Message        as M
import           Capnp.TraversalLimit (evalLimitT)
import qualified Capnp.Untyped        as U
import           Control.Monad.Catch  (MonadThrow(..))
import           Data.Default         (Default(..))
import           Data.Int
import           Data.Kind            (Type)
import           Data.Maybe           (fromJust)
import           Data.Word
import           GHC.Generics         (Generic)
import qualified Language.Haskell.TH  as TH

-- | A 'Repr' describes a wire representation for a value. This is
-- mostly used at the type level (using DataKinds); types are
-- parametrized over representations.
data Repr
    = Ptr (Maybe PtrRepr)
    -- ^ Pointer type. 'Nothing' indicates an AnyPointer, 'Just' describes
    -- a more specific pointer type.
    | Data DataSz
    -- ^ Non-pointer type.
    deriving(Int -> Repr -> ShowS
[Repr] -> ShowS
Repr -> String
(Int -> Repr -> ShowS)
-> (Repr -> String) -> ([Repr] -> ShowS) -> Show Repr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Repr] -> ShowS
$cshowList :: [Repr] -> ShowS
show :: Repr -> String
$cshow :: Repr -> String
showsPrec :: Int -> Repr -> ShowS
$cshowsPrec :: Int -> Repr -> ShowS
Show)

-- | Information about the representation of a pointer type
data PtrRepr
    = Cap
    -- ^ Capability pointer.
    | List (Maybe ListRepr)
    -- ^ List pointer. 'Nothing' describes an AnyList, 'Just' describes
    -- more specific list types.
    | Struct
    -- ^ A struct (or group).
    deriving(Int -> PtrRepr -> ShowS
[PtrRepr] -> ShowS
PtrRepr -> String
(Int -> PtrRepr -> ShowS)
-> (PtrRepr -> String) -> ([PtrRepr] -> ShowS) -> Show PtrRepr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PtrRepr] -> ShowS
$cshowList :: [PtrRepr] -> ShowS
show :: PtrRepr -> String
$cshow :: PtrRepr -> String
showsPrec :: Int -> PtrRepr -> ShowS
$cshowsPrec :: Int -> PtrRepr -> ShowS
Show)

-- | Information about the representation of a list type.
data ListRepr where
    -- | A "normal" list
    ListNormal :: NormalListRepr -> ListRepr
    ListComposite :: ListRepr
    deriving(Int -> ListRepr -> ShowS
[ListRepr] -> ShowS
ListRepr -> String
(Int -> ListRepr -> ShowS)
-> (ListRepr -> String) -> ([ListRepr] -> ShowS) -> Show ListRepr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ListRepr] -> ShowS
$cshowList :: [ListRepr] -> ShowS
show :: ListRepr -> String
$cshow :: ListRepr -> String
showsPrec :: Int -> ListRepr -> ShowS
$cshowsPrec :: Int -> ListRepr -> ShowS
Show)

-- | Information about the representation of a normal (non-composite) list.
data NormalListRepr where
    ListData :: DataSz -> NormalListRepr
    ListPtr :: NormalListRepr
    deriving(Int -> NormalListRepr -> ShowS
[NormalListRepr] -> ShowS
NormalListRepr -> String
(Int -> NormalListRepr -> ShowS)
-> (NormalListRepr -> String)
-> ([NormalListRepr] -> ShowS)
-> Show NormalListRepr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormalListRepr] -> ShowS
$cshowList :: [NormalListRepr] -> ShowS
show :: NormalListRepr -> String
$cshow :: NormalListRepr -> String
showsPrec :: Int -> NormalListRepr -> ShowS
$cshowsPrec :: Int -> NormalListRepr -> ShowS
Show)

-- | The size of a non-pointer type. @SzN@ represents an @N@-bit value.
data DataSz = Sz0 | Sz1 | Sz8 | Sz16 | Sz32 | Sz64
    deriving(Int -> DataSz -> ShowS
[DataSz] -> ShowS
DataSz -> String
(Int -> DataSz -> ShowS)
-> (DataSz -> String) -> ([DataSz] -> ShowS) -> Show DataSz
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataSz] -> ShowS
$cshowList :: [DataSz] -> ShowS
show :: DataSz -> String
$cshow :: DataSz -> String
showsPrec :: Int -> DataSz -> ShowS
$cshowsPrec :: Int -> DataSz -> ShowS
Show)

-- | @Untyped mut r@ is an untyped value with representation @r@ stored in
-- a message with mutability @mut@.
type family Untyped (mut :: Mutability) (r :: Repr) :: Type where
    Untyped mut ('Data sz) = UntypedData sz
    Untyped mut ('Ptr ptr) = UntypedPtr mut ptr

-- | @UntypedData sz@ is an untyped value with size @sz@.
type family UntypedData (sz :: DataSz) :: Type where
    UntypedData 'Sz0 = ()
    UntypedData 'Sz1 = Bool
    UntypedData 'Sz8 = Word8
    UntypedData 'Sz16 = Word16
    UntypedData 'Sz32 = Word32
    UntypedData 'Sz64 = Word64

-- | Like 'Untyped', but for pointers only.
type family UntypedPtr (mut :: Mutability) (r :: Maybe PtrRepr) :: Type where
    UntypedPtr mut 'Nothing = Maybe (U.Ptr mut)
    UntypedPtr mut ('Just r) = UntypedSomePtr mut r

-- | Like 'UntypedPtr', but doesn't allow AnyPointers.
type family UntypedSomePtr (mut :: Mutability) (r :: PtrRepr) :: Type where
    UntypedSomePtr mut 'Struct = U.Struct mut
    UntypedSomePtr mut 'Cap = U.Cap mut
    UntypedSomePtr mut ('List r) = UntypedList mut r

-- | Like 'Untyped', but for lists only.
type family UntypedList (mut :: Mutability) (r :: Maybe ListRepr) :: Type where
    UntypedList mut 'Nothing = U.List mut
    UntypedList mut ('Just r) = UntypedSomeList mut r

-- | Like 'UntypedList', but doesn't allow AnyLists.
type family UntypedSomeList (mut :: Mutability) (r :: ListRepr) :: Type where
    UntypedSomeList mut r = U.ListOf mut (Untyped mut (ElemRepr r))


-- | An instace of @'Allocate'@ specifies how to allocate a value with a given representation.
-- This only makes sense for pointers of course, so it is defined on PtrRepr. Of the well-kinded
-- types, only @'List 'Nothing@ is missing an instance.
class Allocate (r :: PtrRepr) where
    -- | Extra information needed to allocate a value:
    --
    -- * For structs, the sizes of the sections.
    -- * For capabilities, the client to attach to the messages.
    -- * For lists, the length, and for composite lists, the struct sizes as well.
    type AllocHint r

    -- | Allocate a value of the given type.
    alloc :: U.RWCtx m s => M.Message ('Mut s) -> AllocHint r -> m (UntypedSomePtr ('Mut s) r)

-- | @'ReprFor' a@ denotes the Cap'n Proto wire represent of the type @a@.
type family ReprFor (a :: Type) :: Repr

type instance ReprFor () = 'Data 'Sz0
type instance ReprFor Bool = 'Data 'Sz1
type instance ReprFor Word8 = 'Data 'Sz8
type instance ReprFor Word16 = 'Data 'Sz16
type instance ReprFor Word32 = 'Data 'Sz32
type instance ReprFor Word64 = 'Data 'Sz64
type instance ReprFor Int8 = 'Data 'Sz8
type instance ReprFor Int16 = 'Data 'Sz16
type instance ReprFor Int32 = 'Data 'Sz32
type instance ReprFor Int64 = 'Data 'Sz64
type instance ReprFor Float = 'Data 'Sz32
type instance ReprFor Double = 'Data 'Sz64

type instance ReprFor (U.ListOf mut a) = ReprFor (List a)
type instance ReprFor (U.Struct mut) = 'Ptr ('Just 'Struct)
type instance ReprFor (U.Cap mut) = 'Ptr ('Just 'Cap)
type instance ReprFor (U.Ptr mut) = 'Ptr 'Nothing
type instance ReprFor (U.List mut) = 'Ptr ('Just ('List 'Nothing))

type instance ReprFor (List a) = 'Ptr ('Just ('List ('Just (ListReprFor (ReprFor a)))))

-- | @PtrReprFor r@ extracts the pointer represnetation in r; undefined if
-- r is not a pointer representation.
type family PtrReprFor (r :: Repr) :: Maybe PtrRepr where
    PtrReprFor ('Ptr pr) = pr

-- | @ElemRepr r@ is the representation of elements of lists with
-- representation @r@.
type family ElemRepr (rl :: ListRepr) :: Repr where
    ElemRepr 'ListComposite = 'Ptr ('Just 'Struct)
    ElemRepr ('ListNormal 'ListPtr) = 'Ptr 'Nothing
    ElemRepr ('ListNormal ('ListData sz)) = 'Data sz

-- | @ListReprFor e@ is the representation of lists with elements
-- whose representation is @e@.
type family ListReprFor (e :: Repr) :: ListRepr where
    ListReprFor ('Data sz) = 'ListNormal ('ListData sz)
    ListReprFor ('Ptr ('Just 'Struct)) = 'ListComposite
    ListReprFor ('Ptr a) = 'ListNormal 'ListPtr

-- | 'Element' supports converting between values of representation
-- @'ElemRepr' ('ListReprFor' r)@ and values of representation @r@.
--
-- At a glance, you might expect this to just be a no-op, but it is actually
-- *not* always the case that @'ElemRepr' ('ListReprFor' r) ~ r@; in the
-- case of pointer types, @'ListReprFor' r@ can contain arbitrary pointers,
-- so information is lost, and it is possible for the list to contain pointers
-- of the incorrect type. In this case, 'fromElement' will throw an error.
--
-- 'toElement' is more trivial.
class Element (r :: Repr) where
    fromElement
        :: forall m mut. U.ReadCtx m mut
        => M.Message mut
        -> Untyped mut (ElemRepr (ListReprFor r))
        -> m (Untyped mut r)
    toElement :: Untyped mut r -> Untyped mut (ElemRepr (ListReprFor r))

instance Element ('Data sz) where
    fromElement :: Message mut
-> Untyped mut (ElemRepr (ListReprFor ('Data sz)))
-> m (Untyped mut ('Data sz))
fromElement Message mut
_ = Untyped mut (ElemRepr (ListReprFor ('Data sz)))
-> m (Untyped mut ('Data sz))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    toElement :: Untyped mut ('Data sz)
-> Untyped mut (ElemRepr (ListReprFor ('Data sz)))
toElement = Untyped mut ('Data sz)
-> Untyped mut (ElemRepr (ListReprFor ('Data sz)))
forall a. a -> a
id
instance Element ('Ptr ('Just 'Struct)) where
    fromElement :: Message mut
-> Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just 'Struct))))
-> m (Untyped mut ('Ptr ('Just 'Struct)))
fromElement Message mut
_ = Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just 'Struct))))
-> m (Untyped mut ('Ptr ('Just 'Struct)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    toElement :: Untyped mut ('Ptr ('Just 'Struct))
-> Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just 'Struct))))
toElement = Untyped mut ('Ptr ('Just 'Struct))
-> Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just 'Struct))))
forall a. a -> a
id
instance Element ('Ptr 'Nothing) where
    fromElement :: Message mut
-> Untyped mut (ElemRepr (ListReprFor ('Ptr 'Nothing)))
-> m (Untyped mut ('Ptr 'Nothing))
fromElement Message mut
_ = Untyped mut (ElemRepr (ListReprFor ('Ptr 'Nothing)))
-> m (Untyped mut ('Ptr 'Nothing))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    toElement :: Untyped mut ('Ptr 'Nothing)
-> Untyped mut (ElemRepr (ListReprFor ('Ptr 'Nothing)))
toElement = Untyped mut ('Ptr 'Nothing)
-> Untyped mut (ElemRepr (ListReprFor ('Ptr 'Nothing)))
forall a. a -> a
id
instance Element ('Ptr ('Just 'Cap)) where
    fromElement :: Message mut
-> Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just 'Cap))))
-> m (Untyped mut ('Ptr ('Just 'Cap)))
fromElement = forall (m :: * -> *) (mut :: Mutability).
(IsPtrRepr ('Just 'Cap), ReadCtx m mut) =>
Message mut
-> Maybe (Ptr mut) -> m (Untyped mut ('Ptr ('Just 'Cap)))
forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut -> Maybe (Ptr mut) -> m (Untyped mut ('Ptr r))
fromPtr @('Just 'Cap)
    toElement :: Untyped mut ('Ptr ('Just 'Cap))
-> Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just 'Cap))))
toElement = Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Ptr mut -> Maybe (Ptr mut))
-> (Cap mut -> Ptr mut) -> Cap mut -> Maybe (Ptr mut)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cap mut -> Ptr mut
forall (mut :: Mutability). Cap mut -> Ptr mut
U.PtrCap
instance IsPtrRepr ('Just ('List a)) => Element ('Ptr ('Just ('List a))) where
    fromElement :: Message mut
-> Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just ('List a)))))
-> m (Untyped mut ('Ptr ('Just ('List a))))
fromElement = forall (m :: * -> *) (mut :: Mutability).
(IsPtrRepr ('Just ('List a)), ReadCtx m mut) =>
Message mut
-> Maybe (Ptr mut) -> m (Untyped mut ('Ptr ('Just ('List a))))
forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut -> Maybe (Ptr mut) -> m (Untyped mut ('Ptr r))
fromPtr @('Just ('List a))
    toElement :: Untyped mut ('Ptr ('Just ('List a)))
-> Untyped mut (ElemRepr (ListReprFor ('Ptr ('Just ('List a)))))
toElement = forall (mut :: Mutability).
IsPtrRepr ('Just ('List a)) =>
Untyped mut ('Ptr ('Just ('List a))) -> Maybe (Ptr mut)
forall (r :: Maybe PtrRepr) (mut :: Mutability).
IsPtrRepr r =>
Untyped mut ('Ptr r) -> Maybe (Ptr mut)
toPtr @('Just ('List a))

-- | A @'Raw' mut a@ is an @a@ embedded in a capnproto message with mutability
-- @mut@.
newtype Raw (mut :: Mutability) (a :: Type)
    = Raw { Raw mut a -> Untyped mut (ReprFor a)
fromRaw :: Untyped mut (ReprFor a) }

deriving instance Show (Untyped mut (ReprFor a)) => Show (Raw mut a)
deriving instance Read (Untyped mut (ReprFor a)) => Read (Raw mut a)
deriving instance Eq (Untyped mut (ReprFor a)) => Eq (Raw mut a)
deriving instance Generic (Untyped mut (ReprFor a)) => Generic (Raw mut a)

-- | A phantom type denoting capnproto lists of type @a@.
data List a

-- | Get the length of a capnproto list.
length :: Raw mut (List a) -> Int
length :: Raw mut (List a) -> Int
length (Raw Untyped mut (ReprFor (List a))
l) = ListOf mut (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
-> Int
forall (msg :: Mutability) a. ListOf msg a -> Int
U.length ListOf mut (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
Untyped mut (ReprFor (List a))
l

-- | @'index' i list@ gets the @i@th element of the list.
index :: forall a m mut.
    ( U.ReadCtx m mut
    , Element (ReprFor a)
    ) => Int -> Raw mut (List a) -> m (Raw mut a)
index :: Int -> Raw mut (List a) -> m (Raw mut a)
index Int
i (Raw Untyped mut (ReprFor (List a))
l) =
    Untyped mut (ReprFor a) -> Raw mut a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
Raw (Untyped mut (ReprFor a) -> Raw mut a)
-> m (Untyped mut (ReprFor a)) -> m (Raw mut a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
-> ListOf mut (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
-> m (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
forall (m :: * -> *) (mut :: Mutability) a.
ReadCtx m mut =>
Int -> ListOf mut a -> m a
U.index Int
i ListOf mut (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
Untyped mut (ReprFor (List a))
l m (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
-> (Untyped mut (ElemRepr (ListReprFor (ReprFor a)))
    -> m (Untyped mut (ReprFor a)))
-> m (Untyped mut (ReprFor a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message mut
-> Untyped mut (ElemRepr (ListReprFor (ReprFor a)))
-> m (Untyped mut (ReprFor a))
forall (r :: Repr) (m :: * -> *) (mut :: Mutability).
(Element r, ReadCtx m mut) =>
Message mut
-> Untyped mut (ElemRepr (ListReprFor r)) -> m (Untyped mut r)
fromElement @(ReprFor a) @m @mut (ListOf mut (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
-> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
U.message ListOf mut (Untyped mut (ElemRepr (ListReprFor (ReprFor a))))
Untyped mut (ReprFor (List a))
l))

-- | @'setIndex' value i list@ sets the @i@th element of @list@ to @value@.
setIndex :: forall a m s.
    ( U.RWCtx m s
    , Element (ReprFor a)
    ) => Raw ('Mut s) a -> Int -> Raw ('Mut s) (List a) -> m ()
setIndex :: Raw ('Mut s) a -> Int -> Raw ('Mut s) (List a) -> m ()
setIndex (Raw Untyped ('Mut s) (ReprFor a)
v) Int
i (Raw Untyped ('Mut s) (ReprFor (List a))
l) = Untyped ('Mut s) (ElemRepr (ListReprFor (ReprFor a)))
-> Int
-> ListOf
     ('Mut s) (Untyped ('Mut s) (ElemRepr (ListReprFor (ReprFor a))))
-> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
a -> Int -> ListOf ('Mut s) a -> m ()
U.setIndex (Untyped ('Mut s) (ReprFor a)
-> Untyped ('Mut s) (ElemRepr (ListReprFor (ReprFor a)))
forall (r :: Repr) (mut :: Mutability).
Element r =>
Untyped mut r -> Untyped mut (ElemRepr (ListReprFor r))
toElement @(ReprFor a) @('Mut s) Untyped ('Mut s) (ReprFor a)
v) Int
i ListOf
  ('Mut s) (Untyped ('Mut s) (ElemRepr (ListReprFor (ReprFor a))))
Untyped ('Mut s) (ReprFor (List a))
l

instance (ReprFor a ~ 'Ptr ('Just 'Struct)) => C.ToStruct mut (Raw mut a) where
    toStruct :: Raw mut a -> Struct mut
toStruct = Raw mut a -> Struct mut
forall (mut :: Mutability) a. Raw mut a -> Untyped mut (ReprFor a)
fromRaw
instance (ReprFor a ~ 'Ptr ('Just 'Struct)) => C.FromStruct mut (Raw mut a) where
    fromStruct :: Struct mut -> m (Raw mut a)
fromStruct = Raw mut a -> m (Raw mut a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Raw mut a -> m (Raw mut a))
-> (Struct mut -> Raw mut a) -> Struct mut -> m (Raw mut a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct mut -> Raw mut a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
Raw

instance U.HasMessage (Untyped mut (ReprFor a)) mut => U.HasMessage (Raw mut a) mut where
    message :: Raw mut a -> Message mut
message (Raw Untyped mut (ReprFor a)
r) = Untyped mut (ReprFor a) -> Message mut
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
U.message Untyped mut (ReprFor a)
r
instance U.MessageDefault (Untyped mut (ReprFor a)) mut => U.MessageDefault (Raw mut a) mut where
    messageDefault :: Message mut -> m (Raw mut a)
messageDefault Message mut
msg = Untyped mut (ReprFor a) -> Raw mut a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
Raw (Untyped mut (ReprFor a) -> Raw mut a)
-> m (Untyped mut (ReprFor a)) -> m (Raw mut a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> m (Untyped mut (ReprFor a))
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
U.messageDefault Message mut
msg

instance U.MessageDefault (Raw 'Const a) 'Const => Default (Raw 'Const a) where
    def :: Raw 'Const a
def = 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
$ Message 'Const -> LimitT Maybe (Raw 'Const a)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
U.messageDefault Message 'Const
M.empty

-- | Operations on types with pointer representations.
class IsPtrRepr (r :: Maybe PtrRepr) where
    toPtr :: Untyped mut ('Ptr r) -> Maybe (U.Ptr mut)
    -- ^ Convert an untyped value of this representation to an AnyPointer.
    fromPtr :: U.ReadCtx m mut => M.Message mut -> Maybe (U.Ptr mut) -> m (Untyped mut ('Ptr r))
    -- ^ Extract a value with this representation from an AnyPointer, failing
    -- if the pointer is the wrong type for this representation.

instance IsPtrRepr 'Nothing where
    toPtr :: Untyped mut ('Ptr 'Nothing) -> Maybe (Ptr mut)
toPtr Untyped mut ('Ptr 'Nothing)
p = Maybe (Ptr mut)
Untyped mut ('Ptr 'Nothing)
p
    fromPtr :: Message mut -> Maybe (Ptr mut) -> m (Untyped mut ('Ptr 'Nothing))
fromPtr Message mut
_ Maybe (Ptr mut)
p = Maybe (Ptr mut) -> m (Maybe (Ptr mut))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ptr mut)
p

instance IsPtrRepr ('Just 'Struct) where
    toPtr :: Untyped mut ('Ptr ('Just 'Struct)) -> Maybe (Ptr mut)
toPtr Untyped mut ('Ptr ('Just 'Struct))
s = Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Struct mut -> Ptr mut
forall (mut :: Mutability). Struct mut -> Ptr mut
U.PtrStruct Struct mut
Untyped mut ('Ptr ('Just 'Struct))
s)
    fromPtr :: Message mut
-> Maybe (Ptr mut) -> m (Untyped mut ('Ptr ('Just 'Struct)))
fromPtr Message mut
msg Maybe (Ptr mut)
Nothing              = Message mut -> m (Struct mut)
forall a (mut :: Mutability) (m :: * -> *).
(MessageDefault a mut, ReadCtx m mut) =>
Message mut -> m a
U.messageDefault Message mut
msg
    fromPtr Message mut
_ (Just (U.PtrStruct Struct mut
s)) = Struct mut -> m (Struct mut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct mut
s
    fromPtr Message mut
_ Maybe (Ptr mut)
_                      = String -> m (Struct mut)
forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to struct"
instance IsPtrRepr ('Just 'Cap) where
    toPtr :: Untyped mut ('Ptr ('Just 'Cap)) -> Maybe (Ptr mut)
toPtr Untyped mut ('Ptr ('Just 'Cap))
c = Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (Cap mut -> Ptr mut
forall (mut :: Mutability). Cap mut -> Ptr mut
U.PtrCap Cap mut
Untyped mut ('Ptr ('Just 'Cap))
c)
    fromPtr :: Message mut
-> Maybe (Ptr mut) -> m (Untyped mut ('Ptr ('Just 'Cap)))
fromPtr Message mut
_ Maybe (Ptr mut)
Nothing             = String -> m (Cap mut)
forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to capability"
    fromPtr Message mut
_ (Just (U.PtrCap Cap mut
c)) = Cap mut -> m (Cap mut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cap mut
c
    fromPtr Message mut
_ Maybe (Ptr mut)
_                   = String -> m (Cap mut)
forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to capability"
instance IsPtrRepr ('Just ('List 'Nothing)) where
    toPtr :: Untyped mut ('Ptr ('Just ('List 'Nothing))) -> Maybe (Ptr mut)
toPtr Untyped mut ('Ptr ('Just ('List 'Nothing)))
l = Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (List mut -> Ptr mut
forall (mut :: Mutability). List mut -> Ptr mut
U.PtrList List mut
Untyped mut ('Ptr ('Just ('List 'Nothing)))
l)
    fromPtr :: Message mut
-> Maybe (Ptr mut)
-> m (Untyped mut ('Ptr ('Just ('List 'Nothing))))
fromPtr Message mut
_ Maybe (Ptr mut)
Nothing              = String -> m (List mut)
forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to list"
    fromPtr Message mut
_ (Just (U.PtrList List mut
l)) = List mut -> m (List mut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure List mut
l
    fromPtr Message mut
_ (Just Ptr mut
_)             = String -> m (List mut)
forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to list"
instance IsListPtrRepr r => IsPtrRepr ('Just ('List ('Just r))) where
    toPtr :: Untyped mut ('Ptr ('Just ('List ('Just r)))) -> Maybe (Ptr mut)
toPtr Untyped mut ('Ptr ('Just ('List ('Just r))))
l = Ptr mut -> Maybe (Ptr mut)
forall a. a -> Maybe a
Just (List mut -> Ptr mut
forall (mut :: Mutability). List mut -> Ptr mut
U.PtrList (UntypedSomeList mut r -> List mut
forall (r :: ListRepr) (mut :: Mutability).
IsListPtrRepr r =>
UntypedSomeList mut r -> List mut
rToList @r UntypedSomeList mut r
Untyped mut ('Ptr ('Just ('List ('Just r))))
l))
    fromPtr :: Message mut
-> Maybe (Ptr mut)
-> m (Untyped mut ('Ptr ('Just ('List ('Just r)))))
fromPtr Message mut
msg Maybe (Ptr mut)
Nothing            = Message mut -> m (UntypedSomeList mut r)
forall (r :: ListRepr) (m :: * -> *) (mut :: Mutability).
(IsListPtrRepr r, ReadCtx m mut) =>
Message mut -> m (UntypedSomeList mut r)
rFromListMsg @r Message mut
msg
    fromPtr Message mut
_ (Just (U.PtrList List mut
l)) = List mut -> m (UntypedSomeList mut r)
forall (r :: ListRepr) (m :: * -> *) (mut :: Mutability).
(IsListPtrRepr r, ReadCtx m mut) =>
List mut -> m (UntypedSomeList mut r)
rFromList @r List mut
l
    fromPtr Message mut
_ (Just Ptr mut
_)             = String -> m (ListOf mut (Untyped mut (ElemRepr r)))
forall (m :: * -> *) a. MonadThrow m => String -> m a
expected String
"pointer to list"

-- | Operations on types with list representations.
class IsListPtrRepr (r :: ListRepr) where
    rToList :: UntypedSomeList mut r -> U.List mut
    -- ^ Convert an untyped value of this representation to an AnyList.
    rFromList :: U.ReadCtx m mut => U.List mut -> m (UntypedSomeList mut r)
    -- ^ Extract a value with this representation from an AnyList, failing
    -- if the list is the wrong type for this representation.
    rFromListMsg :: U.ReadCtx m mut => M.Message mut -> m (UntypedSomeList mut r)
    -- ^ Create a zero-length value with this representation, living in the
    -- provided message.

-- helper function for throwing SchemaViolationError "expected ..."
expected :: MonadThrow m => String -> m a
expected :: String -> m a
expected String
msg = Error -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ String -> Error
E.SchemaViolationError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

do
    let mkIsListPtrRepr (r, listC, str) =
            [d| instance IsListPtrRepr $r where
                    rToList = $(pure $ TH.ConE listC)
                    rFromList $(pure $ TH.ConP listC [TH.VarP (TH.mkName "l")]) = pure l
                    rFromList _ = expected $(pure $ TH.LitE $ TH.StringL $ "pointer to " ++ str)
                    rFromListMsg = U.messageDefault
            |]
    concat <$> traverse mkIsListPtrRepr
        [ ( [t| 'ListNormal ('ListData 'Sz0) |]
          , 'U.List0
          , "List(Void)"
          )
        , ( [t| 'ListNormal ('ListData 'Sz1) |]
          , 'U.List1
          , "List(Bool)"
          )
        , ( [t| 'ListNormal ('ListData 'Sz8) |]
          , 'U.List8
          , "List(UInt8)"
          )
        , ( [t| 'ListNormal ('ListData 'Sz16) |]
          , 'U.List16
          , "List(UInt16)"
          )
        , ( [t| 'ListNormal ('ListData 'Sz32) |]
          , 'U.List32
          , "List(UInt32)"
          )
        , ( [t| 'ListNormal ('ListData 'Sz64) |]
          , 'U.List64
          , "List(UInt64)"
          )
        , ( [t| 'ListNormal 'ListPtr |]
          , 'U.ListPtr
          , "List(AnyPointer)"
          )
        , ( [t| 'ListComposite |]
          , 'U.ListStruct
          , "composite list"
          )
        ]

instance (IsPtrRepr r, ReprFor a ~ 'Ptr r) => C.ToPtr s (Raw ('Mut s) a) where
    toPtr :: Message ('Mut s) -> Raw ('Mut s) a -> m (Maybe (Ptr ('Mut s)))
toPtr Message ('Mut s)
_msg (Raw Untyped ('Mut s) (ReprFor a)
p) = Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s))))
-> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall a b. (a -> b) -> a -> b
$ Untyped ('Mut s) ('Ptr r) -> Maybe (Ptr ('Mut s))
forall (r :: Maybe PtrRepr) (mut :: Mutability).
IsPtrRepr r =>
Untyped mut ('Ptr r) -> Maybe (Ptr mut)
toPtr @r Untyped ('Mut s) (ReprFor a)
Untyped ('Mut s) ('Ptr r)
p
instance (IsPtrRepr r, ReprFor a ~ 'Ptr r) => C.FromPtr mut (Raw mut a) where
    fromPtr :: Message mut -> Maybe (Ptr mut) -> m (Raw mut a)
fromPtr Message mut
msg Maybe (Ptr mut)
p = UntypedPtr mut r -> Raw mut a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
Raw (UntypedPtr mut r -> Raw mut a)
-> m (UntypedPtr mut r) -> m (Raw mut a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message mut -> Maybe (Ptr mut) -> m (Untyped mut ('Ptr r))
forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut -> Maybe (Ptr mut) -> m (Untyped mut ('Ptr r))
fromPtr @r Message mut
msg Maybe (Ptr mut)
p

instance Allocate 'Struct where
    type AllocHint 'Struct = (Word16, Word16)
    alloc :: Message ('Mut s)
-> AllocHint 'Struct -> m (UntypedSomePtr ('Mut s) 'Struct)
alloc Message ('Mut s)
msg = (Word16 -> Word16 -> m (Struct ('Mut s)))
-> (Word16, Word16) -> m (Struct ('Mut s))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))
U.allocStruct Message ('Mut s)
msg)
instance Allocate 'Cap where
    type AllocHint 'Cap = M.Client
    alloc :: Message ('Mut s)
-> AllocHint 'Cap -> m (UntypedSomePtr ('Mut s) 'Cap)
alloc = Message ('Mut s)
-> AllocHint 'Cap -> m (UntypedSomePtr ('Mut s) 'Cap)
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m (Cap ('Mut s))
U.appendCap
instance Allocate ('List ('Just 'ListComposite)) where
    type AllocHint ('List ('Just 'ListComposite)) = (Int, AllocHint 'Struct)
    alloc :: Message ('Mut s)
-> AllocHint ('List ('Just 'ListComposite))
-> m (UntypedSomePtr ('Mut s) ('List ('Just 'ListComposite)))
alloc Message ('Mut s)
msg (len, (nWords, nPtrs)) = Message ('Mut s)
-> Word16 -> Word16 -> Int -> m (ListOf ('Mut s) (Struct ('Mut s)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Word16 -> Word16 -> Int -> m (ListOf ('Mut s) (Struct ('Mut s)))
U.allocCompositeList Message ('Mut s)
msg Word16
nWords Word16
nPtrs Int
len
instance AllocateNormalList r => Allocate ('List ('Just ('ListNormal r))) where
    type AllocHint ('List ('Just ('ListNormal r))) = Int
    alloc :: Message ('Mut s)
-> AllocHint ('List ('Just ('ListNormal r)))
-> m (UntypedSomePtr ('Mut s) ('List ('Just ('ListNormal r))))
alloc = forall (m :: * -> *) s.
(AllocateNormalList r, RWCtx m s) =>
Message ('Mut s)
-> Int -> m (UntypedSomeList ('Mut s) ('ListNormal r))
forall (r :: NormalListRepr) (m :: * -> *) s.
(AllocateNormalList r, RWCtx m s) =>
Message ('Mut s)
-> Int -> m (UntypedSomeList ('Mut s) ('ListNormal r))
allocNormalList @r

class AllocateNormalList (r :: NormalListRepr) where
    allocNormalList :: U.RWCtx m s => M.Message ('Mut s) -> Int -> m (UntypedSomeList ('Mut s) ('ListNormal r))
instance AllocateNormalList ('ListData 'Sz0) where allocNormalList :: Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz0)))
allocNormalList = Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz0)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) ())
U.allocList0
instance AllocateNormalList ('ListData 'Sz1) where allocNormalList :: Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz1)))
allocNormalList = Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz1)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Bool)
U.allocList1
instance AllocateNormalList ('ListData 'Sz8) where allocNormalList :: Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz8)))
allocNormalList = Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz8)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word8)
U.allocList8
instance AllocateNormalList ('ListData 'Sz16) where allocNormalList :: Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz16)))
allocNormalList = Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz16)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word16)
U.allocList16
instance AllocateNormalList ('ListData 'Sz32) where allocNormalList :: Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz32)))
allocNormalList = Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz32)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word32)
U.allocList32
instance AllocateNormalList ('ListData 'Sz64) where allocNormalList :: Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz64)))
allocNormalList = Message ('Mut s)
-> Int
-> m (UntypedSomeList ('Mut s) ('ListNormal ('ListData 'Sz64)))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word64)
U.allocList64
instance AllocateNormalList 'ListPtr where allocNormalList :: Message ('Mut s)
-> Int -> m (UntypedSomeList ('Mut s) ('ListNormal 'ListPtr))
allocNormalList = Message ('Mut s)
-> Int -> m (UntypedSomeList ('Mut s) ('ListNormal 'ListPtr))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s)
-> Int -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))
U.allocListPtr


-- | Constraint that @a@ is a struct type.
type IsStruct a = ReprFor a ~ 'Ptr ('Just 'Struct)

-- | Constraint that @a@ is a capability type.
type IsCap a = ReprFor a ~ 'Ptr ('Just 'Cap)

-- | Constraint that @a@ is a pointer type.
type IsPtr a =
    ( ReprFor a ~ 'Ptr (PtrReprFor (ReprFor a))
    , IsPtrRepr (PtrReprFor (ReprFor a))
    )