{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
module CRDT.Cm.RGA
( RGA (..)
, RgaIntent (..)
, RgaPayload (..)
, fromString
, load
, toString
, toVector
) where
import Prelude hiding (lookup)
import Control.Monad.State.Strict (MonadState)
import Data.Empty (AsEmpty (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Vector (Vector, (//))
import qualified Data.Vector as Vector
import CRDT.Cm (CausalOrd, CmRDT, Intent, Payload, apply, initial,
makeAndApplyOp, makeOp, precedes)
import CRDT.LamportClock (Clock, LamportTime (LamportTime), advance,
getTime)
type VertexId = LamportTime
data RgaPayload a = RgaPayload
{ RgaPayload a -> Vector (VertexId, a)
vertices :: Vector (VertexId, a)
, RgaPayload a -> Map VertexId Int
vertexIxs :: Map VertexId Int
}
deriving (RgaPayload a -> RgaPayload a -> Bool
(RgaPayload a -> RgaPayload a -> Bool)
-> (RgaPayload a -> RgaPayload a -> Bool) -> Eq (RgaPayload a)
forall a. Eq a => RgaPayload a -> RgaPayload a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RgaPayload a -> RgaPayload a -> Bool
$c/= :: forall a. Eq a => RgaPayload a -> RgaPayload a -> Bool
== :: RgaPayload a -> RgaPayload a -> Bool
$c== :: forall a. Eq a => RgaPayload a -> RgaPayload a -> Bool
Eq, Int -> RgaPayload a -> ShowS
[RgaPayload a] -> ShowS
RgaPayload a -> String
(Int -> RgaPayload a -> ShowS)
-> (RgaPayload a -> String)
-> ([RgaPayload a] -> ShowS)
-> Show (RgaPayload a)
forall a. Show a => Int -> RgaPayload a -> ShowS
forall a. Show a => [RgaPayload a] -> ShowS
forall a. Show a => RgaPayload a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RgaPayload a] -> ShowS
$cshowList :: forall a. Show a => [RgaPayload a] -> ShowS
show :: RgaPayload a -> String
$cshow :: forall a. Show a => RgaPayload a -> String
showsPrec :: Int -> RgaPayload a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RgaPayload a -> ShowS
Show)
lookup :: AsEmpty a => VertexId -> RgaPayload a -> Bool
lookup :: VertexId -> RgaPayload a -> Bool
lookup VertexId
v RgaPayload { Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices, Map VertexId Int
vertexIxs :: Map VertexId Int
vertexIxs :: forall a. RgaPayload a -> Map VertexId Int
vertexIxs } = case VertexId -> Map VertexId Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup VertexId
v Map VertexId Int
vertexIxs of
Just Int
ix -> let (VertexId
_, a
a) = Vector (VertexId, a)
vertices Vector (VertexId, a) -> Int -> (VertexId, a)
forall a. Vector a -> Int -> a
Vector.! Int
ix in a -> Bool
forall a. AsEmpty a => a -> Bool
isNotEmpty a
a
Maybe Int
Nothing -> Bool
False
data RgaIntent a
= AddAfter (Maybe VertexId) a
| Remove VertexId
deriving (Int -> RgaIntent a -> ShowS
[RgaIntent a] -> ShowS
RgaIntent a -> String
(Int -> RgaIntent a -> ShowS)
-> (RgaIntent a -> String)
-> ([RgaIntent a] -> ShowS)
-> Show (RgaIntent a)
forall a. Show a => Int -> RgaIntent a -> ShowS
forall a. Show a => [RgaIntent a] -> ShowS
forall a. Show a => RgaIntent a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RgaIntent a] -> ShowS
$cshowList :: forall a. Show a => [RgaIntent a] -> ShowS
show :: RgaIntent a -> String
$cshow :: forall a. Show a => RgaIntent a -> String
showsPrec :: Int -> RgaIntent a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RgaIntent a -> ShowS
Show)
data RGA a
= OpAddAfter (Maybe VertexId) a VertexId
| OpRemove VertexId
deriving (RGA a -> RGA a -> Bool
(RGA a -> RGA a -> Bool) -> (RGA a -> RGA a -> Bool) -> Eq (RGA a)
forall a. Eq a => RGA a -> RGA a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RGA a -> RGA a -> Bool
$c/= :: forall a. Eq a => RGA a -> RGA a -> Bool
== :: RGA a -> RGA a -> Bool
$c== :: forall a. Eq a => RGA a -> RGA a -> Bool
Eq, Int -> RGA a -> ShowS
[RGA a] -> ShowS
RGA a -> String
(Int -> RGA a -> ShowS)
-> (RGA a -> String) -> ([RGA a] -> ShowS) -> Show (RGA a)
forall a. Show a => Int -> RGA a -> ShowS
forall a. Show a => [RGA a] -> ShowS
forall a. Show a => RGA a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RGA a] -> ShowS
$cshowList :: forall a. Show a => [RGA a] -> ShowS
show :: RGA a -> String
$cshow :: forall a. Show a => RGA a -> String
showsPrec :: Int -> RGA a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RGA a -> ShowS
Show)
instance CausalOrd (RGA a) where
precedes :: RGA a -> RGA a -> Bool
precedes RGA a
_ RGA a
_ = Bool
False
emptyPayload :: RgaPayload a
emptyPayload :: RgaPayload a
emptyPayload = RgaPayload :: forall a. Vector (VertexId, a) -> Map VertexId Int -> RgaPayload a
RgaPayload {vertices :: Vector (VertexId, a)
vertices = Vector (VertexId, a)
forall a. Vector a
Vector.empty, vertexIxs :: Map VertexId Int
vertexIxs = Map VertexId Int
forall k a. Map k a
Map.empty}
instance (AsEmpty a, Ord a) => CmRDT (RGA a) where
type Intent (RGA a) = RgaIntent a
type Payload (RGA a) = RgaPayload a
initial :: Payload (RGA a)
initial = Payload (RGA a)
forall a. RgaPayload a
emptyPayload
makeOp :: Intent (RGA a) -> Payload (RGA a) -> Maybe (m (RGA a))
makeOp (AddAfter mOldId atom) Payload (RGA a)
payload = case Maybe VertexId
mOldId of
Maybe VertexId
Nothing -> Maybe (m (RGA a))
ok
Just VertexId
oldId
| VertexId -> RgaPayload a -> Bool
forall a. AsEmpty a => VertexId -> RgaPayload a -> Bool
lookup VertexId
oldId Payload (RGA a)
RgaPayload a
payload -> Maybe (m (RGA a))
ok
| Bool
otherwise -> Maybe (m (RGA a))
forall a. Maybe a
Nothing
where
RgaPayload{Map VertexId Int
vertexIxs :: Map VertexId Int
vertexIxs :: forall a. RgaPayload a -> Map VertexId Int
vertexIxs} = Payload (RGA a)
RgaPayload a
payload
ok :: Maybe (m (RGA a))
ok = m (RGA a) -> Maybe (m (RGA a))
forall a. a -> Maybe a
Just (m (RGA a) -> Maybe (m (RGA a))) -> m (RGA a) -> Maybe (m (RGA a))
forall a b. (a -> b) -> a -> b
$ do
case Map VertexId Int -> Maybe (VertexId, Int)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map VertexId Int
vertexIxs of
Just (LamportTime LocalTime
maxKnownTime Pid
_, Int
_) -> LocalTime -> m ()
forall (m :: * -> *). Clock m => LocalTime -> m ()
advance LocalTime
maxKnownTime
Maybe (VertexId, Int)
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe VertexId -> a -> VertexId -> RGA a
forall a. Maybe VertexId -> a -> VertexId -> RGA a
OpAddAfter Maybe VertexId
mOldId a
atom (VertexId -> RGA a) -> m VertexId -> m (RGA a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VertexId
forall (m :: * -> *). Clock m => m VertexId
getTime
makeOp (Remove w) Payload (RGA a)
payload
| VertexId -> RgaPayload a -> Bool
forall a. AsEmpty a => VertexId -> RgaPayload a -> Bool
lookup VertexId
w Payload (RGA a)
RgaPayload a
payload = m (RGA a) -> Maybe (m (RGA a))
forall a. a -> Maybe a
Just (m (RGA a) -> Maybe (m (RGA a)))
-> (RGA a -> m (RGA a)) -> RGA a -> Maybe (m (RGA a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGA a -> m (RGA a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RGA a -> Maybe (m (RGA a))) -> RGA a -> Maybe (m (RGA a))
forall a b. (a -> b) -> a -> b
$ VertexId -> RGA a
forall a. VertexId -> RGA a
OpRemove VertexId
w
| Bool
otherwise = Maybe (m (RGA a))
forall a. Maybe a
Nothing
apply :: RGA a -> Payload (RGA a) -> Payload (RGA a)
apply (OpAddAfter Maybe VertexId
mOldId a
newAtom VertexId
newId) Payload (RGA a)
payload =
RgaPayload :: forall a. Vector (VertexId, a) -> Map VertexId Int -> RgaPayload a
RgaPayload{vertices :: Vector (VertexId, a)
vertices = Vector (VertexId, a)
vertices', vertexIxs :: Map VertexId Int
vertexIxs = Map VertexId Int
vertexIxs'}
where
RgaPayload{Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices, Map VertexId Int
vertexIxs :: Map VertexId Int
vertexIxs :: forall a. RgaPayload a -> Map VertexId Int
vertexIxs} = Payload (RGA a)
RgaPayload a
payload
n :: Int
n = Vector (VertexId, a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector (VertexId, a)
vertices
(Vector (VertexId, a)
vertices', Int
newIx)
| Vector (VertexId, a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector (VertexId, a)
vertices = case Maybe VertexId
mOldId of
Maybe VertexId
Nothing -> ((VertexId, a) -> Vector (VertexId, a)
forall a. a -> Vector a
Vector.singleton (VertexId
newId, a
newAtom), Int
0)
Just VertexId
oldId -> String -> (Vector (VertexId, a), Int)
forall a. HasCallStack => String -> a
error (String -> (Vector (VertexId, a), Int))
-> String -> (Vector (VertexId, a), Int)
forall a b. (a -> b) -> a -> b
$ VertexId -> String
forall a. Show a => a -> String
show VertexId
oldId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" not delivered"
| Bool
otherwise = (Int -> Vector (VertexId, a)
insert Int
ix, Int
ix)
where
ix :: Int
ix = Int -> Int
findWhereToInsert (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ case Maybe VertexId
mOldId of
Maybe VertexId
Nothing -> Int
0
Just VertexId
oldId -> Map VertexId Int
vertexIxs Map VertexId Int -> VertexId -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! VertexId
oldId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
vertexIxs' :: Map VertexId Int
vertexIxs' = VertexId -> Int -> Map VertexId Int -> Map VertexId Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VertexId
newId Int
newIx (Map VertexId Int -> Map VertexId Int)
-> Map VertexId Int -> Map VertexId Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Map VertexId Int -> Map VertexId Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Int -> Int
shift Map VertexId Int
vertexIxs
shift :: Int -> Int
shift Int
ix
| Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
newIx = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
| Bool
otherwise = Int
ix
findWhereToInsert :: Int -> Int
findWhereToInsert Int
ix =
case Vector (VertexId, a)
vertices Vector (VertexId, a) -> Int -> Maybe (VertexId, a)
forall a. Vector a -> Int -> Maybe a
Vector.!? Int
ix of
Just (VertexId
t', a
_) | VertexId
newId VertexId -> VertexId -> Bool
forall a. Ord a => a -> a -> Bool
< VertexId
t' ->
Int -> Int
findWhereToInsert (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
ix
Maybe (VertexId, a)
_ -> Int
ix
insert :: Int -> Vector (VertexId, a)
insert Int
ix
| Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = Vector (VertexId, a)
left Vector (VertexId, a)
-> Vector (VertexId, a) -> Vector (VertexId, a)
forall a. Semigroup a => a -> a -> a
<> (VertexId, a) -> Vector (VertexId, a)
forall a. a -> Vector a
Vector.singleton (VertexId
newId, a
newAtom) Vector (VertexId, a)
-> Vector (VertexId, a) -> Vector (VertexId, a)
forall a. Semigroup a => a -> a -> a
<> Vector (VertexId, a)
right
| Bool
otherwise = Vector (VertexId, a) -> (VertexId, a) -> Vector (VertexId, a)
forall a. Vector a -> a -> Vector a
Vector.snoc Vector (VertexId, a)
vertices (VertexId
newId, a
newAtom)
where
(Vector (VertexId, a)
left, Vector (VertexId, a)
right) = Int
-> Vector (VertexId, a)
-> (Vector (VertexId, a), Vector (VertexId, a))
forall a. Int -> Vector a -> (Vector a, Vector a)
Vector.splitAt Int
ix Vector (VertexId, a)
vertices
apply (OpRemove VertexId
vid) payload :: Payload (RGA a)
payload@RgaPayload{vertices, vertexIxs} =
Payload (RGA a)
RgaPayload a
payload{vertices :: Vector (VertexId, a)
vertices = Vector (VertexId, a)
vertices Vector (VertexId, a)
-> [(Int, (VertexId, a))] -> Vector (VertexId, a)
forall a. Vector a -> [(Int, a)] -> Vector a
// [(Int
ix, (VertexId
vid, a
forall a. AsEmpty a => a
empty))]}
where
ix :: Int
ix = Map VertexId Int
vertexIxs Map VertexId Int -> VertexId -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! VertexId
vid
fromList
:: (AsEmpty a, Ord a, Clock m, MonadFail m, MonadState (RgaPayload a) m)
=> [a]
-> m [RGA a]
fromList :: [a] -> m [RGA a]
fromList = Maybe VertexId -> [a] -> m [RGA a]
forall (f :: * -> *) a.
(AsEmpty a, Ord a, Clock f, MonadFail f,
MonadState (RgaPayload a) f) =>
Maybe VertexId -> [a] -> f [RGA a]
go Maybe VertexId
forall a. Maybe a
Nothing
where
go :: Maybe VertexId -> [a] -> f [RGA a]
go Maybe VertexId
_ [] = [RGA a] -> f [RGA a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go Maybe VertexId
prevId (a
x:[a]
xs) = do
op :: RGA a
op@(OpAddAfter Maybe VertexId
_ a
_ VertexId
newId) <- Intent (RGA a) -> f (RGA a)
forall op (m :: * -> *).
(CmRDT op, Clock m, MonadFail m, MonadState (Payload op) m) =>
Intent op -> m op
makeAndApplyOp (Maybe VertexId -> a -> RgaIntent a
forall a. Maybe VertexId -> a -> RgaIntent a
AddAfter Maybe VertexId
prevId a
x)
(RGA a
op RGA a -> [RGA a] -> [RGA a]
forall a. a -> [a] -> [a]
:) ([RGA a] -> [RGA a]) -> f [RGA a] -> f [RGA a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VertexId -> [a] -> f [RGA a]
go (VertexId -> Maybe VertexId
forall a. a -> Maybe a
Just VertexId
newId) [a]
xs
toList :: RgaPayload a -> [a]
toList :: RgaPayload a -> [a]
toList RgaPayload { Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices } = ((VertexId, a) -> a) -> [(VertexId, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (VertexId, a) -> a
forall a b. (a, b) -> b
snd ([(VertexId, a)] -> [a]) -> [(VertexId, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ Vector (VertexId, a) -> [(VertexId, a)]
forall a. Vector a -> [a]
Vector.toList Vector (VertexId, a)
vertices
toVector :: RgaPayload a -> Vector a
toVector :: RgaPayload a -> Vector a
toVector RgaPayload { Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices } = ((VertexId, a) -> a) -> Vector (VertexId, a) -> Vector a
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map (VertexId, a) -> a
forall a b. (a, b) -> b
snd Vector (VertexId, a)
vertices
fromString
:: (Clock m, MonadFail m, MonadState (RgaPayload Char) m)
=> String
-> m [RGA Char]
fromString :: String -> m [RGA Char]
fromString = String -> m [RGA Char]
forall a (m :: * -> *).
(AsEmpty a, Ord a, Clock m, MonadFail m,
MonadState (RgaPayload a) m) =>
[a] -> m [RGA a]
fromList
toString :: RgaPayload Char -> String
toString :: RgaPayload Char -> String
toString = RgaPayload Char -> String
forall a. RgaPayload a -> [a]
toList
load :: Vector (VertexId, a) -> RgaPayload a
load :: Vector (VertexId, a) -> RgaPayload a
load Vector (VertexId, a)
vertices = RgaPayload :: forall a. Vector (VertexId, a) -> Map VertexId Int -> RgaPayload a
RgaPayload
{ Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices
, vertexIxs :: Map VertexId Int
vertexIxs = [(VertexId, Int)] -> Map VertexId Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (VertexId
vid, Int
ix) | Int
ix <- [Int
0..] | (VertexId
vid, a
_) <- Vector (VertexId, a) -> [(VertexId, a)]
forall a. Vector a -> [a]
Vector.toList Vector (VertexId, a)
vertices ]
}