{-# LANGUAGE TupleSections #-} module Data.VectorClock ( -- * Vector clock type VectorClock, -- * Construction empty, singleton, fromList, -- * Query null, size, member, lookup, -- * Insertion insert, -- * Delete delete, -- * Merges combine, max, -- * Relations relation, -- * Debugging 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 ) -- | A vector clock is, conceptually, an associtive list sorted by the -- value of the key, where each key appears only once. data VectorClock a b = VectorClock { clock :: [(a, b)] } deriving ( Eq ) instance (Show a, Show b) => Show (VectorClock a b) where show vc = show (clock vc) instance (Binary a, Binary b) => Binary (VectorClock a b) where put vc = put (clock vc) get = get >>= \xys -> return (VectorClock { clock = xys }) -- | The relations two vector clocks may find themselves in. data Relation = Causes | CausedBy | Concurrent deriving (Eq, Show) -- | The empty vector clock. empty :: VectorClock a b empty = VectorClock { clock = [] } -- | A vector clock with a single element. singleton :: a -> b -> VectorClock a b singleton x y = VectorClock { clock = [(x, y)] } -- | Insert each entry in the list one at a time. fromList :: (Ord a) => [(a, b)] -> VectorClock a b fromList = foldl' (\vc (x, y) -> insert x y vc) empty -- | Is the vector clock empty? null :: VectorClock a b -> Bool null = Prelude.null . clock -- | The number of entries in the vector clock. size :: VectorClock a b -> Int size = length . clock -- | Lookup the value for a key in the vector clock and remove the -- corresponding entry. 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') : _)) -> ( if x' == x then Just y' else Nothing , vc { clock = xys ++ xys' } ) -- | Lookup the value for a key in the vector clock. lookup :: (Ord a) => a -> VectorClock a b -> Maybe b lookup x = fst . extract x -- | Is the given key a key in an entry of the vector clock? member :: (Ord a) => a -> VectorClock a b -> Bool member x = isJust . lookup x -- | Delete an entry from the vector clock. If the requested entry -- does not exist, does nothing. delete :: (Ord a) => a -> VectorClock a b -> VectorClock a b delete x = snd . extract x -- | Insert or replace the entry for a key. insert :: (Ord a) => a -> b -> VectorClock a b -> VectorClock a b insert x y vc = let xys' = go (clock vc) in vc { clock = reverse xys' } where go [] = [] go (xy@(x', _) : xys) | x' < x = xy : go xys | x' == x = (x, y) : xys | otherwise = xy : xys -- | Combine two vector clocks entry-by-entry. 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,) -- | The maximum of the two vector clocks. 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) -- | The relation between the two vector clocks. relation :: (Ord a, Ord b) => VectorClock a b -> VectorClock a b -> Relation relation vc1 vc2 = go (clock vc1) (clock vc2) where go [] _ = Concurrent go _ [] = Concurrent go (xy@(x, y) : xys) (xy'@(x', y') : xys') | x < x' = go xys (xy' : xys') | x == x' = (if y < y' then checkCausedBy else checkCauses) xys xys' | otherwise = go (xy : xys) xys' checkCauses _ [] = Causes checkCauses [] _ = Causes checkCauses (xy@(x, y) : xys) (xy'@(x', y') : xys') | x < x' = checkCauses xys (xy' : xys') | x == x' = if y > y' then checkCauses xys xys' else Concurrent | otherwise = checkCauses (xy : xys) xys' checkCausedBy _ [] = CausedBy checkCausedBy [] _ = CausedBy checkCausedBy (xy@(x, y) : xys) (xy'@(x', y') : xys') | x < x' = checkCauses xys (xy' : xys') | x == x' = if y < y' then checkCauses xys xys' else Concurrent | otherwise = checkCauses (xy : xys) xys' -- | Check whether the vector clock is valid or not. 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