From e30d1443b32d931480e22ebda70a7d101cae36b1 Mon Sep 17 00:00:00 2001 From: public-release Date: Thu, 21 Nov 2024 20:33:02 +0000 Subject: [PATCH] v0.18~preview.130.05+548 --- .../src}/balance_list_tree.ml | 6 +- .../src}/balance_list_tree.mli | 2 +- balance_list_tree/src/dune | 6 + .../test/balance_list_tree_test.ml | 142 +++++ .../test/balance_list_tree_test.mli | 0 balance_list_tree/test/dune | 6 + bonsai.opam | 2 +- ppx_bonsai/src/expander/dune | 4 +- .../src/expander/ppx_bonsai_expander.ml | 60 +- ppx_bonsai/test/error_location_tests/dune | 0 .../test_match_sub_type_error_location.mlt | 74 +++ .../test/inline/test_match_sub_expansion.ml | 141 +++++ .../test/inline/test_match_sub_expansion.mli | 1 + ppx_bonsai/test/inline/test_subst.ml | 188 +++--- ppx_bonsai/test/inline/test_tree_balancer.ml | 140 ----- ppx_bonsai/test/inline/test_util.ml | 4 + ppx_bonsai/test/inline/test_util.mli | 4 + src/bonsai.ml | 12 +- src/bonsai.mli | 12 +- src/constant_fold.ml | 2 +- src/cont.ml | 54 +- src/cont.mli | 73 ++- src/driver/bonsai_driver.ml | 4 +- src/enable_computation_watcher.ml | 531 ++++++++++++++++ src/enable_computation_watcher.mli | 7 + src/enable_free_variable_monitor.ml | 44 -- src/enable_free_variable_monitor.mli | 4 - src/fix_transform.ml | 23 +- src/graph_info.ml | 2 +- src/linter.ml | 2 +- src/private_eval/annotate_incr.ml | 13 +- src/private_eval/annotate_incr.mli | 10 +- src/private_eval/computation.ml | 15 +- src/private_eval/computation_watcher.ml | 567 ++++++++++++++++++ src/private_eval/computation_watcher.mli | 177 ++++++ src/private_eval/dune | 5 +- src/private_eval/eval.ml | 75 ++- src/private_eval/eval_assoc.ml | 25 +- src/private_eval/eval_assoc.mli | 1 + src/private_eval/eval_assoc_on.ml | 17 +- src/private_eval/eval_assoc_on.mli | 1 + src/private_eval/eval_assoc_simple.ml | 5 +- src/private_eval/eval_assoc_simple.mli | 1 + src/private_eval/eval_computation_watcher.ml | 102 ++++ src/private_eval/eval_computation_watcher.mli | 20 + src/private_eval/eval_fetch.ml | 5 +- src/private_eval/eval_fetch.mli | 1 + src/private_eval/eval_fix.ml | 13 +- src/private_eval/eval_fix.mli | 2 + src/private_eval/eval_lazy.ml | 4 +- src/private_eval/eval_lazy.mli | 1 + src/private_eval/eval_leaf0.ml | 7 +- src/private_eval/eval_leaf0.mli | 1 + src/private_eval/eval_leaf1.ml | 6 +- src/private_eval/eval_leaf1.mli | 1 + src/private_eval/eval_leaf_incr.ml | 5 +- src/private_eval/eval_leaf_incr.mli | 1 + src/private_eval/eval_lifecycle.ml | 3 +- src/private_eval/eval_lifecycle.mli | 1 + .../eval_monitor_free_variables.ml | 46 -- .../eval_monitor_free_variables.mli | 11 - src/private_eval/eval_path.ml | 7 +- src/private_eval/eval_path.mli | 2 +- src/private_eval/eval_return.ml | 5 +- src/private_eval/eval_return.mli | 5 +- src/private_eval/eval_sub.ml | 8 +- src/private_eval/eval_switch.ml | 9 +- src/private_eval/eval_switch.mli | 1 + src/private_eval/eval_with_model_resetter.ml | 3 +- src/private_eval/eval_with_model_resetter.mli | 1 + src/private_eval/eval_wrap.ml | 6 +- src/private_eval/eval_wrap.mli | 1 + src/private_eval/snapshot.ml | 12 +- src/private_eval/snapshot.mli | 8 +- src/private_eval/value.ml | 218 ++++++- src/proc.ml | 38 ++ src/proc_intf.ml | 12 + src/proc_min.ml | 33 +- src/proc_min.mli | 9 +- .../bonsai_introspection_protocol.ml | 2 + .../bonsai_introspection_protocol.mli | 2 + .../introspection/incr_node_introspection.ml | 49 ++ .../introspection/incr_node_introspection.mli | 33 + .../source_code_position_with_quickcheck.ml | 9 + .../source_code_position_with_quickcheck.mli | 3 + src/skeleton.ml | 40 +- src/skeleton.mli | 2 +- src/to_dot.ml | 4 +- src/transform.ml | 21 +- 89 files changed, 2702 insertions(+), 533 deletions(-) rename {ppx_bonsai/src/expander => balance_list_tree/src}/balance_list_tree.ml (87%) rename {ppx_bonsai/src/expander => balance_list_tree/src}/balance_list_tree.mli (84%) create mode 100644 balance_list_tree/src/dune create mode 100644 balance_list_tree/test/balance_list_tree_test.ml rename ppx_bonsai/test/inline/test_tree_balancer.mli => balance_list_tree/test/balance_list_tree_test.mli (100%) create mode 100644 balance_list_tree/test/dune create mode 100644 ppx_bonsai/test/error_location_tests/dune create mode 100644 ppx_bonsai/test/error_location_tests/test_match_sub_type_error_location.mlt create mode 100644 ppx_bonsai/test/inline/test_match_sub_expansion.ml create mode 100644 ppx_bonsai/test/inline/test_match_sub_expansion.mli delete mode 100644 ppx_bonsai/test/inline/test_tree_balancer.ml create mode 100644 ppx_bonsai/test/inline/test_util.ml create mode 100644 ppx_bonsai/test/inline/test_util.mli create mode 100644 src/enable_computation_watcher.ml create mode 100644 src/enable_computation_watcher.mli delete mode 100644 src/enable_free_variable_monitor.ml delete mode 100644 src/enable_free_variable_monitor.mli create mode 100644 src/private_eval/computation_watcher.ml create mode 100644 src/private_eval/computation_watcher.mli create mode 100644 src/private_eval/eval_computation_watcher.ml create mode 100644 src/private_eval/eval_computation_watcher.mli delete mode 100644 src/private_eval/eval_monitor_free_variables.ml delete mode 100644 src/private_eval/eval_monitor_free_variables.mli create mode 100644 src/protocol/introspection/incr_node_introspection.ml create mode 100644 src/protocol/introspection/incr_node_introspection.mli create mode 100644 src/protocol/introspection/source_code_position_with_quickcheck.ml create mode 100644 src/protocol/introspection/source_code_position_with_quickcheck.mli diff --git a/ppx_bonsai/src/expander/balance_list_tree.ml b/balance_list_tree/src/balance_list_tree.ml similarity index 87% rename from ppx_bonsai/src/expander/balance_list_tree.ml rename to balance_list_tree/src/balance_list_tree.ml index 456e99c8..0702a39a 100644 --- a/ppx_bonsai/src/expander/balance_list_tree.ml +++ b/balance_list_tree/src/balance_list_tree.ml @@ -22,16 +22,14 @@ let balance ~n nodes = | _ when Nonempty_list.length chunks > n -> Nonempty_list.map chunks ~f:loop |> loop | _ -> Node (Nonempty_list.map chunks ~f:loop) in - match loop nodes with - | Leaf _ as single -> Nonempty_list.singleton single - | Node ls -> ls + loop nodes ;; let balance ~n list = match Nonempty_list.of_list list with | None -> Or_error.error_string "expand_letn: list of bindings must be non-empty" | Some _ when n <= 0 -> Or_error.error_string "expand_letn: n must be positive" - | Some [ singleton ] when n = 1 -> Ok (Nonempty_list.singleton (Leaf singleton)) + | Some [ singleton ] when n = 1 -> Ok (Leaf singleton) | Some _ when n = 1 -> Or_error.error_string "expand_letn: n may only be 1 if the length of the input list is exactly 1" diff --git a/ppx_bonsai/src/expander/balance_list_tree.mli b/balance_list_tree/src/balance_list_tree.mli similarity index 84% rename from ppx_bonsai/src/expander/balance_list_tree.mli rename to balance_list_tree/src/balance_list_tree.mli index ed896bfc..8d58c435 100644 --- a/ppx_bonsai/src/expander/balance_list_tree.mli +++ b/balance_list_tree/src/balance_list_tree.mli @@ -12,4 +12,4 @@ type 'a t = private - the length of the list is < 1, or - n <= 0, or - n = 1, and the length of the list is not exactly 1 *) -val balance : n:int -> 'a list -> 'a t Nonempty_list.t Or_error.t +val balance : n:int -> 'a list -> 'a t Or_error.t diff --git a/balance_list_tree/src/dune b/balance_list_tree/src/dune new file mode 100644 index 00000000..e01d83d2 --- /dev/null +++ b/balance_list_tree/src/dune @@ -0,0 +1,6 @@ +(library + (name balance_list_tree) + (public_name bonsai.balance_list_tree) + (libraries core core_kernel.nonempty_list) + (preprocess + (pps ppx_jane))) diff --git a/balance_list_tree/test/balance_list_tree_test.ml b/balance_list_tree/test/balance_list_tree_test.ml new file mode 100644 index 00000000..d345d1dc --- /dev/null +++ b/balance_list_tree/test/balance_list_tree_test.ml @@ -0,0 +1,142 @@ +open Core +open Balance_list_tree + +let test ~n ~list_len = + let list = List.init list_len ~f:Fn.id in + match balance ~n list with + | Error error -> print_s [%message (error : Error.t)] + | Ok result -> print_s [%sexp (result : int t)] +;; + +let%expect_test "special case of ~n=1, list_len=1" = + test ~n:1 ~list_len:1; + [%expect {| (Leaf 0) |}] +;; + +let%expect_test "basic behavior" = + test ~n:2 ~list_len:5; + [%expect + {| + (Node + ((Node ((Node ((Leaf 0) (Leaf 1))) (Node ((Leaf 2) (Leaf 3))))) (Leaf 4))) + |}]; + test ~n:5 ~list_len:20; + [%expect + {| + (Node + ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4))) + (Node ((Leaf 5) (Leaf 6) (Leaf 7) (Leaf 8) (Leaf 9))) + (Node ((Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13) (Leaf 14))) + (Node ((Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18) (Leaf 19))))) + |}] +;; + +let%expect_test "(mod n list_len = mod n (-1))" = + test ~n:2 ~list_len:16; + [%expect + {| + (Node + ((Node + ((Node ((Node ((Leaf 0) (Leaf 1))) (Node ((Leaf 2) (Leaf 3))))) + (Node ((Node ((Leaf 4) (Leaf 5))) (Node ((Leaf 6) (Leaf 7))))))) + (Node + ((Node ((Node ((Leaf 8) (Leaf 9))) (Node ((Leaf 10) (Leaf 11))))) + (Node ((Node ((Leaf 12) (Leaf 13))) (Node ((Leaf 14) (Leaf 15))))))))) + |}]; + test ~n:3 ~list_len:5; + [%expect {| (Node ((Node ((Leaf 0) (Leaf 1) (Leaf 2))) (Node ((Leaf 3) (Leaf 4))))) |}]; + test ~n:3 ~list_len:11; + [%expect + {| + (Node + ((Node + ((Node ((Leaf 0) (Leaf 1) (Leaf 2))) (Node ((Leaf 3) (Leaf 4) (Leaf 5))) + (Node ((Leaf 6) (Leaf 7) (Leaf 8))))) + (Node ((Leaf 9) (Leaf 10))))) + |}]; + test ~n:7 ~list_len:13; + [%expect + {| + (Node + ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4) (Leaf 5) (Leaf 6))) + (Node ((Leaf 7) (Leaf 8) (Leaf 9) (Leaf 10) (Leaf 11) (Leaf 12))))) + |}]; + test ~n:5 ~list_len:19; + [%expect + {| + (Node + ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4))) + (Node ((Leaf 5) (Leaf 6) (Leaf 7) (Leaf 8) (Leaf 9))) + (Node ((Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13) (Leaf 14))) + (Node ((Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18))))) + |}] +;; + +let%expect_test "errors" = + test ~n:(-1) ~list_len:5; + [%expect {| (error "expand_letn: n must be positive") |}]; + test ~n:0 ~list_len:5; + [%expect {| (error "expand_letn: n must be positive") |}]; + test ~n:5 ~list_len:0; + [%expect {| (error "expand_letn: list of bindings must be non-empty") |}] +;; + +let%expect_test "regression" = + test ~n:7 ~list_len:50; + [%expect + {| + (Node + ((Node + ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4) (Leaf 5) (Leaf 6))) + (Node + ((Leaf 7) (Leaf 8) (Leaf 9) (Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13))) + (Node + ((Leaf 14) (Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18) (Leaf 19) (Leaf 20))) + (Node + ((Leaf 21) (Leaf 22) (Leaf 23) (Leaf 24) (Leaf 25) (Leaf 26) (Leaf 27))) + (Node + ((Leaf 28) (Leaf 29) (Leaf 30) (Leaf 31) (Leaf 32) (Leaf 33) (Leaf 34))) + (Node + ((Leaf 35) (Leaf 36) (Leaf 37) (Leaf 38) (Leaf 39) (Leaf 40) (Leaf 41))) + (Node + ((Leaf 42) (Leaf 43) (Leaf 44) (Leaf 45) (Leaf 46) (Leaf 47) (Leaf 48))))) + (Leaf 49))) + |}] +;; + +let%quick_test "balancer is balanced, doesn't have more than `n` children per node, and \ + has all leaves exactly once. Also, leaves preserve order. " + = + fun (n : (int[@generator Int.gen_uniform_incl 0 15])) + (list_len : (int[@generator Int.gen_uniform_incl 0 1_000])) -> + let list = List.init list_len ~f:Fn.id in + match balance ~n list, n, list with + | Error _, _, [] | Error _, 0, _ -> () + | Error _, 1, ls when List.length ls > 1 -> () + | Error err, _, _ -> + Error.raise_s + [%message "Balancer errored" (err : Error.t) (n : int) (List.length list : int)] + | Ok balanced, _, _ -> + let last_visited_leaf = ref (-1) in + let rec traverse ~depth = function + | Leaf v -> + assert (v = !last_visited_leaf + 1); + last_visited_leaf := v + | Node children -> + (match children with + | [ Leaf _ ] -> raise_s [%message "Found an unflattened node!"] + | _ -> ()); + assert (Nonempty_list.length children <= n); + Nonempty_list.fold children ~init:`Seen_no_leaves ~f:(fun acc child -> + traverse ~depth:(depth + 1) child; + match acc, child with + | `Seen_no_leaves, Node _ -> `Seen_no_leaves + | `Seen_no_leaves, Leaf _ -> `Seen_leaves + | `Seen_leaves, Node _ -> failwith "All nodes must be before all leaves" + | `Seen_leaves, Leaf _ -> `Seen_leaves) + |> Fn.ignore + in + traverse ~depth:0 balanced; + assert (List.length list = !last_visited_leaf + 1); + [%expect {| |}] +;; diff --git a/ppx_bonsai/test/inline/test_tree_balancer.mli b/balance_list_tree/test/balance_list_tree_test.mli similarity index 100% rename from ppx_bonsai/test/inline/test_tree_balancer.mli rename to balance_list_tree/test/balance_list_tree_test.mli diff --git a/balance_list_tree/test/dune b/balance_list_tree/test/dune new file mode 100644 index 00000000..230e1c29 --- /dev/null +++ b/balance_list_tree/test/dune @@ -0,0 +1,6 @@ +(library + (name balance_list_tree_test) + (libraries balance_list_tree core patdiff.expect_test_patdiff + core_kernel.nonempty_list) + (preprocess + (pps ppx_jane ppx_expect ppx_bonsai ppxlib.metaquot ppx_quick_test))) diff --git a/bonsai.opam b/bonsai.opam index b6d754ba..f37f418c 100644 --- a/bonsai.opam +++ b/bonsai.opam @@ -18,6 +18,7 @@ depends: [ "core_kernel" "incr_map" "incremental" + "ocaml-embed-file" "ppx_here" "ppx_jane" "ppx_let" @@ -26,7 +27,6 @@ depends: [ "uopt" "virtual_dom" "dune" {>= "3.11.0"} - "ocaml-embed-file" "ppxlib" {>= "0.33.0"} ] available: arch != "arm32" & arch != "x86_32" diff --git a/ppx_bonsai/src/expander/dune b/ppx_bonsai/src/expander/dune index 11dd76c9..9583eea2 100644 --- a/ppx_bonsai/src/expander/dune +++ b/ppx_bonsai/src/expander/dune @@ -1,7 +1,7 @@ (library (name ppx_bonsai_expander) (public_name bonsai.ppx_bonsai_expander) - (libraries core core_kernel.nonempty_list ppxlib ppxlib_jane - ppx_let.expander ppx_pattern_bind ppx_here.expander) + (libraries balance_list_tree core core_kernel.nonempty_list + ppx_here.expander ppx_let.expander ppx_pattern_bind ppxlib ppxlib_jane) (preprocess (pps ppxlib.metaquot ppx_jane))) diff --git a/ppx_bonsai/src/expander/ppx_bonsai_expander.ml b/ppx_bonsai/src/expander/ppx_bonsai_expander.ml index dc12e723..cd64f6ef 100644 --- a/ppx_bonsai/src/expander/ppx_bonsai_expander.ml +++ b/ppx_bonsai/src/expander/ppx_bonsai_expander.ml @@ -89,9 +89,13 @@ let sub (location_behavior : Location_behavior.t) : (module Ext) = List.fold pattern_projections ~init:body - ~f:(fun expr { txt = binding; loc } -> + ~f:(fun expr { txt = binding; loc = _ } -> sub_return - ~loc + ~loc: + { loc_start = lhs.ppat_loc.loc_start + ; loc_end = body.pexp_loc.loc_end + ; loc_ghost = true + } ~modul ~lhs:binding.pvb_pat ~rhs:binding.pvb_expr @@ -154,13 +158,16 @@ let sub (location_behavior : Location_behavior.t) : (module Ext) = let expand_match ~loc ~modul ~locality expr = let expr = - match expr.pexp_desc with - | Pexp_tuple expressions -> - match_tuple_mapper - ~modul - ~loc:{ expr.pexp_loc with loc_ghost = true } - ~expressions - ~locality + match Ppxlib_jane.Shim.Expression_desc.of_parsetree ~loc expr.pexp_desc with + | Pexp_tuple labeled_expressions -> + (match Ppxlib_jane.as_unlabeled_tuple labeled_expressions with + | Some expressions -> + match_tuple_mapper + ~modul + ~loc:{ expr.pexp_loc with loc_ghost = true } + ~expressions + ~locality + | None -> expr) | _ -> expr in function @@ -238,20 +245,20 @@ let arr (location_behavior : Location_behavior.t) : (module Ext) = match acc with | true -> true | false -> - (match Ppxlib_jane.Jane_syntax.Pattern.of_ast pattern with - | Some (Jpat_tuple (_tuple, Open), _attrs) -> true - | _ -> - (match Ppxlib_jane.Shim.Pattern_desc.of_parsetree pattern.ppat_desc with - (* let (_ as a) = x in ... *) - | Ppat_alias (_, _) -> false - | Ppat_any - (* let { a ; b ; _ } = x in ... *) - | Ppat_record (_, Open) - (* let { a = (module _) ; b } = x in ... *) - | Ppat_unpack { txt = None; _ } -> true - | Ppat_record (_, Closed) | Ppat_unpack { txt = Some _; _ } -> - super#pattern pattern acc - | _ -> super#pattern pattern acc)) + (match Ppxlib_jane.Shim.Pattern_desc.of_parsetree pattern.ppat_desc with + (* let (_ as a) = x in ... *) + | Ppat_alias (_, _) -> false + | Ppat_any + (* let { a ; b ; _ } = x in ... *) + | Ppat_record (_, Open) + (* let ~a, .. = x in ... *) + | Ppat_tuple (_, Open) + (* let { a = (module _) ; b } = x in ... *) + | Ppat_unpack { txt = None; _ } -> true + | Ppat_record (_, Closed) + | Ppat_tuple (_, Closed) + | Ppat_unpack { txt = Some _; _ } -> super#pattern pattern acc + | _ -> super#pattern pattern acc) end in ignore_finder#pattern pattern false @@ -478,7 +485,12 @@ let arr (location_behavior : Location_behavior.t) : (module Ext) = in match Balance_list_tree.balance ~n ppx_bindings with | Error err -> invalid_arg (Error.to_string_hum err) - | Ok subtrees -> + | Ok balanced -> + let subtrees = + match balanced with + | Balance_list_tree.Leaf _ -> Nonempty_list.singleton balanced + | Node xs -> xs + in let exps, pats = Nonempty_list.map subtrees ~f:loop |> Nonempty_list.unzip in let f_exp = build_multiarg_fun ~args:pats ~body:ppx_body in build_application exps ~f_exp ~op_name:"arr" diff --git a/ppx_bonsai/test/error_location_tests/dune b/ppx_bonsai/test/error_location_tests/dune new file mode 100644 index 00000000..e69de29b diff --git a/ppx_bonsai/test/error_location_tests/test_match_sub_type_error_location.mlt b/ppx_bonsai/test/error_location_tests/test_match_sub_type_error_location.mlt new file mode 100644 index 00000000..a5e688c0 --- /dev/null +++ b/ppx_bonsai/test/error_location_tests/test_match_sub_type_error_location.mlt @@ -0,0 +1,74 @@ +#print_line_numbers true + +open! Bonsai +open Bonsai.Let_syntax + +(* This test file is a regression test for a bug where the errors from the match + arms of a match%sub were instead reported at the start of the match%sub which results + in confusing type error messages! *) + +type t = + | A of int + | B of int + | C of t list + +let _component t (local_ _graph) = + match%sub t with + | A x -> + let%arr x in + x + | B x -> + let%arr x in + x + | C l -> + let%arr l in + let _ = l in + Bonsai.return 1.0 +;; + +[%%expect + {xxx| +Line 23, characters 4-66: +Error: This expression has type float Bonsai.t Bonsai.t + but an expression was expected of type int Bonsai.t + Type float Bonsai.t is not compatible with type int +|xxx}] + +let _more_basic_component t (local_ _graph) = + match%sub Bonsai.return false with + | false -> + (* An int! *) + Bonsai.return 1 + | true -> + (* A float! *) + Bonsai.return 1.0 +;; + +(* This one is fine! *) + +[%%expect + {| +Line 44, characters 4-21: +Error: This expression has type float Bonsai.t + but an expression was expected of type int Bonsai.t + Type float is not compatible with type int +|}] + +let _more_basic_component t (local_ _graph) = + match%sub Bonsai.return false with + | false -> + (* An int! *) + Bonsai.return 1 + | true -> + (* A float! *) + Bonsai.return (Bonsai.return 1) +;; + +(* This one is also fine! (error points to a useful location) *) +[%%expect + {| +Line 64, characters 4-35: +Error: This expression has type int Bonsai.t Bonsai.t + but an expression was expected of type int Bonsai.t + Type int Bonsai.t is not compatible with type int +|}] diff --git a/ppx_bonsai/test/inline/test_match_sub_expansion.ml b/ppx_bonsai/test/inline/test_match_sub_expansion.ml new file mode 100644 index 00000000..3e1829bd --- /dev/null +++ b/ppx_bonsai/test/inline/test_match_sub_expansion.ml @@ -0,0 +1,141 @@ +open! Core +open Ppxlib +open Test_util + +let locality = Ppx_let_expander.Locality.global +let loc = Location.none + +let test expr = + Ppx_let_expander.expand + (Ppx_bonsai_expander.sub Location_of_callsite) + Ppx_let_expander.Extension_kind.default + ~modul:None + ~locality + expr + |> print_expr +;; + +(* This test shows the difference in expansion when there are match%sub arms + with and without type variables. We already have implicit tests for this, but + this test shows that we generate additional expansion code for the match arms that + have bound variables. *) + +let%expect_test "No bound variables" = + test + [%expr + match EXPR with + | Foo1 _ -> ARM1 + | Foo2 _ -> ARM2]; + [%expect + {| + ((Let_syntax.sub + ~here:{ + Ppx_here_lib.pos_fname = "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } (Let_syntax.return EXPR) + ~f:(fun __pattern_syntax__001_ -> + ((Let_syntax.switch + ~here:{ + Ppx_here_lib.pos_fname = "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } + ~match_:((Let_syntax.map __pattern_syntax__001_ + ~f:(function + | Foo1 ((_)[@merlin.focus ]) -> 0 + | Foo2 ((_)[@merlin.focus ]) -> 1)) + [@ocaml.warning "-26-27"]) ~branches:2 + ~with_:(function + | ((0)[@merlin.hide ]) -> ARM1 + | ((1)[@merlin.hide ]) -> ARM2 + | _ -> assert false)) + [@nontail ]))) + [@nontail ]) + |}] +;; + +let%expect_test "1 bound variables" = + test + [%expr + match EXPR with + | Foo1 a_variable -> ARM1 + | Foo2 a_variable -> ARM2]; + [%expect + {| + ((Let_syntax.sub + ~here:{ + Ppx_here_lib.pos_fname = "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } (Let_syntax.return EXPR) + ~f:(fun __pattern_syntax__002_ -> + ((Let_syntax.switch + ~here:{ + Ppx_here_lib.pos_fname = "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } + ~match_:((Let_syntax.map __pattern_syntax__002_ + ~f:(function + | Foo1 a_variable -> 0 + | Foo2 a_variable -> 1)) + [@ocaml.warning "-26-27"]) ~branches:2 + ~with_:(function + | ((0)[@merlin.hide ]) -> + ((Let_syntax.sub + ~here:{ + Ppx_here_lib.pos_fname = "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } + (Let_syntax.return + ((Let_syntax.map + ~here:{ + Ppx_here_lib.pos_fname = + "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } __pattern_syntax__002_ + ~f:((function + | Foo1 __pattern_syntax__003_ -> + __pattern_syntax__003_ + | _ -> assert false) + [@ocaml.warning "-11"]))[@merlin.hide ])) + ~f:(fun a_variable -> ((ARM1)[@nontail ]))) + [@nontail ]) + | ((1)[@merlin.hide ]) -> + ((Let_syntax.sub + ~here:{ + Ppx_here_lib.pos_fname = "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } + (Let_syntax.return + ((Let_syntax.map + ~here:{ + Ppx_here_lib.pos_fname = + "_none_"; + pos_lnum = 0; + pos_cnum = (-1); + pos_bol = 0 + } __pattern_syntax__002_ + ~f:((function + | Foo2 __pattern_syntax__004_ -> + __pattern_syntax__004_ + | _ -> assert false) + [@ocaml.warning "-11"]))[@merlin.hide ])) + ~f:(fun a_variable -> ((ARM2)[@nontail ]))) + [@nontail ]) + | _ -> assert false)) + [@nontail ]))) + [@nontail ]) + |}] +;; diff --git a/ppx_bonsai/test/inline/test_match_sub_expansion.mli b/ppx_bonsai/test/inline/test_match_sub_expansion.mli new file mode 100644 index 00000000..53e67be6 --- /dev/null +++ b/ppx_bonsai/test/inline/test_match_sub_expansion.mli @@ -0,0 +1 @@ +(*_ Intentionally left empty. *) diff --git a/ppx_bonsai/test/inline/test_subst.ml b/ppx_bonsai/test/inline/test_subst.ml index bd4c234b..54ac68a9 100644 --- a/ppx_bonsai/test/inline/test_subst.ml +++ b/ppx_bonsai/test/inline/test_subst.ml @@ -1,9 +1,9 @@ open Core open Ppxlib +open Test_util let locality = Ppx_let_expander.Locality.global let loc = Location.none -let print_expr expr = Pprintast.string_of_expression expr |> print_string let%expect_test "single let%sub " = Ppx_let_expander.expand @@ -20,7 +20,7 @@ let%expect_test "single let%sub " = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } ((MY_EXPR)[@ppxlib.enter_value a]) ~f:(fun a -> MY_BODY)) @@ -61,7 +61,7 @@ let%expect_test "single pattern sub with modul" = ((X.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } ((MY_EXPR)[@ppxlib.enter_value a]) ~f:(fun a -> MY_BODY)) @@ -110,7 +110,7 @@ let%expect_test "single pattern sub open" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } ((MY_EXPR_1)[@ppxlib.enter_value a]) ~f:(fun a -> MY_BODY)) @@ -159,7 +159,7 @@ let%expect_test "if%sub is supported" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return MY_EXPR_1) @@ -167,7 +167,7 @@ let%expect_test "if%sub is supported" = ((Let_syntax.switch ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -198,7 +198,7 @@ let%expect_test "very simple match%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return MY_EXPR_1) ~f:(fun a -> BODY_1)) @@ -221,7 +221,7 @@ let%expect_test "destructuring let%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } MY_EXPR @@ -229,7 +229,7 @@ let%expect_test "destructuring let%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -237,7 +237,7 @@ let%expect_test "destructuring let%sub" = ((Let_syntax.map ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__007_ @@ -248,7 +248,7 @@ let%expect_test "destructuring let%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -256,7 +256,7 @@ let%expect_test "destructuring let%sub" = ((Let_syntax.map ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__007_ @@ -269,7 +269,7 @@ let%expect_test "destructuring let%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -278,7 +278,7 @@ let%expect_test "destructuring let%sub" = ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__007_ @@ -368,7 +368,7 @@ let%expect_test "destructuring let%sub (comparing location of callsite vs locati -|((Let_syntax.sub -| ~here:{ -| Ppx_here_lib.pos_fname = "_none_"; - -| pos_lnum = 1; + -| pos_lnum = 0; -| pos_cnum = (-1); -| pos_bol = 0 -| } MY_EXPR @@ -377,7 +377,7 @@ let%expect_test "destructuring let%sub (comparing location of callsite vs locati -| ((Let_syntax.sub -| ~here:{ -| Ppx_here_lib.pos_fname = "_none_"; - -| pos_lnum = 1; + -| pos_lnum = 0; -| pos_cnum = (-1); -| pos_bol = 0 -| } @@ -386,7 +386,7 @@ let%expect_test "destructuring let%sub (comparing location of callsite vs locati -| ((Let_syntax.map -| ~here:{ -| Ppx_here_lib.pos_fname = "_none_"; - -| pos_lnum = 1; + -| pos_lnum = 0; -| pos_cnum = (-1); -| pos_bol = 0 -| } __pattern_syntax__ID_REPLACED_IN_TEST_ @@ -399,7 +399,7 @@ let%expect_test "destructuring let%sub (comparing location of callsite vs locati -| ((Let_syntax.sub -| ~here:{ -| Ppx_here_lib.pos_fname = "_none_"; - -| pos_lnum = 1; + -| pos_lnum = 0; -| pos_cnum = (-1); -| pos_bol = 0 -| } @@ -408,7 +408,7 @@ let%expect_test "destructuring let%sub (comparing location of callsite vs locati -| ((Let_syntax.map -| ~here:{ -| Ppx_here_lib.pos_fname = "_none_"; - -| pos_lnum = 1; + -| pos_lnum = 0; -| pos_cnum = (-1); -| pos_bol = 0 -| } __pattern_syntax__ID_REPLACED_IN_TEST_ @@ -423,7 +423,7 @@ let%expect_test "destructuring let%sub (comparing location of callsite vs locati -| ((Let_syntax.sub -| ~here:{ -| Ppx_here_lib.pos_fname = "_none_"; - -| pos_lnum = 1; + -| pos_lnum = 0; -| pos_cnum = (-1); -| pos_bol = 0 -| } @@ -433,7 +433,7 @@ let%expect_test "destructuring let%sub (comparing location of callsite vs locati -| ~here:{ -| Ppx_here_lib.pos_fname = -| "_none_"; - -| pos_lnum = 1; + -| pos_lnum = 0; -| pos_cnum = (-1); -| pos_bol = 0 -| } __pattern_syntax__ID_REPLACED_IN_TEST_ @@ -470,7 +470,7 @@ let%expect_test "destructuring match%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return MY_EXPR) @@ -478,7 +478,7 @@ let%expect_test "destructuring match%sub" = ((Let_syntax.switch ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -493,7 +493,7 @@ let%expect_test "destructuring match%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -502,7 +502,7 @@ let%expect_test "destructuring match%sub" = ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__023_ @@ -517,7 +517,7 @@ let%expect_test "destructuring match%sub" = ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -526,7 +526,7 @@ let%expect_test "destructuring match%sub" = ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__023_ @@ -628,7 +628,7 @@ let%expect_test "single-case match%sub doesn't call switch" = ((Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Module.Let_syntax.Let_syntax.return MY_EXPR) @@ -636,7 +636,7 @@ let%expect_test "single-case match%sub doesn't call switch" = ((Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -644,7 +644,7 @@ let%expect_test "single-case match%sub doesn't call switch" = ((Module.Let_syntax.Let_syntax.map ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__029_ @@ -674,7 +674,7 @@ let%expect_test "module-qualified match%sub" = ((Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Module.Let_syntax.Let_syntax.return MY_EXPR) @@ -682,7 +682,7 @@ let%expect_test "module-qualified match%sub" = ((Module.Let_syntax.Let_syntax.switch ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -695,7 +695,7 @@ let%expect_test "module-qualified match%sub" = ((Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -704,7 +704,7 @@ let%expect_test "module-qualified match%sub" = ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__031_ @@ -719,7 +719,7 @@ let%expect_test "module-qualified match%sub" = ((Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -728,7 +728,7 @@ let%expect_test "module-qualified match%sub" = ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__031_ @@ -760,7 +760,7 @@ let%expect_test "type annotations are preserved" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } EXPR @@ -768,7 +768,7 @@ let%expect_test "type annotations are preserved" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -776,7 +776,7 @@ let%expect_test "type annotations are preserved" = ((Let_syntax.map ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__034_ @@ -804,7 +804,7 @@ let%expect_test "function%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return __let_syntax__035_) @@ -812,7 +812,7 @@ let%expect_test "function%sub" = ((Let_syntax.switch ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -824,7 +824,7 @@ let%expect_test "function%sub" = ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -833,7 +833,7 @@ let%expect_test "function%sub" = ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__036_ @@ -869,7 +869,7 @@ let%expect_test "function%arr" = Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__038_ @@ -892,7 +892,7 @@ let%expect_test "destructuring let%arr uses cutoff" = Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -928,7 +928,7 @@ let%expect_test "destructuring let%arr uses cutoff, if specific fields have igno Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -996,7 +996,7 @@ let%expect_test "destructuring let%arr uses cutoff (multiple arms)" = Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1045,7 +1045,7 @@ let%expect_test "one arm of destructuring let%arr uses cutoff" = Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1079,7 +1079,7 @@ let%expect_test "Destructuring does not happen when there is no ignoring" = Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } MY_EXPR ~f:(fun (a, { b; c; d }) -> MY_BODY) @@ -1104,7 +1104,7 @@ let%expect_test "Destructuring does not happen when there is no ignoring (multip Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__087_ __let_syntax__088_ @@ -1135,7 +1135,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } ((NO_DESTRUCTION)[@ppxlib.enter_value a]) ~f:(fun a -> BODY) @@ -1159,7 +1159,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__092_ __let_syntax__093_ ~f:(fun a b -> BODY) @@ -1183,7 +1183,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__096_ __let_syntax__097_ @@ -1204,7 +1204,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1226,7 +1226,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1255,7 +1255,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1283,7 +1283,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1311,7 +1311,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } NO_DESTRUCTION ~f:(fun { a; b } -> BODY) @@ -1331,7 +1331,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__126_ __let_syntax__127_ @@ -1349,7 +1349,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } NO_DESTRUCTION ~f:(fun ({ a; b = (module X) }, c) -> BODY) @@ -1366,7 +1366,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1393,7 +1393,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.cutoff ALWAYS_EQUAL ~equal:(fun _ _ -> true)) @@ -1415,7 +1415,7 @@ module%test [@name "Destructuring vs. no destructuring criteria."] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1446,7 +1446,7 @@ let%expect_test "current match%arr behavior" = Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } EXPR @@ -1476,7 +1476,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1495,7 +1495,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.switch ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1521,7 +1521,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1559,7 +1559,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1567,7 +1567,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.map ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__159_ @@ -1591,7 +1591,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return EXPR) @@ -1599,7 +1599,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.switch ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1615,7 +1615,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ((Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } @@ -1624,7 +1624,7 @@ module%test [@name "match%sub with tuple payload"] _ = struct ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __pattern_syntax__160_ @@ -1664,7 +1664,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } ((E)[@ppxlib.enter_value a]) ~f:(fun a -> MY_BODY) @@ -1686,7 +1686,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__163_ __let_syntax__164_ ~f:(fun x1 x2 -> MY_BODY) @@ -1720,7 +1720,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr6 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__167_ __let_syntax__168_ __let_syntax__169_ @@ -1759,7 +1759,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__179_ __let_syntax__180_ __let_syntax__181_ @@ -1801,14 +1801,14 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__193_ __let_syntax__194_ __let_syntax__195_ @@ -1870,14 +1870,14 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__210_ __let_syntax__211_ __let_syntax__212_ @@ -1887,7 +1887,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__217_ __let_syntax__218_ __let_syntax__219_ @@ -1947,14 +1947,14 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__240_ __let_syntax__241_ __let_syntax__242_ @@ -1964,7 +1964,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map6 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__247_ __let_syntax__248_ __let_syntax__249_ @@ -2135,21 +2135,21 @@ module%test [@name "arrn nesting edge cases"] _ = struct Let_syntax.arr2 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__268_ __let_syntax__269_ __let_syntax__270_ @@ -2159,7 +2159,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__275_ __let_syntax__276_ __let_syntax__277_ @@ -2169,7 +2169,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__282_ __let_syntax__283_ __let_syntax__284_ @@ -2179,7 +2179,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__289_ __let_syntax__290_ __let_syntax__291_ @@ -2189,7 +2189,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__296_ __let_syntax__297_ __let_syntax__298_ @@ -2199,7 +2199,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__303_ __let_syntax__304_ __let_syntax__305_ @@ -2209,7 +2209,7 @@ module%test [@name "arrn nesting edge cases"] _ = struct (Let_syntax.map7 ~here:{ Ppx_here_lib.pos_fname = "_none_"; - pos_lnum = 1; + pos_lnum = 0; pos_cnum = (-1); pos_bol = 0 } __let_syntax__310_ __let_syntax__311_ __let_syntax__312_ diff --git a/ppx_bonsai/test/inline/test_tree_balancer.ml b/ppx_bonsai/test/inline/test_tree_balancer.ml deleted file mode 100644 index f76f8184..00000000 --- a/ppx_bonsai/test/inline/test_tree_balancer.ml +++ /dev/null @@ -1,140 +0,0 @@ -open Core -open Ppx_bonsai_expander.For_testing.Balance_list_tree - -let test ~n ~list_len = - let list = List.init list_len ~f:Fn.id in - match balance ~n list with - | Error error -> print_s [%message (error : Error.t)] - | Ok result -> - Nonempty_list.iter result ~f:(fun result -> print_s [%sexp (result : int t)]) -;; - -let%expect_test "special case of ~n=1, list_len=1" = - test ~n:1 ~list_len:1; - [%expect {| (Leaf 0) |}] -;; - -let%expect_test "basic behavior" = - test ~n:2 ~list_len:5; - [%expect - {| - (Node ((Node ((Leaf 0) (Leaf 1))) (Node ((Leaf 2) (Leaf 3))))) - (Leaf 4) - |}]; - test ~n:5 ~list_len:20; - [%expect - {| - (Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4))) - (Node ((Leaf 5) (Leaf 6) (Leaf 7) (Leaf 8) (Leaf 9))) - (Node ((Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13) (Leaf 14))) - (Node ((Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18) (Leaf 19))) - |}] -;; - -let%expect_test "(mod n list_len = mod n (-1))" = - test ~n:2 ~list_len:16; - [%expect - {| - (Node - ((Node ((Node ((Leaf 0) (Leaf 1))) (Node ((Leaf 2) (Leaf 3))))) - (Node ((Node ((Leaf 4) (Leaf 5))) (Node ((Leaf 6) (Leaf 7))))))) - (Node - ((Node ((Node ((Leaf 8) (Leaf 9))) (Node ((Leaf 10) (Leaf 11))))) - (Node ((Node ((Leaf 12) (Leaf 13))) (Node ((Leaf 14) (Leaf 15))))))) - |}]; - test ~n:3 ~list_len:5; - [%expect - {| - (Node ((Leaf 0) (Leaf 1) (Leaf 2))) - (Node ((Leaf 3) (Leaf 4))) - |}]; - test ~n:3 ~list_len:11; - [%expect - {| - (Node - ((Node ((Leaf 0) (Leaf 1) (Leaf 2))) (Node ((Leaf 3) (Leaf 4) (Leaf 5))) - (Node ((Leaf 6) (Leaf 7) (Leaf 8))))) - (Node ((Leaf 9) (Leaf 10))) - |}]; - test ~n:7 ~list_len:13; - [%expect - {| - (Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4) (Leaf 5) (Leaf 6))) - (Node ((Leaf 7) (Leaf 8) (Leaf 9) (Leaf 10) (Leaf 11) (Leaf 12))) - |}]; - test ~n:5 ~list_len:19; - [%expect - {| - (Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4))) - (Node ((Leaf 5) (Leaf 6) (Leaf 7) (Leaf 8) (Leaf 9))) - (Node ((Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13) (Leaf 14))) - (Node ((Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18))) - |}] -;; - -let%expect_test "errors" = - test ~n:(-1) ~list_len:5; - [%expect {| (error "expand_letn: n must be positive") |}]; - test ~n:0 ~list_len:5; - [%expect {| (error "expand_letn: n must be positive") |}]; - test ~n:5 ~list_len:0; - [%expect {| (error "expand_letn: list of bindings must be non-empty") |}] -;; - -let%expect_test "regression" = - test ~n:7 ~list_len:50; - [%expect - {| - (Node - ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4) (Leaf 5) (Leaf 6))) - (Node ((Leaf 7) (Leaf 8) (Leaf 9) (Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13))) - (Node - ((Leaf 14) (Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18) (Leaf 19) (Leaf 20))) - (Node - ((Leaf 21) (Leaf 22) (Leaf 23) (Leaf 24) (Leaf 25) (Leaf 26) (Leaf 27))) - (Node - ((Leaf 28) (Leaf 29) (Leaf 30) (Leaf 31) (Leaf 32) (Leaf 33) (Leaf 34))) - (Node - ((Leaf 35) (Leaf 36) (Leaf 37) (Leaf 38) (Leaf 39) (Leaf 40) (Leaf 41))) - (Node - ((Leaf 42) (Leaf 43) (Leaf 44) (Leaf 45) (Leaf 46) (Leaf 47) (Leaf 48))))) - (Leaf 49) - |}] -;; - -let%quick_test "balancer is balanced, doesn't have more than `n` children per node, and \ - has all leaves exactly once. Also, leaves preserve order. " - = - fun (n : (int[@generator Int.gen_uniform_incl 0 15])) - (list_len : (int[@generator Int.gen_uniform_incl 0 1_000])) -> - let list = List.init list_len ~f:Fn.id in - match balance ~n list, n, list with - | Error _, _, [] | Error _, 0, _ -> () - | Error _, 1, ls when List.length ls > 1 -> () - | Error err, _, _ -> - Error.raise_s - [%message "Balancer errored" (err : Error.t) (n : int) (List.length list : int)] - | Ok balanced, _, _ -> - let last_visited_leaf = ref (-1) in - assert (Nonempty_list.length balanced <= n); - Nonempty_list.iter balanced ~f:(fun subtree -> - let min_depth = ref Int.max_value in - let max_depth = ref 0 in - let rec traverse ~depth = function - | Leaf v -> - assert (v = !last_visited_leaf + 1); - last_visited_leaf := v; - max_depth := max depth !max_depth; - min_depth := min depth !min_depth - | Node children -> - (match children with - | [ Leaf _ ] -> raise_s [%message "Found an unflattened node!"] - | _ -> ()); - assert (Nonempty_list.length children <= n); - Nonempty_list.iter children ~f:(fun child -> traverse ~depth:(depth + 1) child) - in - assert (!max_depth - !min_depth <= 1); - traverse ~depth:0 subtree); - assert (List.length list = !last_visited_leaf + 1); - [%expect {| |}] -;; diff --git a/ppx_bonsai/test/inline/test_util.ml b/ppx_bonsai/test/inline/test_util.ml new file mode 100644 index 00000000..4d1a846d --- /dev/null +++ b/ppx_bonsai/test/inline/test_util.ml @@ -0,0 +1,4 @@ +open! Core +open Ppxlib + +let print_expr expr = Pprintast.string_of_expression expr |> print_string diff --git a/ppx_bonsai/test/inline/test_util.mli b/ppx_bonsai/test/inline/test_util.mli new file mode 100644 index 00000000..ee1d3489 --- /dev/null +++ b/ppx_bonsai/test/inline/test_util.mli @@ -0,0 +1,4 @@ +open! Core +open Ppxlib + +val print_expr : expression -> unit diff --git a/src/bonsai.ml b/src/bonsai.ml index 6c2ccd05..f7a0681e 100644 --- a/src/bonsai.ml +++ b/src/bonsai.ml @@ -19,7 +19,7 @@ module Private = struct module Path = Path module Action = Action module Stabilization_tracker = Stabilization_tracker - module Enable_free_variable_monitor = Enable_free_variable_monitor + module Enable_computation_watcher = Enable_computation_watcher module Node_path = Node_path module Graph_info = Graph_info module Instrumentation = Instrumentation @@ -30,6 +30,7 @@ module Private = struct module Linter = Linter module Trampoline = Trampoline module Annotate_incr = Annotate_incr + module Computation_watcher = Computation_watcher let path ?(here = Stdlib.Lexing.dummy_pos) graph = Proc_layer2.path ~here () graph let gather = Eval.gather @@ -52,7 +53,14 @@ module Proc = struct end end -module Cont = Cont +module Cont = struct + include Cont + + module Bonsai = struct + include Cont + end +end + include Cont module For_open = struct diff --git a/src/bonsai.mli b/src/bonsai.mli index 49f33148..aedc64de 100644 --- a/src/bonsai.mli +++ b/src/bonsai.mli @@ -15,6 +15,13 @@ module Cont : sig module type of Cont with module For_proc2 := Cont.For_proc2 and module Conv := Cont.Conv + + module Bonsai : sig + include + module type of Cont + with module For_proc2 := Cont.For_proc2 + and module Conv := Cont.Conv + end end module Private : sig @@ -55,12 +62,13 @@ module Private : sig module Instrumentation = Instrumentation module Flatten_values = Flatten_values module Constant_fold = Constant_fold - module Enable_free_variable_monitor = Enable_free_variable_monitor + module Enable_computation_watcher = Enable_computation_watcher module Skeleton = Skeleton module Transform = Transform module Linter = Linter module Trampoline = Trampoline module Annotate_incr = Annotate_incr + module Computation_watcher = Computation_watcher val gather : recursive_scopes:Computation.Recursive_scopes.t @@ -116,7 +124,7 @@ module Stable : sig end end -include module type of Cont +include module type of Cont with module Map := Cont.Map module For_open : sig module Effect = Effect diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 299c5005..ce6aa2d6 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -458,7 +458,7 @@ module Constant_fold (Recurse : Fix_transform.Recurse with module Types := Types | With_model_resetter _ | Path _ | Assoc_simpl _ - | Monitor_free_variables _ + | Computation_watcher _ | Lifecycle _ -> let%bind (), (), c = Recurse.on_computation { constants_in_scope; evaluated } () `Skipping_over t diff --git a/src/cont.ml b/src/cont.ml index 004fedb0..30e4d83d 100644 --- a/src/cont.ml +++ b/src/cont.ml @@ -242,6 +242,12 @@ let map7 ?(here = Stdlib.Lexing.dummy_pos) a b c d e g h ~f = ~no_graph:(fun () -> Value.map7 ~here a b c d e g h ~f) ;; +let all ?(here = Stdlib.Lexing.dummy_pos) ts = + with_global_graph + ~f:(fun graph -> perform ~here graph (Proc.read ~here (Value.all ~here ts))) + ~no_graph:(fun () -> Value.all ts) +;; + module Autopack = struct type 'a bonsai = 'a Value.t @@ -423,6 +429,29 @@ let state_opt |> split ~here graph ;; +let state'__for_proc2 + ?(here = Stdlib.Lexing.dummy_pos) + ?reset + ?sexp_of_model + ?equal + default_model + graph + = + perform ~here graph (Proc.state' ~here ?reset ?sexp_of_model ?equal default_model) +;; + +let state' + ?(here = Stdlib.Lexing.dummy_pos) + ?reset + ?sexp_of_model + ?equal + default_model + graph + = + state'__for_proc2 ~here ?reset ?sexp_of_model ?equal default_model graph + |> split ~here graph +;; + let toggle__for_proc2 ?(here = Stdlib.Lexing.dummy_pos) ~default_model graph = perform ~here graph (Proc.toggle ~here ~default_model ()) ;; @@ -1269,11 +1298,31 @@ module Debug = struct |> perform ~here graph ;; - let monitor_free_variables ?(here = Stdlib.Lexing.dummy_pos) ~f graph = + let watch_computation + ?(here = Stdlib.Lexing.dummy_pos) + ?(log_model_before = false) + ?(log_model_after = false) + ?(log_action = false) + ?(log_incr_info = true) + ?(log_watcher_positions = true) + ?(log_dependency_definition_position = true) + ?label + ~f + graph + = perform graph + (Proc.watch_computation + ~here + ~log_model_before + ~log_model_after + ~log_action + ~log_incr_info + ~log_watcher_positions + ~log_dependency_definition_position + ~label + (handle graph ~f:(fun graph -> f graph))) ~here - (Proc.monitor_free_variables ~here (handle graph ~f:(fun graph -> f graph))) ;; end @@ -1348,6 +1397,7 @@ module For_proc2 = struct let value_cutoff v ~equal = Value.cutoff v ~equal ~added_by_let_syntax:false let conceal_value v = v let state = state__for_proc2 + let state' = state'__for_proc2 let state_opt = state_opt__for_proc2 let toggle = toggle__for_proc2 diff --git a/src/cont.mli b/src/cont.mli index 06db1b76..7977e420 100644 --- a/src/cont.mli +++ b/src/cont.mli @@ -147,6 +147,17 @@ val state_opt -> graph -> 'model option t * ('model option -> unit Effect.t) t +(** Similar to [state], but the `set` function takes a function that calculates + the new state from the previous state. *) +val state' + : ?here:Stdlib.Lexing.position + -> ?reset:('model -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> 'model + -> graph + -> 'model t * (?here:Stdlib.Lexing.position -> ('model -> 'model) -> unit Effect.t) t + (** [Bonsai.toggle] is a small helper function for building a [bool] state that toggles back and forth between [true] and [false] whenever the [unit Effect.t] is scheduled. *) @@ -911,16 +922,59 @@ module Debug : sig val enable_incremental_annotations : unit -> unit val disable_incremental_annotations : unit -> unit - (** Wrapping [monitor_free_variables] around a computation will add informative print + (** Wrapping [watch_computation] around a computation will add informative print statements every time that a value defined outside the closue - and used _inside_ the closure - is updated. This can be useful to debug why a component is being updated. - By default, calls to [monitor_free_variables] are no-ops, and must be enabled - manually with external tools. This is so you can leave calls to this function - in production builds without impacting performance until you start debugging. *) - val monitor_free_variables + By default, calls to [watch_computation] are no-ops, and must be enabled manually + with external tools. This is so you can leave calls to this function in production + builds without impacting performance until you start debugging. + + [log_model_before]: Will log a state machine's model before apply_action/reset is + called. Uses the sexp_of_model function passed to the state machine, or + sexp_of_opaque if no sexp function is provided. + (Default: false) + + [log_model_after]: Will log a state machine's model after apply_action/reset is + applied to it. Uses the sexp_of_model function passed to the state machine, or + sexp_of_opaque if no sexp function is provided. + (Default: false) + + [log_action]: Logs the action applied to the state machine. Uses the sexp_of_action + function passed to the state machine, or sexp_of_opaque if no sexp function is + provided. + (Default: false) + + [log_incr_info]: Will log a state machine's model after apply_action/reset is + applied to it. Uses the sexp_of_model function passed to the state machine, or + sexp_of_opaque if no sexp function is provided. + (Default: false) + + [log_watcher_positions]: Logs the source code positions of the Computation_watcher + nodes that are relevant to the current change. The node nearest to the change is at + the top + (Default: true) + + [log_dependency_definition_position]: Logs the source code position of the + Computation node that updated and caused the watched computation to update. + (Default: true) + + [label]: Prefixes the watcher position in the list of watchers for easier + identification of individual watchers. Will not show up if [log_watcher_positions] + is set to false + (Default: None) + + *) + val watch_computation : ?here:Stdlib.Lexing.position + -> ?log_model_before:bool + -> ?log_model_after:bool + -> ?log_action:bool + -> ?log_incr_info:bool + -> ?log_watcher_positions:bool + -> ?log_dependency_definition_position:bool + -> ?label:string -> f:(graph -> 'a t) -> graph -> 'a t @@ -1161,6 +1215,15 @@ module For_proc2 : sig -> graph -> ('model * ('model -> unit Effect.t)) t + val state' + : ?here:Stdlib.Lexing.position + -> ?reset:('model -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> 'model + -> graph + -> ('model * (?here:Stdlib.Lexing.position -> ('model -> 'model) -> unit Effect.t)) t + val state_opt : ?here:Stdlib.Lexing.position -> ?reset:('model option -> 'model option) diff --git a/src/driver/bonsai_driver.ml b/src/driver/bonsai_driver.ml index 0df852dd..51ebfa32 100644 --- a/src/driver/bonsai_driver.ml +++ b/src/driver/bonsai_driver.ml @@ -119,7 +119,9 @@ let create_direct in let action_input = Incr.observe action_input_incr in let result = result_incr |> Incr.observe in - let lifecycle_incr = Bonsai.Private.Snapshot.lifecycle_or_empty snapshot in + let lifecycle_incr = + Bonsai.Private.Snapshot.lifecycle_or_empty ~here:[%here] snapshot + in let lifecycle = Incr.observe lifecycle_incr in Incr.stabilize (); T diff --git a/src/enable_computation_watcher.ml b/src/enable_computation_watcher.ml new file mode 100644 index 00000000..eb651d72 --- /dev/null +++ b/src/enable_computation_watcher.ml @@ -0,0 +1,531 @@ +open! Core +open! Import +module Source_code_positions = Computation_watcher.Source_code_positions +module Output_queue = Computation_watcher.Output_queue + +module Types = struct + module Down = struct + type t = + { source_code_positions : Source_code_positions.pending Source_code_positions.t + ; visited_stores : Type_equal.Id.Uid.Set.t + ; watcher_queue : Output_queue.t + ; config : Computation_watcher.Config.t + ; enable_watcher : bool + ; should_run_computation_watcher : bool + ; value_type_id_observation_definition_positions : + (Source_code_positions.finalized Source_code_positions.t + * Computation_watcher.Config.t) + Computation_watcher.Type_id_location_hashmap.t + } + end + + module Acc = Unit + + module Up = struct + type t = Computation_watcher.Type_id_location_map.t + + let empty = Computation_watcher.Type_id_location_map.empty + let combine = Computation_watcher.Type_id_location_map.merge + let empty_for_lazy = empty + end +end + +let rewrite_resetter + ~reset + ~model + ~(down : Types.Down.t) + ~(kind : [ `State_machine0 | `State_machine1 | `Wrap ]) + ~watcher_queue + ~source_code_positions + = + let reset ~inject ~schedule_event ~time_source reset_model = + let new_model = reset ~inject ~schedule_event ~time_source reset_model in + if not (model.Meta.Model.equal new_model reset_model) + then + Queue.enqueue + watcher_queue + (Computation_watcher.Node.Reset + { source_code_positions = + Source_code_positions.extract_finalized source_code_positions + ; config = down.config + ; model_before = reset_model + ; model_after = new_model + ; sexp_of_model = model.Meta.Model.sexp_of + ; kind + }); + new_model + in + reset +;; + +let apply_action_wrapper + ~model + ~action + ~(down : Types.Down.t) + ~apply_action_model + ~apply_action_action + ~(kind : [ `Wrap | `State_machine1 | `State_machine0 ]) + ~watcher_queue + ~source_code_positions + partially_applied_apply_action + = + let new_model = partially_applied_apply_action apply_action_model apply_action_action in + if not (phys_equal apply_action_model new_model) + then + Queue.enqueue + watcher_queue + (Computation_watcher.Node.State_machine_like + { source_code_positions = + Source_code_positions.extract_finalized source_code_positions + ; config = down.config + ; model_before = apply_action_model + ; model_after = new_model + ; sexp_of_model = model.Meta.Model.sexp_of + ; action = Some apply_action_action + ; sexp_of_action = Some (Type_equal.Id.to_sexp action) + ; kind + }); + new_model +;; + +let rewrite_apply_action_leaf1 + ~apply_action + ~model + ~action + ~down + ~(kind : [> `Wrap | `State_machine1 ]) + ~watcher_queue + ~source_code_positions + = + let apply_action + ~inject + ~schedule_event + ~time_source + apply_action_input + apply_action_model + apply_action_action + = + apply_action ~inject ~schedule_event ~time_source apply_action_input + |> apply_action_wrapper + ~model + ~action + ~down + ~apply_action_model + ~apply_action_action + ~kind + ~watcher_queue + ~source_code_positions + in + apply_action +;; + +let rewrite_apply_action_leaf0 + ~apply_action + ~model + ~action + ~down + ~watcher_queue + ~source_code_positions + = + let apply_action + ~inject + ~schedule_event + ~time_source + apply_action_model + apply_action_action + = + apply_action ~inject ~schedule_event ~time_source + |> apply_action_wrapper + ~model + ~action + ~down + ~apply_action_model + ~apply_action_action + ~kind:`State_machine0 + ~watcher_queue + ~source_code_positions + in + apply_action +;; + +module F (Recurse : Fix_transform.Recurse with module Types := Types) = struct + open Trampoline.Let_syntax + + let transform_v + (type a) + ({ Types.Down.source_code_positions + ; should_run_computation_watcher = _ + ; config + ; watcher_queue + ; enable_watcher + ; value_type_id_observation_definition_positions + ; visited_stores = _ + } as down) + () + ({ value; id; here } as v : a Value.t) + = + (* We only want to transform values if we're below a Computation_watcher node, which + is what [enable_watcher] signifies *) + match enable_watcher with + | false -> Recurse.on_value down () `Skipping_over v + | true -> + (match value with + | Named _ -> + ( () + , Computation_watcher.Type_id_location_map.singleton + id + (Source_code_positions.add_dependency_definition source_code_positions here) + , v ) + | Incr incr_value -> + let has_been_set = + Computation_watcher.Type_id_location_hashmap.update_and_check_if_value_set + ~id + ~update_data: + ( Source_code_positions.add_dependency_definition source_code_positions here + |> Source_code_positions.extract_finalized + , config ) + value_type_id_observation_definition_positions + in + let value_node = + match has_been_set with + | `Not_set -> + let new_incr = + Computation_watcher.instrument_incremental_node + ~here:[%here] + ~kind:`Incr + ~watcher_queue + ~value_type_id_observation_definition_positions + ~id + incr_value + in + { Value.value = Incr new_incr; id; here } + | `Already_set -> v + in + (), Computation_watcher.Type_id_location_map.empty, value_node + | Map _ | Map2 _ | Map3 _ | Map4 _ | Map5 _ | Map6 _ | Map7 _ -> + Recurse.on_value + { down with + source_code_positions = + Source_code_positions.add_depended_on_at source_code_positions here + } + () + `Skipping_over + v + (* For any other node, just perform the default *) + | _ -> Recurse.on_value down () `Skipping_over v) + ;; + + let transform_c + (type a) + (Types.Down. + { source_code_positions + ; config + ; should_run_computation_watcher + ; watcher_queue + ; enable_watcher + ; visited_stores + ; value_type_id_observation_definition_positions + } as down) + () + (t : a Computation.t) + = + match t with + | Sub { via; from = _; into = _; here = _ } -> + let%bind (), free_vars, c = Recurse.on_computation down () `Skipping_over t in + (* the values bound in a sub are no longer free, so remove them *) + return ((), Computation_watcher.Type_id_location_map.remove free_vars via, c) + | Fix_define { fix_id = _; initial_input = _; input_id; result = _; here = _ } -> + let%bind (), free_vars, c = Recurse.on_computation down () `Skipping_over t in + (* input_id is no longer free, remove it. Fix_define is the top-level node for + Fix_recurse *) + return ((), Computation_watcher.Type_id_location_map.remove free_vars input_id, c) + | Assoc { map = _; key_comparator = _; key_id; cmp_id = _; data_id; by = _; here = _ } + -> + let%bind (), free_vars, c = Recurse.on_computation down () `Skipping_over t in + (* Assoc_like_key and Assoc_like_data are both Named values, must remove both as + they are no longer free *) + let removed_key = + Computation_watcher.Type_id_location_map.remove free_vars key_id + in + let removed_key_and_data = + Computation_watcher.Type_id_location_map.remove removed_key data_id + in + return ((), removed_key_and_data, c) + | Assoc_on + { map = _ + ; io_comparator = _ + ; model_comparator = _ + ; io_key_id + ; io_cmp_id = _ + ; model_key_id = _ + ; model_cmp_id = _ + ; data_id + ; by = _ + ; get_model_key = _ + ; here = _ + } -> + let%bind (), free_vars, c = Recurse.on_computation down () `Skipping_over t in + (* Assoc_like_key and Assoc_like_data are both Named values, must remove both as + they are no longer free. + + The key that is added to [Environment] is [io_key_id] + *) + let removed_key = + Computation_watcher.Type_id_location_map.remove free_vars io_key_id + in + let removed_key_and_data = + Computation_watcher.Type_id_location_map.remove removed_key data_id + in + return ((), removed_key_and_data, c) + | Leaf0 { model; static_action; apply_action; reset; here } when enable_watcher -> + let apply_action = + rewrite_apply_action_leaf0 + ~apply_action + ~model + ~action:static_action + ~watcher_queue + ~down + ~source_code_positions: + (Computation_watcher.Source_code_positions.add_dependency_definition + source_code_positions + here) + in + let reset = + rewrite_resetter + ~reset + ~model + ~down + ~source_code_positions: + (Computation_watcher.Source_code_positions.add_dependency_definition + source_code_positions + here) + ~kind:`State_machine0 + ~watcher_queue + in + return + ( () + , Types.Up.empty + , Computation.Leaf0 { model; static_action; apply_action; reset; here } ) + | Leaf1 { model; input_id; dynamic_action; apply_action; input; reset; here } + when enable_watcher -> + let (), free_vars, input = transform_v down () input in + let apply_action = + rewrite_apply_action_leaf1 + ~model + ~action:dynamic_action + ~apply_action + ~down + ~source_code_positions: + (Computation_watcher.Source_code_positions.add_dependency_definition + source_code_positions + here) + ~kind:`State_machine1 + ~watcher_queue + in + let reset = + rewrite_resetter + ~reset + ~model + ~down + ~source_code_positions: + (Computation_watcher.Source_code_positions.add_dependency_definition + source_code_positions + here) + ~kind:`State_machine1 + ~watcher_queue + in + return + ( () + , free_vars + , Computation.Leaf1 + { model; input_id; dynamic_action; apply_action; input; reset; here } ) + | Wrap + { wrapper_model + ; result_id + ; action_id + ; inject_id + ; model_id + ; inner + ; dynamic_apply_action + ; reset + ; here + } + when enable_watcher -> + let%bind (), free_vars, inner = Recurse.on_computation down () `Directly_on inner in + (* Wrap_model and Wrap_inject are both Named values, must remove both as + they are no longer free. + *) + let removed_model = + Computation_watcher.Type_id_location_map.remove free_vars model_id + in + let free_vars = + Computation_watcher.Type_id_location_map.remove removed_model inject_id + in + let dynamic_apply_action, reset = + match enable_watcher with + | true -> + let dynamic_apply_action = + rewrite_apply_action_leaf1 + ~model:wrapper_model + ~action:action_id + ~apply_action:dynamic_apply_action + ~kind:`Wrap + ~watcher_queue + ~down + ~source_code_positions: + (Computation_watcher.Source_code_positions.add_dependency_definition + source_code_positions + here) + in + let reset = + rewrite_resetter + ~reset + ~model:wrapper_model + ~down + ~source_code_positions: + (Computation_watcher.Source_code_positions.add_dependency_definition + source_code_positions + here) + ~kind:`Wrap + ~watcher_queue + in + dynamic_apply_action, reset + | false -> dynamic_apply_action, reset + in + return + ( () + , free_vars + , Computation.Wrap + { wrapper_model + ; result_id + ; action_id + ; inject_id + ; model_id + ; inner + ; dynamic_apply_action + ; reset + ; here + } ) + | With_model_resetter { inner; reset_id; here } -> + let%bind (), free_vars, inner = Recurse.on_computation down () `Directly_on inner in + return + ( () + , Computation_watcher.Type_id_location_map.remove free_vars reset_id + , Computation.With_model_resetter { inner; reset_id; here } ) + | Computation_watcher + { inner + ; here + ; free_vars = _ + ; config = inner_config + ; queue = _ + ; value_type_id_observation_definition_positions = _ + ; enable_watcher = _ + } -> + (* [enable_watcher] should only be set to true once we've hit a + [Computation_watcher] node and [should_run_computation_watcher] is true. + Redefining here so that both [Down] and [Computation_watcher] receive + the proper value + *) + let enable_watcher = should_run_computation_watcher in + let config = Computation_watcher.Config.merge config inner_config in + let%bind (), free_vars, inner = + Recurse.on_computation + { Types.Down.source_code_positions = + Computation_watcher.Source_code_positions.add_watcher + source_code_positions + here + inner_config.label + ; config + ; watcher_queue + ; should_run_computation_watcher + ; enable_watcher + ; visited_stores + ; value_type_id_observation_definition_positions + } + () + `Directly_on + inner + in + return + ( () + , free_vars + , Computation.Computation_watcher + { inner + ; here + ; free_vars + ; config + ; queue = Some watcher_queue + ; value_type_id_observation_definition_positions = + Some value_type_id_observation_definition_positions + ; enable_watcher + } ) + | Store { id; value; inner; here } -> + let%bind (), free_vars, c = + Recurse.on_computation + { down with visited_stores = Set.add visited_stores (Type_equal.Id.uid id) } + () + `Directly_on + inner + in + return + ( () + , Computation_watcher.Type_id_location_map.remove free_vars id + , Computation.Store { id; value; inner = c; here } ) + | Fetch ({ id; default = _; for_some = _; here } as t) -> + let source_code_positions = + match + Set.exists visited_stores ~f:(fun store_id -> + Type_equal.Id.Uid.equal (Type_equal.Id.uid id) store_id) + with + | true -> + Computation_watcher.Type_id_location_map.singleton + id + (Computation_watcher.Source_code_positions.add_dependency_definition + source_code_positions + here) + | false -> Computation_watcher.Type_id_location_map.empty + in + return ((), source_code_positions, Computation.Fetch t) + | _ -> Recurse.on_computation down () `Skipping_over t + ;; +end + +open Fix_transform.Make (Types) (F) + +let run ~watcher_queue c = + let top_config = + (* These values must all be set to false initially. The fields will switch to [true] + only when they hit `Computation_watcher` nodes that have configs with [true] values + *) + { Computation_watcher.Config.log_model_before = false + ; log_model_after = false + ; log_action = false + ; log_incr_info = false + ; log_watcher_positions = false + ; log_dependency_definition_position = false + ; label = None + } + in + let (), _free_vars, r = + Trampoline.run + (transform_c + { Types.Down.source_code_positions = + Computation_watcher.Source_code_positions.empty + ; config = top_config + ; watcher_queue + (* `enable_watcher` will be set by the `Computation_watcher` node and will + propagate downwards from said node onwards *) + ; enable_watcher = + false + (* This flag lets us know that we should set [enable_watcher] once we've reached + any [Computation_watcher] node *) + ; should_run_computation_watcher = true + ; visited_stores = Type_equal.Id.Uid.Set.empty + ; value_type_id_observation_definition_positions = + Computation_watcher.Type_id_location_hashmap.create () + } + () + c) + in + r +;; diff --git a/src/enable_computation_watcher.mli b/src/enable_computation_watcher.mli new file mode 100644 index 00000000..10c1572f --- /dev/null +++ b/src/enable_computation_watcher.mli @@ -0,0 +1,7 @@ +open! Core +open! Import + +val run + : watcher_queue:Computation_watcher.Output_queue.t + -> 'a Computation.t + -> 'a Computation.t diff --git a/src/enable_free_variable_monitor.ml b/src/enable_free_variable_monitor.ml deleted file mode 100644 index ba3fc894..00000000 --- a/src/enable_free_variable_monitor.ml +++ /dev/null @@ -1,44 +0,0 @@ -open! Core -open! Import - -module Types = struct - module Down = Unit - module Acc = Unit - - module Up = struct - type t = Type_id_set.t - - let empty = Type_id_set.empty - let combine = Type_id_set.union - let empty_for_lazy = empty - end -end - -module F (Recurse : Fix_transform.Recurse with module Types := Types) = struct - open Trampoline.Let_syntax - - let transform_v (type a) () () (value : a Value.t) = - match value with - | { value = Named _; id; here = _ } -> (), Type_id_set.singleton id, value - | value -> Recurse.on_value () () `Skipping_over value - ;; - - let transform_c (type a) () () (t : a Computation.t) = - match t with - | Sub { via; from = _; into = _; here = _ } -> - let%bind (), free_vars, c = Recurse.on_computation () () `Skipping_over t in - (* the values bound in a sub are no longer free, so remove them *) - return ((), Type_id_set.remove free_vars via, c) - | Monitor_free_variables { inner; free_vars = _; here } -> - let%bind (), free_vars, inner = Recurse.on_computation () () `Directly_on inner in - return ((), free_vars, Computation.Monitor_free_variables { inner; free_vars; here }) - | _ -> Recurse.on_computation () () `Skipping_over t - ;; -end - -open Fix_transform.Make (Types) (F) - -let run c = - let (), _free_vars, r = Trampoline.run (transform_c () () c) in - r -;; diff --git a/src/enable_free_variable_monitor.mli b/src/enable_free_variable_monitor.mli deleted file mode 100644 index 2f44a419..00000000 --- a/src/enable_free_variable_monitor.mli +++ /dev/null @@ -1,4 +0,0 @@ -open! Core -open! Import - -val run : 'a Computation.t -> 'a Computation.t diff --git a/src/fix_transform.ml b/src/fix_transform.ml index eba4e5bf..6ab26029 100644 --- a/src/fix_transform.ml +++ b/src/fix_transform.ml @@ -126,9 +126,28 @@ struct | Lifecycle { lifecycle = value; here } -> let acc, up, value = User.transform_v down acc value in return (acc, up, Computation.Lifecycle { lifecycle = value; here }) - | Monitor_free_variables { inner; free_vars; here } -> + | Computation_watcher + { inner + ; here + ; free_vars + ; config + ; queue + ; value_type_id_observation_definition_positions + ; enable_watcher + } -> let%bind acc, up, inner = User.transform_c down acc inner in - return (acc, up, Computation.Monitor_free_variables { inner; free_vars; here }) + return + ( acc + , up + , Computation.Computation_watcher + { inner + ; here + ; free_vars + ; config + ; queue + ; value_type_id_observation_definition_positions + ; enable_watcher + } ) ;; let reduce_up l = List.reduce l ~f:combine_up |> Option.value ~default:empty diff --git a/src/graph_info.ml b/src/graph_info.ml index 161b83e6..1ae2f927 100644 --- a/src/graph_info.ml +++ b/src/graph_info.ml @@ -172,7 +172,7 @@ module Node_info = struct | With_model_resetter _ -> "with_model_resetter" | Path _ -> "path" | Lifecycle _ -> "lifecycle" - | Monitor_free_variables _ -> "monitor_free_variables" + | Computation_watcher _ -> "computation_watcher" in { node_type; here = Some here } ;; diff --git a/src/linter.ml b/src/linter.ml index 448f9c6e..4d759ade 100644 --- a/src/linter.ml +++ b/src/linter.ml @@ -79,7 +79,7 @@ let state_machine1_to_state_machine0_linter = | Lifecycle _ | Fix_define _ | Fix_recurse _ - | Monitor_free_variables _ + | Computation_watcher _ | Identity _ -> warnings in super#computation computation warnings diff --git a/src/private_eval/annotate_incr.ml b/src/private_eval/annotate_incr.ml index 07cc11b0..1619a2c8 100644 --- a/src/private_eval/annotate_incr.ml +++ b/src/private_eval/annotate_incr.ml @@ -246,10 +246,10 @@ end let incr_annotation_listeners = ref - [ (fun kind _ -> + [ (fun ~here:_ kind _ -> (* NOTE: Because this counting is cheap, it is safe to always do it. *) Counts.incr_global kind) - ; (fun kind incr -> + ; (fun ~here:_ kind incr -> (* The "is enabled" check is performed here in order to avoid going through the memoization or allocation of a Packed.t even when disabled. *) @@ -259,11 +259,14 @@ let incr_annotation_listeners = let on_incr_annotation f = incr_annotation_listeners := f :: !incr_annotation_listeners -let annotate_packed kind incr = - List.iter !incr_annotation_listeners ~f:(fun f -> f kind incr) +let annotate_packed ~here kind incr = + List.iter !incr_annotation_listeners ~f:(fun f -> f ~here kind incr) +;; + +let annotate (type a) ~here kind (incr : a Ui_incr.t) = + annotate_packed ~here kind (Ui_incr.pack incr) ;; -let annotate (type a) kind (incr : a Ui_incr.t) = annotate_packed kind (Ui_incr.pack incr) let attribute_packed pos incr = if !enabled then attribute_loc pos incr let attribute pos_opt incr = attribute_packed pos_opt (Ui_incr.pack incr) diff --git a/src/private_eval/annotate_incr.mli b/src/private_eval/annotate_incr.mli index d8c3e5a2..0d600b95 100644 --- a/src/private_eval/annotate_incr.mli +++ b/src/private_eval/annotate_incr.mli @@ -20,6 +20,8 @@ module Kind : sig | Assoc_inputs | Path | Lifecycle_apply_action_pair + + val name : t -> string end (** [on_incr_annotation] registers a callback that will run whenever Bonsai annotates an @@ -30,12 +32,14 @@ end A single node may be annotated multiple times, e.g. if it is both a model and a result. *) -val on_incr_annotation : (Kind.t -> Ui_incr.Packed.t -> unit) -> unit +val on_incr_annotation + : (here:Source_code_position.t -> Kind.t -> Ui_incr.Packed.t -> unit) + -> unit (** [annotate] will run all [on_incr_annotation] listeners. *) -val annotate : Kind.t -> 'a Ui_incr.t -> unit +val annotate : here:Source_code_position.t -> Kind.t -> 'a Ui_incr.t -> unit -val annotate_packed : Kind.t -> Ui_incr.Packed.t -> unit +val annotate_packed : here:Source_code_position.t -> Kind.t -> Ui_incr.Packed.t -> unit module Counts : sig (** Values of this type contain a counter for every kind of incremental diff --git a/src/private_eval/computation.ml b/src/private_eval/computation.ml index 5229f510..55c12d4b 100644 --- a/src/private_eval/computation.ml +++ b/src/private_eval/computation.ml @@ -240,10 +240,19 @@ type 'result t = ; here : Source_code_position.t } -> unit t - | Monitor_free_variables : + | Computation_watcher : { inner : 'result t + ; enable_watcher : bool ; here : Source_code_position.t - ; free_vars : Type_id_set.t + ; free_vars : Computation_watcher.Type_id_location_map.t + ; config : Computation_watcher.Config.t + ; queue : Computation_watcher.Output_queue.t option + ; value_type_id_observation_definition_positions : + (Computation_watcher.Source_code_positions.finalized + Computation_watcher.Source_code_positions.t + * Computation_watcher.Config.t) + Computation_watcher.Type_id_location_hashmap.t + option } -> 'result t @@ -273,5 +282,5 @@ let source_code_position (type result) (computation : result t) = | With_model_resetter { here; _ } | Path { here; _ } | Lifecycle { here; _ } - | Monitor_free_variables { here; _ } -> here + | Computation_watcher { here; _ } -> here ;; diff --git a/src/private_eval/computation_watcher.ml b/src/private_eval/computation_watcher.ml new file mode 100644 index 00000000..832369cb --- /dev/null +++ b/src/private_eval/computation_watcher.ml @@ -0,0 +1,567 @@ +open! Core +open! Import + +module Source_code_positions = struct + type pending = + { watchers : string option Source_code_position.Map.t + ; depended_on_at : Source_code_position.Set.t + } + [@@deriving sexp_of] + + type finalized = + { watchers : string option Source_code_position.Map.t + ; dependency_definitions : Source_code_position.Set.t + ; depended_on_at : Source_code_position.Set.t + } + [@@deriving sexp_of] + + type _ t = + | Pending : pending -> pending t + | Finalized : finalized -> finalized t + [@@deriving sexp_of] + + let add_watcher (type a) (positions : a t) here label : a t = + let update_watchers watchers = + Map.update watchers here ~f:(fun existing_label -> + match existing_label with + (* Top-level None, there was no value prior to this *) + | None -> label + | Some existing_label -> + (match (Option.equal String.equal) existing_label label with + | true -> existing_label + | false -> + eprint_s + [%message + "BUG" + [%here] + "attempting to set two different labels for the same computation \ + watcher"]; + existing_label)) + in + match positions with + | Finalized { watchers; dependency_definitions; depended_on_at } -> + Finalized + { dependency_definitions; watchers = update_watchers watchers; depended_on_at } + | Pending { watchers; depended_on_at } -> + Pending { watchers = update_watchers watchers; depended_on_at } + ;; + + let get_watchers (type a) (a : a t) = + match a with + | Pending { watchers; _ } -> watchers + | Finalized { watchers; _ } -> watchers + ;; + + let merge_watchers a b = + Map.merge a b ~f:(fun ~key:_ -> function + | `Left left -> Some left + | `Right right -> Some right + (* If this watcher has a label in either map, keep that label *) + | `Both (Some left, None) -> Some (Some left) + (* If this watcher has a label in either map, keep that label *) + | `Both (None, Some right) -> Some (Some right) + | `Both (None, None) -> Some None + (* If watcher had label in both maps, arbitrarily pick one *) + | `Both (Some left, Some _right) -> Some (Some left)) + ;; + + let merge_watchers_of_t (a : _ t) (b : _ t) = + let a = get_watchers a in + let b = get_watchers b in + merge_watchers a b + ;; + + let empty = + Pending + { watchers = Source_code_position.Map.empty + ; depended_on_at = Source_code_position.Set.empty + } + ;; + + let add_dependency_definition (type a) (t : a t) here = + let watchers, dependency_definitions, depended_on_at = + match t with + | Pending { watchers; depended_on_at } -> + watchers, Source_code_position.Set.empty, depended_on_at + | Finalized { watchers; dependency_definitions; depended_on_at } -> + watchers, dependency_definitions, depended_on_at + in + Finalized + { watchers + ; dependency_definitions = Set.add dependency_definitions here + ; depended_on_at + } + ;; + + let add_depended_on_at (type a) (t : a t) here : a t = + match t with + | Pending { watchers; depended_on_at } -> + Pending { watchers; depended_on_at = Set.add depended_on_at here } + | Finalized { watchers; dependency_definitions; depended_on_at } -> + Finalized + { watchers; dependency_definitions; depended_on_at = Set.add depended_on_at here } + ;; + + let merge_depended_on_at (type a) (t : a t) b_depended_on_at : a t = + match t with + | Pending { watchers; depended_on_at } -> + Pending { watchers; depended_on_at = Set.union b_depended_on_at depended_on_at } + | Finalized { watchers; dependency_definitions; depended_on_at } -> + Finalized + { watchers + ; dependency_definitions + ; depended_on_at = Set.union b_depended_on_at depended_on_at + } + ;; + + let extract_finalized (Finalized t) = t +end + +module Config = struct + type t = + { log_action : bool + ; log_model_before : bool + ; log_model_after : bool + ; log_watcher_positions : bool + ; log_dependency_definition_position : bool + ; log_incr_info : bool + ; label : string option + } + [@@deriving sexp_of] + + let merge (left : t) (right : t) = + (* If either the left or right log config for a property is set to true, we will set + the value to true from this point forward *) + { log_action = left.log_action || right.log_action + ; log_model_before = left.log_model_before || right.log_model_before + ; log_model_after = left.log_model_after || right.log_model_after + ; log_watcher_positions = left.log_watcher_positions || right.log_watcher_positions + ; log_dependency_definition_position = + left.log_dependency_definition_position + || right.log_dependency_definition_position + ; log_incr_info = left.log_incr_info || right.log_incr_info + ; label = (* We take the rigthmost label as that is the innermost config *) + right.label + } + ;; +end + +(* Mutability is required here because whenever we hit the incremental node, + we cannot be sure of two things: + + 1. We do not know if we've already wrapped the Incremental node + 2. We do not know if the current copy of [Source_code_positions.t] is the most up-to-date + version + + Prior versions just wrapped the Incremental node multiple times, which created a new node + in the queue for each [depended_on_at] location per update of the Incremental node. This + is an undesired outcome, as we want to have one node per update for the Incremental node. + + We could either run the transformation twice (once to retrieve all the source code + positions necessary, and then another to transform the computations), or use mutability + to share a hashmap that allows for retrieving the most complete [Source_code_positions.t] + as well as provides a way to know if the Incremental node has already been wrapped. +*) +module Type_id_location_hashmap = struct + include Hashtbl.Make_plain (Type_equal.Id.Uid) + + let update_and_check_if_value_set + ~(id : _ Type_equal.Id.t) + ~update_data:(update_data, config) + table + = + let id = Type_equal.Id.uid id in + let stored_value = Hashtbl.find table id in + (* Merge the [depended_on_at], [dependency_definitions], AND [watcher] values if + watcher is enabled. The node prior to this should have been a Map node, + so it should have a [depended_on_at] value *) + Hashtbl.update table id ~f:(function + | None -> Source_code_positions.Finalized update_data, config + | Some (Source_code_positions.Finalized existing_value_positions, old_config) -> + ( Source_code_positions.Finalized + { depended_on_at = + Set.union + existing_value_positions.depended_on_at + update_data.depended_on_at + ; watchers = + Source_code_positions.merge_watchers + existing_value_positions.watchers + update_data.watchers + ; dependency_definitions = + Set.union + existing_value_positions.dependency_definitions + update_data.dependency_definitions + } + , Config.merge old_config config )); + match stored_value with + | None -> `Not_set + | Some _ -> `Already_set + ;; +end + +module Type_id_location_map = struct + module Data = struct + type 'a t = Source_code_positions.finalized Source_code_positions.t + [@@deriving sexp_of] + end + + module T = Univ_map.Make (Univ_map.Type_id_key) (Data) + module Merge = Univ_map.Merge (Univ_map.Type_id_key) (Data) (Data) (Data) + + type t = T.t + + type 'acc folder = + { f : + 'a 'b. + 'acc + -> 'a Type_equal.Id.t + -> Source_code_positions.finalized Source_code_positions.t + -> 'acc + } + + type 'b mapper = + { f : + 'a. + 'a Type_equal.Id.t + -> Source_code_positions.finalized Source_code_positions.t + -> 'b + } + + let set = T.set + let empty = T.empty + let singleton = T.singleton + let find = T.find + let remove = T.remove + + let merge a b = + Merge.merge + b + a + ~f: + { f = + (fun ~key:_ -> function + | `Left left -> Some left + | `Right right -> Some right + | `Both (Source_code_positions.Finalized a, Finalized b) -> + Some + (Source_code_positions.Finalized + { dependency_definitions = + Set.union a.dependency_definitions b.dependency_definitions + ; depended_on_at = Set.union a.depended_on_at b.depended_on_at + ; watchers = + Source_code_positions.merge_watchers a.watchers b.watchers + })) + } + ;; + + let fold t ~init ({ f } : _ folder) = + Map.fold + (Type_equal.conv T.type_equal t) + ~init + ~f:(fun ~key:_ ~data:(T (key, data)) acc -> f acc key data) + ;; + + let map_to_list t ({ f } : _ mapper) = + List.map (T.to_alist t) ~f:(fun (T (key, data)) -> f key data) + ;; +end + +let format_depended_on_at_positions + ~config:({ log_watcher_positions = _; _ } : Config.t) + ({ depended_on_at; _ } : Source_code_positions.finalized) + = + let depended_on_at = Set.to_list depended_on_at in + match true, List.length depended_on_at with + | false, _ | true, 0 -> "" + | true, _ -> + List.fold + depended_on_at + ~init:"\n\nUpdated computation depended on at:" + ~f:(fun acc depended_on_at -> + let depended_on_at_string = Source_code_position.to_string depended_on_at in + acc ^ [%string "\n - %{depended_on_at_string}"]) +;; + +let format_watcher_positions + ~config:({ log_watcher_positions; _ } : Config.t) + ({ watchers; _ } : Source_code_positions.finalized) + = + match log_watcher_positions, Map.length watchers with + | false, _ | true, 0 -> "" + | true, _ -> + Map.fold watchers ~init:"\n\nWatchers:" ~f:(fun ~key:watcher ~data:label acc -> + let label = + match label with + | None -> "" + | Some label -> [%string " [%{label}]"] + in + let watcher_string = Source_code_position.to_string watcher in + acc ^ [%string "\n -%{label} %{watcher_string}"]) +;; + +let format_dependency_definition_position + ~config:({ log_dependency_definition_position; _ } : Config.t) + ({ dependency_definitions; _ } : Source_code_positions.finalized) + = + match log_dependency_definition_position with + | false -> "" + | true -> + let here_string = + match Set.to_list dependency_definitions with + | dependency_definition :: [] -> + [%string " at [%{Source_code_position.to_string dependency_definition}]"] + | dependency_definitions -> + let dependency_definitions_string = + List.fold dependency_definitions ~init:"" ~f:(fun acc dependency_definition -> + acc ^ [%string "\n - %{dependency_definition#Source_code_position}"]) + in + [%string "s at: %{dependency_definitions_string}"] + in + here_string +;; + +let log_model_action_monitor + (type model action) + ~sexp_of_model + ?(sexp_of_action = sexp_of_opaque) + ?(action : action option = None) + ?(info_string_prefix : string = "") + ~(model_before : model) + ~(model_after : model) + ~(config : Config.t) + () + = + let { Config.log_model_before + ; log_action + ; log_model_after + ; log_incr_info = _ + ; log_watcher_positions = _ + ; log_dependency_definition_position = _ + ; label = _ + } + = + config + in + let old_model_string = + match log_model_before with + | true -> + let model_before = sexp_of_model model_before in + Sexp.to_string_hum [%message (model_before : Sexp.t)] + | false -> "" + in + let new_model_string = + match log_model_after with + | true -> + let model_after = sexp_of_model model_after in + Sexp.to_string_hum [%message (model_after : Sexp.t)] + | false -> "" + in + let action_string = + match log_action, action with + | true, Some action -> + let old_model_action_separator = + if String.length old_model_string > 0 then " " else "" + in + let action = sexp_of_action action in + old_model_action_separator ^ Sexp.to_string_hum [%message (action : Sexp.t)] + | false, Some _ | false, None | true, None -> "" + in + let old_new_model_separator = + if (String.length old_model_string > 0 || String.length action_string > 0) + && String.length new_model_string > 0 + then " -> " + else "" + in + let info_string = + old_model_string ^ action_string ^ old_new_model_separator ^ new_model_string + in + match String.length info_string with + | 0 -> "" + | _ -> info_string_prefix ^ info_string +;; + +module Node = struct + type t = + | Named_or_incr : + { source_code_positions : Source_code_positions.finalized + ; incr_info : Info.t option + ; kind : [ `Named | `Incr ] + ; config : Config.t + } + -> t + | State_machine_like : + { source_code_positions : Source_code_positions.finalized + ; model_before : 'a + ; model_after : 'a + ; action : 'b option + ; sexp_of_model : 'a -> Sexp.t + ; sexp_of_action : ('b -> Sexp.t) option + ; kind : [ `State_machine0 | `State_machine1 | `Wrap ] + ; config : Config.t + } + -> t + | Reset : + { source_code_positions : Source_code_positions.finalized + ; model_before : 'a + ; model_after : 'a + ; sexp_of_model : 'a -> Sexp.t + ; kind : [ `State_machine0 | `State_machine1 | `Wrap ] + ; config : Config.t + } + -> t + + let kind_to_string = function + | `Named -> "Named node" + | `Incr -> "Incremental node" + | `State_machine0 -> "State_machine0" + | `State_machine1 -> "State_machine1" + | `Wrap -> "Wrap node" + ;; + + let num_watchers_prefix ({ watchers; _ } : Source_code_positions.finalized) = + match Map.length watchers with + | 0 -> + eprint_s [%message "BUG" [%here] "Source_code_positions has 0 watcher positions"]; + "" + | 1 -> "Watched computation" + | num_watchers -> [%string "%{num_watchers#Int} watched computations"] + ;; + + let get_shared_strings node = + let source_code_positions, kind, config = + match node with + | Named_or_incr { source_code_positions; kind; config; _ } -> + source_code_positions, kind_to_string kind, config + | State_machine_like { source_code_positions; kind; config; _ } -> + source_code_positions, kind_to_string kind, config + | Reset { source_code_positions; kind; config; _ } -> + source_code_positions, kind_to_string kind, config + in + let watchers_prefix = num_watchers_prefix source_code_positions in + let watcher_positions_string = + format_watcher_positions ~config source_code_positions + in + let depended_on_at_string = + format_depended_on_at_positions ~config source_code_positions + in + let dependency_definition_string = + format_dependency_definition_position ~config source_code_positions + in + ( watchers_prefix + , kind + , watcher_positions_string + , dependency_definition_string + , depended_on_at_string ) + ;; + + let to_string node = + let ( watchers_prefix + , kind + , watcher_positions_string + , dependency_definition_string + , depended_on_at_string ) + = + get_shared_strings node + in + let model_action_info_string = + let info_string_prefix = "\n\nDetails: " in + match node with + | Named_or_incr { source_code_positions = _; incr_info; kind = _; config } -> + (match config.log_incr_info with + | false -> "" + | true -> + info_string_prefix ^ Sexp.to_string_hum [%message (incr_info : Info.t option)]) + | State_machine_like + { source_code_positions = _ + ; model_before + ; model_after + ; action + ; sexp_of_model + ; sexp_of_action + ; kind = _ + ; config + } -> + let sexp_of_action = Option.value sexp_of_action ~default:sexp_of_opaque in + log_model_action_monitor + ~sexp_of_model + ~sexp_of_action + ~config + ~model_before + ~model_after + ~action + ~info_string_prefix + () + | Reset + { source_code_positions = _ + ; model_before + ; model_after + ; sexp_of_model + ; kind = _ + ; config + } -> + log_model_action_monitor + ~sexp_of_model + ~model_before + ~model_after + ~config + ~info_string_prefix + () + in + {%string|%{watchers_prefix} updated due to %{kind}%{dependency_definition_string}%{model_action_info_string}%{watcher_positions_string}%{depended_on_at_string}|} + ;; + + let log node = to_string node |> print_endline +end + +module Output_queue = struct + type t = Node.t Core.Queue.t + + let process_queue ~f (q : t) = + Queue.iter q ~f; + Queue.clear q + ;; + + let log_all_in_queue q = process_queue ~f:Node.log q +end + +let instrument_incremental_node + ~here + ~kind + ~value_type_id_observation_definition_positions + ~watcher_queue + ~id + value + = + let incr_info = (Incr.user_info value : Info.t option) in + (* Using Incr.map for better code clarity as to when the stored value should + be pulled from the hashmap *) + Incr.map value ~f:(fun a -> + (match + Hashtbl.find value_type_id_observation_definition_positions (Type_equal.Id.uid id) + with + | None -> + let kind_string = + match kind with + | `Named -> "named" + | `Incr -> "incremental" + in + (* This value should not be None, as this function should only be called once the + user has set the value in the hashtable *) + eprint_s + [%message + "BUG" + (here : Source_code_position.t) + (kind_string ^ "node did not have source code positions set")] + | Some (stored_value, config) -> + let source_code_positions = + stored_value |> Source_code_positions.extract_finalized + in + Queue.enqueue + watcher_queue + (Node.Named_or_incr { source_code_positions; incr_info; kind; config })); + a) +;; + +module For_testing = struct + let log_model_action_monitor = log_model_action_monitor +end diff --git a/src/private_eval/computation_watcher.mli b/src/private_eval/computation_watcher.mli new file mode 100644 index 00000000..d00da73a --- /dev/null +++ b/src/private_eval/computation_watcher.mli @@ -0,0 +1,177 @@ +open! Core +open! Import + +module Source_code_positions : sig + (** [watchers] is a list that contains the chain of Computation_watcher nodes that + contain this current node. + [dependency_definitions] a set of [Source_code_position.t]s that caused the + Computation_watcher to update. All of these [dependency_definitions] are + semantically the same but some nodes happen to be generated more than once + [depended_on_at] is the location of the Map node/let%arr that was called + on the value + *) + type pending = + { watchers : string option Source_code_position.Map.t + ; depended_on_at : Source_code_position.Set.t + } + [@@deriving sexp_of] + + type finalized = + { watchers : string option Source_code_position.Map.t + ; dependency_definitions : Source_code_position.Set.t + ; depended_on_at : Source_code_position.Set.t + } + [@@deriving sexp_of] + + type _ t = + | Pending : pending -> pending t + | Finalized : finalized -> finalized t + [@@deriving sexp_of] + + val empty : pending t + val add_watcher : 'a t -> Source_code_position.t -> string option -> 'a t + val add_dependency_definition : 'a t -> Source_code_position.t -> finalized t + val add_depended_on_at : 'a t -> Source_code_position.t -> 'a t + val extract_finalized : finalized t -> finalized + val merge_depended_on_at : 'a t -> Source_code_position.Set.t -> 'a t + val merge_watchers_of_t : _ t -> _ t -> string option Source_code_position.Map.t +end + +(** [dependecy_definition_position] is the first thing set when looking for free + variables, so we know that we can use [finalized] in this map +*) +module Type_id_location_map : sig + type t + + type 'acc folder = + { f : + 'a. + 'acc + -> 'a Type_equal.Id.t + -> Source_code_positions.finalized Source_code_positions.t + -> 'acc + } + + type 'b mapper = + { f : + 'a. + 'a Type_equal.Id.t + -> Source_code_positions.finalized Source_code_positions.t + -> 'b + } + + val set + : t + -> key:_ Type_equal.Id.t + -> data:Source_code_positions.finalized Source_code_positions.t + -> t + + val find + : t + -> _ Type_equal.Id.t + -> Source_code_positions.finalized Source_code_positions.t option + + (** If the key exists in both a and b, b will overwrite a *) + val merge : t -> t -> t + + val empty : t + + val singleton + : _ Type_equal.Id.t + -> Source_code_positions.finalized Source_code_positions.t + -> t + + val remove : t -> _ Type_equal.Id.t -> t + val fold : t -> init:'acc -> 'acc folder -> 'acc + val map_to_list : t -> 'a mapper -> 'a list +end + +module Config : sig + type t = + { log_action : bool + ; log_model_before : bool + ; log_model_after : bool + ; log_watcher_positions : bool + ; log_dependency_definition_position : bool + ; log_incr_info : bool + ; label : string option + } + [@@deriving sexp_of] + + val merge : t -> t -> t +end + +module Type_id_location_hashmap : sig + include Hashtbl.S_plain with type key = Type_equal.Id.Uid.t + + val update_and_check_if_value_set + : id:_ Type_equal.Id.t + -> update_data:Source_code_positions.finalized * Config.t + -> (Source_code_positions.finalized Source_code_positions.t * Config.t) t + -> [ `Already_set | `Not_set ] +end + +module Node : sig + type t = + | Named_or_incr : + { source_code_positions : Source_code_positions.finalized + ; incr_info : Info.t option + ; kind : [ `Named | `Incr ] + ; config : Config.t + } + -> t + | State_machine_like : + { source_code_positions : Source_code_positions.finalized + ; model_before : 'a + ; model_after : 'a + ; action : 'b option + ; sexp_of_model : 'a -> Sexp.t + ; sexp_of_action : ('b -> Sexp.t) option + ; kind : [ `State_machine0 | `State_machine1 | `Wrap ] + ; config : Config.t + } + -> t + | Reset : + { source_code_positions : Source_code_positions.finalized + ; model_before : 'a + ; model_after : 'a + ; sexp_of_model : 'a -> Sexp.t + ; kind : [ `State_machine0 | `State_machine1 | `Wrap ] + ; config : Config.t + } + -> t + + val to_string : t -> string + val log : t -> unit +end + +module Output_queue : sig + type t = Node.t Queue.t + + val process_queue : f:(Node.t -> unit) -> t -> unit + val log_all_in_queue : t -> unit +end + +val instrument_incremental_node + : here:Source_code_position.t + -> kind:[ `Named | `Incr ] + -> value_type_id_observation_definition_positions: + (Source_code_positions.finalized Source_code_positions.t * Config.t) + Type_id_location_hashmap.t + -> watcher_queue:Output_queue.t + -> id:_ Type_equal.Id.t + -> 'a Ui_incr.Incr.t + -> 'a Ui_incr.Incr.t + +module For_testing : sig + val log_model_action_monitor + : sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?action:'action option + -> ?info_string_prefix:string + -> model_before:'model + -> model_after:'model + -> config:Config.t + -> unit + -> string +end diff --git a/src/private_eval/dune b/src/private_eval/dune index b3f5b83c..fcea8601 100644 --- a/src/private_eval/dune +++ b/src/private_eval/dune @@ -1,7 +1,8 @@ (library (name bonsai_private_eval) - (libraries core_kernel.balanced_reducer core incr_map incremental - core_kernel.reversed_list virtual_dom.ui_effect bonsai_concrete.ui_incr + (libraries balance_list_tree core_kernel.balanced_reducer core incr_map + incremental core_kernel.nonempty_list core_kernel.reversed_list + virtual_dom.ui_effect bonsai_concrete.ui_incr bonsai_concrete.ui_time_source uopt) (preprocess (pps ppx_jane ppx_pattern_bind)) diff --git a/src/private_eval/eval.ml b/src/private_eval/eval.ml index 09e35292..ee586755 100644 --- a/src/private_eval/eval.ml +++ b/src/private_eval/eval.ml @@ -6,8 +6,8 @@ let () = Incr.State.(set_max_height_allowed t 1024) let rec gather : type result. result Computation.gather_fun = let open Computation in fun ~recursive_scopes ~time_source -> function - | Return { value; here = _ } -> Eval_return.f ~value - | Leaf1 { model; input_id; dynamic_action; apply_action; input; reset; here = _ } -> + | Return { value; here } -> Eval_return.f ~value ~here + | Leaf1 { model; input_id; dynamic_action; apply_action; input; reset; here } -> Eval_leaf1.f ~model ~input_id @@ -16,10 +16,11 @@ let rec gather : type result. result Computation.gather_fun = ~input ~reset ~time_source - | Leaf0 { model; static_action; apply_action; reset; here = _ } -> - Eval_leaf0.f ~model ~static_action ~time_source ~apply_action ~reset - | Leaf_incr { input; compute; here = _ } -> - Eval_leaf_incr.f ~input ~compute ~time_source + ~here + | Leaf0 { model; static_action; apply_action; reset; here } -> + Eval_leaf0.f ~model ~static_action ~time_source ~apply_action ~reset ~here + | Leaf_incr { input; compute; here } -> + Eval_leaf_incr.f ~input ~compute ~time_source ~here | Sub { into = Sub { into = Sub _; _ }; _ } as t -> Eval_sub.chain t ~gather:{ f = gather } ~recursive_scopes ~time_source | Sub { from; via; into; here } -> @@ -28,8 +29,8 @@ let rec gather : type result. result Computation.gather_fun = Trampoline.return (Eval_sub.gather ~here ~info_from ~info_into ~via) | Store { id; value; inner; here = _ } -> Eval_store.f ~gather ~recursive_scopes ~time_source ~id ~value ~inner - | Fetch { id; default; for_some; here = _ } -> Eval_fetch.f ~id ~default ~for_some - | Assoc { map; key_comparator; key_id; cmp_id; data_id; by; here = _ } -> + | Fetch { id; default; for_some; here } -> Eval_fetch.f ~id ~default ~for_some ~here + | Assoc { map; key_comparator; key_id; cmp_id; data_id; by; here } -> Eval_assoc.f ~gather ~recursive_scopes @@ -40,6 +41,7 @@ let rec gather : type result. result Computation.gather_fun = ~cmp_id ~data_id ~by + ~here | Assoc_on { map ; io_comparator @@ -51,7 +53,7 @@ let rec gather : type result. result Computation.gather_fun = ; data_id ; by ; get_model_key - ; here = _ + ; here } -> Eval_assoc_on.f ~gather @@ -67,13 +69,14 @@ let rec gather : type result. result Computation.gather_fun = ~data_id ~by ~get_model_key - | Assoc_simpl { map; by; may_contain; here = _ } -> - Eval_assoc_simple.f ~map ~by ~may_contain - | Switch { match_; arms; here = _ } -> - Eval_switch.f ~gather ~recursive_scopes ~time_source ~match_ ~arms - | Lazy { t = lazy_computation; here = _ } -> - Eval_lazy.f ~gather ~recursive_scopes ~time_source ~lazy_computation - | Fix_define { fix_id; initial_input; input_id; result; here = _ } -> + ~here + | Assoc_simpl { map; by; may_contain; here } -> + Eval_assoc_simple.f ~map ~by ~may_contain ~here + | Switch { match_; arms; here } -> + Eval_switch.f ~gather ~recursive_scopes ~time_source ~match_ ~arms ~here + | Lazy { t = lazy_computation; here } -> + Eval_lazy.f ~gather ~recursive_scopes ~time_source ~lazy_computation ~here + | Fix_define { fix_id; initial_input; input_id; result; here } -> Eval_fix.define ~gather ~recursive_scopes @@ -82,8 +85,9 @@ let rec gather : type result. result Computation.gather_fun = ~initial_input ~input_id ~result - | Fix_recurse { input; input_id; fix_id; here = _ } -> - Eval_fix.recurse ~recursive_scopes ~input ~input_id ~fix_id + ~here + | Fix_recurse { input; input_id; fix_id; here } -> + Eval_fix.recurse ~recursive_scopes ~input ~input_id ~fix_id ~here | Wrap { wrapper_model ; action_id @@ -93,9 +97,10 @@ let rec gather : type result. result Computation.gather_fun = ; inner ; dynamic_apply_action ; reset - ; here = _ + ; here } -> Eval_wrap.f + ~here ~gather ~recursive_scopes ~time_source @@ -107,20 +112,36 @@ let rec gather : type result. result Computation.gather_fun = ~inner ~dynamic_apply_action ~reset - | With_model_resetter { inner; reset_id; here = _ } -> - Eval_with_model_resetter.f ~gather ~recursive_scopes ~time_source ~inner ~reset_id - | Path { here = _ } -> Eval_path.f - | Lifecycle { lifecycle; here = _ } -> Eval_lifecycle.f ~lifecycle - | Monitor_free_variables { inner; free_vars; here = _ } - when Type_id_set.is_empty free_vars -> gather ~recursive_scopes ~time_source inner - | Monitor_free_variables { here; inner; free_vars } -> - Eval_monitor_free_variables.f + | With_model_resetter { inner; reset_id; here } -> + Eval_with_model_resetter.f + ~gather + ~recursive_scopes + ~time_source + ~inner + ~reset_id + ~here + | Path { here } -> Eval_path.f ~here + | Lifecycle { lifecycle; here } -> Eval_lifecycle.f ~lifecycle ~here + | Computation_watcher + { here + ; enable_watcher + ; inner + ; free_vars + ; config + ; queue + ; value_type_id_observation_definition_positions + } -> + Eval_computation_watcher.f + ~enable_watcher ~gather ~recursive_scopes ~time_source ~inner ~free_vars + ~config + ~watcher_queue:queue ~here + ~value_type_id_observation_definition_positions ;; let gather ~recursive_scopes ~time_source c = diff --git a/src/private_eval/eval_assoc.ml b/src/private_eval/eval_assoc.ml index 9f2b91c8..bcf0cb3c 100644 --- a/src/private_eval/eval_assoc.ml +++ b/src/private_eval/eval_assoc.ml @@ -22,7 +22,7 @@ let unzip3_mapi' incremental) is always the empty lifecycle collection, then we can drop it here, and avoid nesting unzips *) let first, second = - Incr_map.unzip_mapi' ~comparator map ~f:(fun ~key ~data -> + Incr_map.unzip_mapi' map ~f:(fun ~key ~data -> let a, b, _ = f ~key ~data in a, b) in @@ -32,12 +32,12 @@ let unzip3_mapi' incremental) is always the empty lifecycle collection, then we can drop it here, and avoid nesting unzips *) let first, third = - Incr_map.unzip_mapi' ~comparator map ~f:(fun ~key ~data -> + Incr_map.unzip_mapi' map ~f:(fun ~key ~data -> let a, _, c = f ~key ~data in a, c) in first, Incr.return (Map.empty comparator), third - | Yes_or_maybe, Yes_or_maybe -> Incr_map.unzip3_mapi' ~comparator map ~f + | Yes_or_maybe, Yes_or_maybe -> Incr_map.unzip3_mapi' map ~f ;; let f @@ -51,6 +51,7 @@ let f ~cmp_id ~data_id ~by + ~here = let module Cmp = (val key_comparator) in let wrap_assoc ~key inject = @@ -85,7 +86,7 @@ let f ~contains_lifecycle:resolved.lifecycle ~contains_input:resolved.input ~f:(fun ~key ~data:input_and_model -> - annotate Model_and_input input_and_model; + annotate ~here Model_and_input input_and_model; let path = match resolved.path with | Yes_or_maybe -> Path.append path Path.Elem.(Assoc (create_keyed key)) @@ -93,8 +94,8 @@ let f in let%pattern_bind value, model = input_and_model in let key_incr = Incr.const key in - annotate Assoc_key key_incr; - annotate Assoc_input value; + annotate ~here Assoc_key key_incr; + annotate ~here Assoc_input value; let environment = (* It is safe to reuse the same [key_id] and [data_id] for each pair in the map, since they all start with a fresh "copy" of the outer environment. *) @@ -108,11 +109,11 @@ let f in ( Snapshot.result snapshot , Input.to_incremental (Snapshot.input snapshot) - , Snapshot.lifecycle_or_empty snapshot )) + , Snapshot.lifecycle_or_empty ~here snapshot )) in - annotate Assoc_results results_map; - annotate Assoc_lifecycles lifecycle_map; - annotate Assoc_inputs input_map; + annotate ~here Assoc_results results_map; + annotate ~here Assoc_lifecycles lifecycle_map; + annotate ~here Assoc_inputs input_map; let lifecycle = (* if we can prove that the body of the assoc doesn't contain a lifecycle node, then return None, dropping the constant incremental @@ -130,7 +131,7 @@ let f | None -> data)) ~remove:(fun ~outer_key:_ ~inner_key:key ~data:_ acc -> Map.remove acc key) in - annotate Assoc_lifecycles unfolded; + annotate ~here Assoc_lifecycles unfolded; Some unfolded in let input = @@ -138,7 +139,7 @@ let f | No -> Input.static_none | Yes_or_maybe -> Input.dynamic (input_map >>| Option.some) in - Trampoline.return (Snapshot.create ~result:results_map ~input ~lifecycle, ()) + Trampoline.return (Snapshot.create ~here ~result:results_map ~input ~lifecycle, ()) in let apply_action ~inject diff --git a/src/private_eval/eval_assoc.mli b/src/private_eval/eval_assoc.mli index f2102f2c..245cede4 100644 --- a/src/private_eval/eval_assoc.mli +++ b/src/private_eval/eval_assoc.mli @@ -19,4 +19,5 @@ val f -> cmp_id:'cmp Type_equal.Id.t -> data_id:'v Type_equal.Id.t -> by:'r Computation.t + -> here:Source_code_position.t -> (('k, 'r, 'cmp) Map_intf.Map.t, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_assoc_on.ml b/src/private_eval/eval_assoc_on.ml index 6f708143..d332af2f 100644 --- a/src/private_eval/eval_assoc_on.ml +++ b/src/private_eval/eval_assoc_on.ml @@ -17,6 +17,7 @@ let f ~data_id ~by ~get_model_key + ~here = let module Model_comparator = (val model_comparator) in let module Io_comparator = (val io_comparator) in @@ -62,8 +63,8 @@ let f | No -> path in let key_incr = Incr.const io_key in - annotate Assoc_key key_incr; - annotate Assoc_input value; + annotate ~here Assoc_key key_incr; + annotate ~here Assoc_input value; let environment = (* It is safe to reuse the same [key_id] and [data_id] for each pair in the map, since they all start with a fresh "copy" of the outer environment. *) @@ -84,7 +85,7 @@ let f | None -> model_info.default | Some (_prev_io_key, model) -> model in - annotate Model model; + annotate ~here Model model; let snapshot, () = run ~environment @@ -96,13 +97,13 @@ let f in let%mapn result = Snapshot.result snapshot and input = Input.to_incremental (Snapshot.input snapshot) - and lifecycle = Snapshot.lifecycle_or_empty snapshot in + and lifecycle = Snapshot.lifecycle_or_empty ~here snapshot in result, input, lifecycle in results_map, input_map, lifecycle_map) in - annotate Assoc_results results_map; - annotate Assoc_lifecycles lifecycle_map; + annotate ~here Assoc_results results_map; + annotate ~here Assoc_lifecycles lifecycle_map; let lifecycle = (* if we can prove that the body of the assoc_on doesn't contain a lifecycle node, then return None, dropping the constant incremental @@ -120,7 +121,7 @@ let f | None -> data)) ~remove:(fun ~outer_key:_ ~inner_key:key ~data:_ acc -> Map.remove acc key) in - annotate Assoc_lifecycles unfolded; + annotate ~here Assoc_lifecycles unfolded; Some unfolded in let input = @@ -128,7 +129,7 @@ let f | No -> Input.static_none | Yes_or_maybe -> Input.dynamic (input_map >>| Option.some) in - Trampoline.return (Snapshot.create ~result:results_map ~input ~lifecycle, ()) + Trampoline.return (Snapshot.create ~here ~result:results_map ~input ~lifecycle, ()) in let apply_action ~inject diff --git a/src/private_eval/eval_assoc_on.mli b/src/private_eval/eval_assoc_on.mli index 4796face..91e40cf9 100644 --- a/src/private_eval/eval_assoc_on.mli +++ b/src/private_eval/eval_assoc_on.mli @@ -17,4 +17,5 @@ val f -> data_id:'v Type_equal.Id.t -> by:'r Computation.t -> get_model_key:('io -> 'v -> 'model) + -> here:Source_code_position.t -> (('io, 'r, 'cmp_io) Map_intf.Map.t, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_assoc_simple.ml b/src/private_eval/eval_assoc_simple.ml index 992fe2d6..dbbe7afa 100644 --- a/src/private_eval/eval_assoc_simple.ml +++ b/src/private_eval/eval_assoc_simple.ml @@ -1,11 +1,12 @@ open! Core open! Import -let f ~map ~by ~may_contain = +let f ~map ~by ~may_contain ~here = let run ~environment ~fix_envs:_ ~path ~model:_ ~inject:_ = let map_input = Value.eval environment map in let result = Incr_map.mapi map_input ~f:(fun ~key ~data -> by path key data) in - Trampoline.return (Snapshot.create ~result ~input:Input.static ~lifecycle:None, ()) + Trampoline.return + (Snapshot.create ~here ~result ~input:Input.static ~lifecycle:None, ()) in Trampoline.return (Computation.T diff --git a/src/private_eval/eval_assoc_simple.mli b/src/private_eval/eval_assoc_simple.mli index e7374977..02dc69d5 100644 --- a/src/private_eval/eval_assoc_simple.mli +++ b/src/private_eval/eval_assoc_simple.mli @@ -5,4 +5,5 @@ val f : map:('key, 'data, 'cmp) Base.Map.t Value.t -> by:(Path.t -> 'key -> 'data -> 'result) -> may_contain:May_contain.Resolved.t + -> here:Source_code_position.t -> (('key, 'result, 'cmp) Base.Map.t, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_computation_watcher.ml b/src/private_eval/eval_computation_watcher.ml new file mode 100644 index 00000000..feb69d93 --- /dev/null +++ b/src/private_eval/eval_computation_watcher.ml @@ -0,0 +1,102 @@ +open! Core +open! Import + +(* extends the environment with a new version of the incremental identified by [id] with + an incremental that enqueues relevant info to the watcher queue whenever it updates *) +let enqueue_value + ~source_code_positions + ~watcher_queue + ~config + ~value_type_id_observation_definition_positions + environment + id + = + match Environment.find environment id with + | None -> + (* not being able to find this value is probably a bug, but let's not crash inside + this debugging utility. *) + eprint_s [%message "BUG" [%here] "value not found in environment"]; + environment + | Some value -> + let has_been_set = + Computation_watcher.Type_id_location_hashmap.update_and_check_if_value_set + ~id + ~update_data:(source_code_positions, config) + value_type_id_observation_definition_positions + in + (match has_been_set with + | `Already_set -> environment + | `Not_set -> + let loud_value = + Computation_watcher.instrument_incremental_node + ~here:[%here] + ~kind:`Named + ~watcher_queue + ~value_type_id_observation_definition_positions + ~id + value + in + Environment.add_overwriting environment ~key:id ~data:loud_value) +;; + +let f + (type a) + ~(gather : a Computation.gather_fun) + ~enable_watcher + ~recursive_scopes + ~time_source + ~inner + ~here:_ + ~free_vars + ~config + ~watcher_queue + ~value_type_id_observation_definition_positions + = + match + ( `Enable_watcher enable_watcher + , `Queue watcher_queue + , `Positions value_type_id_observation_definition_positions ) + with + | `Enable_watcher false, _, _ -> + (* If watcher isn't enabled, we shouldn't be printing anything *) + let%bind.Trampoline (T inner) = gather ~recursive_scopes ~time_source inner in + Trampoline.return (Computation.T inner) + | `Enable_watcher true, `Queue None, `Positions None + | `Enable_watcher true, `Queue None, `Positions (Some _) + | `Enable_watcher true, `Queue (Some _), `Positions None -> + (* If watcher is enabled and we are missing one or both of [watcher_queue] and + [value_type_id_observation_definition_positions], something's gone wrong + and we need to raise + *) + Core.raise_s + [%message + "BUG" + [%here] + "watcher queue or value_type_id_observation_definition_positions is none"] + | ( `Enable_watcher true + , `Queue (Some watcher_queue) + , `Positions (Some value_type_id_observation_definition_positions) ) -> + let%bind.Trampoline (T inner) = gather ~recursive_scopes ~time_source inner in + let run ~environment ~fix_envs ~path ~model ~inject = + let environment = + Computation_watcher.Type_id_location_map.fold + free_vars + ~init:environment + { f = + (fun env + id + (Computation_watcher.Source_code_positions.Finalized + source_code_positions) -> + enqueue_value + ~source_code_positions + ~watcher_queue + ~config + ~value_type_id_observation_definition_positions + env + id) + } + in + inner.run ~environment ~fix_envs ~path ~model ~inject + in + Trampoline.return (Computation.T { inner with run }) +;; diff --git a/src/private_eval/eval_computation_watcher.mli b/src/private_eval/eval_computation_watcher.mli new file mode 100644 index 00000000..32658223 --- /dev/null +++ b/src/private_eval/eval_computation_watcher.mli @@ -0,0 +1,20 @@ +open! Core +open! Import + +val f + : gather:'a Computation.gather_fun + -> enable_watcher:bool + -> recursive_scopes:Computation.Recursive_scopes.t + -> time_source:Time_source.t + -> inner:'a Computation.t + -> here:Lexing.position + -> free_vars:Computation_watcher.Type_id_location_map.t + -> config:Computation_watcher.Config.t + -> watcher_queue:Computation_watcher.Output_queue.t option + -> value_type_id_observation_definition_positions: + (Computation_watcher.Source_code_positions.finalized + Computation_watcher.Source_code_positions.t + * Computation_watcher.Config.t) + Computation_watcher.Type_id_location_hashmap.t + option + -> ('a, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_fetch.ml b/src/private_eval/eval_fetch.ml index 8e0d630f..15113aba 100644 --- a/src/private_eval/eval_fetch.ml +++ b/src/private_eval/eval_fetch.ml @@ -1,14 +1,15 @@ open! Core open! Import -let f ~id ~default ~for_some = +let f ~id ~default ~for_some ~here = let run ~environment ~fix_envs:_ ~path:_ ~model:_ ~inject:_ = let result = match Environment.find environment id with | None -> Incr.return default | Some x -> Incr.map x ~f:(fun a -> for_some a) in - Trampoline.return (Snapshot.create ~result ~lifecycle:None ~input:Input.static, ()) + Trampoline.return + (Snapshot.create ~here ~result ~lifecycle:None ~input:Input.static, ()) in Trampoline.return (Computation.T diff --git a/src/private_eval/eval_fetch.mli b/src/private_eval/eval_fetch.mli index 1e1a435b..eff0d4f3 100644 --- a/src/private_eval/eval_fetch.mli +++ b/src/private_eval/eval_fetch.mli @@ -5,4 +5,5 @@ val f : id:'a Type_equal.Id.t -> default:'b -> for_some:('a -> 'b) + -> here:Source_code_position.t -> ('b, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_fix.ml b/src/private_eval/eval_fix.ml index 78b5f11a..d3acedce 100644 --- a/src/private_eval/eval_fix.ml +++ b/src/private_eval/eval_fix.ml @@ -2,7 +2,15 @@ open! Core open! Import open Incr.Let_syntax -let define ~gather ~recursive_scopes ~time_source ~fix_id ~initial_input ~input_id ~result +let define + ~gather + ~recursive_scopes + ~time_source + ~fix_id + ~initial_input + ~input_id + ~result + ~here:_ = let rec inner_packed = lazy @@ -50,7 +58,7 @@ let define ~gather ~recursive_scopes ~time_source ~fix_id ~initial_input ~input_ (Computation.T { model; input; action; apply_action; reset; run; may_contain }) ;; -let recurse ~recursive_scopes ~input ~input_id ~fix_id = +let recurse ~recursive_scopes ~input ~input_id ~fix_id ~here = let wrap_lazy ~type_id inject = Action.lazy_ ~type_id >>> inject in let model = Meta.Model.Hidden.lazy_ in let gathered = Computation.Recursive_scopes.find_exn recursive_scopes fix_id in @@ -99,6 +107,7 @@ let recurse ~recursive_scopes ~input ~input_id ~fix_id = in Trampoline.return ( Snapshot.create + ~here ~input ~result:(Snapshot.result snapshot) ~lifecycle:(Snapshot.lifecycle snapshot) diff --git a/src/private_eval/eval_fix.mli b/src/private_eval/eval_fix.mli index ca9a1d58..568f7d15 100644 --- a/src/private_eval/eval_fix.mli +++ b/src/private_eval/eval_fix.mli @@ -9,6 +9,7 @@ val define -> initial_input:'b Value.t -> input_id:'b Type_equal.Id.t -> result:'a Computation.t + -> here:Source_code_position.t -> ('a, unit) Computation.packed_info Trampoline.t val recurse @@ -16,4 +17,5 @@ val recurse -> input:'a Value.t -> input_id:'a Type_equal.Id.t -> fix_id:'b Fix_id.t + -> here:Source_code_position.t -> ('b, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_lazy.ml b/src/private_eval/eval_lazy.ml index 57799659..3c6402ad 100644 --- a/src/private_eval/eval_lazy.ml +++ b/src/private_eval/eval_lazy.ml @@ -7,6 +7,7 @@ let f ~recursive_scopes ~time_source ~lazy_computation + ~here = let wrap_lazy ~type_id inject = Action.lazy_ ~type_id >>> inject in let model = Meta.Model.Hidden.lazy_ in @@ -27,7 +28,7 @@ let f = force gathered in - annotate Model model; + annotate ~here Model model; let input_model = let%map model in let (Meta.Model.Hidden.T { model; info; _ }) = @@ -52,6 +53,7 @@ let f in Trampoline.return ( Snapshot.create + ~here ~input ~result:(Snapshot.result snapshot) ~lifecycle:(Snapshot.lifecycle snapshot) diff --git a/src/private_eval/eval_lazy.mli b/src/private_eval/eval_lazy.mli index 4a6b35f7..58163810 100644 --- a/src/private_eval/eval_lazy.mli +++ b/src/private_eval/eval_lazy.mli @@ -6,4 +6,5 @@ val f -> recursive_scopes:Computation.Recursive_scopes.t -> time_source:Time_source.t -> lazy_computation:'a Computation.t lazy_t + -> here:Source_code_position.t -> ('a, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_leaf0.ml b/src/private_eval/eval_leaf0.ml index 32b28e6d..e9c297a0 100644 --- a/src/private_eval/eval_leaf0.ml +++ b/src/private_eval/eval_leaf0.ml @@ -2,10 +2,10 @@ open! Core open! Import open Incr.Let_syntax -let f ~model ~static_action ~time_source ~apply_action ~reset = +let f ~model ~static_action ~time_source ~apply_action ~reset ~here = let wrap_leaf inject = Action.static_leaf >>> inject in let run ~environment:_ ~fix_envs:_ ~path:_ ~model ~inject = - annotate Model model; + annotate ~here Model model; (* It's important to create [inject_static] outside of the [let%mapn] so that it remains [phys_equal] when the [model] changes. *) let inject_static = Lazy_inject.make (wrap_leaf inject) in @@ -13,7 +13,8 @@ let f ~model ~static_action ~time_source ~apply_action ~reset = let%map model in model, inject_static in - Trampoline.return (Snapshot.create ~result ~input:Input.static ~lifecycle:None, ()) + Trampoline.return + (Snapshot.create ~here ~result ~input:Input.static ~lifecycle:None, ()) in let apply_action ~inject ~schedule_event _input model = function | Action.Leaf_dynamic _ -> diff --git a/src/private_eval/eval_leaf0.mli b/src/private_eval/eval_leaf0.mli index 312d4e55..0b0ca7f2 100644 --- a/src/private_eval/eval_leaf0.mli +++ b/src/private_eval/eval_leaf0.mli @@ -18,4 +18,5 @@ val f -> time_source:Time_source.t -> 'model -> 'model) + -> here:Source_code_position.t -> ('model * ('action -> unit Effect.t), unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_leaf1.ml b/src/private_eval/eval_leaf1.ml index 08ca9afc..6afdd55d 100644 --- a/src/private_eval/eval_leaf1.ml +++ b/src/private_eval/eval_leaf1.ml @@ -2,10 +2,10 @@ open! Core open! Import open Incr.Let_syntax -let f ~model ~input_id ~dynamic_action ~input ~time_source ~reset ~apply_action = +let f ~model ~input_id ~dynamic_action ~input ~time_source ~reset ~apply_action ~here = let wrap_leaf inject = Action.dynamic_leaf >>> inject in let run ~environment ~fix_envs:_ ~path:_ ~model ~inject = - annotate Model model; + annotate ~here Model model; let input = Value.eval environment input in (* It's important to create [inject_dynamic] outside of the [let%mapn] so that it remains [phys_equal] when the [model] changes. *) @@ -15,7 +15,7 @@ let f ~model ~input_id ~dynamic_action ~input ~time_source ~reset ~apply_action model, inject_dynamic in Trampoline.return - (Snapshot.create ~result ~input:(Input.dynamic input) ~lifecycle:None, ()) + (Snapshot.create ~here ~result ~input:(Input.dynamic input) ~lifecycle:None, ()) in let apply_action ~inject ~schedule_event input model = function | Action.Leaf_static _ -> diff --git a/src/private_eval/eval_leaf1.mli b/src/private_eval/eval_leaf1.mli index ecf4c010..b199a7e8 100644 --- a/src/private_eval/eval_leaf1.mli +++ b/src/private_eval/eval_leaf1.mli @@ -21,4 +21,5 @@ val f -> 'model -> 'action -> 'model) + -> here:Source_code_position.t -> ('model * ('action -> unit Effect.t), unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_leaf_incr.ml b/src/private_eval/eval_leaf_incr.ml index 6f100565..fe251438 100644 --- a/src/private_eval/eval_leaf_incr.ml +++ b/src/private_eval/eval_leaf_incr.ml @@ -1,11 +1,12 @@ open! Core open! Import -let f ~input ~compute ~time_source = +let f ~input ~compute ~time_source ~here = let run ~environment ~fix_envs:_ ~path:_ ~model:_ ~inject:_ = let input = Value.eval environment input in let result = compute time_source input in - Trampoline.return (Snapshot.create ~result ~input:Input.static ~lifecycle:None, ()) + Trampoline.return + (Snapshot.create ~here ~result ~input:Input.static ~lifecycle:None, ()) in Trampoline.return (Computation.T diff --git a/src/private_eval/eval_leaf_incr.mli b/src/private_eval/eval_leaf_incr.mli index e096c76f..ab597b7d 100644 --- a/src/private_eval/eval_leaf_incr.mli +++ b/src/private_eval/eval_leaf_incr.mli @@ -5,4 +5,5 @@ val f : input:'a Value.t -> compute:('b -> 'a Incr.t -> 'c Incr.t) -> time_source:'b + -> here:Source_code_position.t -> ('c, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_lifecycle.ml b/src/private_eval/eval_lifecycle.ml index f7c46e74..b174fedf 100644 --- a/src/private_eval/eval_lifecycle.ml +++ b/src/private_eval/eval_lifecycle.ml @@ -4,7 +4,7 @@ open Incr.Let_syntax let do_nothing_lifecycle = Incr.return Lifecycle.Collection.empty -let f ~lifecycle = +let f ~lifecycle ~here = let run ~environment ~fix_envs:_ ~path ~model:_ ~inject:_ = let lifecycle = match%pattern_bind Value.eval environment lifecycle with @@ -15,6 +15,7 @@ let f ~lifecycle = in Trampoline.return ( Snapshot.create + ~here ~result:(Incr.return ()) ~input:Input.static ~lifecycle:(Some lifecycle) diff --git a/src/private_eval/eval_lifecycle.mli b/src/private_eval/eval_lifecycle.mli index ffc379f7..5d5044d8 100644 --- a/src/private_eval/eval_lifecycle.mli +++ b/src/private_eval/eval_lifecycle.mli @@ -3,4 +3,5 @@ open! Import val f : lifecycle:Lifecycle.t option Value.t + -> here:Source_code_position.t -> (unit, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_monitor_free_variables.ml b/src/private_eval/eval_monitor_free_variables.ml deleted file mode 100644 index af1ef172..00000000 --- a/src/private_eval/eval_monitor_free_variables.ml +++ /dev/null @@ -1,46 +0,0 @@ -open! Core -open! Import - -(* extends the environment with a new version of the incremental identified by [id] with - an incremental that prints whenever the input changes. *) -let make_value_loud ~here environment id = - match Environment.find environment id with - | None -> - (* not being able to find this value is probably a bug, but let's not crash inside - this debugging utility. *) - environment - | Some value -> - let incr_info = (Incr.user_info value : Info.t option) in - let loud_value = - Incr.map value ~f:(fun a -> - print_s - [%message - "node updated" - ~monitor:(here : Source_code_position.t) - (incr_info : Info.t option)]; - a) - in - Environment.add_overwriting environment ~key:id ~data:loud_value -;; - -let f - (type a) - ~(gather : a Computation.gather_fun) - ~recursive_scopes - ~time_source - ~inner - ~here - ~free_vars - = - let%bind.Trampoline (T inner) = gather ~recursive_scopes ~time_source inner in - let run ~environment ~fix_envs ~path ~model ~inject = - let environment = - Type_id_set.fold - free_vars - ~init:environment - { f = (fun env id -> make_value_loud ~here env id) } - in - inner.run ~environment ~fix_envs ~path ~model ~inject - in - Trampoline.return (Computation.T { inner with run }) -;; diff --git a/src/private_eval/eval_monitor_free_variables.mli b/src/private_eval/eval_monitor_free_variables.mli deleted file mode 100644 index 2cc9e6ff..00000000 --- a/src/private_eval/eval_monitor_free_variables.mli +++ /dev/null @@ -1,11 +0,0 @@ -open! Core -open! Import - -val f - : gather:'a Computation.gather_fun - -> recursive_scopes:Computation.Recursive_scopes.t - -> time_source:Time_source.t - -> inner:'a Computation.t - -> here:Source_code_position.t - -> free_vars:Type_id_set.t - -> ('a, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_path.ml b/src/private_eval/eval_path.ml index 7625f3ba..fe086392 100644 --- a/src/private_eval/eval_path.ml +++ b/src/private_eval/eval_path.ml @@ -1,11 +1,12 @@ open! Core open! Import -let f = +let f ~here = let run ~environment:_ ~fix_envs:_ ~path ~model:_ ~inject:_ = let result = Incr.return path in - annotate Path result; - Trampoline.return (Snapshot.create ~result ~input:Input.static ~lifecycle:None, ()) + annotate ~here Path result; + Trampoline.return + (Snapshot.create ~here ~result ~input:Input.static ~lifecycle:None, ()) in Trampoline.return (Computation.T diff --git a/src/private_eval/eval_path.mli b/src/private_eval/eval_path.mli index dffe390e..4cf90d00 100644 --- a/src/private_eval/eval_path.mli +++ b/src/private_eval/eval_path.mli @@ -1,4 +1,4 @@ open! Core open! Import -val f : (Path.t, unit) Computation.packed_info Trampoline.t +val f : here:Source_code_position.t -> (Path.t, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_return.ml b/src/private_eval/eval_return.ml index 16385cff..7af1e181 100644 --- a/src/private_eval/eval_return.ml +++ b/src/private_eval/eval_return.ml @@ -1,10 +1,11 @@ open! Core open! Import -let f ~value = +let f ~value ~here = let run ~environment ~fix_envs:_ ~path:_ ~model:_ ~inject:_ = let result = Value.eval environment value in - Trampoline.return (Snapshot.create ~result ~input:Input.static ~lifecycle:None, ()) + Trampoline.return + (Snapshot.create ~here ~result ~input:Input.static ~lifecycle:None, ()) in Trampoline.return (Computation.T diff --git a/src/private_eval/eval_return.mli b/src/private_eval/eval_return.mli index 197603a8..d7fbaabc 100644 --- a/src/private_eval/eval_return.mli +++ b/src/private_eval/eval_return.mli @@ -1,4 +1,7 @@ open! Core open! Import -val f : value:'a Value.t -> ('a, unit) Computation.packed_info Trampoline.t +val f + : value:'a Value.t + -> here:Source_code_position.t + -> ('a, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_sub.ml b/src/private_eval/eval_sub.ml index 9e0f7d65..d7d85d9c 100644 --- a/src/private_eval/eval_sub.ml +++ b/src/private_eval/eval_sub.ml @@ -118,7 +118,7 @@ let baseline let both_use_path = May_contain.Resolved.both_use_path from_may_contain into_may_contain in - annotate Model model; + annotate ~here Model model; let%bind.Trampoline from, maybe_env = let model = Incr.map model ~f:Tuple2.get1 in let path = if both_use_path then Path.append path Path.Elem.Subst_from else path in @@ -142,7 +142,7 @@ let baseline in let input = Input.merge (Snapshot.input from) (Snapshot.input into) in Trampoline.return - ( Snapshot.create ~result ~input ~lifecycle + ( Snapshot.create ~here ~result ~input ~lifecycle , Thread_env.capture thread_environment ~environment ~maybe_env ) in let model = Meta.Model.both info_from.model info_into.model in @@ -204,7 +204,7 @@ let from_stateless in let input = Snapshot.input into in Trampoline.return - ( Snapshot.create ~result ~input ~lifecycle + ( Snapshot.create ~here ~result ~input ~lifecycle , Thread_env.capture thread_environment ~environment ~maybe_env ) in T @@ -264,7 +264,7 @@ let into_stateless in let input = Snapshot.input from in Trampoline.return - ( Snapshot.create ~result ~input ~lifecycle + ( Snapshot.create ~here ~result ~input ~lifecycle , Thread_env.capture thread_environment ~environment ~maybe_env ) in T diff --git a/src/private_eval/eval_switch.ml b/src/private_eval/eval_switch.ml index 3c0b137b..bda37f9c 100644 --- a/src/private_eval/eval_switch.ml +++ b/src/private_eval/eval_switch.ml @@ -2,7 +2,7 @@ open! Core open! Import open Incr.Let_syntax -let f ~gather ~recursive_scopes ~time_source ~match_ ~arms = +let f ~gather ~recursive_scopes ~time_source ~match_ ~arms ~here = let wrap_switch ~branch ~type_id inject = Action.switch ~branch ~type_id >>> inject in let%bind.Trampoline gathered = Trampoline.all_map (Map.map arms ~f:(gather ~recursive_scopes ~time_source)) @@ -25,7 +25,7 @@ let f ~gather ~recursive_scopes ~time_source ~match_ ~arms = in num_contain_path > 1 in - annotate Switch_model model; + annotate ~here Switch_model model; let index = Value.eval environment match_ in let result_input_and_lifecycle = let%bind index in @@ -75,7 +75,8 @@ let f ~gather ~recursive_scopes ~time_source ~match_ ~arms = let%mapn input = Input.to_incremental (Snapshot.input snapshot) in Some (Meta.Input.Hidden.T { input; type_id = input_info; key = index }) in - Incr.return (Snapshot.result snapshot, input, Snapshot.lifecycle_or_empty snapshot) + Incr.return + (Snapshot.result snapshot, input, Snapshot.lifecycle_or_empty ~here snapshot) in let result = Incr.bind result_input_and_lifecycle ~f:Tuple3.get1 and input = Incr.bind result_input_and_lifecycle ~f:Tuple3.get2 @@ -92,7 +93,7 @@ let f ~gather ~recursive_scopes ~time_source ~match_ ~arms = | Yes_or_maybe -> Input.dynamic input | No -> Input.static_none in - Trampoline.return (Snapshot.create ~result ~input ~lifecycle, ()) + Trampoline.return (Snapshot.create ~here ~result ~input ~lifecycle, ()) in let apply_action ~inject diff --git a/src/private_eval/eval_switch.mli b/src/private_eval/eval_switch.mli index 682f67e3..11cf77ca 100644 --- a/src/private_eval/eval_switch.mli +++ b/src/private_eval/eval_switch.mli @@ -7,4 +7,5 @@ val f -> time_source:Time_source.t -> match_:int Value.t -> arms:(int, 'r Computation.t, Base.Int.comparator_witness) Map_intf.Map.t + -> here:Source_code_position.t -> ('r, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_with_model_resetter.ml b/src/private_eval/eval_with_model_resetter.ml index 9ab430ab..888485ac 100644 --- a/src/private_eval/eval_with_model_resetter.ml +++ b/src/private_eval/eval_with_model_resetter.ml @@ -1,7 +1,7 @@ open! Core open! Import -let f ~gather ~recursive_scopes ~time_source ~inner ~reset_id = +let f ~gather ~recursive_scopes ~time_source ~inner ~reset_id ~here = let%bind.Trampoline (Computation.T ({ model; input; action; apply_action; run; reset; may_contain } as gathered_inner)) @@ -38,6 +38,7 @@ let f ~gather ~recursive_scopes ~time_source ~inner ~reset_id = let result = Snapshot.result snapshot in Trampoline.return ( Snapshot.create + ~here ~result ~input:(Snapshot.input snapshot) ~lifecycle:(Snapshot.lifecycle snapshot) diff --git a/src/private_eval/eval_with_model_resetter.mli b/src/private_eval/eval_with_model_resetter.mli index 2d1f76ea..3c2b096c 100644 --- a/src/private_eval/eval_with_model_resetter.mli +++ b/src/private_eval/eval_with_model_resetter.mli @@ -7,4 +7,5 @@ val f -> time_source:Time_source.t -> inner:'a Computation.t -> reset_id:unit Effect.t Type_equal.Id.t + -> here:Source_code_position.t -> ('a, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/eval_wrap.ml b/src/private_eval/eval_wrap.ml index f855ae4d..cf7006c6 100644 --- a/src/private_eval/eval_wrap.ml +++ b/src/private_eval/eval_wrap.ml @@ -14,6 +14,7 @@ let f ~inner ~dynamic_apply_action ~reset:reset_me + ~here = let%bind.Trampoline (Computation.T { model = inner_model @@ -30,9 +31,9 @@ let f let wrap_inner inject = Action.wrap_inner >>> inject in let wrap_outer inject = Action.wrap_outer >>> inject in let run ~environment ~fix_envs ~path ~model ~inject = - annotate Model model; + annotate ~here Model model; let%pattern_bind outer_model, inner_model = model in - annotate Model outer_model; + annotate ~here Model outer_model; let%bind.Trampoline inner_snapshot, () = let outer_inject = Lazy_inject.make (wrap_outer inject) in let environment = @@ -50,6 +51,7 @@ let f in Trampoline.return ( Snapshot.create + ~here ~result:inner_result ~input ~lifecycle:(Snapshot.lifecycle inner_snapshot) diff --git a/src/private_eval/eval_wrap.mli b/src/private_eval/eval_wrap.mli index 05590373..23828464 100644 --- a/src/private_eval/eval_wrap.mli +++ b/src/private_eval/eval_wrap.mli @@ -25,4 +25,5 @@ val f -> time_source:Time_source.t -> 'model -> 'model) + -> here:Source_code_position.t -> ('result, unit) Computation.packed_info Trampoline.t diff --git a/src/private_eval/snapshot.ml b/src/private_eval/snapshot.ml index 902b83d7..34a82fec 100644 --- a/src/private_eval/snapshot.ml +++ b/src/private_eval/snapshot.ml @@ -8,10 +8,10 @@ type ('model, 'input, 'result) t = } [@@deriving fields ~getters ~iterators:create] -let create ~input ~lifecycle ~result = - Input.iter_incremental input ~f:(annotate_packed Input); - Option.iter lifecycle ~f:(annotate Lifecycle); - annotate Result result; +let create ~here ~input ~lifecycle ~result = + Input.iter_incremental input ~f:(annotate_packed ~here Input); + Option.iter lifecycle ~f:(annotate ~here Lifecycle); + annotate ~here Result result; Fields.create ~input ~lifecycle ~result ;; @@ -21,11 +21,11 @@ let attribute_positions here t = attribute here t.result ;; -let lifecycle_or_empty t = +let lifecycle_or_empty ~here t = match lifecycle t with | None -> let r = Incr.const Lifecycle.Collection.empty in - annotate Empty_lifecycle r; + annotate ~here Empty_lifecycle r; r | Some l -> l ;; diff --git a/src/private_eval/snapshot.mli b/src/private_eval/snapshot.mli index 77f65b91..c86d1ee6 100644 --- a/src/private_eval/snapshot.mli +++ b/src/private_eval/snapshot.mli @@ -18,12 +18,16 @@ val result : (_, _, 'result) t -> 'result Incr.t deactivation, and after_display callbacks. *) val lifecycle : _ t -> Lifecycle.Collection.t Incr.t option -val lifecycle_or_empty : _ t -> Lifecycle.Collection.t Incr.t +val lifecycle_or_empty + : here:Source_code_position.t + -> _ t + -> Lifecycle.Collection.t Incr.t (** Creates a new snapshot. Note that the [apply_action] provided here should apply the action in question to the model in force at the time [create] is called. *) val create - : input:'input Input.t + : here:Source_code_position.t + -> input:'input Input.t -> lifecycle:Lifecycle.Collection.t Incr.t option -> result:'result Incr.t -> ('model, 'input, 'result) t diff --git a/src/private_eval/value.ml b/src/private_eval/value.ml index ee4e2957..fb2dc497 100644 --- a/src/private_eval/value.ml +++ b/src/private_eval/value.ml @@ -212,7 +212,7 @@ let rec eval : type a. Environment.t -> a t -> a Incr.t = let eval env t = let incr = eval env t in - annotate Value incr; + annotate ~here:t.here Value incr; incr ;; @@ -260,27 +260,205 @@ let map7 ?(here = Stdlib.Lexing.dummy_pos) t1 t2 t3 t4 t5 t6 t7 ~f = { value = Map7 { t1; t2; t3; t4; t5; t6; t7; f }; here; id = value_id "map7" } ;; -let rec all ?(here = Stdlib.Lexing.dummy_pos) = function +let all ?(here = Stdlib.Lexing.dummy_pos) = function | [] -> return [] - | [ t1 ] -> map ~here t1 ~f:(fun a1 -> [ a1 ]) - | [ t1; t2 ] -> map2 ~here t1 t2 ~f:(fun a1 a2 -> [ a1; a2 ]) - | [ t1; t2; t3 ] -> map3 ~here t1 t2 t3 ~f:(fun a1 a2 a3 -> [ a1; a2; a3 ]) - | [ t1; t2; t3; t4 ] -> - map4 ~here t1 t2 t3 t4 ~f:(fun a1 a2 a3 a4 -> [ a1; a2; a3; a4 ]) - | [ t1; t2; t3; t4; t5 ] -> - map5 ~here t1 t2 t3 t4 t5 ~f:(fun a1 a2 a3 a4 a5 -> [ a1; a2; a3; a4; a5 ]) - | [ t1; t2; t3; t4; t5; t6 ] -> - map6 ~here t1 t2 t3 t4 t5 t6 ~f:(fun a1 a2 a3 a4 a5 a6 -> [ a1; a2; a3; a4; a5; a6 ]) - | [ t1; t2; t3; t4; t5; t6; t7 ] -> - map7 ~here t1 t2 t3 t4 t5 t6 t7 ~f:(fun a1 a2 a3 a4 a5 a6 a7 -> - [ a1; a2; a3; a4; a5; a6; a7 ]) - | t1 :: t2 :: t3 :: t4 :: t5 :: t6 :: t7 :: rest -> - let left = - map7 ~here t1 t2 t3 t4 t5 t6 t7 ~f:(fun a1 a2 a3 a4 a5 a6 a7 -> - [ a1; a2; a3; a4; a5; a6; a7 ]) + | [ x ] -> map x ~f:(fun x -> [ x ]) + | xs -> + (* [Balance_list_tree] guarantees that if there are any [Node]s, they will all be at the + start of the list. This means we don't need to match on all possible permutations + of leaves and nodes. *) + let tree = Balance_list_tree.balance ~n:7 xs |> ok_exn in + let rec flatten (node : 'a t Balance_list_tree.t) = + match node with + | Leaf x -> map ~here x ~f:(fun x -> [ x ]) + | Node [ x1 ] -> flatten x1 + | Node [ Leaf x1; Leaf x2 ] -> map2 ~here x1 x2 ~f:(fun x1 x2 -> [ x1; x2 ]) + | Node [ x1; Leaf x2 ] -> map2 ~here (flatten x1) x2 ~f:(fun x1 x2 -> x1 @ [ x2 ]) + | Node [ x1; x2 ] -> map2 ~here (flatten x1) (flatten x2) ~f:(fun x1 x2 -> x1 @ x2) + | Node [ Leaf x1; Leaf x2; Leaf x3 ] -> + map3 ~here x1 x2 x3 ~f:(fun x1 x2 x3 -> [ x1; x2; x3 ]) + | Node [ x1; Leaf x2; Leaf x3 ] -> + map3 ~here (flatten x1) x2 x3 ~f:(fun x1 x2 x3 -> x1 @ [ x2; x3 ]) + | Node [ x1; x2; Leaf x3 ] -> + map3 ~here (flatten x1) (flatten x2) x3 ~f:(fun x1 x2 x3 -> x1 @ x2 @ [ x3 ]) + | Node [ x1; x2; x3 ] -> + map3 ~here (flatten x1) (flatten x2) (flatten x3) ~f:(fun x1 x2 x3 -> + x1 @ x2 @ x3) + | Node [ Leaf x1; Leaf x2; Leaf x3; Leaf x4 ] -> + map4 ~here x1 x2 x3 x4 ~f:(fun x1 x2 x3 x4 -> [ x1; x2; x3; x4 ]) + | Node [ x1; Leaf x2; Leaf x3; Leaf x4 ] -> + map4 ~here (flatten x1) x2 x3 x4 ~f:(fun x1 x2 x3 x4 -> x1 @ [ x2; x3; x4 ]) + | Node [ x1; x2; Leaf x3; Leaf x4 ] -> + map4 ~here (flatten x1) (flatten x2) x3 x4 ~f:(fun x1 x2 x3 x4 -> + x1 @ x2 @ [ x3; x4 ]) + | Node [ x1; x2; x3; Leaf x4 ] -> + map4 ~here (flatten x1) (flatten x2) (flatten x3) x4 ~f:(fun x1 x2 x3 x4 -> + x1 @ x2 @ x3 @ [ x4 ]) + | Node [ x1; x2; x3; x4 ] -> + map4 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + ~f:(fun x1 x2 x3 x4 -> x1 @ x2 @ x3 @ x4) + | Node [ Leaf x1; Leaf x2; Leaf x3; Leaf x4; Leaf x5 ] -> + map5 ~here x1 x2 x3 x4 x5 ~f:(fun x1 x2 x3 x4 x5 -> [ x1; x2; x3; x4; x5 ]) + | Node [ x1; Leaf x2; Leaf x3; Leaf x4; Leaf x5 ] -> + map5 ~here (flatten x1) x2 x3 x4 x5 ~f:(fun x1 x2 x3 x4 x5 -> + x1 @ [ x2; x3; x4; x5 ]) + | Node [ x1; x2; Leaf x3; Leaf x4; Leaf x5 ] -> + map5 ~here (flatten x1) (flatten x2) x3 x4 x5 ~f:(fun x1 x2 x3 x4 x5 -> + x1 @ x2 @ [ x3; x4; x5 ]) + | Node [ x1; x2; x3; Leaf x4; Leaf x5 ] -> + map5 ~here (flatten x1) (flatten x2) (flatten x3) x4 x5 ~f:(fun x1 x2 x3 x4 x5 -> + x1 @ x2 @ x3 @ [ x4; x5 ]) + | Node [ x1; x2; x3; x4; Leaf x5 ] -> + map5 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + x5 + ~f:(fun x1 x2 x3 x4 x5 -> x1 @ x2 @ x3 @ x4 @ [ x5 ]) + | Node [ x1; x2; x3; x4; x5 ] -> + map5 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + (flatten x5) + ~f:(fun x1 x2 x3 x4 x5 -> x1 @ x2 @ x3 @ x4 @ x5) + | Node [ Leaf x1; Leaf x2; Leaf x3; Leaf x4; Leaf x5; Leaf x6 ] -> + map6 ~here x1 x2 x3 x4 x5 x6 ~f:(fun x1 x2 x3 x4 x5 x6 -> + [ x1; x2; x3; x4; x5; x6 ]) + | Node [ x1; Leaf x2; Leaf x3; Leaf x4; Leaf x5; Leaf x6 ] -> + map6 ~here (flatten x1) x2 x3 x4 x5 x6 ~f:(fun x1 x2 x3 x4 x5 x6 -> + x1 @ [ x2; x3; x4; x5; x6 ]) + | Node [ x1; x2; Leaf x3; Leaf x4; Leaf x5; Leaf x6 ] -> + map6 ~here (flatten x1) (flatten x2) x3 x4 x5 x6 ~f:(fun x1 x2 x3 x4 x5 x6 -> + x1 @ x2 @ [ x3; x4; x5; x6 ]) + | Node [ x1; x2; x3; Leaf x4; Leaf x5; Leaf x6 ] -> + map6 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + x4 + x5 + x6 + ~f:(fun x1 x2 x3 x4 x5 x6 -> x1 @ x2 @ x3 @ [ x4; x5; x6 ]) + | Node [ x1; x2; x3; x4; Leaf x5; Leaf x6 ] -> + map6 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + x5 + x6 + ~f:(fun x1 x2 x3 x4 x5 x6 -> x1 @ x2 @ x3 @ x4 @ [ x5; x6 ]) + | Node [ x1; x2; x3; x4; x5; Leaf x6 ] -> + map6 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + (flatten x5) + x6 + ~f:(fun x1 x2 x3 x4 x5 x6 -> x1 @ x2 @ x3 @ x4 @ x5 @ [ x6 ]) + | Node [ x1; x2; x3; x4; x5; x6 ] -> + map6 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + (flatten x5) + (flatten x6) + ~f:(fun x1 x2 x3 x4 x5 x6 -> x1 @ x2 @ x3 @ x4 @ x5 @ x6) + | Node [ Leaf x1; Leaf x2; Leaf x3; Leaf x4; Leaf x5; Leaf x6; Leaf x7 ] -> + map7 ~here x1 x2 x3 x4 x5 x6 x7 ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> + [ x1; x2; x3; x4; x5; x6; x7 ]) + | Node [ x1; Leaf x2; Leaf x3; Leaf x4; Leaf x5; Leaf x6; Leaf x7 ] -> + map7 ~here (flatten x1) x2 x3 x4 x5 x6 x7 ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> + x1 @ [ x2; x3; x4; x5; x6; x7 ]) + | Node [ x1; x2; Leaf x3; Leaf x4; Leaf x5; Leaf x6; Leaf x7 ] -> + map7 + ~here + (flatten x1) + (flatten x2) + x3 + x4 + x5 + x6 + x7 + ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> x1 @ x2 @ [ x3; x4; x5; x6; x7 ]) + | Node [ x1; x2; x3; Leaf x4; Leaf x5; Leaf x6; Leaf x7 ] -> + map7 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + x4 + x5 + x6 + x7 + ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> x1 @ x2 @ x3 @ [ x4; x5; x6; x7 ]) + | Node [ x1; x2; x3; x4; Leaf x5; Leaf x6; Leaf x7 ] -> + map7 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + x5 + x6 + x7 + ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> x1 @ x2 @ x3 @ x4 @ [ x5; x6; x7 ]) + | Node [ x1; x2; x3; x4; x5; Leaf x6; Leaf x7 ] -> + map7 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + (flatten x5) + x6 + x7 + ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> x1 @ x2 @ x3 @ x4 @ x5 @ [ x6; x7 ]) + | Node [ x1; x2; x3; x4; x5; x6; Leaf x7 ] -> + map7 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + (flatten x5) + (flatten x6) + x7 + ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> x1 @ x2 @ x3 @ x4 @ x5 @ x6 @ [ x7 ]) + | Node [ x1; x2; x3; x4; x5; x6; x7 ] -> + map7 + ~here + (flatten x1) + (flatten x2) + (flatten x3) + (flatten x4) + (flatten x5) + (flatten x6) + (flatten x7) + ~f:(fun x1 x2 x3 x4 x5 x6 x7 -> x1 @ x2 @ x3 @ x4 @ x5 @ x6 @ x7) + | Node xs -> + (* This shouldn't happen, because the balancer guaruntees that each node has at + most 7 children. But exceptions at runtime are scary, so let's be safe. *) + Nonempty_list.fold_right xs ~init:(return ~here []) ~f:(fun x acc -> + map2 ~here (flatten x) acc ~f:(fun x acc -> x @ acc)) in - let right = all ~here rest in - map2 ~here left right ~f:(fun left right -> left @ right) + flatten tree ;; let of_incr ?(here = Stdlib.Lexing.dummy_pos) x = diff --git a/src/proc.ml b/src/proc.ml index aa2890e0..9e2bdaa1 100644 --- a/src/proc.ml +++ b/src/proc.ml @@ -339,6 +339,44 @@ let actor0 (Value.return ~here ()) ;; +let state' + (type model) + ?(here = Stdlib.Lexing.dummy_pos) + ?reset + ?sexp_of_model + ?equal + default_model + = + let module Action = struct + type t = Source_code_position.t * (model -> model) [@@deriving sexp_of] + end + in + let reset = + Option.map reset ~f:(fun reset (_ : _ Apply_action_context.t) m -> reset m) + in + let open Let_syntax_with_map_location (struct + let here = here + end) in + let%sub state, set_state = + state_machine0 + ~here + ?reset + ~sexp_of_action:[%sexp_of: Action.t] + ?sexp_of_model + ?equal + ~apply_action:(fun (_ : _ Apply_action_context.t) old_model (_location, f) -> + f old_model) + ~default_model + () + in + let%sub set_state = + let%arr set_state in + fun ?(here = Stdlib.Lexing.dummy_pos) prev -> set_state (here, prev) + in + let%arr state and set_state in + state, set_state +;; + let state ?(here = Stdlib.Lexing.dummy_pos) ?reset ?sexp_of_model ?equal default_model = let sexp_of_action = (* NOTE: The model and the action for [state] are the same. *) diff --git a/src/proc_intf.ml b/src/proc_intf.ml index 7d53268a..af6a315f 100644 --- a/src/proc_intf.ml +++ b/src/proc_intf.ml @@ -289,6 +289,18 @@ module type S = sig -> unit -> ('model option * ('model option -> unit Effect.t)) Computation.t + (** Similar to [state], but the `set` function takes a function that calculates + the new state from the previous state. *) + val state' + : ?here:Stdlib.Lexing.position + -> ?reset:('model -> 'model) + (** to learn more about [reset], read the docs on [with_model_resetter] *) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> 'model + -> ('model * (?here:Stdlib.Lexing.position -> ('model -> 'model) -> unit Effect.t)) + Computation.t + (** A bool-state which starts at [default_model] and flips whenever the returned effect is scheduled. *) val toggle diff --git a/src/proc_min.ml b/src/proc_min.ml index e2c3cd2b..7089eb5d 100644 --- a/src/proc_min.ml +++ b/src/proc_min.ml @@ -4,8 +4,37 @@ open Computation let read ?(here = Stdlib.Lexing.dummy_pos) value = Return { value; here } -let monitor_free_variables ~here inner = - Monitor_free_variables { here; inner; free_vars = Type_id_set.empty } +let watch_computation + ~here + ~log_model_before + ~log_model_after + ~log_action + ~log_incr_info + ~log_watcher_positions + ~log_dependency_definition_position + ~label + inner + = + Computation_watcher + { here + ; inner + ; free_vars = Computation_watcher.Type_id_location_map.empty + ; config = + { log_model_before + ; log_model_after + ; log_action + ; log_incr_info + ; log_watcher_positions + ; log_dependency_definition_position + ; label + } + ; queue = None + ; value_type_id_observation_definition_positions = None + ; enable_watcher = + false + (* [enable_watcher] will be set during the transformation stage if computation watchers + are enabled *) + } ;; let sub (type via) ?(here = Stdlib.Lexing.dummy_pos) (from : via Computation.t) ~f = diff --git a/src/proc_min.mli b/src/proc_min.mli index 05c699e5..d9a006ca 100644 --- a/src/proc_min.mli +++ b/src/proc_min.mli @@ -60,8 +60,15 @@ module Dynamic_scope : sig -> 'b Computation.t end -val monitor_free_variables +val watch_computation : here:Source_code_position.t + -> log_model_before:bool + -> log_model_after:bool + -> log_action:bool + -> log_incr_info:bool + -> log_watcher_positions:bool + -> log_dependency_definition_position:bool + -> label:string option -> 'a Computation.t -> 'a Computation.t diff --git a/src/protocol/introspection/bonsai_introspection_protocol.ml b/src/protocol/introspection/bonsai_introspection_protocol.ml index 91d47c73..25a64fe8 100644 --- a/src/protocol/introspection/bonsai_introspection_protocol.ml +++ b/src/protocol/introspection/bonsai_introspection_protocol.ml @@ -285,6 +285,8 @@ module For_module_startup_timings = struct end end +module For_incr_node_introspection = Incr_node_introspection + module For_testing = struct module Rpc_id = struct include Rpc_id diff --git a/src/protocol/introspection/bonsai_introspection_protocol.mli b/src/protocol/introspection/bonsai_introspection_protocol.mli index 809a3f3c..15f980d3 100644 --- a/src/protocol/introspection/bonsai_introspection_protocol.mli +++ b/src/protocol/introspection/bonsai_introspection_protocol.mli @@ -164,6 +164,8 @@ module For_module_startup_timings : sig end end +module For_incr_node_introspection = Incr_node_introspection + module For_testing : sig module Rpc_id : sig type t = Rpc_id.t diff --git a/src/protocol/introspection/incr_node_introspection.ml b/src/protocol/introspection/incr_node_introspection.ml new file mode 100644 index 00000000..de66c08c --- /dev/null +++ b/src/protocol/introspection/incr_node_introspection.ml @@ -0,0 +1,49 @@ +open! Core + +module Node = struct + module T = struct + type t = + { here : Source_code_position_with_quickcheck.t + ; kind : string + } + [@@sexp.allow_extra_fields] [@@deriving sexp, compare, quickcheck] + end + + include T + include Comparable.Make (T) +end + +module Event = struct + module Stable = struct + module V1 = struct + type t = Node_created of { node : Node.t } + [@@unboxed] [@@deriving sexp, quickcheck] + end + + type t = V1 of V1.t [@@deriving sexp, quickcheck] + + let of_latest v1 = V1 v1 + + let to_latest = function + | V1 v1 -> v1 + ;; + end + + type t = Stable.V1.t = Node_created of { node : Node.t } + [@@unboxed] [@@deriving sexp_of] +end + +module State = struct + type t = int Node.Map.t [@@deriving sexp] + + let empty = Node.Map.empty + + let apply_event : t -> Event.t -> t = + fun map event -> + match event with + | Node_created { node } -> + Map.update map node ~f:(function + | None -> 1 + | Some prev -> prev + 1) + ;; +end diff --git a/src/protocol/introspection/incr_node_introspection.mli b/src/protocol/introspection/incr_node_introspection.mli new file mode 100644 index 00000000..d743384d --- /dev/null +++ b/src/protocol/introspection/incr_node_introspection.mli @@ -0,0 +1,33 @@ +open! Core + +module Node : sig + type t = + { here : Source_code_position.t + ; kind : string + } + [@@deriving sexp_of, compare] + + include Comparable.S with type t := t +end + +module Event : sig + type t = Node_created of { node : Node.t } [@@unboxed] [@@deriving sexp_of] + + module Stable : sig + module V1 : sig + type nonrec t = t [@@deriving sexp] + end + + type t [@@deriving sexp, quickcheck] + + val of_latest : V1.t -> t + val to_latest : t -> V1.t + end +end + +module State : sig + type t = int Node.Map.t [@@deriving sexp_of] + + val empty : t + val apply_event : t -> Event.t -> t +end diff --git a/src/protocol/introspection/source_code_position_with_quickcheck.ml b/src/protocol/introspection/source_code_position_with_quickcheck.ml new file mode 100644 index 00000000..eef9b112 --- /dev/null +++ b/src/protocol/introspection/source_code_position_with_quickcheck.ml @@ -0,0 +1,9 @@ +open! Core + +type t = Source_code_position.t = + { pos_fname : string + ; pos_lnum : int + ; pos_bol : int + ; pos_cnum : int + } +[@@deriving sexp, quickcheck, equal, compare] diff --git a/src/protocol/introspection/source_code_position_with_quickcheck.mli b/src/protocol/introspection/source_code_position_with_quickcheck.mli new file mode 100644 index 00000000..292aed6d --- /dev/null +++ b/src/protocol/introspection/source_code_position_with_quickcheck.mli @@ -0,0 +1,3 @@ +open! Core + +type t = Source_code_position.t [@@deriving sexp, quickcheck, compare, equal] diff --git a/src/skeleton.ml b/src/skeleton.ml index 4197f5b8..8bf74c33 100644 --- a/src/skeleton.ml +++ b/src/skeleton.ml @@ -224,7 +224,7 @@ module Computation0 = struct | Path | Lifecycle of { value : Value.t } | Identity of { t : t } - | Monitor_free_variables of + | Computation_watcher of { inner : t ; free_vars : Id.t list } @@ -387,11 +387,22 @@ module Computation0 = struct } in { node_path; here; kind } - | Monitor_free_variables { inner; free_vars; here } -> + | Computation_watcher + { inner + ; here + ; free_vars + ; config = _ + ; queue = _ + ; value_type_id_observation_definition_positions = _ + ; enable_watcher = _ + } -> let kind = - Monitor_free_variables + Computation_watcher { inner = helper ~current_path:(Node_path.descend current_path) inner - ; free_vars = Type_id_set.map_to_list free_vars { f = Id.of_type_id } + ; free_vars = + Computation_watcher.Type_id_location_map.map_to_list + free_vars + { f = (fun key _ -> Id.of_type_id key) } } in { node_path; here; kind } @@ -464,7 +475,7 @@ module Computation0 = struct | Path | Lifecycle of { value : Value.Minimal.t } | Identity of { t : t } - | Monitor_free_variables of + | Computation_watcher of { inner : t ; free_vars : Id.t list } @@ -524,8 +535,8 @@ module Computation0 = struct | Path -> Path | Lifecycle { value } -> Lifecycle { value = Value.Minimal.of_complete value } | Identity { t } -> Identity { t = of_complete t } - | Monitor_free_variables { inner; free_vars } -> - Monitor_free_variables { inner = of_complete inner; free_vars } + | Computation_watcher { inner; free_vars } -> + Computation_watcher { inner = of_complete inner; free_vars } ;; end @@ -556,7 +567,7 @@ module Computation0 = struct | Path -> [] | Lifecycle { value } -> [ value ] | Identity _ -> [] - | Monitor_free_variables _ -> [] + | Computation_watcher _ -> [] ;; let children (t : t) = @@ -585,7 +596,7 @@ module Computation0 = struct | Path -> [] | Lifecycle _ -> [] | Identity { t } -> [ t ] - | Monitor_free_variables { inner; _ } -> [ inner ] + | Computation_watcher { inner; _ } -> [ inner ] ;; end @@ -669,7 +680,7 @@ include struct | Path | Lifecycle of { value : value } | Identity of { t : computation } - | Monitor_free_variables of + | Computation_watcher of { inner : computation ; free_vars : id list } @@ -771,7 +782,7 @@ module Counts = struct ; path : int ; lifecycle : int ; identity : int - ; monitor_free_variables : int + ; computation_watcher : int } [@@deriving sexp_of] end @@ -827,9 +838,8 @@ module Counts = struct | Lifecycle _ -> acc.computation <- { c with lifecycle = c.lifecycle + 1 } | Identity _ -> acc.computation <- { c with identity = c.identity + 1 } | Lazy _ -> () - | Monitor_free_variables _ -> - acc.computation - <- { c with monitor_free_variables = c.monitor_free_variables + 1 }); + | Computation_watcher _ -> + acc.computation <- { c with computation_watcher = c.computation_watcher + 1 }); super#computation_kind t acc method! value_kind t acc = @@ -867,7 +877,7 @@ module Counts = struct ; path = 0 ; lifecycle = 0 ; identity = 0 - ; monitor_free_variables = 0 + ; computation_watcher = 0 } ; value = { constant = 0; exception_ = 0; incr = 0; named = 0; cutoff = 0; mapn = 0 } diff --git a/src/skeleton.mli b/src/skeleton.mli index d45dadfb..538efd7f 100644 --- a/src/skeleton.mli +++ b/src/skeleton.mli @@ -115,7 +115,7 @@ module Computation : sig | Path | Lifecycle of { value : Value.t } | Identity of { t : t } - | Monitor_free_variables of + | Computation_watcher of { inner : t ; free_vars : Id.t list } diff --git a/src/to_dot.ml b/src/to_dot.ml index a3af7ded..5de47d5e 100644 --- a/src/to_dot.ml +++ b/src/to_dot.ml @@ -247,8 +247,8 @@ let rec follow_skeleton_computation state (computation : Skeleton.Computation.t) let me = register_computation "identity" in arrow state ~from:(follow_skeleton_computation state t) ~to_:me; me - | Monitor_free_variables { inner; _ } -> - let me = register_computation "monitor_free_variables" in + | Computation_watcher { inner; _ } -> + let me = register_computation "computation_watcher" in arrow state ~from:(follow_skeleton_computation state inner) ~to_:me; me ;; diff --git a/src/transform.ml b/src/transform.ml index 697296ca..d0872217 100644 --- a/src/transform.ml +++ b/src/transform.ml @@ -264,9 +264,26 @@ module For_computation = struct | Lifecycle { lifecycle = t; here } -> let%bind inner = map_value t in return (Computation.Lifecycle { lifecycle = inner; here }) - | Monitor_free_variables { inner; free_vars; here } -> + | Computation_watcher + { inner + ; here + ; free_vars + ; config + ; queue + ; value_type_id_observation_definition_positions + ; enable_watcher + } -> let%bind inner = map inner in - return (Computation.Monitor_free_variables { inner; free_vars; here }) + return + (Computation.Computation_watcher + { inner + ; here + ; free_vars + ; config + ; queue + ; value_type_id_observation_definition_positions + ; enable_watcher + }) ;; let id =