{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ParallelListComp #-}

module CRDT.Cv.RGA
    ( RGA (..)
    , fromList
    , toList
    , edit
    , RgaString
    , fromString
    , toString
    -- * Packed representation
    , RgaPacked
    , pack
    , unpack
    ) where

import           Data.Algorithm.Diff (PolyDiff (Both, First, Second),
                                      getGroupedDiffBy)
import           Data.Empty (AsEmpty (..))
import           Data.Function (on)
import           Data.Semilattice (Semilattice)
import           Data.Traversable (for)

import           CRDT.LamportClock (Clock, LamportTime (LamportTime), getTimes)

type VertexId = LamportTime

-- | TODO(cblp, 2018-02-06) Vector.Unboxed
newtype RGA a = RGA [(VertexId, a)]
    deriving (RGA a -> RGA a -> Bool
(RGA a -> RGA a -> Bool) -> (RGA a -> RGA a -> Bool) -> Eq (RGA a)
forall a. Eq a => RGA a -> RGA a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RGA a -> RGA a -> Bool
$c/= :: forall a. Eq a => RGA a -> RGA a -> Bool
== :: RGA a -> RGA a -> Bool
$c== :: forall a. Eq a => RGA a -> RGA a -> Bool
Eq, Int -> RGA a -> ShowS
[RGA a] -> ShowS
RGA a -> String
(Int -> RGA a -> ShowS)
-> (RGA a -> String) -> ([RGA a] -> ShowS) -> Show (RGA a)
forall a. Show a => Int -> RGA a -> ShowS
forall a. Show a => [RGA a] -> ShowS
forall a. Show a => RGA a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RGA a] -> ShowS
$cshowList :: forall a. Show a => [RGA a] -> ShowS
show :: RGA a -> String
$cshow :: forall a. Show a => RGA a -> String
showsPrec :: Int -> RGA a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RGA a -> ShowS
Show)

type RgaString = RGA Char

merge :: (Eq a, AsEmpty a) => RGA a -> RGA a -> RGA a
merge :: RGA a -> RGA a -> RGA a
merge (RGA [(VertexId, a)]
vertices1) (RGA [(VertexId, a)]
vertices2) = [(VertexId, a)] -> RGA a
forall a. [(VertexId, a)] -> RGA a
RGA
    ([(VertexId, a)] -> RGA a) -> [(VertexId, a)] -> RGA a
forall a b. (a -> b) -> a -> b
$ [(VertexId, a)] -> [(VertexId, a)] -> [(VertexId, a)]
forall a b.
(Ord a, AsEmpty b, Eq b) =>
[(a, b)] -> [(a, b)] -> [(a, b)]
mergeVertexLists [(VertexId, a)]
vertices1 [(VertexId, a)]
vertices2
  where
    mergeVertexLists :: [(a, b)] -> [(a, b)] -> [(a, b)]
mergeVertexLists []  [(a, b)]
vs2 = [(a, b)]
vs2
    mergeVertexLists [(a, b)]
vs1 []  = [(a, b)]
vs1
    mergeVertexLists (v1 :: (a, b)
v1@(a
id1, b
a1):[(a, b)]
vs1) (v2 :: (a, b)
v2@(a
id2, b
a2):[(a, b)]
vs2) =
        case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
id1 a
id2 of
            Ordering
LT -> (a, b)
v2 (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)] -> [(a, b)]
mergeVertexLists ((a, b)
v1 (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
vs1) [(a, b)]
vs2
            Ordering
GT -> (a, b)
v1 (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)] -> [(a, b)]
mergeVertexLists [(a, b)]
vs1 ((a, b)
v2 (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
vs2)
            Ordering
EQ -> (a
id1, b -> b -> b
forall p. (AsEmpty p, Eq p) => p -> p -> p
mergeAtoms b
a1 b
a2) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)] -> [(a, b)]
mergeVertexLists [(a, b)]
vs1 [(a, b)]
vs2

    -- priority of deletion
    mergeAtoms :: p -> p -> p
mergeAtoms p
a1 p
a2 | p -> Bool
forall a. AsEmpty a => a -> Bool
isEmpty p
a1 Bool -> Bool -> Bool
|| p -> Bool
forall a. AsEmpty a => a -> Bool
isEmpty p
a2 = p
forall a. AsEmpty a => a
empty
                     | p
a1 p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
a2                 = p
a1
                     | Bool
otherwise                = p
forall a. AsEmpty a => a
empty -- error: contradiction

instance (Eq a, AsEmpty a) => Semigroup (RGA a) where
    <> :: RGA a -> RGA a -> RGA a
(<>) = RGA a -> RGA a -> RGA a
forall a. (Eq a, AsEmpty a) => RGA a -> RGA a -> RGA a
merge

instance (Eq a, AsEmpty a) => Semilattice (RGA a)

-- Why not?
instance (Eq a, AsEmpty a) => Monoid (RGA a) where
    mempty :: RGA a
mempty = [(VertexId, a)] -> RGA a
forall a. [(VertexId, a)] -> RGA a
RGA []
    mappend :: RGA a -> RGA a -> RGA a
mappend = RGA a -> RGA a -> RGA a
forall a. Semigroup a => a -> a -> a
(<>)

toList :: AsEmpty a => RGA a -> [a]
toList :: RGA a -> [a]
toList (RGA [(VertexId, a)]
rga) = [ a
a | (VertexId
_, a
a) <- [(VertexId, a)]
rga, a -> Bool
forall a. AsEmpty a => a -> Bool
isNotEmpty a
a ]

toString :: RgaString -> String
toString :: RgaString -> String
toString = RgaString -> String
forall a. AsEmpty a => RGA a -> [a]
toList

fromList :: Clock m => [a] -> m (RGA a)
fromList :: [a] -> m (RGA a)
fromList = ([(VertexId, a)] -> RGA a) -> m [(VertexId, a)] -> m (RGA a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(VertexId, a)] -> RGA a
forall a. [(VertexId, a)] -> RGA a
RGA (m [(VertexId, a)] -> m (RGA a))
-> ([a] -> m [(VertexId, a)]) -> [a] -> m (RGA a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> m [(VertexId, a)]
forall (m :: * -> *) a. Clock m => [a] -> m [(VertexId, a)]
fromList'

fromList' :: Clock m => [a] -> m [(VertexId, a)]
fromList' :: [a] -> m [(VertexId, a)]
fromList' [a]
xs = do
    LamportTime LocalTime
time0 Pid
pid <- LocalTime -> m VertexId
forall (m :: * -> *). Clock m => LocalTime -> m VertexId
getTimes (LocalTime -> m VertexId)
-> (Int -> LocalTime) -> Int -> m VertexId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LocalTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> m VertexId) -> Int -> m VertexId
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    [(VertexId, a)] -> m [(VertexId, a)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (LocalTime -> Pid -> VertexId
LamportTime LocalTime
time Pid
pid, a
x) | LocalTime
time <- [LocalTime
time0..] | a
x <- [a]
xs ]

fromString :: Clock m => String -> m RgaString
fromString :: String -> m RgaString
fromString = String -> m RgaString
forall (m :: * -> *) a. Clock m => [a] -> m (RGA a)
fromList

-- | Replace content with specified,
-- applying changed found by the diff algorithm
edit :: (Eq a, AsEmpty a, Clock m) => [a] -> RGA a -> m (RGA a)
edit :: [a] -> RGA a -> m (RGA a)
edit [a]
newList (RGA [(VertexId, a)]
oldRga) = ([[(VertexId, a)]] -> RGA a) -> m [[(VertexId, a)]] -> m (RGA a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(VertexId, a)] -> RGA a
forall a. [(VertexId, a)] -> RGA a
RGA ([(VertexId, a)] -> RGA a)
-> ([[(VertexId, a)]] -> [(VertexId, a)])
-> [[(VertexId, a)]]
-> RGA a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(VertexId, a)]] -> [(VertexId, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (m [[(VertexId, a)]] -> m (RGA a))
-> ((PolyDiff [(VertexId, a)] [(VertexId, a)] -> m [(VertexId, a)])
    -> m [[(VertexId, a)]])
-> (PolyDiff [(VertexId, a)] [(VertexId, a)] -> m [(VertexId, a)])
-> m (RGA a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PolyDiff [(VertexId, a)] [(VertexId, a)]]
-> (PolyDiff [(VertexId, a)] [(VertexId, a)] -> m [(VertexId, a)])
-> m [[(VertexId, a)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [PolyDiff [(VertexId, a)] [(VertexId, a)]]
diff ((PolyDiff [(VertexId, a)] [(VertexId, a)] -> m [(VertexId, a)])
 -> m (RGA a))
-> (PolyDiff [(VertexId, a)] [(VertexId, a)] -> m [(VertexId, a)])
-> m (RGA a)
forall a b. (a -> b) -> a -> b
$ \case
    First [(VertexId, a)]
removed -> [(VertexId, a)] -> m [(VertexId, a)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (VertexId
vid, a
forall a. AsEmpty a => a
empty) | (VertexId
vid, a
_) <- [(VertexId, a)]
removed ]
    Both [(VertexId, a)]
v [(VertexId, a)]
_      -> [(VertexId, a)] -> m [(VertexId, a)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(VertexId, a)]
v
    Second [(VertexId, a)]
added  -> [a] -> m [(VertexId, a)]
forall (m :: * -> *) a. Clock m => [a] -> m [(VertexId, a)]
fromList' ([a] -> m [(VertexId, a)]) -> [a] -> m [(VertexId, a)]
forall a b. (a -> b) -> a -> b
$ ((VertexId, a) -> a) -> [(VertexId, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (VertexId, a) -> a
forall a b. (a, b) -> b
snd [(VertexId, a)]
added
  where
    newList' :: [(a, a)]
newList' = [ (a
forall a. HasCallStack => a
undefined, a
a) | a
a <- [a]
newList ]
    diff :: [PolyDiff [(VertexId, a)] [(VertexId, a)]]
diff     = ((VertexId, a) -> (VertexId, a) -> Bool)
-> [(VertexId, a)]
-> [(VertexId, a)]
-> [PolyDiff [(VertexId, a)] [(VertexId, a)]]
forall a b. (a -> b -> Bool) -> [a] -> [b] -> [PolyDiff [a] [b]]
getGroupedDiffBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> ((VertexId, a) -> a) -> (VertexId, a) -> (VertexId, a) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (VertexId, a) -> a
forall a b. (a, b) -> b
snd) [(VertexId, a)]
oldRga [(VertexId, a)]
forall a. [(a, a)]
newList'

-- | Compact version of 'RGA'.
-- For each 'VertexId', the corresponding sequence of vetices has the same 'Pid'
-- and sequentially growing 'LocalTime', starting with the specified one.
type RgaPacked a = [(VertexId, [a])]

pack :: RGA a -> RgaPacked a
pack :: RGA a -> RgaPacked a
pack (RGA []                ) = []
pack (RGA ((VertexId
first, a
atom):[(VertexId, a)]
vs)) = VertexId -> [a] -> LocalTime -> [(VertexId, a)] -> RgaPacked a
forall a.
VertexId
-> [a] -> LocalTime -> [(VertexId, a)] -> [(VertexId, [a])]
go VertexId
first [a
atom] LocalTime
1 [(VertexId, a)]
vs
  where
    -- TODO(cblp, 2018-02-08) buf :: DList
    go :: VertexId
-> [a] -> LocalTime -> [(VertexId, a)] -> [(VertexId, [a])]
go VertexId
vid [a]
buf LocalTime
_ [] = [(VertexId
vid, [a]
buf)]
    go VertexId
vid [a]
buf LocalTime
dt ((VertexId
wid, a
a):[(VertexId, a)]
ws)
        | VertexId
wid VertexId -> VertexId -> Bool
forall a. Eq a => a -> a -> Bool
== LocalTime -> VertexId -> VertexId
next LocalTime
dt VertexId
vid = VertexId
-> [a] -> LocalTime -> [(VertexId, a)] -> [(VertexId, [a])]
go VertexId
vid ([a]
buf [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
a]) (LocalTime -> LocalTime
forall a. Enum a => a -> a
succ LocalTime
dt) [(VertexId, a)]
ws
        | Bool
otherwise          = (VertexId
vid, [a]
buf) (VertexId, [a]) -> [(VertexId, [a])] -> [(VertexId, [a])]
forall a. a -> [a] -> [a]
: VertexId
-> [a] -> LocalTime -> [(VertexId, a)] -> [(VertexId, [a])]
go VertexId
wid [a
a] LocalTime
1 [(VertexId, a)]
ws
    next :: LocalTime -> VertexId -> VertexId
next LocalTime
dt (LamportTime LocalTime
t Pid
p) = LocalTime -> Pid -> VertexId
LamportTime (LocalTime
t LocalTime -> LocalTime -> LocalTime
forall a. Num a => a -> a -> a
+ LocalTime
dt) Pid
p

unpack :: RgaPacked a -> RGA a
unpack :: RgaPacked a -> RGA a
unpack RgaPacked a
packed = [(VertexId, a)] -> RGA a
forall a. [(VertexId, a)] -> RGA a
RGA ([(VertexId, a)] -> RGA a) -> [(VertexId, a)] -> RGA a
forall a b. (a -> b) -> a -> b
$ do
    (LamportTime LocalTime
time Pid
pid, [a]
atoms) <- RgaPacked a
packed
    [ (LocalTime -> Pid -> VertexId
LamportTime (LocalTime
time LocalTime -> LocalTime -> LocalTime
forall a. Num a => a -> a -> a
+ LocalTime
i) Pid
pid, a
atom) | LocalTime
i <- [LocalTime
0..] | a
atom <- [a]
atoms ]