{-# 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(foldMap), foldl' )
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