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