-- |
-- Module:      Network.Riak.CRDT.Ops
-- Copyright:   (c) 2016 Sentenai
-- Author:      Antonio Nikishaev <me@lelf.lu>
-- License:     Apache
-- Maintainer:  Tim McGilchrist <timmcgil@gmail.com>, Mark Hibberd <mark@hibberd.id.au>
-- Stability:   experimental
-- Portability: portable
--
--
-- Conversions of CRDT operations to 'PB.DtOp'
--
module Network.Riak.CRDT.Ops (
    counterUpdateOp
  , setUpdateOp
  , SetOpsComb(..)
  , toOpsComb
  , mapUpdateOp
  ) where

import           Data.ByteString (ByteString)
import           Data.Semigroup (Semigroup((<>)))
import qualified Data.Set as S

import qualified Data.Riak.Proto as Proto
import           Network.Riak.CRDT.Types
import           Network.Riak.Lens

counterUpdateOp :: [CounterOp] -> Proto.DtOp
counterUpdateOp :: [CounterOp] -> DtOp
counterUpdateOp [CounterOp]
ops = DtOp
forall msg. Message msg => msg
Proto.defMessage DtOp -> (DtOp -> DtOp) -> DtOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity DtOp CounterOp
forall (f :: * -> *) s a.
(Functor f, HasField s "counterOp" a) =>
LensLike' f s a
Proto.counterOp LensLike' Identity DtOp CounterOp -> CounterOp -> DtOp -> DtOp
forall s a. Setter s a -> a -> s -> s
.~ [CounterOp] -> CounterOp
counterOpPB [CounterOp]
ops

counterOpPB :: [CounterOp] -> Proto.CounterOp
counterOpPB :: [CounterOp] -> CounterOp
counterOpPB [CounterOp]
ops = CounterOp
forall msg. Message msg => msg
Proto.defMessage CounterOp -> (CounterOp -> CounterOp) -> CounterOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity CounterOp Count
forall (f :: * -> *) s a.
(Functor f, HasField s "increment" a) =>
LensLike' f s a
Proto.increment LensLike' Identity CounterOp Count
-> Count -> CounterOp -> CounterOp
forall s a. Setter s a -> a -> s -> s
.~ Count
i
    where CounterInc Count
i = [CounterOp] -> CounterOp
forall a. Monoid a => [a] -> a
mconcat [CounterOp]
ops


data SetOpsComb = SetOpsComb { SetOpsComb -> Set ByteString
setAdds    :: S.Set ByteString,
                               SetOpsComb -> Set ByteString
setRemoves :: S.Set ByteString }
             deriving (Int -> SetOpsComb -> ShowS
[SetOpsComb] -> ShowS
SetOpsComb -> String
(Int -> SetOpsComb -> ShowS)
-> (SetOpsComb -> String)
-> ([SetOpsComb] -> ShowS)
-> Show SetOpsComb
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetOpsComb] -> ShowS
$cshowList :: [SetOpsComb] -> ShowS
show :: SetOpsComb -> String
$cshow :: SetOpsComb -> String
showsPrec :: Int -> SetOpsComb -> ShowS
$cshowsPrec :: Int -> SetOpsComb -> ShowS
Show)

instance Semigroup SetOpsComb where
    (SetOpsComb Set ByteString
a Set ByteString
b) <> :: SetOpsComb -> SetOpsComb -> SetOpsComb
<> (SetOpsComb Set ByteString
x Set ByteString
y) = Set ByteString -> Set ByteString -> SetOpsComb
SetOpsComb (Set ByteString
aSet ByteString -> Set ByteString -> Set ByteString
forall a. Semigroup a => a -> a -> a
<>Set ByteString
x) (Set ByteString
bSet ByteString -> Set ByteString -> Set ByteString
forall a. Semigroup a => a -> a -> a
<>Set ByteString
y)

instance Monoid SetOpsComb where
    mempty :: SetOpsComb
mempty = Set ByteString -> Set ByteString -> SetOpsComb
SetOpsComb Set ByteString
forall a. Monoid a => a
mempty Set ByteString
forall a. Monoid a => a
mempty
    (SetOpsComb Set ByteString
a Set ByteString
b) mappend :: SetOpsComb -> SetOpsComb -> SetOpsComb
`mappend` (SetOpsComb Set ByteString
x Set ByteString
y) = Set ByteString -> Set ByteString -> SetOpsComb
SetOpsComb (Set ByteString
aSet ByteString -> Set ByteString -> Set ByteString
forall a. Semigroup a => a -> a -> a
<>Set ByteString
x) (Set ByteString
bSet ByteString -> Set ByteString -> Set ByteString
forall a. Semigroup a => a -> a -> a
<>Set ByteString
y)

toOpsComb :: SetOp -> SetOpsComb
toOpsComb :: SetOp -> SetOpsComb
toOpsComb (SetAdd ByteString
s)    = Set ByteString -> Set ByteString -> SetOpsComb
SetOpsComb (ByteString -> Set ByteString
forall a. a -> Set a
S.singleton ByteString
s) Set ByteString
forall a. Set a
S.empty
toOpsComb (SetRemove ByteString
s) = Set ByteString -> Set ByteString -> SetOpsComb
SetOpsComb Set ByteString
forall a. Set a
S.empty (ByteString -> Set ByteString
forall a. a -> Set a
S.singleton ByteString
s)



setUpdateOp :: [SetOp] -> Proto.DtOp
setUpdateOp :: [SetOp] -> DtOp
setUpdateOp [SetOp]
ops = DtOp
forall msg. Message msg => msg
Proto.defMessage DtOp -> (DtOp -> DtOp) -> DtOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity DtOp SetOp
forall (f :: * -> *) s a.
(Functor f, HasField s "setOp" a) =>
LensLike' f s a
Proto.setOp LensLike' Identity DtOp SetOp -> SetOp -> DtOp -> DtOp
forall s a. Setter s a -> a -> s -> s
.~ [SetOp] -> SetOp
setOpPB [SetOp]
ops

setOpPB :: [SetOp] -> Proto.SetOp
setOpPB :: [SetOp] -> SetOp
setOpPB [SetOp]
ops = SetOp
forall msg. Message msg => msg
Proto.defMessage SetOp -> (SetOp -> SetOp) -> SetOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity SetOp [ByteString]
forall (f :: * -> *) s a.
(Functor f, HasField s "adds" a) =>
LensLike' f s a
Proto.adds LensLike' Identity SetOp [ByteString]
-> [ByteString] -> SetOp -> SetOp
forall s a. Setter s a -> a -> s -> s
.~ Set ByteString -> [ByteString]
forall a. Set a -> [a]
S.toList Set ByteString
adds
                               SetOp -> (SetOp -> SetOp) -> SetOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity SetOp [ByteString]
forall (f :: * -> *) s a.
(Functor f, HasField s "removes" a) =>
LensLike' f s a
Proto.removes LensLike' Identity SetOp [ByteString]
-> [ByteString] -> SetOp -> SetOp
forall s a. Setter s a -> a -> s -> s
.~ Set ByteString -> [ByteString]
forall a. Set a -> [a]
S.toList Set ByteString
rems
    where SetOpsComb Set ByteString
adds Set ByteString
rems = [SetOpsComb] -> SetOpsComb
forall a. Monoid a => [a] -> a
mconcat ([SetOpsComb] -> SetOpsComb)
-> ([SetOp] -> [SetOpsComb]) -> [SetOp] -> SetOpsComb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SetOp -> SetOpsComb) -> [SetOp] -> [SetOpsComb]
forall a b. (a -> b) -> [a] -> [b]
map SetOp -> SetOpsComb
toOpsComb ([SetOp] -> SetOpsComb) -> [SetOp] -> SetOpsComb
forall a b. (a -> b) -> a -> b
$ [SetOp]
ops

flagOpPB :: FlagOp -> Proto.MapUpdate'FlagOp
flagOpPB :: FlagOp -> MapUpdate'FlagOp
flagOpPB (FlagSet Bool
True)  = MapUpdate'FlagOp
Proto.MapUpdate'ENABLE
flagOpPB (FlagSet Bool
False) = MapUpdate'FlagOp
Proto.MapUpdate'DISABLE

registerOpPB :: RegisterOp -> ByteString
registerOpPB :: RegisterOp -> ByteString
registerOpPB (RegisterSet ByteString
x) = ByteString
x

mapUpdateOp :: [MapOp] -> Proto.DtOp
mapUpdateOp :: [MapOp] -> DtOp
mapUpdateOp [MapOp]
ops = DtOp
forall msg. Message msg => msg
Proto.defMessage DtOp -> (DtOp -> DtOp) -> DtOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity DtOp MapOp
forall (f :: * -> *) s a.
(Functor f, HasField s "mapOp" a) =>
LensLike' f s a
Proto.mapOp LensLike' Identity DtOp MapOp -> MapOp -> DtOp -> DtOp
forall s a. Setter s a -> a -> s -> s
.~ [MapOp] -> MapOp
mapOpPB [MapOp]
ops

mapOpPB :: [MapOp] -> Proto.MapOp
mapOpPB :: [MapOp] -> MapOp
mapOpPB [MapOp]
ops = MapOp
forall msg. Message msg => msg
Proto.defMessage MapOp -> (MapOp -> MapOp) -> MapOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity MapOp [MapField]
forall (f :: * -> *) s a.
(Functor f, HasField s "removes" a) =>
LensLike' f s a
Proto.removes LensLike' Identity MapOp [MapField] -> [MapField] -> MapOp -> MapOp
forall s a. Setter s a -> a -> s -> s
.~ [MapField]
rems
                               MapOp -> (MapOp -> MapOp) -> MapOp
forall a b. a -> (a -> b) -> b
& LensLike' Identity MapOp [MapUpdate]
forall (f :: * -> *) s a.
(Functor f, HasField s "updates" a) =>
LensLike' f s a
Proto.updates LensLike' Identity MapOp [MapUpdate]
-> [MapUpdate] -> MapOp -> MapOp
forall s a. Setter s a -> a -> s -> s
.~ [MapUpdate]
updates
    where rems :: [MapField]
rems    = [ MapField -> MapField
toRemove MapField
f   | MapRemove MapField
f <- [MapOp]
ops ]
          updates :: [MapUpdate]
updates = [ MapPath -> MapValueOp -> MapUpdate
toUpdate MapPath
f MapValueOp
u | MapUpdate MapPath
f MapValueOp
u <- [MapOp]
ops ]

toRemove :: MapField -> Proto.MapField
toRemove :: MapField -> MapField
toRemove (MapField MapEntryTag
t ByteString
name) = ByteString -> MapEntryTag -> MapField
toField ByteString
name MapEntryTag
t

toUpdate :: MapPath -> MapValueOp -> Proto.MapUpdate
toUpdate :: MapPath -> MapValueOp -> MapUpdate
toUpdate (MapPath (ByteString
e :| [])) MapValueOp
op     = ByteString -> MapEntryTag -> MapValueOp -> MapUpdate
toUpdate' ByteString
e (MapValueOp -> MapEntryTag
mapEntryTag MapValueOp
op) MapValueOp
op
toUpdate (MapPath (ByteString
e :| (ByteString
r:[ByteString]
rs))) MapValueOp
op = ByteString -> MapEntryTag -> MapValueOp -> MapUpdate
toUpdate' ByteString
e MapEntryTag
MapMapTag MapValueOp
op'
    where op' :: MapValueOp
op' = MapOp -> MapValueOp
MapMapOp (MapPath -> MapValueOp -> MapOp
MapUpdate (NonEmpty ByteString -> MapPath
MapPath (ByteString
rByteString -> [ByteString] -> NonEmpty ByteString
forall a. a -> [a] -> NonEmpty a
:|[ByteString]
rs)) MapValueOp
op)

toUpdate' :: ByteString -> MapEntryTag -> MapValueOp -> Proto.MapUpdate
toUpdate' :: ByteString -> MapEntryTag -> MapValueOp -> MapUpdate
toUpdate' ByteString
f MapEntryTag
t MapValueOp
op = MapValueOp -> MapUpdate -> MapUpdate
setSpecificOp MapValueOp
op (ByteString -> MapEntryTag -> MapUpdate
updateNothing ByteString
f MapEntryTag
t)

setSpecificOp :: MapValueOp -> Proto.MapUpdate -> Proto.MapUpdate
setSpecificOp :: MapValueOp -> MapUpdate -> MapUpdate
setSpecificOp (MapCounterOp CounterOp
cop)   = LensLike' Identity MapUpdate CounterOp
forall (f :: * -> *) s a.
(Functor f, HasField s "counterOp" a) =>
LensLike' f s a
Proto.counterOp LensLike' Identity MapUpdate CounterOp
-> CounterOp -> MapUpdate -> MapUpdate
forall s a. Setter s a -> a -> s -> s
.~ [CounterOp] -> CounterOp
counterOpPB [CounterOp
cop]
setSpecificOp (MapSetOp SetOp
sop)       = LensLike' Identity MapUpdate SetOp
forall (f :: * -> *) s a.
(Functor f, HasField s "setOp" a) =>
LensLike' f s a
Proto.setOp LensLike' Identity MapUpdate SetOp
-> SetOp -> MapUpdate -> MapUpdate
forall s a. Setter s a -> a -> s -> s
.~ [SetOp] -> SetOp
setOpPB [SetOp
sop]
setSpecificOp (MapRegisterOp RegisterOp
rop)  = LensLike' Identity MapUpdate ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "registerOp" a) =>
LensLike' f s a
Proto.registerOp LensLike' Identity MapUpdate ByteString
-> ByteString -> MapUpdate -> MapUpdate
forall s a. Setter s a -> a -> s -> s
.~ RegisterOp -> ByteString
registerOpPB RegisterOp
rop
setSpecificOp (MapFlagOp FlagOp
fop)      = LensLike' Identity MapUpdate MapUpdate'FlagOp
forall (f :: * -> *) s a.
(Functor f, HasField s "flagOp" a) =>
LensLike' f s a
Proto.flagOp LensLike' Identity MapUpdate MapUpdate'FlagOp
-> MapUpdate'FlagOp -> MapUpdate -> MapUpdate
forall s a. Setter s a -> a -> s -> s
.~ FlagOp -> MapUpdate'FlagOp
flagOpPB FlagOp
fop
setSpecificOp (MapMapOp MapOp
mop)       = LensLike' Identity MapUpdate MapOp
forall (f :: * -> *) s a.
(Functor f, HasField s "mapOp" a) =>
LensLike' f s a
Proto.mapOp LensLike' Identity MapUpdate MapOp
-> MapOp -> MapUpdate -> MapUpdate
forall s a. Setter s a -> a -> s -> s
.~ [MapOp] -> MapOp
mapOpPB [MapOp
mop]


updateNothing :: ByteString -> MapEntryTag -> Proto.MapUpdate
updateNothing :: ByteString -> MapEntryTag -> MapUpdate
updateNothing ByteString
f MapEntryTag
t = MapUpdate
forall msg. Message msg => msg
Proto.defMessage MapUpdate -> (MapUpdate -> MapUpdate) -> MapUpdate
forall a b. a -> (a -> b) -> b
& LensLike' Identity MapUpdate MapField
forall (f :: * -> *) s a.
(Functor f, HasField s "field" a) =>
LensLike' f s a
Proto.field LensLike' Identity MapUpdate MapField
-> MapField -> MapUpdate -> MapUpdate
forall s a. Setter s a -> a -> s -> s
.~ ByteString -> MapEntryTag -> MapField
toField ByteString
f MapEntryTag
t

toField :: ByteString -> MapEntryTag -> Proto.MapField
toField :: ByteString -> MapEntryTag -> MapField
toField ByteString
name MapEntryTag
t = MapField
forall msg. Message msg => msg
Proto.defMessage MapField -> (MapField -> MapField) -> MapField
forall a b. a -> (a -> b) -> b
& LensLike' Identity MapField ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Proto.name LensLike' Identity MapField ByteString
-> ByteString -> MapField -> MapField
forall s a. Setter s a -> a -> s -> s
.~ ByteString
name
                                  MapField -> (MapField -> MapField) -> MapField
forall a b. a -> (a -> b) -> b
& LensLike' Identity MapField MapField'MapFieldType
forall (f :: * -> *) s a.
(Functor f, HasField s "type'" a) =>
LensLike' f s a
Proto.type' LensLike' Identity MapField MapField'MapFieldType
-> MapField'MapFieldType -> MapField -> MapField
forall s a. Setter s a -> a -> s -> s
.~ MapEntryTag -> MapField'MapFieldType
typ MapEntryTag
t
    where typ :: MapEntryTag -> MapField'MapFieldType
typ MapEntryTag
MapCounterTag  = MapField'MapFieldType
Proto.MapField'COUNTER
          typ MapEntryTag
MapSetTag      = MapField'MapFieldType
Proto.MapField'SET
          typ MapEntryTag
MapRegisterTag = MapField'MapFieldType
Proto.MapField'REGISTER
          typ MapEntryTag
MapFlagTag     = MapField'MapFieldType
Proto.MapField'FLAG
          typ MapEntryTag
MapMapTag      = MapField'MapFieldType
Proto.MapField'MAP