{-# 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