import Data.List (foldl', sortBy)

import Data.Monoid (Monoid(mappend))

import Data.Typeable (Typeable)

-import Network.Riak.Debug (debug)

+import Network.Riak.Debug (debugValues)

import Network.Riak.Types.Internal hiding (MessageTag(..))

-- | A type that can automatically resolve a vector clock conflict

-- If several conflicting siblings are found, 'resolve' will be

-- applied over all of them using a fold, to yield a single

-class Resolvable a where

+class (Eq a, Show a) => Resolvable a where

-- | Resolve a conflict between two values.

newtype ResolvableMonoid a = RM { unRM :: a }

deriving (Eq, Ord, Read, Show, Typeable, Data, Monoid, FromJSON, ToJSON)

-instance (Monoid a) => Resolvable (ResolvableMonoid a) where

+instance (Eq a, Show a, Monoid a) => Resolvable (ResolvableMonoid a) where

-> (Connection -> Bucket -> Key -> R -> IO (Maybe (a, VClock)))

get doGet conn bucket key r =

fmap (first resolveMany) `fmap` doGet conn bucket key r

getMany :: (Resolvable a) =>

(Connection -> Bucket -> [Key] -> R -> IO [Maybe ([a], VClock)])

-> Connection -> Bucket -> [Key] -> R -> IO [Maybe (a, VClock)]

-getMany doGet conn b ks r = map (fmap (first resolveMany)) `fmap` doGet conn b ks r

+getMany doGet conn b ks r =

+ map (fmap (first resolveMany)) `fmap` doGet conn b ks r

-put :: (~~Eq a, ~~Resolvable a) =>

+put :: (Resolvable a) =>

(Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW

-> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW

[] -> return (val, vclock) -- not observed in the wild

[v] | v == val -> return (val, vclock)

- ys -> do debug "put" "conflict"

+ ys -> do debugValues "put" "conflict" ys

go (resolveMany' val ys) (Just vclock)

-put_ :: (~~Eq a, ~~Resolvable a) =>

+put_ :: (Resolvable a) =>

(Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW

-> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW

put doPut conn bucket key mvclock0 val0 w dw >> return ()

-putMany :: (~~Eq a, ~~Resolvable a) =>

+putMany :: (Resolvable a) =>

(Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW

-> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW

rs <- doPut conn bucket (map snd puts) w dw

let (conflicts, ok) = partitionEithers $ zipWith mush puts rs

unless (null conflicts) $

- debug "putMany" ~~$ show (length ~~conflicts~~) ++ ~~" conflicts~~"~~

+ debugValues "putMany" "conflicts" conflicts

mush (i,(k,_,c)) (cs,v) =

[] -> Right (i,(c,v)) -- not observed in the wild

[x] | x == c -> Right (i,(c,v))

_ -> Left (i,(k,Just v, resolveMany' c cs))

-putMany_ :: (~~Eq a, ~~Resolvable a) =>

+putMany_ :: (Resolvable a) =>

(Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW

-> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()

resolveMany' :: (Resolvable a) => a -> [a] -> a

-resolveMany' a as = foldl' resolve a as

+resolveMany' = foldl' resolve

+{-# INLINE resolveMany' #-}

resolveMany :: (Resolvable a) => [a] -> a

resolveMany (a:as) = resolveMany' a as

resolveMany _ = error "resolveMany: empty list"

+{-# INLINE resolveMany #-}