{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Plutus.Trace.Effects.ContractInstanceId(
ContractInstanceIdEff
, nextId
, handleDeterministicIds
, handleRandomIds
) where
import Control.Monad.Freer
import Control.Monad.Freer.State
import Control.Monad.Freer.TH
import Control.Monad.IO.Class (MonadIO (..))
import Data.Maybe (fromMaybe, listToMaybe)
import Wallet.Types (ContractInstanceId (..), contractInstanceIDs, randomID)
data ContractInstanceIdEff r where
NextId :: ContractInstanceIdEff ContractInstanceId
makeEffect ''ContractInstanceIdEff
handleRandomIds ::
(LastMember m effs, MonadIO m)
=> Eff (ContractInstanceIdEff ': effs)
~> Eff effs
handleRandomIds :: Eff (ContractInstanceIdEff : effs) ~> Eff effs
handleRandomIds = (ContractInstanceIdEff ~> m)
-> Eff (ContractInstanceIdEff : effs) ~> Eff effs
forall (eff :: * -> *) (m :: * -> *) (effs :: [* -> *]).
(Monad m, LastMember m effs) =>
(eff ~> m) -> Eff (eff : effs) ~> Eff effs
interpretM ((ContractInstanceIdEff ~> m)
-> Eff (ContractInstanceIdEff : effs) ~> Eff effs)
-> (ContractInstanceIdEff ~> m)
-> Eff (ContractInstanceIdEff : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
ContractInstanceIdEff x
NextId -> IO ContractInstanceId -> m ContractInstanceId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ContractInstanceId
randomID
handleDeterministicIds ::
Eff (ContractInstanceIdEff ': effs)
~> Eff effs
handleDeterministicIds :: Eff (ContractInstanceIdEff : effs) x -> Eff effs x
handleDeterministicIds =
[ContractInstanceId]
-> Eff (State [ContractInstanceId] : effs) x -> Eff effs x
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs a
evalState [ContractInstanceId]
contractInstanceIDs
(Eff (State [ContractInstanceId] : effs) x -> Eff effs x)
-> (Eff (ContractInstanceIdEff : effs) x
-> Eff (State [ContractInstanceId] : effs) x)
-> Eff (ContractInstanceIdEff : effs) x
-> Eff effs x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContractInstanceIdEff ~> Eff (State [ContractInstanceId] : effs))
-> Eff (ContractInstanceIdEff : effs)
~> Eff (State [ContractInstanceId] : effs)
forall (f :: * -> *) (g :: * -> *) (effs :: [* -> *]).
(f ~> Eff (g : effs)) -> Eff (f : effs) ~> Eff (g : effs)
reinterpret @_ @(State [ContractInstanceId])
(\case
ContractInstanceIdEff x
NextId -> do
x
x <- ([x] -> x) -> Eff (State [ContractInstanceId] : effs) x
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets (x -> Maybe x -> x
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> x
forall a. HasCallStack => [Char] -> a
error [Char]
"handleDeterministicIds: ran out of IDs") (Maybe x -> x) -> ([x] -> Maybe x) -> [x] -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [x] -> Maybe x
forall a. [a] -> Maybe a
listToMaybe)
([ContractInstanceId] -> [ContractInstanceId])
-> Eff (State [ContractInstanceId] : effs) ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify @[ContractInstanceId] (Int -> [ContractInstanceId] -> [ContractInstanceId]
forall a. Int -> [a] -> [a]
drop Int
1)
x -> Eff (State [ContractInstanceId] : effs) x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x)