{-# 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