module Data.VectorClock.Simple (
VectorClock,
empty, singleton, fromList,
null, size, member, lookup, toList,
insert, inc, incWithDefault,
delete,
combine, max,
Relation(..), relation, causes,
valid
) where
import Prelude hiding ( null, lookup, max )
import qualified Prelude
import Data.Binary ( Binary(..) )
import Data.List ( foldl', sort, nub )
import Data.Maybe ( isJust, catMaybes )
data VectorClock a b = VectorClock { clock :: [(a, b)] }
deriving ( Eq )
instance (Show a, Show b) => Show (VectorClock a b) where
show = show . clock
instance (Binary a, Binary b) => Binary (VectorClock a b) where
put = put . clock
get = get >>= \xys -> return (VectorClock { clock = xys })
data Relation = Causes | CausedBy | Concurrent
deriving (Eq, Show)
empty :: VectorClock a b
empty = VectorClock { clock = [] }
singleton :: (Ord a) => a -> b -> VectorClock a b
singleton x y = fromList [(x, y)]
fromList :: (Ord a) => [(a, b)] -> VectorClock a b
fromList = foldl' (\vc (x, y) -> insert x y vc) empty
toList :: VectorClock a b -> [(a, b)]
toList = clock
null :: VectorClock a b -> Bool
null = Prelude.null . clock
size :: VectorClock a b -> Int
size = length . clock
extract :: (Ord a) => a -> VectorClock a b -> (Maybe b, VectorClock a b)
extract x vc =
case span (\(x', _) -> x' < x) (clock vc) of
(_, []) ->
(Nothing, vc)
(xys, xys'@((x', y') : xys'')) ->
if x' == x
then (return y', vc { clock = xys ++ xys'' })
else (Nothing, vc { clock = xys ++ xys' })
lookup :: (Ord a) => a -> VectorClock a b -> Maybe b
lookup x = fst . extract x
member :: (Ord a) => a -> VectorClock a b -> Bool
member x = isJust . lookup x
delete :: (Ord a) => a -> VectorClock a b -> VectorClock a b
delete x = snd . extract x
insert :: (Ord a) => a -> b -> VectorClock a b -> VectorClock a b
insert x y vc = vc { clock = go (clock vc) }
where
go [] = [(x, y)]
go (xy@(x', _) : xys)
| x' < x = xy : go xys
| x' == x = (x, y) : xys
| otherwise = (x, y) : xy : xys
inc :: (Ord a, Num b) => a -> VectorClock a b -> Maybe (VectorClock a b)
inc x vc = lookup x vc >>= \y -> return (insert x (y + fromInteger 1) vc)
incWithDefault :: (Ord a, Num b)
=> a
-> VectorClock a b
-> b
-> VectorClock a b
incWithDefault x vc y' =
case lookup x vc of
Nothing -> insert x (y' + fromInteger 1) vc
Just y -> insert x (y + fromInteger 1) vc
combine :: (Ord a, Ord b)
=> (a -> Maybe b -> Maybe b -> Maybe b)
-> VectorClock a b
-> VectorClock a b
-> VectorClock a b
combine f vc1 vc2 =
VectorClock { clock = catMaybes (go (clock vc1) (clock vc2)) }
where
go [] xys = map (\(x, y) -> (x ~^ f x Nothing (Just y))) xys
go xys [] = map (\(x, y) -> (x ~^ f x (Just y) Nothing)) xys
go (xy@(x, y) : xys) (xy'@(x', y') : xys')
| x < x' = (x ~^ f x (Just y) Nothing) : go xys (xy' : xys')
| x == x' = (x ~^ f x (Just y) (Just y')) : go xys xys'
| otherwise = (x' ~^ f x' Nothing (Just y')) : go (xy : xys) xys'
(~^) x v = v >>= return . (x,)
max :: (Ord a, Ord b) => VectorClock a b -> VectorClock a b -> VectorClock a b
max = combine maxEntry
where
maxEntry _ Nothing Nothing = Nothing
maxEntry _ x@(Just _) Nothing = x
maxEntry _ Nothing y@(Just _) = y
maxEntry _ (Just x) (Just y) = Just (Prelude.max x y)
relation :: (Ord a, Ord b) => VectorClock a b -> VectorClock a b -> Relation
relation vc1 vc2 = go (clock vc1) (clock vc2)
where
go ((x, y) : xys) ((x', y') : xys')
| x == x' =
if y == y'
then go xys xys'
else if y < y'
then if checkCauses xys xys' then Causes else Concurrent
else if checkCauses xys' xys then CausedBy else Concurrent
| otherwise = Concurrent
go _ _ = Concurrent
checkCauses [] [] = True
checkCauses ((x, y) : xys) ((x', y') : xys')
| x == x' = if y <= y' then checkCauses xys xys' else False
| otherwise = False
checkCauses _ _ = False
causes :: (Ord a, Ord b) => VectorClock a b -> VectorClock a b -> Bool
causes vc1 vc2 = relation vc1 vc2 == Causes
valid :: (Ord a, Ord b) => VectorClock a b -> Bool
valid vc = let xys = clock vc
xysSorted = sort xys
xysNub = nub xys
in xys == xysSorted && xys == xysNub