{-# 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.Fields            as F
import           Capnp.Message           (Mutability(..), newMessage)
import qualified Capnp.Message           as M
import qualified Capnp.New.Classes       as NC
import qualified Capnp.Repr              as R
import           Capnp.Rpc.Promise       (newPromise)
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.Monad.Catch     (MonadThrow)
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
    { Method c p r -> Word64
interfaceId :: !Word64
    , 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 = HasMethod name c p r => Method c p r
forall (name :: Symbol) c p r. HasMethod name c p r => Method c p r
methodByLabel @name @c @p @r

-- | A @'Pipeline' a@ is a reference to possibly-not-resolved result from
-- a method call.
newtype Pipeline a = Pipeline Rpc.Pipeline

newtype Client a = Client Rpc.Client
    deriving(Int -> Client a -> ShowS
[Client a] -> ShowS
Client a -> String
(Int -> Client a -> ShowS)
-> (Client a -> String) -> ([Client a] -> ShowS) -> Show (Client a)
forall a. Int -> Client a -> ShowS
forall a. [Client a] -> ShowS
forall a. Client a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Client a] -> ShowS
$cshowList :: forall a. [Client a] -> ShowS
show :: Client a -> String
$cshow :: forall a. Client a -> String
showsPrec :: Int -> Client a -> ShowS
$cshowsPrec :: forall a. Int -> Client a -> ShowS
Show, Client a -> Client a -> Bool
(Client a -> Client a -> Bool)
-> (Client a -> Client a -> Bool) -> Eq (Client a)
forall a. Client a -> Client a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Client a -> Client a -> Bool
$c/= :: forall a. Client a -> Client a -> Bool
== :: Client a -> Client a -> Bool
$c== :: forall a. Client a -> Client a -> Bool
Eq)

-- | 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 :: Pipeline c -> m (Client c)
asClient = Pipeline c -> m (Client c)
forall a (m :: * -> *).
(IsCap a, MonadSTM m) =>
Pipeline a -> m (Client a)
pipelineClient

instance AsClient Client where
    asClient :: Client c -> m (Client c)
asClient = STM (Client c) -> m (Client c)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Client c) -> m (Client c))
-> (Client c -> STM (Client c)) -> Client c -> m (Client c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client c -> STM (Client 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), NC.Super p c) => f c -> f p
upcast :: f c -> f p
upcast = f c -> f p
coerce

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

-- | Call a method, supplying the parameters as a 'Raw' struct.
callR
    :: (AsClient f, R.IsCap c, R.IsStruct p, MonadSTM m)
    => Method c p r -> R.Raw 'Const p -> f c -> m (Pipeline r)
callR :: Method c p r -> Raw 'Const p -> f c -> m (Pipeline r)
callR 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 Untyped 'Const (ReprFor p)
arg) f c
c = STM (Pipeline r) -> m (Pipeline r)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Pipeline r) -> m (Pipeline r))
-> STM (Pipeline r) -> m (Pipeline r)
forall a b. (a -> b) -> a -> b
$ do
    Client Client
client <- f c -> STM (Client c)
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) <- STM (Promise (Maybe (Ptr 'Const)), Fulfiller (Maybe (Ptr 'Const)))
forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
    Pipeline -> Pipeline r
forall a. Pipeline -> Pipeline a
Pipeline (Pipeline -> Pipeline r) -> STM Pipeline -> STM (Pipeline r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CallInfo -> Client -> STM Pipeline
forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m Pipeline
Rpc.call
        CallInfo :: Word64
-> Word16
-> Maybe (Ptr 'Const)
-> Fulfiller (Maybe (Ptr 'Const))
-> CallInfo
Server.CallInfo
            { Word64
interfaceId :: Word64
interfaceId :: Word64
interfaceId
            , Word16
methodId :: Word16
methodId :: Word16
methodId
            , arguments :: Maybe (Ptr 'Const)
arguments = Ptr 'Const -> Maybe (Ptr 'Const)
forall a. a -> Maybe a
Just (Struct 'Const -> Ptr 'Const
forall (mut :: Mutability). Struct mut -> Ptr mut
U.PtrStruct Struct 'Const
Untyped 'Const (ReprFor p)
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
        , NC.Parse p pp
        , MonadSTM m
        , MonadThrow m
        )
    => Method c p r -> pp -> f c -> m (Pipeline r)
callP :: Method c p r -> pp -> f c -> m (Pipeline r)
callP Method c p r
method pp
parsed f c
client = do
    Struct 'Const
struct <- WordCount
-> (forall s. PureBuilder s (Mutable s (Struct 'Const)))
-> m (Struct 'Const)
forall (m :: * -> *) a.
(MonadThrow m, Thaw a) =>
WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
forall a. Bounded a => a
maxBound ((forall s. PureBuilder s (Mutable s (Struct 'Const)))
 -> m (Struct 'Const))
-> (forall s. PureBuilder s (Mutable s (Struct 'Const)))
-> m (Struct 'Const)
forall a b. (a -> b) -> a -> b
$ do
        Message ('Mut s)
msg <- Maybe WordCount -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
newMessage Maybe WordCount
forall a. Maybe a
Nothing
        Raw ('Mut s) p -> Struct ('Mut s)
forall (mut :: Mutability) a. Raw mut a -> Untyped mut (ReprFor a)
R.fromRaw (Raw ('Mut s) p -> Struct ('Mut s))
-> PureBuilder s (Raw ('Mut s) p)
-> PureBuilder s (Struct ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> pp -> PureBuilder s (Raw ('Mut s) p)
forall t p (m :: * -> *) s.
(Parse t p, RWCtx m s) =>
Message ('Mut s) -> p -> m (Raw ('Mut s) t)
NC.encode Message ('Mut s)
msg pp
parsed
    Method c p r -> Raw 'Const p -> f c -> m (Pipeline r)
forall (f :: * -> *) c p (m :: * -> *) r.
(AsClient f, IsCap c, IsStruct p, MonadSTM m) =>
Method c p r -> Raw 'Const p -> f c -> m (Pipeline r)
callR Method c p r
method (Untyped 'Const (ReprFor p) -> Raw 'Const p
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw Struct 'Const
Untyped 'Const (ReprFor p)
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 :: 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   -> Pipeline -> Pipeline b
forall a. Pipeline -> Pipeline a
Pipeline Pipeline
p
        F.PtrField Word16
idx -> Pipeline -> Pipeline b
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 :: Pipeline a -> m (Client a)
pipelineClient (Pipeline Pipeline
p) =
    STM (Client a) -> m (Client a)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Client a) -> m (Client a)) -> STM (Client a) -> m (Client a)
forall a b. (a -> b) -> a -> b
$ Client -> Client a
forall a. Client -> Client a
Client (Client -> Client a) -> STM Client -> STM (Client a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pipeline -> STM Client
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 'Const a)
waitPipeline :: Pipeline a -> m (Raw 'Const a)
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.
    STM (Raw 'Const a) -> m (Raw 'Const a)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Raw 'Const a) -> m (Raw 'Const a))
-> STM (Raw 'Const a) -> m (Raw 'Const a)
forall a b. (a -> b) -> a -> b
$ WordCount -> LimitT STM (Raw 'Const a) -> STM (Raw 'Const a)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
100 (LimitT STM (Raw 'Const a) -> STM (Raw 'Const a))
-> LimitT STM (Raw 'Const a) -> STM (Raw 'Const a)
forall a b. (a -> b) -> a -> b
$ do
        Maybe (Ptr 'Const)
ptr <- Pipeline -> LimitT STM (Maybe (Ptr 'Const))
forall (m :: * -> *).
MonadSTM m =>
Pipeline -> m (Maybe (Ptr 'Const))
Rpc.waitPipeline Pipeline
p
        UntypedPtr 'Const pr -> Raw 'Const a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (UntypedPtr 'Const pr -> Raw 'Const a)
-> LimitT STM (UntypedPtr 'Const pr) -> LimitT STM (Raw 'Const a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message 'Const
-> Maybe (Ptr 'Const) -> LimitT STM (Untyped 'Const ('Ptr pr))
forall (r :: Maybe PtrRepr) (m :: * -> *) (mut :: Mutability).
(IsPtrRepr r, ReadCtx m mut) =>
Message mut -> Maybe (Ptr mut) -> m (Untyped mut ('Ptr r))
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 = Client -> Client a
forall a. Client -> Client a
Client