388 lines
18 KiB
OCaml
388 lines
18 KiB
OCaml
open Test_harness
|
|
|
|
let records () =
|
|
(infer
|
|
"type order = { customer : string; total : int }\ninput rows : collection order\nquery q = rows\n")
|
|
.Typed.tp_records
|
|
|
|
let word rng =
|
|
let length = range rng 4 + 1 in
|
|
String.init length (fun index -> Char.chr (97 + ((range rng 3 + index) mod 3)))
|
|
|
|
let rec value_of_type rng ty =
|
|
match Types.repr ty with
|
|
| Types.TInt -> Value.VInt (range rng 41 - 20)
|
|
| Types.TBool -> Value.VBool (range rng 2 = 0)
|
|
| Types.TString -> Value.VString (word rng)
|
|
| Types.TUnit -> Value.VUnit
|
|
| Types.TTuple components -> Value.VTuple (List.map (value_of_type rng) components)
|
|
| Types.TRecord "order" ->
|
|
Value.VRecord ("order", [ ("customer", Value.VString (word rng)); ("total", Value.VInt (range rng 41 - 20)) ])
|
|
| Types.TRecord name ->
|
|
fail "generator" ("no generator for record " ^ name);
|
|
Value.VUnit
|
|
| Types.TCollection _ ->
|
|
fail "generator" "collections are generated separately";
|
|
Value.VUnit
|
|
| Types.TArrow _ | Types.TVar _ ->
|
|
fail "generator" "no generator for this type";
|
|
Value.VUnit
|
|
|
|
let collection_value rng element_ty =
|
|
let count = range rng 5 in
|
|
let entries = Util.list_init count (fun index -> (index + 1, value_of_type rng element_ty)) in
|
|
Value.VCollection (Value.collection_of_list entries)
|
|
|
|
let sample_types =
|
|
[ Types.TInt; Types.TBool; Types.TString; Types.TUnit; Types.TTuple [ Types.TInt; Types.TString ]; Types.TRecord "order" ]
|
|
|
|
let change_of_values records ty old_value new_value = Change.of_values records ty old_value new_value
|
|
|
|
let law_cases =
|
|
let records_ctx = records () in
|
|
let seeds = Util.list_init 120 (fun index -> index) in
|
|
[
|
|
( "the empty change leaves every value unchanged",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
List.iter
|
|
(fun ty ->
|
|
let value = value_of_type rng ty in
|
|
let applied = Change.apply value (Change.empty ty) in
|
|
if not (Value.equal applied value) then
|
|
fail "identity" (Printf.sprintf "seed %d type %s" seed (Types.pp ty)))
|
|
sample_types)
|
|
seeds );
|
|
( "a replacement change reaches the new value",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
List.iter
|
|
(fun ty ->
|
|
let old_value = value_of_type rng ty in
|
|
let new_value = value_of_type rng ty in
|
|
let change = change_of_values records_ctx ty old_value new_value in
|
|
let applied = Change.apply old_value change in
|
|
if not (Value.equal applied new_value) then
|
|
fail "replacement"
|
|
(Printf.sprintf "seed %d type %s change %s" seed (Types.pp ty)
|
|
(Change.to_string change)))
|
|
sample_types)
|
|
seeds );
|
|
( "composition matches sequential application",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
List.iter
|
|
(fun ty ->
|
|
let first = value_of_type rng ty in
|
|
let middle = value_of_type rng ty in
|
|
let last = value_of_type rng ty in
|
|
let step_one = change_of_values records_ctx ty first middle in
|
|
let step_two = change_of_values records_ctx ty middle last in
|
|
let composed = Change.compose step_one step_two in
|
|
let sequential = Change.apply (Change.apply first step_one) step_two in
|
|
let direct = Change.apply first composed in
|
|
if not (Value.equal sequential direct) then
|
|
fail "composition"
|
|
(Printf.sprintf "seed %d type %s" seed (Types.pp ty)))
|
|
sample_types)
|
|
seeds );
|
|
( "composition with the empty change is neutral",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
List.iter
|
|
(fun ty ->
|
|
let old_value = value_of_type rng ty in
|
|
let new_value = value_of_type rng ty in
|
|
let change = change_of_values records_ctx ty old_value new_value in
|
|
let empty = Change.empty ty in
|
|
if not (Change.equal (Change.compose change empty) change) then
|
|
fail "right neutral" (Printf.sprintf "seed %d" seed);
|
|
if not (Change.equal (Change.compose empty change) change) then
|
|
fail "left neutral" (Printf.sprintf "seed %d" seed))
|
|
sample_types)
|
|
seeds );
|
|
( "composition is associative",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
List.iter
|
|
(fun ty ->
|
|
let a = value_of_type rng ty in
|
|
let b = value_of_type rng ty in
|
|
let c = value_of_type rng ty in
|
|
let d = value_of_type rng ty in
|
|
let ab = change_of_values records_ctx ty a b in
|
|
let bc = change_of_values records_ctx ty b c in
|
|
let cd = change_of_values records_ctx ty c d in
|
|
let left = Change.compose (Change.compose ab bc) cd in
|
|
let right = Change.compose ab (Change.compose bc cd) in
|
|
if not (Change.equal left right) then
|
|
fail "associativity" (Printf.sprintf "seed %d type %s" seed (Types.pp ty)))
|
|
sample_types)
|
|
seeds );
|
|
( "integer changes add",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
let value = Value.VInt (range rng 100 - 50) in
|
|
let first = Change.CInt (range rng 21 - 10) in
|
|
let second = Change.CInt (range rng 21 - 10) in
|
|
let composed = Change.compose first second in
|
|
let applied = Change.apply value composed in
|
|
let sequential = Change.apply (Change.apply value first) second in
|
|
if not (Value.equal applied sequential) then fail "integer composition" (Printf.sprintf "seed %d" seed);
|
|
match composed with
|
|
| Change.CInt delta ->
|
|
let expected =
|
|
(match first with Change.CInt a -> a | _ -> 0) + (match second with Change.CInt b -> b | _ -> 0)
|
|
in
|
|
if delta <> expected then fail "integer sum" (Printf.sprintf "seed %d" seed)
|
|
| _ -> fail "integer sum" "expected an additive change")
|
|
seeds );
|
|
( "collection changes compose keywise",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
let element_ty = Types.TInt in
|
|
let value = collection_value rng element_ty in
|
|
let middle = collection_value rng element_ty in
|
|
let last = collection_value rng element_ty in
|
|
let step_one = change_of_values records_ctx (Types.TCollection element_ty) value middle in
|
|
let step_two = change_of_values records_ctx (Types.TCollection element_ty) middle last in
|
|
let composed = Change.compose step_one step_two in
|
|
let sequential = Change.apply (Change.apply value step_one) step_two in
|
|
let direct = Change.apply value composed in
|
|
if not (Value.equal sequential direct) then
|
|
fail "collection composition"
|
|
(Printf.sprintf "seed %d value=%s middle=%s last=%s one=%s two=%s composed=%s seq=%s direct=%s"
|
|
seed (Value.to_string value) (Value.to_string middle) (Value.to_string last)
|
|
(Change.to_string step_one) (Change.to_string step_two) (Change.to_string composed)
|
|
(Value.to_string sequential) (Value.to_string direct)))
|
|
seeds );
|
|
( "a change with equal old and new values is empty",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
List.iter
|
|
(fun ty ->
|
|
let value = value_of_type rng ty in
|
|
let change = change_of_values records_ctx ty value value in
|
|
if not (Change.is_empty change) then
|
|
fail "unchanged" (Printf.sprintf "seed %d type %s" seed (Types.pp ty)))
|
|
sample_types)
|
|
seeds );
|
|
( "applying a change to a mismatched value is rejected",
|
|
fun () ->
|
|
expect_diagnostic "mismatch" (fun () -> ignore (Change.apply (Value.VInt 1) (Change.CString "x")));
|
|
expect_diagnostic "mismatch" (fun () -> ignore (Change.apply (Value.VString "x") (Change.CInt 1))) );
|
|
( "composing changes of different types is rejected",
|
|
fun () ->
|
|
expect_diagnostic "compose" (fun () -> ignore (Change.compose (Change.CInt 1) (Change.CString "x"))) );
|
|
]
|
|
|
|
|
|
let collection keys element_ty rng =
|
|
let entries =
|
|
List.map
|
|
(fun key -> (key, value_of_type rng element_ty))
|
|
keys
|
|
in
|
|
Value.collection_of_list entries
|
|
|
|
let batch_cases =
|
|
let element_ty = Types.TInt in
|
|
let original rng = collection [ 1; 2; 3 ] element_ty rng in
|
|
[
|
|
( "an insert of an absent key becomes an insertion change",
|
|
fun () ->
|
|
let rng = rng 1 in
|
|
let existing = original rng in
|
|
match Change.validate_batch ~existing [ Change.OpInsert (7, Value.VInt 70) ] with
|
|
| Change.Failure message -> fail "insert" message
|
|
| Change.Success (temp, changes) ->
|
|
check_equal_string "changes"
|
|
"collection [insert 7 70]"
|
|
(Change.to_string (Change.CCollection changes));
|
|
check_equal_int "temporary map" 4 (Delta_runtime.Pure_map.cardinal temp) );
|
|
( "removing a present key becomes a removal change",
|
|
fun () ->
|
|
let rng = rng 2 in
|
|
let existing = original rng in
|
|
let value = Delta_runtime.Pure_map.find 2 existing in
|
|
match Change.validate_batch ~existing [ Change.OpRemove 2 ] with
|
|
| Change.Failure message -> fail "remove" message
|
|
| Change.Success (temp, changes) ->
|
|
check_equal_string "changes"
|
|
(Printf.sprintf "collection [remove 2 %s]" (Value.to_string value))
|
|
(Change.to_string (Change.CCollection changes));
|
|
check "the key is gone" (not (Delta_runtime.Pure_map.mem 2 temp)) );
|
|
( "replacing a present key becomes a replacement change",
|
|
fun () ->
|
|
let rng = rng 3 in
|
|
let existing = original rng in
|
|
let value = Delta_runtime.Pure_map.find 1 existing in
|
|
match Change.validate_batch ~existing [ Change.OpReplace (1, Value.VInt 99) ] with
|
|
| Change.Failure message -> fail "replace" message
|
|
| Change.Success (_, changes) ->
|
|
check_equal_string "changes"
|
|
(Printf.sprintf "collection [replace 1 %s 99]" (Value.to_string value))
|
|
(Change.to_string (Change.CCollection changes)) );
|
|
( "insert followed by remove cancels",
|
|
fun () ->
|
|
let rng = rng 4 in
|
|
let existing = original rng in
|
|
let ops = [ Change.OpInsert (9, Value.VInt 1); Change.OpRemove 9 ] in
|
|
match Change.validate_batch ~existing ops with
|
|
| Change.Failure message -> fail "cancel" message
|
|
| Change.Success (temp, changes) ->
|
|
check "no effective change" (changes = []);
|
|
check "the map is unchanged" (Value.equal (Value.VCollection temp) (Value.VCollection existing)) );
|
|
( "several replacements collapse into one",
|
|
fun () ->
|
|
let rng = rng 5 in
|
|
let existing = original rng in
|
|
let value = Delta_runtime.Pure_map.find 3 existing in
|
|
let ops =
|
|
[ Change.OpReplace (3, Value.VInt 10); Change.OpReplace (3, Value.VInt 20); Change.OpReplace (3, Value.VInt 30) ]
|
|
in
|
|
match Change.validate_batch ~existing ops with
|
|
| Change.Failure message -> fail "collapse" message
|
|
| Change.Success (_, changes) ->
|
|
check_equal_string "changes"
|
|
(Printf.sprintf "collection [replace 3 %s 30]" (Value.to_string value))
|
|
(Change.to_string (Change.CCollection changes)) );
|
|
( "removing and reinserting an original key becomes a replacement",
|
|
fun () ->
|
|
let rng = rng 6 in
|
|
let existing = original rng in
|
|
let value = Delta_runtime.Pure_map.find 2 existing in
|
|
let ops = [ Change.OpRemove 2; Change.OpInsert (2, Value.VInt 200) ] in
|
|
match Change.validate_batch ~existing ops with
|
|
| Change.Failure message -> fail "reinsert" message
|
|
| Change.Success (_, changes) ->
|
|
check_equal_string "changes"
|
|
(Printf.sprintf "collection [replace 2 %s 200]" (Value.to_string value))
|
|
(Change.to_string (Change.CCollection changes)) );
|
|
( "a replacement with an equal value is not an effective change",
|
|
fun () ->
|
|
let rng = rng 7 in
|
|
let existing = original rng in
|
|
let value = Delta_runtime.Pure_map.find 1 existing in
|
|
match Change.validate_batch ~existing [ Change.OpReplace (1, value) ] with
|
|
| Change.Failure message -> fail "equal" message
|
|
| Change.Success (_, changes) -> check "no effective change" (changes = []) );
|
|
( "a duplicate insertion is rejected",
|
|
fun () ->
|
|
let rng = rng 8 in
|
|
let existing = original rng in
|
|
let ops = [ Change.OpInsert (5, Value.VInt 1); Change.OpInsert (5, Value.VInt 2) ] in
|
|
(match Change.validate_batch ~existing ops with
|
|
| Change.Success _ -> fail "duplicate" "expected a failure"
|
|
| Change.Failure message ->
|
|
check_equal_string "message" "cannot insert key 5: it is already present" message) );
|
|
( "removing a missing key is rejected",
|
|
fun () ->
|
|
let rng = rng 9 in
|
|
let existing = original rng in
|
|
match Change.validate_batch ~existing [ Change.OpRemove 42 ] with
|
|
| Change.Success _ -> fail "missing" "expected a failure"
|
|
| Change.Failure message ->
|
|
check_equal_string "message" "cannot remove key 42: it is not present" message );
|
|
( "replacing a missing key is rejected",
|
|
fun () ->
|
|
let rng = rng 10 in
|
|
let existing = original rng in
|
|
match Change.validate_batch ~existing [ Change.OpReplace (42, Value.VInt 1) ] with
|
|
| Change.Success _ -> fail "missing" "expected a failure"
|
|
| Change.Failure message ->
|
|
check_equal_string "message" "cannot replace key 42: it is not present" message );
|
|
( "later operations see the effect of earlier ones",
|
|
fun () ->
|
|
let rng = rng 11 in
|
|
let existing = original rng in
|
|
let ops = [ Change.OpInsert (4, Value.VInt 40); Change.OpRemove 4; Change.OpInsert (4, Value.VInt 41) ] in
|
|
match Change.validate_batch ~existing ops with
|
|
| Change.Failure message -> fail "sequence" message
|
|
| Change.Success (temp, changes) ->
|
|
check_equal_string "changes" "collection [insert 4 41]"
|
|
(Change.to_string (Change.CCollection changes));
|
|
check "the temporary map holds the final value"
|
|
(match Delta_runtime.Pure_map.find_opt 4 temp with Some (Value.VInt 41) -> true | _ -> false) );
|
|
( "a failed batch leaves the input untouched",
|
|
fun () ->
|
|
let rng = rng 12 in
|
|
let existing = original rng in
|
|
let before = Value.VCollection existing in
|
|
let ops = [ Change.OpInsert (8, Value.VInt 1); Change.OpRemove 42 ] in
|
|
(match Change.validate_batch ~existing ops with
|
|
| Change.Success _ -> fail "atomic" "expected a failure"
|
|
| Change.Failure _ -> ());
|
|
check_equal_string "the input is unchanged" (Value.to_string before) (Value.to_string (Value.VCollection existing));
|
|
check_equal_int "cardinality" 3 (Delta_runtime.Pure_map.cardinal existing) );
|
|
( "the normalized change reproduces the validated map",
|
|
fun () ->
|
|
List.iter
|
|
(fun seed ->
|
|
let rng = rng seed in
|
|
let existing = original rng in
|
|
let count = range rng 6 + 1 in
|
|
let keys = [ 1; 2; 3; 4; 5 ] in
|
|
let temp = ref existing in
|
|
let ops = ref [] in
|
|
for _ = 1 to count do
|
|
let key = pick rng keys in
|
|
if Delta_runtime.Pure_map.mem key !temp then
|
|
if range rng 2 = 0 then (
|
|
ops := Change.OpRemove key :: !ops;
|
|
temp := Delta_runtime.Pure_map.remove key !temp)
|
|
else (
|
|
let value = Value.VInt (range rng 100) in
|
|
ops := Change.OpReplace (key, value) :: !ops;
|
|
temp := Delta_runtime.Pure_map.add key value !temp)
|
|
else (
|
|
let value = Value.VInt (range rng 100) in
|
|
ops := Change.OpInsert (key, value) :: !ops;
|
|
temp := Delta_runtime.Pure_map.add key value !temp)
|
|
done;
|
|
let ops = List.rev !ops in
|
|
match Change.validate_batch ~existing ops with
|
|
| Change.Failure message -> fail "random batch" (Printf.sprintf "seed %d: %s" seed message)
|
|
| Change.Success (validated, changes) ->
|
|
let rebuilt = Change.apply_keyed existing changes in
|
|
let expected = Value.VCollection !temp in
|
|
let actual = Value.VCollection validated in
|
|
let from_changes = Value.VCollection rebuilt in
|
|
if not (Value.equal expected actual) then fail "validated map" (Printf.sprintf "seed %d" seed);
|
|
if not (Value.equal expected from_changes) then
|
|
fail "change application" (Printf.sprintf "seed %d ops=%s" seed
|
|
(Change.to_string (Change.CCollection changes))))
|
|
(Util.list_init 120 (fun index -> index + 1)) );
|
|
]
|
|
|
|
let rec value_for rng records ty =
|
|
match Types.repr ty with
|
|
| Types.TInt -> Value.VInt (range rng 41 - 20)
|
|
| Types.TBool -> Value.VBool (range rng 2 = 0)
|
|
| Types.TString -> Value.VString (word rng)
|
|
| Types.TUnit -> Value.VUnit
|
|
| Types.TTuple items -> Value.VTuple (List.map (value_for rng records) items)
|
|
| Types.TRecord name -> (
|
|
match Types.record_info records name with
|
|
| Some info ->
|
|
Value.VRecord
|
|
(name, List.map (fun (label, field_ty) -> (label, value_for rng records field_ty)) info.Types.ri_fields)
|
|
| None -> Value.VUnit)
|
|
| Types.TCollection _ | Types.TArrow _ | Types.TVar _ -> Value.VUnit
|