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

An effect for generating fresh contract instance IDs.

-}
module Plutus.Trace.Effects.ContractInstanceId(
    ContractInstanceIdEff
    , nextId

    -- * Handlers
    , 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

-- | Handle 'ContractInstanceIdEff' using a random number generator
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

-- | Handle 'ContractInstanceIdEff' using the list of IDs
--   'contractInstanceIDs'.
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)