{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE KindSignatures   #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeOperators    #-}
-- | Interfacing with the wallet (for making payments)
module Plutus.Trace.Effects.EmulatedWalletAPI(
    EmulatedWalletAPI(..)
    , liftWallet
    , payToWallet
    , handleEmulatedWalletAPI
    ) where

import Cardano.Api qualified as C
import Control.Monad.Freer (Eff, Member, subsume, type (~>))
import Control.Monad.Freer.Error (Error)
import Control.Monad.Freer.Extras (raiseEnd)
import Control.Monad.Freer.Extras.Log (LogMsg)
import Control.Monad.Freer.TH (makeEffect)
import Data.Default (def)
import Data.Text (Text)
import Ledger qualified
import Ledger.Tx (getCardanoTxId)
import Plutus.Script.Utils.Value (Value)
import Wallet.API (WalletAPIError, defaultSlotRange, payToAddress)
import Wallet.Effects (WalletEffect)
import Wallet.Emulator qualified as EM
import Wallet.Emulator.LogMessages (RequestHandlerLogMsg)
import Wallet.Emulator.MultiAgent (MultiAgentEffect, walletAction)
import Wallet.Emulator.Wallet (Wallet)

data EmulatedWalletAPI r where
    LiftWallet :: Wallet -> Eff '[WalletEffect, Error WalletAPIError, LogMsg Text, LogMsg RequestHandlerLogMsg] a -> EmulatedWalletAPI a

makeEffect ''EmulatedWalletAPI

-- | Make a payment from one wallet to another
payToWallet ::
    forall effs.
    ( Member EmulatedWalletAPI effs
    )
    => Wallet
    -> Wallet
    -> Value
    -> Eff effs C.TxId
payToWallet :: Wallet -> Wallet -> Value -> Eff effs TxId
payToWallet Wallet
source Wallet
target Value
amount = do
    CardanoTx
ctx <- Wallet
-> Eff
     '[WalletEffect, Error WalletAPIError, LogMsg Text,
       LogMsg RequestHandlerLogMsg]
     CardanoTx
-> Eff effs CardanoTx
forall a (effs :: [* -> *]).
Member EmulatedWalletAPI effs =>
Wallet
-> Eff
     '[WalletEffect, Error WalletAPIError, LogMsg Text,
       LogMsg RequestHandlerLogMsg]
     a
-> Eff effs a
liftWallet Wallet
source
         (Eff
   '[WalletEffect, Error WalletAPIError, LogMsg Text,
     LogMsg RequestHandlerLogMsg]
   CardanoTx
 -> Eff effs CardanoTx)
-> Eff
     '[WalletEffect, Error WalletAPIError, LogMsg Text,
       LogMsg RequestHandlerLogMsg]
     CardanoTx
-> Eff effs CardanoTx
forall a b. (a -> b) -> a -> b
$ Params
-> SlotRange
-> Value
-> Address
-> Eff
     '[WalletEffect, Error WalletAPIError, LogMsg Text,
       LogMsg RequestHandlerLogMsg]
     CardanoTx
forall (effs :: [* -> *]).
(Member WalletEffect effs, Member (Error WalletAPIError) effs,
 Member (LogMsg Text) effs,
 Member (LogMsg RequestHandlerLogMsg) effs) =>
Params -> SlotRange -> Value -> Address -> Eff effs CardanoTx
payToAddress Params
forall a. Default a => a
def SlotRange
defaultSlotRange Value
amount (AddressInEra BabbageEra -> Address
forall era. AddressInEra era -> Address
Ledger.toPlutusAddress (AddressInEra BabbageEra -> Address)
-> AddressInEra BabbageEra -> Address
forall a b. (a -> b) -> a -> b
$ Wallet -> AddressInEra BabbageEra
EM.mockWalletAddress Wallet
target)
    TxId -> Eff effs TxId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxId -> Eff effs TxId) -> TxId -> Eff effs TxId
forall a b. (a -> b) -> a -> b
$ CardanoTx -> TxId
getCardanoTxId CardanoTx
ctx

-- | Handle the 'EmulatedWalletAPI' effect using the emulator's
--   'MultiAgent' effect.
handleEmulatedWalletAPI ::
    ( Member MultiAgentEffect effs
    )
    => EmulatedWalletAPI
    ~> Eff effs
handleEmulatedWalletAPI :: EmulatedWalletAPI ~> Eff effs
handleEmulatedWalletAPI = \case
    LiftWallet Wallet
w Eff
  '[WalletEffect, Error WalletAPIError, LogMsg Text,
    LogMsg RequestHandlerLogMsg]
  x
action ->
        Wallet -> Eff EmulatedWalletEffects x -> Eff effs x
forall (effs :: [* -> *]) r.
Member MultiAgentEffect effs =>
Wallet -> Eff EmulatedWalletEffects r -> Eff effs r
walletAction Wallet
w
            (Eff EmulatedWalletEffects x -> Eff effs x)
-> Eff EmulatedWalletEffects x -> Eff effs x
forall a b. (a -> b) -> a -> b
$ Eff (LogMsg RequestHandlerLogMsg : EmulatedWalletEffects) x
-> Eff EmulatedWalletEffects x
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume
            (Eff (LogMsg RequestHandlerLogMsg : EmulatedWalletEffects) x
 -> Eff EmulatedWalletEffects x)
-> Eff (LogMsg RequestHandlerLogMsg : EmulatedWalletEffects) x
-> Eff EmulatedWalletEffects x
forall a b. (a -> b) -> a -> b
$ Eff
  (LogMsg Text : LogMsg RequestHandlerLogMsg : EmulatedWalletEffects)
  x
-> Eff (LogMsg RequestHandlerLogMsg : EmulatedWalletEffects) x
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume
            (Eff
   (LogMsg Text : LogMsg RequestHandlerLogMsg : EmulatedWalletEffects)
   x
 -> Eff (LogMsg RequestHandlerLogMsg : EmulatedWalletEffects) x)
-> Eff
     (LogMsg Text : LogMsg RequestHandlerLogMsg : EmulatedWalletEffects)
     x
-> Eff (LogMsg RequestHandlerLogMsg : EmulatedWalletEffects) x
forall a b. (a -> b) -> a -> b
$ Eff
  (Error WalletAPIError
     : LogMsg Text : LogMsg RequestHandlerLogMsg
     : EmulatedWalletEffects)
  x
-> Eff
     (LogMsg Text : LogMsg RequestHandlerLogMsg : EmulatedWalletEffects)
     x
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume
            (Eff
   (Error WalletAPIError
      : LogMsg Text : LogMsg RequestHandlerLogMsg
      : EmulatedWalletEffects)
   x
 -> Eff
      (LogMsg Text : LogMsg RequestHandlerLogMsg : EmulatedWalletEffects)
      x)
-> Eff
     (Error WalletAPIError
        : LogMsg Text : LogMsg RequestHandlerLogMsg
        : EmulatedWalletEffects)
     x
-> Eff
     (LogMsg Text : LogMsg RequestHandlerLogMsg : EmulatedWalletEffects)
     x
forall a b. (a -> b) -> a -> b
$ Eff
  (WalletEffect
     : Error WalletAPIError : LogMsg Text : LogMsg RequestHandlerLogMsg
     : EmulatedWalletEffects)
  x
-> Eff
     (Error WalletAPIError
        : LogMsg Text : LogMsg RequestHandlerLogMsg
        : EmulatedWalletEffects)
     x
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume
            (Eff
   (WalletEffect
      : Error WalletAPIError : LogMsg Text : LogMsg RequestHandlerLogMsg
      : EmulatedWalletEffects)
   x
 -> Eff
      (Error WalletAPIError
         : LogMsg Text : LogMsg RequestHandlerLogMsg
         : EmulatedWalletEffects)
      x)
-> Eff
     (WalletEffect
        : Error WalletAPIError : LogMsg Text : LogMsg RequestHandlerLogMsg
        : EmulatedWalletEffects)
     x
-> Eff
     (Error WalletAPIError
        : LogMsg Text : LogMsg RequestHandlerLogMsg
        : EmulatedWalletEffects)
     x
forall a b. (a -> b) -> a -> b
$ Eff
  '[WalletEffect, Error WalletAPIError, LogMsg Text,
    LogMsg RequestHandlerLogMsg]
  x
-> Eff
     (WalletEffect
        : Error WalletAPIError : LogMsg Text : LogMsg RequestHandlerLogMsg
        : EmulatedWalletEffects)
     x
forall (effs :: [* -> *]) (as :: [* -> *]).
CanWeakenEnd as effs =>
Eff as ~> Eff effs
raiseEnd Eff
  '[WalletEffect, Error WalletAPIError, LogMsg Text,
    LogMsg RequestHandlerLogMsg]
  x
action