{-# LANGUAGE FlexibleInstances #-}

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           CRDT.LamportClock (Clock)
import           CRDT.LWW (LWW, advanceFromLWW)
import qualified CRDT.LWW as LWW
import           Data.Semilattice (Semilattice)

newtype LwwElementSet a = LES (Map a (LWW Bool))
    deriving (LwwElementSet a -> LwwElementSet a -> Bool
(LwwElementSet a -> LwwElementSet a -> Bool)
-> (LwwElementSet a -> LwwElementSet a -> Bool)
-> Eq (LwwElementSet a)
forall a. Eq a => LwwElementSet a -> LwwElementSet a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LwwElementSet a -> LwwElementSet a -> Bool
$c/= :: forall a. Eq a => LwwElementSet a -> LwwElementSet a -> Bool
== :: LwwElementSet a -> LwwElementSet a -> Bool
$c== :: forall a. Eq a => LwwElementSet a -> LwwElementSet a -> Bool
Eq, Int -> LwwElementSet a -> ShowS
[LwwElementSet a] -> ShowS
LwwElementSet a -> String
(Int -> LwwElementSet a -> ShowS)
-> (LwwElementSet a -> String)
-> ([LwwElementSet a] -> ShowS)
-> Show (LwwElementSet a)
forall a. Show a => Int -> LwwElementSet a -> ShowS
forall a. Show a => [LwwElementSet a] -> ShowS
forall a. Show a => LwwElementSet a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LwwElementSet a] -> ShowS
$cshowList :: forall a. Show a => [LwwElementSet a] -> ShowS
show :: LwwElementSet a -> String
$cshow :: forall a. Show a => LwwElementSet a -> String
showsPrec :: Int -> LwwElementSet a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> LwwElementSet a -> ShowS
Show)

instance Ord a => Semigroup (LwwElementSet a) where
    LES Map a (LWW Bool)
m1 <> :: LwwElementSet a -> LwwElementSet a -> LwwElementSet a
<> LES Map a (LWW Bool)
m2 = Map a (LWW Bool) -> LwwElementSet a
forall a. Map a (LWW Bool) -> LwwElementSet a
LES ((LWW Bool -> LWW Bool -> LWW Bool)
-> Map a (LWW Bool) -> Map a (LWW Bool) -> Map a (LWW Bool)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith LWW Bool -> LWW Bool -> LWW Bool
forall a. Semigroup a => a -> a -> a
(<>) Map a (LWW Bool)
m1 Map a (LWW Bool)
m2)

instance Ord a => Semilattice (LwwElementSet a)

initial :: LwwElementSet a
initial :: LwwElementSet a
initial = Map a (LWW Bool) -> LwwElementSet a
forall a. Map a (LWW Bool) -> LwwElementSet a
LES Map a (LWW Bool)
forall k a. Map k a
Map.empty

add :: (Ord a, Clock m) => a -> LwwElementSet a -> m (LwwElementSet a)
add :: a -> LwwElementSet a -> m (LwwElementSet a)
add a
value old :: LwwElementSet a
old@(LES Map a (LWW Bool)
m) = do
    LwwElementSet a -> m ()
forall (m :: * -> *) a. Clock m => LwwElementSet a -> m ()
advanceFromLES LwwElementSet a
old
    LWW Bool
tag <- Bool -> m (LWW Bool)
forall (m :: * -> *) a. Clock m => a -> m (LWW a)
LWW.initialize Bool
True
    LwwElementSet a -> m (LwwElementSet a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LwwElementSet a -> m (LwwElementSet a))
-> (Map a (LWW Bool) -> LwwElementSet a)
-> Map a (LWW Bool)
-> m (LwwElementSet a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (LWW Bool) -> LwwElementSet a
forall a. Map a (LWW Bool) -> LwwElementSet a
LES (Map a (LWW Bool) -> m (LwwElementSet a))
-> Map a (LWW Bool) -> m (LwwElementSet a)
forall a b. (a -> b) -> a -> b
$ a -> LWW Bool -> Map a (LWW Bool) -> Map a (LWW Bool)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
value LWW Bool
tag Map a (LWW Bool)
m

remove :: (Ord a, Clock m) => a -> LwwElementSet a -> m (LwwElementSet a)
remove :: a -> LwwElementSet a -> m (LwwElementSet a)
remove a
value old :: LwwElementSet a
old@(LES Map a (LWW Bool)
m) = do
    LwwElementSet a -> m ()
forall (m :: * -> *) a. Clock m => LwwElementSet a -> m ()
advanceFromLES LwwElementSet a
old
    LWW Bool
tag <- Bool -> m (LWW Bool)
forall (m :: * -> *) a. Clock m => a -> m (LWW a)
LWW.initialize Bool
False
    LwwElementSet a -> m (LwwElementSet a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LwwElementSet a -> m (LwwElementSet a))
-> (Map a (LWW Bool) -> LwwElementSet a)
-> Map a (LWW Bool)
-> m (LwwElementSet a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (LWW Bool) -> LwwElementSet a
forall a. Map a (LWW Bool) -> LwwElementSet a
LES (Map a (LWW Bool) -> m (LwwElementSet a))
-> Map a (LWW Bool) -> m (LwwElementSet a)
forall a b. (a -> b) -> a -> b
$ a -> LWW Bool -> Map a (LWW Bool) -> Map a (LWW Bool)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
value LWW Bool
tag Map a (LWW Bool)
m

lookup :: Ord a => a -> LwwElementSet a -> Bool
lookup :: a -> LwwElementSet a -> Bool
lookup a
value (LES Map a (LWW Bool)
m) = Bool -> (LWW Bool -> Bool) -> Maybe (LWW Bool) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False LWW Bool -> Bool
forall a. LWW a -> a
LWW.query (Maybe (LWW Bool) -> Bool) -> Maybe (LWW Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Map a (LWW Bool) -> Maybe (LWW Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
value Map a (LWW Bool)
m

advanceFromLES :: Clock m => LwwElementSet a -> m ()
advanceFromLES :: LwwElementSet a -> m ()
advanceFromLES (LES Map a (LWW Bool)
m) = Map a (LWW Bool) -> (LWW Bool -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Map a (LWW Bool)
m LWW Bool -> m ()
forall (m :: * -> *) a. Clock m => LWW a -> m ()
advanceFromLWW