playwright/src/Control/Concurrent/BeeZero.hs

{- This file is part of playwright.
 -
 - Written in 2024 by Pere Lev <[email protected]>
 -
 - Licensed under the Apache License, Version 2.0 (the "License");
 - you may not use this file except in compliance with the License.
 - You may obtain a copy of the License at
 -
 -     http://www.apache.org/licenses/LICENSE-2.0
 -
 - Unless required by applicable law or agreed to in writing, software
 - distributed under the License is distributed on an "AS IS" BASIS,
 - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 - See the License for the specific language governing permissions and
 - limitations under the License.
 -}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A live actor system, built on top of "Control.Concurrent.Exchange".
--
-- It can be used as is, and\/or further features such as disk persistence and
-- networking can be built on top.
module Control.Concurrent.BeeZero
    ( -- * Intro

      -- * Declaring an actor's interface
      Signature (..)
    , Method (..)
    , LookupSig ()
    , Bee (..)

      -- * Defining an actor implementation
    , HandleMethod ()
    , handleMethod
    , Script ()
    , makeScript
    , Implementor (..)

      -- * Using actors in the current thread
    , Near ()
    , near
    , callNear
    , callNear_

      -- * Launching and calling actors running in a separate thread
    , Far ()
    , Next (..)
    , launchFar
    , matchMethodClient
    , matchMethodClient'
    , callFar
    , callFar_
    )
where

import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Unlift
import Data.Kind
import Data.Proxy
import Data.Type.Bool
import Data.Type.Equality
import GHC.TypeLits
import UnliftIO.Exception

import qualified Data.Vinyl as V

import Control.Concurrent.Exchange

import qualified Data.Vinyl.Local as V

-- / -------------------------------------------------------------------------

data Signature = Signature Type Type

type SignatureParam :: Signature -> Type
type family SignatureParam s where
    SignatureParam ('Signature p _) = p

type SignatureReturn :: Signature -> Type
type family SignatureReturn s where
    SignatureReturn ('Signature _ r) = r

data Method = Method Symbol Signature

type MethodSignature :: Method -> Signature
type family MethodSignature method where
    MethodSignature ('Method _ sig) = sig

{-
type family MethodToPair (m :: Method) =
    (p :: (Symbol, Signature)) | p -> m where
        MethodToPair (Method sym sig) = '(sym, sig)

data MethodToPair :: Method -> Exp (Symbol, Signature)
type instance Eval (MethodToPair (Method sym sig)) = '(sym, sig)

data LookupSig :: Symbol -> [Method] -> Exp (Maybe Signature)
type instance Eval (LookupSig sym ms) =
    Eval (Lookup sym (Eval (Map MethodToPair ms)))

type Lookup :: a -> [(a, b)] -> Maybe b
type family Lookup item list where
    Lookup _ '[]            = 'Nothing
    Lookup x ((y, z) : yzs) = If (x == y) (Just z) (Lookup x yzs)
-}

type LookupSig :: Symbol -> [Method] -> Maybe Signature
type family LookupSig symbol methods where
    LookupSig _ '[]                 = Nothing
    LookupSig x ('Method y s ': ms) = If (x == y) (Just s) (LookupSig x ms)

-- / -------------------------------------------------------------------------

-- | Actor type, defines methods it offers.
class Bee (b :: Type) where

    type BeeInterface b :: [Method]

newtype HandleMethod
    (monad :: Type -> Type) (side :: Type) (method :: Method) = HandleMethod
        { _unHandleMethod
            :: SignatureParam (MethodSignature method)
            -> monad (side, SignatureReturn (MethodSignature method))
        }

handleMethod
    :: forall
            (sym :: Symbol)
            (sig :: Signature)
            (monad :: Type -> Type)
            (side :: Type) .
       (SignatureParam sig -> monad (side, SignatureReturn sig))
    -> HandleMethod monad side ('Method sym sig)
handleMethod = HandleMethod

-- Actor behavior implementation (there can be more than one for a given actor
-- type)

type HandlerSet m side ms = V.Rec (HandleMethod m side) ms

newtype Script (m :: Type -> Type) (side :: Type) (b :: Type) = Script
    { unScript :: HandlerSet m side (BeeInterface b)
    }

makeScript :: forall b m s. HandlerSet m s (BeeInterface b) -> Script m s b
makeScript = Script

-- | A type that provides method handler implementations for a given actor
-- interface.
class (Bee (ImplementorBee i), Monad (ImplementorMonad i)) => Implementor i where

    -- | The actor interface being implemented.
    type ImplementorBee i :: Type

    -- | The monad in which method handlers run
    type ImplementorMonad i :: Type -> Type

    -- | The side value returned by method handlers
    type ImplementorSide i :: Type

    -- | Set of handlers for the actor's methods.
    beeScript
        :: Script (ImplementorMonad i) (ImplementorSide i) (ImplementorBee i)

newtype Near (monad :: Type -> Type) (impl :: Type) = Near
    { _unNear :: forall a. (ImplementorMonad impl) a -> monad a
    }

near
    :: forall (me :: Type) (them :: Type) .
        (Implementor me, Implementor them)
    => (forall a. (ImplementorMonad them) a -> (ImplementorMonad me) a)
    -> Near (ImplementorMonad me) them
near = Near

type family MethodExchange (m :: Method) =
    (m' :: (Type, Type)) | m' -> m where
        MethodExchange ('Method sym ('Signature arg ret)) =
            '((Proxy sym, arg), ret)

type family MethodExchanges (ms :: [Method]) =
    (ms' :: [(Type, Type)]) | ms' -> ms where
        MethodExchanges '[]       = '[]
        MethodExchanges (x ': xs) = MethodExchange x ': MethodExchanges xs

adaptHandler
    :: forall
            (monad :: Type -> Type)
            (method :: Method)
            (sym :: Symbol)
            (sig :: Signature)
            (side :: Type) .
        ( method ~ 'Method sym sig
        , MethodExchange method
          ~
          '((Proxy sym, SignatureParam sig), SignatureReturn sig)
        )
    => HandleMethod monad side method
    -> MethodHandler monad side (MethodExchange method)
adaptHandler (HandleMethod f) = methodHandler (f . snd)

class AdaptHandlers (ms :: [Method]) where
    adaptHandlerSet
        :: forall (monad :: Type -> Type) (side :: Type) .
           V.Rec (HandleMethod monad side) ms
        -> V.Rec (MethodHandler monad side) (MethodExchanges ms)

instance AdaptHandlers ('[] :: [Method]) where
    adaptHandlerSet V.RNil = V.RNil

instance
    forall (m :: Method) (sym :: Symbol) (sig :: Signature) (ms :: [Method]) .
    ( m ~ 'Method sym sig
    , MethodExchange m
      ~
      '((Proxy sym, SignatureParam sig), SignatureReturn sig)
    , AdaptHandlers ms
    ) =>
        AdaptHandlers (m : ms) where
            adaptHandlerSet (h V.:& hs) =
                adaptHandler h V.:& adaptHandlerSet hs

callNear
    :: forall
            (sym :: Symbol)
            (i :: Type)
            (m :: Type -> Type)
            (sig :: Signature) .
        ( Implementor i
        , 'Method sym sig V.∈ BeeInterface (ImplementorBee i)
        , LookupSig sym (BeeInterface (ImplementorBee i)) ~ Just sig
        , '((Proxy sym, SignatureParam sig), SignatureReturn sig)
          V.∈
          MethodExchanges (BeeInterface (ImplementorBee i))
        , AdaptHandlers (BeeInterface (ImplementorBee i))
        )
    => Near m i
    -> SignatureParam sig
    -> m (ImplementorSide i, SignatureReturn sig)
callNear (Near run) arg =
    run $ runMethodHandler (Proxy @sym, arg) $ adaptHandlerSet $ unScript $ beeScript @i

callNear_
    :: forall
            (sym :: Symbol)
            (i :: Type)
            (m :: Type -> Type)
            (sig :: Signature) .
        ( Implementor i
        , Functor m
        , 'Method sym sig V.∈ BeeInterface (ImplementorBee i)
        , LookupSig sym (BeeInterface (ImplementorBee i)) ~ Just sig
        , '((Proxy sym, SignatureParam sig), SignatureReturn sig)
          V.∈
          MethodExchanges (BeeInterface (ImplementorBee i))
        , AdaptHandlers (BeeInterface (ImplementorBee i))
        )
    => Near m i
    -> SignatureParam sig
    -> m ()
callNear_ bee arg = void $ callNear @sym bee arg

type ClientSet (ms :: [Method]) = V.Rec AsyncExchangeClientWrapper (MethodExchanges ms)

newtype Caller (b :: Type) = Caller
    { _unCaller :: ClientSet (BeeInterface b)
    }

newtype Far (b :: Type) = Far
    { _unFar :: Caller b
    }

data Next = Stop | Continue

launchFar
    :: forall (impl :: Type) (util :: Type) (pairs :: [(Type, Type)]) .
        ( pairs ~ MethodExchanges (BeeInterface (ImplementorBee impl))
        , Implementor impl
        , V.RMapCM pairs pairs
        , V.RecApplicative pairs
        , AdaptHandlers (BeeInterface (ImplementorBee impl))
        , MonadUnliftIO (ImplementorMonad impl)
        )
    => IO util
    -> ImplementorMonad impl ()
    -> (forall a. util -> ImplementorMonad impl a -> IO a)
    -> (ImplementorSide impl -> (ImplementorMonad impl (), Next))
    -> (SomeException -> ImplementorMonad impl ())
    -> IO (Far (ImplementorBee impl))
launchFar prepareUtil selfInit runBee makeSide useException = do
    mchan <- newMethodServerChan @pairs

    let server = methodServerFromChan mchan
        handlers = adaptHandlerSet $ unScript $ beeScript @impl
    _ <- forkIO $ do
        u <- prepareUtil
        runBee u $ do
            selfInit
            loop server handlers

    let clients = asyncExchangeClientsForMethods mchan
    return $ Far $ Caller clients

    where

    loop server handlers = do
        (become, next) <- do
            result <- try $ handleMethodCallSync server handlers
            case result of
                Left e -> do
                    useException (e :: SomeException)
                    return (pure (), Continue)
                Right side -> pure $ makeSide side
        become
        case next of
            Stop -> pure ()
            Continue -> loop server handlers

matchMethodClient'
    :: forall
            (sym :: Symbol)
            (b :: Type)
            (sig :: Signature) .
        ( Bee b
        , 'Method sym sig V.∈ BeeInterface b
        , LookupSig sym (BeeInterface b) ~ Just sig
        , '((Proxy sym, SignatureParam sig), SignatureReturn sig)
          V.∈
          MethodExchanges (BeeInterface b)
        )
    => Far b
    -> AsyncExchangeClient
        (Proxy sym, SignatureParam sig)
        (SignatureReturn sig)
matchMethodClient' (Far (Caller clients)) = matchAsyncExchangeClient clients

matchMethodClient
    :: forall
            (sym :: Symbol)
            (b :: Type)
            (sig :: Signature) .
        ( Bee b
        , 'Method sym sig V.∈ BeeInterface b
        , LookupSig sym (BeeInterface b) ~ Just sig
        , '((Proxy sym, SignatureParam sig), SignatureReturn sig)
          V.∈
          MethodExchanges (BeeInterface b)
        )
    => Far b
    -> AsyncExchangeClient
        (SignatureParam sig)
        (SignatureReturn sig)
matchMethodClient = adaptAsyncExchangeClient (Proxy @sym,) . matchMethodClient'

callFar
    :: forall
            (sym :: Symbol)
            (b :: Type)
            (sig :: Signature) .
        ( Bee b
        , 'Method sym sig V.∈ BeeInterface b
        , LookupSig sym (BeeInterface b) ~ Just sig
        , '((Proxy sym, SignatureParam sig), SignatureReturn sig)
          V.∈
          MethodExchanges (BeeInterface b)
        )
    => Far b
    -> SignatureParam sig
    -> AsyncExchangeClient (SignatureReturn sig) ()
    -> IO ()
callFar far arg clientReturn =
    let client =
            matchMethodClient @sym far ::
                AsyncExchangeClient
                    (SignatureParam sig)
                    (SignatureReturn sig)
    in  exchangeAsyncClient client arg clientReturn

callFar_
    :: forall
            (sym :: Symbol)
            (b :: Type)
            (sig :: Signature) .
        ( Bee b
        , 'Method sym sig V.∈ BeeInterface b
        , LookupSig sym (BeeInterface b) ~ Just sig
        , '((Proxy sym, SignatureParam sig), SignatureReturn sig)
          V.∈
          MethodExchanges (BeeInterface b)
        )
    => Far b
    -> SignatureParam sig
    -> IO ()
callFar_ far arg = do
    let client =
            matchMethodClient @sym far ::
                AsyncExchangeClient
                    (SignatureParam sig)
                    (SignatureReturn sig)
    (_, clientReturn) <- newAsyncExchange
    exchangeAsyncClient client arg clientReturn

-- Swarm: Vat
-- Hive: Whole local instance