Commits

Bryan O'Sullivan  committed 4f4db70

Add Eq and Show as constraints on Resolvable.

We need Eq to resolve some conflicts.

We somewhat reluctantly want Show so that if an unexpected conflict occurs, we
have a hope of being able to use the debug machinery to tell what's going on.

As an example case of unexpected conflict, consider serialising, then
deserialising, a Double, and hoping that each value still compares as equal to
the other (hint: they won't).

  • Participants
  • Parent commits 4057bca

Comments (0)

Files changed (1)

File src/Network/Riak/Resolvable/Internal.hs

 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
 -- \"winner\".
-class Resolvable a where
+class (Eq a, Show a) => Resolvable a where
     -- | Resolve a conflict between two values.
     resolve :: a -> a -> a
 
 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
     resolve = mappend
     {-# INLINE resolve #-}
 
        -> (Connection -> Bucket -> Key -> R -> IO (Maybe (a, VClock)))
 get doGet conn bucket key r =
     fmap (first resolveMany) `fmap` doGet conn bucket key r
+{-# INLINE get #-}
 
 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
+{-# INLINE getMany #-}
 
-put :: (Eq a, Resolvable a) =>
+put :: (Resolvable a) =>
        (Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
                    -> IO ([a], VClock))
     -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
         case xs of
           []             -> 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)
   go val0 mvclock0
+{-# INLINE put #-}
 
-put_ :: (Eq a, Resolvable a) =>
+put_ :: (Resolvable a) =>
         (Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
                     -> IO ([a], VClock))
      -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
     put doPut conn bucket key mvclock0 val0 w dw >> return ()
 {-# INLINE put_ #-}
 
-putMany :: (Eq a, Resolvable a) =>
+putMany :: (Resolvable a) =>
            (Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
                        -> IO [([a], VClock)])
         -> 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
     go (ok++acc) conflicts
   mush (i,(k,_,c)) (cs,v) =
       case cs of
         []           -> Right (i,(c,v)) -- not observed in the wild
         [x] | x == c -> Right (i,(c,v))
         _            -> Left (i,(k,Just v, resolveMany' c cs))
+{-# INLINE putMany #-}
 
-putMany_ :: (Eq a, Resolvable a) =>
+putMany_ :: (Resolvable a) =>
             (Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
                         -> IO [([a], VClock)])
          -> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()
 {-# INLINE putMany_ #-}
 
 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 #-}