{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE StandaloneKindSignatures #-}

{-# LANGUAGE IncoherentInstances #-}

-- We use Symbol to allow easily referring to a method without needing to
-- define a type alias for it
--
-- Thus, we rely on TypeApplications to specify the method rather than passing
-- a proxy, and this extension is required for GHC to let us defer type
-- inference to the call site.
{-# LANGUAGE AllowAmbiguousTypes #-}

-- | An evolving actor programming library. Intended to become a separate
-- package from Vervis. Name suggestions are welcome! Since many actor-related
-- libraries already exist on Hackage.
module Control.Concurrent.Actor
    ( -- * Defining an actor interface
      Signature (..)
    , Method (..)

      -- * Defining a method handler
    , HandlerSig
    , handleMethod
    , MethodHandler (..)

    -- * Implementing an actor
    , SpawnMode (AllowSpawn)
    , Stage (..)
    , Actor (..)
    , Next ()
    , ActorLaunch (..)

    , TheaterFor ()
    , ActFor ()

    , MonadActor (..)
    , asksEnv

    , done
    , doneAnd
    , stop

    -- * Calling actor methods
    , ActorHasMethod
    , Ref ()
    , callIO'
    , sendIO'
    , call'
    , send'
    , ActorMethodCall ()
    , call
    , ActorMethodSend ()
    , send

    -- * Launching actors
    , spawnIO
    , spawn

    -- * Launching the actor system
    , startTheater

    -- * Exported for use in constraints in Vervis.Actor
    , ActorRef ()
    , Func
    , AdaptedHandler
    , AdaptedAction
    , Parcel_
    , AdaptHandlerConstraint
    , HAdaptHandler
    , Handler_
    , Handle'
    , ActorRefMap
    , ActorRefMapTVar_

    -- * Exported to allow some Yesod Handlers to reuse some actor actions
    , runActor


    --, Message (..)
    --, sendManyIO
    --, sendMany
    )
where

import Data.HList (HList (..))
import Data.Kind
import Fcf
import "first-class-families" Fcf.Data.Symbol

import qualified Data.HList as H

import Control.Concurrent
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad.STM
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Foldable
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import Data.Int
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import Data.Traversable
import Database.Persist.Sql (PersistField (..), PersistFieldSql (..))
import GHC.TypeLits
import UnliftIO.Exception

import qualified Control.Exception.Annotated as AE
import qualified Control.Monad.Trans.RWS.Lazy as RWSL
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Vary as V

import Control.Concurrent.Return
import Database.Persist.Box

--------------------------- Defining method types ----------------------------

-- These are for Actor instances to define the actor's interface
--
-- * An interface is a set of zero or more methods
-- * Each method has:
--      * A unique name
--      * A list of zero or more parameter types
--      * A return type

-- A type-level representation of an actor method's signature.
--
-- >>> :k Int :-> String :-> Return Bool
-- Int :-> String :-> Return Bool :: Signature
data Signature = Return Type | Type :-> Signature

infixr 1 :->

-- A named actor method, combines a signature with a type-level name string.
--
-- >>> :k "saveTheWorld" ::: Int :-> String :-> Return Bool
-- "saveTheWorld" ::: Int :-> String :-> Return Bool :: Method
data Method = Symbol ::: Signature

infix 0 :::

-- Getters to extract parameters and return type from a Signature

type SignatureParams :: Signature -> [Type]
type family SignatureParams s where
    SignatureParams ('Return t)  = '[]
    SignatureParams (t ':-> sig) = t ': SignatureParams sig

type SignatureReturn :: Signature -> Type
type family SignatureReturn s where
    SignatureReturn ('Return t)  = t
    SignatureReturn (t ':-> sig) = SignatureReturn sig

-- Method lookup support

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

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

--------------------------- Defining method handlers -------------------------

-- TODO switch Proxy to SSymbol?

type HandlerAction :: Type -> Type -> Type
type HandlerAction stage ret = ActFor stage (ret, ActFor stage (), Next)

-- | With this setup:
--
-- @
-- type SaveTheWorld :: Signature
-- type SaveTheWorld = Int :-> String :-> Return Bool
--
-- data World
-- instance Stage World where
--     ...
-- @
--
-- The type
--
-- @
-- HandlerSig World SaveTheWorld
-- @
--
-- Is the same as
--
-- @
-- Int -> String -> ActFor World Bool
-- @
--type HandlerSig :: Type -> Signature -> Type
type family HandlerSig (stage :: Type) (signature :: Signature) = (a :: Type) | a -> stage signature where
    HandlerSig s (Return t)  = HandlerAction s t
    HandlerSig s (t :-> sig) = t -> HandlerSig s sig

-- Alias for 'Proxy'. See example in 'MethodHandler'.
handleMethod :: forall (sym :: Symbol) . Proxy sym
handleMethod = Proxy

-- | Example:
--
-- @
-- type SaveTheWorld :: Signature
-- type SaveTheWorld = Int :-> String :-> Return Bool
--
-- data Hero
-- instance Actor Hero where
--     ...
--
-- handler :: MethodHandler Hero "saveTheWorld" SaveTheWorld
-- handler =
--      handleMethod @"saveTheWorld" := \ key num str = do
--          liftIO $ print key
--          liftIO $ print num
--          liftIO $ putStrLn str
--          liftIO $ putStrLn "Yay I saved the world"
--          done True
-- @
data MethodHandler (actor :: Type) (sym :: Symbol) (sig :: Signature) =
    Proxy sym := (ActorIdentity actor -> HandlerSig (ActorStage actor) sig)

--------------------------- Implementing an actor ----------------------------

data SpawnMode = NoSpawn | AllowSpawn

class KnownSpawnMode (StageSpawn a) => Stage (a :: Type) where
    data StageEnv a :: Type
    type StageActors a :: [Type]
    type StageSpawn a :: SpawnMode

class Actor (a :: Type) where
    type ActorStage a :: Type
    type ActorIdentity a :: Type
    type ActorInterface a :: [Method]

data Next = Stop | Proceed

data Handler_ :: Type -> Method -> Exp Type
type instance Eval (Handler_ actor (sym ::: sig)) = MethodHandler actor sym sig

class Actor a => ActorLaunch a where
    actorBehavior :: Proxy a -> HList (Eval (Map (Handler_ a) (ActorInterface a)))

type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

type ActorRefMap a = HashMap (Ref a) (ActorRef a)

data ActorRefMapTVar_ :: Type -> Exp Type
type instance Eval (ActorRefMapTVar_ a) = TVar (ActorRefMap a)

type ActorInt = Int64

type TheaterCounter :: SpawnMode -> Type
type family TheaterCounter mode = t | t -> mode where
    TheaterCounter NoSpawn    = ()
    TheaterCounter AllowSpawn = (TheaterFor (ACounterStage ActorInt), Ref (ACounter ActorInt))

-- | A set of live actors responding to messages
data TheaterFor s = TheaterFor
    { theaterMap     :: HList (Eval (Map ActorRefMapTVar_ (StageActors s)))
    , theaterLog     :: LogFunc
    , theaterCounter :: TheaterCounter (StageSpawn s)
    }

-- | Actor monad in which message reponse actions are executed. Supports
-- logging, a read-only environment, and IO.
newtype ActFor s a = ActFor
    { unActFor :: LoggingT (ReaderT (StageEnv s, TheaterFor s) IO) a
    }
    deriving
        ( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger
        , MonadLoggerIO
        )

instance MonadUnliftIO (ActFor s) where
    withRunInIO inner =
        ActFor $ withRunInIO $ \ run -> inner (run . unActFor)

runActor :: TheaterFor s -> StageEnv s -> ActFor s a -> IO a
runActor theater env (ActFor action) =
    runReaderT (runLoggingT action $ theaterLog theater) (env, theater)

class (Monad m, Stage (MonadActorStage m)) => MonadActor m where
    type MonadActorStage m
    askEnv :: m (StageEnv (MonadActorStage m))
    liftActor :: ActFor (MonadActorStage m) a -> m a

instance Stage (s :: Type) => MonadActor (ActFor s) where
    type MonadActorStage (ActFor s) = s
    askEnv = ActFor $ lift $ asks fst
    liftActor = id

instance MonadActor m => MonadActor (ReaderT r m) where
    type MonadActorStage (ReaderT r m) = MonadActorStage m
    askEnv                             = lift askEnv
    liftActor                          = lift . liftActor

instance MonadActor m => MonadActor (MaybeT m) where
    type MonadActorStage (MaybeT m) = MonadActorStage m
    askEnv                          = lift askEnv
    liftActor                       = lift . liftActor

instance MonadActor m => MonadActor (ExceptT e m) where
    type MonadActorStage (ExceptT e m) = MonadActorStage m
    askEnv                             = lift askEnv
    liftActor                          = lift . liftActor

instance (Monoid w, MonadActor m) => MonadActor (RWSL.RWST r w s m) where
    type MonadActorStage (RWSL.RWST r w s m) = MonadActorStage m
    askEnv                                   = lift askEnv
    liftActor                                = lift . liftActor

asksEnv :: MonadActor m => (StageEnv (MonadActorStage m) -> a) -> m a
asksEnv f = f <$> askEnv

done :: Monad m => a -> m (a, ActFor s (), Next)
done msg = return (msg, return (), Proceed)

doneAnd :: Monad m => a -> ActFor s () -> m (a, ActFor s (), Next)
doneAnd msg act = return (msg, act, Proceed)

stop :: Monad m => a -> m (a, ActFor s (), Next)
stop msg = return (msg, return (), Stop)

--------------------------- Actor queue internals ----------------------------

-- The actual message inserted into an actor's queue
--
-- For example, given this signature:
--
-- @
-- type SaveTheWorld :: Signature
-- type SaveTheWorld = Int :-> String :-> Return Bool
-- @
--
-- We could do the following (a bit silly example, the functions @sendBool@ and
-- @sendString@ don't really exist, they're just for the sake of the example):
--
-- @
-- parcel :: Parcel SaveTheWorld
-- parcel = Parcel
--     {
--       -- HList [Int, String]
--       _parcelParams = 5 `H.HCons` "cool" `H.HCons` H.HNil
--
--       -- Either SomeException Bool -> IO ()
--     , _parcelReturn = \case
--          Left e -> sendString $ displayException e
--          Right b ->
--              if b
--                  then sendBool True
--                  else sendBool False
--     }
-- @

data Parcel (s :: Signature) = Parcel
    { _parcelParams :: HList (SignatureParams s)
    , _parcelReturn :: Either SomeException (SignatureReturn s) -> IO ()
    }

-- Given a method, denotes a pair of:
--
-- * 'Proxy' to witness the method's name
-- * 'Parcel' to hold the actual data required for invoking the method
--
-- Given a method
--
-- @
-- type SaveTheWorld :: Method
-- type SaveTheWorld = "saveTheWorld" ::: Int :-> String :-> Return Bool
-- @
--
-- We could do the following:
--
-- @
-- parcel :: Eval (Parcel_ SaveTheWorld)
-- parcel =
--     ( Proxy@"saveTheWorld"
--     , Parcel
--           {
--             -- HList [Int, String]
--             _parcelParams = ...
--
--             -- Either SomeException Bool -> IO ()
--           , _parcelReturn = ...
--           }
--     )
-- @

data Parcel_ :: Method -> Exp Type
type instance Eval (Parcel_ (sym '::: sig)) = (Proxy sym, Parcel sig)

-- The actual type of items in the actor's message queue, since an actor can
-- have multiple methods

newtype Invocation (ms :: [Method]) = Invocation
    { _unInvocation :: V.Vary (Eval (Map Parcel_ ms))
    }

-- A reference to a live actor holds its message queue, so that we can insert a
-- new message to it

newtype ActorRef' (ms :: [Method]) = ActorRef'
    { _unActorRef' :: Chan (Invocation ms)
    }

newtype ActorRef (a :: Type) = ActorRef
    { _unActorRef :: ActorRef' (ActorInterface a)
    }

--------------------------- Calling a method ---------------------------------

-- invokeMethod and invokeMethod_ are the building blocks for calling actor
-- methods. They simply take an HList of parameters, and a reference to the
-- actor message queue.
--
-- All the high-level wrappers are built on top of these two functions.

invokeMethod'
    :: forall
           (m::Method)
           (ms::[Method])
           (sym::Symbol)
           (sig::Signature) .
       ( m ~ (sym ::: sig)
       , Eval (Parcel_ m) V.:| Eval (Map Parcel_ ms)
       )
    => Proxy m
    -> HList (SignatureParams sig)
    -> ActorRef' ms
    -> IO (SignatureReturn sig)
invokeMethod' proxy args (ActorRef' chan) = do
    (sendResult, waitResult) <- newReturn
    let parcel = Parcel args sendResult :: Parcel sig
        inv = Invocation $ V.from (p proxy, parcel)
    writeChan chan inv
    result <- waitResult
    case result of
        Left e -> AE.checkpointCallStack $ throwIO e
        Right r -> return r
    where
    p :: Proxy (symbol ::: signat) -> Proxy symbol
    p _ = Proxy

invokeMethod
    :: forall
           (a::Type)
           (m::Method)
           (sym::Symbol)
           (sig::Signature) .
       ( Actor a
       , m ~ (sym ::: sig)
       , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
       )
    -- => Proxy sym
    => Proxy m
    -> HList (SignatureParams sig)
    -> ActorRef a
    -> IO (SignatureReturn sig)
invokeMethod proxy args (ActorRef ref) = invokeMethod' (id proxy) args ref
{-
    where
    p :: Proxy sym -> Proxy m
    p _ = Proxy
-}

invokeMethod_'
    :: forall
           (m::Method)
           (ms::[Method])
           (sym::Symbol)
           (sig::Signature) .
       ( m ~ (sym ::: sig)
       , Eval (Parcel_ m) V.:| Eval (Map Parcel_ ms)
       )
    => Proxy m
    -> HList (SignatureParams sig)
    -> ActorRef' ms
    -> IO ()
invokeMethod_' proxy args (ActorRef' chan) = do
    let sendResult = const $ pure ()
        parcel = Parcel args sendResult :: Parcel sig
        inv = Invocation $ V.from (p proxy, parcel)
    writeChan chan inv
    where
    p :: Proxy (symbol ::: signat) -> Proxy symbol
    p _ = Proxy

invokeMethod_
    :: forall
           (a::Type)
           (m::Method)
           (sym::Symbol)
           (sig::Signature) .
       ( Actor a
       , m ~ (sym ::: sig)
       , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
       )
    -- => Proxy sym
    => Proxy m
    -> HList (SignatureParams sig)
    -> ActorRef a
    -> IO ()
invokeMethod_ proxy args (ActorRef ref) = invokeMethod_' (id proxy) args ref
{-
    where
    p :: Proxy sym -> Proxy m
    p _ = Proxy
-}

-- One level higher, instead of holding an ActorRef, i.e. the actor message
-- queue, we hold a Theater and an ActorKey, and we need to lookup the actor's
-- message queue in the Theater
--
-- 'callIO\'' and 'sendIO\'' are exported, for Vervis to use, but will likely
-- be hidden/removed in the future.
--
-- They allow to invoke a method from outside of an actor context. This is
-- possible right now, but as the library evolves and gains complexity, they're
-- likely to be removed.
--
-- Right now it allows the Vervis actor inbox POST handlers to insert
-- activities into actor queues.

askTheater :: ActFor s (TheaterFor s)
askTheater = ActFor $ lift $ asks snd

lookupActor
    :: ( H.HOccurs
                         (TVar (ActorRefMap a))
                         (HList (Eval (Map ActorRefMapTVar_ (StageActors s))))
       )
    => TheaterFor s
    -> Ref a
    -> IO (Maybe (ActorRef a))
lookupActor (TheaterFor hlist _ _) key =
    HM.lookup key <$> readTVarIO (H.hOccurs hlist)

{-
class Actor a => IsActorMethod (sym::Symbol) (a::Type) where
    type ActorMethod sym a = (sig :: Signature) | sym a -> sig
instance 
-}

type ActorHasMethod :: Type -> Symbol -> Signature -> Constraint
type family ActorHasMethod actor symbol signature where
    ActorHasMethod a sym sig =
        ( Eval (LookupSig sym (ActorInterface a)) ~ Just sig
        , Eval (Parcel_ (sym ::: sig)) V.:| Eval (Map Parcel_ (ActorInterface a))
        )

-- | Same as 'call\'', except it takes the theater as a parameter, as well as a
-- Proxy specifying the method's name.
--
-- This function allows to invoke a method from outside of an actor context.
-- This is possible right now, but as the library evolves and gains complexity,
-- this function might be removed.
--
-- Right now it allows the Vervis actor inbox POST handlers to insert
-- activities into actor queues.
callIO'
    :: forall
           (sym::Symbol)
           (a::Type)
           (m::Method)
           (sig::Signature)
           (stage::Type) .
       ( Actor a
       , m ~ (sym ::: sig)
       --, Eval (LookupSig sym (ActorInterface a)) ~ Just sig
       --, Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
       , ActorHasMethod a sym sig
       , H.HOccurs
                         (TVar (ActorRefMap a))
                         (HList (Eval (Map ActorRefMapTVar_ (StageActors stage))))
       )
    => TheaterFor stage
    -> Proxy m
    -> Ref a
    -> HList (SignatureParams sig)
    -> IO (Maybe (SignatureReturn sig))
callIO' theater proxy key args = do
    maybeRef <- lookupActor theater key
    for maybeRef $ \ ref -> invokeMethod proxy args ref

-- | Same as 'send\'', except it takes the theater as a parameter, as well as a
-- Proxy specifying the method's name.
--
-- This function allows to invoke a method from outside of an actor context.
-- This is possible right now, but as the library evolves and gains complexity,
-- this function might be removed.
--
-- Right now it allows the Vervis actor inbox POST handlers to insert
-- activities into actor queues.
sendIO'
    :: forall
           (sym::Symbol)
           (a::Type)
           (m::Method)
           (sig::Signature)
           (stage::Type) .
       ( Actor a
       , m ~ (sym ::: sig)
       , Eval (LookupSig sym (ActorInterface a)) ~ Just sig
       , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
       , H.HOccurs
                         (TVar (ActorRefMap a))
                         (HList (Eval (Map ActorRefMapTVar_ (StageActors stage))))
       )
    => TheaterFor stage
    -> Proxy m
    -> Ref a
    -> HList (SignatureParams sig)
    -> IO Bool
sendIO' theater proxy key args = do
    maybeRef <- lookupActor theater key
    case maybeRef of
        Nothing -> return False
        Just ref -> do
            invokeMethod_ proxy args ref
            return True

-- Another level higher, we're now in an actor context, grabbing the Theater
-- from the context rather than passing it as a parameter.
--
-- Otherwise we're still using an HList and a Proxy.

-- | Like 'call', except a Proxy is passed to specify the method's name, and
-- arguments are passed as a 'HList'.
call'
    :: forall
           (sym::Symbol)
           (a::Type)
           (m::Method)
           (sig::Signature)
           (stage::Type)
           (monad :: Type -> Type) .
       ( Actor a
       , m ~ (sym ::: sig)
       , Eval (LookupSig sym (ActorInterface a)) ~ Just sig
       , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
       , H.HOccurs
                         (TVar (ActorRefMap a))
                         (HList (Eval (Map ActorRefMapTVar_ (StageActors stage))))
       , stage ~ ActorStage a
       , MonadActor monad
       , MonadActorStage monad ~ stage
       )
    => Proxy m
    -> Ref a
    -> HList (SignatureParams sig)
    -> monad (Maybe (SignatureReturn sig))
call' proxy ref args = liftActor $ do
    theater <- askTheater
    liftIO $ callIO' theater proxy ref args

-- | Like 'send', except a Proxy is passed to specify the method's name, and
-- arguments are passed as a 'HList'.
send'
    :: forall
           (sym::Symbol)
           (a::Type)
           (m::Method)
           (sig::Signature)
           (stage::Type)
           (monad :: Type -> Type) .
       ( Actor a
       , m ~ (sym ::: sig)
       , Eval (LookupSig sym (ActorInterface a)) ~ Just sig
       , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
       , H.HOccurs
                         (TVar (ActorRefMap a))
                         (HList (Eval (Map ActorRefMapTVar_ (StageActors stage))))
       , stage ~ ActorStage a
       , MonadActor monad
       , MonadActorStage monad ~ stage
       )
    => Proxy m
    -> Ref a
    -> HList (SignatureParams sig)
    -> monad Bool
send' proxy key args = liftActor $ do
    theater <- askTheater
    liftIO $ sendIO' theater proxy key args

-- We now have 2 things to add, for pretty syntax:
--
-- * Allowing to pass arguments as regular function arguments, instead of an
--   HList
-- * Remove the (Proxy m) and rely on TypeApplications (I tried a middle step
--   of using (Proxy sym) but inference fails, so we'd need TypeApplications
--   either way)
--
-- I can't tell which one makes more sense to add first, so another level
-- higher we're now just adding both at the same time.

------ TODO if the code below fails:
--
-- Maybe a problem will be that even if we give 'sym' via TypeApplications,
-- 'sig' and 'm' can't be inferred because the only thing that suggests what
-- they are is the V.:| constraint. Instead, given 'sym', we need to do a
-- lookup in 'ms', which will determine 'm' and 'sig'
--
-- We can use the 'CallSig' family for help here.
--
-- There's also hCurry/hUncurry from HList

type family CallSig (stage :: Type) (signature :: Signature) = (a :: Type) | a -> stage signature where
    CallSig s (Return t)  = ActFor s (Maybe t)
    CallSig s (t :-> sig) = t -> CallSig s sig

class ActorMethodCall (sym :: Symbol) (actor :: Type) (params :: [Type]) (result :: Type) where
    actorMethodCall :: Ref actor -> HList params -> result

instance
    forall
        (sym::Symbol)
        (a::Type)
        (m::Method)
        (sig::Signature)
        (ret::Type)
        (stage::Type)
        (monad :: Type -> Type)
        (params :: [Type])
        (paramsRev :: [Type]) .
    ( Actor a
    , Eval (LookupSig sym (ActorInterface a)) ~ Just sig
    , m ~ (sym ::: sig)
    , ret ~ SignatureReturn sig
    , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
    , H.HOccurs
            (TVar (ActorRefMap a))
            (HList (Eval (Map ActorRefMapTVar_ (StageActors stage))))
    , stage ~ ActorStage a
    , MonadActor monad
    , MonadActorStage monad ~ stage
    , params ~ SignatureParams sig
    , H.HReverse paramsRev params
    ) =>
        ActorMethodCall sym a paramsRev (monad (Maybe ret)) where
            actorMethodCall key argsRev =
                let args = H.hReverse argsRev :: HList params
                in  call' (Proxy @m) key args

instance ActorMethodCall sym actor (x:xs) r => ActorMethodCall sym actor xs (x -> r) where
    actorMethodCall key args = \ arg -> actorMethodCall @sym key (arg `H.HCons` args)

-- | Send a message to an actor, and wait for the result to arrive. Return
-- 'Nothing' if actor doesn't exist, otherwise 'Just' the result.
--
-- If the called method throws an exception, it is rethrown, wrapped with an
-- annotation, in the current thread.
--
-- @
-- call \@"saveTheWorld" heroID 5 "hello" :: ActFor World (Maybe Bool)
-- @
call
    :: forall (sym :: Symbol) (actor :: Type) (r :: Type) (sig :: Signature) .
       ( ActorMethodCall sym actor '[] r
       , Eval (LookupSig sym (ActorInterface actor)) ~ Just sig
       , r ~ CallSig (ActorStage actor) sig
       )
    => Ref actor
    -> r
call key = actorMethodCall @sym key HNil

type family SendSig (stage :: Type) (signature :: Signature) = (a :: Type) | a -> stage where
    SendSig s (Return t)  = ActFor s Bool
    SendSig s (t :-> sig) = t -> SendSig s sig

class ActorMethodSend (sym :: Symbol) (actor :: Type) (params :: [Type]) (result :: Type) where
    actorMethodSend :: Ref actor -> HList params -> result

instance
    forall
        (sym::Symbol)
        (a::Type)
        (m::Method)
        (sig::Signature)
        (stage::Type)
        (monad :: Type -> Type)
        (params :: [Type])
        (paramsRev :: [Type]) .
    ( Actor a
    , Eval (LookupSig sym (ActorInterface a)) ~ Just sig
    , m ~ (sym ::: sig)
    , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a))
    , H.HOccurs
            (TVar (ActorRefMap a))
            (HList (Eval (Map ActorRefMapTVar_ (StageActors stage))))
    , stage ~ ActorStage a
    , MonadActor monad
    , MonadActorStage monad ~ stage
    , params ~ SignatureParams sig
    , H.HReverse paramsRev params
    ) =>
        ActorMethodSend sym a paramsRev (monad Bool) where
            actorMethodSend key argsRev =
                let args = H.hReverse argsRev :: HList params
                in  send' (Proxy @m) key args

instance ActorMethodSend sym actor (x:xs) r => ActorMethodSend sym actor xs (x -> r) where
    actorMethodSend key args = \ arg -> actorMethodSend @sym key (arg `H.HCons` args)

-- | Send a message to an actor, without waiting for a result. Return 'True' if
-- the given actor exists, 'False' otherwise.
--
-- If the called method throws an exception, it is rethrown, wrapped with an
-- annotation, in the current thread.
--
-- @
-- send \@"saveTheWorld" heroID 5 "hello" :: ActFor World Bool
-- @
send
    :: forall (sym :: Symbol) (actor :: Type) (r :: Type) (sig :: Signature) .
       ( ActorMethodSend sym actor '[] r
       , Eval (LookupSig sym (ActorInterface actor)) ~ Just sig
       , r ~ SendSig (ActorStage actor) sig
       )
    => Ref actor
    -> r
send key = actorMethodSend @sym key HNil

--------------------------- Launching actors ---------------------------------

-- We first need a way to apply a given HList as arguments to a given function,
-- which is the method handler. I think I managed to write a simple
-- implementation! But just in case, HList's HCurry is also available.

class UncurryH xs g r where
    uncurryH :: g -> HList xs -> r

instance UncurryH xs y r => UncurryH (x:xs) (x -> y) r where
    uncurryH g (HCons x xs) = uncurryH (g x) xs

instance UncurryH '[] a a where
    uncurryH x HNil = x

-- Now let's try to implement a generic handler
--
-- Note that this handler is order-based, relying that the parameter types in
-- the Vary and the handler types in the HList match.
--
-- But it's possible for different methods to have the same signature!
--
-- So just in case, to reduce the risk of uncaught confusions here, let's see
-- if we can combine method names into this.

data Func :: Type -> Type -> Exp Type
type instance Eval (Func b a) = a -> b

class Handle' xs r where
    handle' :: V.Vary xs -> HList (Eval (Map (Func r) xs)) -> r

instance Handle' '[] r where
    handle' vary HNil = V.exhaustiveCase vary

instance Handle' xs r => Handle' (x:xs) r where
    handle' vary (HCons f fs) =
        case V.pop vary of
            Left vary' -> handle' vary' fs
            Right arg -> f arg

matchAdaptedHandler
    :: forall (stage::Type) (ms::[Method]) .
       ( Eval (Map (Func (AdaptedAction stage, Text)) (Eval (Map Parcel_ ms)))
         ~
         Eval (Map (AdaptedHandler stage) ms)
       , Handle'
            (Eval (Map Parcel_ ms))
            (AdaptedAction stage, Text)
       )
    => V.Vary (Eval (Map Parcel_ ms))
    -> HList (Eval (Map (AdaptedHandler stage) ms))
    -> (AdaptedAction stage, Text)
matchAdaptedHandler = handle'

-- Now, how we turn the pretty human-defined 'MethodHandler' into the input
-- that handle' expects? Let's try.

uncurryHandler
    :: UncurryH
        (SignatureParams sig)
        (HandlerSig stage sig)
        (HandlerAction stage (SignatureReturn sig))
    => HandlerSig stage sig
    -> HList (SignatureParams sig)
    -> HandlerAction stage (SignatureReturn sig)
uncurryHandler = uncurryH

adaptHandler
    :: ( ActorStage actor ~ stage
       , KnownSymbol sym
       , UncurryH
            (SignatureParams sig)
            (HandlerSig stage sig)
            (HandlerAction stage (SignatureReturn sig))
       )
    => Ref actor
    -> ActorIdentity actor
    -> MethodHandler actor sym sig
    -> (Proxy sym, Parcel sig)
    -> (AdaptedAction (ActorStage actor), Text)
adaptHandler ref ident (Proxy := handler) (p@Proxy, Parcel args respond) =
    (go, prefixOn)
    where
    prefix = T.concat ["[Actor '", T.pack $ show ref, "']"]
    prefixOn = T.concat [prefix, " on ", T.pack $ symbolVal p]
    go = do
        result <- try $ uncurryHandler (handler ident) args
        case result of
            Left e -> do
                logError $ T.concat [prefix, " exception: ", T.pack $ displayException (e :: SomeException)]
                liftIO $ respond $ Left e
                return Nothing
            Right (value, after, next) -> do
                logInfo $ T.concat [prefix, " result"] --, T.pack $ show value]
                liftIO $ respond $ Right value
                return $ Just (after, next)

-- This is for adaptHandler to work with hMapL

data HAdaptHandler a = HAdaptHandler (Ref a) (ActorIdentity a)

instance
    ( ActorStage actor ~ stage
    , KnownSymbol sym
    , UncurryH
        (SignatureParams sig)
        (HandlerSig stage sig)
        (HandlerAction stage (SignatureReturn sig))
    , i ~ MethodHandler actor sym sig
    , o ~ ( (Proxy sym, Parcel sig) -> (AdaptedAction stage, Text) )
    ) =>
    H.ApplyAB (HAdaptHandler actor) i o where
        applyAB (HAdaptHandler ref ident) = adaptHandler ref ident

data AdaptHandlerConstraint :: Type -> Method -> Exp Constraint
type instance Eval (AdaptHandlerConstraint actor (sym ::: sig)) =
    ( KnownSymbol sym
    , UncurryH
        (SignatureParams sig)
        (HandlerSig (ActorStage actor) sig)
        (HandlerAction (ActorStage actor) (SignatureReturn sig))
    )

type AdaptedAction :: Type -> Type
type AdaptedAction stage = ActFor stage (Maybe (ActFor stage (), Next))

data AdaptedHandler :: Type -> Method -> Exp Type
type instance Eval (AdaptedHandler stage (sym ::: sig)) =
    (Proxy sym, Parcel sig) -> (AdaptedAction stage, Text)

launchActorThread
    :: forall (a::Type) (s::Type) (ms::[Method]) .
       ( ActorLaunch a
       , ActorStage a ~ s
       , ActorInterface a ~ ms
       , H.HOccurs
            (TVar (ActorRefMap a))
            (HList (Eval (Map ActorRefMapTVar_ (StageActors s))))
       , Eval (Map (AdaptedHandler s) ms)
         ~
         Eval
            (Map
                (Func (AdaptedAction s, Text))
                (Eval (Map Parcel_ ms))
            )
       , H.SameLength'
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
            (Eval (Map (Handler_ a) ms))
       , H.SameLength'
            (Eval (Map (Handler_ a) ms))
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
       , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms)))
       , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text)
       , H.HMapAux
            HList
            (HAdaptHandler a)
            (Eval (Map (Handler_ a) ms))
            (Eval
                (Map
                    (Func (AdaptedAction s, Text))
                    (Eval (Map Parcel_ ms))
                )
            )
       )
    => Ref a
    -> Chan (Invocation ms)
    -> TheaterFor s
    -> ActorIdentity a
    -> StageEnv s
    -> IO ()
launchActorThread ref chan theater actor env =
    void $ forkIO $ runActor theater env $ do
        let handlers' = H.hMapL (HAdaptHandler ref actor) handlers :: HList (Eval (Map (AdaptedHandler s) ms))
        logInfo $ prefix <> " starting"
        loop handlers'
        logInfo $ prefix <> " bye"
    where
    handlers :: HList (Eval (Map (Handler_ a) ms))
    handlers = actorBehavior (Proxy @a)

    prefix = T.concat ["[Actor '", T.pack $ show ref, "']"]

    loop :: HList (Eval (Map (AdaptedHandler s) ms)) -> ActFor s ()
    loop handlers' = do
        Invocation vary <- liftIO $ readChan chan
        let (run, prefixOn) = matchAdaptedHandler @s @ms vary handlers' :: (AdaptedAction s, Text)
        logInfo $ T.concat [prefixOn, " received"]
        result <- run
        proceed <-
            case result of
                Nothing -> pure True
                Just (after, next) -> do
                    after
                    case next of
                        Stop -> do
                            logInfo $ T.concat [prefixOn, " stopping"]

                            let tvar = H.hOccurs (theaterMap theater) :: TVar (ActorRefMap a)
                            liftIO $ atomically $ modifyTVar' tvar $ HM.delete ref

                            return False
                        Proceed -> do
                            logInfo $ T.concat [prefixOn, " done"]
                            return True
        when proceed $ loop handlers'

-- | Same as 'spawn', except it takes the theater as a parameter.
spawnIO
    :: forall (a::Type) (s::Type) (ms::[Method]) .
       ( ActorLaunch a
       , ActorStage a ~ s
       , Stage s
       , StageSpawn s ~ AllowSpawn
       , ActorInterface a ~ ms
       , H.HOccurs
            (TVar (ActorRefMap a))
            (HList (Eval (Map ActorRefMapTVar_ (StageActors s))))
       , Eval (Map (AdaptedHandler s) ms)
         ~
         Eval
            (Map
                (Func (AdaptedAction s, Text))
                (Eval (Map Parcel_ ms))
            )
       , H.SameLength'
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
            (Eval (Map (Handler_ a) ms))
       , H.SameLength'
            (Eval (Map (Handler_ a) ms))
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
       , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms)))
       , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text)
       , H.HMapAux
            HList
            (HAdaptHandler a)
            (Eval (Map (Handler_ a) ms))
            (Eval
                (Map
                    (Func (AdaptedAction s, Text))
                    (Eval (Map Parcel_ ms))
                )
            )
       )
    => TheaterFor s
    -> ActorIdentity a
    -> IO (StageEnv s)
    -> IO (Ref a)
spawnIO theater@(TheaterFor hlist _ (acounterTheater, acounterRef)) ident mkEnv = do
    let tvar = H.hOccurs hlist :: TVar (ActorRefMap a)
    chan <- newChan
    next <- fromJust <$> callIO' @"next" acounterTheater Proxy acounterRef HNil
    let ref = Ref next
    atomically $ modifyTVar' tvar $ HM.insert ref (ActorRef $ ActorRef' chan)
    env <- mkEnv
    launchActorThread ref chan theater ident env
    return ref

-- | Launch a new actor with the given ID and behavior. Return 'True' if the ID
-- was unused and the actor has been launched. Return 'False' if the ID is
-- already in use, thus a new actor hasn't been launched.
spawn
    :: forall (a::Type) (m::Type->Type) (s::Type) (ms::[Method]) .
       ( MonadActor m, MonadActorStage m ~ s
       , ActorLaunch a
       , ActorStage a ~ s
       , Stage s
       , StageSpawn s ~ AllowSpawn
       , ActorInterface a ~ ms
       , H.HOccurs
            (TVar (ActorRefMap a))
            (HList (Eval (Map ActorRefMapTVar_ (StageActors s))))
       , Eval (Map (AdaptedHandler s) ms)
         ~
         Eval
            (Map
                (Func (AdaptedAction s, Text))
                (Eval (Map Parcel_ ms))
            )
       , H.SameLength'
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
            (Eval (Map (Handler_ a) ms))
       , H.SameLength'
            (Eval (Map (Handler_ a) ms))
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
       , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms)))
       , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text)
       , H.HMapAux
            HList
            (HAdaptHandler a)
            (Eval (Map (Handler_ a) ms))
            (Eval
                (Map
                    (Func (AdaptedAction s, Text))
                    (Eval (Map Parcel_ ms))
                )
            )
       )
    => ActorIdentity a
    -> IO (StageEnv s)
    -> m (Ref a)
spawn ident mkEnv = liftActor $ do
    theater <- askTheater
    liftIO $ spawnIO theater ident mkEnv

--------------------------- Launching the actor system -----------------------

prepareActorType
    :: forall (a::Type) (s::Type) (ms::[Method]) .
       ( ActorLaunch a
       , ActorStage a ~ s
       , ActorInterface a ~ ms
       , H.HOccurs
            (TVar (ActorRefMap a))
            (HList (Eval (Map ActorRefMapTVar_ (StageActors s))))
       , Eval (Map (AdaptedHandler s) ms)
         ~
         Eval
            (Map
                (Func (AdaptedAction s, Text))
                (Eval (Map Parcel_ ms))
            )
       , H.SameLength'
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
            (Eval (Map (Handler_ a) ms))
       , H.SameLength'
            (Eval (Map (Handler_ a) ms))
            (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
       , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms)))
       , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text)
       , H.HMapAux
            HList
            (HAdaptHandler a)
            (Eval (Map (Handler_ a) ms))
            (Eval
                (Map
                    (Func (AdaptedAction s, Text))
                    (Eval (Map Parcel_ ms))
                )
            )
       , Stage s
       )
    => TheaterCounter (StageSpawn s)
    -> [(ActorIdentity a, StageEnv s)]
    -> IO
        ( ( TVar (ActorRefMap a)
          , TheaterFor s -> IO ()
          )
        , [(ActorIdentity a, Ref a)]
        )
prepareActorType counter actors = do
    refs <- produceRefs counter $ length actors
    let actorsWithRefs = zip actors refs
    actorsWithChans <- for actorsWithRefs $ \ ((ident, env), ref) -> do
        chan <- newChan
        return (ref, ident, env, chan)
    tvar <-
        newTVarIO $ HM.fromList $
            map
                (\ (ref, _, _, chan) -> (ref, ActorRef $ ActorRef' chan))
                actorsWithChans
    return
        ( ( tvar
          , \ theater -> for_ actorsWithChans $ \ (ref, ident, env, chan) ->
                launchActorThread ref chan theater ident env
          )
        , map (\ (ref, ident, _, _) -> (ident, ref)) actorsWithChans
        )

data HPrepareActorType (sm::SpawnMode) = HPrepareActorType (TheaterCounter sm)
instance
    forall (a::Type) (s::Type) (sm::SpawnMode) (ms::[Method]) (i::Type) (o::Type).
    ( ActorLaunch a
    , ActorStage a ~ s
    , StageSpawn s ~ sm
    , ActorInterface a ~ ms
    , H.HOccurs
         (TVar (ActorRefMap a))
         (HList (Eval (Map ActorRefMapTVar_ (StageActors s))))
    , Eval (Map (AdaptedHandler s) ms)
      ~
      Eval
         (Map
             (Func (AdaptedAction s, Text))
             (Eval (Map Parcel_ ms))
         )
    , H.SameLength'
         (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
         (Eval (Map (Handler_ a) ms))
    , H.SameLength'
         (Eval (Map (Handler_ a) ms))
         (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms))))
    , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms)))
    , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text)
    , H.HMapAux
         HList
         (HAdaptHandler a)
         (Eval (Map (Handler_ a) ms))
         (Eval
             (Map
                 (Func (AdaptedAction s, Text))
                 (Eval (Map Parcel_ ms))
             )
         )
    , Stage s
    , i ~ [(ActorIdentity a, StageEnv s)]
    , o ~ IO ((TVar (ActorRefMap a), TheaterFor s -> IO ()), [(ActorIdentity a, Ref a)])
    ) =>
    H.ApplyAB (HPrepareActorType sm) i o where
        applyAB (HPrepareActorType counter) a = prepareActorType counter a

data A_ :: Type -> Exp Constraint
type instance Eval (A_ a) =
    ( ActorLaunch a
    , H.HOccurs
         (TVar (ActorRefMap a))
         (HList (Eval (Map ActorRefMapTVar_ (StageActors (ActorStage a)))))
    , Eval (Map (AdaptedHandler (ActorStage a)) (ActorInterface a))
      ~
      Eval
         (Map
             (Func (AdaptedAction (ActorStage a), Text))
             (Eval (Map Parcel_ (ActorInterface a)))
         )
    , H.SameLength'
         (Eval (Map (Func (AdaptedAction (ActorStage a), Text)) (Eval (Map Parcel_ (ActorInterface a)))))
         (Eval (Map (Handler_ a) (ActorInterface a)))
    , H.SameLength'
         (Eval (Map (Handler_ a) (ActorInterface a)))
         (Eval (Map (Func (AdaptedAction (ActorStage a), Text)) (Eval (Map Parcel_ (ActorInterface a)))))
    , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) (ActorInterface a))))
    , Handle' (Eval (Map Parcel_ (ActorInterface a))) (AdaptedAction (ActorStage a), Text)
    , H.HMapAux
         HList
         (HAdaptHandler a)
         (Eval (Map (Handler_ a) (ActorInterface a)))
         (Eval
             (Map
                 (Func (AdaptedAction (ActorStage a), Text))
                 (Eval (Map Parcel_ (ActorInterface a)))
             )
         )
    )

data Starter :: Type -> Exp Type
type instance Eval (Starter a) = [(ActorIdentity a, StageEnv (ActorStage a))]

data Prepare_ :: Type -> Type -> Exp Type
type instance Eval (Prepare_ s a) = IO ((TVar (ActorRefMap a), TheaterFor s -> IO ()), [(ActorIdentity a, Ref a)])

data Pair_ :: Type -> Type -> Exp Type
type instance Eval (Pair_ s a) = (TVar (ActorRefMap a), TheaterFor s -> IO ())

data Triplet_ :: Type -> Type -> Exp Type
type instance Eval (Triplet_ s a) = ((TVar (ActorRefMap a), TheaterFor s -> IO ()), [(ActorIdentity a, Ref a)])

data Launch_ :: Type -> Type -> Exp Type
type instance Eval (Launch_ s _) = TheaterFor s -> IO ()

data Finisher :: Type -> Exp Type
type instance Eval (Finisher a) = [(ActorIdentity a, Ref a)]

class KnownSpawnMode (sm :: SpawnMode) where
    type SpawnModeInput sm = (i :: Type) | i -> sm
    loadCounter :: SpawnModeInput sm -> IO (TheaterCounter sm)
    produceRefs :: TheaterCounter sm -> Int -> IO [Ref a]

instance KnownSpawnMode NoSpawn where
    type SpawnModeInput NoSpawn = ()
    loadCounter () = pure ()
    produceRefs () count = pure $ map Ref [0 .. toEnum count - 1]

instance KnownSpawnMode AllowSpawn where
    type SpawnModeInput AllowSpawn = (LogFunc, FilePath)
    loadCounter (logFunc, pathA) = loadSingleACounterTheater logFunc pathA 0
    produceRefs (acounterTheater, acounterRef) count =
        replicateM count $
            Ref . fromJust <$>
                callIO' @"next" acounterTheater Proxy acounterRef HNil

startTheater'
    :: forall (s :: Type) (as :: [Type]) .
       ( Stage s
       , StageActors s ~ as
       , Eval (Constraints (Eval (Map A_ as)))

       , H.HMapAux
                          HList
                          (HPrepareActorType (StageSpawn s))
                          (Eval (Map Starter as))
                          (Eval (Map (Prepare_ s) as))
       , H.HSequence
                          IO (Eval (Map (Prepare_ s) as)) (Eval (Map (Triplet_ s) as))
       , H.HZipList
                          (Eval (Map (Pair_ s) as))
                          (Eval (Map Finisher as))
                          (Eval (Map (Triplet_ s) as))
       , H.HZipList
                          (Eval (Map ActorRefMapTVar_ as))
                          (Eval (Map (Launch_ s) as))
                          (Eval (Map (Pair_ s) as))
       , H.HList2List
                          (Eval (Map (Launch_ s) as)) (TheaterFor s -> IO ())
       , H.SameLength'
                          (Eval (Map (Prepare_ s) as)) (Eval (Map Starter as))
       , H.SameLength'
                          (Eval (Map (Triplet_ s) as)) (Eval (Map Finisher as))
       , H.SameLength'
                          (Eval (Map (Launch_ s) as)) (Eval (Map (Pair_ s) as))
       , H.SameLength'
                          (Eval (Map Starter as)) (Eval (Map (Prepare_ s) as))
       , H.SameLength'
                          (Eval (Map (Pair_ s) as)) (Eval (Map Finisher as))
       , H.SameLength'
                          (Eval (Map (Launch_ s) as)) (Eval (Map ActorRefMapTVar_ as))
       , H.SameLength'
                          (Eval (Map Finisher as)) (Eval (Map (Pair_ s) as))
       , H.SameLength'
                          (Eval (Map (Pair_ s) as)) (Eval (Map (Launch_ s) as))
       , H.SameLength'
                          (Eval (Map Finisher as)) (Eval (Map (Triplet_ s) as))
       , H.SameLength'
                          (Eval (Map ActorRefMapTVar_ as)) (Eval (Map (Launch_ s) as))
       )
    => SpawnModeInput (StageSpawn s)
    -> LogFunc
    -> HList (Eval (Map Starter as))
    -> IO (TheaterFor s, HList (Eval (Map Finisher as)))
startTheater' input logFunc actors = do
    counter <- loadCounter input
    let actions = H.hMapL (HPrepareActorType counter) actors :: HList (Eval (Map (Prepare_ s) as))
    mapsAndLaunchesAndResults <- H.hSequence actions :: IO (HList (Eval (Map (Triplet_ s) as)))
    let (mapsAndLaunches :: HList (Eval (Map (Pair_ s) as)), results :: HList (Eval (Map Finisher as))) = H.hUnzip mapsAndLaunchesAndResults
        (maps :: HList (Eval (Map ActorRefMapTVar_ as)), launches :: HList (Eval (Map (Launch_ s) as))) = H.hUnzip mapsAndLaunches
        theater = TheaterFor maps logFunc counter
    for_ (H.hList2List launches) $ \ launch -> launch theater
    return (theater, results)

-- | Launch the actor system
startTheater
    :: forall (s :: Type) (as :: [Type]) .
       ( Stage s
       , StageSpawn s ~ AllowSpawn
       , StageActors s ~ as
       , Eval (Constraints (Eval (Map A_ as)))

       , H.HMapAux
                          HList
                          (HPrepareActorType (StageSpawn s))
                          (Eval (Map Starter as))
                          (Eval (Map (Prepare_ s) as))
       , H.HSequence
                          IO (Eval (Map (Prepare_ s) as)) (Eval (Map (Triplet_ s) as))
       , H.HZipList
                          (Eval (Map (Pair_ s) as))
                          (Eval (Map Finisher as))
                          (Eval (Map (Triplet_ s) as))
       , H.HZipList
                          (Eval (Map ActorRefMapTVar_ as))
                          (Eval (Map (Launch_ s) as))
                          (Eval (Map (Pair_ s) as))
       , H.HList2List
                          (Eval (Map (Launch_ s) as)) (TheaterFor s -> IO ())
       , H.SameLength'
                          (Eval (Map (Prepare_ s) as)) (Eval (Map Starter as))
       , H.SameLength'
                          (Eval (Map (Triplet_ s) as)) (Eval (Map Finisher as))
       , H.SameLength'
                          (Eval (Map (Launch_ s) as)) (Eval (Map (Pair_ s) as))
       , H.SameLength'
                          (Eval (Map Starter as)) (Eval (Map (Prepare_ s) as))
       , H.SameLength'
                          (Eval (Map (Pair_ s) as)) (Eval (Map Finisher as))
       , H.SameLength'
                          (Eval (Map (Launch_ s) as)) (Eval (Map ActorRefMapTVar_ as))
       , H.SameLength'
                          (Eval (Map Finisher as)) (Eval (Map (Pair_ s) as))
       , H.SameLength'
                          (Eval (Map (Pair_ s) as)) (Eval (Map (Launch_ s) as))
       , H.SameLength'
                          (Eval (Map Finisher as)) (Eval (Map (Triplet_ s) as))
       , H.SameLength'
                          (Eval (Map ActorRefMapTVar_ as)) (Eval (Map (Launch_ s) as))
       )
    => FilePath
    -> LogFunc
    -> HList (Eval (Map Starter as))
    -> IO (TheaterFor s, HList (Eval (Map Finisher as)))
startTheater avarBoxPath logFunc = startTheater' (logFunc, avarBoxPath) logFunc












--newtype HandlerSet (ms :: [Method])







-- PROBLEM: I'm stuck with how App can hold the (TheaterFor Env) while Env
-- needs to somehow hold the route rendering function (Route App -> Text) so
-- there's a cyclic reference
--
-- And right now the classes below are weird:
--
-- * Stage and Env terms used interchangeably, it's cnfusing, Stage is weird
-- * The main type everything's keyed on is the Env, which is merely parameters
--   for the actor, perhaps we can key on an abstact type where Env is just one
--   of the things keyed on it?
--
-- And that change into abstract type can also help with the cyclic reference?







--data HFind :: Type -> [Type] -> Maybe Type
--type instance Eval (HFind a as) = Eval (Find (TyEq a) as) :: Exp (Maybe a)

{-




hSendTo
    :: ( Actor a
       , Eq (ActorKey a), Hashable (ActorKey a)
       )
    => (TVar (ActorRefOldMap a), Maybe (HashSet (ActorKey a), ActorMessage a))
    -> IO ()
hSendTo (_   , Nothing)            = pure ()
hSendTo (tvar, Just (recips, msg)) = do
    allActors <- readTVarIO tvar
    for_ (HM.intersection allActors (HS.toMap recips)) $
        \ actor -> sendIO' actor msg

data HSendTo = HSendTo
instance
    ( Actor a
    , Eq (ActorKey a), Hashable (ActorKey a)
    , i ~ (TVar (ActorRefOldMap a), Maybe (HashSet (ActorKey a), ActorMessage a))
    ) =>
    H.ApplyAB HSendTo i (IO ()) where
        applyAB _ a = hSendTo a

data B_ :: Type -> Exp Constraint
type instance Eval (B_ a) =
    ( Actor a
    , Eq (ActorKey a), Hashable (ActorKey a)
    )

data Set_ :: Type -> Exp Type
type instance Eval (Set_ a) = Maybe (HashSet (ActorKey a), ActorMessage a)

data Pair__ :: Type -> Exp Type
type instance Eval (Pair__ a) = (Eval (ActorRefMapTVar_ a), Eval (Set_ a))

-- | Like 'sendMany', except it takes the theater as a parameter.
sendManyIO
    :: forall s.
       ( Stage s
       , Eval (Constraints (Eval (Map B_ (StageActors s))))

       , H.HZipList
                          (Eval (Map ActorRefMapTVar_ (StageActors s)))
                          (Eval (Map Set_ (StageActors s)))
                          (Eval (Map Pair__ (StageActors s)))
       , H.SameLength'
                          (Eval (Map ActorRefMapTVar_ (StageActors s)))
                          (Eval (Map Set_ (StageActors s)))
       , H.SameLength'
                          (Eval (Map Set_ (StageActors s)))
                          (Eval (Map ActorRefMapTVar_ (StageActors s)))
       , H.SameLength'
                          (Eval (Map Set_ (StageActors s)))
                          (Eval (Map Pair__ (StageActors s)))
       , H.SameLength'
                          (Eval (Map Pair__ (StageActors s)))
                          (Eval (Map Set_ (StageActors s)))
       , H.HMapAux
                          HList
                          HSendTo
                          (Eval (Map Pair__ (StageActors s)))
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
       , H.SameLength'
                          (Eval (Map Pair__ (StageActors s)))
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
       , H.SameLength'
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
                          (Eval (Map Pair__ (StageActors s)))
       , H.HSequence
                          IO
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
                          (Eval (Map (ConstFn ()) (StageActors s)))
       )
    => TheaterFor s
    -> HList (Eval (Map Set_ (StageActors s)))
    -> IO ()
sendManyIO (TheaterFor hlist _ _) recips =
    let zipped = H.hZip hlist recips
            :: HList (Eval (Map Pair__ (StageActors s)))
        actions = H.hMapL HSendTo zipped
            :: HList (Eval (Map (ConstFn (IO ())) (StageActors s)))
        action = H.hSequence actions
            :: IO (HList (Eval (Map (ConstFn ()) (StageActors s))))
    in  void action

-- | Send a message to each actor in the set that exists in the system,
-- without waiting for results.
sendMany
    :: forall m s.
       ( MonadActor m, MonadActorStage m ~ s
       , Stage s
       , Eval (Constraints (Eval (Map B_ (StageActors s))))

       , H.HZipList
                          (Eval (Map ActorRefMapTVar_ (StageActors s)))
                          (Eval (Map Set_ (StageActors s)))
                          (Eval (Map Pair__ (StageActors s)))
       , H.SameLength'
                          (Eval (Map ActorRefMapTVar_ (StageActors s)))
                          (Eval (Map Set_ (StageActors s)))
       , H.SameLength'
                          (Eval (Map Set_ (StageActors s)))
                          (Eval (Map ActorRefMapTVar_ (StageActors s)))
       , H.SameLength'
                          (Eval (Map Set_ (StageActors s)))
                          (Eval (Map Pair__ (StageActors s)))
       , H.SameLength'
                          (Eval (Map Pair__ (StageActors s)))
                          (Eval (Map Set_ (StageActors s)))
       , H.HMapAux
                          HList
                          HSendTo
                          (Eval (Map Pair__ (StageActors s)))
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
       , H.SameLength'
                          (Eval (Map Pair__ (StageActors s)))
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
       , H.SameLength'
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
                          (Eval (Map Pair__ (StageActors s)))
       , H.HSequence
                          IO
                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
                          (Eval (Map (ConstFn ()) (StageActors s)))
       )
    => HList (Eval (Map Set_ (StageActors s)))
    -> m ()
sendMany keys = liftActor $ do
    theater <- askTheater
    liftIO $ sendManyIO theater keys
-}

{-

-- A way to collect a Signature's params and return value into a convenient
-- type we call Signature'
--
-- For example, given this signature:
--
-- @
-- type SaveTheWorld :: Signature
-- type SaveTheWorld = Int :-> String :-> Return Bool
-- @
--
-- We can do the following:
--
-- @
-- type SaveTheWorld' :: Signature'
-- type SaveTheWorld' = Pack SaveTheWorld
-- @
--
-- Which is equivalent to:
--
-- @
-- type SaveTheWorld' :: Signature'
-- type SaveTheWorld' = Signature' [Int, String] Bool
-- @

data Signature' = Signature' [Type] Type

--type PrependParam :: Type -> Signature' -> Signature'
type family PrependParam (t :: Type) (s :: Signature') = (s' :: Signature') | s' -> t s where
    PrependParam t ('Signature' params ret) = 'Signature' (t ': params) ret

--type Pack :: Signature -> Signature'
type family Pack (s :: Signature) = (s' :: Signature') | s' -> s where
    Pack ('Return t)  = 'Signature' '[] t
    Pack (t ':-> sig) = PrependParam t (Pack sig)

-- Getters for the Signature' type

type SignatureParams' :: Signature' -> [Type]
type family SignatureParams' s where
    SignatureParams' ('Signature' params _) = params

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

-- The actual message inserted into an actor's queue
--
-- For example, given this signature:
--
-- @
-- type SaveTheWorld :: Signature
-- type SaveTheWorld = Int :-> String :-> Return Bool
-- @
--
-- We could do the following (a bit silly example, the functions @sendBool@ and
-- @sendString@ don't really exist, they're just for the sake of the example):
--
-- @
-- parcel :: Parcel (Pack SaveTheWorld)
-- parcel = Parcel
--     {
--       -- HList [Int, String]
--       parcelParams = 5 `H.HCons` "cool" `H.HCons` H.HNil
--
--       -- Either SomeException Bool -> IO ()
--     , parcelReturn = \case
--          Left e -> sendString $ displayException e
--          Right b ->
--              if b
--                  then sendBool True
--                  else sendBool False
--     }
-- @

data Parcel (s :: Signature') = Parcel
    { parcelParams :: HList (SignatureParams' s)
    , parcelReturn :: Either SomeException (SignatureReturn' s) -> IO ()
    }

-}

-- We're going to define a "simple value holder" actor, which is both a good
-- simple example for using the actor system itself, and will serve us for
-- holding vat and actor auto-increasing numbering.
--
-- Let's start with the Box.

newtype Cell a = Cell a
instance PersistField a => PersistField (Cell a) where
    toPersistValue (Cell v) = toPersistValue v
    fromPersistValue = fmap Cell . fromPersistValue

instance PersistFieldSql a => PersistFieldSql (Cell a) where
    sqlType = sqlType . fmap uncell
        where
        uncell (Cell v) = v

instance PersistFieldSql a => BoxableVia (Cell a) where
    type BV (Cell a) = BoxableField

-- Let's use this Box in a new actor type, the value holder

data AVarStage (a :: Type)

instance Stage (AVarStage a) where
    data StageEnv (AVarStage a) = AVarStageEnv (Box (Cell a))
    type StageActors (AVarStage a) = '[AVar a]
    type StageSpawn (AVarStage a) = NoSpawn

data AVar (a :: Type)

instance Actor (AVar a) where
    type ActorStage (AVar a) = AVarStage a
    type ActorInterface (AVar a) =
        [ "get" ::: Return a
        , "put" ::: a :-> Return ()
        ]
    type ActorIdentity (AVar a) = ()

instance PersistFieldSql a => ActorLaunch (AVar a) where
    actorBehavior _ =
        (handleMethod @"get" := \ () -> do
            AVarStageEnv box <- askEnv
            Cell val <- withBox box obtain
            done val
        )
        `HCons`
        (handleMethod @"put" := \ () val -> do
            AVarStageEnv box <- askEnv
            withBox box $ bestow $ Cell val
            done ()
        )
        `HCons`
        HNil

-- So, we want to load a theater with exactly one AVar

loadSingleAVarTheater
    :: PersistFieldSql a
    => LogFunc
    -> FilePath
    -> a
    -> IO (TheaterFor (AVarStage a), Ref (AVar a))
loadSingleAVarTheater logFunc path initial = do
    box <- flip runLoggingT logFunc $ loadBox path $ Cell initial
    startStar () logFunc () (AVarStageEnv box)

-- Now, we have an infinite loop problem:
--
-- * Every theater needs an AVar, in order to auto-increase the key counter
-- * The AVar comes inside a Theater
--
-- Solution: Instead of using a Theater, we're going to write a different
-- version specialized for our purpose here. A single-actor theater, that
-- doesn't need to count. But since ActFor uses a Theater, we're going to use
-- Theater as well, except we just rely on avoiding any spawning.

startStar counter logFunc ident env = do
    (theater, actors `HCons` HNil) <- startTheater' counter logFunc $ [(ident, env)] `HCons` HNil
    ref <-
        case actors of
            [((), r)] -> pure r
            _ -> error "startStar: Expected exactly one actor"
    return (theater, ref)

-- Now, we can't really use AVar here because we need increase to be atomic,
-- and AVar has only 'get' and 'put'. We could write a whole new actor type for
-- this, or just wrap AVar (shows what wrapping looks like with current API),
-- or add a new method to AVar (which wouldn't work in a network setting,
-- unless there's a way to send a function (a->a) remotely).
--
-- Let's go for the wrapping.

data ACounterStage (a :: Type)

instance Stage (ACounterStage a) where
    data StageEnv (ACounterStage a) = ACounterStageEnv (TheaterFor (AVarStage a)) (Ref (AVar a))
    type StageActors (ACounterStage a) = '[ACounter a]
    type StageSpawn (ACounterStage a) = NoSpawn

data ACounter (a :: Type)

instance Actor (ACounter a) where
    type ActorStage (ACounter a) = ACounterStage a
    type ActorInterface (ACounter a) =
        '[ "next" ::: Return a
         ]
    type ActorIdentity (ACounter a) = ()

instance (Integral a, PersistFieldSql a) => ActorLaunch (ACounter a) where
    actorBehavior _ =
        (handleMethod @"next" := \ () -> do
            ACounterStageEnv avarTheater avarRef <- askEnv
            val <- liftIO $ fromJust <$> callIO' @"get" avarTheater Proxy avarRef HNil
            void $ liftIO $ sendIO' @"put" avarTheater Proxy avarRef $ (val+1) `HCons` HNil
            done val
        )
        `HCons`
        HNil

-- So, we want to load a theater with exactly one ACounter

loadSingleACounterTheater
    :: (Integral a, PersistFieldSql a)
    => LogFunc
    -> FilePath
    -> a
    -> IO (TheaterFor (ACounterStage a), Ref (ACounter a))
loadSingleACounterTheater logFunc pathA initial = do
    (theaterA, avarRef) <- loadSingleAVarTheater logFunc pathA initial
    startStar () logFunc () (ACounterStageEnv theaterA avarRef)

-- We now modify TheaterFor, to have 2 types of theaters: Ones that allow
-- spawning, and ones that don't.
--
-- And we're going to do it type-based.
--
-- Done. Now, how will we track the bidirectional mapping between DB key and
-- internal actor number? Let's see why we need both directions:
--
-- * In actor handlers, we need the DB key avalable somehow, i.e. startTheater
--   and spawn/IO must take this per-actor "env"
-- * Inbox POST handlers need to determine the internal ID in order to insert
--   the incoming activity

-- First let's define a type to use for the ID

newtype Ref a = Ref ActorInt deriving newtype (Eq, Show, Read, Hashable)

-- Now, for each actor type, specify an env type, and have spawn & startTheater
-- take these values

-- Done. Now, we need to keep the map updated:
--
-- [ ] Whenever an actor is deleted, remove from appActors as well (preferrably
--     even before the removal from Theater)

-- The next trick I'll try is Promise Pipelining. Well, to be precise, we just
-- start with simple minimal promises. What's a promise?
--
-- When you 'call', you do 2 things:
--
-- 1. Invoke a method by sending a message
-- 2. Synchronously wait for the result
--
-- In this step we're going to augment the API, so that calling returns a
-- *Promise*, and the synchronous waiting (which is supposed to be removed from
-- the API if I understand correctly how Goblins works) can be done on top.
--
-- First of all, every actor needs a persistent counter. To avoid a weird
-- infinite loop or an ugly workaround, let's (at least for now) not use
-- ACounter for this. We'll instead use a per-actor Box.