{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} module CRDT.Cm.ORSet ( ORSet (..) , Intent (..) , Payload (..) , Tag (..) , query ) where import Data.MultiMap (MultiMap) import qualified Data.MultiMap as MultiMap import Data.Set (Set) import Numeric.Natural (Natural) import CRDT.Cm (CausalOrd, CmRDT) import qualified CRDT.Cm as Cm import CRDT.LamportClock (Pid (Pid), getPid) data ORSet a = OpAdd a Tag | OpRemove a (Set Tag) deriving Int -> ORSet a -> ShowS [ORSet a] -> ShowS ORSet a -> String (Int -> ORSet a -> ShowS) -> (ORSet a -> String) -> ([ORSet a] -> ShowS) -> Show (ORSet a) forall a. Show a => Int -> ORSet a -> ShowS forall a. Show a => [ORSet a] -> ShowS forall a. Show a => ORSet a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ORSet a] -> ShowS $cshowList :: forall a. Show a => [ORSet a] -> ShowS show :: ORSet a -> String $cshow :: forall a. Show a => ORSet a -> String showsPrec :: Int -> ORSet a -> ShowS $cshowsPrec :: forall a. Show a => Int -> ORSet a -> ShowS Show data Intent a = Add a | Remove a deriving Int -> Intent a -> ShowS [Intent a] -> ShowS Intent a -> String (Int -> Intent a -> ShowS) -> (Intent a -> String) -> ([Intent a] -> ShowS) -> Show (Intent a) forall a. Show a => Int -> Intent a -> ShowS forall a. Show a => [Intent a] -> ShowS forall a. Show a => Intent a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Intent a] -> ShowS $cshowList :: forall a. Show a => [Intent a] -> ShowS show :: Intent a -> String $cshow :: forall a. Show a => Intent a -> String showsPrec :: Int -> Intent a -> ShowS $cshowsPrec :: forall a. Show a => Int -> Intent a -> ShowS Show data Payload a = Payload { Payload a -> MultiMap a Tag elements :: MultiMap a Tag , Payload a -> Version version :: Version } deriving (Payload a -> Payload a -> Bool (Payload a -> Payload a -> Bool) -> (Payload a -> Payload a -> Bool) -> Eq (Payload a) forall a. Eq a => Payload a -> Payload a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Payload a -> Payload a -> Bool $c/= :: forall a. Eq a => Payload a -> Payload a -> Bool == :: Payload a -> Payload a -> Bool $c== :: forall a. Eq a => Payload a -> Payload a -> Bool Eq, Int -> Payload a -> ShowS [Payload a] -> ShowS Payload a -> String (Int -> Payload a -> ShowS) -> (Payload a -> String) -> ([Payload a] -> ShowS) -> Show (Payload a) forall a. Show a => Int -> Payload a -> ShowS forall a. Show a => [Payload a] -> ShowS forall a. Show a => Payload a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Payload a] -> ShowS $cshowList :: forall a. Show a => [Payload a] -> ShowS show :: Payload a -> String $cshow :: forall a. Show a => Payload a -> String showsPrec :: Int -> Payload a -> ShowS $cshowsPrec :: forall a. Show a => Int -> Payload a -> ShowS Show) data Tag = Tag Pid Version deriving (Tag -> Tag -> Bool (Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Tag -> Tag -> Bool $c/= :: Tag -> Tag -> Bool == :: Tag -> Tag -> Bool $c== :: Tag -> Tag -> Bool Eq, Eq Tag Eq Tag -> (Tag -> Tag -> Ordering) -> (Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> (Tag -> Tag -> Tag) -> (Tag -> Tag -> Tag) -> Ord Tag Tag -> Tag -> Bool Tag -> Tag -> Ordering Tag -> Tag -> Tag forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Tag -> Tag -> Tag $cmin :: Tag -> Tag -> Tag max :: Tag -> Tag -> Tag $cmax :: Tag -> Tag -> Tag >= :: Tag -> Tag -> Bool $c>= :: Tag -> Tag -> Bool > :: Tag -> Tag -> Bool $c> :: Tag -> Tag -> Bool <= :: Tag -> Tag -> Bool $c<= :: Tag -> Tag -> Bool < :: Tag -> Tag -> Bool $c< :: Tag -> Tag -> Bool compare :: Tag -> Tag -> Ordering $ccompare :: Tag -> Tag -> Ordering $cp1Ord :: Eq Tag Ord) type Version = Natural instance Show Tag where show :: Tag -> String show (Tag (Pid Word64 pid) Version version) = Word64 -> String forall a. Show a => a -> String show Word64 pid String -> ShowS forall a. [a] -> [a] -> [a] ++ Char '-' Char -> ShowS forall a. a -> [a] -> [a] : Version -> String forall a. Show a => a -> String show Version version instance CausalOrd (ORSet a) where precedes :: ORSet a -> ORSet a -> Bool precedes ORSet a _ ORSet a _ = Bool False instance Ord a => CmRDT (ORSet a) where type Intent (ORSet a) = Intent a type Payload (ORSet a) = Payload a initial :: Payload (ORSet a) initial = Payload :: forall a. MultiMap a Tag -> Version -> Payload a Payload{elements :: MultiMap a Tag elements = MultiMap a Tag forall k v. MultiMap k v MultiMap.empty, version :: Version version = Version 0} makeOp :: Intent (ORSet a) -> Payload (ORSet a) -> Maybe (m (ORSet a)) makeOp (Add a) Payload{version} = m (ORSet a) -> Maybe (m (ORSet a)) forall a. a -> Maybe a Just (m (ORSet a) -> Maybe (m (ORSet a))) -> m (ORSet a) -> Maybe (m (ORSet a)) forall a b. (a -> b) -> a -> b $ do Pid pid <- m Pid forall (m :: * -> *). Process m => m Pid getPid ORSet a -> m (ORSet a) forall (f :: * -> *) a. Applicative f => a -> f a pure (ORSet a -> m (ORSet a)) -> ORSet a -> m (ORSet a) forall a b. (a -> b) -> a -> b $ a -> Tag -> ORSet a forall a. a -> Tag -> ORSet a OpAdd a a (Tag -> ORSet a) -> Tag -> ORSet a forall a b. (a -> b) -> a -> b $ Pid -> Version -> Tag Tag Pid pid Version version makeOp (Remove a) Payload{elements} = m (ORSet a) -> Maybe (m (ORSet a)) forall a. a -> Maybe a Just (m (ORSet a) -> Maybe (m (ORSet a))) -> (Set Tag -> m (ORSet a)) -> Set Tag -> Maybe (m (ORSet a)) forall b c a. (b -> c) -> (a -> b) -> a -> c . ORSet a -> m (ORSet a) forall (f :: * -> *) a. Applicative f => a -> f a pure (ORSet a -> m (ORSet a)) -> (Set Tag -> ORSet a) -> Set Tag -> m (ORSet a) forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Set Tag -> ORSet a forall a. a -> Set Tag -> ORSet a OpRemove a a (Set Tag -> Maybe (m (ORSet a))) -> Set Tag -> Maybe (m (ORSet a)) forall a b. (a -> b) -> a -> b $ a -> MultiMap a Tag -> Set Tag forall k v. Ord k => k -> MultiMap k v -> Set v MultiMap.lookup a a MultiMap a Tag elements apply :: ORSet a -> Payload (ORSet a) -> Payload (ORSet a) apply ORSet a op Payload{elements, version} = Payload :: forall a. MultiMap a Tag -> Version -> Payload a Payload { version :: Version version = Version version Version -> Version -> Version forall a. Num a => a -> a -> a + Version 1 , elements :: MultiMap a Tag elements = case ORSet a op of OpAdd a a Tag tag -> a -> Tag -> MultiMap a Tag -> MultiMap a Tag forall k v. (Ord k, Ord v) => k -> v -> MultiMap k v -> MultiMap k v MultiMap.insert a a Tag tag MultiMap a Tag elements OpRemove a a Set Tag tags -> a -> Set Tag -> MultiMap a Tag -> MultiMap a Tag forall k v. (Ord k, Ord v) => k -> Set v -> MultiMap k v -> MultiMap k v MultiMap.deleteMany a a Set Tag tags MultiMap a Tag elements } query :: (Ord a, Foldable f) => f (ORSet a) -> Set a query :: f (ORSet a) -> Set a query = MultiMap a Tag -> Set a forall k v. MultiMap k v -> Set k MultiMap.keysSet (MultiMap a Tag -> Set a) -> (f (ORSet a) -> MultiMap a Tag) -> f (ORSet a) -> Set a forall b c a. (b -> c) -> (a -> b) -> a -> c . Payload a -> MultiMap a Tag forall a. Payload a -> MultiMap a Tag elements (Payload a -> MultiMap a Tag) -> (f (ORSet a) -> Payload a) -> f (ORSet a) -> MultiMap a Tag forall b c a. (b -> c) -> (a -> b) -> a -> c . f (ORSet a) -> Payload a forall op (f :: * -> *). (CmRDT op, Foldable f) => f op -> Payload op Cm.query