crdt 9.0 → 9.1
raw patch · 23 files changed
+105/−859 lines, 23 filesdep +faildep +semigroupsdep +transformersdep −QuickCheckdep −QuickCheck-GenTdep −crdtdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: fail, semigroups, transformers
Dependencies removed: QuickCheck, QuickCheck-GenT, crdt, quickcheck-instances, tasty, tasty-discover, tasty-quickcheck
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- crdt.cabal +66/−96
- lib/CRDT/Cm.hs +9/−5
- lib/CRDT/LWW.hs +12/−1
- lib/CRDT/LamportClock.hs +0/−1
- lib/CRDT/LamportClock/Simulation.hs +7/−1
- lib/Compat.hs +11/−0
- test/ArbitraryOrphans.hs +0/−102
- test/Cm/ORSet.hs +0/−47
- test/Cm/RGA.hs +0/−130
- test/Cm/TwoPSet.hs +0/−19
- test/Counter.hs +0/−11
- test/Cv/ORSet.hs +0/−29
- test/Cv/RGA.hs +0/−54
- test/Cv/TwoPSet.hs +0/−25
- test/GCounter.hs +0/−17
- test/GSet.hs +0/−17
- test/LWW.hs +0/−38
- test/Laws.hs +0/−148
- test/LwwElementSet.hs +0/−56
- test/Main.hs +0/−1
- test/Max.hs +0/−17
- test/PNCounter.hs +0/−21
- test/Util.hs +0/−23
crdt.cabal view
@@ -1,101 +1,71 @@--- This file has been generated from package.yaml by hpack version 0.20.0.------ see: https://github.com/sol/hpack------ hash: 6b85645aa899cb940c1bf1caed7e902da66f4dd6c35c35fad4c33443f5606138--name: crdt-version: 9.0-synopsis: Conflict-free replicated data types-description: Definitions of CmRDT and CvRDT. Implementations for some classic CRDTs.-category: Distributed Systems-homepage: https://github.com/cblp/crdt#readme-bug-reports: https://github.com/cblp/crdt/issues-maintainer: Yuriy Syrovetskiy <cblp@cblp.su>-copyright: 2017 Yuriy Syrovetskiy, Nikolay Loginov; 2018 Yuriy Syrovetskiy-license: BSD3-license-file: LICENSE-build-type: Simple-cabal-version: >= 1.10+name: crdt+version: 9.1+ -- ^ ComVer+category: Distributed Systems+copyright:+ 2017 Yuriy Syrovetskiy, Nikolay Loginov;+ 2018 Yuriy Syrovetskiy+maintainer: Yuriy Syrovetskiy <cblp@cblp.su>+license: BSD3+license-file: LICENSE+synopsis: Conflict-free replicated data types+description:+ Definitions of CmRDT and CvRDT. Implementations for some classic CRDTs.+homepage: https://github.com/cblp/crdt#readme+bug-reports: https://github.com/cblp/crdt/issues+cabal-version: >= 1.10+build-type: Simple source-repository head- type: git- location: https://github.com/cblp/crdt+ type: git+ location: https://github.com/cblp/crdt.git +flag Cm+ description: Include commutative types+ default: True+ library- hs-source-dirs:- lib- build-depends:- Diff- , base >=4.9 && <4.11- , binary- , bytestring- , containers- , hashable- , mtl- , network-info- , safe- , stm- , time- , vector- exposed-modules:- CRDT.Cm- CRDT.Cm.Counter- CRDT.Cm.GSet- CRDT.Cm.ORSet- CRDT.Cm.RGA- 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.RGA- CRDT.Cv.TwoPSet- CRDT.LamportClock- CRDT.LamportClock.Simulation- CRDT.LWW- Data.MultiMap- Data.Semilattice- other-modules:- Paths_crdt- default-language: Haskell2010+ hs-source-dirs: lib+ build-depends: base >= 4.8 && < 4.11+ , binary+ , bytestring+ , containers+ , Diff+ , hashable+ , mtl+ , network-info+ , safe+ , stm+ , time+ , vector+ exposed-modules: CRDT.Cv+ CRDT.Cv.GCounter+ CRDT.Cv.GSet+ CRDT.Cv.LwwElementSet+ CRDT.Cv.Max+ CRDT.Cv.ORSet+ CRDT.Cv.PNCounter+ CRDT.Cv.RGA+ CRDT.Cv.TwoPSet+ CRDT.LamportClock+ CRDT.LamportClock.Simulation+ CRDT.LWW+ Data.MultiMap+ Data.Semilattice+ if flag(Cm)+ cpp-options: -DENABLE_CM=1+ exposed-modules: CRDT.Cm+ CRDT.Cm.Counter+ CRDT.Cm.GSet+ CRDT.Cm.ORSet+ CRDT.Cm.RGA+ CRDT.Cm.TwoPSet+ default-language: Haskell2010 -test-suite test- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs:- test- build-depends:- QuickCheck- , QuickCheck-GenT- , base >=4.9 && <4.11- , containers- , crdt- , mtl- , quickcheck-instances- , tasty- , tasty-discover >=4.1- , tasty-quickcheck- , vector- other-modules:- ArbitraryOrphans- Cm.ORSet- Cm.RGA- Cm.TwoPSet- Counter- Cv.ORSet- Cv.RGA- Cv.TwoPSet- GCounter- GSet- Laws- LWW- LwwElementSet- Max- PNCounter- Util- Paths_crdt- default-language: Haskell2010+ if impl(ghc >= 8)+ default-extensions: StrictData+ else+ build-depends: fail+ , semigroups+ , transformers+ other-modules: Compat
lib/CRDT/Cm.hs view
@@ -91,17 +91,18 @@ -- We must make a test for it first. apply :: op -> Payload op -> Payload op -query :: forall op f. (CmRDT op, Foldable f) => f op -> Payload op+query :: forall op f . (CmRDT op, Foldable f) => f op -> Payload op query = foldl (flip apply) (initial @op) -- | Make op and apply it to the payload -- a common routine at the source node. makeAndApplyOp :: (CmRDT op, Clock m, MonadFail m, MonadState (Payload op) m)- => Intent op -> m op+ => Intent op+ -> m op makeAndApplyOp intent = do payload <- get case makeOp intent payload of- Nothing -> fail "precodition failed"+ Nothing -> fail "precodition failed" Just opAction -> do op <- opAction modify $ apply op@@ -109,8 +110,11 @@ makeAndApplyOps :: ( CmRDT op- , Clock m, MonadFail m, MonadState (Payload op) m+ , Clock m+ , MonadFail m+ , MonadState (Payload op) m , Traversable f )- => f (Intent op) -> m (f op)+ => f (Intent op)+ -> m (f op) makeAndApplyOps = traverse makeAndApplyOp
lib/CRDT/LWW.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} +#if ENABLE_CM+{-# LANGUAGE LambdaCase #-}+#endif /* ENABLE_CM */+ module CRDT.LWW ( LWW (..) -- * CvRDT@@ -16,7 +20,10 @@ import Data.Semilattice (Semilattice) +#if ENABLE_CM import CRDT.Cm (CausalOrd (..), CmRDT (..))+#endif /* ENABLE_CM */+ import CRDT.LamportClock (Clock, LamportTime (LamportTime), advance, getTime) @@ -65,6 +72,8 @@ -------------------------------------------------------------------------------- -- CmRDT ----------------------------------------------------------------------- +#if ENABLE_CM+ instance CausalOrd (LWW a) where precedes _ _ = False @@ -81,6 +90,8 @@ apply op = Just . \case Just payload -> op <> payload Nothing -> op++#endif /* ENABLE_CM */ advanceFromLWW :: Clock m => LWW a -> m () advanceFromLWW LWW{time = LamportTime time _} = advance time
lib/CRDT/LamportClock.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE StrictData #-} module CRDT.LamportClock ( Pid (..)
lib/CRDT/LamportClock/Simulation.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}@@ -19,7 +20,8 @@ import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)-import Control.Monad.Fail (MonadFail, fail)+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail as Fail import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.State.Strict (StateT, evalState, evalStateT, modify, state)@@ -34,6 +36,10 @@ import CRDT.LamportClock (Clock, LamportTime (LamportTime), LocalTime, Pid (Pid), Process, advance, getPid, getTimes)++#if __GLASGOW_HASKELL__ < 800+import Compat ()+#endif /* __GLASGOW_HASKELL__ < 800 */ -- | Lamport clock simulation. Key is 'Pid'. -- Non-present value is equivalent to (0, initial).
+ lib/Compat.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Compat where++import Prelude hiding (fail)++import Control.Monad.Fail (MonadFail, fail)+import Control.Monad.Reader (ReaderT, lift)++instance MonadFail m => MonadFail (ReaderT r m) where+ fail = lift . fail
− test/ArbitraryOrphans.hs
@@ -1,102 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}--{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE StandaloneDeriving #-}--module ArbitraryOrphans () where--import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum,- elements, frequency, oneof)-import Test.QuickCheck.Gen (Gen (MkGen))-import Test.QuickCheck.Instances ()-import Test.QuickCheck.Random (mkQCGen)--import CRDT.Cm.Counter (Counter (..))-import CRDT.Cm.GSet (GSet (..))-import qualified CRDT.Cm.ORSet as CmORSet-import qualified CRDT.Cm.RGA as CmRGA-import qualified CRDT.Cm.TwoPSet as CmTwoPSet-import CRDT.Cv.GCounter (GCounter (..))-import CRDT.Cv.LwwElementSet (LwwElementSet (..))-import qualified CRDT.Cv.ORSet as CvORSet-import CRDT.Cv.PNCounter (PNCounter (..))-import qualified CRDT.Cv.RGA as CvRGA-import qualified CRDT.Cv.TwoPSet as CvTwoPSet-import CRDT.LamportClock (LamportTime (..), Pid (..))-import CRDT.LWW (LWW (..))-import Data.MultiMap (MultiMap (..))--import Util (pattern (:-))--instance Arbitrary (Counter a) where- arbitrary = arbitraryBoundedEnum--instance Arbitrary a => Arbitrary (LWW a) where- arbitrary = do- time <- arbitrary- value <- seeded (hash time) arbitrary- pure LWW{value, time}- where- hash (LamportTime t (Pid p)) = fromIntegral t * 997 + fromIntegral p--deriving instance Arbitrary a => Arbitrary (GSet a)--deriving instance- (Arbitrary k, Ord k, Arbitrary v, Ord v) => Arbitrary (MultiMap k v)--instance Arbitrary a => Arbitrary (CmORSet.Intent a) where- arbitrary = elements [CmORSet.Add, CmORSet.Remove] <*> arbitrary--instance Arbitrary a => Arbitrary (CmORSet.ORSet a) where- arbitrary = oneof- [ CmORSet.OpAdd <$> arbitrary <*> arbitrary- , CmORSet.OpRemove <$> arbitrary <*> arbitrary- ]--instance (Arbitrary a, Ord a) => Arbitrary (CmORSet.Payload a) where- arbitrary = CmORSet.Payload <$> arbitrary <*> arbitrary--instance Arbitrary CmORSet.Tag where- arbitrary = CmORSet.Tag <$> arbitrary <*> arbitrary--instance Arbitrary a => Arbitrary (CmRGA.RGA a) where- arbitrary = oneof- [ CmRGA.OpAddAfter <$> arbitrary <*> arbitrary <*> arbitrary- , CmRGA.OpRemove <$> arbitrary- ]--instance Arbitrary a => Arbitrary (CmRGA.RgaIntent a) where- arbitrary = frequency- [ 10 :- CmRGA.AddAfter <$> arbitrary <*> arbitrary- , 1 :- CmRGA.Remove <$> arbitrary- ]--instance (Arbitrary a, Ord a) => Arbitrary (CmRGA.RgaPayload a) where- arbitrary = CmRGA.load <$> arbitrary--instance Arbitrary a => Arbitrary (CmTwoPSet.TwoPSet a) where- arbitrary = elements [CmTwoPSet.Add, CmTwoPSet.Remove] <*> arbitrary--deriving instance Arbitrary a => Arbitrary (GCounter a)--deriving instance (Arbitrary a, Ord a) => Arbitrary (CvORSet.ORSet a)--deriving instance (Arbitrary a, Ord a) => Arbitrary (LwwElementSet a)--instance Arbitrary a => Arbitrary (PNCounter a) where- arbitrary = PNCounter <$> arbitrary <*> arbitrary--deriving instance Arbitrary a => Arbitrary (CvRGA.RGA a)--deriving instance (Ord a, Arbitrary a) => Arbitrary (CvTwoPSet.TwoPSet a)--instance Arbitrary LamportTime where- arbitrary = LamportTime <$> arbitrary <*> arbitrary--deriving instance Arbitrary Pid---- | Generate deterministically-seeded :: Int -> Gen a -> Gen a-seeded s (MkGen g) = MkGen $ \_ n -> g (mkQCGen s) n
− test/Cm/ORSet.hs
@@ -1,47 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module Cm.ORSet where--import Control.Monad.State.Strict (evalStateT)-import qualified Data.MultiMap as MultiMap-import Test.QuickCheck (counterexample, (.&&.), (===), (==>))--import CRDT.Cm (initial, makeAndApplyOp, query)-import CRDT.Cm.ORSet (Intent (Add, Remove), ORSet, Tag (Tag),- elements)-import CRDT.LamportClock.Simulation (runLamportClockSim,- runProcessSim)--import Laws (cmrdtLaw)-import Util (pattern (:-), expectRight)--prop_Cm = cmrdtLaw @(ORSet Char)---- | Example from fig. 14 from "A comprehensive study of CRDTs"-prop_fig14 α β a = expectRight . runLamportClockSim $ do- op1 <- runProcessSim β . eval . makeAndApplyOp $ Add (a :: Char)- (op2, op3) <- runProcessSim α . eval $- (,) <$> makeAndApplyOp (Add a)- <*> makeAndApplyOp (Remove a)- pure $- α < β ==>- check "2" [op2] [a :- [Tag α 0]] .&&.- check "23" [op2, op3] [] .&&.- check "231" [op2, op3, op1] [a :- [Tag β 0]] .&&.- check "1" [op1] [a :- [Tag β 0]] .&&.- check "12" [op1, op2] [a :- [Tag α 0, Tag β 0]] .&&.- check "123" [op1, op2, op3] [a :- [Tag β 0]]- where- check opsLabel ops result =- counterexample ("ops = " ++ opsLabel) $- counterexample ("ops = " ++ show ops) $- query' ops === result- eval = (`evalStateT` initial @(ORSet Char))--query' :: (Ord a, Foldable f) => f (ORSet a) -> [(a, [Tag])]-query' = MultiMap.assocs . elements . query
− test/Cm/RGA.hs
@@ -1,130 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeApplications #-}--module Cm.RGA where--import Prelude hiding (fail)--import Control.Monad.State.Strict (execStateT, runStateT)-import Data.Foldable (toList)-import qualified Data.Map.Strict as Map-import Data.Maybe (isJust)-import qualified Data.Vector as Vector-import Test.QuickCheck (Property, conjoin, counterexample, (.&&.),- (===))--import CRDT.Cm (apply, initial, makeAndApplyOp, makeOp)-import CRDT.Cm.RGA (RGA (OpAddAfter, OpRemove), RgaIntent (AddAfter),- RgaPayload (RgaPayload), fromString, load,- toString)-import CRDT.LamportClock (LamportTime (LamportTime), Pid (Pid),- advance)-import CRDT.LamportClock.Simulation (ProcessSim, runLamportClockSim,- runProcessSim)--import Laws (cmrdtLaw)-import Util (pattern (:-), expectRightK, fail, ok)--prop_makeOp = isJust $ makeOp @(RGA Char) @ProcessSim- (AddAfter Nothing 'a')- (initial @(RGA Char))--prop_makeAndApplyOp = conjoin- [ counterexample "result3" $ expectRightK result3 $ \(op, payload) ->- counterexample ("op = " ++ show op) (opsEqWoTime op op3)- .&&. counterexample "payload" (payloadsEqWoTime payload payload3)- , counterexample "result2" $ expectRightK result2 $ \(op, payload) ->- counterexample ("op = " ++ show op) (opsEqWoTime op op2)- .&&. counterexample "payload" (payloadsEqWoTime payload payload2)- , counterexample "result1" $ expectRightK result1 $ \(op, payload) ->- counterexample ("op = " ++ show op) (opsEqWoTime op op1)- .&&. counterexample "payload" (payloadsEqWoTime payload payload1)- , counterexample "result12" $ result12 === payload12- , counterexample "results=" $ result21 === result12- ]- where- time1 = LamportTime 4 $ Pid 1 -- TODO(cblp, 2018-02-11) arbitrary pids- time2 = LamportTime 4 $ Pid 2- time3 = LamportTime 3 $ Pid 3- op1 = OpAddAfter Nothing '1' time1- op2 = OpAddAfter Nothing '2' time2- op3 = OpAddAfter Nothing '3' time3- payload3 = load $ Vector.singleton (time3 :- Just '3')- payload1 = load $ Vector.fromList [time1 :- Just '1', time3 :- Just '3']- payload2 = load $ Vector.fromList [time2 :- Just '2', time3 :- Just '3']- payload12 = load $ Vector.fromList- [time2 :- Just '2', time1 :- Just '1', time3 :- Just '3']- result3 =- runLamportClockSim- . runProcessSim (Pid 3)- . (`runStateT` initial @(RGA Char))- $ do- advance 2- makeAndApplyOp @(RGA Char) (AddAfter Nothing '3')- result2 =- runLamportClockSim . runProcessSim (Pid 2) . (`runStateT` payload3) $ do- advance 1- makeAndApplyOp @(RGA Char) (AddAfter Nothing '2')- result1 =- runLamportClockSim- . runProcessSim (Pid 1)- . (`runStateT` payload3)- $ makeAndApplyOp @(RGA Char) (AddAfter Nothing '1')- result12 = apply op2 payload1- result21 = apply op1 payload2--prop_fromString s pid =- expectRightK result $ payloadsEqWoTime $ load $ Vector.fromList- [ LamportTime t pid :- Just c | t <- [1..] | c <- s ]- where- result =- runLamportClockSim- . runProcessSim pid- . (`execStateT` initial @(RGA Char))- $ fromString s--prop_fromString_toString s pid = expectRightK result $ \s' -> toString s' === s- where- result =- runLamportClockSim- . runProcessSim pid- . (`execStateT` initial @(RGA Char))- $ fromString s--prop_Cm = cmrdtLaw @(RGA Char)---- | Ops equal without local times-opsEqWoTime (OpAddAfter parent1 atom1 id1) (OpAddAfter parent2 atom2 id2) =- conjoin- [ counterexample "parent" $ pidsMaybeEq parent1 parent2- , counterexample "atom" $ atom1 === atom2- , counterexample "id" $ pidsEqWoTime id1 id2- ]-opsEqWoTime (OpRemove parent1) (OpRemove parent2) =- counterexample "parent" $ pidsEqWoTime parent1 parent2-opsEqWoTime x y = fail $ show x ++ " /= " ++ show y--pidsEqWoTime (LamportTime _ pid1) (LamportTime _ pid2) = pid1 === pid2--pidsMaybeEq Nothing Nothing = ok-pidsMaybeEq (Just x) (Just y) = pidsEqWoTime x y-pidsMaybeEq x y = fail $ show x ++ " /= " ++ show y--payloadsEqWoTime :: (Eq a, Show a) => RgaPayload a -> RgaPayload a -> Property-payloadsEqWoTime (RgaPayload vertices1 vertexIxs1) (RgaPayload vertices2 vertexIxs2)- = conjoin- [ counterexample "vertices" $ conjoin- [ counterexample ("[" ++ show i ++ "]")- $ counterexample "id" (pidsEqWoTime id1 id2)- .&&. counterexample "atom" (a1 === a2)- | i <- [0 :: Int ..] | (id1, a1) <- toList vertices1 | (id2, a2) <- toList vertices2- ]- , counterexample "vertexIxs" $ conjoin- [ counterexample "id" (pidsEqWoTime id1 id2)- .&&. counterexample "ix" (ix1 === ix2)- | (id1, ix1) <- Map.assocs vertexIxs1 | (id2, ix2) <- Map.assocs vertexIxs2- ]- ]
− test/Cm/TwoPSet.hs
@@ -1,19 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE TypeApplications #-}--module Cm.TwoPSet where--import Test.QuickCheck (Small)--import CRDT.Cm.TwoPSet (TwoPSet (Remove))--import Laws (cmrdtLaw, opCommutativity)--prop_Cm = cmrdtLaw @(TwoPSet Char)--prop_remove_commutes_with_itself e = opCommutativity intentOp intentOp- where- intent = Remove (e :: Small Int)- op = intent- intentOp = (intent, op)
− test/Counter.hs
@@ -1,11 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE TypeApplications #-}--module Counter where--import CRDT.Cm.Counter (Counter)--import Laws (cmrdtLaw)--prop_Cm = cmrdtLaw @(Counter Int)
− test/Cv/ORSet.hs
@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Cv.ORSet where--import Prelude hiding (lookup)--import Data.Semigroup (Semigroup ((<>)))--import CRDT.Cv.ORSet (ORSet, add, lookup, remove)-import CRDT.LamportClock.Simulation (runLamportClockSim,- runProcessSim)--import Laws (cvrdtLaws)-import Util (expectRight)--test_Cv = cvrdtLaws @(ORSet Int)--prop_add pid (x :: Char) s =- expectRight . runLamportClockSim . runProcessSim 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 =- expectRight . runLamportClockSim . runProcessSim pid $- lookup x . (<> s1) <$> add x s0
− test/Cv/RGA.hs
@@ -1,54 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE TypeApplications #-}--module Cv.RGA where--import Prelude hiding (fail)--import Test.QuickCheck (conjoin, (.&&.), (.||.), (===))--import CRDT.Cv.RGA (RgaString, edit, fromString, pack, toString,- unpack)-import CRDT.LamportClock (LamportTime (LamportTime))-import CRDT.LamportClock.Simulation (runLamportClockSim,- runProcessSim)--import Laws (cvrdtLaws)-import Util (expectRight, fail)--prop_fromString_toString s pid = expectRight $ do- v <- runLamportClockSim . runProcessSim pid $ fromString s- pure $ toString v === s--test_Cv = cvrdtLaws @RgaString--prop_edit v1 s2 pid = expectRight . runLamportClockSim $ do- v2 <- runProcessSim pid $ edit s2 v1- pure $ toString v2 === s2--prop_pack_unpack rga = unpack (pack rga) == (rga :: RgaString)--prop_fromString_pack s pid = expectRight $ do- v <- runLamportClockSim . runProcessSim pid $ fromString s- pure $ case pack v of- [(LamportTime _ pid', atoms)] -> atoms === map Just s .&&. pid' === pid- [] -> s === ""- p -> fail $ "cannot pack " ++ show p--prop_edit_pack s1 s2 pid1 pid2 = expectRight . runLamportClockSim $ do- v1 <- runProcessSim pid1 $ fromString s1- v2 <- runProcessSim pid2 $ edit (s1 ++ s2) v1- pure $ case pack v2 of- [(LamportTime _ pid1', atoms1), (LamportTime _ pid2', atoms2)] ->- conjoin- [ atoms1 === map Just s1- , pid1' === pid1- , atoms2 === map Just s2- , pid2' === pid2- ]- [(LamportTime _ pid', atoms)] ->- (atoms === map Just s1 .&&. pid' === pid1 .&&. s2 === "")- .||. (atoms === map Just s2 .&&. pid' === pid2 .&&. s1 === "")- [] -> s1 === "" .&&. s2 === ""- p -> fail $ "cannot pack " ++ show p
− test/Cv/TwoPSet.hs
@@ -1,25 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Cv.TwoPSet where--import Test.QuickCheck ((==>))--import CRDT.Cv.TwoPSet (TwoPSet (..), add, isKnown, member, remove)--import Laws (cvrdtLaws)---- | Difference from LwwElementSet and ORSet -- removal bias-prop_removal_bias (s :: TwoPSet Char) x =- not . member x . add x . remove x $ add x s--prop_add (s :: TwoPSet Char) x = not (isKnown x s) ==> member x (add x s)--prop_remove (s :: TwoPSet Char) x = not . member x $ remove x s--prop_add_then_remove (s :: TwoPSet Char) x =- not . member x . remove x $ add x s--test_Cv = cvrdtLaws @(TwoPSet Char)
− test/GCounter.hs
@@ -1,17 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module GCounter where--import Test.QuickCheck ((===))--import CRDT.Cv.GCounter (GCounter (..), increment, query)--import Laws (cvrdtLaws)--test_Cv = cvrdtLaws @(GCounter Int)--prop_increment (counter :: GCounter Int) pid =- query (increment pid counter) === succ (query counter)
− test/GSet.hs
@@ -1,17 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module GSet where--import qualified CRDT.Cm.GSet as Cm-import qualified CRDT.Cv.GSet as Cv--import Laws (cmrdtLaw, cvrdtLaws)--prop_Cm = cmrdtLaw @(Cm.GSet Char)--test_Cv = cvrdtLaws @(Cv.GSet Char)--prop_add (x :: Char) = Cv.lookup x . Cv.add x
− test/LWW.hs
@@ -1,38 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module LWW- ( prop_Cm- , prop_assign- , prop_merge_with_former- , test_Cv- ) where--import Data.Semigroup ((<>))-import Test.QuickCheck ((===))--import CRDT.LamportClock.Simulation (runLamportClockSim,- runProcessSim)-import CRDT.LWW (LWW, assign, initialize, query)--import Laws (cmrdtLaw, cvrdtLaws)-import Util (expectRight)--prop_Cm = cmrdtLaw @(LWW Char)--test_Cv = cvrdtLaws @(LWW Char)--prop_assign pid1 pid2 (formerValue :: Char) latterValue =- expectRight . runLamportClockSim $ do- state1 <- runProcessSim pid1 $ initialize formerValue- state2 <- runProcessSim pid2 $ assign latterValue state1- pure $ query state2 === latterValue--prop_merge_with_former pid1 pid2 (formerValue :: Char) latterValue =- expectRight . runLamportClockSim $ do- state1 <- runProcessSim pid1 $ initialize formerValue- state2 <- runProcessSim pid2 $ assign latterValue state1- pure $ query (state1 <> state2) === latterValue
− test/Laws.hs
@@ -1,148 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}--{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Laws- ( cmrdtLaw- , cvrdtLaws- , opCommutativity- ) where--import Control.Monad.State.Strict (MonadState, StateT, evalStateT,- execStateT, get, modify)-import Control.Monad.Trans (lift)-import Data.Functor.Identity (runIdentity)-import Data.Maybe (isJust)-import Data.Semigroup (Semigroup, (<>))-import QuickCheck.GenT (MonadGen, liftGen, runGenT)-import qualified QuickCheck.GenT as GenT-import Test.QuickCheck (Arbitrary (..), Property, choose,- counterexample, discard, forAll, getSize,- property, (.&&.), (===), (==>))-import Test.Tasty (TestTree)-import Test.Tasty.QuickCheck (testProperty)--import CRDT.Cm (CmRDT (..), concurrent)-import CRDT.Cv (CvRDT)-import CRDT.LamportClock (Clock)-import CRDT.LamportClock.Simulation (ProcessSim, ProcessSimT,- runLamportClockSimT,- runProcessSimT)-import Data.Semilattice (Semilattice, merge)--import ArbitraryOrphans ()--semigroupLaw :: forall a. (Arbitrary a, Semigroup a, Eq a, Show a) => TestTree-semigroupLaw = testProperty "associativity" associativity- where- associativity x y (z :: a) = (x <> y) <> z === x <> (y <> z)--semilatticeLaws- :: forall a. (Arbitrary a, Semilattice a, Eq a, Show a) => [TestTree]-semilatticeLaws =- [ semigroupLaw @a- , testProperty "commutativity" commutativity- , testProperty "idempotency" idempotency- ]- where- idempotency (x :: a) = x `merge` x === x- commutativity x (y :: a) = x `merge` y === y `merge` x--cvrdtLaws :: forall a. (Arbitrary a, CvRDT a, Eq a, Show a) => [TestTree]-cvrdtLaws = semilatticeLaws @a---- | CmRDT law: concurrent ops commute-cmrdtLaw- :: forall op.- ( CmRDT op- , Show op- , Arbitrary (Intent op)- , Show (Intent op)- , Show (Payload op)- )- => Property-cmrdtLaw = property concurrentOpsCommute- where- concurrentOpsCommute pid1 pid2 pid3 =- pid1 < pid2 && pid2 < pid3 ==>- forAll genFixture $ \case- Right ((in1, op1), (in2, op2), state3) ->- concurrent op1 op2 ==>- opCommutativity (in1, op1) (in2, op2) state3- Left _ -> discard- where- genFixture = fmap runIdentity . runGenT . runLamportClockSimT $ (,,)- <$> runProcessSimT pid1 genStateAndTakeLastOp- <*> runProcessSimT pid2 genStateAndTakeLastOp- <*> runProcessSimT pid3 genState- genState = (`execStateT` initial @op) $ genAndApplyOps @op- genStateAndTakeLastOp = (`evalStateT` initial @op) $ do- _ <- genAndApplyOps @op- genAndApplyOp @op--opCommutativity- :: forall op.- (CmRDT op, Show op, Show (Intent op), Show (Payload op))- => (Intent op, op) -- ^ the op must be made from the intent- -> (Intent op, op) -- ^ the op must be made from the intent- -> Payload op -- ^ any reachable state- -> Property-opCommutativity (in1, op1) (in2, op2) state =- isJust (makeOp' in1 state) ==>- isJust (makeOp' in2 state) ==>- counterexample- ( show in2 ++ " must be valid after " ++ show op1 ++- " applied to " ++ show state )- (isJust $ makeOp' in2 $ apply op1 state)- .&&.- (apply op1 . apply op2) state === (apply op2 . apply op1) state- where- makeOp' = makeOp @op @ProcessSim--genAndApplyOp- :: ( CmRDT op, Arbitrary (Intent op)- , Clock m, MonadState (Payload op) m, MonadGen m- , Show op, Show (Intent op), Show (Payload op)- )- => m (Intent op, op)-genAndApplyOp = do- payload <- get- intent <- liftGen arbitrary- case makeOp intent payload of- Nothing -> genAndApplyOp- Just opAction -> do- op <- opAction- modify $ apply op- pure (intent, op)--genAndApplyOps- :: ( CmRDT op, Arbitrary (Intent op)- , Clock m, MonadState (Payload op) m, MonadGen m- , Show op, Show (Intent op), Show (Payload op)- )- => m [(Intent op, op)]-genAndApplyOps = GenT.listOf genAndApplyOp--instance MonadGen m => MonadGen (ProcessSimT m) where- liftGen = lift . liftGen- variant = undefined- sized f = do- size <- liftGen getSize- f size- resize = undefined- choose = liftGen . choose--instance MonadGen m => MonadGen (StateT s m) where- liftGen = lift . liftGen- variant = undefined- sized f = do- size <- liftGen getSize- f size- resize = undefined- choose = liftGen . choose
− test/LwwElementSet.hs
@@ -1,56 +0,0 @@-{-# 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 Data.Semigroup ((<>))--import CRDT.Cv.LwwElementSet (LwwElementSet, add, lookup, remove)-import CRDT.LamportClock (LamportTime (LamportTime), advance, getTime)-import CRDT.LamportClock.Simulation (runLamportClockSim,- runProcessSim)--import Laws (cvrdtLaws)-import Util (expectRight)--test_Cv = cvrdtLaws @(LwwElementSet Char)--prop_add (s :: LwwElementSet Char) x pid1 =- expectRight . runLamportClockSim $ do- s1 <- runProcessSim pid1 $ add x s- pure $ lookup x s1--prop_remove (s :: LwwElementSet Char) x pid1 pid2 =- expectRight . runLamportClockSim $ do- s1 <- runProcessSim pid1 $ add x s- s2 <- runProcessSim 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 =- expectRight . runLamportClockSim $ do- s1 <- runProcessSim pid1 $ add x s- s2 <- runProcessSim pid2 $ remove x s1- s3 <- runProcessSim 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 =- expectRight . runLamportClockSim $ do- (s1, LamportTime t0 _) <-- runProcessSim pid1 $ (,) <$> add x s <*> getTime- s2 <- runProcessSim pid2 $ do- advance t0- s' <- add x s- remove x s'- pure . not . lookup x $ s1 <> s2
− test/Main.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
− test/Max.hs
@@ -1,17 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Max where--import Test.QuickCheck ((===))--import CRDT.Cv.Max (Max, initial, query)-import Data.Semilattice (merge)--import Laws (cvrdtLaws)--test_Cv = cvrdtLaws @(Max Char)--prop_merge (x :: Char) y = query (initial x `merge` initial y) === max x y
− test/PNCounter.hs
@@ -1,21 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-signatures #-}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module PNCounter where--import Test.QuickCheck ((===))--import CRDT.Cv.PNCounter (PNCounter (..), decrement, increment, query)--import GCounter ()-import Laws (cvrdtLaws)--test_Cv = cvrdtLaws @(PNCounter Int)--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)
− test/Util.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}--module Util where--import Test.QuickCheck (Property, Testable, counterexample, property)--expectRight :: Testable a => Either String a -> Property-expectRight e = expectRightK e id--expectRightK :: Testable b => Either String a -> (a -> b) -> Property-expectRightK e f = case e of- Left l -> counterexample l $ property False- Right a -> property $ f a--pattern (:-) :: a -> b -> (a, b)-pattern a :- b = (a, b)-infix 0 :---ok :: Property-ok = property ()--fail :: String -> Property-fail s = counterexample s $ property False