{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE LambdaCase #-}
#endif /* __GLASGOW_HASKELL__ >= 800 */
module CRDT.LWW
( LWW (..)
, initialize
, assign
, query
, advanceFromLWW
) where
import Data.Semigroup (Semigroup, (<>))
import Data.Semilattice (Semilattice)
#if __GLASGOW_HASKELL__ >= 800
import CRDT.Cm (CausalOrd (..), CmRDT (..))
#endif /* __GLASGOW_HASKELL__ >= 800 */
import CRDT.LamportClock (Clock, LamportTime (LamportTime), advance,
getTime)
data LWW a = LWW
{ value :: !a
, time :: !LamportTime
}
deriving (Eq, Show)
instance Eq a => Semigroup (LWW a) where
x@(LWW xv xt) <> y@(LWW yv yt)
| xt < yt = y
| yt < xt = x
| xv == yv = x
| otherwise = error "LWW assumes timestamps to be unique"
instance Eq a => Semilattice (LWW a)
initialize :: Clock m => a -> m (LWW a)
initialize value = LWW value <$> getTime
assign :: Clock m => a -> LWW a -> m (LWW a)
assign value old = do
advanceFromLWW old
initialize value
query :: LWW a -> a
query = value
#if __GLASGOW_HASKELL__ >= 800
instance CausalOrd (LWW a) where
precedes _ _ = False
instance Eq a => CmRDT (LWW a) where
type Intent (LWW a) = a
type Payload (LWW a) = Maybe (LWW a)
initial = Nothing
makeOp value = Just . \case
Just payload -> assign value payload
Nothing -> initialize value
apply op = Just . \case
Just payload -> op <> payload
Nothing -> op
#endif /* __GLASGOW_HASKELL__ >= 800 */
advanceFromLWW :: Clock m => LWW a -> m ()
advanceFromLWW LWW{time = LamportTime time _} = advance time