1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
open Rnt
module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct
open Alcotest
module H = Helpers.Storage.Make (S) (C)
module SR = Rnt.Kernel.SubstantialRelation.Make (S)
let alaric = Helpers.employee "Alaric" 42
let contains relation tuple =
let open Utilities.Result in
let* relation = Protocols.Relation.require relation in
Protocols.Relation.contains relation tuple
let enumerate relation =
let open Utilities.Result in
let* enumerated =
Protocols.Enumerable.scan relation (fun scan -> Protocols.Cursor.drain scan ())
in
Ok (BatFingerTree.to_list enumerated)
let contain_and_enumerate conn =
let absent, present, enumerated =
begin
let open Utilities.Result in
let* schematics =
H.SI.with_transaction conn (fun tx -> H.store_schema tx ["name"; "age"])
in
let* empty = SR.instantiate conn ~schematics in
let* absent = contains empty alaric in
let* holding = H.relation conn ["name"; "age"] [alaric] in
let* present = contains holding alaric in
let* enumerated = enumerate holding in
Ok (absent, present, enumerated)
end
|> Helpers.condition_as_failure
in
check bool "absent from an empty relation" false absent;
check bool "present in a relation holding it" true present;
check int "one tuple enumerated" 1 (List.length enumerated);
check bool "the tuple that was asserted" true
(List.for_all
(fun tuple ->
Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric) )
enumerated )
let refuse_a_tuple_off_its_heading conn =
let refused message name attributes =
Helpers.refuses message name (H.relation conn ["name"; "age"] [{alaric with attributes}])
in
refused "a tuple lacking an attribute is refused" "missing-attribute"
(BatMap.String.remove "name" alaric.attributes);
refused "a tuple with an attribute too many is refused" "unexpected-attribute"
(BatMap.String.add "salary" (Concepts.Value.Integer 1) alaric.attributes)
let look_up_by_one_attribute conn =
let names relation attribute value =
let open Utilities.Result in
let* indexed = Protocols.Indexed.require relation in
let* cursor = Protocols.Indexed.lookup indexed attribute value in
let* found = Protocols.Cursor.consuming cursor (fun scan -> Protocols.Cursor.drain scan ()) in
Ok
( BatFingerTree.to_list found
|> List.map (fun tuple -> BatMap.String.find "name" tuple.Concepts.Tuple.attributes)
|> List.sort compare )
in
let indexes, aged, named, unaged, prefixed, unindexed =
begin
let open Utilities.Result in
let* relation =
H.relation conn ["name"; "age"]
Helpers.[employee "Alaric" 42; employee "Brunhild" 30; employee "Gunther" 42]
in
let* indexed = Protocols.Indexed.require relation in
let* aged = names relation "age" (Concepts.Value.Integer 42) in
let* named = names relation "name" (Concepts.Value.String "Brunhild") in
let* unaged = names relation "age" (Concepts.Value.Integer 4) in
let* prefixed = names relation "name" (Concepts.Value.String "Al") in
let unindexed = names relation "salary" (Concepts.Value.Integer 1) in
Ok (Protocols.Indexed.indexes indexed, aged, named, unaged, prefixed, unindexed)
end
|> Helpers.condition_as_failure
in
let s v = Concepts.Value.String v in
check (list string) "every attribute is indexed" ["age"; "name"] indexes;
check (list Helpers.value) "an integer finds every tuple holding it"
[s "Alaric"; s "Gunther"]
aged;
check (list Helpers.value) "a string finds the tuple holding it" [s "Brunhild"] named;
check (list Helpers.value) "an integer finds nothing under a longer one" [] unaged;
check (list Helpers.value) "a string finds nothing under a longer one" [] prefixed;
Helpers.refuses "an attribute without an index is refused" "unindexed-attribute" unindexed
let suite =
( "kernel/substantial-relation",
[ test_case "contain-and-enumerate" `Quick
(H.with_connection contain_and_enumerate "substantial-relation-test");
test_case "refuse-a-tuple-off-its-heading" `Quick
(H.with_connection refuse_a_tuple_off_its_heading "substantial-relation-test");
test_case "look-up-by-one-attribute" `Quick
(H.with_connection look_up_by_one_attribute "substantial-relation-test") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
let suites () = [LMDB.suite]
|
