diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,14 @@ ## [Unreleased] +## [0.10] - 2019-10-08 +### Added +- `RGA.toList` +- `RGA.toText` + +### Fixed +- Cabal-file: Diff dependency bounds + ## [0.9] - 2019-09-06 ### Added - Function `ORSet.getFieldObject` @@ -195,7 +203,8 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/ron-rdt-0.9...HEAD +[Unreleased]: https://github.com/ff-notes/ron/compare/ron-rdt-0.10...HEAD +[0.10]: https://github.com/ff-notes/ron/compare/ron-rdt-0.9...ron-rdt-0.10 [0.9]: https://github.com/ff-notes/ron/compare/ron-rdt-0.8...ron-rdt-0.9 [0.8]: https://github.com/ff-notes/ron/compare/ron-rdt-0.7...ron-rdt-0.8 [0.7]: https://github.com/ff-notes/ron/compare/ron-rdt-0.6...ron-rdt-0.7 diff --git a/lib/RON/Data/RGA.hs b/lib/RON/Data/RGA.hs --- a/lib/RON/Data/RGA.hs +++ b/lib/RON/Data/RGA.hs @@ -11,8 +11,8 @@ {-# LANGUAGE TypeFamilies #-} -- | Replicated Growable Array (RGA) -module RON.Data.RGA ( - RGA (..), +module RON.Data.RGA + ( RGA (..), RgaRep, RgaString, edit, @@ -30,37 +30,54 @@ newFromText, remove, rgaType, -) where - -import RON.Prelude + RON.Data.RGA.toList, + toText, + ) +where -import Data.Algorithm.Diff (Diff (Both, First, Second), - getGroupedDiffBy) +import Data.Algorithm.Diff (Diff (Both, First, Second), getGroupedDiffBy) import qualified Data.HashMap.Strict as HashMap -import Data.Map.Strict ((!?)) +import Data.Map.Strict ((!?)) import qualified Data.Map.Strict as Map import qualified Data.Text as Text - -import RON.Data.Internal (MonadObjectState, - ReducedChunk (ReducedChunk, rcBody, rcRef), - Reducible, Rep, Replicated (encoding), - ReplicatedAsObject, ReplicatedAsPayload, - Unapplied, applyPatches, fromRon, - getObjectStateChunk, - modifyObjectStateChunk_, newObject, newRon, - objectEncoding, readObject, - reduceUnappliedPatches, reducibleOpType, - stateFromChunk, stateToChunk, toPayload) -import RON.Error (MonadE, errorContext, throwErrorText) -import RON.Event (ReplicaClock, getEventUuid, getEventUuids) -import RON.Semilattice (Semilattice) -import RON.Types (ObjectRef (ObjectRef), - Op (Op, opId, payload, refId), - StateChunk (StateChunk), StateFrame, UUID, - WireStateChunk (WireStateChunk, stateBody, stateType)) -import RON.Util.Word (pattern B11, ls60) -import RON.UUID (pattern Zero, uuidVersion) +import RON.Data.Internal + ( MonadObjectState, + ReducedChunk (ReducedChunk, rcBody, rcRef), + Reducible, + Rep, + Replicated (encoding), + ReplicatedAsObject, + ReplicatedAsPayload, + Unapplied, + applyPatches, + fromRon, + getObjectStateChunk, + modifyObjectStateChunk_, + newObject, + newRon, + objectEncoding, + readObject, + reduceUnappliedPatches, + reducibleOpType, + stateFromChunk, + stateToChunk, + toPayload, + ) +import RON.Error (MonadE, errorContext, throwErrorText) +import RON.Event (ReplicaClock, getEventUuid, getEventUuids) +import RON.Prelude +import RON.Semilattice (Semilattice) +import RON.Types + ( ObjectRef (ObjectRef), + Op (Op, opId, payload, refId), + StateChunk (StateChunk), + StateFrame, + UUID, + WireStateChunk (WireStateChunk, stateBody, stateType), + ) +import RON.UUID (uuidVersion, pattern Zero) import qualified RON.UUID as UUID +import RON.Util.Word (ls60, pattern B11) {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} @@ -71,231 +88,247 @@ -- payload: the value type Vertex = Op -data VertexListItem = VertexListItem - { itemValue :: Vertex - , itemNext :: Maybe UUID - } - deriving (Eq, Show) +data VertexListItem + = VertexListItem + { itemValue :: Vertex, + itemNext :: Maybe UUID + } + deriving (Eq, Show) -data VertexList = VertexList - { listHead :: UUID - , listItems :: HashMap UUID VertexListItem - } - deriving (Eq, Show) +data VertexList + = VertexList + { listHead :: UUID, + listItems :: HashMap UUID VertexListItem + } + deriving (Eq, Show) instance Semigroup VertexList where - (<>) = merge + (<>) = merge vertexListToOps :: VertexList -> [Vertex] -vertexListToOps v@VertexList{..} = go listHead listItems +vertexListToOps v@VertexList {..} = go listHead listItems where - go root items = let - VertexListItem{..} = + go root items = + let VertexListItem {..} = HashMap.lookupDefault - (error $ unlines - $ ["Cannot find vertex id", show root, "in array"] + ( error $ unlines + $ ["Cannot find vertex id", show root, "in array"] ++ map show (HashMap.toList items) - ++ ["Original array is", show v]) - root - items - rest = case itemNext of + ++ ["Original array is", show v] + ) + root + items + rest = case itemNext of Just next -> go next (HashMap.delete root items) Nothing -> [] - in itemValue : rest + in itemValue : rest vertexListFromOps :: [Vertex] -> Maybe VertexList -vertexListFromOps = foldr go mempty where - go v@Op{opId} vlist = Just $ VertexList{listHead = opId, listItems = vlist'} +vertexListFromOps = foldr go mempty + where + go v@Op {opId} vlist = + Just $ VertexList {listHead = opId, listItems = vlist'} where - item itemNext = VertexListItem{itemValue = v, itemNext} + item itemNext = VertexListItem {itemValue = v, itemNext} vlist' = case vlist of - Nothing -> HashMap.singleton opId (item Nothing) - Just VertexList{listHead, listItems} -> - HashMap.insert opId (item $ Just listHead) listItems + Nothing -> HashMap.singleton opId (item Nothing) + Just VertexList {listHead, listItems} -> + HashMap.insert opId (item $ Just listHead) listItems -- | Untyped RGA newtype RgaRep = RgaRep (Maybe VertexList) - deriving (Eq, Monoid, Semigroup, Semilattice, Show) + deriving (Eq, Monoid, Semigroup, Semilattice, Show) -data PatchSet = PatchSet - { psPatches :: Map UUID VertexList +data PatchSet + = PatchSet + { psPatches :: Map UUID VertexList, -- ^ the key is the parent event, the value is a non-empty VertexList - , psRemovals :: Map UUID UUID + psRemovals :: Map UUID UUID -- ^ the key is the target event, the value is the tombstone event - } - deriving (Eq, Show) + } + deriving (Eq, Show) instance Semigroup PatchSet where - rga1 <> rga2 = reapplyPatchSet $ preMerge rga1 rga2 + rga1 <> rga2 = reapplyPatchSet $ preMerge rga1 rga2 preMerge :: PatchSet -> PatchSet -> PatchSet preMerge (PatchSet p1 r1) (PatchSet p2 r2) = PatchSet - {psPatches = Map.unionWith (<>) p1 p2, psRemovals = Map.unionWith max r1 r2} + { psPatches = Map.unionWith (<>) p1 p2, + psRemovals = Map.unionWith max r1 r2 + } instance Monoid PatchSet where - mempty = PatchSet{psPatches = mempty, psRemovals = mempty} + mempty = PatchSet {psPatches = mempty, psRemovals = mempty} patchSetFromRawOp :: Op -> PatchSet -patchSetFromRawOp op@Op{opId, refId, payload} = case payload of - [] -> -- remove op - mempty{psRemovals = Map.singleton refId opId} - _:_ -> -- append op - mempty - { psPatches = - Map.singleton - refId - VertexList - { listHead = opId - , listItems = - HashMap.singleton - opId - VertexListItem - { itemValue = op{refId = Zero} - , itemNext = Nothing - } +patchSetFromRawOp op@Op {opId, refId, payload} = case payload of + [] -> + -- remove op + mempty {psRemovals = Map.singleton refId opId} + _ : _ -> + -- append op + mempty + { psPatches = Map.singleton + refId + VertexList + { listHead = opId, + listItems = HashMap.singleton + opId + VertexListItem + { itemValue = op {refId = Zero}, + itemNext = Nothing + } } - } + } patchSetFromChunk :: ReducedChunk -> PatchSet -patchSetFromChunk ReducedChunk{rcRef, rcBody} = - case uuidVersion $ UUID.split rcRef of - B11 -> - -- derived event -- rm-patch compatibility - foldMap patchSetFromRawOp rcBody - _ -> -- patch - case vertexListFromOps rcBody of - Just patch -> mempty{psPatches = Map.singleton rcRef patch} - Nothing -> mempty +patchSetFromChunk ReducedChunk {rcRef, rcBody} = + case uuidVersion $ UUID.split rcRef of + B11 -> + -- derived event -- rm-patch compatibility + foldMap patchSetFromRawOp rcBody + _ -> + -- patch + case vertexListFromOps rcBody of + Just patch -> mempty {psPatches = Map.singleton rcRef patch} + Nothing -> mempty instance Reducible RgaRep where - reducibleOpType = rgaType - stateFromChunk = RgaRep . vertexListFromOps + reducibleOpType = rgaType - stateToChunk (RgaRep rga) = maybe [] vertexListToOps rga + stateFromChunk = RgaRep . vertexListFromOps - applyPatches rga (patches, ops) = - bimap id patchSetToChunks . reapplyPatchSetToState rga $ - foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops + stateToChunk (RgaRep rga) = maybe [] vertexListToOps rga - reduceUnappliedPatches (patches, ops) = - patchSetToChunks . reapplyPatchSet $ - foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops + applyPatches rga (patches, ops) = + bimap id patchSetToChunks . reapplyPatchSetToState rga + $ foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops + reduceUnappliedPatches (patches, ops) = + patchSetToChunks . reapplyPatchSet + $ foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops + patchSetToChunks :: PatchSet -> Unapplied -patchSetToChunks PatchSet{psPatches, psRemovals} = - ( [ ReducedChunk{..} - | (rcRef, vertices) <- Map.assocs psPatches - , let rcBody = vertexListToOps vertices - ] - , [ Op{opId = tombstone, refId, payload = []} - | (refId, tombstone) <- Map.assocs psRemovals - ] - ) +patchSetToChunks PatchSet {psPatches, psRemovals} = + ( [ ReducedChunk {..} + | (rcRef, vertices) <- Map.assocs psPatches, + let rcBody = vertexListToOps vertices + ], + [ Op {opId = tombstone, refId, payload = []} + | (refId, tombstone) <- Map.assocs psRemovals + ] + ) reapplyPatchSet :: PatchSet -> PatchSet reapplyPatchSet ps = - continue ps [reapplyPatchesToOtherPatches, reapplyRemovalsToPatches] + continue ps [reapplyPatchesToOtherPatches, reapplyRemovalsToPatches] reapplyPatchSetToState :: RgaRep -> PatchSet -> (RgaRep, PatchSet) reapplyPatchSetToState rga ps = - continue (rga, ps) [reapplyPatchesToState, reapplyRemovalsToState] + continue (rga, ps) [reapplyPatchesToState, reapplyRemovalsToState] continue :: x -> [x -> Maybe x] -> x continue x fs = case asum $ map ($ x) fs of - Nothing -> x - Just x' -> continue x' fs + Nothing -> x + Just x' -> continue x' fs reapplyPatchesToState :: (RgaRep, PatchSet) -> Maybe (RgaRep, PatchSet) -reapplyPatchesToState (RgaRep rstate, ps@PatchSet{..}) = case rstate of - Just VertexList{listHead = targetHead, listItems = targetItems} -> asum - [ do - targetItems' <- applyPatch parent patch targetItems - pure - ( RgaRep . Just $ VertexList targetHead targetItems' - , ps{psPatches = Map.delete parent psPatches} - ) +reapplyPatchesToState (RgaRep rstate, ps@PatchSet {..}) = case rstate of + Just VertexList {listHead = targetHead, listItems = targetItems} -> + asum + [ do + targetItems' <- applyPatch parent patch targetItems + pure + ( RgaRep . Just $ VertexList targetHead targetItems', + ps {psPatches = Map.delete parent psPatches} + ) | (parent, patch) <- Map.assocs psPatches - ] - Nothing -> do - -- rstate is empty => only virtual 0 node exists - -- => we can apply only 0 patch - patch <- psPatches !? Zero - pure (RgaRep $ Just patch, ps{psPatches = Map.delete Zero psPatches}) + ] + Nothing -> do + -- rstate is empty => only virtual 0 node exists + -- => we can apply only 0 patch + patch <- psPatches !? Zero + pure (RgaRep $ Just patch, ps {psPatches = Map.delete Zero psPatches}) reapplyPatchesToOtherPatches :: PatchSet -> Maybe PatchSet -reapplyPatchesToOtherPatches ps@PatchSet{..} = asum +reapplyPatchesToOtherPatches ps@PatchSet {..} = + asum [ do targetItems' <- applyPatch parent patch targetItems - pure ps + pure + ps { psPatches = - Map.insert targetParent (VertexList targetHead targetItems') $ - Map.delete parent psPatches + Map.insert targetParent (VertexList targetHead targetItems') + $ Map.delete parent psPatches } - | (parent, patch) <- Map.assocs psPatches - , (targetParent, targetPatch) <- Map.assocs psPatches - , parent /= targetParent - , let VertexList targetHead targetItems = targetPatch + | (parent, patch) <- Map.assocs psPatches, + (targetParent, targetPatch) <- Map.assocs psPatches, + parent /= targetParent, + let VertexList targetHead targetItems = targetPatch ] applyPatch - :: UUID - -> VertexList - -> HashMap UUID VertexListItem - -> Maybe (HashMap UUID VertexListItem) + :: UUID + -> VertexList + -> HashMap UUID VertexListItem + -> Maybe (HashMap UUID VertexListItem) applyPatch parent patch targetItems = case parent of - Zero -> - error "chunk with zero ref mustn't be considered a state, not a patch" - _ -> do - item@VertexListItem{itemNext} <- HashMap.lookup parent targetItems - let VertexList next' newItems = case itemNext of - Nothing -> patch - Just next -> VertexList next targetItems <> patch - let item' = item{itemNext = Just next'} - pure $ HashMap.insert parent item' targetItems <> newItems + Zero -> + error "chunk with zero ref must be considered a state, not a patch" + _ -> do + item@VertexListItem {itemNext} <- HashMap.lookup parent targetItems + let VertexList next' newItems = case itemNext of + Nothing -> patch + Just next -> VertexList next targetItems <> patch + let item' = item {itemNext = Just next'} + pure $ HashMap.insert parent item' targetItems <> newItems reapplyRemovalsToState :: (RgaRep, PatchSet) -> Maybe (RgaRep, PatchSet) -reapplyRemovalsToState (RgaRep rstate, ps@PatchSet{..}) = do - VertexList{listHead = targetHead, listItems = targetItems} <- rstate - asum - [ do - targetItems' <- applyRemoval parent tombstone targetItems - pure - ( RgaRep . Just $ VertexList targetHead targetItems' - , ps{psRemovals = Map.delete parent psRemovals} - ) - | (parent, tombstone) <- Map.assocs psRemovals - ] +reapplyRemovalsToState (RgaRep rstate, ps@PatchSet {..}) = do + VertexList {listHead = targetHead, listItems = targetItems} <- rstate + asum + [ do + targetItems' <- applyRemoval parent tombstone targetItems + pure + ( RgaRep . Just $ VertexList targetHead targetItems', + ps {psRemovals = Map.delete parent psRemovals} + ) + | (parent, tombstone) <- Map.assocs psRemovals + ] reapplyRemovalsToPatches :: PatchSet -> Maybe PatchSet -reapplyRemovalsToPatches PatchSet{..} = asum +reapplyRemovalsToPatches PatchSet {..} = + asum [ do targetItems' <- applyRemoval parent tombstone targetItems pure PatchSet - { psRemovals = Map.delete parent psRemovals - , psPatches = - Map.insert - targetParent (VertexList targetHead targetItems') psPatches - } - | (parent, tombstone) <- Map.assocs psRemovals - , (targetParent, targetPatch) <- Map.assocs psPatches - , let VertexList targetHead targetItems = targetPatch + { psRemovals = Map.delete parent psRemovals, + psPatches = + Map.insert + targetParent + (VertexList targetHead targetItems') + psPatches + } + | (parent, tombstone) <- Map.assocs psRemovals, + (targetParent, targetPatch) <- Map.assocs psPatches, + let VertexList targetHead targetItems = targetPatch ] applyRemoval - :: UUID - -> UUID - -> HashMap UUID VertexListItem - -> Maybe (HashMap UUID VertexListItem) + :: UUID + -> UUID + -> HashMap UUID VertexListItem + -> Maybe (HashMap UUID VertexListItem) applyRemoval parent tombstone targetItems = do - item@VertexListItem{itemValue = v@Op{refId}} <- - HashMap.lookup parent targetItems - let item' = item{itemValue = v{refId = max refId tombstone}} - pure $ HashMap.insert parent item' targetItems + item@VertexListItem {itemValue = v@Op {refId}} <- + HashMap.lookup parent targetItems + let item' = item {itemValue = v {refId = max refId tombstone}} + pure $ HashMap.insert parent item' targetItems merge :: VertexList -> VertexList -> VertexList -merge v1 v2 - = fromMaybe (error "merge of non-empty lists cannot be empty") +merge v1 v2 = + fromMaybe (error "merge of non-empty lists cannot be empty") $ vertexListFromOps $ (merge' `on` vertexListToOps) v1 v2 @@ -303,20 +336,19 @@ merge' [] vs2 = vs2 merge' vs1 [] = vs1 merge' w1@(v1 : vs1) w2@(v2 : vs2) = - case compare e1 e2 of - LT -> v2 : merge' w1 vs2 - GT -> v1 : merge' vs1 w2 - EQ -> mergeVertices : merge' vs1 vs2 + case compare e1 e2 of + LT -> v2 : merge' w1 vs2 + GT -> v1 : merge' vs1 w2 + EQ -> mergeVertices : merge' vs1 vs2 where - Op{opId = e1, refId = tombstone1, payload = p1} = v1 - Op{opId = e2, refId = tombstone2, payload = p2} = v2 - + Op {opId = e1, refId = tombstone1, payload = p1} = v1 + Op {opId = e2, refId = tombstone2, payload = p2} = v2 -- priority of deletion mergeVertices = Op - { opId = e1 - , refId = max tombstone1 tombstone2 - , payload = maxOn length p1 p2 - } + { opId = e1, + refId = max tombstone1 tombstone2, + payload = maxOn length p1 p2 + } -- | Name-UUID to use as RGA type marker. rgaType :: UUID @@ -324,73 +356,80 @@ -- | Typed RGA newtype RGA a = RGA [a] - deriving (Eq, Show) + deriving (Eq, Show) instance Replicated a => Replicated (RGA a) where encoding = objectEncoding instance Replicated a => ReplicatedAsObject (RGA a) where - type Rep (RGA a) = RgaRep - newObject (RGA items) = do - oid <- getEventUuid - vertexIds <- getEventUuids $ ls60 $ genericLength items - ops <- for (zip items vertexIds) $ \(item, vertexId) -> do - payload <- newRon item - pure $ Op vertexId Zero payload - modify' $ Map.insert oid $ wireStateChunk ops - pure $ ObjectRef oid + type Rep (RGA a) = RgaRep - readObject = do - StateChunk stateBody <- getObjectStateChunk - mItems <- for stateBody $ \Op{refId, payload} -> case refId of - Zero -> Just <$> fromRon payload - _ -> pure Nothing - pure . RGA $ catMaybes mItems + newObject (RGA items) = do + oid <- getEventUuid + vertexIds <- getEventUuids $ ls60 $ genericLength items + ops <- + for (zip items vertexIds) $ \(item, vertexId) -> do + payload <- newRon item + pure $ Op vertexId Zero payload + modify' $ Map.insert oid $ wireStateChunk ops + pure $ ObjectRef oid + readObject = do + StateChunk stateBody <- getObjectStateChunk + mItems <- + for stateBody $ \Op {refId, payload} -> case refId of + Zero -> Just <$> fromRon payload + _ -> pure Nothing + pure . RGA $ catMaybes mItems + -- | Replace content of the RGA throug introducing changes detected by -- 'getGroupedDiffBy'. edit - :: ( ReplicatedAsPayload a - , ReplicaClock m, MonadE m, MonadObjectState (RGA a) m - ) - => [a] -> m () + :: ( ReplicatedAsPayload a, + ReplicaClock m, + MonadE m, + MonadObjectState (RGA a) m + ) + => [a] + -> m () edit newItems = - modifyObjectStateChunk_ $ \chunk@(StateChunk stateBody) -> do - let newItems' = [Op Zero Zero $ toPayload item | item <- newItems] - -- TODO(2019-04-17, #59, cblp) replace 'toPayload' with 'newRon' and - -- relax constraint on 'a' from 'ReplicatedAsPayload' to - -- 'Replicated' - let diff = getGroupedDiffBy eqAliveOnPayload stateBody newItems' - (stateBody', Last lastEvent) <- - runWriterT . fmap fold . for diff $ \case - First removed -> for removed $ \case - op@Op{refId = Zero} -> do -- not deleted yet - -- TODO(2018-11-03, #15, cblp) get sequential ids - tombstone <- getEventUuid - tell . Last $ Just tombstone - pure op{refId = tombstone} - op -> -- deleted already - pure op - Both v _ -> pure v - Second added -> for added $ \op -> do - -- TODO(2018-11-03, #15, cblp) get sequential ids - opId <- getEventUuid - tell . Last $ Just opId - pure op{opId} - pure $ case lastEvent of - Nothing -> chunk - Just _ -> StateChunk stateBody' + modifyObjectStateChunk_ $ \chunk@(StateChunk stateBody) -> do + let newItems' = [Op Zero Zero $ toPayload item | item <- newItems] + -- TODO(2019-04-17, #59, cblp) replace 'toPayload' with 'newRon' and + -- relax constraint on 'a' from 'ReplicatedAsPayload' to + -- 'Replicated' + let diff = getGroupedDiffBy eqAliveOnPayload stateBody newItems' + (stateBody', Last lastEvent) <- + runWriterT . fmap fold . for diff $ \case + First removed -> for removed $ \case + op@Op {refId = Zero} -> do + -- not deleted yet + -- TODO(2018-11-03, #15, cblp) get sequential ids + tombstone <- getEventUuid + tell . Last $ Just tombstone + pure op {refId = tombstone} + op -> + -- deleted already + pure op + Both v _ -> pure v + Second added -> for added $ \op -> do + -- TODO(2018-11-03, #15, cblp) get sequential ids + opId <- getEventUuid + tell . Last $ Just opId + pure op {opId} + pure $ case lastEvent of + Nothing -> chunk + Just _ -> StateChunk stateBody' where eqAliveOnPayload - Op{refId = Zero, payload = p1} - Op{refId = Zero, payload = p2} - = p1 == p2 + Op {refId = Zero, payload = p1} + Op {refId = Zero, payload = p2} = + p1 == p2 eqAliveOnPayload _ _ = False -- | Speciaization of 'edit' for 'Text' editText - :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) - => Text -> m () + :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) => Text -> m () editText = edit . Text.unpack -- | Speciaization of 'RGA' to 'Char'. @@ -399,26 +438,22 @@ -- | Create an RGA from a list newFromList - :: (Replicated a, MonadState StateFrame m, ReplicaClock m) - => [a] -> m (ObjectRef (RGA a)) + :: (Replicated a, MonadState StateFrame m, ReplicaClock m) + => [a] + -> m (ObjectRef (RGA a)) newFromList = newObject . RGA -- | Create an 'RgaString' from a text newFromText - :: (MonadState StateFrame m, ReplicaClock m) - => Text -> m (ObjectRef RgaString) + :: (MonadState StateFrame m, ReplicaClock m) + => Text + -> m (ObjectRef RgaString) newFromText = newFromList . Text.unpack getAliveIndices :: (MonadE m, MonadObjectState (RGA a) m) => m [UUID] getAliveIndices = do - StateChunk stateBody <- getObjectStateChunk - let mItems = - [ case refId of - Zero -> Just opId - _ -> Nothing - | Op{opId, refId} <- stateBody - ] - pure $ catMaybes mItems + StateChunk stateBody <- getObjectStateChunk + pure [opId | Op {opId, refId = Zero} <- stateBody] -- | Read elements from RGA getList :: (Replicated a, MonadE m, MonadObjectState (RGA a) m) => m [a] @@ -431,81 +466,92 @@ -- | Insert a sequence of elements after the specified position. -- Position is identified by 'UUID'. 'Nothing' means the beginning. insert - :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) - => [a] - -> Maybe UUID -- ^ position - -> m () -insert [] _ = pure () + :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) + => [a] + -> Maybe UUID -- ^ position + -> m () +insert [] _ = pure () insert items mPosition = - modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do - vertexIds <- getEventUuids $ ls60 $ genericLength items - ops <- - for (zip items vertexIds) $ \(item, vertexId) -> do - payload <- newRon item - pure $ Op vertexId Zero payload - stateBody' <- case mPosition of - Nothing -> pure $ ops <> stateBody - Just position -> findAndInsertAfter position ops stateBody - pure $ StateChunk stateBody' + modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do + vertexIds <- getEventUuids $ ls60 $ genericLength items + ops <- + for (zip items vertexIds) $ \(item, vertexId) -> do + payload <- newRon item + pure $ Op vertexId Zero payload + stateBody' <- + case mPosition of + Nothing -> pure $ ops <> stateBody + Just position -> findAndInsertAfter position ops stateBody + pure $ StateChunk stateBody' where - findAndInsertAfter pos newOps = go where + findAndInsertAfter pos newOps = go + where go = \case - [] -> throwErrorText "Position not found" - op@Op{opId} : ops - | opId == pos -> pure $ op : newOps ++ ops - | otherwise -> (op :) <$> go ops + [] -> throwErrorText "Position not found" + op@Op {opId} : ops + | opId == pos -> pure $ op : newOps ++ ops + | otherwise -> (op :) <$> go ops insertAtBegin - :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) - => [a] -> m () + :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) + => [a] + -> m () insertAtBegin items = insert items Nothing insertAfter - :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) - => [a] - -> UUID -- ^ position - -> m () + :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) + => [a] + -> UUID -- ^ position + -> m () insertAfter items = insert items . Just -- | Insert a text after the specified position. -- Position is identified by 'UUID'. 'Nothing' means the beginning. insertText - :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) - => Text - -> Maybe UUID -- ^ position - -> m () + :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) + => Text + -> Maybe UUID -- ^ position + -> m () insertText = insert . Text.unpack insertTextAtBegin - :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) => Text -> m () + :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) => Text -> m () insertTextAtBegin text = insertText text Nothing insertTextAfter - :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) - => Text - -> UUID -- ^ position - -> m () + :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) + => Text + -> UUID -- ^ position + -> m () insertTextAfter text = insertText text . Just -- | Record a removal of a specific item remove - :: (MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) - => UUID -- ^ position - -> m () + :: (MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) + => UUID -- ^ position + -> m () remove position = - errorContext "RGA.remove" $ - errorContext ("position = " <> show position) $ - modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do - event <- getEventUuid - stateBody' <- findAndTombstone event stateBody - pure $ StateChunk stateBody' + errorContext "RGA.remove" + $ errorContext ("position = " <> show position) + $ modifyObjectStateChunk_ + $ \(StateChunk stateBody) -> do + event <- getEventUuid + stateBody' <- findAndTombstone event stateBody + pure $ StateChunk stateBody' where - findAndTombstone event = go where + findAndTombstone event = go + where go = \case - [] -> throwErrorText "Position not found" - op@Op{opId} : ops - | opId == position -> pure $ op{refId = event} : ops - | otherwise -> (op :) <$> go ops + [] -> throwErrorText "Position not found" + op@Op {opId} : ops + | opId == position -> pure $ op {refId = event} : ops + | otherwise -> (op :) <$> go ops wireStateChunk :: [Op] -> WireStateChunk -wireStateChunk stateBody = WireStateChunk{stateType = rgaType, stateBody} +wireStateChunk stateBody = WireStateChunk {stateType = rgaType, stateBody} + +toList :: RGA a -> [a] +toList (RGA xs) = xs + +toText :: RgaString -> Text +toText (RGA s) = Text.pack s diff --git a/ron-rdt.cabal b/ron-rdt.cabal --- a/ron-rdt.cabal +++ b/ron-rdt.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-rdt -version: 0.9.1 +version: 0.10 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database @@ -32,7 +32,7 @@ build-depends: -- global containers, - Diff, + Diff < 0.4, hashable, mtl, text,