module CRDT.Cm.RGA
( RGA (..)
, RgaIntent (..)
, RgaPayload (..)
, fromString
, load
, toString
, toVector
) where
import Prelude hiding (lookup)
import Control.Monad.Fail (MonadFail)
import Control.Monad.State.Strict (MonadState)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Semigroup ((<>))
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
{ vertices :: Vector (VertexId, Maybe a)
, vertexIxs :: Map VertexId Int
}
deriving (Eq, Show)
lookup :: VertexId -> RgaPayload a -> Bool
lookup v RgaPayload{vertices, vertexIxs} =
case Map.lookup v vertexIxs of
Just ix -> case vertices Vector.! ix of
(_, Just _) -> True
_ -> False
Nothing -> False
data RgaIntent a
= AddAfter (Maybe VertexId) a
| Remove VertexId
deriving (Show)
data RGA a
= OpAddAfter (Maybe VertexId) a VertexId
| OpRemove VertexId
deriving (Eq, Show)
instance CausalOrd (RGA a) where
precedes _ _ = False
emptyPayload :: RgaPayload a
emptyPayload = RgaPayload{vertices = Vector.empty, vertexIxs = Map.empty}
instance Ord a => CmRDT (RGA a) where
type Intent (RGA a) = RgaIntent a
type Payload (RGA a) = RgaPayload a
initial = emptyPayload
makeOp (AddAfter mOldId atom) payload = case mOldId of
Nothing -> ok
Just oldId
| lookup oldId payload -> ok
| otherwise -> Nothing
where
RgaPayload{vertexIxs} = payload
ok = Just $ do
case Map.lookupMax vertexIxs of
Just (LamportTime maxKnownTime _, _) -> advance maxKnownTime
Nothing -> pure ()
newId <- getTime
pure $ OpAddAfter mOldId atom newId
makeOp (Remove w) payload
| lookup w payload = Just . pure $ OpRemove w
| otherwise = Nothing
apply (OpAddAfter mOldId newAtom newId) payload =
RgaPayload{vertices = vertices', vertexIxs = vertexIxs'}
where
RgaPayload{vertices, vertexIxs} = payload
n = length vertices
(vertices', newIx)
| null vertices = case mOldId of
Nothing -> (Vector.singleton (newId, Just newAtom), 0)
Just oldId -> error $ show oldId <> " not delivered"
| otherwise = (insert ix, ix)
where
ix = findWhereToInsert $ case mOldId of
Nothing -> 0
Just oldId -> vertexIxs Map.! oldId + 1
vertexIxs' = Map.insert newId newIx $ Map.map shift vertexIxs
shift ix
| ix >= newIx = ix + 1
| otherwise = ix
findWhereToInsert ix =
case vertices Vector.!? ix of
Just (t', _) | newId < t' ->
findWhereToInsert $ succ ix
_ -> ix
insert ix
| ix < n = left <> Vector.singleton (newId, Just newAtom) <> right
| otherwise = Vector.snoc vertices (newId, Just newAtom)
where
(left, right) = Vector.splitAt ix vertices
apply (OpRemove vid) payload@RgaPayload{vertices, vertexIxs} =
payload{vertices = vertices // [(ix, (vid, Nothing))]}
where
ix = vertexIxs Map.! vid
fromList
:: (Ord a, Clock m, MonadFail m, MonadState (RgaPayload a) m)
=> [a] -> m [RGA a]
fromList = go Nothing
where
go _ [] = pure []
go prevId (x:xs) = do
op@(OpAddAfter _ _ newId) <- makeAndApplyOp (AddAfter prevId x)
(op :) <$> go (Just newId) xs
toList :: RgaPayload a -> [a]
toList RgaPayload{vertices} = [a | (_, Just a) <- Vector.toList vertices]
toVector :: RgaPayload a -> Vector a
toVector RgaPayload{vertices} = Vector.mapMaybe snd vertices
fromString
:: (Clock m, MonadFail m, MonadState (RgaPayload Char) m)
=> String -> m [RGA Char]
fromString = fromList
toString :: RgaPayload Char -> String
toString = toList
load :: Vector (VertexId, Maybe a) -> RgaPayload a
load vertices = RgaPayload
{ vertices
, vertexIxs = Map.fromList
[(vid, ix) | ix <- [0..] | (vid, _) <- Vector.toList vertices]
}