playwright/src/Control/Concurrent/Relic.hs

{- This file is part of playwright.
 -
 - Written in 2024, 2025 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 UndecidableInstances #-}

-- Persistence support for Fly actors.
module Control.Concurrent.Relic
    ( Treasure (..)
    , Named (..)
    , RelicRef ()

    , RelicName ()
    , RelicEnvData
    , RelicStateData
    , Migration ()
    , MigrationPlan ()
    , migZero
    , migStep
    , migPlan
    , migPlan'

    , Glide ()
    , askConfig
    , askEnv
    , getState
    , putState
    , modifyState
    , spawnRelic
    , callRelic
    , callSelfAux

    , RelicHandler ()
    , relicHandler
    , MainScroll ()
    , makeMainScroll
    , HelperScroll ()
    , makeHelperScroll

    , Relic (..)

    , RelicOriginSet (..)
    , FlyOriginSet (..)
    , TreasureOrigin (..)

    , RelicLaunchTreasure
    , launchTreasure
    , launchTreasure'
    , launchTreasure''

    , glideIO
    , spawnRelicIO
    , callRelicIO

    , RelicSpawn
    , spawnRelicIO'
    , callRelicIO'
    , relicRefToName
    , unRelicName
    , mkRelicName
    , mkRelicRef
    , relicHandler'

      -- Actor maps, for use by Goose
    , RelicCall (..)
    , RelicMap ()
    , relicMapNew
    , relicMapEnliven
    , relicMapCall
    , relicMapInsert
    )
where

import Control.Concurrent.STM
import Control.Exception.Base
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString (StrictByteString)
import Data.ByteString.Lazy (LazyByteString)
import Data.ByteString.Short (ShortByteString)
import Data.Foldable
import Data.Hashable
import Data.Int
import Data.IORef
import Data.Kind
import Data.Mold
import Data.Proxy
import Data.Text (Text)
import Data.Traversable
import Data.Typeable
import Data.Word
import GHC.TypeLits
import System.Directory
import System.FilePath
import UnliftIO.IO.File

import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as LT (Text)
import qualified Data.Vinyl as V
import qualified Data.Vinyl.CoRec as V
import qualified Data.Vinyl.Functor as V
import qualified Data.Vinyl.TypeLevel as V
import qualified StmContainers.Map as SM

import Control.Concurrent.Exchange
import Control.Concurrent.Fly
import Control.Concurrent.Lifespan
import Data.NameGenerator.Class

import Data.Type.List

import qualified Data.Vinyl.Local as V

------------------------------------------------------------------------------
-- Utils
------------------------------------------------------------------------------

-- Since Data.Text.IO.Utf8 isn't in LTS yet

decodeUtf8IO :: B.ByteString -> IO T.Text
decodeUtf8IO = evaluate . TE.decodeUtf8

readFileU :: FilePath -> IO T.Text
readFileU = decodeUtf8IO <=< B.readFile

writeFileU fp = B.writeFile fp . TE.encodeUtf8

------------------------------------------------------------------------------
-- Treasure, Named, RelicRef, RelicName
------------------------------------------------------------------------------

-- And now the configuration for saving and loading the system

class
    ( NameGenerator (TreasureNameGenerator t)
    ) =>
        Treasure t where

            type TreasureNameGenerator t :: Type

            type TreasureRelics t :: [(Type, [Type])]

            type TreasureConfig t :: Type

-- We need each Fly and each Implementor to name itself

class KnownSymbol (Name a) => Named a where
    type Name a :: Symbol

instance Named Integer where type Name Integer = "Integer"
instance Named Natural where type Name Natural = "Natural"
instance Named Int where type Name Int = "Int"
instance Named Int8 where type Name Int8 = "Int8"
instance Named Int16 where type Name Int16 = "Int16"
instance Named Int32 where type Name Int32 = "Int32"
instance Named Int64 where type Name Int64 = "Int64"
instance Named Word where type Name Word = "Word"
instance Named Word8 where type Name Word8 = "Word8"
instance Named Word16 where type Name Word16 = "Word16"
instance Named Word32 where type Name Word32 = "Word32"
instance Named Word64 where type Name Word64 = "Word64"
instance Named Float where type Name Float = "Float"
instance Named Double where type Name Double = "Double"
instance Named Char where type Name Char = "Char"
instance Named Text where type Name Text = "StrictText"
instance Named LT.Text where type Name LT.Text = "LazyText"
instance Named StrictByteString where type Name StrictByteString = "StrictByteString"
instance Named LazyByteString where type Name LazyByteString = "LazyByteString"
instance Named ShortByteString where type Name ShortByteString = "ShortByteString"

-- TODO switch from Show to Preserves + implement generics for Preserves?
-- TODO allow persistence backends, where the file-and-preserves-based is just
-- one possible option?
-- TODO support migrations and versioning

-- How do we load the system? Given a Treasure, we:
--
-- 1. Load the name generator
-- 2. For each Fly, for each Relic, we load the actor envs and states
-- 3. For each actor, we create the CallClient
-- 4. Map over envs-and-states, convert RelicRefData to RelicRef by adding the
--    CallClient
-- 5. Launch the actors i.e. CallServers

-- This is a live reference

data RelicRef (treasure :: Type) (fly :: Type) = RelicRef
    { rrFly :: FlyRef fly
    , rrName :: NameGeneratorName (TreasureNameGenerator treasure)
    }

-- This is the serializable form

newtype RelicName (treasure :: Type) (fly :: Type) = RelicName
    { unRelicName :: NameGeneratorName (TreasureNameGenerator treasure)
    }

deriving newtype instance Read (NameGeneratorName (TreasureNameGenerator t)) => Read (RelicName t f)

deriving newtype instance Show (NameGeneratorName (TreasureNameGenerator t)) => Show (RelicName t f)

instance MoldBase1 (RelicRef t f) (RelicRef t) (RelicName t) where
    type Molded1 (RelicRef t f) (RelicRef t) (RelicName t) = RelicName t f

instance Mold1 (RelicRef t f) (RelicRef t) (RelicName t) where
    mold1 f x = f x
    moldA1 f x = f x

------------------------------------------------------------------------------
-- Migrations
------------------------------------------------------------------------------

newtype To to from = To (from -> to)

newtype Migration (to :: Type) (froms :: [Type]) = Migration (V.Rec (To to) froms)

migZero :: Migration a '[]
migZero = Migration V.RNil

class MigStep mid to froms where
    migStep :: (from -> mid) -> Migration to froms -> Migration to (from : froms)

infixr 9 `migStep`

instance MigStep to to '[] where
    migStep f (Migration V.RNil) = Migration $ To f V.:& V.RNil

instance MigStep mid to (mid : froms) where
    migStep f (Migration tos@(To g V.:& _)) = Migration $ To (g . f) V.:& tos

migLength
    :: forall to froms . V.NatToInt (V.RLength froms)
    => Migration to froms
    -> Int
migLength (Migration _) = V.natToInt @(V.RLength froms)

loadAndMigrate
    :: forall to froms .
            ( Read to
            , Show to
            , V.AllConstrained Read froms
            , V.NatToInt (V.RLength froms)
            )
    => FilePath
    -> Int
    -> Migration to froms
    -> IO to
loadAndMigrate path start mig = do
    stored <- do
        e <- doesFileExist versionPath
        if e
            then pure (1 :: Int)
            else read . T.unpack <$> readFileU versionPath
    let current = start + migLength mig

    when (stored > current) $
        throwIO $ userError $
            "Old software version v" ++ show current ++
            " loading newer object v" ++ show stored
    when (stored < start) $
        throwIO $ userError $
            "New software version v" ++ show current ++
            " supporting minimal version v" ++ show start ++
            " loading too old object v" ++ show stored

    applyMig mig current stored start

    where

    versionPath = path ++ ".version"

    applyMig migration current stored slider = go migration slider
        where
        go :: V.AllConstrained Read fs => Migration to fs -> Int -> IO to
        go (Migration m) v =
            if v == stored then
                case m of
                    V.RNil -> readIO . T.unpack =<< readFileU path
                    To f V.:& _ -> do
                        to <- fmap f . readIO . T.unpack =<< readFileU path
                        writeBinaryFileDurableAtomic
                            path
                            (TE.encodeUtf8 $ T.pack $ show to)
                        writeBinaryFileDurableAtomic
                            versionPath
                            (TE.encodeUtf8 $ T.pack $ show current)
                        return to
            else if v < stored
                then
                    case m of
                        V.RNil -> error "Impossible: No mig to peel"
                        _ V.:& rest -> go (Migration rest) (v + 1)
            else error "Impossible: v > stored"

-- The Int is the current version number of the actor software
data MigrationPlan to = MigrationPlan Int (FilePath -> IO to)

migPlan
    :: ( Read to
       , Show to
       , V.AllConstrained Read froms
       , V.NatToInt (V.RLength froms)
       )
    => Migration to froms
    -> MigrationPlan to
migPlan = migPlan' 1

migPlan'
    :: ( Read to
       , Show to
       , V.AllConstrained Read froms
       , V.NatToInt (V.RLength froms)
       )
    => Int
    -> Migration to froms
    -> MigrationPlan to
migPlan' start mig =
    MigrationPlan
        (start + migLength mig)
        (\ path -> loadAndMigrate path start mig)

------------------------------------------------------------------------------
-- Relic
------------------------------------------------------------------------------

data GlideEnv r = GlideEnv
    { geEnv    :: RelicEnv r
    , geNG     :: TreasureNameGenerator (RelicTreasure r)
    , geRoot   :: FilePath
    , geAux    :: AuxRef r
    , geConfig :: TreasureConfig (RelicTreasure r)
    }

newtype Glide r a = Glide
    { unGlide
        :: StateT
            (RelicState r)
            (ReaderT (GlideEnv r) IO)
            a
    }
    deriving newtype (Functor, Applicative, Monad)

askEnv :: Relic r => Glide r (RelicEnv r)
askEnv = Glide $ lift $ asks geEnv

askNG :: Relic r => Glide r (TreasureNameGenerator (RelicTreasure r))
askNG = Glide $ lift $ asks geNG

askRoot :: Relic r => Glide r FilePath
askRoot = Glide $ lift $ asks geRoot

askAuxRef :: Relic r => Glide r (AuxRef r)
askAuxRef = Glide $ lift $ asks geAux

askConfig :: Relic r => Glide r (TreasureConfig (RelicTreasure r))
askConfig = Glide $ lift $ asks geConfig

getState :: Relic r => Glide r (RelicState r)
getState = Glide get

putState :: Relic r => RelicState r -> Glide r ()
putState = Glide . put

modifyState :: Relic r => (RelicState r -> RelicState r) -> Glide r ()
modifyState = Glide . modify'

glideIO :: IO a -> Glide r a
glideIO = Glide . lift . lift

spawnRelic
    :: forall t r1 r2 .
        ( Treasure t
        , Relic r1
        , Relic r2
        , t ~ RelicTreasure r1
        , t ~ RelicTreasure r2

        , RelicPrepare t r2
        , RelicFork t r2
        , Show (NameGeneratorName (TreasureNameGenerator t))

        , Show (RelicEnvData t r2)
        , Show (RelicStateData t r2)

        , Mold1 (RelicEnv r2) (RelicRef t) (RelicName t)
        , Mold1 (RelicState r2) (RelicRef t) (RelicName t)
        )
    => RelicOrigin r2
    -> Glide r1 (RelicRef t (RelicFly r2))
spawnRelic origin = do
    ng <- askNG
    root <- askRoot
    config <- askConfig
    glideIO $ do
        (env, state) <- relicPrepare @r2 origin
        (server, ref) <- prepareFly @r2
        name <- generateName ng

        let home = relicHome @t @r2 root name
        createDirectoryIfMissing True home

        writeBinaryFileDurableAtomic
            (home </> "env")
            (TE.encodeUtf8 $ T.pack $ show $
                mold1
                    @(RelicEnv r2) @(RelicRef t) @(RelicName t)
                    (RelicName . rrName) env
            )
        let MigrationPlan envVersion _ = relicMigrateEnv @r2
        writeBinaryFileDurableAtomic
            (home </> "env.version")
            (TE.encodeUtf8 $ T.pack $ show envVersion)

        writeBinaryFileDurableAtomic
            (home </> "state")
            (TE.encodeUtf8 $ T.pack $ show $
                mold1
                    @(RelicState r2) @(RelicRef t) @(RelicName t)
                    (RelicName . rrName) state
            )
        let MigrationPlan stateVersion _ = relicMigrateState @r2
        writeBinaryFileDurableAtomic
            (home </> "state.version")
            (TE.encodeUtf8 $ T.pack $ show stateVersion)

        forkRelic root ng config $ RelicData3 @t @r2 env state name server ref
        return $ RelicRef ref name

callRelic
    :: forall
            (sym :: Symbol)
            (fly :: Type)
            (treasure :: Type)
            (r :: Type)
            (param :: Type)
            (method :: (Symbol, Type)) .
        ( Fly fly
        , method ~ '(sym, param)
        , V.Fst method ~ sym
        , V.Snd method ~ param
        , method V.∈ FlyInterface fly
        , LookupParam sym (FlyInterface fly) ~ Just param

        , Relic r
        )
    => RelicRef treasure fly
    -> param
    -> Glide r ()
callRelic (RelicRef ref _name) arg = glideIO $ callFly @sym ref arg

callSelfAux
    :: forall
            (sym :: Symbol)
            (r :: Type)
            (param :: Type)
            (method :: (Symbol, Type)) .
        ( Relic r
        , Implementor r
        , method ~ '(sym, param)
        , V.Fst method ~ sym
        , V.Snd method ~ param
        , method V.∈ ImplementorHelpers r
        , LookupParam sym (ImplementorHelpers r) ~ Just param
        )
    => param
    -> Glide r ()
callSelfAux arg = do
    auxRef <- askAuxRef
    glideIO $ callAux @sym auxRef arg

newtype RelicHandler (r :: Type) (m :: (Symbol, Type)) = RelicHandler
    { _RelicHandler :: V.Snd m -> Glide r (Coda Glide r)
    }

relicHandler
    :: forall
            (sym :: Symbol)
            (relic :: Type)
            (method :: (Symbol, Type))
            (param :: Type) .
        ( method ~ '(sym, param)
        , V.Fst method ~ sym
        , V.Snd method ~ param
        )
    => (param -> Glide relic (Coda Glide relic))
    -> RelicHandler relic method
relicHandler = RelicHandler

newtype MainScroll r = MainScroll
    { unMainScroll :: V.Rec (RelicHandler r) (FlyInterface (RelicFly r))
    }

makeMainScroll
    :: V.Rec (RelicHandler r) (FlyInterface (RelicFly r)) -> MainScroll r
makeMainScroll = MainScroll

newtype HelperScroll r = HelperScroll
    { unHelperScroll :: V.Rec (RelicHandler r) (RelicHelpers r)
    }

makeHelperScroll :: V.Rec (RelicHandler r) (RelicHelpers r) -> HelperScroll r
makeHelperScroll = HelperScroll

-- TODO tracking the updates - where do we run migrations?
--
-- [x] When loading from file
-- [x] When spawning new actor, we need to write the version file
-- [x] Same when launching root actors from origins
--
-- We have a problem: Migrations get defined on the actual state and env, but
-- the data stored is the molded form with RelicName instead of RelicRef
--
-- What do we do? Ideas:
--
--  * Expose RelicName and define migrations on Relic{Env,State}Data t r
--  * Have a data Mode = Live | Stored as a type parameter of RelicRef
--  * When loading from file:
--      - Split migration process into 2 steps: Instead of just loading target
--        type from file, load the *stored* version, and do the enlivening
--        using that!
--      - Then, right before the forking, apply the migrations

class (Fly (RelicFly i), Alive i) => Relic i where

    type RelicFly i :: Type

    type RelicHelpers i :: [(Symbol, Type)]

    type RelicOrigin i :: Type

    type RelicEnv i :: Type

    type RelicState i :: Type

    -- We need this for the Implementor instance, where relicToCall is used,
    -- which depends on t which controls the NameGeneratorName in RelicRefs
    type RelicTreasure i :: Type

    relicPrepare :: RelicOrigin i -> IO (RelicEnv i, RelicState i)

    relicMigrateEnv :: MigrationPlan (RelicEnvData (RelicTreasure i) i)

    relicMigrateState :: MigrationPlan (RelicStateData (RelicTreasure i) i)

    relicInit :: RelicRef (RelicTreasure i) (RelicFly i) -> Glide i ()

    -- When launching the Treasure (but not when calling spawnRelic etc.),
    -- should actors of this type be registered in the produced RelicMap?
    relicRegister :: Bool
    relicRegister = True

    relicScroll :: MainScroll i

    relicHelpers :: HelperScroll i

------------------------------------------------------------------------------
-- Step 1: loadTreasure: Parse actor data from files, into TreasureData1
------------------------------------------------------------------------------

-- First step, we load data in serialized format from persistent storage

type RelicEnvData t r = Molded1 (RelicEnv r) (RelicRef t) (RelicName t)

type RelicStateData t r = Molded1 (RelicState r) (RelicRef t) (RelicName t)

data RelicData1 t (r :: Type) = RelicData1
    { _relic1Env :: RelicEnvData t r
    , _relic1State :: RelicStateData t r
    , _relic1Key :: NameGeneratorName (TreasureNameGenerator t)
    }

newtype RelicSet1 t (r :: Type) = RelicSet1
    { _unRelicSet1 :: [RelicData1 t r]
    }

newtype FlyData1 t (f :: (Type, [Type])) = FlyData1
    { _unFlyData1 :: V.Rec (RelicSet1 t) (V.Snd f)
    }

newtype TreasureData1 t = TreasureData1
    { _TreasureData1 :: V.Rec (FlyData1 t) (TreasureRelics t)
    }

class
    ( Named r
    , Relic r
    , Read (RelicEnvData t r)
    , Read (RelicStateData t r)
    , t ~ RelicTreasure r
    ) =>
        RelicLoad t r

instance
    ( Named r
    , Relic r
    , Read (RelicEnvData t r)
    , Read (RelicStateData t r)
    , t ~ RelicTreasure r
    ) =>
        RelicLoad t r

loadRelic
    :: forall t r .
        ( Read (NameGeneratorName (TreasureNameGenerator t))
        , RelicLoad t r
        )
    => FilePath
    -> Proxy r
    -> IO (RelicSet1 t r)
loadRelic fly _ = do
    let name = fromSSymbol $ symbolSing @(Name r)
        path = fly </> name
    createDirectoryIfMissing False path
    keys <- do
        subs <- listDirectory path
        for subs $ \ sub -> do
            key <- readIO @(NameGeneratorName (TreasureNameGenerator t)) sub
            return (sub, key)
    fmap RelicSet1 $ for keys $ \ (sub, key) -> do
        let home = path </> sub
        env <- do
            let MigrationPlan _ load = relicMigrateEnv @r
            load $ home </> "env"
        state <- do
            let MigrationPlan _ load = relicMigrateState @r
            load $ home </> "state"
        return $ RelicData1 env state key

class
    ( Named (V.Fst frs)
    , V.RecApplicative (V.Snd frs)
    , V.RecTraverseMethod (RelicLoad t) Proxy (V.Snd frs)
    ) =>
        FlyAndRelics t (frs :: (Type, [Type]))

instance
    ( '(f, rs) ~ '(V.Fst '(f, rs), V.Snd '(f, rs))
    , Named f
    , V.RecApplicative rs
    , V.RecTraverseMethod (RelicLoad t) Proxy rs
    ) =>
        FlyAndRelics t '(f, rs)

loadFly
    :: forall t (frs :: (Type, [Type])) .
        ( Read (NameGeneratorName (TreasureNameGenerator t))
        , FlyAndRelics t frs
        )
    => FilePath
    -> Proxy frs
    -> IO (FlyData1 t frs)
loadFly root _ = do
    let name = fromSSymbol $ symbolSing @(Name (V.Fst frs))
        path = root </> name
    createDirectoryIfMissing False path
    FlyData1 <$> V.rtraverseMethod @(RelicLoad t) (loadRelic @t path) (V.rpure @(V.Snd frs) Proxy)

loadTreasure
    :: forall t.
        ( Treasure t
        , Read (NameGeneratorName (TreasureNameGenerator t))
        , V.RecApplicative (TreasureRelics t)
        , V.RecTraverseMethod (FlyAndRelics t) Proxy (TreasureRelics t)
        )
    => FilePath
    -> IO (TreasureData1 t)
loadTreasure path =
    TreasureData1 <$> V.rtraverseMethod @(FlyAndRelics t) (loadFly @t path) (V.rpure @(TreasureRelics t) Proxy)

------------------------------------------------------------------------------
-- Step 2: prepareTreasure: Create the Chan for each actor, into TreasureData2
------------------------------------------------------------------------------

-- Next step is to create a Chan for every actor

data RelicData2 (t :: Type) (r :: Type) = RelicData2
    { _relic2Env :: RelicEnvData t r
    , _relic2State :: RelicStateData t r
    , _relic2Key :: NameGeneratorName (TreasureNameGenerator t)
    , _relic2Server :: FlyServer r
    , _relic2Ref :: FlyRef (RelicFly r)
    }

newtype RelicSet2 (t :: Type) (r :: Type) = RelicSet2
    { _unRelicSet2 :: [RelicData2 t r]
    }

newtype FlyData2 (t :: Type) (frs :: (Type, [Type])) = FlyData2
    { _unFlyData2 :: V.Rec (RelicSet2 t) (V.Snd frs)
    }

newtype TreasureData2 t = TreasureData2
    { _TreasureData2 :: V.Rec (FlyData2 t) (TreasureRelics t)
    }

class
    ( Relic r
    , V.RMapCM
        (FlyInterface (RelicFly r))
        (FlyInterface (RelicFly r))
    , V.RMapCM (RelicHelpers r) (RelicHelpers r)
    , V.RecApplicative (FlyInterface (RelicFly r))
    , V.RecApplicative (RelicHelpers r)
    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (FlyInterface (RelicFly r))
    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (RelicHelpers r)
    , t ~ RelicTreasure r
    , Mold1 (RelicState r) (RelicRef t) (RelicName t)
    , Show (RelicStateData t r)

    , Named r
    , Named (RelicFly r)
    , Show (NameGeneratorName (TreasureNameGenerator t))
    , Show (RelicEnvData t r)
    , Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
    ) =>
        RelicPrepare t r
instance
    ( Relic r
    , V.RMapCM
        (FlyInterface (RelicFly r))
        (FlyInterface (RelicFly r))
    , V.RMapCM (RelicHelpers r) (RelicHelpers r)
    , V.RecApplicative (FlyInterface (RelicFly r))
    , V.RecApplicative (RelicHelpers r)
    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (FlyInterface (RelicFly r))
    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (RelicHelpers r)
    , t ~ RelicTreasure r
    , Mold1 (RelicState r) (RelicRef t) (RelicName t)
    , Show (RelicStateData t r)

    , Named r
    , Named (RelicFly r)
    , Show (NameGeneratorName (TreasureNameGenerator t))
    , Show (RelicEnvData t r)
    , Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
    ) =>
        RelicPrepare t r

prepareRelic
    :: forall t r .
        ( RelicPrepare t r
        )
    => RelicSet1 t r
    -> IO (RelicSet2 t r)
prepareRelic (RelicSet1 rs) =
    fmap RelicSet2 $ for rs $ \ (RelicData1 env state key) -> do
        (server, ref) <- prepareFly @r
        return $ RelicData2 env state key server ref

class
    V.RecTraverseMethod (RelicPrepare t) (RelicSet1 t) (V.Snd frs) =>
        FlyAndRelics2 t frs

instance
    V.RecTraverseMethod (RelicPrepare t) (RelicSet1 t) (V.Snd frs) =>
        FlyAndRelics2 t frs

prepareFlySet
    :: forall t frs . FlyAndRelics2 t frs
    => FlyData1 t frs
    -> IO (FlyData2 t frs)
prepareFlySet (FlyData1 sets) =
    FlyData2 <$> V.rtraverseMethod @(RelicPrepare t) prepareRelic sets

prepareTreasure
    :: forall t .
        ( Treasure t
        , V.RecTraverseMethod (FlyAndRelics2 t) (FlyData1 t) (TreasureRelics t)
        )
    => TreasureData1 t
    -> IO (TreasureData2 t)
prepareTreasure (TreasureData1 flies) =
    TreasureData2 <$> V.rtraverseMethod @(FlyAndRelics2 t) prepareFlySet flies

------------------------------------------------------------------------------
-- Step 3: enlivenTreasure: Convert refs in states & envs, into TreasureData3
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- lookupInput: Prepare map for ref key lookup
------------------------------------------------------------------------------

class (Relic r, f ~ RelicFly r) => FlyAndRelic3 f r
instance (Relic r, f ~ RelicFly r) => FlyAndRelic3 f r

lookupInput''
    :: FlyAndRelic3 f r
    => RelicSet2 t r
    -> V.Const [(NameGeneratorName (TreasureNameGenerator t), FlyRef f)] r
lookupInput'' (RelicSet2 rds) = V.Const $ map toPair rds
    where
    toPair (RelicData2 _ _ key _ ref) = (key, ref)

class
    ( frs ~ '(V.Fst frs, V.Snd frs)
    , V.RecMapMethod (FlyAndRelic3 (V.Fst frs)) (RelicSet2 t) (V.Snd frs)
    , V.RecordToList (V.Snd frs)
    ) =>
        FlyAndRelics3 (t :: Type) (frs :: (Type, [Type]))
instance
    ( frs ~ '(V.Fst frs, V.Snd frs)
    , V.RecMapMethod (FlyAndRelic3 (V.Fst frs)) (RelicSet2 t) (V.Snd frs)
    , V.RecordToList (V.Snd frs)
    ) =>
        FlyAndRelics3 t frs

newtype Input t frs = Input
    { _unInput :: [(NameGeneratorName (TreasureNameGenerator t), FlyRef (V.Fst frs))]
    }

lookupInput'
    :: forall t frs .
        ( Treasure t
        , FlyAndRelics3 t frs
        )
    => FlyData2 t frs
    -> Input t frs
lookupInput' (FlyData2 sets) =
    Input $ concat $ V.recordToList $ V.rmapMethod @(FlyAndRelic3 (V.Fst frs)) lookupInput'' sets

lookupInput
    :: forall t .
        ( Treasure t
        , V.RecMapMethod' (FlyAndRelics3 t) (FlyData2 t) (TreasureRelics t)
        )
    => TreasureData2 t
    -> V.Rec (Input t) (TreasureRelics t)
lookupInput (TreasureData2 fds) = V.rmapMethod' @(FlyAndRelics3 t) lookupInput' fds

------------------------------------------------------------------------------
-- enlivenRef
------------------------------------------------------------------------------

-- It's now time to mold the state and env

enlivenRef''
    :: Treasure t
    => Input t frs
    -> RelicName t (V.Fst frs)
    -> Maybe (RelicRef t (V.Fst frs))
enlivenRef'' (Input pairs) (RelicName name) =
    flip RelicRef name <$> lookup name pairs

data RelicRefToNonexistentActor (t :: Type) =
    RelicRefToNonexistentActor String (NameGeneratorName (TreasureNameGenerator t))
    deriving Typeable

{-
deriving instance
    Typeable (NameGeneratorName (TreasureNameGenerator t)) =>
        Typeable (RelicRefToNonexistentActor t)
-}

deriving instance
    Show (NameGeneratorName (TreasureNameGenerator t)) =>
        Show (RelicRefToNonexistentActor t)

instance
    ( Treasure t
    , Show (NameGeneratorName (TreasureNameGenerator t))
    , Typeable (NameGeneratorName (TreasureNameGenerator t))
    , Typeable t
    ) =>
        Exception (RelicRefToNonexistentActor t)

enlivenRef'
    :: forall t frs f rs .
        ( Treasure t
        , frs V.∈ TreasureRelics t
        , frs ~ '(f, rs)
        )
    => V.Rec (Input t) (TreasureRelics t)
    -> RelicName t f
    -> Maybe (RelicRef t f)
enlivenRef' inputs name = enlivenRef'' (V.rget @frs inputs) name

enlivenRef
    :: forall t frs f rs .
        ( Treasure t
        , Typeable t
        , frs V.∈ TreasureRelics t
        , frs ~ '(f, rs)
        , Named f
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))
        )
    => V.Rec (Input t) (TreasureRelics t)
    -> RelicName t f
    -> RelicRef t f
enlivenRef inputs name@(RelicName n) =
    case enlivenRef' @t @frs @f @rs inputs name of
        Nothing ->
            let s = fromSSymbol $ symbolSing @(Name f)
            in  RelicRef (throw $ RelicRefToNonexistentActor @t s n) n
        Just ref -> ref

------------------------------------------------------------------------------
-- enlivenEnv, enlivenState
------------------------------------------------------------------------------

type InputRec t = V.Rec (Input t) (TreasureRelics t)

class
    ( Treasure t
    , Lookup f (TreasureRelics t) ~ 'Just (LookupJust f (TreasureRelics t))
    , '(f, LookupJust f (TreasureRelics t)) V.∈ TreasureRelics t
    , Named f
    ) =>
        TreasureFly t f
instance
    ( Treasure t
    , Lookup f (TreasureRelics t) ~ 'Just (LookupJust f (TreasureRelics t))
    , '(f, LookupJust f (TreasureRelics t)) V.∈ TreasureRelics t
    , Named f
    ) =>
        TreasureFly t f

instance MoldBase1 (RelicName t f) (RelicName t) (RelicRef t) where
    type Molded1 (RelicName t f) (RelicName t) (RelicRef t) = RelicRef t f

instance
    ( Treasure t
    , Lookup f (TreasureRelics t) ~ 'Just (LookupJust f (TreasureRelics t))
    , '(f, LookupJust f (TreasureRelics t)) V.∈ TreasureRelics t
    , Named f
    , InputRec t ~ i
    ) =>
        MoldM1C (TreasureFly t) (RelicName t f) (Reader i) (RelicName t) (RelicRef t) where
            moldM1c f x = f x

enlivenState
    :: forall t r .
        ( Treasure t
        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))
        , Mold1 (RelicState r) (RelicRef t) (RelicName t)
        , MoldM1C (TreasureFly t) (RelicStateData t r) (Reader (InputRec t)) (RelicName t) (RelicRef t)
        , Molded1 (RelicStateData t r) (RelicName t) (RelicRef t) ~ RelicState r
        )
    => InputRec t
    -> RelicStateData t r
    -> RelicState r
enlivenState input state =
    runReader
        (moldM1c
            @(TreasureFly t) @(RelicStateData t r) @(Reader (InputRec t)) @(RelicName t) @(RelicRef t)
            f state
        )
        input
    where
    f :: forall f . TreasureFly t f => RelicName t f -> Reader (InputRec t) (RelicRef t f)
    f name = do
        i <- ask
        pure $ enlivenRef @t @('(f, LookupJust f (TreasureRelics t))) i name

enlivenEnv
    :: forall t r .
        ( Treasure t
        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))
        , Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
        , MoldM1C (TreasureFly t) (RelicEnvData t r) (Reader (InputRec t)) (RelicName t) (RelicRef t)
        , Molded1 (RelicEnvData t r) (RelicName t) (RelicRef t) ~ RelicEnv r
        )
    => InputRec t
    -> RelicEnvData t r
    -> RelicEnv r
enlivenEnv input env =
    runReader
        (moldM1c
            @(TreasureFly t) @(RelicEnvData t r) @(Reader (InputRec t)) @(RelicName t) @(RelicRef t)
            f env
        )
        input
    where
    f :: forall f . TreasureFly t f => RelicName t f -> Reader (InputRec t) (RelicRef t f)
    f name = do
        i <- ask
        pure $ enlivenRef @t @('(f, LookupJust f (TreasureRelics t))) i name

------------------------------------------------------------------------------
-- enlivenTreasure
------------------------------------------------------------------------------

-- Now that we know how to mold them, let's do it for the whole system

data RelicData3 t (r :: Type) = RelicData3
    { _relic3Env :: RelicEnv r
    , _relic3State :: RelicState r
    , _relic3Key :: NameGeneratorName (TreasureNameGenerator t)
    , _relic3Server :: FlyServer r
    , _relic3Ref :: FlyRef (RelicFly r)
    }

newtype RelicSet3 t (r :: Type) = RelicSet3
    { _unRelicSet3 :: [RelicData3 t r]
    }

newtype FlyData3 t (f :: (Type, [Type])) = FlyData3
    { _unFlyData3 :: V.Rec (RelicSet3 t) (V.Snd f)
    }

newtype TreasureData3 t = TreasureData3
    { _TreasureData3 :: V.Rec (FlyData3 t) (TreasureRelics t)
    }

class
    ( Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
    , MoldM1C (TreasureFly t) (RelicEnvData t r) (Reader (InputRec t)) (RelicName t) (RelicRef t)
    , Molded1 (RelicEnvData t r) (RelicName t) (RelicRef t) ~ RelicEnv r

    , Mold1 (RelicState r) (RelicRef t) (RelicName t)
    , MoldM1C (TreasureFly t) (RelicStateData t r) (Reader (InputRec t)) (RelicName t) (RelicRef t)
    , Molded1 (RelicStateData t r) (RelicName t) (RelicRef t) ~ RelicState r
    ) =>
        TreasureEnliven t r
instance
    ( Treasure t

    , Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
    , MoldM1C (TreasureFly t) (RelicEnvData t r) (Reader (InputRec t)) (RelicName t) (RelicRef t)
    , Molded1 (RelicEnvData t r) (RelicName t) (RelicRef t) ~ RelicEnv r

    , Mold1 (RelicState r) (RelicRef t) (RelicName t)
    , MoldM1C (TreasureFly t) (RelicStateData t r) (Reader (InputRec t)) (RelicName t) (RelicRef t)
    , Molded1 (RelicStateData t r) (RelicName t) (RelicRef t) ~ RelicState r
    ) =>
        TreasureEnliven t r

enlivenRelic
    :: forall t r .
        ( Treasure t
        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))

        , TreasureEnliven t r
        )
    => InputRec t
    -> RelicData2 t r
    -> RelicData3 t r
enlivenRelic input (RelicData2 env state key server ref) =
    RelicData3
        (enlivenEnv @t @r input env)
        (enlivenState @t @r input state)
        key
        server
        ref

enlivenRelicSet
    :: forall t r .
        ( Treasure t
        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))

        , TreasureEnliven t r
        )
    => InputRec t
    -> RelicSet2 t r
    -> RelicSet3 t r
enlivenRelicSet input (RelicSet2 rds) =
    RelicSet3 $ map (enlivenRelic input) rds

class
    V.RecMapMethod' (TreasureEnliven t) (RelicSet2 t) (V.Snd frs) =>
        TreasureEnlivenFly (t :: Type) (frs :: (Type, [Type]))

instance
    ( Treasure t
    , V.RecMapMethod' (TreasureEnliven t) (RelicSet2 t) (V.Snd frs)
    ) =>
        TreasureEnlivenFly (t :: Type) (frs :: (Type, [Type]))

enlivenFly
    :: forall t frs .
        ( Treasure t
        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))

        , TreasureEnlivenFly t frs
        )
    => InputRec t
    -> FlyData2 t frs
    -> FlyData3 t frs
enlivenFly input (FlyData2 sets) =
    FlyData3 $ V.rmapMethod' @(TreasureEnliven t) (enlivenRelicSet @t input) sets

enlivenTreasure
    :: forall t .
        ( Treasure t
        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))

        , V.RecMapMethod' (TreasureEnlivenFly t) (FlyData2 t) (TreasureRelics t)
        )
    => InputRec t
    -> TreasureData2 t
    -> TreasureData3 t
enlivenTreasure input (TreasureData2 flies) =
    TreasureData3 $ V.rmapMethod' @(TreasureEnlivenFly t) (enlivenFly input) flies

------------------------------------------------------------------------------
-- Step 4: forkTreasure: Launch all actor threads
------------------------------------------------------------------------------

data ImplEnv i = ImplEnv
    { _iiHome :: FilePath
    , _iiRoot :: FilePath
    , _iiNG   :: TreasureNameGenerator (RelicTreasure i)
    , _iiEnv :: RelicEnv i
    , _iiState :: IORef (RelicState i)
    , _iiAux :: AuxRef i
    , _iiConfig :: TreasureConfig (RelicTreasure i)
    }

class (Relic r, m ~ '(V.Fst m, V.Snd m)) => RelicAndMethod r m
instance (Relic r, m ~ '(V.Fst m, V.Snd m)) => RelicAndMethod r m

instance
    ( Relic i
    , Fly (RelicFly i)
    , V.RecMapMethod' (RelicAndMethod i) (RelicHandler i) (FlyInterface (RelicFly i))
    , V.RecMapMethod' (RelicAndMethod i) (RelicHandler i) (RelicHelpers i)
    , t ~ RelicTreasure i
    , Mold1 (RelicState i) (RelicRef t) (RelicName t)
    , Show (RelicStateData t i)
    ) =>
        Implementor i where
            type ImplementorFly i = RelicFly i
            type ImplementorHelpers i = RelicHelpers i
            type ImplementorMonad i = ReaderT (ImplEnv i) IO
            type ImplementorSide i = Coda Glide i
            flyScript = makeScript $ V.rmapMethod' @(RelicAndMethod i) (relicToCall @t) $ unMainScroll $ relicScroll @i
            flyHelpers = makeHelperScript $ V.rmapMethod' @(RelicAndMethod i) (relicToCall @t) $ unHelperScroll $ relicHelpers @i

glideToCall
    :: forall t r a .
        ( Relic r
        , Mold1 (RelicState r) (RelicRef t) (RelicName t)
        , Show (RelicStateData t r)
        )
    => Glide r a
    -> ReaderT (ImplEnv r) IO a
glideToCall glide = do
    ImplEnv home root ng env stateRef meAux config <- ask
    state <- lift $ readIORef stateRef
    (ret, state') <- lift $ runReaderT (runStateT (unGlide glide) state) (GlideEnv env ng root meAux config)
    {-
    lift $ putStrLn $ home </> "state"
    lift $ putStrLn $
        (show $
            mold1
                @(RelicState r) @(RelicRef t) @(RelicName t)
                (RelicName . rrName) state'
        )
    -}
    lift $ writeBinaryFileDurableAtomic
        (home </> "state")
        (TE.encodeUtf8 $ T.pack $ show $
            mold1
                @(RelicState r) @(RelicRef t) @(RelicName t)
                (RelicName . rrName) state'
        )
    lift $ atomicWriteIORef stateRef state'
    return ret

relicToCall
    :: forall t r m .
        ( Relic r
        , Mold1 (RelicState r) (RelicRef t) (RelicName t)
        , m ~ '(V.Fst m, V.Snd m)
        , Show (RelicStateData t r)
        )
    => RelicHandler r m
    -> CallHandler (ReaderT (ImplEnv r) IO) (Coda Glide r) m
relicToCall (RelicHandler glide) =
    handleCall @(V.Fst m) $ glideToCall @t @r . glide

makeSide
    :: forall t r .
        ( Relic r
        , Mold1 (RelicState r) (RelicRef t) (RelicName t)
        , Show (RelicStateData t r)
        )
    => Coda Glide r
    -> (ReaderT (ImplEnv r) IO (), Next)
makeSide = toSideValue (glideToCall @t @r) die
    where
    die = do
        ImplEnv home _ _ _ _ _ _ <- ask
        lift $ removeDirectoryRecursive home

relicHome
    :: forall t r .
        ( Treasure t
        , Relic r
        , Named (RelicFly r)
        , Named r
        , Show (NameGeneratorName (TreasureNameGenerator t))
        )
    => FilePath
    -> NameGeneratorName (TreasureNameGenerator t)
    -> FilePath
relicHome root key =
    let fly = fromSSymbol $ symbolSing @(Name (RelicFly r))
        relic = fromSSymbol $ symbolSing @(Name r)
    in  root </> fly </> relic </> show key

class
    ( Relic r

    , Named (RelicFly r)
    , Named r

    , V.RMapCM         (FlyInterface (RelicFly r)) (FlyInterface (RelicFly r))
    , V.RecApplicative (FlyInterface (RelicFly r))
    , V.RMapCM         (RelicHelpers r) (RelicHelpers r)
    , V.RecApplicative (RelicHelpers r)

    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (FlyInterface (RelicFly r))
    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (RelicHelpers r)

    , t ~ RelicTreasure r
    , Mold1 (RelicState r) (RelicRef t) (RelicName t)
    , Show (RelicStateData t r)
    ) =>
        RelicFork t r
instance
    ( Relic r

    , Named (RelicFly r)
    , Named r

    , V.RMapCM         (FlyInterface (RelicFly r)) (FlyInterface (RelicFly r))
    , V.RecApplicative (FlyInterface (RelicFly r))
    , V.RMapCM         (RelicHelpers r) (RelicHelpers r)
    , V.RecApplicative (RelicHelpers r)

    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (FlyInterface (RelicFly r))
    , V.RecMapMethod' (RelicAndMethod r) (RelicHandler r) (RelicHelpers r)

    , t ~ RelicTreasure r
    , Mold1 (RelicState r) (RelicRef t) (RelicName t)
    , Show (RelicStateData t r)

    , Treasure t
    , Show (NameGeneratorName (TreasureNameGenerator t))
    ) =>
        RelicFork t r

forkRelic
    :: forall
            (t :: Type)
            (impl :: Type) .
        ( RelicFork t impl
        , Treasure t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        )
    => FilePath
    -> TreasureNameGenerator t
    -> TreasureConfig t
    -> RelicData3 t impl
    -> IO ()
forkRelic root ng config (RelicData3 env state key server flyRef) =
    forkFly server (newIORef state) selfInit runFly (makeSide @t @impl) useException
    where
    selfInit :: ReaderT (ImplEnv impl) IO ()
    selfInit = glideToCall @t @impl $ relicInit @impl $ RelicRef flyRef key
    runFly
        :: FlyRef (ImplementorFly impl)
        -> AuxRef impl
        -> IORef (RelicState impl)
        -> ReaderT (ImplEnv impl) IO a
        -> IO a
    runFly _meFly meAux stateRef action =
        runReaderT action $ ImplEnv (relicHome @t @impl root key) root ng env stateRef meAux config
    useException e =
        let fly = fromSSymbol $ symbolSing @(Name (RelicFly impl))
            relic = fromSSymbol $ symbolSing @(Name impl)
        in  lift $ putStrLn $
                "<" ++ fly ++ "> " ++ relic ++ " throws: " ++
                displayException e

forkRelicSet
    :: forall
            (t :: Type)
            (impl :: Type) .
        ( RelicFork t impl
        , Treasure t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        )
    => FilePath
    -> TreasureNameGenerator t
    -> TreasureConfig t
    -> RelicSet3 t impl
    -> V.Const (IO ()) impl
forkRelicSet root ng config (RelicSet3 rds) = V.Const $ traverse_ (forkRelic root ng config) rds

class
    ( V.RecMapMethod' (RelicFork t) (RelicSet3 t) (V.Snd frs)
    , Treasure t
    , Show (NameGeneratorName (TreasureNameGenerator t))
    , V.RecordToList (V.Snd frs)
    ) =>
        FlyFork t frs
instance
    ( V.RecMapMethod' (RelicFork t) (RelicSet3 t) (V.Snd frs)
    , Treasure t
    , Show (NameGeneratorName (TreasureNameGenerator t))
    , V.RecordToList (V.Snd frs)
    ) =>
        FlyFork t frs

forkFlySet
    :: forall (t :: Type) (frs :: (Type, [Type])) .
        ( FlyFork t frs
        )
    => FilePath
    -> TreasureNameGenerator t
    -> TreasureConfig t
    -> FlyData3 t frs
    -> V.Const (IO ()) frs
forkFlySet root ng config (FlyData3 sets) =
    V.Const $ sequence_ $ V.recordToList $
        (V.rmapMethod' @(RelicFork t) (forkRelicSet @t root ng config) sets :: V.Rec (V.Const (IO ())) (V.Snd frs))

forkTreasure
    :: forall t .
        ( V.RecMapMethod' (FlyFork t) (FlyData3 t) (TreasureRelics t)
        , V.RecordToList (TreasureRelics t)
        )
    => FilePath
    -> TreasureNameGenerator t
    -> TreasureConfig t
    -> TreasureData3 t
    -> IO ()
forkTreasure root ng config (TreasureData3 flies) =
    sequence_ $ V.recordToList $
        V.rmapMethod' @(FlyFork t) (forkFlySet @t root ng config) flies

------------------------------------------------------------------------------
-- Provide initial root actors for a new clean system
------------------------------------------------------------------------------

newtype RelicOriginSet (r :: Type) = RelicOriginSet [RelicOrigin r]

newtype FlyOriginSet (frs :: (Type, [Type])) = FlyOriginSet
    { _unFlyOriginSet :: V.Rec RelicOriginSet (V.Snd frs)
    }

newtype TreasureOrigin (t :: Type) = TreasureOrigin
    { _unTreasureOrigin :: V.Rec FlyOriginSet (TreasureRelics t)
    }

prepareRoots'''
    :: forall t r .
        ( Treasure t
        , RelicPrepare t r
        )
    => FilePath
    -> TreasureNameGenerator t
    -> RelicOrigin r
    -> IO (RelicData3 t r)
prepareRoots''' root ng origin = do
    (env, state) <- relicPrepare @r origin
    (server, ref) <- prepareFly @r
    name <- generateName ng

    let home = relicHome @t @r root name
    createDirectoryIfMissing True home

    writeBinaryFileDurableAtomic
        (home </> "env")
        (TE.encodeUtf8 $ T.pack $ show $
            mold1
                @(RelicEnv r) @(RelicRef t) @(RelicName t)
                (RelicName . rrName) env
        )
    let MigrationPlan envVersion _ = relicMigrateEnv @r
    writeBinaryFileDurableAtomic
        (home </> "env.version")
        (TE.encodeUtf8 $ T.pack $ show envVersion)

    writeBinaryFileDurableAtomic
        (home </> "state")
        (TE.encodeUtf8 $ T.pack $ show $
            mold1
                @(RelicState r) @(RelicRef t) @(RelicName t)
                (RelicName . rrName) state
        )
    let MigrationPlan stateVersion _ = relicMigrateState @r
    writeBinaryFileDurableAtomic
        (home </> "state.version")
        (TE.encodeUtf8 $ T.pack $ show stateVersion)

    return $ RelicData3 env state name server ref

prepareRoots''
    :: forall t r .
        ( Treasure t
        , RelicPrepare t r
        )
    => FilePath
    -> TreasureNameGenerator t
    -> RelicOriginSet r
    -> IO (RelicSet3 t r)
prepareRoots'' root ng (RelicOriginSet origins) =
    RelicSet3 <$> traverse (prepareRoots''' root ng) origins

prepareRoots'
    :: forall t frs .
        ( Treasure t
        , V.RecTraverseMethod (RelicPrepare t) RelicOriginSet (V.Snd frs)
        )
    => FilePath
    -> TreasureNameGenerator t
    -> FlyOriginSet frs
    -> IO (FlyData3 t frs)
prepareRoots' root ng (FlyOriginSet sets) =
    fmap FlyData3 $
        V.rtraverseMethod @(RelicPrepare t) (prepareRoots'' root ng) sets

class
    ( V.RecTraverseMethod (RelicPrepare t) RelicOriginSet (V.Snd frs)
    ) =>
        PrepareRoots t frs
instance
    ( Treasure t
    , V.RecTraverseMethod (RelicPrepare t) RelicOriginSet (V.Snd frs)
    ) =>
        PrepareRoots t frs

prepareRoots
    :: forall t .
        ( Treasure t
        , V.RecTraverseMethod (PrepareRoots t) FlyOriginSet (TreasureRelics t)
        )
    => FilePath
    -> TreasureNameGenerator t
    -> TreasureOrigin t
    -> IO (TreasureData3 t)
prepareRoots root ng (TreasureOrigin flies) =
    fmap TreasureData3 $
        V.rtraverseMethod @(PrepareRoots t) (prepareRoots' root ng) flies

------------------------------------------------------------------------------
-- Finally, high-level wrapper for loading the system
------------------------------------------------------------------------------

updateRelicMap''
    :: forall
        (t :: Type)
        (frs :: (Type, [Type]))
        (f :: Type)
        (rs :: [Type])
        (r :: Type) .
            ( Hashable (NameGeneratorName (TreasureNameGenerator t))
            , frs V.∈ TreasureRelics t
            , frs ~ '(f, rs)
            , FlyAndRelic3 f r
            )
    => RelicMap t
    -> RelicSet3 t r
    -> V.Const (STM ()) r
updateRelicMap'' rm (RelicSet3 rds) =
    V.Const $
    if relicRegister @r
        then
            for_ rds $ \ (RelicData3 _ _ name _ flyRef) ->
                relicMapInsertSTM @t @frs (RelicRef flyRef name) rm
        else
            pure ()

updateRelicMap'
    :: forall
        (t :: Type)
        (frs :: (Type, [Type]))
        (f :: Type)
        (rs :: [Type]) .
            ( Hashable (NameGeneratorName (TreasureNameGenerator t))
            , frs V.∈ TreasureRelics t
            , frs ~ '(f, rs)
            , f ~ V.Fst frs
            , rs ~ V.Snd frs
            , V.RecMapMethod' (FlyAndRelic3 f) (RelicSet3 t) rs
            , V.RecordToList rs
            )
    => RelicMap t
    -> FlyData3 t frs
    -> V.Const (STM ()) frs
updateRelicMap' rm (FlyData3 rs) =
    V.Const $
        sequence_ $ V.recordToList (V.rmapMethod' @(FlyAndRelic3 f) f rs :: V.Rec (V.Const (STM ())) rs)
    where
    f :: forall r. FlyAndRelic3 f r => RelicSet3 t r -> V.Const (STM ()) r
    f = updateRelicMap'' @t @frs rm

class
    ( frs V.∈ TreasureRelics t
    , frs ~ '(V.Fst frs, V.Snd frs)
    , V.RecMapMethod' (FlyAndRelic3 (V.Fst frs)) (RelicSet3 t) (V.Snd frs)
    , V.RecordToList (V.Snd frs)
    ) =>
        UpdateRelicMap t frs
instance
    ( frs V.∈ TreasureRelics t
    , frs ~ '(V.Fst frs, V.Snd frs)
    , V.RecMapMethod' (FlyAndRelic3 (V.Fst frs)) (RelicSet3 t) (V.Snd frs)
    , V.RecordToList (V.Snd frs)
    ) =>
        UpdateRelicMap t frs

updateRelicMap
    :: forall (t :: Type) .
        ( Hashable (NameGeneratorName (TreasureNameGenerator t))
        , V.RecMapMethod' (UpdateRelicMap t) (FlyData3 t) (TreasureRelics t)
        , V.RecordToList (TreasureRelics t)
        )
    => TreasureData3 t
    -> RelicMap t
    -> STM ()
updateRelicMap (TreasureData3 fs) rm =
    sequence_ $ V.recordToList
        (V.rmapMethod' @(UpdateRelicMap t) (updateRelicMap' @t rm) fs :: V.Rec (V.Const (STM ())) (TreasureRelics t))

type RelicLaunchTreasure t =
    ( Treasure t
    , Read (NameGeneratorName (TreasureNameGenerator t))
    , V.RecApplicative (TreasureRelics t)
    , V.RecTraverseMethod (FlyAndRelics t) Proxy (TreasureRelics t)

    , V.RecTraverseMethod (FlyAndRelics2 t) (FlyData1 t) (TreasureRelics t)

    , V.RecMapMethod' (FlyAndRelics3 t) (FlyData2 t) (TreasureRelics t)

    , Typeable t
    , Show (NameGeneratorName (TreasureNameGenerator t))
    , Typeable (NameGeneratorName (TreasureNameGenerator t))
    , V.RecMapMethod' (TreasureEnlivenFly t) (FlyData2 t) (TreasureRelics t)

    , V.RecMapMethod' (FlyFork t) (FlyData3 t) (TreasureRelics t)
    , V.RecordToList (TreasureRelics t)

    , V.RecTraverseMethod (PrepareRoots t) FlyOriginSet (TreasureRelics t)

    , Hashable (NameGeneratorName (TreasureNameGenerator t))
    , V.RecMapMethod' (UpdateRelicMap t) (FlyData3 t) (TreasureRelics t)
    , V.RecMapMethod' (MakeRelicCallMap t) (LocalFlyMap t) (TreasureRelics t)
    )

launchTreasure
    :: forall t .
        ( Treasure t
        , Read (NameGeneratorName (TreasureNameGenerator t))
        , V.RecApplicative (TreasureRelics t)
        , V.RecTraverseMethod (FlyAndRelics t) Proxy (TreasureRelics t)

        , V.RecTraverseMethod (FlyAndRelics2 t) (FlyData1 t) (TreasureRelics t)

        , V.RecMapMethod' (FlyAndRelics3 t) (FlyData2 t) (TreasureRelics t)

        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))
        , V.RecMapMethod' (TreasureEnlivenFly t) (FlyData2 t) (TreasureRelics t)

        , V.RecMapMethod' (FlyFork t) (FlyData3 t) (TreasureRelics t)
        , V.RecordToList (TreasureRelics t)

        , V.RecTraverseMethod (PrepareRoots t) FlyOriginSet (TreasureRelics t)

        , Hashable (NameGeneratorName (TreasureNameGenerator t))
        , V.RecMapMethod' (UpdateRelicMap t) (FlyData3 t) (TreasureRelics t)
        )
    => NameGeneratorConfig (TreasureNameGenerator t)
    -> FilePath
    -> TreasureConfig t
    -> RelicMap t
    -> TreasureOrigin t
    -> IO ()
launchTreasure ngConfig path config rm origin = do
    ng <- loadNameGenerator ngConfig
    new <- do
        createDirectoryIfMissing False path
        null <$> listDirectory path
    t3 <-
        if new
            then prepareRoots path ng origin
            else do
                t1 <- loadTreasure path
                t2 <- prepareTreasure t1
                let input = lookupInput t2
                return $ enlivenTreasure input t2
    atomically $ updateRelicMap t3 rm
    forkTreasure path ng config t3

-- Same, except takes a ready NG
launchTreasure'
    :: forall t .
        ( Treasure t
        , Read (NameGeneratorName (TreasureNameGenerator t))
        , V.RecApplicative (TreasureRelics t)
        , V.RecTraverseMethod (FlyAndRelics t) Proxy (TreasureRelics t)

        , V.RecTraverseMethod (FlyAndRelics2 t) (FlyData1 t) (TreasureRelics t)

        , V.RecMapMethod' (FlyAndRelics3 t) (FlyData2 t) (TreasureRelics t)

        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))
        , V.RecMapMethod' (TreasureEnlivenFly t) (FlyData2 t) (TreasureRelics t)

        , V.RecMapMethod' (FlyFork t) (FlyData3 t) (TreasureRelics t)
        , V.RecordToList (TreasureRelics t)

        , V.RecTraverseMethod (PrepareRoots t) FlyOriginSet (TreasureRelics t)

        , Hashable (NameGeneratorName (TreasureNameGenerator t))
        , V.RecMapMethod' (UpdateRelicMap t) (FlyData3 t) (TreasureRelics t)
        )
    => TreasureNameGenerator t
    -> FilePath
    -> TreasureConfig t
    -> RelicMap t
    -> TreasureOrigin t
    -> IO ()
launchTreasure' ng path config rm origin = do
    new <- do
        createDirectoryIfMissing False path
        null <$> listDirectory path
    t3 <-
        if new
            then prepareRoots path ng origin
            else do
                t1 <- loadTreasure path
                t2 <- prepareTreasure t1
                let input = lookupInput t2
                return $ enlivenTreasure input t2
    atomically $ updateRelicMap t3 rm
    forkTreasure path ng config t3

-- Same, except it takes an arbitrary IO action for initialization
launchTreasure''
    :: forall t .
        ( Treasure t
        , Read (NameGeneratorName (TreasureNameGenerator t))
        , V.RecApplicative (TreasureRelics t)
        , V.RecTraverseMethod (FlyAndRelics t) Proxy (TreasureRelics t)

        , V.RecTraverseMethod (FlyAndRelics2 t) (FlyData1 t) (TreasureRelics t)

        , V.RecMapMethod' (FlyAndRelics3 t) (FlyData2 t) (TreasureRelics t)

        , Typeable t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Typeable (NameGeneratorName (TreasureNameGenerator t))
        , V.RecMapMethod' (TreasureEnlivenFly t) (FlyData2 t) (TreasureRelics t)

        , V.RecMapMethod' (FlyFork t) (FlyData3 t) (TreasureRelics t)
        , V.RecordToList (TreasureRelics t)

        , V.RecTraverseMethod (PrepareRoots t) FlyOriginSet (TreasureRelics t)

        , Hashable (NameGeneratorName (TreasureNameGenerator t))
        , V.RecMapMethod' (UpdateRelicMap t) (FlyData3 t) (TreasureRelics t)
        )
    => TreasureNameGenerator t
    -> FilePath
    -> TreasureConfig t
    -> RelicMap t
    -> IO ()
    -> IO ()
launchTreasure'' ng path config rm initialize = do
    new <- do
        createDirectoryIfMissing False path
        null <$> listDirectory path
    if new
        then initialize
        else do
            t1 <- loadTreasure path
            t2 <- prepareTreasure t1
            let input = lookupInput t2
            let t3 = enlivenTreasure input t2
            atomically $ updateRelicMap t3 rm
            forkTreasure @t path ng config t3

------------------------------------------------------------------------------
-- The back doors
------------------------------------------------------------------------------

type RelicSpawn t r =
    ( Relic r
    , t ~ RelicTreasure r
    , RelicPrepare t r
    , RelicFork t r
    , Show (RelicEnvData t r)
    , Show (RelicStateData t r)
    , Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
    , Mold1 (RelicState r) (RelicRef t) (RelicName t)
    )

-- Same as spawnRelicIO except it doesn't run prepareFly and generateName, and
-- instead takes the data as parameters.
spawnRelicIO'
    :: forall t r .
        ( Treasure t
        , Show (NameGeneratorName (TreasureNameGenerator t))

        {-
        , Relic r
        , t ~ RelicTreasure r
        , RelicPrepare t r
        , RelicFork t r

        , Show (RelicEnvData t r)
        , Show (RelicStateData t r)

        , Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
        , Mold1 (RelicState r) (RelicRef t) (RelicName t)
        -}
        , RelicSpawn t r
        )
    => FilePath
    -> TreasureNameGenerator t
    -> TreasureConfig t
    -> RelicOrigin r
    -> FlyServer r
    -> FlyRef (RelicFly r)
    -> NameGeneratorName (TreasureNameGenerator t)
    -> IO (RelicRef t (RelicFly r))
spawnRelicIO' root ng config origin server ref name = do
    (env, state) <- relicPrepare @r origin

    let home = relicHome @t @r root name
    createDirectoryIfMissing True home

    writeBinaryFileDurableAtomic
        (home </> "env")
        (TE.encodeUtf8 $ T.pack $ show $
            mold1
                @(RelicEnv r) @(RelicRef t) @(RelicName t)
                (RelicName . rrName) env
        )
    let MigrationPlan envVersion _ = relicMigrateEnv @r
    writeBinaryFileDurableAtomic
        (home </> "env.version")
        (TE.encodeUtf8 $ T.pack $ show envVersion)

    writeBinaryFileDurableAtomic
        (home </> "state")
        (TE.encodeUtf8 $ T.pack $ show $
            mold1
                @(RelicState r) @(RelicRef t) @(RelicName t)
                (RelicName . rrName) state
        )
    let MigrationPlan stateVersion _ = relicMigrateState @r
    writeBinaryFileDurableAtomic
        (home </> "state.version")
        (TE.encodeUtf8 $ T.pack $ show stateVersion)

    forkRelic root ng config $ RelicData3 @t @r env state name server ref
    return $ RelicRef ref name

spawnRelicIO
    :: forall t r .
        ( Treasure t
        , Relic r
        , t ~ RelicTreasure r

        , RelicPrepare t r
        , RelicFork t r
        , Show (NameGeneratorName (TreasureNameGenerator t))

        , Show (RelicEnvData t r)
        , Show (RelicStateData t r)

        , Mold1 (RelicEnv r) (RelicRef t) (RelicName t)
        , Mold1 (RelicState r) (RelicRef t) (RelicName t)
        )
    => FilePath
    -> TreasureNameGenerator t
    -> TreasureConfig t
    -> RelicOrigin r
    -> IO (RelicRef t (RelicFly r))
spawnRelicIO root ng config origin = do
    (server, ref) <- prepareFly @r
    name <- generateName ng
    spawnRelicIO' root ng config origin server ref name

callRelicIO
    :: forall
            (sym :: Symbol)
            (fly :: Type)
            (treasure :: Type)
            (param :: Type)
            (method :: (Symbol, Type)) .
        ( Fly fly
        , method ~ '(sym, param)
        , V.Fst method ~ sym
        , V.Snd method ~ param
        , method V.∈ FlyInterface fly
        , LookupParam sym (FlyInterface fly) ~ Just param
        )
    => RelicRef treasure fly
    -> param
    -> IO ()
callRelicIO (RelicRef ref _name) arg = callFly @sym ref arg

-- Same but without the LookupParam constraint
callRelicIO'
    :: forall
            (sym :: Symbol)
            (fly :: Type)
            (treasure :: Type)
            (param :: Type)
            (method :: (Symbol, Type)) .
        ( Fly fly
        , method ~ '(sym, param)
        , V.Fst method ~ sym
        , V.Snd method ~ param
        , method V.∈ FlyInterface fly
        )
    => RelicRef treasure fly
    -> param
    -> IO ()
callRelicIO' (RelicRef ref _name) arg = callFly' @sym ref arg

relicRefToName :: RelicRef t f -> RelicName t f
relicRefToName (RelicRef _fly name) = RelicName name

mkRelicName = RelicName

mkRelicRef = RelicRef

relicHandler'
    :: forall
            (relic :: Type)
            (method :: (Symbol, Type)) .
       (V.Snd method -> Glide relic (Coda Glide relic))
    -> RelicHandler relic method
relicHandler' = RelicHandler

-- ======================================================================== --
-- Actor maps, for use by Goose
-- ======================================================================== --

------------------------------------------------------------------------------
-- LocalFlyMap
------------------------------------------------------------------------------

newtype LocalFlyMap w frs = LocalFlyMap
    { _unLocalFlyMap :: SM.Map (NameGeneratorName (TreasureNameGenerator w)) (FlyRef (V.Fst frs))
    }

enlivenRelicRef'
    :: forall w frs .
        ( Treasure w
        , Show (NameGeneratorName (TreasureNameGenerator w))
        , Hashable (NameGeneratorName (TreasureNameGenerator w))
        )
    => LocalFlyMap w frs
    -> NameGeneratorName (TreasureNameGenerator w)
    -> IO (Maybe (RelicRef w (V.Fst frs)))
enlivenRelicRef' (LocalFlyMap m) name =
    atomically $ fmap (flip RelicRef name) <$> SM.lookup name m

------------------------------------------------------------------------------
-- LocalFlyCallMap
------------------------------------------------------------------------------

callRelicViaMap'''
    :: forall
            (treasure :: Type)
            (fly :: Type)
            (relics :: [Type])
            (method :: (Symbol, Type))
            (sym :: Symbol)
            (param :: Type) .
        ( Hashable (NameGeneratorName (TreasureNameGenerator treasure))
        , Fly fly
        , method ~ '(sym, param)
        , V.Fst method ~ sym
        , V.Snd method ~ param
        , method V.∈ FlyInterface fly
        )
    => LocalFlyMap treasure '(fly, relics)
    -> Proxy method
    -> NameGeneratorName (TreasureNameGenerator treasure)
    -> param
    -> IO Bool
callRelicViaMap''' (LocalFlyMap m) _ name arg = do
    maybeRef <- atomically $ SM.lookup name m
    case maybeRef of
        Nothing -> return False
        Just ref -> do
            callFly' @sym ref arg
            return True

newtype CallRelicViaMap' w f m = CallRelicViaMap'
    { _unCallRelicViaMap'
        :: NameGeneratorName (TreasureNameGenerator w) -> V.Snd m -> IO Bool
    }

callRelicViaMap''
    :: forall
            (treasure :: Type)
            (fly :: Type)
            (relics :: [Type])
            (method :: (Symbol, Type))
            (sym :: Symbol)
            (param :: Type) .
        ( Hashable (NameGeneratorName (TreasureNameGenerator treasure))
        , Fly fly
        , method ~ '(sym, param)
        , V.Fst method ~ sym
        , V.Snd method ~ param
        , method V.∈ FlyInterface fly
        )
    => LocalFlyMap treasure '(fly, relics)
    -> Proxy method
    -> CallRelicViaMap' treasure fly method
callRelicViaMap'' l p =
    CallRelicViaMap' $ callRelicViaMap''' @treasure @fly @relics @method l p

class
    ( Hashable (NameGeneratorName (TreasureNameGenerator w))
    , Fly f
    , m ~ '(V.Fst m, V.Snd m)
    )
        => CallViaMap' w f (m :: (Symbol, Type))
instance
    ( Hashable (NameGeneratorName (TreasureNameGenerator w))
    , Fly f
    , m ~ '(V.Fst m, V.Snd m)
    )
        => CallViaMap' w f m

relicCallMap'
    :: forall (w :: Type) (frs :: (Type, [Type])) (f :: Type) (rs :: [Type]) .
        ( Hashable (NameGeneratorName (TreasureNameGenerator w))
        , frs ~ '(f, rs)
        , f ~ V.Fst frs
        , rs ~ V.Snd frs
        , Fly f
        , V.RecMapMethodElem (CallViaMap' w f) Proxy (FlyInterface f)
        , V.RecApplicative (FlyInterface f)
        )
    => LocalFlyMap w frs
    -> V.Rec (CallRelicViaMap' w f) (FlyInterface f)
relicCallMap' l =
    V.rmapMethodElem @(Symbol, Type) @(CallViaMap' w f)
        (callRelicViaMap'' @w @f @rs l)
        (V.rpure @(FlyInterface f) Proxy)

newtype LocalFlyCallMap w frs = LocalFlyCallMap
    { _unLocalFlyCallMap
        :: V.Rec (CallRelicViaMap' w (V.Fst frs)) (FlyInterface (V.Fst frs))
    }

callRelicViaMap'
    :: forall w frs .
       Call (FlyInterface (V.Fst frs))
    -> LocalFlyCallMap w frs
    -> NameGeneratorName (TreasureNameGenerator w)
    -> IO Bool
callRelicViaMap' (Call call) (LocalFlyCallMap inserters) name =
    V.foldCoRec match call
    where
    match :: forall m. m V.∈ FlyInterface (V.Fst frs) => Arg m -> IO Bool
    match (Arg arg) =
        let CallRelicViaMap' insertCall =
                V.rget inserters :: CallRelicViaMap' w (V.Fst frs) m
        in  insertCall name arg

------------------------------------------------------------------------------
-- LocalTreasureMap
------------------------------------------------------------------------------

newtype LocalTreasureMap w = LocalTreasureMap
    { _unLocalTreasureMap :: V.Rec (LocalFlyMap w) (TreasureRelics w)
    }

enlivenRelicRef
    :: forall t frs f rs .
        ( Treasure t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Hashable (NameGeneratorName (TreasureNameGenerator t))
        , frs V.∈ TreasureRelics t
        , frs ~ '(f, rs)
        )
    => LocalTreasureMap t
    -> RelicName t f
    -> IO (Maybe (RelicRef t f))
enlivenRelicRef (LocalTreasureMap flies) (RelicName name) =
    enlivenRelicRef' (V.rget @frs flies) name

------------------------------------------------------------------------------
-- LocalTreasureCallMap
------------------------------------------------------------------------------

newtype LocalTreasureCallMap w = LocalTreasureCallMap
    { _unLocalTreasureCallMap :: V.Rec (LocalFlyCallMap w) (TreasureRelics w)
    }

newtype RelicCall (frs :: (Type, [Type])) = RelicCall
    { _unRelicCall :: Call (FlyInterface (V.Fst frs))
    }

callRelicViaMap
    :: forall w . Treasure w
    => V.CoRec RelicCall (TreasureRelics w)
    -> LocalTreasureCallMap w
    -> NameGeneratorName (TreasureNameGenerator w)
    -> IO Bool
callRelicViaMap call (LocalTreasureCallMap inserters) name =
    V.foldCoRec match call
    where
    match :: forall frs. frs V.∈ TreasureRelics w => RelicCall frs -> IO Bool
    match (RelicCall arg) =
        let localFlyCallMap = V.rget inserters :: LocalFlyCallMap w frs
        in  callRelicViaMap' @w @frs arg localFlyCallMap name

------------------------------------------------------------------------------
-- Wrapper for all of this: RelicMap
------------------------------------------------------------------------------

class
    ( Hashable (NameGeneratorName (TreasureNameGenerator w))
    , frs ~ '(V.Fst frs, V.Snd frs)
    , Fly (V.Fst frs)
    , V.RecMapMethodElem (CallViaMap' w (V.Fst frs)) Proxy (FlyInterface (V.Fst frs))
    , V.RecApplicative (FlyInterface (V.Fst frs))
    ) =>
        MakeRelicCallMap w frs
instance
    ( Hashable (NameGeneratorName (TreasureNameGenerator w))
    , frs ~ '(V.Fst frs, V.Snd frs)
    , Fly (V.Fst frs)
    , V.RecMapMethodElem (CallViaMap' w (V.Fst frs)) Proxy (FlyInterface (V.Fst frs))
    , V.RecApplicative (FlyInterface (V.Fst frs))
    ) =>
        MakeRelicCallMap w frs

data RelicMap w = RelicMap
    { _rmRefs :: LocalTreasureMap w
    , _rmCalls :: LocalTreasureCallMap w
    }

relicMapNew
    :: forall (w :: Type) .
        ( Treasure w
        , V.RecApplicative (TreasureRelics w)
        , V.RecMapMethod' (MakeRelicCallMap w) (LocalFlyMap w) (TreasureRelics w)
        )
    => IO (RelicMap w)
relicMapNew = do
    flyMaps <-
        V.rtraverse
            (\ _ -> LocalFlyMap <$> SM.newIO)
            (V.rpure @(TreasureRelics w) Proxy)
    let flyCallMaps =
            V.rmapMethod' @(MakeRelicCallMap w)
                (LocalFlyCallMap . relicCallMap' @w)
                flyMaps
    return $
        RelicMap (LocalTreasureMap flyMaps) (LocalTreasureCallMap flyCallMaps)

relicMapEnliven
    :: forall t frs f rs .
        ( Treasure t
        , Show (NameGeneratorName (TreasureNameGenerator t))
        , Hashable (NameGeneratorName (TreasureNameGenerator t))
        , frs V.∈ TreasureRelics t
        , frs ~ '(f, rs)
        )
    => RelicMap t
    -> RelicName t f
    -> IO (Maybe (RelicRef t f))
relicMapEnliven (RelicMap m _) = enlivenRelicRef @t @frs m

-- True: Actor found and call inserted
-- False: Actor by the given name not found
relicMapCall
    :: forall w . Treasure w
    => V.CoRec RelicCall (TreasureRelics w)
    -> RelicMap w
    -> NameGeneratorName (TreasureNameGenerator w)
    -> IO Bool
relicMapCall arg (RelicMap _ m) = callRelicViaMap arg m

relicMapInsertSTM
    :: forall w frs f rs .
        ( Hashable (NameGeneratorName (TreasureNameGenerator w))
        , frs V.∈ TreasureRelics w
        , frs ~ '(f, rs)
        )
    => RelicRef w f
    -> RelicMap w
    -> STM ()
relicMapInsertSTM (RelicRef fly name) (RelicMap (LocalTreasureMap flies) _) =
    let LocalFlyMap m = V.rget flies :: LocalFlyMap w frs
    in  SM.insert fly name m

relicMapInsert
    :: forall w frs f rs .
        ( Hashable (NameGeneratorName (TreasureNameGenerator w))
        , frs V.∈ TreasureRelics w
        , frs ~ '(f, rs)
        )
    => RelicRef w f
    -> RelicMap w
    -> IO ()
relicMapInsert r m = atomically $ relicMapInsertSTM @w @frs r m