{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# 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 Data.Word

import GHC.OverloadedLabels (IsLabel(..))
import GHC.TypeLits         (Symbol)

import qualified Capnp.Classes     as C
import qualified Capnp.Message     as M
import qualified Capnp.New.Classes as NC
import qualified Capnp.Repr        as R
import qualified Capnp.Untyped     as U

-- | 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
    = Slot
    -- ^ The field is a normal slot; it can be read and written as an
    -- individual value.
    | Group
    -- ^ The field is a group. Since this shares space with its parent struct
    -- access patterns are a bit different.
    deriving(Int -> FieldKind -> ShowS
[FieldKind] -> ShowS
FieldKind -> String
(Int -> FieldKind -> ShowS)
-> (FieldKind -> String)
-> ([FieldKind] -> ShowS)
-> Show FieldKind
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]
(Int -> ReadS FieldKind)
-> ReadS [FieldKind]
-> ReadPrec FieldKind
-> ReadPrec [FieldKind]
-> Read 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
(FieldKind -> FieldKind -> Bool)
-> (FieldKind -> FieldKind -> Bool) -> Eq FieldKind
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
    { DataFieldLoc sz -> BitCount
shift        :: !BitCount
    , DataFieldLoc sz -> Word16
index        :: !Word16
    , DataFieldLoc sz -> Word64
mask         :: !Word64
    , 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 (mut :: M.Mutability) a

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

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

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

instance
    ( NC.Allocate (Which a)
    , NC.AllocHint (Which a) ~ ()
    , NC.Parse (Which a) p
    ) => NC.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
    { Variant k a b -> Field k a b
field    :: !(Field k 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 = HasField name k a b => Field k a b
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 = HasVariant name k a b => Variant k a b
forall (name :: Symbol) (k :: FieldKind) a b.
HasVariant name k a b =>
Variant k a b
variantByLabel @name @k @a @b