Skip to content

Commit 6a0c425

Browse files
jorisdraljorisdral
authored
Merge pull request #475 from IntersectMBO/jdral/single-api-qls
Add mupserts and table unions to the state machine tests
2 parents 6904297 + 6058205 commit 6a0c425

File tree

14 files changed

+628
-142
lines changed

14 files changed

+628
-142
lines changed

‎lsm-tree.cabal‎

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -343,9 +343,12 @@ test-suite lsm-tree-test
343343
hs-source-dirs: test
344344
main-is: Main.hs
345345
other-modules:
346+
Database.LSMTree.Class
347+
Database.LSMTree.Class.Common
346348
Database.LSMTree.Class.Monoidal
347349
Database.LSMTree.Class.Normal
348350
Database.LSMTree.Model
351+
Database.LSMTree.Model.IO
349352
Database.LSMTree.Model.IO.Monoidal
350353
Database.LSMTree.Model.IO.Normal
351354
Database.LSMTree.Model.Session
@@ -380,10 +383,10 @@ test-suite lsm-tree-test
380383
Test.Database.LSMTree.Internal.Vector.Growing
381384
Test.Database.LSMTree.Model.Table
382385
Test.Database.LSMTree.Monoidal
383-
Test.Database.LSMTree.Normal.StateMachine
384-
Test.Database.LSMTree.Normal.StateMachine.DL
385-
Test.Database.LSMTree.Normal.StateMachine.Op
386-
Test.Database.LSMTree.Normal.UnitTests
386+
Test.Database.LSMTree.StateMachine
387+
Test.Database.LSMTree.StateMachine.DL
388+
Test.Database.LSMTree.StateMachine.Op
389+
Test.Database.LSMTree.UnitTests
387390
Test.System.Posix.Fcntl.NoCache
388391
Test.Util.FS
389392
Test.Util.Orphans

‎src-extras/Database/LSMTree/Extras/Generators.hs‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,7 @@ import Data.List (sort)
4646
import qualified Data.Primitive.ByteArray as BA
4747
import qualified Data.Vector.Primitive as VP
4848
import Data.Word
49+
import qualified Database.LSMTree as Unified
4950
import Database.LSMTree.Common (Range (..))
5051
import Database.LSMTree.Extras
5152
import Database.LSMTree.Extras.Index (Append (..))
@@ -75,6 +76,25 @@ import Test.QuickCheck.Instances ()
7576
Common LSMTree types
7677
-------------------------------------------------------------------------------}
7778

79+
instance (Arbitrary v, Arbitrary blob) => Arbitrary (Unified.Update v blob) where
80+
arbitrary = QC.arbitrary2
81+
shrink = QC.shrink2
82+
83+
instance Arbitrary2 Unified.Update where
84+
liftArbitrary2 genVal genBlob = frequency
85+
[ (10, Unified.Insert <$> genVal <*> liftArbitrary genBlob)
86+
, (5, Unified.Mupsert <$> genVal)
87+
, (1, pure Unified.Delete)
88+
]
89+
90+
liftShrink2 shrinkVal shrinkBlob = \case
91+
Unified.Insert v blob ->
92+
Unified.Delete
93+
: map (uncurry Unified.Insert)
94+
(liftShrink2 shrinkVal (liftShrink shrinkBlob) (v, blob))
95+
Unified.Mupsert v -> Unified.Insert v Nothing : map Unified.Mupsert (shrinkVal v)
96+
Unified.Delete -> []
97+
7898
instance (Arbitrary v, Arbitrary blob) => Arbitrary (Normal.Update v blob) where
7999
arbitrary = QC.arbitrary2
80100
shrink = QC.shrink2

‎test/Database/LSMTree/Class.hs‎

Lines changed: 274 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,274 @@
1+
{-# LANGUAGE TypeFamilies #-}
2+
3+
-- | An abstraction of the normal LSM API, instantiated by both the real
4+
-- implementation and a model (see "Database.LSMTree.Model.IO").
5+
module Database.LSMTree.Class (
6+
IsTable (..)
7+
, withTableNew
8+
, withTableFromSnapshot
9+
, withTableDuplicate
10+
, withCursor
11+
, module Common
12+
, module Types
13+
) where
14+
15+
import Control.Monad.Class.MonadThrow (MonadThrow (..))
16+
import Data.Kind (Constraint, Type)
17+
import Data.Typeable (Proxy (..))
18+
import qualified Data.Vector as V
19+
import Database.LSMTree as Types (LookupResult (..), QueryResult (..),
20+
ResolveValue, Update (..))
21+
import qualified Database.LSMTree as R
22+
import Database.LSMTree.Class.Common as Common
23+
24+
-- | Class abstracting over table operations.
25+
--
26+
type IsTable :: ((Type -> Type) -> Type -> Type -> Type -> Type) -> Constraint
27+
class (IsSession (Session h)) => IsTable h where
28+
type Session h :: (Type -> Type) -> Type
29+
type TableConfig h :: Type
30+
type BlobRef h :: (Type -> Type) -> Type -> Type
31+
type Cursor h :: (Type -> Type) -> Type -> Type -> Type -> Type
32+
33+
new ::
34+
( IOLike m
35+
, C k v b
36+
)
37+
=> Session h m
38+
-> TableConfig h
39+
-> m (h m k v b)
40+
41+
close ::
42+
( IOLike m
43+
, C k v b
44+
)
45+
=> h m k v b
46+
-> m ()
47+
48+
lookups ::
49+
( IOLike m
50+
, SerialiseKey k
51+
, SerialiseValue v
52+
, ResolveValue v
53+
, C k v b
54+
)
55+
=> h m k v b
56+
-> V.Vector k
57+
-> m (V.Vector (LookupResult v (BlobRef h m b)))
58+
59+
rangeLookup ::
60+
( IOLike m
61+
, SerialiseKey k
62+
, SerialiseValue v
63+
, ResolveValue v
64+
, C k v b
65+
)
66+
=> h m k v b
67+
-> Range k
68+
-> m (V.Vector (QueryResult k v (BlobRef h m b)))
69+
70+
newCursor ::
71+
( IOLike m
72+
, SerialiseKey k
73+
, C k v b
74+
)
75+
=> Maybe k
76+
-> h m k v b
77+
-> m (Cursor h m k v b)
78+
79+
closeCursor ::
80+
( IOLike m
81+
, C k v b
82+
)
83+
=> proxy h
84+
-> Cursor h m k v b
85+
-> m ()
86+
87+
readCursor ::
88+
( IOLike m
89+
, SerialiseKey k
90+
, SerialiseValue v
91+
, ResolveValue v
92+
, C k v b
93+
)
94+
=> proxy h
95+
-> Int
96+
-> Cursor h m k v b
97+
-> m (V.Vector (QueryResult k v (BlobRef h m b)))
98+
99+
retrieveBlobs ::
100+
( IOLike m
101+
, SerialiseValue b
102+
, C_ b
103+
)
104+
=> proxy h
105+
-> Session h m
106+
-> V.Vector (BlobRef h m b)
107+
-> m (V.Vector b)
108+
109+
updates ::
110+
( IOLike m
111+
, SerialiseKey k
112+
, SerialiseValue v
113+
, SerialiseValue b
114+
, ResolveValue v
115+
, C k v b
116+
)
117+
=> h m k v b
118+
-> V.Vector (k, Update v b)
119+
-> m ()
120+
121+
inserts ::
122+
( IOLike m
123+
, SerialiseKey k
124+
, SerialiseValue v
125+
, SerialiseValue b
126+
, ResolveValue v
127+
, C k v b
128+
)
129+
=> h m k v b
130+
-> V.Vector (k, v, Maybe b)
131+
-> m ()
132+
133+
deletes ::
134+
( IOLike m
135+
, SerialiseKey k
136+
, SerialiseValue v
137+
, SerialiseValue b
138+
, ResolveValue v
139+
, C k v b
140+
)
141+
=> h m k v b
142+
-> V.Vector k
143+
-> m ()
144+
145+
mupserts ::
146+
( IOLike m
147+
, SerialiseKey k
148+
, SerialiseValue v
149+
, SerialiseValue b
150+
, ResolveValue v
151+
, C k v b
152+
)
153+
=> h m k v b
154+
-> V.Vector (k, v)
155+
-> m ()
156+
157+
createSnapshot ::
158+
( IOLike m
159+
, SerialiseKey k
160+
, SerialiseValue v
161+
, SerialiseValue b
162+
, ResolveValue v
163+
, C k v b
164+
)
165+
=> SnapshotLabel
166+
-> SnapshotName
167+
-> h m k v b
168+
-> m ()
169+
170+
openSnapshot ::
171+
( IOLike m
172+
, SerialiseKey k
173+
, SerialiseValue v
174+
, ResolveValue v
175+
, SerialiseValue b
176+
, C k v b
177+
)
178+
=> Session h m
179+
-> SnapshotLabel
180+
-> SnapshotName
181+
-> m (h m k v b)
182+
183+
duplicate ::
184+
( IOLike m
185+
, C k v b
186+
)
187+
=> h m k v b
188+
-> m (h m k v b)
189+
190+
union ::
191+
( IOLike m
192+
, ResolveValue v
193+
, SerialiseValue v
194+
, C k v b
195+
)
196+
=> h m k v b
197+
-> h m k v b
198+
-> m (h m k v b)
199+
200+
withTableNew :: forall h m k v b a.
201+
( IOLike m
202+
, IsTable h
203+
, C k v b
204+
)
205+
=> Session h m
206+
-> TableConfig h
207+
-> (h m k v b -> m a)
208+
-> m a
209+
withTableNew sesh conf = bracket (new sesh conf) close
210+
211+
withTableFromSnapshot :: forall h m k v b a.
212+
( IOLike m, IsTable h
213+
, SerialiseKey k, SerialiseValue v, SerialiseValue b, ResolveValue v
214+
, C k v b
215+
)
216+
=> Session h m
217+
-> SnapshotLabel
218+
-> SnapshotName
219+
-> (h m k v b -> m a)
220+
-> m a
221+
withTableFromSnapshot sesh label snap = bracket (openSnapshot sesh label snap) close
222+
223+
withTableDuplicate :: forall h m k v b a.
224+
( IOLike m
225+
, IsTable h
226+
, C k v b
227+
)
228+
=> h m k v b
229+
-> (h m k v b -> m a)
230+
-> m a
231+
withTableDuplicate table = bracket (duplicate table) close
232+
233+
withCursor :: forall h m k v b a.
234+
( IOLike m
235+
, IsTable h
236+
, SerialiseKey k
237+
, C k v b
238+
)
239+
=> Maybe k
240+
-> h m k v b
241+
-> (Cursor h m k v b -> m a)
242+
-> m a
243+
withCursor offset hdl = bracket (newCursor offset hdl) (closeCursor (Proxy @h))
244+
245+
{-------------------------------------------------------------------------------
246+
Real instance
247+
-------------------------------------------------------------------------------}
248+
249+
instance IsTable R.Table where
250+
type Session R.Table = R.Session
251+
type TableConfig R.Table = R.TableConfig
252+
type BlobRef R.Table = R.BlobRef
253+
type Cursor R.Table = R.Cursor
254+
255+
new = R.new
256+
close = R.close
257+
lookups = R.lookups
258+
updates = R.updates
259+
inserts = R.inserts
260+
deletes = R.deletes
261+
mupserts = R.mupserts
262+
263+
rangeLookup = R.rangeLookup
264+
retrieveBlobs _ = R.retrieveBlobs
265+
266+
newCursor = maybe R.newCursor R.newCursorAtOffset
267+
closeCursor _ = R.closeCursor
268+
readCursor _ = R.readCursor
269+
270+
createSnapshot = R.createSnapshot
271+
openSnapshot sesh snap = R.openSnapshot sesh R.configNoOverride snap
272+
273+
duplicate = R.duplicate
274+
union = R.union

0 commit comments

Comments
 (0)