{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wmissing-import-lists #-}

{- | Description: Monadic interaction with an EventFold. -}
module Data.CRDT.EventFold.Monad (
  MonadEventFold(..),
  EventFoldT,
  runEventFoldT,
) where


import Control.Monad.Reader (MonadReader(ask), ReaderT(runReaderT))
import Control.Monad.State (MonadState(state), StateT, runStateT)
import Control.Monad.Trans.Class (MonadTrans(lift))
import Data.CRDT.EventFold (Event(Output), UpdateResult(UpdateResult),
  Diff, EventFold, EventId, MergeError)
import qualified Data.CRDT.EventFold as EF (diffMerge, disassociate,
  event, fullMerge, participate)


{- |
  The interface for monadically updating an EventFold, where the
  monadic context is intended to manage:

  - The local participant.
  - The current state of the EventFold.
  - The accumulated consistent outputs.
  - Whether the 'EventFold' needs to be propagated to other participants.
-}
class MonadEventFold o p e m | m -> o p e where
  {- | Apply an event. See 'EF.event'. -}
  event :: e -> m (Output e, EventId p)

  {- | Perform a full merge. See 'EF.fullMerge'. -}
  fullMerge
    :: EventFold o p e
    -> m (Either (MergeError o p e) ())

  {- | Perform a diff merge. See 'EF.diffMerge'. -}
  diffMerge
    :: Diff o p e
    -> m (Either (MergeError o p e) ())

  {- | Allow a new participant to join in the cluster. See 'EF.participate'. -}
  participate :: p -> m (EventId p)

  {- | Remove a peer from participation. See 'EF.disassociate'. -}
  disassociate :: p -> m (EventId p)

{- | A transformer providing 'MonadEventFold'. -}
newtype EventFoldT o p e m a = EventFoldT {
    EventFoldT o p e m a -> StateT (UpdateResult o p e) (ReaderT p m) a
unEventFoldT ::
      StateT (UpdateResult o p e) (
      ReaderT p m)
      a
  }
  deriving newtype
    ( Functor (EventFoldT o p e m)
a -> EventFoldT o p e m a
Functor (EventFoldT o p e m) =>
(forall a. a -> EventFoldT o p e m a)
-> (forall a b.
    EventFoldT o p e m (a -> b)
    -> EventFoldT o p e m a -> EventFoldT o p e m b)
-> (forall a b c.
    (a -> b -> c)
    -> EventFoldT o p e m a
    -> EventFoldT o p e m b
    -> EventFoldT o p e m c)
-> (forall a b.
    EventFoldT o p e m a
    -> EventFoldT o p e m b -> EventFoldT o p e m b)
-> (forall a b.
    EventFoldT o p e m a
    -> EventFoldT o p e m b -> EventFoldT o p e m a)
-> Applicative (EventFoldT o p e m)
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m a
EventFoldT o p e m (a -> b)
-> EventFoldT o p e m a -> EventFoldT o p e m b
(a -> b -> c)
-> EventFoldT o p e m a
-> EventFoldT o p e m b
-> EventFoldT o p e m c
forall a. a -> EventFoldT o p e m a
forall a b.
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m a
forall a b.
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
forall a b.
EventFoldT o p e m (a -> b)
-> EventFoldT o p e m a -> EventFoldT o p e m b
forall a b c.
(a -> b -> c)
-> EventFoldT o p e m a
-> EventFoldT o p e m b
-> EventFoldT o p e m c
forall o p e (m :: * -> *). Monad m => Functor (EventFoldT o p e m)
forall o p e (m :: * -> *) a. Monad m => a -> EventFoldT o p e m a
forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m a
forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m (a -> b)
-> EventFoldT o p e m a -> EventFoldT o p e m b
forall o p e (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> EventFoldT o p e m a
-> EventFoldT o p e m b
-> EventFoldT o p e m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m a
$c<* :: forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m a
*> :: EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
$c*> :: forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
liftA2 :: (a -> b -> c)
-> EventFoldT o p e m a
-> EventFoldT o p e m b
-> EventFoldT o p e m c
$cliftA2 :: forall o p e (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> EventFoldT o p e m a
-> EventFoldT o p e m b
-> EventFoldT o p e m c
<*> :: EventFoldT o p e m (a -> b)
-> EventFoldT o p e m a -> EventFoldT o p e m b
$c<*> :: forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m (a -> b)
-> EventFoldT o p e m a -> EventFoldT o p e m b
pure :: a -> EventFoldT o p e m a
$cpure :: forall o p e (m :: * -> *) a. Monad m => a -> EventFoldT o p e m a
$cp1Applicative :: forall o p e (m :: * -> *). Monad m => Functor (EventFoldT o p e m)
Applicative
    , a -> EventFoldT o p e m b -> EventFoldT o p e m a
(a -> b) -> EventFoldT o p e m a -> EventFoldT o p e m b
(forall a b.
 (a -> b) -> EventFoldT o p e m a -> EventFoldT o p e m b)
-> (forall a b. a -> EventFoldT o p e m b -> EventFoldT o p e m a)
-> Functor (EventFoldT o p e m)
forall a b. a -> EventFoldT o p e m b -> EventFoldT o p e m a
forall a b.
(a -> b) -> EventFoldT o p e m a -> EventFoldT o p e m b
forall o p e (m :: * -> *) a b.
Functor m =>
a -> EventFoldT o p e m b -> EventFoldT o p e m a
forall o p e (m :: * -> *) a b.
Functor m =>
(a -> b) -> EventFoldT o p e m a -> EventFoldT o p e m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EventFoldT o p e m b -> EventFoldT o p e m a
$c<$ :: forall o p e (m :: * -> *) a b.
Functor m =>
a -> EventFoldT o p e m b -> EventFoldT o p e m a
fmap :: (a -> b) -> EventFoldT o p e m a -> EventFoldT o p e m b
$cfmap :: forall o p e (m :: * -> *) a b.
Functor m =>
(a -> b) -> EventFoldT o p e m a -> EventFoldT o p e m b
Functor
    , Applicative (EventFoldT o p e m)
a -> EventFoldT o p e m a
Applicative (EventFoldT o p e m) =>
(forall a b.
 EventFoldT o p e m a
 -> (a -> EventFoldT o p e m b) -> EventFoldT o p e m b)
-> (forall a b.
    EventFoldT o p e m a
    -> EventFoldT o p e m b -> EventFoldT o p e m b)
-> (forall a. a -> EventFoldT o p e m a)
-> Monad (EventFoldT o p e m)
EventFoldT o p e m a
-> (a -> EventFoldT o p e m b) -> EventFoldT o p e m b
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
forall a. a -> EventFoldT o p e m a
forall a b.
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
forall a b.
EventFoldT o p e m a
-> (a -> EventFoldT o p e m b) -> EventFoldT o p e m b
forall o p e (m :: * -> *).
Monad m =>
Applicative (EventFoldT o p e m)
forall o p e (m :: * -> *) a. Monad m => a -> EventFoldT o p e m a
forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> (a -> EventFoldT o p e m b) -> EventFoldT o p e m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EventFoldT o p e m a
$creturn :: forall o p e (m :: * -> *) a. Monad m => a -> EventFoldT o p e m a
>> :: EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
$c>> :: forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> EventFoldT o p e m b -> EventFoldT o p e m b
>>= :: EventFoldT o p e m a
-> (a -> EventFoldT o p e m b) -> EventFoldT o p e m b
$c>>= :: forall o p e (m :: * -> *) a b.
Monad m =>
EventFoldT o p e m a
-> (a -> EventFoldT o p e m b) -> EventFoldT o p e m b
$cp1Monad :: forall o p e (m :: * -> *).
Monad m =>
Applicative (EventFoldT o p e m)
Monad
    )
instance MonadTrans (EventFoldT o p e) where
  lift :: m a -> EventFoldT o p e m a
lift = StateT (UpdateResult o p e) (ReaderT p m) a -> EventFoldT o p e m a
forall o p e (m :: * -> *) a.
StateT (UpdateResult o p e) (ReaderT p m) a -> EventFoldT o p e m a
EventFoldT (StateT (UpdateResult o p e) (ReaderT p m) a
 -> EventFoldT o p e m a)
-> (m a -> StateT (UpdateResult o p e) (ReaderT p m) a)
-> m a
-> EventFoldT o p e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT p m a -> StateT (UpdateResult o p e) (ReaderT p m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT p m a -> StateT (UpdateResult o p e) (ReaderT p m) a)
-> (m a -> ReaderT p m a)
-> m a
-> StateT (UpdateResult o p e) (ReaderT p m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT p m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance
    ( Eq (Output e)
    , Eq e
    , Eq o
    , Event e
    , Monad m
    , Ord p
    )
  =>
    MonadEventFold o p e (EventFoldT o p e m)
  where
    event :: e -> EventFoldT o p e m (Output e, EventId p)
event e :: e
e =
      (EventFold o p e
 -> p -> ((Output e, EventId p), UpdateResult o p e))
-> EventFoldT o p e m (Output e, EventId p)
forall o p e (m :: * -> *) a.
(Monad m, Ord p) =>
(EventFold o p e -> p -> (a, UpdateResult o p e))
-> EventFoldT o p e m a
withEF
        (\ef :: EventFold o p e
ef self :: p
self ->
          let (o :: Output e
o, eid :: EventId p
eid, ur :: UpdateResult o p e
ur) = p
-> e
-> EventFold o p e
-> (Output e, EventId p, UpdateResult o p e)
forall p e o.
(Ord p, Event e) =>
p
-> e
-> EventFold o p e
-> (Output e, EventId p, UpdateResult o p e)
EF.event p
self e
e EventFold o p e
ef
          in ((Output e
o, EventId p
eid), UpdateResult o p e
ur)
        )

    fullMerge :: EventFold o p e
-> EventFoldT o p e m (Either (MergeError o p e) ())
fullMerge other :: EventFold o p e
other =
      (EventFold o p e
 -> p -> (Either (MergeError o p e) (), UpdateResult o p e))
-> EventFoldT o p e m (Either (MergeError o p e) ())
forall o p e (m :: * -> *) a.
(Monad m, Ord p) =>
(EventFold o p e -> p -> (a, UpdateResult o p e))
-> EventFoldT o p e m a
withEF
        (\ef :: EventFold o p e
ef self :: p
self ->
          case p
-> EventFold o p e
-> EventFold o p e
-> Either (MergeError o p e) (UpdateResult o p e)
forall e o p.
(Eq (Output e), Eq e, Eq o, Event e, Ord p) =>
p
-> EventFold o p e
-> EventFold o p e
-> Either (MergeError o p e) (UpdateResult o p e)
EF.fullMerge p
self EventFold o p e
ef EventFold o p e
other of
            Left err :: MergeError o p e
err -> (MergeError o p e -> Either (MergeError o p e) ()
forall a b. a -> Either a b
Left MergeError o p e
err, EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
forall o p e.
EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
UpdateResult EventFold o p e
ef Map (EventId p) (Output e)
forall a. Monoid a => a
mempty Bool
False)
            Right ur :: UpdateResult o p e
ur -> (() -> Either (MergeError o p e) ()
forall a b. b -> Either a b
Right (), UpdateResult o p e
ur)
        )

    diffMerge :: Diff o p e -> EventFoldT o p e m (Either (MergeError o p e) ())
diffMerge diff :: Diff o p e
diff =
      (EventFold o p e
 -> p -> (Either (MergeError o p e) (), UpdateResult o p e))
-> EventFoldT o p e m (Either (MergeError o p e) ())
forall o p e (m :: * -> *) a.
(Monad m, Ord p) =>
(EventFold o p e -> p -> (a, UpdateResult o p e))
-> EventFoldT o p e m a
withEF
        (\ef :: EventFold o p e
ef self :: p
self ->
          case p
-> EventFold o p e
-> Diff o p e
-> Either (MergeError o p e) (UpdateResult o p e)
forall e o p.
(Eq (Output e), Eq e, Eq o, Event e, Ord p) =>
p
-> EventFold o p e
-> Diff o p e
-> Either (MergeError o p e) (UpdateResult o p e)
EF.diffMerge p
self EventFold o p e
ef Diff o p e
diff of
            Left err :: MergeError o p e
err -> (MergeError o p e -> Either (MergeError o p e) ()
forall a b. a -> Either a b
Left MergeError o p e
err, EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
forall o p e.
EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
UpdateResult EventFold o p e
ef Map (EventId p) (Output e)
forall a. Monoid a => a
mempty Bool
False)
            Right ur :: UpdateResult o p e
ur -> (() -> Either (MergeError o p e) ()
forall a b. b -> Either a b
Right (), UpdateResult o p e
ur)
        )

    participate :: p -> EventFoldT o p e m (EventId p)
participate participant :: p
participant =
      (EventFold o p e -> p -> (EventId p, UpdateResult o p e))
-> EventFoldT o p e m (EventId p)
forall o p e (m :: * -> *) a.
(Monad m, Ord p) =>
(EventFold o p e -> p -> (a, UpdateResult o p e))
-> EventFoldT o p e m a
withEF (\ef :: EventFold o p e
ef self :: p
self -> p -> p -> EventFold o p e -> (EventId p, UpdateResult o p e)
forall o p e.
(Ord p, Event e) =>
p -> p -> EventFold o p e -> (EventId p, UpdateResult o p e)
EF.participate p
self p
participant EventFold o p e
ef)

    disassociate :: p -> EventFoldT o p e m (EventId p)
disassociate participant :: p
participant =
      (EventFold o p e -> p -> (EventId p, UpdateResult o p e))
-> EventFoldT o p e m (EventId p)
forall o p e (m :: * -> *) a.
(Monad m, Ord p) =>
(EventFold o p e -> p -> (a, UpdateResult o p e))
-> EventFoldT o p e m a
withEF (\ef :: EventFold o p e
ef _self :: p
_self -> p -> EventFold o p e -> (EventId p, UpdateResult o p e)
forall o p e.
(Event e, Ord p) =>
p -> EventFold o p e -> (EventId p, UpdateResult o p e)
EF.disassociate p
participant EventFold o p e
ef)


{- |
  EventFoldT helper to make sure we always do the right thing when
  updating an event.
-}
withEF
  :: forall o p e m a. (Monad m, Ord p)
  => (EventFold o p e -> p -> (a, UpdateResult o p e))
  -> EventFoldT o p e m a
withEF :: (EventFold o p e -> p -> (a, UpdateResult o p e))
-> EventFoldT o p e m a
withEF f :: EventFold o p e -> p -> (a, UpdateResult o p e)
f = StateT (UpdateResult o p e) (ReaderT p m) a -> EventFoldT o p e m a
forall o p e (m :: * -> *) a.
StateT (UpdateResult o p e) (ReaderT p m) a -> EventFoldT o p e m a
EventFoldT (StateT (UpdateResult o p e) (ReaderT p m) a
 -> EventFoldT o p e m a)
-> StateT (UpdateResult o p e) (ReaderT p m) a
-> EventFoldT o p e m a
forall a b. (a -> b) -> a -> b
$
    (UpdateResult o p e -> (a, UpdateResult o p e))
-> StateT (UpdateResult o p e) (ReaderT p m) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((UpdateResult o p e -> (a, UpdateResult o p e))
 -> StateT (UpdateResult o p e) (ReaderT p m) a)
-> (p -> UpdateResult o p e -> (a, UpdateResult o p e))
-> p
-> StateT (UpdateResult o p e) (ReaderT p m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> UpdateResult o p e -> (a, UpdateResult o p e)
updateState (p -> StateT (UpdateResult o p e) (ReaderT p m) a)
-> StateT (UpdateResult o p e) (ReaderT p m) p
-> StateT (UpdateResult o p e) (ReaderT p m) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (UpdateResult o p e) (ReaderT p m) p
forall r (m :: * -> *). MonadReader r m => m r
ask
  where
    updateState :: p -> UpdateResult o p e -> (a, UpdateResult o p e)
    updateState :: p -> UpdateResult o p e -> (a, UpdateResult o p e)
updateState self :: p
self (UpdateResult ef :: EventFold o p e
ef outputs :: Map (EventId p) (Output e)
outputs prop :: Bool
prop) =
      let
        (a :: a
a, UpdateResult ef2 :: EventFold o p e
ef2 outputs2 :: Map (EventId p) (Output e)
outputs2 prop2 :: Bool
prop2) =
          EventFold o p e -> p -> (a, UpdateResult o p e)
f EventFold o p e
ef p
self
        results :: UpdateResult o p e
        results :: UpdateResult o p e
results = EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
forall o p e.
EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
UpdateResult EventFold o p e
ef2 (Map (EventId p) (Output e)
outputs Map (EventId p) (Output e)
-> Map (EventId p) (Output e) -> Map (EventId p) (Output e)
forall a. Semigroup a => a -> a -> a
<> Map (EventId p) (Output e)
outputs2) (Bool
prop Bool -> Bool -> Bool
|| Bool
prop2)
      in
        (a
a, UpdateResult o p e
results)

runEventFoldT
  :: (Ord p)
  => p {- ^ The local participant. -}
  -> EventFold o p e {- ^ Initial event fold value.  -}
  -> EventFoldT o p e m a {- ^ The action to run.  -}
  -> m (a, UpdateResult o p e)
     {- ^
       Returns the result of the action, plus all the accumulated
       'UpdateResult's, which contain the new 'EventFold' value, all
       of the consistent outputs, and a flag indicating whether the new
       'EventFold' value should be propagated to the other participants.
     -}
runEventFoldT :: p
-> EventFold o p e
-> EventFoldT o p e m a
-> m (a, UpdateResult o p e)
runEventFoldT self :: p
self ef :: EventFold o p e
ef action :: EventFoldT o p e m a
action = do
  (ReaderT p m (a, UpdateResult o p e)
 -> p -> m (a, UpdateResult o p e))
-> p
-> ReaderT p m (a, UpdateResult o p e)
-> m (a, UpdateResult o p e)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT p m (a, UpdateResult o p e)
-> p -> m (a, UpdateResult o p e)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT p
self
  (ReaderT p m (a, UpdateResult o p e) -> m (a, UpdateResult o p e))
-> (EventFoldT o p e m a -> ReaderT p m (a, UpdateResult o p e))
-> EventFoldT o p e m a
-> m (a, UpdateResult o p e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (UpdateResult o p e) (ReaderT p m) a
 -> UpdateResult o p e -> ReaderT p m (a, UpdateResult o p e))
-> UpdateResult o p e
-> StateT (UpdateResult o p e) (ReaderT p m) a
-> ReaderT p m (a, UpdateResult o p e)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (UpdateResult o p e) (ReaderT p m) a
-> UpdateResult o p e -> ReaderT p m (a, UpdateResult o p e)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
forall o p e.
EventFold o p e
-> Map (EventId p) (Output e) -> Bool -> UpdateResult o p e
UpdateResult EventFold o p e
ef Map (EventId p) (Output e)
forall a. Monoid a => a
mempty Bool
False)
  (StateT (UpdateResult o p e) (ReaderT p m) a
 -> ReaderT p m (a, UpdateResult o p e))
-> (EventFoldT o p e m a
    -> StateT (UpdateResult o p e) (ReaderT p m) a)
-> EventFoldT o p e m a
-> ReaderT p m (a, UpdateResult o p e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventFoldT o p e m a -> StateT (UpdateResult o p e) (ReaderT p m) a
forall o p e (m :: * -> *) a.
EventFoldT o p e m a -> StateT (UpdateResult o p e) (ReaderT p m) a
unEventFoldT 
  (EventFoldT o p e m a -> m (a, UpdateResult o p e))
-> EventFoldT o p e m a -> m (a, UpdateResult o p e)
forall a b. (a -> b) -> a -> b
$ EventFoldT o p e m a
action