{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

{-

An effect for inspecting & changing the internal state of the emulator.

-}
module Plutus.Trace.Effects.EmulatorControl(
    EmulatorControl(..)
    , setSigningProcess
    , agentState
    , freezeContractInstance
    , thawContractInstance
    , chainState
    , getParams
    , discardWallets
    , handleEmulatorControl
    , getSlotConfig
    ) where

import Cardano.Node.Emulator.Internal.Node (ChainState, Params (Params, pSlotConfig), SlotConfig)
import Control.Lens (over, view)
import Control.Monad (void)
import Control.Monad.Freer (Eff, Member, type (~>))
import Control.Monad.Freer.Coroutine (Yield)
import Control.Monad.Freer.Error (Error)
import Control.Monad.Freer.State (State, gets, modify)
import Control.Monad.Freer.TH (makeEffect)
import Data.Map qualified as Map
import Plutus.Trace.Emulator.ContractInstance (EmulatorRuntimeError, getThread)
import Plutus.Trace.Emulator.Types (EmulatorMessage (Freeze), EmulatorThreads)
import Plutus.Trace.Scheduler (EmSystemCall, MessageCall (Message), Priority (Normal), ThreadCall (Thaw), mkSysCall)
import Wallet.Emulator qualified as EM
import Wallet.Emulator.MultiAgent (EmulatorState, MultiAgentControlEffect, walletControlAction, walletState)
import Wallet.Emulator.Wallet (SigningProcess, Wallet, WalletState)
import Wallet.Emulator.Wallet qualified as W
import Wallet.Types (ContractInstanceId)

{- Note [The EmulatorControl effect]

The 'EmulatorControl' effect bundles all trace actions that deal with the
internals of the Plutus emulator, such as messing with the clock and dis-
connecting agents from the network.

All other effects defined under @Plutus.Trace.Effects@ can, in theory, be run
against a live system, ie. one running in real time with a real Goguen node and
wallet(s).

This means that if you write traces in a way that doesn't require the
'Member EmulatorControl' constraint, then it is likely that your traces will
work on a live system just as they do on the emulator. (We haven't implemented
the effect handlers for "live mode" yet, so it is still possible that there
are some modifications to be made)

-}

data EmulatorControl r where
    SetSigningProcess :: Wallet -> Maybe SigningProcess -> EmulatorControl ()
    AgentState :: Wallet -> EmulatorControl WalletState
    FreezeContractInstance :: ContractInstanceId -> EmulatorControl ()
    ThawContractInstance :: ContractInstanceId -> EmulatorControl ()
    ChainState :: EmulatorControl ChainState
    GetParams :: EmulatorControl Params
    GetSlotConfig :: EmulatorControl SlotConfig
    DiscardWallets :: (Wallet -> Bool) -> EmulatorControl ()  -- ^ Discard wallets matching the predicate.

-- | Interpret the 'EmulatorControl' effect in the 'MultiAgentEffect' and
--   scheduler system calls.
handleEmulatorControl ::
    forall effs effs2 a.
    ( Member (State EmulatorThreads) effs
    , Member (State EmulatorState) effs
    , Member (Error EmulatorRuntimeError) effs
    , Member MultiAgentControlEffect effs
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    )
    => Params
    -> EmulatorControl
    ~> Eff effs
handleEmulatorControl :: Params -> EmulatorControl ~> Eff effs
handleEmulatorControl params :: Params
params@Params{pSlotConfig :: Params -> SlotConfig
pSlotConfig=SlotConfig
slotCfg} = \case
    SetSigningProcess Wallet
wllt Maybe SigningProcess
sp -> Wallet -> Eff EmulatedWalletControlEffects () -> Eff effs ()
forall (effs :: [* -> *]) r.
Member MultiAgentControlEffect effs =>
Wallet -> Eff EmulatedWalletControlEffects r -> Eff effs r
walletControlAction Wallet
wllt (Eff EmulatedWalletControlEffects () -> Eff effs ())
-> Eff EmulatedWalletControlEffects () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Maybe SigningProcess -> Eff EmulatedWalletControlEffects ()
forall (effs :: [* -> *]).
Member SigningProcessControlEffect effs =>
Maybe SigningProcess -> Eff effs ()
W.setSigningProcess Maybe SigningProcess
sp
    AgentState Wallet
wllt -> (EmulatorState -> x) -> Eff effs x
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets @EmulatorState (Getting WalletState EmulatorState WalletState
-> EmulatorState -> WalletState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Wallet -> Lens' EmulatorState WalletState
walletState Wallet
wllt))
    FreezeContractInstance ContractInstanceId
i -> do
        ThreadId
threadId <- ContractInstanceId -> Eff effs ThreadId
forall (effs :: [* -> *]).
(Member (State EmulatorThreads) effs,
 Member (Error EmulatorRuntimeError) effs) =>
ContractInstanceId -> Eff effs ThreadId
getThread ContractInstanceId
i
        -- see note [Freeze and Thaw]
        Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs (Maybe EmulatorMessage) -> Eff effs ())
-> Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Priority
-> SysCall effs2 EmulatorMessage a
-> Eff effs (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall @effs2 @EmulatorMessage @_ @a Priority
Normal (MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a
forall a b. a -> Either a b
Left (MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a)
-> MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a
forall a b. (a -> b) -> a -> b
$ ThreadId -> EmulatorMessage -> MessageCall EmulatorMessage
forall systemEvent.
ThreadId -> systemEvent -> MessageCall systemEvent
Message ThreadId
threadId EmulatorMessage
Freeze)
    ThawContractInstance ContractInstanceId
i -> do
        ThreadId
threadId <- ContractInstanceId -> Eff effs ThreadId
forall (effs :: [* -> *]).
(Member (State EmulatorThreads) effs,
 Member (Error EmulatorRuntimeError) effs) =>
ContractInstanceId -> Eff effs ThreadId
getThread ContractInstanceId
i
        -- see note [Freeze and Thaw]
        Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs (Maybe EmulatorMessage) -> Eff effs ())
-> Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Priority
-> SysCall effs2 EmulatorMessage a
-> Eff effs (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall @effs2 @EmulatorMessage @_ @a Priority
Normal (ThreadCall effs2 EmulatorMessage a
-> SysCall effs2 EmulatorMessage a
forall a b. b -> Either a b
Right (ThreadCall effs2 EmulatorMessage a
 -> SysCall effs2 EmulatorMessage a)
-> ThreadCall effs2 EmulatorMessage a
-> SysCall effs2 EmulatorMessage a
forall a b. (a -> b) -> a -> b
$ ThreadId -> ThreadCall effs2 EmulatorMessage a
forall (effs :: [* -> *]) systemEvent a.
ThreadId -> ThreadCall effs systemEvent a
Thaw ThreadId
threadId)
    EmulatorControl x
ChainState -> (EmulatorState -> x) -> Eff effs x
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets (Getting ChainState EmulatorState ChainState
-> EmulatorState -> ChainState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ChainState EmulatorState ChainState
Lens' EmulatorState ChainState
EM.chainState)
    EmulatorControl x
GetParams -> Params -> Eff effs Params
forall (m :: * -> *) a. Monad m => a -> m a
return Params
params
    EmulatorControl x
GetSlotConfig -> SlotConfig -> Eff effs SlotConfig
forall (m :: * -> *) a. Monad m => a -> m a
return SlotConfig
slotCfg
    DiscardWallets Wallet -> Bool
discard -> forall (effs :: [* -> *]).
Member (State EmulatorState) effs =>
(EmulatorState -> EmulatorState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify @EmulatorState ((EmulatorState -> EmulatorState) -> Eff effs ())
-> (EmulatorState -> EmulatorState) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ ASetter
  EmulatorState
  EmulatorState
  (Map Wallet WalletState)
  (Map Wallet WalletState)
-> (Map Wallet WalletState -> Map Wallet WalletState)
-> EmulatorState
-> EmulatorState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  EmulatorState
  EmulatorState
  (Map Wallet WalletState)
  (Map Wallet WalletState)
Lens' EmulatorState (Map Wallet WalletState)
EM.walletStates ((Wallet -> WalletState -> Bool)
-> Map Wallet WalletState -> Map Wallet WalletState
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\ Wallet
k WalletState
_ -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Wallet -> Bool
discard Wallet
k))

makeEffect ''EmulatorControl