crdt 9.3 → 10.0

raw patch · 5 files changed

+80/−43 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• crdt.cabal +3/−3
• lib/CRDT/Cm/RGA.hs +21/−21
• lib/CRDT/Cv/RGA.hs +20/−17
• lib/Data/Empty.hs +34/−0
• lib/MacAddress.hs +2/−2

@@ -1,5 +1,5 @@ name: crdt-version: 9.3+version: 10.0           -- ^ ComVer category: Distributed Systems copyright:@@ -29,12 +29,11 @@                   , Diff                   , hashable                   , mtl+                  , network-info                   , safe                   , stm                   , time                   , vector-    -- if !impl(eta)-    build-depends:  network-info     exposed-modules:  CRDT.Cv                       CRDT.Cv.GCounter                       CRDT.Cv.GSet@@ -47,6 +46,7 @@                       CRDT.LamportClock                       CRDT.LamportClock.Simulation                       CRDT.LWW+                      Data.Empty                       Data.MultiMap                       Data.Semilattice     if impl(ghc >= 8)

@@ -19,6 +19,7 @@  import           Control.Monad.Fail (MonadFail) import           Control.Monad.State.Strict (MonadState)+import           Data.Empty (AsEmpty (..)) import           Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import           Data.Semigroup ((<>))@@ -34,20 +35,17 @@ type VertexId = LamportTime  data RgaPayload a = RgaPayload-    { vertices  :: Vector (VertexId, Maybe a) -- TODO(cblp, 2018-02-06) Unbox+    { vertices  :: Vector (VertexId, a) -- TODO(cblp, 2018-02-06) Unbox     , vertexIxs :: Map VertexId Int       -- ^ indices in `vertices` vector     }     deriving (Eq, Show)  -- | Is added and is not removed.-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+lookup :: AsEmpty a => VertexId -> RgaPayload a -> Bool+lookup v RgaPayload { vertices, vertexIxs } = case Map.lookup v vertexIxs of+    Just ix -> let (_, a) = vertices Vector.! ix in isNotEmpty a+    Nothing -> False  data RgaIntent a     = AddAfter (Maybe VertexId) a@@ -67,9 +65,9 @@     precedes _ _ = False  emptyPayload :: RgaPayload a-emptyPayload = RgaPayload{vertices = Vector.empty, vertexIxs = Map.empty}+emptyPayload = RgaPayload {vertices = Vector.empty, vertexIxs = Map.empty} -instance Ord a => CmRDT (RGA a) where+instance (AsEmpty a, Ord a) => CmRDT (RGA a) where     type Intent  (RGA a) = RgaIntent  a     type Payload (RGA a) = RgaPayload a @@ -101,7 +99,7 @@          (vertices', newIx)             | null vertices = case mOldId of-                Nothing    -> (Vector.singleton (newId, Just newAtom), 0)+                Nothing    -> (Vector.singleton (newId, newAtom), 0)                 Just oldId -> error $ show oldId <> " not delivered"             | otherwise = (insert ix, ix)               where@@ -123,20 +121,21 @@                 _ -> ix          insert ix-            | ix < n = left <> Vector.singleton (newId, Just newAtom) <> right-            | otherwise = Vector.snoc vertices (newId, Just newAtom)+            | ix < n = left <> Vector.singleton (newId, newAtom) <> right+            | otherwise = Vector.snoc vertices (newId, newAtom)           where             (left, right) = Vector.splitAt ix vertices      apply (OpRemove vid) payload@RgaPayload{vertices, vertexIxs} =         -- pre addAfter(_, w) delivered  -- 2P-Set precondition-        payload{vertices = vertices // [(ix, (vid, Nothing))]}+        payload{vertices = vertices // [(ix, (vid, empty))]}       where         ix = vertexIxs Map.! vid  fromList-    :: (Ord a, Clock m, MonadFail m, MonadState (RgaPayload a) m)-    => [a] -> m [RGA a]+    :: (AsEmpty a, Ord a, Clock m, MonadFail m, MonadState (RgaPayload a) m)+    => [a]+    -> m [RGA a] fromList = go Nothing   where     go _      []     = pure []@@ -145,22 +144,23 @@         (op :) <$> go (Just newId) xs  toList :: RgaPayload a -> [a]-toList RgaPayload{vertices} = [a | (_, Just a) <- Vector.toList vertices]+toList RgaPayload { vertices } = map snd $ Vector.toList vertices  toVector :: RgaPayload a -> Vector a-toVector RgaPayload{vertices} = Vector.mapMaybe snd vertices+toVector RgaPayload { vertices } = Vector.map snd vertices  fromString     :: (Clock m, MonadFail m, MonadState (RgaPayload Char) m)-    => String -> m [RGA Char]+    => String+    -> m [RGA Char] fromString = fromList  toString :: RgaPayload Char -> String toString = toList -load :: Vector (VertexId, Maybe a) -> RgaPayload a+load :: Vector (VertexId, a) -> RgaPayload a load vertices = RgaPayload     { vertices     , vertexIxs = Map.fromList-        [(vid, ix) | ix <- [0..] | (vid, _) <- Vector.toList vertices]+        [ (vid, ix) | ix <- [0..] | (vid, _) <- Vector.toList vertices ]     }

@@ -17,6 +17,7 @@  import           Data.Algorithm.Diff (Diff (Both, First, Second),                                       getGroupedDiffBy)+import           Data.Empty (AsEmpty (..)) import           Data.Function (on) import           Data.Semigroup (Semigroup, (<>)) import           Data.Semilattice (Semilattice)@@ -27,12 +28,12 @@ type VertexId = LamportTime  -- | TODO(cblp, 2018-02-06) Vector.Unboxed-newtype RGA a = RGA [(VertexId, Maybe a)]+newtype RGA a = RGA [(VertexId, a)]     deriving (Eq, Show)  type RgaString = RGA Char -merge :: Eq a => RGA a -> RGA a -> RGA a+merge :: (Eq a, AsEmpty a) => RGA a -> RGA a -> RGA a merge (RGA vertices1) (RGA vertices2) = RGA     $ mergeVertexLists vertices1 vertices2   where@@ -44,29 +45,31 @@             GT -> v1 : mergeVertexLists vs1 (v2 : vs2)             EQ -> (id1, mergeAtoms a1 a2) : mergeVertexLists vs1 vs2 -    mergeAtoms (Just a1) (Just a2) | a1 == a2 = Just a1-    mergeAtoms _         _                    = Nothing+    -- priority of deletion+    mergeAtoms a1 a2 | isEmpty a1 || isEmpty a2 = empty+                     | a1 == a2                 = a1+                     | otherwise                = empty -- error: contradiction -instance Eq a => Semigroup (RGA a) where+instance (Eq a, AsEmpty a) => Semigroup (RGA a) where     (<>) = merge -instance Eq a => Semilattice (RGA a)+instance (Eq a, AsEmpty a) => Semilattice (RGA a)  -- Why not?-instance Eq a => Monoid (RGA a) where+instance (Eq a, AsEmpty a) => Monoid (RGA a) where     mempty = RGA []     mappend = (<>) -toList :: RGA a -> [a]-toList (RGA rga) = [ a | (_, Just a) <- rga ]+toList :: AsEmpty a => RGA a -> [a]+toList (RGA rga) = [ a | (_, a) <- rga, isNotEmpty a ]  toString :: RgaString -> String toString = toList  fromList :: Clock m => [a] -> m (RGA a)-fromList = fmap RGA . fromList' . map Just+fromList = fmap RGA . fromList' -fromList' :: Clock m => [Maybe a] -> m [(VertexId, Maybe a)]+fromList' :: Clock m => [a] -> m [(VertexId, a)] fromList' xs = do     LamportTime time0 pid <- getTimes . fromIntegral $ length xs     pure [ (LamportTime time pid, x) | time <- [time0..] | x <- xs ]@@ -76,19 +79,19 @@  -- | Replace content with specified, -- applying changed found by the diff algorithm-edit :: (Eq a, Clock m) => [a] -> RGA a -> m (RGA a)+edit :: (Eq a, AsEmpty a, Clock m) => [a] -> RGA a -> m (RGA a) edit newList (RGA oldRga) = fmap (RGA . concat) . for diff $ \case-    First removed -> pure [ (vid, Nothing) | (vid, _) <- removed ] -- :: m [(VertexId, Maybe a)]-    Both v _      -> pure v -- :: m [(VertexId, Maybe a)]-    Second added  -> fromList' $ map snd added -- :: m [(VertexId, Maybe a)]+    First removed -> pure [ (vid, empty) | (vid, _) <- removed ]+    Both v _      -> pure v+    Second added  -> fromList' $ map snd added   where-    newList' = [ (undefined, Just a) | a <- newList ]+    newList' = [ (undefined, a) | a <- newList ]     diff     = getGroupedDiffBy ((==) `on` snd) oldRga newList'  -- | Compact version of 'RGA'. -- For each 'VertexId', the corresponding sequence of vetices has the same 'Pid' -- and sequentially growing 'LocalTime', starting with the specified one.-type RgaPacked a = [(VertexId, [Maybe a])]+type RgaPacked a = [(VertexId, [a])]  pack :: RGA a -> RgaPacked a pack (RGA []                ) = []

@@ -0,0 +1,34 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE LambdaCase #-}++module Data.Empty where++-- | A type that may be empty.+-- If your type does not have a special empty value, just wrap it into 'Maybe',+-- it is free.+--+-- Based on Control.Lens.Empty.AsEmpty.+class AsEmpty a where+    empty :: a++    isEmpty :: a -> Bool+    default isEmpty :: Eq a => a -> Bool+    isEmpty a = empty == a++    isNotEmpty :: a -> Bool+    default isNotEmpty :: Eq a => a -> Bool+    isNotEmpty a = empty /= a++instance AsEmpty (Maybe a) where+    empty = Nothing++    isEmpty = \case+        Nothing -> True+        _       -> False++    isNotEmpty = \case+        Nothing -> False+        _       -> True++instance AsEmpty Char where+    empty = '\NUL'

@@ -14,7 +14,7 @@ import           Data.Traversable (for) import           Data.Word (Word64, Word8) -#else /* ETA_VERSION */+#else /* !defined ETA_VERSION */  import           Data.Word (Word64) import           Network.Info (MAC (MAC), getNetworkInterfaces, mac)@@ -47,7 +47,7 @@ foldBytes :: [Word8] -> Word64 foldBytes bytes = decode . BSL.pack $ replicate (8 - length bytes) 0 ++ bytes -#else /* ETA_VERSION */+#else /* !defined ETA_VERSION */  getMacAddress = decodeMac <$> getMac