Merge pull request #7 from input-output-hk/model-monoid
Model monoid
Model monoid
Data.Map.Range
Database.LSMTree
Database.LSMTree.Common
Database.LSMTree.Model.Monoidal
Database.LSMTree.Model.Normal
Database.LSMTree.Monoidal
Database.LSMTree.Normal
other-modules: Database.LSMTree.Model.Common
build-depends:
, base >=4.14 && <4.19
, bytestring
main-is: Main.hs
other-modules:
Test.Database.LSMTree
Test.Database.LSMTree.Model.Monoidal
Test.Database.LSMTree.Model.Normal
build-depends:
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Database.LSMTree.Model.Common (
SomeSerialisationConstraint (..)
, SomeUpdateConstraint (..)
) where
import qualified Data.ByteString as BS
class SomeSerialisationConstraint a where
serialise :: a -> BS.ByteString
-- Note: cannot fail.
deserialise :: BS.ByteString -> a
instance SomeSerialisationConstraint BS.ByteString where
serialise = id
deserialise = id
class SomeUpdateConstraint a where
merge :: a -> a -> a
instance SomeUpdateConstraint BS.ByteString where
merge = (<>)
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-- lookup has redundant update constraint.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-- |
--
-- This module is intended to be imported qualified.
--
-- > import qualified Database.LSMTree.Monoidal as LSMT
module Database.LSMTree.Model.Monoidal (
-- * Temporary placeholder types
SomeSerialisationConstraint (..)
, SomeUpdateConstraint (..)
-- * Tables
, Table
, empty
-- * Table querying and updates
-- ** Queries
, Range
, LookupResult (..)
, lookups
, RangeLookupResult (..)
, rangeLookup
-- ** Updates
, Update (..)
, updates
, inserts
, deletes
, mupserts
-- * Snapshots
, snapshot
-- * Multiple writable table handles
, duplicate
-- * Merging tables
, mergeTables
) where
import Data.Bifunctor (second)
import qualified Data.ByteString as BS
import Data.Foldable (foldl')
import Data.Map (Map)
import qualified Data.Map.Range as Map.R
import qualified Data.Map.Strict as Map
import Database.LSMTree.Model.Common
(SomeSerialisationConstraint (..),
SomeUpdateConstraint (..))
import Database.LSMTree.Normal (Range (..))
import GHC.Exts (IsList (..))
{-------------------------------------------------------------------------------
Tables
-------------------------------------------------------------------------------}
data Table k v = Table
{ _values :: Map BS.ByteString BS.ByteString
}
type role Table nominal nominal
-- | An empty table.
empty :: Table k v
empty = Table Map.empty
-- | This instance is for testing and debugging only.
instance
( SomeSerialisationConstraint k
, SomeSerialisationConstraint v
) => IsList (Table k v)
where
type Item (Table k v) = (k, v)
fromList xs = Table $ Map.fromList
[ (serialise k, serialise v)
| (k, v) <- xs
]
toList (Table m) =
[ (deserialise k, deserialise v)
| (k, v) <- Map.toList m
]
-- | This instance is for testing and debugging only.
instance Show (Table k v) where
showsPrec d (Table tbl) = showParen (d > 10)
$ showString "fromList "
. showsPrec 11 (toList (Table @BS.ByteString @BS.ByteString tbl))
-- | This instance is for testing and debugging only.
deriving instance Eq (Table k v)
{-------------------------------------------------------------------------------
Table querying and updates
-------------------------------------------------------------------------------}
-- | Result of a single point lookup.
data LookupResult k v =
NotFound !k
| Found !k !v
deriving (Eq, Show)
-- | Perform a batch of lookups.
--
-- Lookups can be performed concurrently from multiple Haskell threads.
lookups ::
( SomeSerialisationConstraint k
, SomeSerialisationConstraint v
, SomeUpdateConstraint v
)
=> [k]
-> Table k v
-> [LookupResult k v]
lookups ks tbl =
[ case Map.lookup (serialise k) (_values tbl) of
Nothing -> NotFound k
Just v -> Found k (deserialise v)
| k <- ks
]
-- | A result for one point in a range lookup.
data RangeLookupResult k v =
FoundInRange !k !v
deriving (Eq, Show)
-- | Perform a range lookup.
--
-- Range lookups can be performed concurrently from multiple Haskell threads.
rangeLookup :: forall k v.
( SomeSerialisationConstraint k
, SomeSerialisationConstraint v
, SomeUpdateConstraint v
)
=> Range k
-> Table k v
-> [RangeLookupResult k v]
rangeLookup r tbl =
[ FoundInRange (deserialise k) (deserialise v)
| let (ub, lb) = convertRange r
, (k, v) <- Map.R.rangeLookup lb ub (_values tbl)
]
where
convertRange :: Range k -> (Map.R.Bound BS.ByteString, Map.R.Bound BS.ByteString)
convertRange (FromToExcluding lb ub) =
( Map.R.Bound (serialise lb) Map.R.Inclusive
, Map.R.Bound (serialise ub) Map.R.Exclusive )
convertRange (FromToIncluding lb ub) =
( Map.R.Bound (serialise lb) Map.R.Inclusive
, Map.R.Bound (serialise ub) Map.R.Inclusive )
-- | Normal tables support insert, delete and monoidal upsert operations.
--
-- An __update__ is a term that groups all types of table-manipulating
-- operations, like inserts and deletes.
data Update v =
Insert !v
| Delete
-- | TODO: should be given a more suitable name.
| Mupsert !v
deriving (Eq, Show)
-- | Perform a mixed batch of inserts, deletes and monoidal upserts.
--
-- Updates can be performed concurrently from multiple Haskell threads.
updates :: forall k v.
( SomeSerialisationConstraint k
, SomeSerialisationConstraint v
, SomeUpdateConstraint v
)
=> [(k, Update v)]
-> Table k v
-> Table k v
updates ups tbl0 = foldl' update tbl0 ups where
update :: Table k v -> (k, Update v) -> Table k v
update tbl (k, Delete) = tbl
{ _values = Map.delete (serialise k) (_values tbl) }
update tbl (k, Insert v) = tbl
{ _values = Map.insert (serialise k) (serialise v) (_values tbl) }
update tbl (k, Mupsert v) = tbl
{ _values = mapUpsert (serialise k) (serialise v) f (_values tbl) }
where
f old = serialise (merge v (deserialise old))
mapUpsert :: Ord k => k -> v -> (v -> v) -> Map k v -> Map k v
mapUpsert k v f = Map.alter (Just . g) k where
g Nothing = v
g (Just v') = f v'
-- | Perform a batch of inserts.
--
-- Inserts can be performed concurrently from multiple Haskell threads.
inserts ::
( SomeSerialisationConstraint k
, SomeSerialisationConstraint v
, SomeUpdateConstraint v
import Data.Map (Map)
import qualified Data.Map.Range as Map.R
import qualified Data.Map.Strict as Map
import Database.LSMTree.Model.Common
(SomeSerialisationConstraint (..))
import Database.LSMTree.Normal (Range (..))
import GHC.Exts (IsList (..))
{-------------------------------------------------------------------------------
Temporary placeholder types
-------------------------------------------------------------------------------}
class SomeSerialisationConstraint a where
serialise :: a -> BS.ByteString
-- Note: cannot fail.
deserialise :: BS.ByteString -> a
instance SomeSerialisationConstraint BS.ByteString where
serialise = id
deserialise = id
{-------------------------------------------------------------------------------
Tables
-------------------------------------------------------------------------------}
module Main (main) where
import Test.Database.LSMTree (tests)
import qualified Test.Database.LSMTree.Model.Monoidal
import qualified Test.Database.LSMTree.Model.Normal
import Test.Tasty
main :: IO ()
main = defaultMain $ testGroup "lsm-tree"
[ tests
, Test.Database.LSMTree.Model.Normal.tests
, Test.Database.LSMTree.Model.Monoidal.tests
]
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Database.LSMTree.Model.Monoidal (tests) where
import qualified Data.ByteString as BS
import Database.LSMTree.Model.Monoidal
import GHC.Exts (IsList (..))
import Test.QuickCheck.Instances ()
import Test.Tasty
import Test.Tasty.QuickCheck
tests :: TestTree
tests = testGroup "Database.LSMTree.Model.Monoidal"
[ testProperty "lookup-insert" prop_lookupInsert
, testProperty "lookup-delete" prop_lookupDelete
, testProperty "insert-insert" prop_insertInsert
, testProperty "upsert-insert" prop_upsertInsert
, testProperty "upsert=lookup+insert" prop_upsertDef
, testProperty "insert-commutes" prop_insertCommutes
]
type Key = BS.ByteString
type Value = BS.ByteString
type Tbl = Table Key Value
-- | You can lookup what you inserted.
prop_lookupInsert :: Key -> Value -> Tbl -> Property
prop_lookupInsert k v tbl =
lookups [k] (inserts [(k, v)] tbl) === [Found k v]
-- | You cannot lookup what you have deleted
prop_lookupDelete :: Key -> Tbl -> Property
prop_lookupDelete k tbl =
lookups [k] (deletes [k] tbl) === [NotFound k]
-- | Last insert wins.
prop_insertInsert :: Key -> Key -> Value -> Tbl -> Property
prop_insertInsert k v1 v2 tbl =
inserts [(k, v1), (k, v2)] tbl === inserts [(k, v2)] tbl
-- | Updating after insert is the same as inserting merged value.
--
-- Note: the order of merge.
prop_upsertInsert :: Key -> Key -> Value -> Tbl -> Property
prop_upsertInsert k v1 v2 tbl =
updates [(k, Insert v1), (k, Mupsert v2)] tbl === inserts [(k, merge v2 v1)] tbl
-- | Upsert is the same as lookup followed by an insert.
prop_upsertDef :: Key -> Value -> Tbl -> Property
prop_upsertDef k v tbl =
tbl' === mupserts [(k, v)] tbl
where
tbl' = case lookups [k] tbl of
[Found _ v'] -> inserts [(k, merge v v')] tbl
_ -> inserts [(k, v)] tbl
-- | Different key inserts commute.
prop_insertCommutes :: Key -> Value -> Key -> Value -> Tbl -> Property
prop_insertCommutes k1 v1 k2 v2 tbl = k1 /= k2 ==>
inserts [(k1, v1), (k2, v2)] tbl === inserts [(k2, v2), (k1, v1)] tbl
instance (SomeSerialisationConstraint k, SomeSerialisationConstraint v, Arbitrary k, Arbitrary v) => Arbitrary (Table k v) where
arbitrary = fromList <$> arbitrary
shrink t = fromList <$> shrink (toList t)
import Test.Tasty.QuickCheck
tests :: TestTree
tests = testGroup "Test.Database.LSMTree.Model.Normal"
tests = testGroup "Database.LSMTree.Model.Normal"
[ testProperty "lookup-insert" prop_lookupInsert
, testProperty "lookup-delete" prop_lookupDelete
, testProperty "insert-insert" prop_insertInsert
Alonzo builds