Merge pull request #12 from input-output-hk/commons
Use shared Some*Constraints
Use shared Some*Constraints
main-is: Main.hs
other-modules:
Test.Database.LSMTree
Test.Database.LSMTree.Model.Common
Test.Database.LSMTree.Common
Test.Database.LSMTree.Model.Monoidal
Test.Database.LSMTree.Model.Normal
, Session
, newSession
, closeSession
-- * Constraints
, SomeSerialisationConstraint (..)
, SomeUpdateConstraint (..)
) where
import Control.Concurrent.Class.MonadMVar (MonadMVar)
import Control.Monad.Class.MonadThrow (MonadCatch, MonadThrow)
import Data.Bits (shiftR, (.&.))
import qualified Data.ByteString as BS
import Data.Kind (Type)
import Data.Word (Word64)
import System.FS.API (FsPath, HasFS, SomeHasFS)
{-------------------------------------------------------------------------------
closeSession :: IOLike m => Session m -> m ()
closeSession = undefined
{-------------------------------------------------------------------------------
Serialization constraints
-------------------------------------------------------------------------------}
-- | A placeholder class for (de)serialisation constraints.
--
-- TODO: Should be replaced with whatever (de)serialisation class we eventually
-- want to use. Some prerequisites:
-- * Serialisation/deserialisation should preserve ordering.
class SomeSerialisationConstraint a where
serialise :: a -> BS.ByteString
-- Note: cannot fail.
deserialise :: BS.ByteString -> a
instance SomeSerialisationConstraint BS.ByteString where
serialise = id
deserialise = id
-- | A placeholder class for constraints on 'Update's.
--
-- TODO: should be replaced by the actual constraints we want to use. Some
-- prerequisites:
-- * Combining/merging/resolving 'Update's should be associative.
-- * Should include a function that determines whether it is safe to remove an
-- 'Update' from the last level of an LSM tree.
--
class SomeUpdateConstraint a where
merge :: a -> a -> a
instance SomeUpdateConstraint BS.ByteString where
merge = (<>)
-- | MSB, so order is preserved.
instance SomeSerialisationConstraint Word64 where
-- TODO: optimize me when SomeSerialisationConstraint is replaced with its
-- final version
serialise w = BS.pack [b1,b2,b3,b4,b5,b6,b7,b8] where
b8 = fromIntegral $ w .&. 0xff
b7 = fromIntegral $ shiftR w 8 .&. 0xff
b6 = fromIntegral $ shiftR w 16 .&. 0xff
b5 = fromIntegral $ shiftR w 24 .&. 0xff
b4 = fromIntegral $ shiftR w 32 .&. 0xff
b3 = fromIntegral $ shiftR w 40 .&. 0xff
b2 = fromIntegral $ shiftR w 48 .&. 0xff
b1 = fromIntegral $ shiftR w 56 .&. 0xff
-- TODO: optimize me when SomeSerialisationConstraint is replaced with its
-- final version
deserialise = BS.foldl' (\acc d -> acc * 0x100 + fromIntegral d) 0
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Database.LSMTree.Model.Common (
SomeSerialisationConstraint (..)
, SomeUpdateConstraint (..)
) where
import Data.Bits (shiftR, (.&.))
import qualified Data.ByteString as BS
import Data.Word (Word64)
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 = (<>)
-- | MSB, so order is preserved.
instance SomeSerialisationConstraint Word64 where
serialise w = BS.pack [b1,b2,b3,b4,b5,b6,b7,b8] where
b8 = fromIntegral $ w .&. 0xff
b7 = fromIntegral $ shiftR w 8 .&. 0xff
b6 = fromIntegral $ shiftR w 16 .&. 0xff
b5 = fromIntegral $ shiftR w 24 .&. 0xff
b4 = fromIntegral $ shiftR w 32 .&. 0xff
b3 = fromIntegral $ shiftR w 40 .&. 0xff
b2 = fromIntegral $ shiftR w 48 .&. 0xff
b1 = fromIntegral $ shiftR w 56 .&. 0xff
deserialise = BS.foldl' (\acc d -> acc * 0x100 + fromIntegral d) 0
module Database.LSMTree.Model.Common () where
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.Common (SomeSerialisationConstraint (..),
SomeUpdateConstraint (..))
import Database.LSMTree.Normal (Range (..))
import GHC.Exts (IsList (..))
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.Common (SomeSerialisationConstraint (..))
import Database.LSMTree.Normal (Range (..))
import GHC.Exts (IsList (..))
import Data.Bifunctor (Bifunctor (second))
import Data.Kind (Type)
import Data.Word (Word64)
import Database.LSMTree.Common (IOLike, Session, closeSession,
newSession)
{-------------------------------------------------------------------------------
Temporary placeholder types
-------------------------------------------------------------------------------}
-- | An empty placeholder class for (de)serialisation constraints.
--
-- TODO: Should be replaced with whatever (de)serialisation class we eventually
-- want to use. Some prerequisites:
-- * Serialisation/deserialisation should preserve ordering.
class SomeSerialisationConstraint a where
-- | An empty placeholder class for constraints on 'Update's.
--
-- TODO: should be replaced by the actual constraints we want to use. Some
-- prerequisites:
-- * Combining/merging/resolving 'Update's should be associative.
-- * Should include a function that determines whether it is safe to remove an
-- 'Update' from the last level of an LSM tree.
class SomeUpdateConstraint a where
import Database.LSMTree.Common (IOLike, Session,
SomeSerialisationConstraint, SomeUpdateConstraint,
closeSession, newSession)
{-------------------------------------------------------------------------------
Tables
import Data.Kind (Type)
import Data.Word (Word64)
import Database.LSMTree.Common (IOLike, Session, closeSession,
newSession)
{-------------------------------------------------------------------------------
Temporary placeholder types
-------------------------------------------------------------------------------}
-- | An empty placeholder class for (de)serialisation constraints.
--
-- TODO: Should be replaced with whatever (de)serialisation class we eventually
-- want to use. Some prerequisites:
-- * Serialisation/deserialisation should preserve ordering.
class SomeSerialisationConstraint a where
import Database.LSMTree.Common (IOLike, Session,
SomeSerialisationConstraint, closeSession, newSession)
{-------------------------------------------------------------------------------
Tables
module Main (main) where
import Test.Database.LSMTree (tests)
import qualified Test.Database.LSMTree.Model.Common
import qualified Test.Database.LSMTree.Common
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.Common.tests
, Test.Database.LSMTree.Common.tests
, Test.Database.LSMTree.Model.Normal.tests
, Test.Database.LSMTree.Model.Monoidal.tests
]
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Database.LSMTree.Model.Common (tests) where
module Test.Database.LSMTree.Common (tests) where
import Control.DeepSeq (NFData, deepseq)
import qualified Data.ByteString as BS
import Data.Proxy (Proxy (..))
import Data.Word (Word64)
import Database.LSMTree.Model.Normal
(SomeSerialisationConstraint (..))
import Database.LSMTree.Common (SomeSerialisationConstraint (..))
import Test.QuickCheck.Instances ()
import Test.Tasty
import Test.Tasty.QuickCheck
Alonzo builds