crdt 2.1 → 3.0

raw patch · 31 files changed

+632/−392 lines, 31 filesdep +QuickCheckdep +tasty-discoverPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, tasty-discover

API changes (from Hackage documentation)

Files

• crdt.cabal +14/−4
• lib/CRDT/Cm.hs +21/−39
• lib/CRDT/Cm/Counter.hs +3/−3
• lib/CRDT/Cm/GSet.hs +3/−7
• lib/CRDT/Cm/TPSet.hs +0/−34
• lib/CRDT/Cm/TwoPSet.hs +31/−0
• lib/CRDT/Cv/GCounter.hs +1/−3
• lib/CRDT/Cv/GSet.hs +6/−8
• lib/CRDT/Cv/LwwElementSet.hs +51/−0
• lib/CRDT/Cv/Max.hs +3/−8
• lib/CRDT/Cv/ORSet.hs +48/−0
• lib/CRDT/Cv/TwoPSet.hs +45/−0
• lib/CRDT/LWW.hs +32/−32
• lib/CRDT/LamportClock.hs +66/−0
• lib/Data/Semilattice.hs +8/−1
• lib/LamportClock.hs +0/−89
• test/ArbitraryOrphans.hs +20/−13
• test/Cm/TwoPSet.hs +13/−0
• test/Counter.hs +4/−6
• test/Cv/TwoPSet.hs +27/−0
• test/GCounter.hs +8/−12
• test/GSet.hs +8/−13
• test/LWW.hs +35/−28
• test/Laws.hs +60/−37
• test/LwwElementSet.hs +65/−0
• test/Main.hs +1/−13
• test/Max.hs +8/−14
• test/ORSet.hs +25/−0
• test/PNCounter.hs +11/−15
• test/QCUtil.hs +15/−0
• test/TPSet.hs +0/−13

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           crdt-version:        2.1+version:        3.0 synopsis:       Conflict-free replicated data types description:    Definitions of CmRDT and CvRDT. Implementations for some classic CRDTs. category:       Distributed Systems@@ -31,15 +31,18 @@       CRDT.Cm       CRDT.Cm.Counter       CRDT.Cm.GSet-      CRDT.Cm.TPSet+      CRDT.Cm.TwoPSet       CRDT.Cv       CRDT.Cv.GCounter       CRDT.Cv.GSet+      CRDT.Cv.LwwElementSet       CRDT.Cv.Max+      CRDT.Cv.ORSet       CRDT.Cv.PNCounter+      CRDT.Cv.TwoPSet+      CRDT.LamportClock       CRDT.LWW       Data.Semilattice-      LamportClock   default-language: Haskell2010  test-suite test@@ -50,17 +53,24 @@   build-depends:       base >= 4.9 && < 4.11     , containers+    , mtl+    , QuickCheck     , tasty+    , tasty-discover >= 4.1     , tasty-quickcheck     , crdt   other-modules:       ArbitraryOrphans+      Cm.TwoPSet       Counter+      Cv.TwoPSet       GCounter       GSet       Laws       LWW+      LwwElementSet       Max+      ORSet       PNCounter-      TPSet+      QCUtil   default-language: Haskell2010

@@ -1,10 +1,6 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}  module CRDT.Cm     ( CausalOrd (..)@@ -12,15 +8,17 @@     , concurrent     ) where -import           LamportClock (Clock)+import           CRDT.LamportClock (Process)  -- | Partial order for causal semantics. -- Values of some type may be ordered and causally-ordered different ways. class CausalOrd a where-    before :: a -> a -> Bool+    -- | @x `affects` y@ means that+    -- @x@ must go before @y@ and @y@ can not go before @x@.+    affects :: a -> a -> Bool  comparable :: CausalOrd a => a -> a -> Bool-comparable a b = a `before` b || b `before` a+comparable a b = a `affects` b || b `affects` a  -- | Not comparable, i. e. ¬(a ≤ b) ∧ ¬(b ≤ a). concurrent :: CausalOrd a => a -> a -> Bool@@ -32,16 +30,16 @@ == Implementation  In Haskell, a CmRDT implementation consists of 3 types —-a __payload__, an __operation__ (@op@) and an __update__.+a __payload__, an __operation__ (@op@) and an __intent__.  [Payload]     Internal state of a replica.-[Operation]+[Intent]     User's request to update.-[Update]+[Operation (Op)]     Operation to be applied to other replicas. -For many types /operation/ and /update/ may be the same.+For many types /operation/ and /intent/ may be the same. But for 'CRDT.Cm.LWW.LWW', for instance, this rule doesn't hold: user can request only value, and type attaches a timestamp to it. @@ -50,44 +48,28 @@ Concurrent updates are observed equally.  @-∀ up1 up2 s .-'concurrent' up1 up2 ==>-    'observe' ('updateDownstream' up1 . 'updateDownstream' up2 $ s) ==-    'observe' ('updateDownstream' up2 . 'updateDownstream' up1 $ s)+∀ op1 op2 .+'concurrent' op1 op2 ==> 'apply' op1 . 'apply' op2 == 'apply' op2 . 'apply' op1 @  Idempotency doesn't need to hold. -} -class (CausalOrd u, Eq (View u)) => CmRDT u where-    type Op u-    type Op u = u -- default case--    type Payload u--    type View u-    type View u = Payload u -- default case+class (CausalOrd op, Eq (Payload op)) => CmRDT op where+    type Intent op+    type Intent op = op -- common case -    -- | Precondition for 'updateAtSource'.-    -- Calculates if the operation is applicable to the current state.-    updateAtSourcePre :: Op u -> Payload u -> Bool-    updateAtSourcePre _ _ = True+    type Payload op      -- | Generate an update to the local and remote replicas.-    -- Doesn't have sense if 'updateAtSourcePre' is false.     ---    -- May or may not use clock.-    updateAtSource :: Clock m => Op u -> m u+    -- Returns 'Nothing' if the intended operation is not applicable.+    makeOp :: Intent op -> Payload op -> Maybe (Process op) -    default updateAtSource :: (Clock m, Op u ~ u) => Op u -> m u-    updateAtSource = pure+    default makeOp+        :: Intent op ~ op => Intent op -> Payload op -> Maybe (Process op)+    makeOp i _ = Just $ pure i      -- | Apply an update to the payload.     -- An invalid update must be ignored.-    updateDownstream :: u -> Payload u -> Payload u--    -- | Extract user-visible value from payload-    view :: Payload u -> View u--    default view :: (Payload u ~ View u) => Payload u -> View u-    view = id+    apply :: op -> Payload op -> Payload op

@@ -13,12 +13,12 @@     deriving (Bounded, Enum, Eq, Show)  instance (Num a, Eq a) => CmRDT (Counter a) where-    type Payload  (Counter a) = a+    type Payload (Counter a) = a -    updateDownstream = \case+    apply = \case         Increment -> (+ 1)         Decrement -> subtract 1  -- | Empty order, allowing arbitrary reordering instance CausalOrd (Counter a) where-    before _ _ = False+    affects _ _ = False

@@ -1,13 +1,9 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}  module CRDT.Cm.GSet     ( GSet (..)     ) where -import           Prelude hiding (lookup)- import           Data.Set (Set) import qualified Data.Set as Set @@ -17,9 +13,9 @@     deriving (Eq, Show)  instance Ord a => CmRDT (GSet a) where-    type Payload  (GSet a) = Set a+    type Payload (GSet a) = Set a -    updateDownstream (Add a) = Set.insert a+    apply (Add a) = Set.insert a  instance Eq a => CausalOrd (GSet a) where-    before _ _ = False+    affects _ _ = False

@@ -1,34 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}---- | TODO(cblp, 2017-09-29) USet?-module CRDT.Cm.TPSet-    ( TPSet (..)-    , updateAtSource-    , updateDownstream-    ) where--import           Data.Set (Set)-import qualified Data.Set as Set--import           CRDT.Cm (CausalOrd (..), CmRDT (..))--data TPSet a = Add a | Remove a-    deriving (Eq, Show)--instance Ord a => CmRDT (TPSet a) where-    type Payload  (TPSet a) = Set a--    updateAtSourcePre op payload = case op of-        Add _     -> True-        Remove a  -> Set.member a payload--    updateDownstream = \case-        Add a     -> Set.insert a-        Remove a  -> Set.delete a--instance Eq a => CausalOrd (TPSet a) where-    Remove a `before` Add b = a == b -- `Remove e` can occur only after `Add e`-    _        `before` _     = False  -- Any other are not ordered

@@ -0,0 +1,31 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}++-- | TODO(cblp, 2017-09-29) USet?+module CRDT.Cm.TwoPSet+    ( TwoPSet (..)+    ) where++import           Control.Monad (guard)+import           Data.Set (Set)+import qualified Data.Set as Set++import           CRDT.Cm (CausalOrd (..), CmRDT (..))++data TwoPSet a = Add a | Remove a+    deriving (Eq, Show)++instance Ord a => CmRDT (TwoPSet a) where+    type Payload (TwoPSet a) = Set a++    makeOp op s = case op of+        Add _     -> Just (pure op)+        Remove a  -> guard (Set.member a s) *> Just (pure op)++    apply = \case+        Add a     -> Set.insert a+        Remove a  -> Set.delete a++instance Eq a => CausalOrd (TwoPSet a) where+    Remove a `affects` Add b = a == b -- `Remove e` can occur only after `Add e`+    _        `affects` _     = False  -- Any other are not ordered

@@ -37,6 +37,4 @@  -- | Get value from the state query :: Num a => GCounter a -> a-query (GCounter v) = mapSum v-  where-    mapSum = IntMap.foldr (+) 0+query (GCounter v) = sum v

@@ -1,21 +1,18 @@-{-# OPTIONS_GHC -Wno-orphans #-}- module CRDT.Cv.GSet     ( GSet     , add     , initial-    , query+    , lookup     ) where -import           Data.Semilattice (Semilattice)+import           Prelude hiding (lookup)+ import           Data.Set (Set) import qualified Data.Set as Set  -- | Grow-only set type GSet = Set -instance Ord a => Semilattice (Set a)- -- | update add :: Ord a => a -> GSet a -> GSet a add = Set.insert@@ -24,5 +21,6 @@ initial :: GSet a initial = Set.empty -query :: Ord a => a -> GSet a -> Bool-query = Set.member+-- | lookup query+lookup :: Ord a => a -> GSet a -> Bool+lookup = Set.member

@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module CRDT.Cv.LwwElementSet+    ( LwwElementSet (..)+    , add+    , initial+    , lookup+    , remove+    ) where++import           Prelude hiding (lookup)++import           Data.Foldable (for_)+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Semigroup (Semigroup (..))++import           CRDT.LamportClock (Process)+import           CRDT.LWW (LWW, advanceFromLWW)+import qualified CRDT.LWW as LWW+import           Data.Semilattice (Semilattice)++newtype LwwElementSet a = LES (Map a (LWW Bool))+    deriving (Eq, Show)++instance Ord a => Semigroup (LwwElementSet a) where+    LES m1 <> LES m2 = LES (Map.unionWith (<>) m1 m2)++instance Ord a => Semilattice (LwwElementSet a)++initial :: LwwElementSet a+initial = LES Map.empty++add :: Ord a => a -> LwwElementSet a -> Process (LwwElementSet a)+add value old@(LES m) = do+    advanceFromLES old+    tag <- LWW.initial True+    pure . LES $ Map.insertWith (<>) value tag m++remove :: Ord a => a -> LwwElementSet a -> Process (LwwElementSet a)+remove value old@(LES m) = do+    advanceFromLES old+    tag <- LWW.initial False+    pure . LES $ Map.insertWith (<>) value tag m++lookup :: Ord a => a -> LwwElementSet a -> Bool+lookup value (LES m) = maybe False LWW.query $ Map.lookup value m++advanceFromLES :: LwwElementSet a -> Process ()+advanceFromLES (LES m) = for_ m advanceFromLWW

@@ -1,19 +1,14 @@-{-# OPTIONS_GHC -Wno-orphans #-}- module CRDT.Cv.Max     ( Max (..)-    , point+    , initial     , query     ) where  import           Data.Semigroup (Max (..))-import           Data.Semilattice (Semilattice) -instance Ord a => Semilattice (Max a)- -- | Construct new value-point :: a -> Max a-point = Max+initial :: a -> Max a+initial = Max  query :: Max a -> a query = getMax

@@ -0,0 +1,48 @@+module CRDT.Cv.ORSet+    ( ORSet (..)+    , add+    , initial+    , remove+    , lookup+    ) where++import           Prelude hiding (lookup)++import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Maybe (fromMaybe)+import           Data.Semigroup (Semigroup, (<>))+import           Numeric.Natural (Natural)++import           CRDT.LamportClock (Pid, Process, getPid)+import           Data.Semilattice (Semilattice)++type Tag = (Pid, Natural)++newtype ORSet a = ORSet (Map a (Map Tag Bool))+    deriving (Eq, Show)++unpack :: ORSet a -> Map a (Map Tag Bool)+unpack (ORSet s) = s++instance Ord a => Semigroup (ORSet a) where+    ORSet s1 <> ORSet s2 = ORSet $ Map.unionWith (Map.unionWith (&&)) s1 s2++instance Ord a => Semilattice (ORSet a)++initial :: ORSet a+initial = ORSet Map.empty++add :: Ord a => a -> ORSet a -> Process (ORSet a)+add a (ORSet s) = do+    pid <- getPid+    pure $ ORSet $ Map.alter (add1 pid) a s+  where+    add1 pid = Just . add2 pid . fromMaybe Map.empty+    add2 pid tags = Map.insert (pid, fromIntegral $ length tags) True tags++remove :: Ord a => a -> ORSet a -> ORSet a+remove a (ORSet s) = ORSet $ Map.adjust (Map.map $ const False) a s++lookup :: Ord a => a -> ORSet a -> Bool+lookup e = or . fromMaybe Map.empty . Map.lookup e . unpack

@@ -0,0 +1,45 @@+module CRDT.Cv.TwoPSet+    ( TwoPSet (..)+    , add+    , initial+    , lookup+    , remove+    , singleton+    , isKnown+    ) where++import           Prelude hiding (lookup)++import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Maybe (fromMaybe)+import           Data.Semigroup (Semigroup ((<>)))++import           Data.Semilattice (Semilattice)++newtype TwoPSet a = TwoPSet (Map a Bool)+    deriving (Eq, Show)++instance Ord a => Semigroup (TwoPSet a) where+    TwoPSet m1 <> TwoPSet m2 = TwoPSet (Map.unionWith (&&) m1 m2)++instance Ord a => Semilattice (TwoPSet a)++add :: Ord a => a -> TwoPSet a -> TwoPSet a+add e (TwoPSet m) = TwoPSet (Map.insertWith (&&) e True m)++initial :: TwoPSet a+initial = TwoPSet Map.empty++lookup :: Ord a => a -> TwoPSet a -> Bool+lookup e (TwoPSet m) = fromMaybe False $ Map.lookup e m++remove :: Ord a => a -> TwoPSet a -> TwoPSet a+remove e (TwoPSet m) = TwoPSet $ Map.adjust (const False) e m++singleton :: Ord a => a -> TwoPSet a+singleton a = add a initial++-- | XXX Internal TODO remove+isKnown :: Ord a => a -> TwoPSet a -> Bool+isKnown e (TwoPSet m) = Map.member e m

@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} @@ -8,49 +7,54 @@     , initial     , assign     , query-      -- * CmRDT-    , Assign (..)+      -- * Implementation detail+    , advanceFromLWW     ) where -import           Data.Function (on) import           Data.Semigroup (Semigroup, (<>))+ import           Data.Semilattice (Semilattice)  import           CRDT.Cm (CausalOrd (..), CmRDT (..))-import           LamportClock (Clock (newTimestamp), Timestamp)+import           CRDT.LamportClock (LamportTime, Process, advance, getTime)  -- | Last write wins. Assuming timestamp is unique. -- This type is both 'CmRDT' and 'CvRDT'.+--+-- Timestamps are assumed unique, totally ordered,+-- and consistent with causal order;+-- i.e., if assignment 1 happened-before assignment 2,+-- the former’s timestamp is less than the latter’s. data LWW a = LWW-    { value     :: !a-    , timestamp :: !Timestamp+    { value :: !a+    , time  :: !LamportTime     }-    deriving (Show)+    deriving (Eq, Show)  -------------------------------------------------------------------------------- -- CvRDT ----------------------------------------------------------------------- -instance Eq (LWW a) where-    (==) = (==) `on` timestamp--instance Ord (LWW a) where-    (<=) = (<=) `on` timestamp- -- | Merge by choosing more recent timestamp.-instance Semigroup (LWW a) where-    (<>) = max+instance Eq a => Semigroup (LWW a) where+    x@(LWW xv xt) <> y@(LWW yv yt)+        | xt < yt = y+        | yt < xt = x+        | xv == yv = x+        | otherwise = error "LWW assumes timestamps to be unique"  -- | See 'CvRDT'-instance Semilattice (LWW a)+instance Eq a => Semilattice (LWW a)  -- | Initialize state-initial :: Clock f => a -> f (LWW a)-initial value = LWW value <$> newTimestamp+initial :: a -> Process (LWW a)+initial value = LWW value <$> getTime  -- | Change state as CvRDT operation. -- Current value is ignored, because new timestamp is always greater.-assign :: Clock f => a -> LWW a -> f (LWW a)-assign value _ = LWW value <$> newTimestamp+assign :: a -> LWW a -> Process (LWW a)+assign value old = do+    advanceFromLWW old+    initial value  -- | Query state query :: LWW a -> a@@ -60,19 +64,15 @@ -- CmRDT -----------------------------------------------------------------------  instance CausalOrd (LWW a) where-    before _ _ = False---- | Change state as CmRDT operation-newtype Assign a = Assign a-    deriving (Eq, Show)+    affects _ _ = False  instance Eq a => CmRDT (LWW a) where-    type Op       (LWW a) = Assign a-    type Payload  (LWW a) = LWW a-    type View     (LWW a) = a+    type Intent  (LWW a) = a+    type Payload (LWW a) = LWW a -    updateAtSource (Assign value) = LWW value <$> newTimestamp+    makeOp value = Just . assign value -    updateDownstream = (<>)+    apply = (<>) -    view = value+advanceFromLWW :: LWW a -> Process ()+advanceFromLWW LWW{time} = advance time

@@ -0,0 +1,66 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module CRDT.LamportClock+    ( Pid (..)+    -- * Lamport timestamp (for a single process)+    , LamportTime (..)+    , getTime+    , advance+    -- * Lamport clock (for a whole multi-process system)+    , LamportClock (..)+    , runLamportClock+    -- * Process+    , Process (..)+    , getPid+    , runProcess+    ) where++import           Control.Monad.Reader (ReaderT, ask, runReaderT)+import           Control.Monad.State.Strict (State, evalState, modify, state)+import           Control.Monad.Trans (lift)+import           Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import           Data.Maybe (fromMaybe)+import           Numeric.Natural (Natural)++type LocalTime = Natural++data LamportTime = LamportTime !LocalTime !Pid+    deriving (Eq, Ord, Show)++-- | Unique process identifier+newtype Pid = Pid Int+    deriving (Eq, Ord, Show)++-- | Key is 'Pid'. Non-present value is equivalent to 0.+newtype LamportClock a = LamportClock (State (IntMap LocalTime) a)+    deriving (Applicative, Functor, Monad)++newtype Process a = Process (ReaderT Pid LamportClock a)+    deriving (Applicative, Functor, Monad)++getPid :: Process Pid+getPid = Process ask++getTime :: Process LamportTime+getTime = Process $ do+    pid <- ask+    time <- lift $ preIncrementAt pid+    pure $ LamportTime time pid++runLamportClock :: LamportClock a -> a+runLamportClock (LamportClock action) = evalState action mempty++runProcess :: Pid -> Process a -> LamportClock a+runProcess pid (Process action) = runReaderT action pid++preIncrementAt :: Pid -> LamportClock LocalTime+preIncrementAt (Pid pid) =+    LamportClock . state $ \m -> let+        lt' = succ . fromMaybe 0 $ IntMap.lookup pid m+        in (lt', IntMap.insert pid lt' m)++advance :: LamportTime -> Process ()+advance (LamportTime time _) = Process $ do+    Pid pid <- ask+    lift . LamportClock . modify $ IntMap.insertWith max pid time

@@ -3,7 +3,8 @@     , merge     ) where -import           Data.Semigroup (Semigroup, (<>))+import           Data.Semigroup (Max, Semigroup, (<>))+import           Data.Set (Set)  {- | A semilattice.@@ -29,3 +30,9 @@ merge = (<>) infixr 6 `merge` {-# INLINE merge #-}++-- instances for external types++instance Ord a => Semilattice (Max a)++instance Ord a => Semilattice (Set a)

@@ -1,89 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}--module LamportClock-    ( Pid (..)-    , Time-    , Timestamp (..)-    , Clock (..)-    , LamportClock-    , runLamportClock-    , Process-    , runProcess-    , barrier-    ) where--import           Control.Arrow (first)-import           Control.Monad.Reader (ReaderT, ask, runReaderT)-import           Control.Monad.State.Strict (MonadState, State, evalState,-                                             modify, state)-import           Data.Functor (($>))-import           Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap-import           Data.Maybe (fromMaybe)--type Time = Word---- | Unique process identifier-newtype Pid = Pid Int-    deriving (Eq, Ord, Show)--unPid :: Pid -> Int-unPid (Pid pid) = pid---- | Key is 'Pid'. Non-present value is equivalent to 0.--- TODO(cblp, 2017-09-28) Use bounded-intmap-type LamportTime = IntMap Time--type LamportClock = State LamportTime---- | XXX Make sure all subsequent calls to 'newTimestamp' return timestamps--- greater than all prior calls.-barrier :: [Pid] -> LamportClock ()-barrier pids =-    modify $ \clocks -> let-        selectedClocks = lamportTimeFromList-            [(pid, fromMaybe 0 $ lamportTimeLookup pid clocks) | pid <- pids]-        in-        if null selectedClocks then-            clocks-        else-            IntMap.union-                (selectedClocks $> succ (maximum selectedClocks))-                clocks---- | Timestamps are assumed unique, totally ordered,--- and consistent with causal order;--- i.e., if assignment 1 happened-before assignment 2,--- the former’s timestamp is less than the latter’s.-data Timestamp = Timestamp !Time !Pid-    deriving (Eq, Ord, Show)--class Applicative f => Clock f where-    -- | Get another unique timestamp-    newTimestamp :: f Timestamp--type Process = ReaderT Pid LamportClock--instance Clock Process where-    newTimestamp = do-        pid <- ask-        time <- postIncrementAt pid-        pure $ Timestamp time pid--runLamportClock :: LamportClock a -> a-runLamportClock action = evalState action mempty--runProcess :: Pid -> Process a -> LamportClock a-runProcess pid action = runReaderT action pid--postIncrementAt :: MonadState LamportTime m => Pid -> m Time-postIncrementAt (Pid pid) = state $ \m ->-    let v = fromMaybe 0 $ IntMap.lookup pid m-    in  (v, IntMap.insert pid (v + 1) m)--lamportTimeFromList :: [(Pid, Time)] -> LamportTime-lamportTimeFromList = IntMap.fromList . map (first unPid)--lamportTimeLookup :: Pid -> LamportTime -> Maybe Time-lamportTimeLookup = IntMap.lookup . unPid

@@ -5,40 +5,47 @@  module ArbitraryOrphans () where -import           Test.Tasty.QuickCheck (Arbitrary (..), arbitraryBoundedEnum,-                                        oneof)+import           Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum,+                                  elements)  import           CRDT.Cm.Counter (Counter (..)) import           CRDT.Cm.GSet (GSet (..))-import           CRDT.Cm.TPSet (TPSet (..))-import qualified CRDT.Cm.TPSet as TPSet+import           CRDT.Cm.TwoPSet (TwoPSet (..))+import qualified CRDT.Cm.TwoPSet as TwoPSet+import           CRDT.Cv.ORSet (ORSet (..)) import           CRDT.Cv.GCounter (GCounter (..))+import           CRDT.Cv.LwwElementSet (LwwElementSet (..)) import           CRDT.Cv.Max (Max (..)) import           CRDT.Cv.PNCounter (PNCounter (..))-import           CRDT.LWW (Assign (..), LWW (..))-import           LamportClock (Pid (..), Timestamp (..))+import qualified CRDT.Cv.TwoPSet as Cv+import           CRDT.LamportClock (LamportTime (..), Pid (..))+import           CRDT.LWW (LWW (..))  instance Arbitrary (Counter a) where     arbitrary = arbitraryBoundedEnum -deriving instance Arbitrary a => Arbitrary (Assign a)- instance Arbitrary a => Arbitrary (LWW a) where     arbitrary = LWW <$> arbitrary <*> arbitrary  deriving instance Arbitrary a => Arbitrary (GSet a) -instance Arbitrary a => Arbitrary (TPSet a) where-    arbitrary = oneof [TPSet.Add <$> arbitrary, Remove <$> arbitrary]+instance Arbitrary a => Arbitrary (TwoPSet a) where+    arbitrary = elements [TwoPSet.Add, Remove] <*> arbitrary  deriving instance Arbitrary a => Arbitrary (GCounter a) +deriving instance (Arbitrary a, Ord a) => Arbitrary (ORSet a)++deriving instance (Arbitrary a, Ord a) => Arbitrary (LwwElementSet a)+ deriving instance Arbitrary a => Arbitrary (Max a)  instance Arbitrary a => Arbitrary (PNCounter a) where     arbitrary = PNCounter <$> arbitrary <*> arbitrary -deriving instance Arbitrary Pid+deriving instance (Ord a, Arbitrary a) => Arbitrary (Cv.TwoPSet a) -instance Arbitrary Timestamp where-    arbitrary = Timestamp <$> arbitrary <*> arbitrary+instance Arbitrary LamportTime where+    arbitrary = LamportTime <$> arbitrary <*> arbitrary++deriving instance Arbitrary Pid

@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}++{-# LANGUAGE TypeApplications #-}++module Cm.TwoPSet where++import           CRDT.Cm.TwoPSet (TwoPSet)++import           Laws (cmrdtLaw)++prop_Cm = cmrdtLaw @(TwoPSet Char)++-- prop_add =

@@ -1,13 +1,11 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+ {-# LANGUAGE TypeApplications #-} -module Counter-    ( counter-    ) where+module Counter where  import           CRDT.Cm.Counter (Counter)-import           Test.Tasty (TestTree, testGroup)  import           Laws (cmrdtLaw) -counter :: TestTree-counter = testGroup "Counter" [cmrdtLaw @(Counter Int)]+prop_Cm = cmrdtLaw @(Counter Int)

@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Cv.TwoPSet where++import           Prelude hiding (lookup)++import           Test.QuickCheck ((==>))++import           CRDT.Cv.TwoPSet (TwoPSet (..), add, isKnown, lookup, remove)++import           Laws (cvrdtLaws)++-- | Difference from LwwElementSet and ORSet -- removal bias+prop_removal_bias (s :: TwoPSet Char) x =+    not . lookup x . add x . remove x $ add x s++prop_add (s :: TwoPSet Char) x = not (isKnown x s) ==> lookup x (add x s)++prop_remove (s :: TwoPSet Char) x = not . lookup x $ remove x s++prop_add_then_remove (s :: TwoPSet Char) x =+    not . lookup x . remove x $ add x s++test_Cv = cvrdtLaws @(TwoPSet Char) Nothing

@@ -1,21 +1,17 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module GCounter-    ( gCounter-    ) where+module GCounter where -import           Test.Tasty (TestTree, testGroup)-import           Test.Tasty.QuickCheck (testProperty)+import           Test.QuickCheck ((===))  import           CRDT.Cv.GCounter (GCounter (..), increment, query)  import           Laws (cvrdtLaws) -gCounter :: TestTree-gCounter = testGroup "GCounter"-    [ cvrdtLaws @(GCounter Int)-    , testProperty "increment" $-        \(counter :: GCounter Int) i ->-            query (increment i counter) == succ (query counter)-    ]+test_Cv = cvrdtLaws @(GCounter Int) Nothing++prop_increment (counter :: GCounter Int) pid =+    query (increment pid counter) === succ (query counter)

@@ -1,22 +1,17 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module GSet-    ( gSet-    ) where--import           Test.Tasty (TestTree, testGroup)-import           Test.Tasty.QuickCheck (testProperty, (==>))+module GSet where  import qualified CRDT.Cm.GSet as Cm import qualified CRDT.Cv.GSet as Cv  import           Laws (cmrdtLaw, cvrdtLaws) -gSet :: TestTree-gSet = testGroup "GSet"-    [ cmrdtLaw @(Cm.GSet Int)-    , cvrdtLaws @(Cv.GSet Int)-    , testProperty "Cv.add" $ \(set :: Cv.GSet Int) i ->-        not (Cv.query i set) ==> Cv.query i (Cv.add i set)-    ]+prop_Cm = cmrdtLaw @(Cm.GSet Char)++test_Cv = cvrdtLaws @(Cv.GSet Char) Nothing++prop_add (x :: Char) = Cv.lookup x . Cv.add x

@@ -1,37 +1,44 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module LWW (lww) where+module LWW+    ( genUniquelyTimedLWW+    , prop_Cm+    , prop_assign+    , prop_merge_with_former+    , test_Cv+    ) where +import           Control.Monad.State.Strict (StateT, lift) import           Data.Semigroup ((<>))-import           Test.Tasty (TestTree, testGroup)-import           Test.Tasty.QuickCheck (testProperty)+import           Data.Set (Set)+import qualified Data.Set as Set+import           Test.QuickCheck (Arbitrary, Gen, arbitrary, (===)) -import           CRDT.LWW (LWW (..), assign, initial, query)-import           LamportClock (barrier, runLamportClock, runProcess)+import           CRDT.LamportClock (LamportTime, runLamportClock, runProcess)+import           CRDT.LWW (LWW (LWW), assign, initial, query)  import           Laws (cmrdtLaw, cvrdtLaws)+import           QCUtil (genUnique) -lww :: TestTree-lww = testGroup "LWW"-    [ cmrdtLaw @(LWW Int)-    , testGroup "Cv"-        [ cvrdtLaws @(LWW Int)-        , testProperty "assign" $-            \pid1 pid2 (formerValue :: Int) latterValue ->-                runLamportClock $ do-                    state1 <- runProcess pid1 $ initial formerValue-                    barrier [pid1, pid2]-                    state2 <- runProcess pid2 $ assign latterValue state1-                    pure $ query state2 == latterValue-        , testProperty "merge with former" $-            \pid1 pid2 (formerValue :: Int) latterValue ->-                runLamportClock $ do-                    state1 <- runProcess pid1 $ initial formerValue-                    barrier [pid1, pid2]-                    state2 <- runProcess pid2 $ initial latterValue-                    pure $ query (state1 <> state2) == latterValue-        ]-    ]+prop_Cm = cmrdtLaw @(LWW Char)++test_Cv = cvrdtLaws @(LWW Char) $ Just (genUniquelyTimedLWW, Set.empty)++prop_assign pid1 pid2 (formerValue :: Char) latterValue = runLamportClock $ do+    state1 <- runProcess pid1 $ initial formerValue+    state2 <- runProcess pid2 $ assign latterValue state1+    pure $ query state2 === latterValue++prop_merge_with_former pid1 pid2 (formerValue :: Char) latterValue =+    runLamportClock $ do+        state1 <- runProcess pid1 $ initial formerValue+        state2 <- runProcess pid2 $ assign latterValue state1+        pure $ query (state1 <> state2) === latterValue++-- | Generate specified number of 'LWW' with unique timestamps+genUniquelyTimedLWW :: Arbitrary a => StateT (Set LamportTime) Gen (LWW a)+genUniquelyTimedLWW = LWW <$> lift arbitrary <*> genUnique

@@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -9,57 +9,80 @@     , cvrdtLaws     ) where -import           Control.Monad (unless)-import           Data.Function ((&))+import           Control.Monad.State.Strict (StateT, evalStateT) import           Data.Semigroup (Semigroup, (<>))-import           Data.Semilattice (Semilattice, merge)-import           Test.Tasty (TestTree, testGroup)-import           Test.Tasty.QuickCheck (Arbitrary (..), discard, testProperty,-                                        (===), (==>))+import           Test.QuickCheck (Arbitrary (..), Gen, Property, discard,+                                  forAll, property, (===), (==>))+import           Test.Tasty (TestTree)+import           Test.Tasty.QuickCheck (testProperty)  import           CRDT.Cm (CmRDT (..), concurrent) import           CRDT.Cv (CvRDT)-import           LamportClock (Clock, runLamportClock, runProcess)+import           CRDT.LamportClock (runLamportClock, runProcess)+import           Data.Semilattice (Semilattice, merge)  import           ArbitraryOrphans () -semigroupLaw :: forall a . (Arbitrary a, Semigroup a, Eq a, Show a) => TestTree-semigroupLaw =-    testGroup "Semigroup law" [testProperty "associativity" associativity]+gen2 :: (StateT s Gen a, s) -> Gen (a, a)+gen2 (gen, start) = evalStateT ((,) <$> gen <*> gen) start++gen3 :: (StateT s Gen a, s) -> Gen (a, a, a)+gen3 (gen, start) = evalStateT ((,,) <$> gen <*> gen <*> gen) start++semigroupLaw+    :: forall a+    . (Arbitrary a, Semigroup a, Eq a, Show a)+    => Maybe (Gen (a, a, a)) -> TestTree+semigroupLaw mgen = testProperty "associativity" $ associativity' mgen   where-    associativity (x, y, z :: a) = (x <> y) <> z == x <> (y <> z)+    associativity x y (z :: a) = (x <> y) <> z === x <> (y <> z)+    associativity' = \case+        Nothing  -> property associativity+        Just gen -> forAll gen $ uncurry3 associativity  semilatticeLaws-    :: forall a . (Arbitrary a, Semilattice a, Eq a, Show a) => TestTree-semilatticeLaws = testGroup "Semilattice laws"-    [ semigroupLaw @a-    , testProperty "commutativity" commutativity+    :: forall a s+    . (Arbitrary a, Semilattice a, Eq a, Show a)+    => Maybe (StateT s Gen a, s) -> [TestTree]+semilatticeLaws mgen =+    [ semigroupLaw $ gen3 <$> mgen+    , testProperty "commutativity" $ commutativity' $ gen2 <$> mgen     , testProperty "idempotency"   idempotency     ]   where-    commutativity (x, y :: a) = x `merge` y === y `merge` x     idempotency (x :: a) = x `merge` x === x+    commutativity x (y :: a) = x `merge` y === y `merge` x+    commutativity' = \case+        Nothing  -> property commutativity+        Just gen -> forAll gen $ uncurry commutativity -cvrdtLaws :: forall a . (Arbitrary a, CvRDT a, Eq a, Show a) => TestTree-cvrdtLaws = semilatticeLaws @a+cvrdtLaws+    :: forall a s+    . (Arbitrary a, CvRDT a, Eq a, Show a)+    => Maybe (StateT s Gen a, s) -> [TestTree]+cvrdtLaws = semilatticeLaws +-- | CmRDT law: concurrent ops commute cmrdtLaw-    :: forall u-    . ( CmRDT u-      , Arbitrary (Op u), Show (Op u)-      , Arbitrary (Payload u), Show (Payload u)-      , Show (View u)-      )-    => TestTree-cmrdtLaw = testProperty "CmRDT law: concurrent ops commute" $-    \pid (state0 :: Payload u) (op1, op2 :: Op u) ->-        runLamportClock $ runProcess pid $ do-            up1 <- updateAtSourceIfCan op1 state0-            up2 <- updateAtSourceIfCan op2 state0-            let state12 = state0 & updateDownstream up1 & updateDownstream up2-            let state21 = state0 & updateDownstream up2 & updateDownstream up1-            pure $ concurrent up1 up2 ==> view @u state12 === view @u state21+    :: forall op.+    ( CmRDT op+    , Arbitrary op, Show op+    , Arbitrary (Intent op), Show (Intent op)+    , Arbitrary (Payload op), Show (Payload op)+    )+    => Property+cmrdtLaw = property $ \(s :: Payload op) in1 in2 pid1 pid2 ->+    whenJust (makeOp @op in1 s) $ \getOp1 ->+    whenJust (makeOp @op in2 s) $ \getOp2 -> let+        (op1, op2) =+            runLamportClock $+            (,) <$> runProcess pid1 getOp1 <*> runProcess pid2 getOp2+        in+        concurrent op1 op2 ==>+            (apply op1 . apply op2) s === (apply op2 . apply op1) s   where-    updateAtSourceIfCan :: Clock m => Op u -> Payload u -> m u-    updateAtSourceIfCan op state =-        unless (updateAtSourcePre @u op state) discard *> updateAtSource op+    whenJust Nothing  _ = discard+    whenJust (Just a) f = f a++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c

@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module LwwElementSet+    ( prop_add+    , prop_no_removal_bias+    , prop_remove+    , prop_they_accidentally_delete_our_value+    , test_Cv+    ) where++import           Prelude hiding (lookup)++import           Control.Monad (replicateM)+import           Control.Monad.State.Strict (StateT, lift)+import qualified Data.Map.Strict as Map+import           Data.Semigroup ((<>))+import           Data.Set (Set)+import qualified Data.Set as Set+import           Test.QuickCheck (Arbitrary, Gen, arbitrary)++import           CRDT.Cv.LwwElementSet (LwwElementSet (..), add, lookup, remove)+import           CRDT.LamportClock (LamportTime, runLamportClock, runProcess)++import           Laws (cvrdtLaws)+import           LWW (genUniquelyTimedLWW)++test_Cv =+    cvrdtLaws @(LwwElementSet Char) $ Just (genUniquelyTimedLES, Set.empty)++-- | Generate specified number of 'LWW' with unique timestamps+genUniquelyTimedLES+    :: (Arbitrary a, Ord a) => StateT (Set LamportTime) Gen (LwwElementSet a)+genUniquelyTimedLES = do+    values <- lift arbitrary+    tags <- replicateM (length values) genUniquelyTimedLWW+    pure $ LES $ Map.fromList $ zip values tags++prop_add (s :: LwwElementSet Char) x pid1 =+    runLamportClock $ do+        s1 <- runProcess pid1 $ add x s+        pure $ lookup x s1++prop_remove (s :: LwwElementSet Char) x pid1 pid2 =+    runLamportClock $ do+        s1 <- runProcess pid1 $ add x s+        s2 <- runProcess pid2 $ remove x s1+        pure . not $ lookup x s2++-- | Difference from 'TwoPSet' -- no removal bias+prop_no_removal_bias (s :: LwwElementSet Char) x pid1 pid2 pid3 =+    runLamportClock $ do+        s1 <- runProcess pid1 $ add x s+        s2 <- runProcess pid2 $ remove x s1+        s3 <- runProcess pid3 $ add x s2+        pure $ lookup x s3++-- | Difference from 'ORSet' -- other replica can accidentally delete x+prop_they_accidentally_delete_our_value (s :: LwwElementSet Char) x pid1 pid2 =+    runLamportClock $ do+        s1 <- runProcess pid1 $ add x s+        s2 <- runProcess pid2 $ remove x =<< add x s+        pure . not . lookup x $ s1 <> s2

@@ -1,13 +1,1 @@-import           Test.Tasty (defaultMain, testGroup)--import           Counter (counter)-import           GCounter (gCounter)-import           GSet (gSet)-import           LWW (lww)-import           Max (maxTest)-import           PNCounter (pnCounter)-import           TPSet (tpSet)--main :: IO ()-main = defaultMain $-    testGroup "" [counter, gCounter, gSet, lww, maxTest, pnCounter, tpSet]+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}

@@ -1,23 +1,17 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Max-    ( maxTest-    ) where+module Max where -import           Test.Tasty (TestTree, testGroup)-import           Test.Tasty.QuickCheck (testProperty)+import           Test.QuickCheck ((===)) -import           CRDT.Cv.Max (Max, point, query)+import           CRDT.Cv.Max (Max, initial, query) import           Data.Semilattice (merge)  import           Laws (cvrdtLaws) -maxTest :: TestTree-maxTest = testGroup "Max"-    [ testGroup "Cv"-        [ cvrdtLaws @(Max Int)-        , testProperty "merge" $-            \(m :: Max Int) i -> query (point i `merge` m) == max i (query m)-        ]-    ]+test_Cv = cvrdtLaws @(Max Char) Nothing++prop_merge (x :: Char) y = query (initial x `merge` initial y) === max x y

@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module ORSet where++import           Prelude hiding (lookup)++import           Data.Semigroup (Semigroup ((<>)))++import           CRDT.Cv.ORSet (ORSet (..), add, lookup, remove)+import           CRDT.LamportClock (runLamportClock, runProcess)++import           Laws (cvrdtLaws)++test_Cv = cvrdtLaws @(ORSet Int) Nothing++prop_add pid (x :: Char) s =+    runLamportClock $ runProcess pid $ not . lookup x . remove x <$> add x s++-- | Difference from 'LwwElementSet' --+-- other replica can not accidentally delete x+prop_add_merge (x :: Char) pid s1 s0 =+    runLamportClock $ runProcess pid $ lookup x . (<> s1) <$> add x s0

@@ -1,25 +1,21 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module PNCounter-    ( pnCounter-    ) where+module PNCounter where -import           Test.Tasty (TestTree, testGroup)-import           Test.Tasty.QuickCheck (testProperty)+import           Test.QuickCheck ((===))  import           CRDT.Cv.PNCounter (PNCounter (..), decrement, increment, query)  import           GCounter () import           Laws (cvrdtLaws) -pnCounter :: TestTree-pnCounter = testGroup "PNCounter"-    [ cvrdtLaws @(PNCounter Int)-    , testProperty "increment" $-        \(counter :: PNCounter Int) i ->-            query (increment i counter) == succ (query counter)-    , testProperty "decrement" $-        \(counter :: PNCounter Int) i ->-            query (decrement i counter) == pred (query counter)-    ]+test_Cv = cvrdtLaws @(PNCounter Int) Nothing++prop_increment (counter :: PNCounter Int) pid =+    query (increment pid counter) === succ (query counter)++prop_decrement (counter :: PNCounter Int) pid =+    query (decrement pid counter) === pred (query counter)

@@ -0,0 +1,15 @@+module QCUtil+    ( genUnique+    ) where++import           Control.Monad.State.Strict (StateT, get, lift, modify)+import           Data.Set (Set)+import qualified Data.Set as Set+import           Test.QuickCheck (Arbitrary, Gen, arbitrary, suchThat)++genUnique :: (Arbitrary a, Ord a) => StateT (Set a) Gen a+genUnique = do+    used <- get+    a <- lift $ arbitrary `suchThat` (`Set.notMember` used)+    modify $ Set.insert a+    pure a

@@ -1,13 +0,0 @@-{-# LANGUAGE TypeApplications #-}--module TPSet-    ( tpSet-    ) where--import           CRDT.Cm.TPSet (TPSet)-import           Test.Tasty (TestTree, testGroup)--import           Laws (cmrdtLaw)--tpSet :: TestTree-tpSet = testGroup "TPSet" [cmrdtLaw @(TPSet Int)]