Propagate map changes through cached outputs

test/test_incremental.ml

@@ -197,3 +197,236 @@ let graph_cases =
         in
         check_equal_int "four nodes" 4 (List.length plan.Graph.pl_nodes) );
   ]
+
+type fixture = {
+  fx_program : Typed.program;
+  fx_plan : Graph.plan;
+  fx_counters : Delta_runtime.counters;
+  mutable fx_state : Incremental.state;
+  fx_entries : (int * Value.t) list;
+}
+
+let build_fixture text entries =
+  let program = infer text in
+  let plan = Graph.build (Anf.program (Specialize.program program)) in
+  let counters = Delta_runtime.new_counters () in
+  let state = Incremental.init plan counters entries in
+  { fx_program = program; fx_plan = plan; fx_counters = counters; fx_state = state; fx_entries = entries }
+
+let fixture_entries plan state = Delta_runtime.Pure_map.bindings state.Incremental.s_input
+
+let reference_result fixture state =
+  Interpret.program fixture.fx_program (fixture_entries fixture.fx_plan state)
+
+let reference_after fixture ops =
+  match Change.validate_batch ~existing:fixture.fx_state.Incremental.s_input ops with
+  | Change.Failure message -> Error message
+  | Change.Success (temp, _) ->
+      let program = fixture.fx_program in
+      ignore program;
+      Ok (Interpret.program fixture.fx_program (Delta_runtime.Pure_map.bindings temp))
+
+let step fixture ops =
+  let before = Incremental.result fixture.fx_plan fixture.fx_state in
+  match Incremental.apply_batch fixture.fx_plan fixture.fx_counters fixture.fx_state ops with
+  | Change.Failure message -> Error message
+  | Change.Success (state, change) ->
+      let applied = Change.apply before change in
+      let cached_after = Incremental.result fixture.fx_plan state in
+      fixture.fx_state <- state;
+      Ok (applied, cached_after, change)
+
+let order_row customer total =
+  Value.VRecord ("order", [ ("customer", Value.VString customer); ("total", Value.VInt total) ])
+
+let executor_cases =
+  let orders text entries =
+    let fixture =
+      build_fixture
+        ("input orders : collection order\n" ^ text)
+        entries
+    in
+    fixture
+  in
+  [
+    ( "initialization matches the reference interpreter",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta")
+            [ (1, order_row "Ada" 1500); (2, order_row "Bo" 900) ]
+        in
+        check_equal_string "initial result"
+          (Value.to_string (reference_result fixture fixture.fx_state))
+          (Value.to_string (Incremental.result fixture.fx_plan fixture.fx_state)) );
+    ( "inserting a key appends a mapped contribution",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta") [ (1, order_row "Ada" 1500) ]
+        in
+        (match step fixture [ Change.OpInsert (2, order_row "Lin" 2200) ] with
+        | Error message -> fail "insert" message
+        | Ok (applied, cached, change) ->
+            let expected = reference_result fixture fixture.fx_state in
+            check_equal_string "change" "collection [insert 2 (tuple \"Lin\" 440)]"
+              (Change.to_string change);
+            check_equal_string "applied" (Value.to_string expected) (Value.to_string applied);
+            check_equal_string "cached" (Value.to_string expected) (Value.to_string cached)) );
+    ( "removing a key retracts the cached contribution",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta")
+            [ (1, order_row "Ada" 1500); (2, order_row "Lin" 2200) ]
+        in
+        (match step fixture [ Change.OpRemove 2 ] with
+        | Error message -> fail "remove" message
+        | Ok (applied, cached, change) ->
+            let expected = reference_result fixture fixture.fx_state in
+            check_equal_string "change" "collection [remove 2 (tuple \"Lin\" 440)]"
+              (Change.to_string change);
+            check_equal_string "applied" (Value.to_string expected) (Value.to_string applied);
+            check_equal_string "cached" (Value.to_string expected) (Value.to_string cached)) );
+    ( "replacing a retained key forwards the new contribution",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta") [ (1, order_row "Ada" 1500) ]
+        in
+        (match step fixture [ Change.OpReplace (1, order_row "Ada" 2500) ] with
+        | Error message -> fail "replace" message
+        | Ok (applied, cached, change) ->
+            let expected = reference_result fixture fixture.fx_state in
+            check_equal_string "change" "collection [replace 1 (tuple \"Ada\" 300) (tuple \"Ada\" 500)]"
+              (Change.to_string change);
+            check_equal_string "applied" (Value.to_string expected) (Value.to_string applied);
+            check_equal_string "cached" (Value.to_string expected) (Value.to_string cached)) );
+    ( "replacing a key with an equal row produces no change",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta") [ (1, order_row "Ada" 1500) ]
+        in
+        (match step fixture [ Change.OpReplace (1, order_row "Ada" 1500) ] with
+        | Error message -> fail "equal" message
+        | Ok (applied, cached, change) ->
+            check "empty change" (Change.is_empty change);
+            check_equal_string "applied" (Value.to_string (reference_result fixture fixture.fx_state))
+              (Value.to_string applied);
+            check_equal_string "cached" (Value.to_string (reference_result fixture fixture.fx_state))
+              (Value.to_string cached)) );
+    ( "a row that stops matching leaves the collection only once",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta") [ (1, order_row "Ada" 1500) ]
+        in
+        (match step fixture [ Change.OpReplace (1, order_row "Ada" 100) ] with
+        | Error message -> fail "drop" message
+        | Ok (applied, cached, change) ->
+            let expected = reference_result fixture fixture.fx_state in
+            check_equal_string "change" "collection [remove 1 (tuple \"Ada\" 300)]"
+              (Change.to_string change);
+            check_equal_string "applied" (Value.to_string expected) (Value.to_string applied);
+            check_equal_string "cached" (Value.to_string expected) (Value.to_string cached)) );
+    ( "a row that starts matching is inserted once",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta") [ (1, order_row "Ada" 100) ]
+        in
+        (match step fixture [ Change.OpReplace (1, order_row "Ada" 5000) ] with
+        | Error message -> fail "gain" message
+        | Ok (applied, cached, change) ->
+            let expected = reference_result fixture fixture.fx_state in
+            check_equal_string "change" "collection [insert 1 (tuple \"Ada\" 1000)]"
+              (Change.to_string change);
+            check_equal_string "applied" (Value.to_string expected) (Value.to_string applied);
+            check_equal_string "cached" (Value.to_string expected) (Value.to_string cached)) );
+    ( "several batches keep the state consistent",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta") [ (1, order_row "Ada" 1500) ]
+        in
+        (match step fixture [ Change.OpInsert (2, order_row "Bo" 3000) ] with
+        | Error message -> fail "insert" message
+        | Ok _ -> ());
+        (match step fixture [ Change.OpRemove 1 ] with
+        | Error message -> fail "remove" message
+        | Ok _ -> ());
+        (match step fixture [ Change.OpReplace (2, order_row "Bo" 900) ] with
+        | Error message -> fail "replace" message
+        | Ok (applied, cached, _) ->
+            let expected = reference_result fixture fixture.fx_state in
+            check_equal_string "applied" (Value.to_string expected) (Value.to_string applied);
+            check_equal_string "cached" (Value.to_string expected) (Value.to_string cached)) );
+    ( "an identity query forwards the input change",
+      fun () ->
+        let fixture =
+          build_fixture "input rows : collection int\nquery q = rows" [ (1, Value.VInt 5) ]
+        in
+        (match step fixture [ Change.OpInsert (2, Value.VInt 9) ] with
+        | Error message -> fail "identity" message
+        | Ok (applied, cached, change) ->
+            check_equal_string "change" "collection [insert 2 9]" (Change.to_string change);
+            check_equal_string "applied" "(collection (1 5) (2 9))" (Value.to_string applied);
+            check_equal_string "cached" "(collection (1 5) (2 9))" (Value.to_string cached)) );
+    ( "an integer query reports an additive change",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "revenue.delta") [ (1, order_row "Ada" 1000) ]
+        in
+        (match step fixture [ Change.OpInsert (2, order_row "Bo" 250) ] with
+        | Error message -> fail "sum" message
+        | Ok (applied, cached, change) ->
+            check_equal_string "change" "+50" (Change.to_string change);
+            check_equal_string "applied" "250" (Value.to_string applied);
+            check_equal_string "cached" "250" (Value.to_string cached)) );
+    ( "count ignores replacements that keep a row",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "count_large.delta") [ (1, order_row "Ada" 1000) ]
+        in
+        (match step fixture [ Change.OpReplace (1, order_row "Ada" 2000) ] with
+        | Error message -> fail "count" message
+        | Ok (_, _, change) -> check "empty change" (Change.is_empty change));
+        (match step fixture [ Change.OpReplace (1, order_row "Ada" 10) ] with
+        | Error message -> fail "count" message
+        | Ok (_, cached, change) ->
+            check_equal_string "change" "-1" (Change.to_string change);
+            check_equal_string "cached" "0" (Value.to_string cached)) );
+    ( "an invalid batch leaves the state usable",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta") [ (1, order_row "Ada" 1500) ]
+        in
+        let before = Value.to_string (Incremental.result fixture.fx_plan fixture.fx_state) in
+        (match step fixture [ Change.OpRemove 99 ] with
+        | Ok _ -> fail "invalid" "expected a failure"
+        | Error _ -> ());
+        check_equal_string "result unchanged" before
+          (Value.to_string (Incremental.result fixture.fx_plan fixture.fx_state));
+        (match step fixture [ Change.OpInsert (2, order_row "Bo" 2000) ] with
+        | Error message -> fail "recovery" message
+        | Ok (applied, _, _) ->
+            check_equal_string "still incremental" (Value.to_string (reference_result fixture fixture.fx_state))
+              (Value.to_string applied)) );
+    ( "updates visit one key per node",
+      fun () ->
+        let fixture =
+          build_fixture (read_fixture "expensive_order.delta")
+            [ (1, order_row "Ada" 1500); (2, order_row "Bo" 2000); (3, order_row "Cy" 500) ]
+        in
+        Delta_runtime.reset_counters fixture.fx_counters;
+        (match step fixture [ Change.OpReplace (2, order_row "Bo" 2500) ] with
+        | Error message -> fail "visit" message
+        | Ok _ ->
+            let counters = fixture.fx_counters in
+            check_equal_int "changed key visits" 3 counters.Delta_runtime.changed_key_visits;
+            check_equal_int "predicate evaluations" 1 counters.Delta_runtime.predicate_evaluations;
+            check_equal_int "mapping evaluations" 0 counters.Delta_runtime.mapping_evaluations;
+            check_equal_int "scalar deltas" 1 counters.Delta_runtime.scalar_deltas;
+            check_equal_int "full traversals" 0 counters.Delta_runtime.full_traversals) );
+    ( "initialization counts one traversal per node",
+      fun () ->
+        let plan = plan_of_fixture "expensive_order.delta" in
+        let counters = Delta_runtime.new_counters () in
+        let _ = Incremental.init plan counters [ (1, order_row "Ada" 1500) ] in
+        check_equal_int "full traversals" 3 counters.Delta_runtime.full_traversals;
+        check_equal_int "mapping evaluations" 1 counters.Delta_runtime.mapping_evaluations;
+        check_equal_int "predicate evaluations" 1 counters.Delta_runtime.predicate_evaluations );
+  ]

test/test_main.ml

@@ -380,5 +380,6 @@ let () =
   Test_harness.run_suite "batches" Test_change.batch_cases;
   Test_harness.run_suite "interpret" Test_incremental.cases;
   Test_harness.run_suite "graph" Test_incremental.graph_cases;
+  Test_harness.run_suite "executor" Test_incremental.executor_cases;
   Printf.printf "%d cases, %d failures\n" (Test_harness.case_count ()) (Test_harness.failure_count ());
   exit (if Test_harness.failure_count () = 0 then 0 else 1)