{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module CRDT.Cm
( CausalOrd (..)
, CmRDT (..)
, concurrent
, query
, makeAndApplyOp
, makeAndApplyOps
) where
import Control.Monad.State.Strict (MonadState, get, modify)
import CRDT.LamportClock (Clock)
class CausalOrd a where
precedes :: a -> a -> Bool
comparable :: CausalOrd a => a -> a -> Bool
comparable :: a -> a -> Bool
comparable a
a a
b = a
a a -> a -> Bool
forall a. CausalOrd a => a -> a -> Bool
`precedes` a
b Bool -> Bool -> Bool
|| a
b a -> a -> Bool
forall a. CausalOrd a => a -> a -> Bool
`precedes` a
a
concurrent :: CausalOrd a => a -> a -> Bool
concurrent :: a -> a -> Bool
concurrent a
a a
b = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a -> a -> Bool
forall a. CausalOrd a => a -> a -> Bool
comparable a
a a
b
class (CausalOrd op, Eq (Payload op)) => CmRDT op where
type Intent op
type Intent op = op
type Payload op
initial :: Payload op
makeOp :: Clock m => Intent op -> Payload op -> Maybe (m op)
default makeOp
:: (Intent op ~ op, Applicative m)
=> Intent op -> Payload op -> Maybe (m op)
makeOp Intent op
i Payload op
_ = m op -> Maybe (m op)
forall a. a -> Maybe a
Just (m op -> Maybe (m op)) -> m op -> Maybe (m op)
forall a b. (a -> b) -> a -> b
$ op -> m op
forall (f :: * -> *) a. Applicative f => a -> f a
pure op
Intent op
i
apply :: op -> Payload op -> Payload op
query :: forall op f . (CmRDT op, Foldable f) => f op -> Payload op
query :: f op -> Payload op
query = (Payload op -> op -> Payload op)
-> Payload op -> f op -> Payload op
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((op -> Payload op -> Payload op) -> Payload op -> op -> Payload op
forall a b c. (a -> b -> c) -> b -> a -> c
flip op -> Payload op -> Payload op
forall op. CmRDT op => op -> Payload op -> Payload op
apply) (CmRDT op => Payload op
forall op. CmRDT op => Payload op
initial @op)
makeAndApplyOp
:: (CmRDT op, Clock m, MonadFail m, MonadState (Payload op) m)
=> Intent op
-> m op
makeAndApplyOp :: Intent op -> m op
makeAndApplyOp Intent op
intent = do
Payload op
payload <- m (Payload op)
forall s (m :: * -> *). MonadState s m => m s
get
case Intent op -> Payload op -> Maybe (m op)
forall op (m :: * -> *).
(CmRDT op, Clock m) =>
Intent op -> Payload op -> Maybe (m op)
makeOp Intent op
intent Payload op
payload of
Maybe (m op)
Nothing -> String -> m op
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"precodition failed"
Just m op
opAction -> do
op
op <- m op
opAction
(Payload op -> Payload op) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Payload op -> Payload op) -> m ())
-> (Payload op -> Payload op) -> m ()
forall a b. (a -> b) -> a -> b
$ op -> Payload op -> Payload op
forall op. CmRDT op => op -> Payload op -> Payload op
apply op
op
op -> m op
forall (f :: * -> *) a. Applicative f => a -> f a
pure op
op
makeAndApplyOps
:: ( CmRDT op
, Clock m
, MonadFail m
, MonadState (Payload op) m
, Traversable f
)
=> f (Intent op)
-> m (f op)
makeAndApplyOps :: f (Intent op) -> m (f op)
makeAndApplyOps = (Intent op -> m op) -> f (Intent op) -> m (f op)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Intent op -> m op
forall op (m :: * -> *).
(CmRDT op, Clock m, MonadFail m, MonadState (Payload op) m) =>
Intent op -> m op
makeAndApplyOp