ron-rdt 0.5 → 0.6
raw patch · 3 files changed
+150/−9 lines, 3 files
Files
- lib/RON/Data/RGA.hs +119/−3
- prelude/Prelude.hs +29/−4
- ron-rdt.cabal +2/−2
lib/RON/Data/RGA.hs view
@@ -16,10 +16,18 @@ , RgaString , edit , editText+ , getAliveIndices , getList , getText+ , insert+ , insertAfter+ , insertAtBegin+ , insertText+ , insertTextAfter+ , insertTextAtBegin , newFromList , newFromText+ , remove , rgaType ) where @@ -31,7 +39,7 @@ import qualified Data.Text as Text import RON.Data.Internal-import RON.Error (MonadE)+import RON.Error (MonadE, errorContext, throwErrorText) import RON.Event (ReplicaClock, advanceToUuid, getEventUuid, getEventUuids) import RON.Types (Object (..), Op (..), StateChunk (..), UUID)@@ -39,6 +47,8 @@ import RON.UUID (pattern Zero, uuidVersion) import qualified RON.UUID as UUID +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+ -- | opId = vertex id -- refId: -- 0 = value is alive,@@ -343,10 +353,12 @@ => [a] -> m () edit newItems = do obj@Object{id, frame} <- get- StateChunk{..} <- getObjectStateChunk obj+ StateChunk{stateVersion, stateBody} <- getObjectStateChunk obj advanceToUuid stateVersion 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@@ -399,10 +411,114 @@ newFromText :: ReplicaClock m => Text -> m (Object RgaString) newFromText = newFromList . Text.unpack +getAliveIndices :: MonadE m => Object (RGA a) -> m [UUID]+getAliveIndices obj = do+ StateChunk{stateBody} <- getObjectStateChunk obj+ let mItems =+ [ case refId of+ Zero -> Just opId+ _ -> Nothing+ | Op{opId, refId} <- stateBody+ ]+ pure $ catMaybes mItems+ -- | Read elements from RGA-getList :: forall a m . (Replicated a, MonadE m) => Object (RGA a) -> m [a]+getList :: (Replicated a, MonadE m) => Object (RGA a) -> m [a] getList = fmap coerce . getObject -- | Read characters from 'RgaString' getText :: MonadE m => Object RgaString -> m Text getText = fmap Text.pack . getList++-- | Insert a sequence of elements after the specified position.+-- Position is identified by 'UUID'. 'Nothing' means the beginning.+insert+ :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m)+ => [a]+ -> Maybe UUID -- ^ position+ -> m ()+insert [] _ = pure ()+insert items mPosition = do+ obj@Object{id, frame} <- get+ stateChunk@StateChunk{stateVersion, stateBody} <- getObjectStateChunk obj+ advanceToUuid stateVersion++ vertexIds <- getEventUuids $ ls60 $ genericLength items+ (ops, newFrame) <- runWriterT $+ for (zip items vertexIds) $ \(item, vertexId) -> do+ payload <- newRon item+ pure $ Op vertexId Zero payload++ let stateVersion' = maximumDef stateVersion $ map opId ops+ stateBody' <- case mPosition of+ Nothing -> pure $ ops <> stateBody+ Just position -> findAndInsertAfter position ops stateBody+ let stateChunk' =+ stateChunk{stateVersion = stateVersion', stateBody = stateBody'}+ put obj{frame = Map.insert id stateChunk' frame <> newFrame}+ 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++insertAtBegin+ :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m)+ => [a] -> m ()+insertAtBegin items = insert items Nothing++insertAfter+ :: (Replicated a, MonadE m, MonadState (Object (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, MonadState (Object RgaString) m)+ => Text+ -> Maybe UUID -- ^ position+ -> m ()+insertText = insert . Text.unpack++insertTextAtBegin+ :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m)+ => Text -> m ()+insertTextAtBegin text = insertText text Nothing++insertTextAfter+ :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m)+ => Text+ -> UUID -- ^ position+ -> m ()+insertTextAfter text = insertText text . Just++-- | Record a removal of a specific item+remove+ :: (MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m)+ => UUID -- ^ position+ -> m ()+remove position =+ errorContext "RGA.remove" $+ errorContext ("position = " <> show position) $ do+ obj@Object{id, frame} <- get+ stateChunk@StateChunk{stateVersion, stateBody} <-+ getObjectStateChunk obj+ advanceToUuid stateVersion++ event <- getEventUuid+ stateBody' <- findAndTombstone event stateBody+ let stateChunk' =+ stateChunk{stateVersion = event, stateBody = stateBody'}+ put obj{frame = Map.insert id stateChunk' frame}+ 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
prelude/Prelude.hs view
@@ -5,13 +5,18 @@ module X, fmapL, foldr1,+ headMay, identity, lastDef, maximumDef, maxOn, minOn,+ note,+ replicateM2,+ replicateM3, show, whenJust,+ (!!), (?:), ) where @@ -40,10 +45,11 @@ import Data.Int as X (Int, Int16, Int32, Int64, Int8) import Data.IORef as X (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)-import Data.List as X (filter, genericLength, intercalate, isPrefixOf,- isSuffixOf, lookup, map, partition, repeat,- replicate, sortBy, sortOn, span, splitAt, take,- takeWhile, unlines, unwords, zip, (++))+import Data.List as X (drop, filter, genericLength, intercalate,+ isPrefixOf, isSuffixOf, lookup, map, partition,+ repeat, replicate, sortBy, sortOn, span,+ splitAt, take, takeWhile, unlines, unwords,+ zip, (++)) import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty) import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList)@@ -131,6 +137,11 @@ foldr1 :: (a -> a -> a) -> NonEmpty a -> a foldr1 = Data.Foldable.foldr1 +headMay :: [a] -> Maybe a+headMay = \case+ [] -> Nothing+ a:_ -> Just a+ identity :: a -> a identity x = x @@ -151,11 +162,25 @@ minOn :: Ord b => (a -> b) -> a -> a -> a minOn f x y = if f x < f y then x else y +note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right++replicateM2 :: Applicative m => m a -> m (a, a)+replicateM2 ma = (,) <$> ma <*> ma++replicateM3 :: Applicative m => m a -> m (a, a, a)+replicateM3 ma = (,,) <$> ma <*> ma <*> ma+ show :: (Show a, IsString s) => a -> s show = fromString . Text.Show.show whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust m f = maybe (pure ()) f m++(!!) :: [a] -> Int -> Maybe a+xs !! i+ | i < 0 = Nothing+ | otherwise = headMay $ drop i xs -- | An infix form of 'fromMaybe' with arguments flipped. (?:) :: Maybe a -> a -> a
ron-rdt.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-rdt-version: 0.5+version: 0.6 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -19,7 +19,7 @@ . > import RON.Data > import RON.Schema.TH- > import RON.Storage.IO as Storage+ > import RON.Storage.FS as Storage > > [mkReplicated| > (struct_lww Note