{-# LANGUAGE Safe, TupleSections, DeriveDataTypeable, DeriveGeneric #-} -- | A vector clock implementation in terms of simply-linked lists. module Data.VectorClock.Simple ( -- * Usage example -- $example -- * Vector clock type VectorClock, -- * Construction empty, singleton, fromList, -- * Query null, size, member, lookup, toList, -- * Insertion insert, inc, incWithDefault, -- * Deletion delete, -- * Merges combine, max, diff, -- * Relations Relation(..), relation, causes, -- * Debugging valid ) where import Prelude hiding ( null, lookup, max ) import qualified Prelude import Control.Applicative ( (<$>) ) import Data.Binary ( Binary(..) ) import Data.Data ( Data, Typeable ) import Data.Foldable ( Foldable(..) ) import Data.Traversable ( Traversable(..) ) import Data.List ( sort, nub ) import Data.Maybe ( isJust, catMaybes ) import GHC.Generics ( Generic ) -- $example -- -- To create a vector clock, start from 'empty' and 'insert' elements -- into it. As a shortcut, 'fromList' just inserts all the elements -- in a list, in order. -- -- > let vc = empty in -- > let vc' = insert 'a' 1 vc in -- > let vc'' = insert 'b' 2 vc in -- > vc'' == fromList [('a', 1), ('b', 2)] -- -- Note that, /for different keys/, the order of insertion does not -- matter: -- -- > fromList [('a', 1), ('b', 2)] == fromList [('b', 2), ('a', 1)] -- -- Once you have a given vector clock, you can 'lookup' its fields, -- check that keys are 'member's, or convert it back 'toList' form. -- -- > lookup 'a' [('a', 1), ('b', 2)] == Just 1 -- > lookup 'c' [('a', 1), ('b', 2)] == Nothing -- -- The main operations that you would do with a vector clcok are to -- 'inc'crement the entry corresponding to the current process and to -- update the process's vector clock with the 'max' of its and the -- received message's clocks. -- -- > inc 'a' [('a', 1), ('b', 2)] = Just [('a', 2), ('b', 2)] -- > max [('a', 1), ('b', 2)] [('c', 3), ('b', 1)] == [('a', 1), ('b', 2), ('c' 3)] -- -- Finally, upon receiving different messages, you may wish to -- discover the 'relation'ship, if any, between them. This -- information could be useful in determining the correct order to -- process the messages. -- -- > relation (fromList [('a', 1), ('b', 2)]) (fromList [('a', 2), ('b', 2)]) == Causes -- > relation (fromList [('a', 2), ('b', 2)]) (fromList [('a', 1), ('b', 2)]) == CausedBy -- > relation (fromList [('a', 2), ('b', 2)]) (fromList [('a', 1), ('b', 3)]) == Concurrent -- -- In order to send and receive vector clocks, they must first be -- serialized. For this purpose, there is a 'Binary' instance for -- 'VectorClock'. Additionally, there are 'Data', 'Typeable', and -- 'Generic' instances, which allow packages such as @cereal@, and -- @sexp@ to automatically generate serializers and deserializers. -- | 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, Data, Generic, Typeable ) 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 }) instance Foldable (VectorClock a) where foldMap f = foldMap f . map snd . clock instance Functor (VectorClock a) where fmap f vc = vc { clock = map (\(x, y) -> (x, f y)) (clock vc) } instance Traversable (VectorClock a) where traverse f vc = let f' (x, y) = (x,) <$> f y in (\xys -> vc { clock = xys }) <$> traverse f' (clock vc) -- | The relations two vector clocks may find themselves in. data Relation = Causes | CausedBy | Concurrent deriving (Eq, Show) -- | /O(1)/. The empty vector clock. empty :: VectorClock a b empty = VectorClock { clock = [] } -- | /O(1)/. A vector clock with a single element. singleton :: (Ord a) => a -> b -> VectorClock a b singleton x y = fromList [(x, y)] -- | /O(N)/. 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 -- | /O(1)/. All the entries in the vector clock. Note that this is -- /not/ the inverse of 'fromList'. toList :: VectorClock a b -> [(a, b)] toList = clock -- | /O(1)/. Is the vector clock empty? null :: VectorClock a b -> Bool null = Prelude.null . clock -- | /O(N)/. The number of entries in the vector clock. size :: VectorClock a b -> Int size = length . clock -- | /O(N)/. 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') : xys'')) -> if x' == x then (return y', vc { clock = xys ++ xys'' }) else (Nothing, vc { clock = xys ++ xys' }) -- | /O(N)/. Lookup the value for a key in the vector clock. lookup :: (Ord a) => a -> VectorClock a b -> Maybe b lookup x = fst . extract x -- | /O(N)/. 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 -- | /O(N)/. 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 -- | /O(N)/. Insert or replace the entry for a key. 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 -- | /O(N)/. Increment the entry for a key. 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) -- | /O(N)/. Increment the entry for a key. If the key does not -- exist, assume it was the default. incWithDefault :: (Ord a, Num b) => a -- ^ /key/: the key of the entry -> VectorClock a b -- ^ /vc/: the vector clock -> b -- ^ /default/: if the key is not -- found, assume its value was the -- /default/ and increment that -> 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 -- | /O(max(N, M))/. Combine two vector clocks entry-by-entry. combine :: (Ord a, Ord b) => (a -> Maybe b -> Maybe b -> Maybe b) -- ^ a function that takes the /key/, the value of the entry in -- the left hand vector clock, if it exists, the value in the -- right hand vector clock, if it exists, and, if it wishes to -- keep a value for this /key/ in the resulting vector clock, -- returns it. -> VectorClock a b -- ^ /lhs/: the left hand vector clock -> VectorClock a b -- ^ /rhs/: the right hand vector clock -> 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,) -- | /O(max(N, M))/. 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) -- | /O(min(N, M))/. 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 xys@((x, y) : xyt) xys'@((x', y') : xyt') | x == x' = if y == y' then go xyt xyt' else if y < y' then if checkCauses xyt xyt' then Causes else Concurrent else if checkCauses xyt' xyt then CausedBy else Concurrent | x < x' = if checkCauses xys' xyt then CausedBy else Concurrent | x > x' = if checkCauses xys xyt' then Causes else Concurrent | otherwise = Concurrent go [] _ = Causes go _ [] = CausedBy checkCauses xys@((x, y) : xyt) ((x', y') : xyt') | x == x' = if y <= y' then checkCauses xyt xyt' else False | x < x' = False | otherwise = checkCauses xys xyt' checkCauses [] _ = True checkCauses _ _ = False -- | /O(min(N, M))/. Short-hand for @relation vc1 vc2 == Causes@. causes :: (Ord a, Ord b) => VectorClock a b -> VectorClock a b -> Bool causes vc1 vc2 = relation vc1 vc2 == Causes -- | /O(M)/. If @vc2 `causes` vc1@, compute the smallest @vc3@ -- s.t. @max vc3 vc2 == vc1@. Note that the /first/ parameter is the -- newer vector clock. diff :: (Ord a, Ord b) => VectorClock a b -> VectorClock a b -> Maybe (VectorClock a b) diff vc1 vc2 = if vc1 == vc2 then Just (fromList []) else if vc2 `causes` vc1 then Just (combine diffOne vc1 vc2) else Nothing where diffOne _ Nothing Nothing = Nothing diffOne _ x Nothing = x diffOne _ (Just x) (Just y) = if x == y then Nothing else Just x diffOne _ Nothing (Just _) = error "diff broken" -- | /O(N)/. 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