{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Module: Capnp.Fields
-- Description: Support for working with struct fields
module Capnp.Fields
  ( HasField (..),
    Field (..),
    FieldLoc (..),
    DataFieldLoc (..),
    FieldKind (..),
    HasUnion (..),
    Variant (..),
    HasVariant (..),
  )
where

import Capnp.Bits
import qualified Capnp.Classes as C
import qualified Capnp.Message as M
import qualified Capnp.Repr as R
import qualified Capnp.Untyped as U
import Data.Word
import GHC.OverloadedLabels (IsLabel (..))
import GHC.TypeLits (Symbol)

-- | What sort of field is this? This corresponds to the slot/group variants
-- in the @Field@ type in schema.capnp. Mostly used at the type level with
-- the @DataKinds@ extension.
--
-- (Note that this has nothing to do with kinds in the usual type system sense
-- of the word).
data FieldKind
  = -- | The field is a normal slot; it can be read and written as an
    -- individual value.
    Slot
  | -- | The field is a group. Since this shares space with its parent struct
    -- access patterns are a bit different.
    Group
  deriving (Int -> FieldKind -> ShowS
[FieldKind] -> ShowS
FieldKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldKind] -> ShowS
$cshowList :: [FieldKind] -> ShowS
show :: FieldKind -> String
$cshow :: FieldKind -> String
showsPrec :: Int -> FieldKind -> ShowS
$cshowsPrec :: Int -> FieldKind -> ShowS
Show, ReadPrec [FieldKind]
ReadPrec FieldKind
Int -> ReadS FieldKind
ReadS [FieldKind]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FieldKind]
$creadListPrec :: ReadPrec [FieldKind]
readPrec :: ReadPrec FieldKind
$creadPrec :: ReadPrec FieldKind
readList :: ReadS [FieldKind]
$creadList :: ReadS [FieldKind]
readsPrec :: Int -> ReadS FieldKind
$creadsPrec :: Int -> ReadS FieldKind
Read, FieldKind -> FieldKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldKind -> FieldKind -> Bool
$c/= :: FieldKind -> FieldKind -> Bool
== :: FieldKind -> FieldKind -> Bool
$c== :: FieldKind -> FieldKind -> Bool
Eq)

-- | @'Field' k a b@ is a first-class representation of a field of type @b@ within
-- an @a@, where @a@ must be a struct type.
newtype Field (k :: FieldKind) a b = Field (FieldLoc k (R.ReprFor b))

-- | The location of a field within a message.
data FieldLoc (k :: FieldKind) (r :: R.Repr) where
  GroupField :: FieldLoc 'Group ('R.Ptr ('Just 'R.Struct))
  PtrField :: R.IsPtrRepr a => Word16 -> FieldLoc 'Slot ('R.Ptr a)
  DataField :: C.IsWord (R.UntypedData a) => DataFieldLoc a -> FieldLoc 'Slot ('R.Data a)
  VoidField :: FieldLoc 'Slot ('R.Data 'R.Sz0)

-- | The location of a data (non-pointer) field.
data DataFieldLoc (sz :: R.DataSz) = DataFieldLoc
  { forall (sz :: DataSz). DataFieldLoc sz -> BitCount
shift :: !BitCount,
    forall (sz :: DataSz). DataFieldLoc sz -> Word16
index :: !Word16,
    forall (sz :: DataSz). DataFieldLoc sz -> Word64
mask :: !Word64,
    forall (sz :: DataSz). DataFieldLoc sz -> Word64
defaultValue :: !Word64
  }

-- | An instance of 'HasUnion' indicates that the given type is a capnproto struct
-- (or group) with an anonymous union.
class R.IsStruct a => HasUnion a where
  -- | 'unionField' is a field holding the union's tag.
  unionField :: Field 'Slot a Word16

  -- | 'Which' is the abstract capnproto type of the union itself. Like
  -- generated struct types (in this case @a@), this is typically
  -- uninhabitied, and used to define instances and/or act as a phantom type.
  data Which a

  -- | Concrete view into a union embedded in a message. This will be a sum
  -- type with other 'Raw' values as arguments.
  data RawWhich a (mut :: M.Mutability)

  -- | Helper used in generated code to extract a 'RawWhich' from its
  -- surrounding struct.
  internalWhich :: U.ReadCtx m mut => Word16 -> R.Raw a mut -> m (RawWhich a mut)

type instance R.ReprFor (Which a) = 'R.Ptr ('Just 'R.Struct)

instance (C.Allocate a, HasUnion a, R.IsStruct (Which a)) => C.Allocate (Which a) where
  type AllocHint (Which a) = C.AllocHint a
  new :: forall (m :: * -> *) s.
RWCtx m s =>
AllocHint (Which a)
-> Message ('Mut s) -> m (Raw (Which a) ('Mut s))
new AllocHint (Which a)
hint Message ('Mut s)
msg = do
    R.Raw Unwrapped (Untyped (ReprFor a) ('Mut s))
struct <- forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
C.new @a AllocHint (Which a)
hint Message ('Mut s)
msg
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw Unwrapped (Untyped (ReprFor a) ('Mut s))
struct)

instance
  ( C.Allocate (Which a),
    C.AllocHint (Which a) ~ (),
    C.Parse (Which a) p
  ) =>
  C.EstimateAlloc (Which a) p

-- | @'Variant' k a b@ is a first-class representation of a variant of @a@'s
-- anonymous union, whose argument is of type @b@.
data Variant (k :: FieldKind) a b = Variant
  { forall (k :: FieldKind) a b. Variant k a b -> Field k a b
field :: !(Field k a b),
    forall (k :: FieldKind) a b. Variant k a b -> Word16
tagValue :: !Word16
  }

-- | An instance @'HasField' name k a b@ indicates that the struct type @a@
-- has a field named @name@ with type @b@ (with @k@ being the 'FieldKind' for
-- the field). The generated code includes instances of this for each field
-- in the schema.
class R.IsStruct a => HasField (name :: Symbol) k a b | a name -> k b where
  fieldByLabel :: Field k a b

instance HasField name k a b => IsLabel name (Field k a b) where
  fromLabel :: Field k a b
fromLabel = forall (name :: Symbol) (k :: FieldKind) a b.
HasField name k a b =>
Field k a b
fieldByLabel @name @k @a @b

-- | An instance @'HasVariant name k a b@ indicates that the struct type @a@
-- has an anonymous union with a variant named @name@, whose argument is of type
-- @b@.
class HasUnion a => HasVariant (name :: Symbol) k a b | a name -> k b where
  variantByLabel :: Variant k a b

instance HasVariant name k a b => IsLabel name (Variant k a b) where
  fromLabel :: Variant k a b
fromLabel = forall (name :: Symbol) (k :: FieldKind) a b.
HasVariant name k a b =>
Variant k a b
variantByLabel @name @k @a @b