{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Module: Capnp.Repr.Methods
-- Description: Support for working with methods
module Capnp.Repr.Methods
  ( Method (..),
    HasMethod (..),
    Pipeline (..),
    Client (..),
    pipe,
    pipelineClient,
    waitPipeline,
    AsClient (..),
    upcast,

    -- * Calling methods.
    callB,
    callR,
    callP,
  )
where

import qualified Capnp.Classes as C
import qualified Capnp.Fields as F
import Capnp.Message (Mutability (..), newMessage)
import qualified Capnp.Message as M
import qualified Capnp.Repr as R
import Capnp.Rpc.Common (Client (..), Pipeline (..))
import Capnp.Rpc.Promise (Promise, newPromise, wait)
import qualified Capnp.Rpc.Server as Server
import qualified Capnp.Rpc.Untyped as Rpc
import Capnp.TraversalLimit (evalLimitT)
import qualified Capnp.Untyped as U
import Control.Concurrent.STM (STM, atomically)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.STM.Class (MonadSTM (..))
import Data.Word
import GHC.OverloadedLabels (IsLabel (..))
import GHC.Prim (coerce)
import GHC.TypeLits (Symbol)
import GHC.Types (Coercible)
import Internal.BuildPure (PureBuilder, createPure)

-- | Represents a method on the interface type @c@ with parameter
-- type @p@ and return type @r@.
data Method c p r = Method
  { forall c p r. Method c p r -> Word64
interfaceId :: !Word64,
    forall c p r. Method c p r -> Word16
methodId :: !Word16
  }

-- | An instance @'HasMethod' name c p r@ indicates that the interface
-- type @c@ has a method named @name@ with parameter type @p@ and
-- return type @r@. The generated code includes instances of this
-- for each method in the schema.
class (R.IsCap c, R.IsStruct p, R.IsStruct r) => HasMethod (name :: Symbol) c p r | name c -> p r where
  methodByLabel :: Method c p r

instance HasMethod name c p r => IsLabel name (Method c p r) where
  fromLabel :: Method c p r
fromLabel = forall (name :: Symbol) c p r. HasMethod name c p r => Method c p r
methodByLabel @name @c @p @r

-- | The 'AsClient' class allows callers of rpc methods to abstract over 'Client's
-- and 'Pipeline's. @'asClient'@ converts either of those to a client so that
-- methods can be invoked on it.
class AsClient f where
  asClient :: MonadSTM m => R.IsCap c => f c -> m (Client c)

instance AsClient Pipeline where
  asClient :: forall (m :: * -> *) c.
(MonadSTM m, IsCap c) =>
Pipeline c -> m (Client c)
asClient = forall a (m :: * -> *).
(IsCap a, MonadSTM m) =>
Pipeline a -> m (Client a)
pipelineClient

instance AsClient Client where
  asClient :: forall (m :: * -> *) c.
(MonadSTM m, IsCap c) =>
Client c -> m (Client c)
asClient = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Upcast is a (safe) cast from an interface to one of its superclasses.
upcast :: (AsClient f, Coercible (f p) (f c), C.Super p c) => f c -> f p
upcast :: forall (f :: * -> *) p c.
(AsClient f, Coercible (f p) (f c), Super p c) =>
f c -> f p
upcast = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Call a method. Use the provided 'PureBuilder' to construct the parameters.
callB ::
  (AsClient f, R.IsCap c, R.IsStruct p, MonadIO m) =>
  Method c p r ->
  (forall s. PureBuilder s (R.Raw p ('Mut s))) ->
  f c ->
  m (Pipeline r)
callB :: forall (f :: * -> *) c p (m :: * -> *) r.
(AsClient f, IsCap c, IsStruct p, MonadIO m) =>
Method c p r
-> (forall s. PureBuilder s (Raw p ('Mut s)))
-> f c
-> m (Pipeline r)
callB Method c p r
method forall s. PureBuilder s (Raw p ('Mut s))
buildRaw f c
c = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  (Raw p 'Const
params :: R.Raw a 'Const) <- forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure forall a. Bounded a => a
maxBound (forall a (mut :: Mutability).
Raw a mut -> Unwrapped (Untyped (ReprFor a) mut)
R.fromRaw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. PureBuilder s (Raw p ('Mut s))
buildRaw)
  forall (f :: * -> *) c p (m :: * -> *) r.
(AsClient f, IsCap c, IsStruct p, MonadIO m) =>
Method c p r -> Raw p 'Const -> f c -> m (Pipeline r)
callR Method c p r
method Raw p 'Const
params f c
c

-- | Call a method, supplying the parameters as a 'Raw' struct.
callR ::
  (AsClient f, R.IsCap c, R.IsStruct p, MonadIO m) =>
  Method c p r ->
  R.Raw p 'Const ->
  f c ->
  m (Pipeline r)
callR :: forall (f :: * -> *) c p (m :: * -> *) r.
(AsClient f, IsCap c, IsStruct p, MonadIO m) =>
Method c p r -> Raw p 'Const -> f c -> m (Pipeline r)
callR Method c p r
method Raw p 'Const
arg f c
c = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Promise Pipeline
p <- forall a. STM a -> IO a
atomically (forall (f :: * -> *) c p r.
(AsClient f, IsCap c, IsStruct p) =>
Method c p r -> Raw p 'Const -> f c -> STM (Promise Pipeline)
startCallR Method c p r
method Raw p 'Const
arg f c
c)
  forall a. Pipeline -> Pipeline a
Pipeline forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => Promise a -> m a
wait Promise Pipeline
p

startCallR ::
  (AsClient f, R.IsCap c, R.IsStruct p) =>
  Method c p r ->
  R.Raw p 'Const ->
  f c ->
  STM (Promise Rpc.Pipeline)
startCallR :: forall (f :: * -> *) c p r.
(AsClient f, IsCap c, IsStruct p) =>
Method c p r -> Raw p 'Const -> f c -> STM (Promise Pipeline)
startCallR Method {Word64
interfaceId :: Word64
$sel:interfaceId:Method :: forall c p r. Method c p r -> Word64
interfaceId, Word16
methodId :: Word16
$sel:methodId:Method :: forall c p r. Method c p r -> Word16
methodId} (R.Raw Unwrapped (Untyped (ReprFor p) 'Const)
arg) f c
c = do
  Client Client
client <- forall (f :: * -> *) (m :: * -> *) c.
(AsClient f, MonadSTM m, IsCap c) =>
f c -> m (Client c)
asClient f c
c
  (Promise (Maybe (Ptr 'Const))
_, Fulfiller (Maybe (Ptr 'Const))
f) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
  forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m (Promise Pipeline)
Rpc.call
    Server.CallInfo
      { Word64
interfaceId :: Word64
interfaceId :: Word64
interfaceId,
        Word16
methodId :: Word16
methodId :: Word16
methodId,
        arguments :: Maybe (Ptr 'Const)
arguments = forall a. a -> Maybe a
Just (forall (mut :: Mutability). Struct mut -> Ptr mut
U.PtrStruct Unwrapped (Untyped (ReprFor p) 'Const)
arg),
        response :: Fulfiller (Maybe (Ptr 'Const))
response = Fulfiller (Maybe (Ptr 'Const))
f
      }
    Client
client

-- | Call a method, supplying the parmaeters in parsed form.
callP ::
  forall c p r f m pp.
  ( AsClient f,
    R.IsCap c,
    R.IsStruct p,
    C.Parse p pp,
    MonadIO m
  ) =>
  Method c p r ->
  pp ->
  f c ->
  m (Pipeline r)
callP :: forall c p r (f :: * -> *) (m :: * -> *) pp.
(AsClient f, IsCap c, IsStruct p, Parse p pp, MonadIO m) =>
Method c p r -> pp -> f c -> m (Pipeline r)
callP Method c p r
method pp
parsed f c
client = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Struct 'Const
struct <- forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure forall a. Bounded a => a
maxBound forall a b. (a -> b) -> a -> b
$ do
    Message ('Mut s)
msg <- forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
newMessage forall a. Maybe a
Nothing
    forall a (mut :: Mutability).
Raw a mut -> Unwrapped (Untyped (ReprFor a) mut)
R.fromRaw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t p (m :: * -> *) s.
(Parse t p, RWCtx m s) =>
Message ('Mut s) -> p -> m (Raw t ('Mut s))
C.encode Message ('Mut s)
msg pp
parsed
  forall (f :: * -> *) c p (m :: * -> *) r.
(AsClient f, IsCap c, IsStruct p, MonadIO m) =>
Method c p r -> Raw p 'Const -> f c -> m (Pipeline r)
callR Method c p r
method (forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw Struct 'Const
struct) f c
client

-- | Project a pipeline to a struct onto one of its pointer fields.
pipe ::
  ( R.IsStruct a,
    R.ReprFor b ~ 'R.Ptr pr
  ) =>
  F.Field k a b ->
  Pipeline a ->
  Pipeline b
pipe :: forall a b (pr :: Maybe PtrRepr) (k :: FieldKind).
(IsStruct a, ReprFor b ~ 'Ptr pr) =>
Field k a b -> Pipeline a -> Pipeline b
pipe (F.Field FieldLoc k (ReprFor b)
field) (Pipeline Pipeline
p) =
  case FieldLoc k (ReprFor b)
field of
    FieldLoc k (ReprFor b)
F.GroupField -> forall a. Pipeline -> Pipeline a
Pipeline Pipeline
p
    F.PtrField Word16
idx -> forall a. Pipeline -> Pipeline a
Pipeline (Pipeline -> Word16 -> Pipeline
Rpc.walkPipelinePtr Pipeline
p Word16
idx)

-- | Convert a 'Pipeline' for a capability into a 'Client'.
pipelineClient :: (R.IsCap a, MonadSTM m) => Pipeline a -> m (Client a)
pipelineClient :: forall a (m :: * -> *).
(IsCap a, MonadSTM m) =>
Pipeline a -> m (Client a)
pipelineClient (Pipeline Pipeline
p) =
  forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ forall a. Client -> Client a
Client forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSTM m => Pipeline -> m Client
Rpc.pipelineClient Pipeline
p

-- | Wait for the result of a pipeline, and return its value.
waitPipeline ::
  forall a m pr.
  ( 'R.Ptr pr ~ R.ReprFor a,
    R.IsPtrRepr pr,
    MonadSTM m
  ) =>
  Pipeline a ->
  m (R.Raw a 'Const)
waitPipeline :: forall a (m :: * -> *) (pr :: Maybe PtrRepr).
('Ptr pr ~ ReprFor a, IsPtrRepr pr, MonadSTM m) =>
Pipeline a -> m (Raw a 'Const)
waitPipeline (Pipeline Pipeline
p) =
  -- We need an instance of MonadLimit for IsPtrRepr's ReadCtx requirement,
  -- but none of the relevant instances do a lot of reading, so we just
  -- supply a low-ish arbitrary bound.
  forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
100 forall a b. (a -> b) -> a -> b
$ do
    Maybe (Ptr 'Const)
ptr <- forall (m :: * -> *).
MonadSTM m =>
Pipeline -> m (Maybe (Ptr 'Const))
Rpc.waitPipeline Pipeline
p
    forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 @pr Message 'Const
M.empty Maybe (Ptr 'Const)
ptr

instance R.ReprFor a ~ 'R.Ptr ('Just 'R.Cap) => Rpc.IsClient (Client a) where
  toClient :: Client a -> Client
toClient (Client Client
c) = Client
c
  fromClient :: Client -> Client a
fromClient = forall a. Client -> Client a
Client