Merge pull request #4 from kadena-io/lars/has-cas-lookup

Add HasCasLookup

vendored/chainweb-storage/src/Data/CAS.hs

@@ -21,8 +21,10 @@
 --
 module Data.CAS
 ( IsCasValue(..)
+, HasCasLookup(..)
 , IsCas(..)
 , casLookupM
+, HasCasLookupConstraint
 , CasConstraint
 ) where
 
@@ -50,20 +52,41 @@ class Eq (CasKeyType v) => IsCasValue v where
     type CasKeyType v
     casKey :: v -> CasKeyType v
 
--- | Content Addressed Key-Value Stores
+-- | Read-Only View of a Content Addressed Key-Value Store
 --
 -- Since the key uniquely determines the content of the store a value for a key
 -- is either available or not available. There is no dispute about the value
--- itself. Thus there are only 'casInsert' and 'casDelete' functions but there
--- is no @casUpdate@ function.
+-- itself.
 --
-class IsCasValue (CasValueType a) => IsCas a where
+class IsCasValue (CasValueType a) => HasCasLookup a where
     type CasValueType a :: Type
 
     -- | Lookup a value in a content-addressable store
     --
     casLookup :: a -> CasKeyType (CasValueType a) -> IO (Maybe (CasValueType a))
 
+    -- | Lookup a batch of values in a content-addressable store
+    --
+    casLookupBatch :: a -> V.Vector (CasKeyType (CasValueType a)) -> IO (V.Vector (Maybe (CasValueType a)))
+    casLookupBatch = traverse . casLookup
+    {-# INLINE casLookupBatch #-}
+
+    -- | Check for the existence of a value in a content addressable store
+    --
+    casMember :: a -> CasKeyType (CasValueType a) -> IO Bool
+    casMember db = fmap isJust . casLookup db
+    {-# INLINE casMember #-}
+
+
+-- | Content Addressed Key-Value Stores
+--
+-- Since the key uniquely determines the content of the store a value for a key
+-- is either available or not available. There is no dispute about the value
+-- itself. Thus there are only 'casInsert' and 'casDelete' functions but there
+-- is no @casUpdate@ function.
+--
+class HasCasLookup a => IsCas a where
+
     -- | Insert a value into a content-addressasble store
     --
     casInsert :: a -> CasValueType a -> IO ()
@@ -72,12 +95,6 @@ class IsCasValue (CasValueType a) => IsCas a where
     --
     casDelete :: a -> CasKeyType (CasValueType a) -> IO ()
 
-    -- | Lookup a batch of values in a content-addressable store
-    --
-    casLookupBatch :: a -> V.Vector (CasKeyType (CasValueType a)) -> IO (V.Vector (Maybe (CasValueType a)))
-    casLookupBatch = traverse . casLookup
-    {-# INLINE casLookupBatch #-}
-
     -- | Insert a batch of values into a content-addressasble store
     --
     casInsertBatch :: a -> V.Vector (CasValueType a) -> IO ()
@@ -90,17 +107,11 @@ class IsCasValue (CasValueType a) => IsCas a where
     casDeleteBatch = traverse_ . casDelete
     {-# INLINE casDeleteBatch #-}
 
-    -- | Check for the existence of a value in a content addressable store
-    --
-    casMember :: a -> CasKeyType (CasValueType a) -> IO Bool
-    casMember db = fmap isJust . casLookup db
-    {-# INLINE casMember #-}
-
 -- | Lookup a value by its key in a content-addressable store and throw an
 -- 'CasException' if the value doesn't exist in the store
 --
 casLookupM
-    :: IsCas a
+    :: HasCasLookup a
     => a -> CasKeyType (CasValueType a) -> IO (CasValueType a)
 casLookupM cas k = casLookup cas k >>= \case
     Nothing -> throwM . CasException $
@@ -114,8 +125,13 @@ data CasException = CasException Text |  CasImplementationException SomeExceptio
 
 instance Exception CasException
 
--- | @CasConstraint cas x@ asserts that @cas@ is an instance if 'IsCas' with
+-- | @HasCasLookupConstraint cas x@ asserts that @cas x@ is an instance if
+-- 'HasCasLookup' with value type 'x'.
+--
+type HasCasLookupConstraint cas x = (HasCasLookup (cas x), CasValueType (cas x) ~ x)
+
+-- | @CasConstraint cas x@ asserts that @cas x@ is an instance if 'IsCas' with
 -- value type 'x'.
 --
-type CasConstraint cas x = (IsCas (cas x), CasValueType (cas x) ~ x)
+type CasConstraint cas x = (HasCasLookupConstraint cas x, IsCas (cas x))
 

vendored/chainweb-storage/src/Data/CAS/Forgetful.hs

@@ -19,9 +19,14 @@ import Data.CAS
 --
 data ForgetfulCas a = ForgetfulCas
 
-instance IsCasValue a => IsCas (ForgetfulCas a) where
+instance IsCasValue a => HasCasLookup (ForgetfulCas a) where
     type CasValueType (ForgetfulCas a) = a
     casLookup _ _ = return Nothing
+    {-# INLINE casLookup #-}
+
+instance IsCasValue a => IsCas (ForgetfulCas a) where
     casInsert _ _ = return ()
     casDelete _ _ = return ()
+    {-# INLINE casInsert #-}
+    {-# INLINE casDelete #-}
 

vendored/chainweb-storage/src/Data/CAS/HashMap.hs

@@ -36,16 +36,20 @@ import Data.CAS
 --
 data HashMapCas v = IsCasValue v => HashMapCas !(TVar (HM.HashMap (CasKeyType v) v))
 
-instance (Show (CasKeyType v), Hashable (CasKeyType v), IsCasValue v) => IsCas (HashMapCas v) where
+instance (Show (CasKeyType v), Hashable (CasKeyType v), IsCasValue v) => HasCasLookup (HashMapCas v) where
     type CasValueType (HashMapCas v) = v
     casLookup (HashMapCas var) k = HM.lookup k <$!> readTVarIO var
+    {-# INLINE casLookup #-}
+
+instance (Show (CasKeyType v), Hashable (CasKeyType v), IsCasValue v) => IsCas (HashMapCas v) where
     casInsert cas@(HashMapCas var) a = casLookup cas (casKey a) >>= \case
         Just _ -> return ()
         Nothing -> atomically $ modifyTVar' var $ HM.insert (casKey a) a
     casDelete cas@(HashMapCas var) k = casLookup cas k >>= \case
         Nothing -> return ()
         Just _ -> atomically $ modifyTVar' var $ HM.delete k
-
+    {-# INLINE casInsert #-}
+    {-# INLINE casDelete #-}
 
 -- | Create new empty CAS
 --

vendored/chainweb-storage/src/Data/CAS/RocksDB.hs

@@ -568,12 +568,17 @@ tableMinEntry = flip withTableIter $ \i -> tableIterFirst i *> tableIterEntry i
 -- CAS
 
 -- | For a 'IsCasValue' @v@ with 'CasKeyType v ~ k@,  a 'RocksDbTable k v' is an
--- instance of 'IsCas'.
+-- instance of 'HasCasLookup'.
 --
-instance (IsCasValue v, CasKeyType v ~ k) => IsCas (RocksDbTable k v) where
+instance (IsCasValue v, CasKeyType v ~ k) => HasCasLookup (RocksDbTable k v) where
     type CasValueType (RocksDbTable k v) = v
-
     casLookup = tableLookup
+    {-# INLINE casLookup #-}
+
+-- | For a 'IsCasValue' @v@ with 'CasKeyType v ~ k@,  a 'RocksDbTable k v' is an
+-- instance of 'IsCas'.
+--
+instance (IsCasValue v, CasKeyType v ~ k) => IsCas (RocksDbTable k v) where
     casInsert db a = tableInsert db (casKey a) a
     casDelete = tableDelete
 
@@ -583,7 +588,6 @@ instance (IsCasValue v, CasKeyType v ~ k) => IsCas (RocksDbTable k v) where
 
     casDeleteBatch db vs = updateBatch (RocksDbDelete db <$> V.toList vs)
 
-    {-# INLINE casLookup #-}
     {-# INLINE casInsert #-}
     {-# INLINE casDelete #-}
     {-# INLINE casInsertBatch #-}
@@ -596,16 +600,17 @@ instance (IsCasValue v, CasKeyType v ~ k) => IsCas (RocksDbTable k v) where
 --
 newtype RocksDbCas v = RocksDbCas { _getRocksDbCas :: RocksDbTable (CasKeyType v) v }
 
-instance IsCasValue v => IsCas (RocksDbCas v) where
+instance IsCasValue v => HasCasLookup (RocksDbCas v) where
     type CasValueType (RocksDbCas v) = v
-
     casLookup (RocksDbCas x) = casLookup x
+    {-# INLINE casLookup #-}
+
+instance IsCasValue v => IsCas (RocksDbCas v) where
     casInsert (RocksDbCas x) = casInsert x
     casDelete (RocksDbCas x) = casDelete x
     casInsertBatch (RocksDbCas x) = casInsertBatch x
     casDeleteBatch (RocksDbCas x) = casDeleteBatch x
 
-    {-# INLINE casLookup #-}
     {-# INLINE casInsert #-}
     {-# INLINE casDelete #-}
     {-# INLINE casInsertBatch #-}