{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}

-- | Replicated Growable Array (RGA)
module CRDT.Cm.RGA
    ( RGA (..)
    , RgaIntent (..)
    , RgaPayload (..)
    , fromString
    , load
    , toString
    , toVector
    ) where

import           Prelude hiding (lookup)

import           Control.Monad.State.Strict (MonadState)
import           Data.Empty (AsEmpty (..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Vector (Vector, (//))
import qualified Data.Vector as Vector

import           CRDT.Cm (CausalOrd, CmRDT, Intent, Payload, apply, initial,
                          makeAndApplyOp, makeOp, precedes)
import           CRDT.LamportClock (Clock, LamportTime (LamportTime), advance,
                                    getTime)

-- | Using 'LamportTime' as an identifier for vertices
type VertexId = LamportTime

data RgaPayload a = RgaPayload
    { RgaPayload a -> Vector (VertexId, a)
vertices  :: Vector (VertexId, a) -- TODO(cblp, 2018-02-06) Unbox
    , RgaPayload a -> Map VertexId Int
vertexIxs :: Map VertexId Int
      -- ^ indices in `vertices` vector
    }
    deriving (RgaPayload a -> RgaPayload a -> Bool
(RgaPayload a -> RgaPayload a -> Bool)
-> (RgaPayload a -> RgaPayload a -> Bool) -> Eq (RgaPayload a)
forall a. Eq a => RgaPayload a -> RgaPayload a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RgaPayload a -> RgaPayload a -> Bool
$c/= :: forall a. Eq a => RgaPayload a -> RgaPayload a -> Bool
== :: RgaPayload a -> RgaPayload a -> Bool
$c== :: forall a. Eq a => RgaPayload a -> RgaPayload a -> Bool
Eq, Int -> RgaPayload a -> ShowS
[RgaPayload a] -> ShowS
RgaPayload a -> String
(Int -> RgaPayload a -> ShowS)
-> (RgaPayload a -> String)
-> ([RgaPayload a] -> ShowS)
-> Show (RgaPayload a)
forall a. Show a => Int -> RgaPayload a -> ShowS
forall a. Show a => [RgaPayload a] -> ShowS
forall a. Show a => RgaPayload a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RgaPayload a] -> ShowS
$cshowList :: forall a. Show a => [RgaPayload a] -> ShowS
show :: RgaPayload a -> String
$cshow :: forall a. Show a => RgaPayload a -> String
showsPrec :: Int -> RgaPayload a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RgaPayload a -> ShowS
Show)

-- | Is added and is not removed.
lookup :: AsEmpty a => VertexId -> RgaPayload a -> Bool
lookup :: VertexId -> RgaPayload a -> Bool
lookup VertexId
v RgaPayload { Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices, Map VertexId Int
vertexIxs :: Map VertexId Int
vertexIxs :: forall a. RgaPayload a -> Map VertexId Int
vertexIxs } = case VertexId -> Map VertexId Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup VertexId
v Map VertexId Int
vertexIxs of
    Just Int
ix -> let (VertexId
_, a
a) = Vector (VertexId, a)
vertices Vector (VertexId, a) -> Int -> (VertexId, a)
forall a. Vector a -> Int -> a
Vector.! Int
ix in a -> Bool
forall a. AsEmpty a => a -> Bool
isNotEmpty a
a
    Maybe Int
Nothing -> Bool
False

data RgaIntent a
    = AddAfter (Maybe VertexId) a
      -- ^ 'Nothing' means the beginning
    | Remove VertexId
    deriving (Int -> RgaIntent a -> ShowS
[RgaIntent a] -> ShowS
RgaIntent a -> String
(Int -> RgaIntent a -> ShowS)
-> (RgaIntent a -> String)
-> ([RgaIntent a] -> ShowS)
-> Show (RgaIntent a)
forall a. Show a => Int -> RgaIntent a -> ShowS
forall a. Show a => [RgaIntent a] -> ShowS
forall a. Show a => RgaIntent a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RgaIntent a] -> ShowS
$cshowList :: forall a. Show a => [RgaIntent a] -> ShowS
show :: RgaIntent a -> String
$cshow :: forall a. Show a => RgaIntent a -> String
showsPrec :: Int -> RgaIntent a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RgaIntent a -> ShowS
Show)

data RGA a
    = OpAddAfter (Maybe VertexId) a VertexId
      -- ^ - id of previous vertex, 'Nothing' means the beginning
      --   - atom
      --   - id of this vertex
    | OpRemove VertexId
    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)

instance CausalOrd (RGA a) where
    precedes :: RGA a -> RGA a -> Bool
precedes RGA a
_ RGA a
_ = Bool
False

emptyPayload :: RgaPayload a
emptyPayload :: RgaPayload a
emptyPayload = RgaPayload :: forall a. Vector (VertexId, a) -> Map VertexId Int -> RgaPayload a
RgaPayload {vertices :: Vector (VertexId, a)
vertices = Vector (VertexId, a)
forall a. Vector a
Vector.empty, vertexIxs :: Map VertexId Int
vertexIxs = Map VertexId Int
forall k a. Map k a
Map.empty}

instance (AsEmpty a, Ord a) => CmRDT (RGA a) where
    type Intent  (RGA a) = RgaIntent  a
    type Payload (RGA a) = RgaPayload a

    initial :: Payload (RGA a)
initial = Payload (RGA a)
forall a. RgaPayload a
emptyPayload

    makeOp :: Intent (RGA a) -> Payload (RGA a) -> Maybe (m (RGA a))
makeOp (AddAfter mOldId atom) Payload (RGA a)
payload = case Maybe VertexId
mOldId of
        Maybe VertexId
Nothing -> Maybe (m (RGA a))
ok
        Just VertexId
oldId
            | VertexId -> RgaPayload a -> Bool
forall a. AsEmpty a => VertexId -> RgaPayload a -> Bool
lookup VertexId
oldId Payload (RGA a)
RgaPayload a
payload -> Maybe (m (RGA a))
ok
            | Bool
otherwise            -> Maybe (m (RGA a))
forall a. Maybe a
Nothing
      where
        RgaPayload{Map VertexId Int
vertexIxs :: Map VertexId Int
vertexIxs :: forall a. RgaPayload a -> Map VertexId Int
vertexIxs} = Payload (RGA a)
RgaPayload a
payload
        ok :: Maybe (m (RGA a))
ok = m (RGA a) -> Maybe (m (RGA a))
forall a. a -> Maybe a
Just (m (RGA a) -> Maybe (m (RGA a))) -> m (RGA a) -> Maybe (m (RGA a))
forall a b. (a -> b) -> a -> b
$ do
            case Map VertexId Int -> Maybe (VertexId, Int)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map VertexId Int
vertexIxs of
                Just (LamportTime LocalTime
maxKnownTime Pid
_, Int
_) -> LocalTime -> m ()
forall (m :: * -> *). Clock m => LocalTime -> m ()
advance LocalTime
maxKnownTime
                Maybe (VertexId, Int)
Nothing                              -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe VertexId -> a -> VertexId -> RGA a
forall a. Maybe VertexId -> a -> VertexId -> RGA a
OpAddAfter Maybe VertexId
mOldId a
atom (VertexId -> RGA a) -> m VertexId -> m (RGA a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VertexId
forall (m :: * -> *). Clock m => m VertexId
getTime

    makeOp (Remove w) Payload (RGA a)
payload
        | VertexId -> RgaPayload a -> Bool
forall a. AsEmpty a => VertexId -> RgaPayload a -> Bool
lookup VertexId
w Payload (RGA a)
RgaPayload a
payload = m (RGA a) -> Maybe (m (RGA a))
forall a. a -> Maybe a
Just (m (RGA a) -> Maybe (m (RGA a)))
-> (RGA a -> m (RGA a)) -> RGA a -> Maybe (m (RGA a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGA a -> m (RGA a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RGA a -> Maybe (m (RGA a))) -> RGA a -> Maybe (m (RGA a))
forall a b. (a -> b) -> a -> b
$ VertexId -> RGA a
forall a. VertexId -> RGA a
OpRemove VertexId
w
        | Bool
otherwise        = Maybe (m (RGA a))
forall a. Maybe a
Nothing

    apply :: RGA a -> Payload (RGA a) -> Payload (RGA a)
apply (OpAddAfter Maybe VertexId
mOldId a
newAtom VertexId
newId) Payload (RGA a)
payload =
        RgaPayload :: forall a. Vector (VertexId, a) -> Map VertexId Int -> RgaPayload a
RgaPayload{vertices :: Vector (VertexId, a)
vertices = Vector (VertexId, a)
vertices', vertexIxs :: Map VertexId Int
vertexIxs = Map VertexId Int
vertexIxs'}
      where
        RgaPayload{Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices, Map VertexId Int
vertexIxs :: Map VertexId Int
vertexIxs :: forall a. RgaPayload a -> Map VertexId Int
vertexIxs} = Payload (RGA a)
RgaPayload a
payload
        n :: Int
n = Vector (VertexId, a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector (VertexId, a)
vertices

        (Vector (VertexId, a)
vertices', Int
newIx)
            | Vector (VertexId, a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector (VertexId, a)
vertices = case Maybe VertexId
mOldId of
                Maybe VertexId
Nothing    -> ((VertexId, a) -> Vector (VertexId, a)
forall a. a -> Vector a
Vector.singleton (VertexId
newId, a
newAtom), Int
0)
                Just VertexId
oldId -> String -> (Vector (VertexId, a), Int)
forall a. HasCallStack => String -> a
error (String -> (Vector (VertexId, a), Int))
-> String -> (Vector (VertexId, a), Int)
forall a b. (a -> b) -> a -> b
$ VertexId -> String
forall a. Show a => a -> String
show VertexId
oldId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" not delivered"
            | Bool
otherwise = (Int -> Vector (VertexId, a)
insert Int
ix, Int
ix)
              where
                ix :: Int
ix = Int -> Int
findWhereToInsert (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ case Maybe VertexId
mOldId of
                    Maybe VertexId
Nothing    -> Int
0
                    Just VertexId
oldId -> Map VertexId Int
vertexIxs Map VertexId Int -> VertexId -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! VertexId
oldId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

        vertexIxs' :: Map VertexId Int
vertexIxs' = VertexId -> Int -> Map VertexId Int -> Map VertexId Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VertexId
newId Int
newIx (Map VertexId Int -> Map VertexId Int)
-> Map VertexId Int -> Map VertexId Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Map VertexId Int -> Map VertexId Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Int -> Int
shift Map VertexId Int
vertexIxs

        shift :: Int -> Int
shift Int
ix
            | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
newIx = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            | Bool
otherwise   = Int
ix

        -- Find an edge (l, r) within which to splice new
        findWhereToInsert :: Int -> Int
findWhereToInsert Int
ix =
            case Vector (VertexId, a)
vertices Vector (VertexId, a) -> Int -> Maybe (VertexId, a)
forall a. Vector a -> Int -> Maybe a
Vector.!? Int
ix of
                Just (VertexId
t', a
_) | VertexId
newId VertexId -> VertexId -> Bool
forall a. Ord a => a -> a -> Bool
< VertexId
t' -> -- Right position, wrong order
                    Int -> Int
findWhereToInsert (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
ix
                Maybe (VertexId, a)
_ -> Int
ix

        insert :: Int -> Vector (VertexId, a)
insert Int
ix
            | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = Vector (VertexId, a)
left Vector (VertexId, a)
-> Vector (VertexId, a) -> Vector (VertexId, a)
forall a. Semigroup a => a -> a -> a
<> (VertexId, a) -> Vector (VertexId, a)
forall a. a -> Vector a
Vector.singleton (VertexId
newId, a
newAtom) Vector (VertexId, a)
-> Vector (VertexId, a) -> Vector (VertexId, a)
forall a. Semigroup a => a -> a -> a
<> Vector (VertexId, a)
right
            | Bool
otherwise = Vector (VertexId, a) -> (VertexId, a) -> Vector (VertexId, a)
forall a. Vector a -> a -> Vector a
Vector.snoc Vector (VertexId, a)
vertices (VertexId
newId, a
newAtom)
          where
            (Vector (VertexId, a)
left, Vector (VertexId, a)
right) = Int
-> Vector (VertexId, a)
-> (Vector (VertexId, a), Vector (VertexId, a))
forall a. Int -> Vector a -> (Vector a, Vector a)
Vector.splitAt Int
ix Vector (VertexId, a)
vertices

    apply (OpRemove VertexId
vid) payload :: Payload (RGA a)
payload@RgaPayload{vertices, vertexIxs} =
        -- pre addAfter(_, w) delivered  -- 2P-Set precondition
        Payload (RGA a)
RgaPayload a
payload{vertices :: Vector (VertexId, a)
vertices = Vector (VertexId, a)
vertices Vector (VertexId, a)
-> [(Int, (VertexId, a))] -> Vector (VertexId, a)
forall a. Vector a -> [(Int, a)] -> Vector a
// [(Int
ix, (VertexId
vid, a
forall a. AsEmpty a => a
empty))]}
      where
        ix :: Int
ix = Map VertexId Int
vertexIxs Map VertexId Int -> VertexId -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! VertexId
vid

fromList
    :: (AsEmpty a, Ord a, Clock m, MonadFail m, MonadState (RgaPayload a) m)
    => [a]
    -> m [RGA a]
fromList :: [a] -> m [RGA a]
fromList = Maybe VertexId -> [a] -> m [RGA a]
forall (f :: * -> *) a.
(AsEmpty a, Ord a, Clock f, MonadFail f,
 MonadState (RgaPayload a) f) =>
Maybe VertexId -> [a] -> f [RGA a]
go Maybe VertexId
forall a. Maybe a
Nothing
  where
    go :: Maybe VertexId -> [a] -> f [RGA a]
go Maybe VertexId
_      []     = [RGA a] -> f [RGA a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go Maybe VertexId
prevId (a
x:[a]
xs) = do
        op :: RGA a
op@(OpAddAfter Maybe VertexId
_ a
_ VertexId
newId) <- Intent (RGA a) -> f (RGA a)
forall op (m :: * -> *).
(CmRDT op, Clock m, MonadFail m, MonadState (Payload op) m) =>
Intent op -> m op
makeAndApplyOp (Maybe VertexId -> a -> RgaIntent a
forall a. Maybe VertexId -> a -> RgaIntent a
AddAfter Maybe VertexId
prevId a
x)
        (RGA a
op RGA a -> [RGA a] -> [RGA a]
forall a. a -> [a] -> [a]
:) ([RGA a] -> [RGA a]) -> f [RGA a] -> f [RGA a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VertexId -> [a] -> f [RGA a]
go (VertexId -> Maybe VertexId
forall a. a -> Maybe a
Just VertexId
newId) [a]
xs

toList :: RgaPayload a -> [a]
toList :: RgaPayload a -> [a]
toList RgaPayload { Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices } = ((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)] -> [a]) -> [(VertexId, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ Vector (VertexId, a) -> [(VertexId, a)]
forall a. Vector a -> [a]
Vector.toList Vector (VertexId, a)
vertices

toVector :: RgaPayload a -> Vector a
toVector :: RgaPayload a -> Vector a
toVector RgaPayload { Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: forall a. RgaPayload a -> Vector (VertexId, a)
vertices } = ((VertexId, a) -> a) -> Vector (VertexId, a) -> Vector a
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map (VertexId, a) -> a
forall a b. (a, b) -> b
snd Vector (VertexId, a)
vertices

fromString
    :: (Clock m, MonadFail m, MonadState (RgaPayload Char) m)
    => String
    -> m [RGA Char]
fromString :: String -> m [RGA Char]
fromString = String -> m [RGA Char]
forall a (m :: * -> *).
(AsEmpty a, Ord a, Clock m, MonadFail m,
 MonadState (RgaPayload a) m) =>
[a] -> m [RGA a]
fromList

toString :: RgaPayload Char -> String
toString :: RgaPayload Char -> String
toString = RgaPayload Char -> String
forall a. RgaPayload a -> [a]
toList

load :: Vector (VertexId, a) -> RgaPayload a
load :: Vector (VertexId, a) -> RgaPayload a
load Vector (VertexId, a)
vertices = RgaPayload :: forall a. Vector (VertexId, a) -> Map VertexId Int -> RgaPayload a
RgaPayload
    { Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices :: Vector (VertexId, a)
vertices
    , vertexIxs :: Map VertexId Int
vertexIxs = [(VertexId, Int)] -> Map VertexId Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (VertexId
vid, Int
ix) | Int
ix <- [Int
0..] | (VertexId
vid, a
_) <- Vector (VertexId, a) -> [(VertexId, a)]
forall a. Vector a -> [a]
Vector.toList Vector (VertexId, a)
vertices ]
    }