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 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 (ORSet a -> ORSet a -> Bool (ORSet a -> ORSet a -> Bool) -> (ORSet a -> ORSet a -> Bool) -> Eq (ORSet a) forall a. Eq a => ORSet a -> ORSet a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: ORSet a -> ORSet a -> Bool $c/= :: forall a. Eq a => ORSet a -> ORSet a -> Bool == :: ORSet a -> ORSet a -> Bool $c== :: forall a. Eq a => ORSet a -> ORSet a -> Bool Eq, 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) unpack :: ORSet a -> Map a (Map Tag Bool) unpack :: ORSet a -> Map a (Map Tag Bool) unpack (ORSet Map a (Map Tag Bool) s) = Map a (Map Tag Bool) s instance Ord a => Semigroup (ORSet a) where ORSet Map a (Map Tag Bool) s1 <> :: ORSet a -> ORSet a -> ORSet a <> ORSet Map a (Map Tag Bool) s2 = Map a (Map Tag Bool) -> ORSet a forall a. Map a (Map Tag Bool) -> ORSet a ORSet (Map a (Map Tag Bool) -> ORSet a) -> Map a (Map Tag Bool) -> ORSet a forall a b. (a -> b) -> a -> b $ (Map Tag Bool -> Map Tag Bool -> Map Tag Bool) -> Map a (Map Tag Bool) -> Map a (Map Tag Bool) -> Map a (Map Tag Bool) forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a Map.unionWith ((Bool -> Bool -> Bool) -> Map Tag Bool -> Map Tag Bool -> Map Tag Bool forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a Map.unionWith Bool -> Bool -> Bool (&&)) Map a (Map Tag Bool) s1 Map a (Map Tag Bool) s2 instance Ord a => Semilattice (ORSet a) initial :: ORSet a initial :: ORSet a initial = Map a (Map Tag Bool) -> ORSet a forall a. Map a (Map Tag Bool) -> ORSet a ORSet Map a (Map Tag Bool) forall k a. Map k a Map.empty add :: (Ord a, Process m) => a -> ORSet a -> m (ORSet a) add :: a -> ORSet a -> m (ORSet a) add a a (ORSet Map a (Map Tag Bool) s) = 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 $ Map a (Map Tag Bool) -> ORSet a forall a. Map a (Map Tag Bool) -> ORSet a ORSet (Map a (Map Tag Bool) -> ORSet a) -> Map a (Map Tag Bool) -> ORSet a forall a b. (a -> b) -> a -> b $ (Maybe (Map Tag Bool) -> Maybe (Map Tag Bool)) -> a -> Map a (Map Tag Bool) -> Map a (Map Tag Bool) forall k a. Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a Map.alter (Pid -> Maybe (Map Tag Bool) -> Maybe (Map Tag Bool) forall a b. (Ord a, Ord b, Num b) => a -> Maybe (Map (a, b) Bool) -> Maybe (Map (a, b) Bool) add1 Pid pid) a a Map a (Map Tag Bool) s where add1 :: a -> Maybe (Map (a, b) Bool) -> Maybe (Map (a, b) Bool) add1 a pid = Map (a, b) Bool -> Maybe (Map (a, b) Bool) forall a. a -> Maybe a Just (Map (a, b) Bool -> Maybe (Map (a, b) Bool)) -> (Maybe (Map (a, b) Bool) -> Map (a, b) Bool) -> Maybe (Map (a, b) Bool) -> Maybe (Map (a, b) Bool) forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Map (a, b) Bool -> Map (a, b) Bool forall a b. (Ord a, Ord b, Num b) => a -> Map (a, b) Bool -> Map (a, b) Bool add2 a pid (Map (a, b) Bool -> Map (a, b) Bool) -> (Maybe (Map (a, b) Bool) -> Map (a, b) Bool) -> Maybe (Map (a, b) Bool) -> Map (a, b) Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Map (a, b) Bool -> Maybe (Map (a, b) Bool) -> Map (a, b) Bool forall a. a -> Maybe a -> a fromMaybe Map (a, b) Bool forall k a. Map k a Map.empty add2 :: a -> Map (a, b) Bool -> Map (a, b) Bool add2 a pid Map (a, b) Bool tags = (a, b) -> Bool -> Map (a, b) Bool -> Map (a, b) Bool forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert (a pid, Int -> b forall a b. (Integral a, Num b) => a -> b fromIntegral (Int -> b) -> Int -> b forall a b. (a -> b) -> a -> b $ Map (a, b) Bool -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length Map (a, b) Bool tags) Bool True Map (a, b) Bool tags remove :: Ord a => a -> ORSet a -> ORSet a remove :: a -> ORSet a -> ORSet a remove a a (ORSet Map a (Map Tag Bool) s) = Map a (Map Tag Bool) -> ORSet a forall a. Map a (Map Tag Bool) -> ORSet a ORSet (Map a (Map Tag Bool) -> ORSet a) -> Map a (Map Tag Bool) -> ORSet a forall a b. (a -> b) -> a -> b $ (Map Tag Bool -> Map Tag Bool) -> a -> Map a (Map Tag Bool) -> Map a (Map Tag Bool) forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a Map.adjust ((Bool -> Bool) -> Map Tag Bool -> Map Tag Bool forall a b k. (a -> b) -> Map k a -> Map k b Map.map ((Bool -> Bool) -> Map Tag Bool -> Map Tag Bool) -> (Bool -> Bool) -> Map Tag Bool -> Map Tag Bool forall a b. (a -> b) -> a -> b $ Bool -> Bool -> Bool forall a b. a -> b -> a const Bool False) a a Map a (Map Tag Bool) s lookup :: Ord a => a -> ORSet a -> Bool lookup :: a -> ORSet a -> Bool lookup a e = Map Tag Bool -> Bool forall (t :: * -> *). Foldable t => t Bool -> Bool or (Map Tag Bool -> Bool) -> (ORSet a -> Map Tag Bool) -> ORSet a -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Map Tag Bool -> Maybe (Map Tag Bool) -> Map Tag Bool forall a. a -> Maybe a -> a fromMaybe Map Tag Bool forall k a. Map k a Map.empty (Maybe (Map Tag Bool) -> Map Tag Bool) -> (ORSet a -> Maybe (Map Tag Bool)) -> ORSet a -> Map Tag Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Map a (Map Tag Bool) -> Maybe (Map Tag Bool) forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup a e (Map a (Map Tag Bool) -> Maybe (Map Tag Bool)) -> (ORSet a -> Map a (Map Tag Bool)) -> ORSet a -> Maybe (Map Tag Bool) forall b c a. (b -> c) -> (a -> b) -> a -> c . ORSet a -> Map a (Map Tag Bool) forall a. ORSet a -> Map a (Map Tag Bool) unpack