├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.org ├── bench └── src │ ├── dune │ ├── import.ml │ ├── incr_map_bench_lib.ml │ ├── linear.ml │ ├── linear.mli │ ├── map.ml │ ├── map.mli │ ├── merge.ml │ ├── merge.mli │ ├── nested_sum.ml │ ├── nested_sum.mli │ ├── shares_per_symbol.ml │ ├── shares_per_symbol.mli │ ├── stats.ml │ ├── stats.mli │ ├── sum.ml │ └── sum.mli ├── collate ├── README.md ├── src │ ├── collate_params.ml │ ├── collate_params.mli │ ├── collated.ml │ ├── collated.mli │ ├── collated_intf.ml │ ├── dune │ ├── incr_map_collate.ml │ └── incr_map_collate.mli └── test │ ├── bench │ ├── bench.ml │ ├── bench.mli │ ├── dune │ ├── incr_map_collate_bench.ml │ └── incr_map_collate_bench.mli │ ├── collate_and_fold_tests.ml │ ├── collate_and_fold_tests.mli │ ├── dune │ ├── incr_map_collate_test.ml │ ├── key_and_range_tests.ml │ ├── key_and_range_tests.mli │ ├── key_rank_tests.ml │ └── key_rank_tests.mli ├── dune-project ├── erase_key ├── README.md ├── dune ├── src │ ├── dune │ ├── opaque_map.ml │ └── opaque_map.mli └── test │ ├── dune │ ├── import.ml │ └── opaque_map_test.ml ├── incr_map.opam ├── src ├── dune ├── incr_map.ml ├── incr_map.mli └── incr_map_intf.ml └── test ├── benchmarks ├── dune ├── flamegraph_generation_tools │ ├── dune │ ├── generate_flamegraph_for_command.sh │ └── html_table.ml ├── html_table_like_benchmark.ml ├── html_table_like_benchmark.mli ├── import.ml ├── incr_map_benchmarks.ml ├── subrange_by_rank.ml └── subrange_by_rank.mli ├── dune ├── import.ml ├── incr_map_test.ml ├── map_operations.ml ├── map_operations.mli ├── merge_both_some.ml ├── merge_disjoint.ml ├── rand_map_helper.ml ├── rand_map_helper.mli ├── subrange_quickcheck_helper.ml ├── subrange_quickcheck_helper.mli ├── test_cartesian_map.ml ├── test_cartesian_map.mli ├── test_collapse.ml ├── test_counti.ml ├── test_counti.mli ├── test_counting_map.ml ├── test_counting_map.mli ├── test_cutoff.ml ├── test_expand.ml ├── test_expand.mli ├── test_flatten.ml ├── test_for_alli_and_existsi.ml ├── test_for_alli_and_existsi.mli ├── test_generics.ml ├── test_generics.mli ├── test_index_by.ml ├── test_instrument.ml ├── test_join.ml ├── test_keys.ml ├── test_lookup.ml ├── test_mapping.ml ├── test_merge.ml ├── test_observe_changes_exn.ml ├── test_observe_changes_exn.mli ├── test_of_set.ml ├── test_partition_map.ml ├── test_rank.ml ├── test_rekey.ml ├── test_separate.ml ├── test_subrange.ml ├── test_sum.ml ├── test_sum.mli ├── test_transpose.ml ├── test_unordered_fold.ml ├── test_unordered_fold_nested_maps.ml ├── test_unordered_fold_with_extra.ml ├── test_unzip.ml ├── test_unzip3.ml └── unzip_fails.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.17.0 2 | - New functions introduced: 3 | - `Incr_map.merge_disjoint` merges two maps with disjoint keys 4 | - `Incr_map.observe_changes_exn` observes changes in a map across stabilizations 5 | 6 | ## Release v0.16.0 7 | 8 | Incr_map 9 | 10 | - New functions 11 | * `cutoff` - applies a cutoff to the values in an incremental map 12 | * `partition_mapi'` - like `partition_mapi`, but the callback function has an 13 | incremental input and output 14 | * `unordered_fold_with_extra` - like `unordered_fold`, but depends on an arbitrary extra 15 | incremental value that can be factored into the folding computation 16 | * `merge_both_some` - like `merge`, but the mapping callback function is only called on 17 | keys contained in both maps 18 | 19 | - New arguments 20 | * Add `Instrumentation` module and optional `instrumentation` argument to all `Incr_map` 21 | functions, which can be used for performance profiling 22 | * Add optional `finalize` argument to `unordered_fold`, which can be used to change the 23 | order in which fold operations are processed 24 | 25 | - Bug fixes 26 | * Fix function `subrange_by_rank` to handle unbounded lower bound correctly 27 | * Fix typo in function name `mapi_mn` to `map_min` 28 | 29 | Erase_key 30 | 31 | - Small new library for type-erasing the key from an incremental map without introducing 32 | an existential type 33 | 34 | Collate 35 | 36 | - Remove the `Map_list` library 37 | * Switch all prior uses of `Map_list` to the more general `Incr_map_erase_key` 38 | 39 | - Make `Incr_map_collate` no longer a functor 40 | 41 | - Fold 42 | * Add module `Fold` defining a fold callback function 43 | * Add function `collate_and_fold`, like `collate` but allows you to perform a fold 44 | over the post-filtered, pre-range-restricted data 45 | * Add function `collate_and_fold__sort_first`, like `collate__sort_first` but allows you 46 | to perform a fold over the post-filtered, pre-range-restricted data 47 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2016--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Incr\_map 2 | 3 | A set of functions for operating incrementally and efficiently on map 4 | like data structures. This leverages new functionality in Incremental 5 | along with the ability to efficiently diff map data structures using 6 | =Map.symmetric_diff=. 7 | -------------------------------------------------------------------------------- /bench/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incr_map_bench_lib) 3 | (libraries core incremental incr_map core_bench expect_test_helpers_core) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /bench/src/import.ml: -------------------------------------------------------------------------------- 1 | module Incr = Incremental.Make () 2 | module Incr_map = Incr_map.Make (Incr) 3 | module Var = Incr.Var 4 | module Obs = Incr.Observer 5 | module Bench = Core_bench.Bench 6 | include Incr.Let_syntax 7 | 8 | module Infix = struct 9 | let ( := ) = Var.set 10 | let ( ! ) = Var.value 11 | end 12 | -------------------------------------------------------------------------------- /bench/src/incr_map_bench_lib.ml: -------------------------------------------------------------------------------- 1 | module Import = Import 2 | module Linear = Linear 3 | module Map = Map 4 | module Merge = Merge 5 | module Nested_sum = Nested_sum 6 | module Shares_per_symbol = Shares_per_symbol 7 | module Stats = Stats 8 | module Sum = Sum 9 | -------------------------------------------------------------------------------- /bench/src/linear.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | type sequence_kind = 5 | | Trivial 6 | | Recombine 7 | | Wide 8 | [@@deriving sexp] 9 | 10 | let sequence kind n = 11 | let start = Incr.Var.create 0 in 12 | let incr = 13 | match kind with 14 | | Recombine -> 15 | Sequence.fold (Sequence.range 0 n) ~init:(Incr.Var.watch start) ~f:(fun incr _i -> 16 | let a = incr >>| Int.succ in 17 | let b = incr >>| Int.succ in 18 | Incr.map2 a b ~f:( + )) 19 | | Trivial -> 20 | Sequence.fold (Sequence.range 0 n) ~init:(Incr.Var.watch start) ~f:(fun incr _i -> 21 | incr >>| Int.succ) 22 | | Wide -> 23 | let double l = 24 | List.concat_map l ~f:(fun i -> 25 | let a = i >>| Int.succ in 26 | let b = i >>| Int.succ in 27 | [ a; b ]) 28 | in 29 | let spread = 30 | Sequence.fold 31 | (Sequence.range 0 n) 32 | ~init:[ Incr.Var.watch start ] 33 | ~f:(fun incr_list _ -> double incr_list) 34 | in 35 | List.reduce_balanced_exn ~f:(Incr.map2 ~f:( + )) spread 36 | in 37 | start, incr 38 | ;; 39 | 40 | let sequence_raw kind n = 41 | let input, output = 42 | let input, output = sequence kind n in 43 | input, Incr.observe output 44 | in 45 | fun () -> 46 | let open Infix in 47 | input := !input + 1; 48 | Incr.stabilize (); 49 | ignore (Obs.value_exn output : int) 50 | ;; 51 | 52 | let sequence_without_change kind n = 53 | let output = 54 | let _input, output = sequence kind n in 55 | Incr.observe output 56 | in 57 | fun () -> 58 | Incr.stabilize (); 59 | ignore (Obs.value_exn output : int) 60 | ;; 61 | 62 | let%bench_fun "Recombine 50" = sequence_raw Recombine 50 63 | let%bench_fun "Trivial 50" = sequence_raw Trivial 50 64 | let%bench_fun "Wide 5" = sequence_raw Wide 5 65 | let%bench_fun "Wide 10" = sequence_raw Wide 10 66 | let%bench_fun "50 (just stabilize)" = sequence_without_change Recombine 50 67 | 68 | (* 69 | Each iteration of "trivial 50" updates 50 incremental nodes. 70 | Each iteration of "recombine 50" updates ~150 nodes. 71 | Each iteration of "wide K" updates about 3 * 2^K nodes. 72 | 73 | Dividing out times per run shows that each node update takes somewhere between 15 and 74 | 50 nanoseconds. 75 | 76 | {v 77 | ┌─────────────────────────────────┬──────────────┬─────────┬────────────┐ 78 | │ Name │ Time/Run │ mWd/Run │ Percentage │ 79 | ├─────────────────────────────────┼──────────────┼─────────┼────────────┤ 80 | │ [linear.ml] Recombine 50 │ 6_925.04ns │ │ 3.96% │ 81 | │ [linear.ml] Trivial 50 │ 729.76ns │ │ 0.42% │ 82 | │ [linear.ml] Wide 5 │ 5_059.74ns │ │ 2.90% │ 83 | │ [linear.ml] Wide 10 │ 174_702.44ns │ -0.81w │ 100.00% │ 84 | │ [linear.ml] 50 (just stabilize) │ 36.94ns │ │ 0.02% │ 85 | └─────────────────────────────────┴──────────────┴─────────┴────────────┘ 86 | 87 | v} *) 88 | 89 | let%expect_test "stats" = 90 | let stats = unstage (Stats.reporter ()) in 91 | stats (); 92 | [%expect 93 | {| 94 | ((recomputed 0) 95 | (changed 0) 96 | (created 0)) 97 | |}]; 98 | let run = sequence_raw Recombine 50 in 99 | stats (); 100 | [%expect 101 | {| 102 | ((recomputed 0) 103 | (changed 0) 104 | (created 151)) 105 | |}]; 106 | run (); 107 | stats (); 108 | [%expect 109 | {| 110 | ((recomputed 151) 111 | (changed 151) 112 | (created 0)) 113 | |}]; 114 | run (); 115 | stats (); 116 | [%expect 117 | {| 118 | ((recomputed 151) 119 | (changed 151) 120 | (created 0)) 121 | |}]; 122 | run (); 123 | stats (); 124 | [%expect 125 | {| 126 | ((recomputed 151) 127 | (changed 151) 128 | (created 0)) 129 | |}] 130 | ;; 131 | -------------------------------------------------------------------------------- /bench/src/linear.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /bench/src/map.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | (** Test cost of building up (and stabilizing along the way) some derived incr node of a 5 | map. *) 6 | 7 | let input = 8 | lazy 9 | (let size = 100_000 in 10 | Sequence.fold (Sequence.init size ~f:Int.succ) ~init:Int.Map.empty ~f:(fun map i -> 11 | Map.set map ~key:i ~data:i)) 12 | ;; 13 | 14 | module M (S : sig 15 | val name : string 16 | val f : int Int.Map.t Incr.t -> int Incr.t 17 | end) = 18 | struct 19 | let name = S.name 20 | let f = S.f 21 | 22 | module%bench [@name_suffix name] _ = struct 23 | (* Build a map from scratch, one [Map.set] per element, stabilizing along the way. *) 24 | let%bench_fun ("make" [@indexed size = [ 1000; 100_000 ]]) = 25 | fun () -> 26 | let open Infix in 27 | let input = Incr.Var.create Int.Map.empty in 28 | let output = f (Incr.Var.watch input) |> Incr.observe in 29 | for i = 1 to size do 30 | input := Map.set !input ~key:i ~data:i; 31 | Incr.stabilize (); 32 | assert (Incr.Observer.value_exn output = i) 33 | done 34 | ;; 35 | 36 | (* Take a map as input, update one key (1, specifically), and stabilize *) 37 | let%bench_fun "update" = 38 | let input = force input in 39 | let size = Map.length input in 40 | let input = Incr.Var.create input in 41 | let output = f (Incr.Var.watch input) |> Incr.observe in 42 | Incr.stabilize (); 43 | fun () -> 44 | let open Infix in 45 | input 46 | := Map.update !input 1 ~f:(function 47 | | None -> 0 48 | | Some i -> i + 1); 49 | Incr.stabilize (); 50 | assert (Incr.Observer.value_exn output = size) 51 | ;; 52 | 53 | (* Add, stabilize, remove, to existing input map. *) 54 | let%bench_fun "add/remove" = 55 | let input = force input in 56 | let unused = Map.max_elt_exn input |> fst |> Int.succ in 57 | let size = Map.length input in 58 | let input = Incr.Var.create input in 59 | let output = f (Incr.Var.watch input) |> Incr.observe in 60 | Incr.stabilize (); 61 | let size' = size + 1 in 62 | fun () -> 63 | let open Infix in 64 | input := Map.add_exn !input ~key:unused ~data:0; 65 | Incr.stabilize (); 66 | assert (Incr.Observer.value_exn output = size'); 67 | input := Map.remove !input unused; 68 | Incr.stabilize (); 69 | assert (Incr.Observer.value_exn output = size) 70 | ;; 71 | end 72 | end 73 | 74 | module _ = M (struct 75 | let name = "trivial" 76 | let f map = map >>| Map.length 77 | end) 78 | 79 | module _ = M (struct 80 | let name = "mapi" 81 | let f map = Incr_map.mapi map ~f:(fun ~key ~data -> key + data) >>| Map.length 82 | end) 83 | 84 | module _ = M (struct 85 | let name = "mapi'" 86 | 87 | let f map = 88 | Incr_map.mapi' map ~f:(fun ~key ~data -> 89 | let%map data in 90 | key + data) 91 | >>| Map.length 92 | ;; 93 | end) 94 | -------------------------------------------------------------------------------- /bench/src/map.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /bench/src/merge.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | module M (M : sig 5 | val n : int 6 | val left_changes : int 7 | val right_changes : int 8 | end) = 9 | struct 10 | let m_0 = Int.Map.of_alist_exn (List.init M.n ~f:(fun x -> x, x)) 11 | 12 | (* Change 100 elements *) 13 | let negate_k_elements k = 14 | List.init k ~f:(fun x -> x * (M.n / k)) 15 | |> List.fold ~init:m_0 ~f:(fun m x -> Map.change m x ~f:(Option.map ~f:(fun x -> -x))) 16 | ;; 17 | 18 | let m_left = negate_k_elements M.left_changes 19 | let m_right = negate_k_elements M.right_changes 20 | let suffix = sprintf "(%d, %d)" M.left_changes M.right_changes 21 | 22 | module%bench [@name_suffix suffix] _ = struct 23 | let%bench_fun "merge-sum" = 24 | let left = Var.create m_0 in 25 | let right = Var.create m_0 in 26 | let sum = 27 | Incr_map.merge (Var.watch left) (Var.watch right) ~f:(fun ~key:_ -> function 28 | | `Left x | `Right x -> Some x 29 | | `Both (x, y) -> Some (x + y)) 30 | in 31 | let sum = Incr.observe sum in 32 | fun () -> 33 | Var.set left m_left; 34 | Var.set right m_right; 35 | Incr.stabilize (); 36 | ignore (Obs.value_exn sum : int Int.Map.t); 37 | Var.set left m_0; 38 | Var.set right m_0; 39 | Incr.stabilize (); 40 | ignore (Obs.value_exn sum : int Int.Map.t) 41 | ;; 42 | end 43 | end 44 | 45 | module _ = M (struct 46 | let n = 10_000 47 | let left_changes = 0 48 | let right_changes = 100 49 | end) 50 | 51 | module _ = M (struct 52 | let n = 10_000 53 | let left_changes = 1 54 | let right_changes = 1_000 55 | end) 56 | 57 | module _ = M (struct 58 | let n = 10_000 59 | let left_changes = 100 60 | let right_changes = 0 61 | end) 62 | 63 | module _ = M (struct 64 | let n = 10_000 65 | let left_changes = 100 66 | let right_changes = 100 67 | end) 68 | 69 | module _ = M (struct 70 | let n = 10_000 71 | let left_changes = 1_000 72 | let right_changes = 1 73 | end) 74 | 75 | module _ = M (struct 76 | let n = 10_000 77 | let left_changes = 10_000 78 | let right_changes = 10_000 79 | end) 80 | -------------------------------------------------------------------------------- /bench/src/merge.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /bench/src/nested_sum.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | (* In this section, we're doing a summation over nested maps containing floats in the 5 | inner maps. *) 6 | 7 | let sum_map = Sum.sum_map 8 | let sum_map' m = sum_map (Incr_map.mapi' m ~f:(fun ~key:_ ~data -> sum_map data)) 9 | 10 | (* Sets an element in the inner map, given both outer and inner index *) 11 | let set_el m o i v = 12 | Map.update m o ~f:(function 13 | | None -> Map.singleton (module Int) i v 14 | | Some m' -> Map.set m' ~key:i ~data:v) 15 | ;; 16 | 17 | (* Initializes a map full of zeros for all combinations of inner and outer indices *) 18 | let initialize ~outer ~inner = 19 | Sequence.fold 20 | (Sequence.range 0 outer) 21 | ~init:(Map.empty (module Int)) 22 | ~f:(fun acc o -> 23 | Sequence.fold (Sequence.range 0 inner) ~init:acc ~f:(fun acc i -> set_el acc o i 0.)) 24 | ;; 25 | 26 | module Sum_map_direct = struct 27 | (* From the OCaml manual, chapter 20: 28 | 29 | "As an optimization, records whose fields all have static type float are 30 | represented as arrays of floating-point numbers, with tag Double_array_tag." 31 | 32 | This means that a mutable float member of such an record type is effectively 33 | unboxed (other than the record itself), and in particular can be mutated in-place 34 | without allocation. Interestingly, this optimization is not, as of 4.07, applied 35 | to the type [float ref]. 36 | 37 | On the other hand, a [float ref] which does not escape a single scope can be 38 | lowered to a register, so this trick isn't necessary if we're (say) for-looping 39 | over an array. But in any case where we have to use a ref inside a closure we're 40 | far better off using this type. Similarly, we can't return a float in %xmm 41 | registers. So the obvious [Map.fold] here actually allocates one box per map 42 | entry, so we're better off using a ref. 43 | *) 44 | type float_ref = { mutable contents : float } 45 | 46 | let float_ref contents = { contents } 47 | let ( := ) ref x = ref.contents <- x 48 | let ( ! ) ref = ref.contents 49 | let acc = float_ref 0.0 50 | 51 | let sum m ~get = 52 | acc := 0.0; 53 | Map.iter m ~f:(fun v -> acc := !acc +. get v); 54 | !acc 55 | ;; 56 | end 57 | 58 | module M (M : sig 59 | val outer : int 60 | val inner : int 61 | end) = 62 | struct 63 | let outer = M.outer 64 | let inner = M.inner 65 | let suffix = sprintf "(%d, %d)" outer inner 66 | 67 | (* Exposed for testing. Computes the nested sum incrementally, using [sum_map']. *) 68 | let nested_sum_raw () = 69 | let open Infix in 70 | let input = Var.create (initialize ~outer ~inner) in 71 | let sum = Incr.observe (sum_map' (Var.watch input)) in 72 | fun () -> 73 | let o = Random.int outer in 74 | let i = Random.int inner in 75 | input := set_el !input o i (Random.float 1.0); 76 | Incr.stabilize (); 77 | ignore (Obs.value_exn sum : float) 78 | ;; 79 | 80 | module%bench [@name_suffix suffix] _ = struct 81 | let%bench_fun "incr" = nested_sum_raw () 82 | 83 | (* Compute the outer sum incrementally using [sum_map], but do the inner sum 84 | all-at-once. *) 85 | let%bench_fun "out" = 86 | let open Infix in 87 | let input = Var.create (initialize ~outer ~inner) in 88 | let inner_summed = 89 | Incr_map.mapi (Var.watch input) ~f:(fun ~key:_ ~data -> 90 | Sum_map_direct.sum data ~get:Fn.id) 91 | in 92 | let sum = Incr.observe (sum_map inner_summed) in 93 | fun () -> 94 | let o = Random.int outer in 95 | let i = Random.int inner in 96 | input := set_el !input o i (Random.float 1.0); 97 | Incr.stabilize (); 98 | ignore (Obs.value_exn sum : float) 99 | ;; 100 | 101 | (* Does the nested sum in an all-at-once way, using ordinary map folds *) 102 | let%bench_fun "ord" = 103 | let input = ref (initialize ~outer ~inner) in 104 | let sum () = Sum_map_direct.sum !input ~get:(Sum_map_direct.sum ~get:Fn.id) in 105 | fun () -> 106 | let o = Random.int outer in 107 | let i = Random.int inner in 108 | input := set_el !input o i (Random.float 1.0); 109 | ignore (sum ()) 110 | ;; 111 | end 112 | end 113 | 114 | module _ = M (struct 115 | let outer = 10000 116 | let inner = 10 117 | end) 118 | 119 | module M2 = M (struct 120 | let outer = 1000 121 | let inner = 100 122 | end) 123 | 124 | module _ = M (struct 125 | let outer = 100 126 | let inner = 1000 127 | end) 128 | 129 | module _ = M (struct 130 | let outer = 10 131 | let inner = 10000 132 | end) 133 | 134 | (* Looks like it doesn't matter all that much how you choose to structure the nested maps, 135 | though more outer elements clearly adds expense. Note also that despite the decently 136 | large cost of the incremental update, the all-at-once computation is ~200-300x worse. 137 | {v 138 | ┌────────────────────────────────────┬──────────┬─────────┬──────────┬──────────┬───────┐ 139 | │ Name │ Time/Run │ mWd/Run │ mjWd/Run │ Prom/Run │ %age │ 140 | ├────────────────────────────────────┼──────────┼─────────┼──────────┼──────────┼───────┤ 141 | │ [nested_sum.ml:M:(10, 10000)] incr │ 2.32us │ 277.17w │ 24.88w │ 24.88w │ 0.26% │ 142 | │ [nested_sum.ml:M:(100, 1000)] incr │ 2.73us │ 296.97w │ 25.81w │ 25.81w │ 0.31% │ 143 | │ [nested_sum.ml:M:(1000, 100)] incr │ 3.18us │ 325.29w │ 30.82w │ 30.83w │ 0.36% │ 144 | │ [nested_sum.ml:M:(10000, 10)] incr │ 4.93us │ 358.42w │ 44.97w │ 45.00w │ 0.56% │ 145 | │ [nested_sum.ml:M:(10, 10000)] ord │ 669.97us │ 160.35w │ 34.33w │ 34.33w │ 76.3% │ 146 | │ [nested_sum.ml:M:(100, 1000)] ord │ 804.13us │ 155.24w │ 16.73w │ 16.73w │ 91.6% │ 147 | │ [nested_sum.ml:M:(1000, 100)] ord │ 769.96us │ 154.80w │ 15.60w │ 15.60w │ 87.7% │ 148 | │ [nested_sum.ml:M:(10000, 10)] ord │ 877.80us │ 160.23w │ 21.29w │ 21.29w │ 100% │ 149 | │ [nested_sum.ml:M:(10, 10000)] out │ 80.39us │ 245.98w │ 24.79w │ 24.79w │ 9.16% │ 150 | │ [nested_sum.ml:M:(100, 1000)] out │ 12.60us │ 265.92w │ 24.87w │ 24.87w │ 1.44% │ 151 | │ [nested_sum.ml:M:(1000, 100)] out │ 3.75us │ 294.54w │ 28.27w │ 28.27w │ 0.43% │ 152 | │ [nested_sum.ml:M:(10000, 10)] out │ 3.17us │ 330.02w │ 39.67w │ 39.67w │ 0.36% │ 153 | └────────────────────────────────────┴──────────┴─────────┴──────────┴──────────┴───────┘ 154 | 155 | v} 156 | *) 157 | 158 | let%expect_test "stats" = 159 | let stats = unstage (Stats.reporter ()) in 160 | stats (); 161 | [%expect 162 | {| 163 | ((recomputed 0) 164 | (changed 0) 165 | (created 0)) 166 | |}]; 167 | let run = M2.nested_sum_raw () in 168 | stats (); 169 | [%expect 170 | {| 171 | ((recomputed 0) 172 | (changed 0) 173 | (created 4)) 174 | |}]; 175 | run (); 176 | stats (); 177 | [%expect 178 | {| 179 | ((recomputed 2004) 180 | (changed 2004) 181 | (created 2000)) 182 | |}]; 183 | run (); 184 | stats (); 185 | [%expect 186 | {| 187 | ((recomputed 6) 188 | (changed 5) 189 | (created 0)) 190 | |}]; 191 | run (); 192 | stats (); 193 | [%expect 194 | {| 195 | ((recomputed 6) 196 | (changed 5) 197 | (created 0)) 198 | |}] 199 | ;; 200 | -------------------------------------------------------------------------------- /bench/src/nested_sum.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /bench/src/shares_per_symbol.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module Symbol : Identifiable = String 4 | 5 | module Dir = struct 6 | type t = 7 | | Buy 8 | | Sell 9 | [@@deriving equal] 10 | end 11 | 12 | module Order = struct 13 | module Id : Identifiable = String 14 | 15 | type t = 16 | { sym : Symbol.t 17 | ; size : int 18 | ; price : float 19 | ; dir : Dir.t 20 | ; id : Id.t 21 | } 22 | end 23 | 24 | let shares orders = 25 | Incr_map.unordered_fold 26 | orders 27 | ~init:0 28 | ~add:(fun ~key:_ ~data:(o : Order.t) acc -> acc + o.size) 29 | ~remove:(fun ~key:_ ~data:(o : Order.t) acc -> acc - o.size) 30 | ;; 31 | 32 | let index_by inner_comparator outer_comparator map get_outer_index = 33 | let add ~key ~data acc = 34 | let idx = get_outer_index data in 35 | Map.update acc idx ~f:(function 36 | | None -> Map.singleton inner_comparator key data 37 | | Some inner_map -> Map.set inner_map ~key ~data) 38 | in 39 | let remove ~key ~data acc = 40 | let idx = get_outer_index data in 41 | Map.change acc idx ~f:(function 42 | | None -> assert false 43 | | Some inner_map -> 44 | let inner_map = Map.remove inner_map key in 45 | if Map.is_empty inner_map then None else Some inner_map) 46 | in 47 | Incr_map.unordered_fold map ~init:(Map.empty outer_comparator) ~add ~remove 48 | ;; 49 | 50 | let%expect_test "index_by" = 51 | let open Expect_test_helpers_core in 52 | let v = Incr.Var.create (Map.empty (module Int)) in 53 | let o = 54 | index_by (module Int) (module String) (Incr.Var.watch v) String.uppercase 55 | |> Incr.observe 56 | in 57 | let change f = 58 | Incr.Var.set v (f (Incr.Var.value v)); 59 | Incr.stabilize (); 60 | print_s [%sexp (Incr.Observer.value_exn o : string Map.M(Int).t Map.M(String).t)] 61 | in 62 | let add key data m = Map.set m ~key ~data in 63 | change (add 1 "bar"); 64 | [%expect {| ((BAR ((1 bar)))) |}]; 65 | change (add 1 "foo"); 66 | [%expect {| ((FOO ((1 foo)))) |}]; 67 | change (add 2 "foo"); 68 | [%expect 69 | {| 70 | (( 71 | FOO ( 72 | (1 foo) 73 | (2 foo)))) 74 | |}]; 75 | change (add 3 "bar"); 76 | [%expect 77 | {| 78 | ((BAR ((3 bar))) 79 | (FOO ( 80 | (1 foo) 81 | (2 foo)))) 82 | |}]; 83 | change (add 2 "bar"); 84 | [%expect 85 | {| 86 | ((BAR ( 87 | (2 bar) 88 | (3 bar))) 89 | (FOO ((1 foo)))) 90 | |}] 91 | ;; 92 | 93 | let shares_per_symbol orders = 94 | let orders_by_symbol = 95 | index_by (module Order.Id) (module Symbol) orders (fun (o : Order.t) -> o.sym) 96 | in 97 | Incr_map.mapi' orders_by_symbol ~f:(fun ~key:_ ~data -> shares data) 98 | ;; 99 | 100 | let shares_per_symbol_flat (orders : Order.t Map.M(Order.Id).t Incr.t) = 101 | let update_sym_map op ~key:_ ~data:(o : Order.t) m = 102 | Map.update m o.sym ~f:(function 103 | | None -> o.size 104 | | Some x -> op x o.size) 105 | in 106 | Incr_map.unordered_fold 107 | orders 108 | ~init:(Map.empty (module Symbol)) 109 | ~add:(update_sym_map ( + )) 110 | ~remove:(update_sym_map ( - )) 111 | ;; 112 | 113 | let random_order rstate : Order.t = 114 | let num_symbols = 100 in 115 | let sym = Symbol.of_string (sprintf "SYM-%2i" (Random.int num_symbols)) in 116 | let size = Random.State.int rstate 10_000 in 117 | let price = Random.State.int rstate 10_000 // 100 in 118 | let dir = if Random.State.bool rstate then Dir.Buy else Dir.Sell in 119 | let id = Order.Id.of_string (sprintf "ID-%i" (Random.State.int rstate Int.max_value)) in 120 | { sym; size; price; dir; id } 121 | ;; 122 | 123 | let random_orders rstate n = 124 | List.init n ~f:(fun _ -> random_order rstate) 125 | |> List.fold 126 | ~init:(Map.empty (module Order.Id)) 127 | ~f:(fun m o -> Map.set m ~key:o.id ~data:o) 128 | ;; 129 | 130 | let shares_per_symbol_bench n shares_per_symbol_fn = 131 | let open Infix in 132 | let rstate = Random.State.make [| 1 |] in 133 | let init_orders = random_orders rstate n in 134 | let orders = Var.create init_orders in 135 | let shares = Incr.observe (shares_per_symbol_fn (Var.watch orders)) in 136 | fun () -> 137 | let o = random_order rstate in 138 | orders := Map.set init_orders ~key:o.id ~data:o; 139 | Incr.stabilize (); 140 | ignore (Obs.value_exn shares : int Map.M(Symbol).t) 141 | ;; 142 | 143 | let%bench_fun "nested" = shares_per_symbol_bench 1_000_000 shares_per_symbol 144 | let%bench_fun "flat" = shares_per_symbol_bench 1_000_000 shares_per_symbol_flat 145 | 146 | (* Benchmark results: 147 | 148 | The flat version is better, but not massively better, than the original, showing that 149 | having a bunch of extra incremental nodes is expensive, but not horribly so. (The 150 | memory numbers are obviously messed up, and I don't know why...) 151 | 152 | {v 153 | ┌───────────────────────────────┬──────────┬────────────┬──────────┬──────────┬────────────┐ 154 | │ Name │ Time/Run │ mWd/Run │ mjWd/Run │ Prom/Run │ Percentage │ 155 | ├───────────────────────────────┼──────────┼────────────┼──────────┼──────────┼────────────┤ 156 | │ [shares_per_symbol.ml] nested │ 16.96us │ 363.42w │ 39.34w │ 39.34w │ 100.00% │ 157 | │ [shares_per_symbol.ml] flat │ 6.16us │ -5_755.70w │ -2.56w │ -2.56w │ 36.31% │ 158 | └───────────────────────────────┴──────────┴────────────┴──────────┴──────────┴────────────┘ 159 | 160 | v} 161 | *) 162 | -------------------------------------------------------------------------------- /bench/src/shares_per_symbol.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /bench/src/stats.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | type t = 5 | { recomputed : int 6 | ; changed : int 7 | ; created : int 8 | } 9 | [@@deriving sexp] 10 | 11 | let diff t1 t2 = 12 | { recomputed = t1.recomputed - t2.recomputed 13 | ; changed = t1.changed - t2.changed 14 | ; created = t1.created - t2.created 15 | } 16 | ;; 17 | 18 | let snap () = 19 | { recomputed = Incr.State.num_nodes_recomputed Incr.State.t 20 | ; changed = Incr.State.num_nodes_changed Incr.State.t 21 | ; created = Incr.State.num_nodes_created Incr.State.t 22 | } 23 | ;; 24 | 25 | let reporter () = 26 | let open Expect_test_helpers_core in 27 | let old_stats = ref (snap ()) in 28 | let report () = 29 | let stats = snap () in 30 | print_s [%sexp (diff stats !old_stats : t)]; 31 | old_stats := stats 32 | in 33 | stage report 34 | ;; 35 | -------------------------------------------------------------------------------- /bench/src/stats.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | val reporter : unit -> (unit -> unit) Staged.t 5 | -------------------------------------------------------------------------------- /bench/src/sum.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | (* Sums up a list of incrementals in a tree-like fashion *) 5 | let incr_list_sum l = 6 | match List.reduce_balanced l ~f:(Incr.map2 ~f:( +. )) with 7 | | None -> return 0. 8 | | Some x -> x 9 | ;; 10 | 11 | let len = 100_000 12 | 13 | (* Each of the tests below creates a collection of inputs and some form of incremental sum 14 | of those inputs. The test then modifies a single cell, and stabilizes the computation 15 | and gets the result *) 16 | let%bench_fun "tree" = 17 | let open Infix in 18 | let inputs = Array.init len ~f:(fun _ -> Incr.Var.create 0.) in 19 | let sum = 20 | Incr.observe (incr_list_sum (Array.to_list inputs |> List.map ~f:Var.watch)) 21 | in 22 | fun () -> 23 | let i = Random.int len in 24 | inputs.(i) := !(inputs.(i)) +. Random.float 1.0; 25 | Incr.stabilize (); 26 | ignore (Obs.value_exn sum : float) 27 | ;; 28 | 29 | (* This test uses incrementals built-in array fold. *) 30 | let%bench_fun "array_fold" = 31 | let open Infix in 32 | let inputs = Array.init len ~f:(fun _ -> Incr.Var.create 0.) in 33 | let sum = 34 | Incr.observe 35 | (Incr.unordered_array_fold 36 | (Array.map inputs ~f:Var.watch) 37 | ~init:0. 38 | ~f:( +. ) 39 | ~update:(F_inverse ( -. ))) 40 | in 41 | fun () -> 42 | let i = Random.int len in 43 | inputs.(i) := !(inputs.(i)) +. Random.float 1.0; 44 | Incr.stabilize (); 45 | ignore (Obs.value_exn sum : float) 46 | ;; 47 | 48 | (* This sums over an incremental map, using incr_map *) 49 | let sum_map m = 50 | Incr_map.unordered_fold 51 | m 52 | ~init:0. 53 | ~add:(fun ~key:_ ~data:x sum -> sum +. x) 54 | ~remove:(fun ~key:_ ~data:x sum -> sum -. x) 55 | ~update:(fun ~key:_ ~old_data ~new_data sum -> sum -. old_data +. new_data) 56 | ;; 57 | 58 | let%bench_fun "incr_map" = 59 | let open Infix in 60 | let inputs = 61 | Var.create (Map.of_alist_exn (module Int) (List.init len ~f:(fun i -> i, 0.))) 62 | in 63 | let sum = Incr.observe (sum_map (Var.watch inputs)) in 64 | fun () -> 65 | let i = Random.int len in 66 | let change = Random.float 1.0 in 67 | inputs 68 | := Map.update !inputs i ~f:(function 69 | | None -> change 70 | | Some x -> x +. change); 71 | Incr.stabilize (); 72 | ignore (Obs.value_exn sum : float) 73 | ;; 74 | 75 | (* Here we just do a simple fold over the entire array to get the sum. *) 76 | let%bench_fun "ord" = 77 | let inputs = Array.init len ~f:(fun _ -> 0.) in 78 | let sum () = 79 | let acc = ref 0.0 in 80 | for i = 0 to Array.length inputs - 1 do 81 | acc := !acc +. inputs.(i) 82 | done; 83 | !acc 84 | in 85 | fun () -> 86 | let i = Random.int len in 87 | inputs.(i) <- inputs.(i) +. Random.float 1.0; 88 | ignore (sum () : float) 89 | ;; 90 | 91 | (* A run of the above benchmark included below. You can see that the incr_map version is 92 | faster than the tree sum, but it does allocate more. The ordinary all-at-once 93 | computation is 50-100x slower than the incremental ones, unsurprisingly. 94 | 95 | {v 96 | ┌─────────────────────┬──────────────┬─────────┬──────────┬──────────┬────────────┐ 97 | │ Name │ Time/Run │ mWd/Run │ mjWd/Run │ Prom/Run │ Percentage │ 98 | ├─────────────────────┼──────────────┼─────────┼──────────┼──────────┼────────────┤ 99 | │ [sum.ml] tree │ 2_691.56ns │ 37.72w │ 6.27w │ 6.27w │ 2.46% │ 100 | │ [sum.ml] array_fold │ 676.13ns │ 7.96w │ 1.25w │ 1.25w │ 0.62% │ 101 | │ [sum.ml] incr_map │ 1_577.01ns │ 182.66w │ 21.89w │ 21.89w │ 1.44% │ 102 | │ [sum.ml] ord │ 109_582.98ns │ 4.00w │ │ │ 100.00% │ 103 | └─────────────────────┴──────────────┴─────────┴──────────┴──────────┴────────────┘ 104 | 105 | v} *) 106 | -------------------------------------------------------------------------------- /bench/src/sum.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | val sum_map : (_, float, _) Base.Map.t Incr.t -> float Incr.t 5 | -------------------------------------------------------------------------------- /collate/README.md: -------------------------------------------------------------------------------- 1 | # Incr_map_collate 2 | 3 | A library for filtering, sorting and paging a map using incr_map, as often done 4 | in web servers and web apps. 5 | 6 | For most of the use cases, you probably also need the [incr_map_collated_concrete] 7 | library. 8 | -------------------------------------------------------------------------------- /collate/src/collate_params.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Stable = struct 4 | open Stable_witness.Export 5 | 6 | module Rank = struct 7 | module V1 = Int.Stable.V1 8 | 9 | module V2 = struct 10 | type t = 11 | | From_start of int 12 | | From_end of int 13 | [@@deriving 14 | sexp, compare, equal, bin_io, hash, diff ~stable_version:1, stable_witness] 15 | 16 | let of_v1 v1 = From_start v1 17 | end 18 | end 19 | 20 | module Which_range = struct 21 | module V1 = struct 22 | type 'a t = 23 | | All_rows 24 | | From of 'a 25 | | To of 'a 26 | | Between of 'a * 'a 27 | [@@deriving sexp, compare, equal, bin_io, diff ~stable_version:1, stable_witness] 28 | 29 | let map ~f = function 30 | | All_rows -> All_rows 31 | | From a -> From (f a) 32 | | To a -> To (f a) 33 | | Between (a, b) -> Between (f a, f b) 34 | ;; 35 | end 36 | end 37 | 38 | module V1 = struct 39 | type ('k, 'filter, 'order) t = 40 | { filter : 'filter 41 | ; order : 'order 42 | ; key_range : 'k Which_range.V1.t 43 | ; rank_range : Rank.V1.t Which_range.V1.t 44 | } 45 | [@@deriving sexp, equal, bin_io, stable_witness] 46 | 47 | let default ~filter ~order = 48 | { filter; order; key_range = All_rows; rank_range = All_rows } 49 | ;; 50 | end 51 | 52 | module V2 = struct 53 | type ('k, 'filter, 'order) t = 54 | { filter : 'filter 55 | ; order : 'order 56 | ; key_range : 'k Which_range.V1.t 57 | ; rank_range : Rank.V2.t Which_range.V1.t 58 | } 59 | [@@deriving 60 | sexp 61 | , equal 62 | , bin_io 63 | , stable_witness 64 | , stable_record 65 | ~version:[%stable: ('k, 'filter, 'order) V1.t] 66 | ~modify:[ rank_range ]] 67 | 68 | let of_v1 v1 = of_V1_t ~modify_rank_range:(Which_range.V1.map ~f:Rank.V2.of_v1) v1 69 | 70 | let default ~filter ~order = 71 | { filter; order; key_range = All_rows; rank_range = All_rows } 72 | ;; 73 | end 74 | end 75 | 76 | module Rank = Stable.Rank.V2 77 | module Which_range = Stable.Which_range.V1 78 | 79 | type ('k, 'filter, 'order) t = ('k, 'filter, 'order) Stable.V2.t = 80 | { filter : 'filter 81 | ; order : 'order 82 | ; key_range : 'k Which_range.t 83 | ; rank_range : Rank.t Which_range.t 84 | } 85 | [@@deriving equal, sexp_of] 86 | 87 | let default = Stable.V2.default 88 | let of_stable_v1 = Stable.V2.of_v1 89 | -------------------------------------------------------------------------------- /collate/src/collate_params.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Rank : sig 4 | (** Defines an index in the resulting ordered dataset after sorting. The lookup would 5 | start either from the start of the dataset or from the end. Think of [From_end] 6 | indices as using negative indices. *) 7 | type t = 8 | | From_start of int 9 | | From_end of int 10 | [@@deriving sexp, compare, equal, bin_io, hash, diff] 11 | end 12 | 13 | module Which_range : sig 14 | (** Bounds are inclusive at both ends. *) 15 | type 'a t = 16 | | All_rows 17 | | From of 'a 18 | | To of 'a 19 | | Between of 'a * 'a 20 | [@@deriving sexp, compare, equal, bin_io, diff] 21 | 22 | val map : f:('a -> 'b) -> 'a t -> 'b t 23 | end 24 | 25 | type ('k, 'filter, 'order) t = 26 | { filter : 'filter 27 | (** User-defined type, usually algebraic data type, describing how the table can be 28 | filtered. You'll need to provide [equal] and [to_predicate] of type 29 | ['filter -> ('k -> 'v -> bool)] for [collate]. *) 30 | ; order : 'order 31 | (** User-defined type, usually algebraic data type, describing how the table can be 32 | sorted. You'll need to provide [equal] and [to_compare] of type functionally 33 | equivalent to ['order -> ('v -> 'v -> int)] for [collate]. *) 34 | ; key_range : 'k Which_range.t 35 | (** Select only rows between these keys (in the configured ordering) *) 36 | ; rank_range : Rank.t Which_range.t 37 | (** After selecting rows according to [key_range], select rows between these positions. 38 | 39 | For example, if your (sorted & filtered) data is [(A, 1); (B, 2); (C, 3)], then both 40 | for [{key_range = All_rows; rank_range = (From (From_start 1))}] and 41 | [{key_range = From B; rank_range = All_rows}] the result would be [(B, 2); (C, 3)] *) 42 | } 43 | [@@deriving equal, sexp_of] 44 | 45 | val default : filter:'filter -> order:'order -> (_, 'filter, 'order) t 46 | 47 | module Stable : sig 48 | module Rank : sig 49 | module V1 : module type of Int.Stable.V1 50 | 51 | module V2 : sig 52 | type t = Rank.t [@@deriving sexp, bin_io, diff, stable_witness] 53 | end 54 | end 55 | 56 | module Which_range : sig 57 | module V1 : sig 58 | type 'a t = 'a Which_range.t [@@deriving sexp, bin_io, diff, stable_witness] 59 | end 60 | end 61 | 62 | module V1 : sig 63 | type ('k, 'filter, 'order) t = 64 | { filter : 'filter 65 | ; order : 'order 66 | ; key_range : 'k Which_range.V1.t 67 | ; rank_range : Rank.V1.t Which_range.V1.t 68 | } 69 | [@@deriving stable_witness, bin_io, sexp, equal] 70 | 71 | val default : filter:'filter -> order:'order -> (_, 'filter, 'order) t 72 | end 73 | 74 | module V2 : sig 75 | type nonrec ('k, 'filter, 'order) t = ('k, 'filter, 'order) t 76 | [@@deriving stable_witness, bin_io, sexp, equal] 77 | 78 | val of_v1 : ('k, 'filter, 'order) V1.t -> ('k, 'filter, 'order) t 79 | val default : filter:'filter -> order:'order -> (_, 'filter, 'order) t 80 | end 81 | end 82 | 83 | val of_stable_v1 : ('k, 'filter, 'order) Stable.V1.t -> ('k, 'filter, 'order) t 84 | -------------------------------------------------------------------------------- /collate/src/collated.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Which_range = Collate_params.Which_range 3 | 4 | module Parametrized = struct 5 | module Stable = struct 6 | open Stable_witness.Export 7 | 8 | module V1 = struct 9 | type ('k, 'v) t = 10 | { data : ('k * 'v) Opaque_map.Stable.V1.t 11 | ; num_filtered_rows : int 12 | ; key_range : 'k Collate_params.Stable.Which_range.V1.t 13 | (** Ranges that this value was computed for *) 14 | ; rank_range : int Collate_params.Stable.Which_range.V1.t 15 | ; num_before_range : int 16 | ; num_unfiltered_rows : int 17 | } 18 | [@@deriving sexp, bin_io, diff ~stable_version:1, stable_witness] 19 | end 20 | end 21 | 22 | type ('k, 'v) t = ('k, 'v) Stable.V1.t = 23 | { data : ('k * 'v) Opaque_map.t 24 | ; num_filtered_rows : int 25 | ; key_range : 'k Which_range.t (** Ranges that this value was computed for *) 26 | ; rank_range : int Which_range.t 27 | ; num_before_range : int 28 | ; num_unfiltered_rows : int 29 | } 30 | [@@deriving 31 | diff, sexp, compare, fields ~getters ~iterators:(create, fold), equal, bin_io] 32 | 33 | let empty = 34 | { data = Opaque_map.Key.Map.empty 35 | ; num_filtered_rows = 0 36 | ; key_range = All_rows 37 | ; rank_range = All_rows 38 | ; num_before_range = 0 39 | ; num_unfiltered_rows = 0 40 | } 41 | ;; 42 | 43 | let num_after_range { num_before_range; num_filtered_rows; data; _ } = 44 | num_filtered_rows - num_before_range - Map.length data 45 | ;; 46 | 47 | let fold t ~init ~f = Map.fold t.data ~init ~f:(fun ~key:_ ~data acc -> f acc data) 48 | let iter t ~f = Map.iter t.data ~f 49 | let to_alist t = Map.data t.data 50 | let to_opaque_map t = t.data 51 | let first t = Map.min_elt t.data |> Option.map ~f:snd 52 | let last t = Map.max_elt t.data |> Option.map ~f:snd 53 | let mapi t ~f = { t with data = Map.map t.data ~f:(fun (k, v) -> k, f k v) } 54 | let length t = Map.length t.data 55 | 56 | module Private = struct 57 | let create = Fields.create 58 | end 59 | 60 | module For_testing = struct 61 | let of_list 62 | ~num_filtered_rows 63 | ~key_range 64 | ~rank_range 65 | ~num_before_range 66 | ~num_unfiltered_rows 67 | data 68 | = 69 | { data = Opaque_map.of_list data 70 | ; num_filtered_rows 71 | ; rank_range 72 | ; key_range 73 | ; num_before_range 74 | ; num_unfiltered_rows 75 | } 76 | ;; 77 | end 78 | end 79 | 80 | include Parametrized 81 | 82 | module type Concrete = Collated_intf.Concrete with type ('k, 'v) parametrized = ('k, 'v) t 83 | 84 | module Make_concrete 85 | (Key : Collated_intf.Bin_comp_sexp) 86 | (Value : Collated_intf.Bin_comp_sexp) = 87 | struct 88 | module Key = Key 89 | module Value = Value 90 | include Parametrized 91 | 92 | type ('k, 'v) parametrized = ('k, 'v) t 93 | 94 | module T = struct 95 | type t = (Key.t, Value.t) Parametrized.t [@@deriving sexp, bin_io, compare, equal] 96 | 97 | let this_type_does_not_support_ldiffable = () 98 | 99 | (* We have to implement this by hand, as ppx_diff (or Diffable really) 100 | doesn't support parametrized types *) 101 | 102 | module Update = struct 103 | module Map_data = struct 104 | type t = Key.t * Value.t [@@deriving sexp, bin_io, compare, equal] 105 | end 106 | 107 | module Map = Legacy_diffable.Map.Make (Opaque_map.Key) (Map_data) 108 | 109 | module Diff = struct 110 | type t = 111 | | Data of Map.Update.Diff.t 112 | | Num_filtered_rows of int 113 | | Key_range of Key.t Which_range.t 114 | | Rank_range of int Which_range.t 115 | | Elements_prior_to_range of int 116 | | Num_unfiltered_rows of int 117 | [@@deriving sexp, bin_io] 118 | end 119 | 120 | type t = Diff.t list [@@deriving sexp, bin_io] 121 | end 122 | 123 | let update (t : t) (update : Update.t) = 124 | List.fold update ~init:t ~f:(fun acc diff -> 125 | match diff with 126 | | Data map_diff -> { acc with data = Update.Map.update acc.data [ map_diff ] } 127 | | Num_filtered_rows num_filtered_rows -> { acc with num_filtered_rows } 128 | | Key_range key_range -> { acc with key_range } 129 | | Rank_range rank_range -> { acc with rank_range } 130 | | Elements_prior_to_range num_before_range -> { acc with num_before_range } 131 | | Num_unfiltered_rows num_unfiltered_rows -> { acc with num_unfiltered_rows }) 132 | ;; 133 | 134 | let wrap_map_update = List.map ~f:(fun x -> Update.Diff.Data x) 135 | 136 | let diffs ~from ~to_ = 137 | let get = Fieldslib.Field.get in 138 | Fields.fold 139 | ~init:[] 140 | ~data:(fun acc field -> 141 | let from, to_ = get field from, get field to_ in 142 | wrap_map_update (Update.Map.diffs ~from ~to_) @ acc) 143 | ~num_filtered_rows:(fun acc field -> 144 | let from, to_ = get field from, get field to_ in 145 | if Int.equal from to_ then acc else Num_filtered_rows to_ :: acc) 146 | ~key_range:(fun acc field -> 147 | let from, to_ = get field from, get field to_ in 148 | if Which_range.equal Key.equal from to_ then acc else Key_range to_ :: acc) 149 | ~rank_range:(fun acc field -> 150 | let from, to_ = get field from, get field to_ in 151 | if Which_range.equal Int.equal from to_ then acc else Rank_range to_ :: acc) 152 | ~num_before_range:(fun acc field -> 153 | let from, to_ = get field from, get field to_ in 154 | if Int.equal from to_ then acc else Elements_prior_to_range to_ :: acc) 155 | ~num_unfiltered_rows:(fun acc field -> 156 | let from, to_ = get field from, get field to_ in 157 | if Int.equal from to_ then acc else Num_unfiltered_rows to_ :: acc) 158 | ;; 159 | 160 | let to_diffs (t : t) = 161 | let get f = Fieldslib.Field.get f t in 162 | Fields.fold 163 | ~init:[] 164 | ~data:(fun acc field -> wrap_map_update (Update.Map.to_diffs (get field)) @ acc) 165 | ~num_filtered_rows:(fun acc field -> 166 | Update.Diff.Num_filtered_rows (get field) :: acc) 167 | ~key_range:(fun acc field -> Update.Diff.Key_range (get field) :: acc) 168 | ~rank_range:(fun acc field -> Update.Diff.Rank_range (get field) :: acc) 169 | ~num_before_range:(fun acc field -> 170 | Update.Diff.Elements_prior_to_range (get field) :: acc) 171 | ~num_unfiltered_rows:(fun acc field -> 172 | Update.Diff.Num_unfiltered_rows (get field) :: acc) 173 | ;; 174 | 175 | let of_diffs (update : Update.t) = 176 | let data_update = ref [] in 177 | let num_filtered_rows = ref None in 178 | let key_range = ref None in 179 | let rank_range = ref None in 180 | let num_before_range = ref 0 in 181 | let num_unfiltered_rows = ref None in 182 | List.iter update ~f:(function 183 | | Data map_diff -> data_update := map_diff :: !data_update 184 | | Num_filtered_rows n -> num_filtered_rows := Some n 185 | | Key_range r -> key_range := Some r 186 | | Rank_range r -> rank_range := Some r 187 | | Elements_prior_to_range i -> num_before_range := i 188 | | Num_unfiltered_rows n -> num_unfiltered_rows := Some n); 189 | let data = Update.Map.of_diffs !data_update in 190 | let get_exn ref ~name = 191 | Option.value_exn 192 | !ref 193 | ~message:(sprintf "[Collated.of_diffs]: %s missing from diffs list" name) 194 | in 195 | Fields.create 196 | ~data 197 | ~num_filtered_rows:(get_exn num_filtered_rows ~name:"num_filtered_rows") 198 | ~key_range:(get_exn key_range ~name:"key_range") 199 | ~rank_range:(get_exn rank_range ~name:"rank_range") 200 | ~num_before_range:!num_before_range 201 | ~num_unfiltered_rows:(get_exn num_unfiltered_rows ~name:"num_unfiltered_rows") 202 | ;; 203 | end 204 | 205 | include T 206 | include Legacy_diffable.Make_streamable (T) 207 | 208 | let findi_by_key t key = 209 | let found = 210 | Map.filteri ~f:(fun ~key:_pos ~data:(key', _value) -> Key.equal key key') t.data 211 | |> Map.to_alist 212 | in 213 | match found with 214 | | [ x ] -> Some x 215 | | [] -> None 216 | | _ -> 217 | raise_s 218 | [%message "[Collated.findi_by_key] BUG: multiple entries found" (key : Key.t)] 219 | ;; 220 | 221 | let find_by_key t key = 222 | Option.map (findi_by_key t key) ~f:(fun (_pos, (_key, value)) -> value) 223 | ;; 224 | 225 | let prev t key = 226 | let%bind.Option pos, _ = findi_by_key t key in 227 | let%map.Option _pos, res = Map.closest_key t.data `Less_than pos in 228 | res 229 | ;; 230 | 231 | let next t key = 232 | let%bind.Option pos, _ = findi_by_key t key in 233 | let%map.Option _pos, res = Map.closest_key t.data `Greater_than pos in 234 | res 235 | ;; 236 | end 237 | -------------------------------------------------------------------------------- /collate/src/collated.mli: -------------------------------------------------------------------------------- 1 | include Collated_intf.Collated (** @inline *) 2 | -------------------------------------------------------------------------------- /collate/src/collated_intf.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Which_range = Collate_params.Which_range 3 | 4 | module type Parametrized = sig 5 | (** The result of collation - a filtered, sorted and restricted-to-a-range list of keys 6 | and values. The underlying data structure is a bit more sophisticated than a list, 7 | to provide better diffing. 8 | 9 | To get an implementation of [Diffable] interface, you'll need to instantiate 10 | [Make_concrete]. *) 11 | type ('k, 'v) t [@@deriving sexp, bin_io, compare, equal, diff] 12 | 13 | val empty : _ t 14 | val fold : ('k, 'v) t -> init:'accum -> f:('accum -> 'k * 'v -> 'accum) -> 'accum 15 | val iter : ('k, 'v) t -> f:('k * 'v -> unit) -> unit 16 | val to_alist : ('k, 'v) t -> ('k * 'v) list 17 | val to_opaque_map : ('k, 'v) t -> ('k * 'v) Opaque_map.t 18 | val first : ('k, 'v) t -> ('k * 'v) option 19 | val last : ('k, 'v) t -> ('k * 'v) option 20 | val mapi : ('k, 'v1) t -> f:('k -> 'v1 -> 'v2) -> ('k, 'v2) t 21 | val length : _ t -> int 22 | 23 | (** Total number of rows before filtering *) 24 | val num_unfiltered_rows : _ t -> int 25 | 26 | (** Total number of rows after filtering, but before limiting to range. *) 27 | val num_filtered_rows : _ t -> int 28 | 29 | (** Total number of rows that preceed the rank-range and key-range ranges. *) 30 | val num_before_range : _ t -> int 31 | 32 | (** Total number of rows that follow the rank-range and key-range ranges. *) 33 | val num_after_range : _ t -> int 34 | 35 | (** The key range this result was computed for *) 36 | val key_range : ('k, _) t -> 'k Which_range.t 37 | 38 | (** The rank range this result was computed for *) 39 | val rank_range : _ t -> int Which_range.t 40 | 41 | module Stable : sig 42 | module V1 : sig 43 | type nonrec ('k, 'v) t = ('k, 'v) t [@@deriving sexp, bin_io, stable_witness] 44 | 45 | include Diffable.S2 with type ('k, 'v) t := ('k, 'v) t 46 | end 47 | end 48 | 49 | module Private : sig 50 | val create 51 | : data:('k * 'v) Opaque_map.t 52 | -> num_filtered_rows:int 53 | -> key_range:'k Which_range.t 54 | -> rank_range:int Which_range.t 55 | -> num_before_range:int 56 | -> num_unfiltered_rows:int 57 | -> ('k, 'v) t 58 | end 59 | 60 | module For_testing : sig 61 | (** Create Collated.t of a list of data. Note: no collation or checks are performed, 62 | it will contain exactly the data you provided *) 63 | val of_list 64 | : num_filtered_rows:int 65 | -> key_range:'k Which_range.t 66 | -> rank_range:int Which_range.t 67 | -> num_before_range:int 68 | -> num_unfiltered_rows:int 69 | -> ('k * 'v) list 70 | -> ('k, 'v) t 71 | end 72 | end 73 | 74 | module type Bin_comp_sexp = sig 75 | type t [@@deriving bin_io, sexp, compare, equal] 76 | end 77 | 78 | module type Concrete = sig 79 | module Key : Bin_comp_sexp 80 | module Value : Bin_comp_sexp 81 | 82 | type ('k, 'v) parametrized 83 | type t = (Key.t, Value.t) parametrized [@@deriving sexp, bin_io, compare, equal] 84 | 85 | val empty : t 86 | val fold : t -> init:'accum -> f:('accum -> Key.t * Value.t -> 'accum) -> 'accum 87 | val iter : t -> f:(Key.t * Value.t -> unit) -> unit 88 | val to_alist : t -> (Key.t * Value.t) list 89 | val to_opaque_map : t -> (Key.t * Value.t) Opaque_map.t 90 | val first : t -> (Key.t * Value.t) option 91 | val last : t -> (Key.t * Value.t) option 92 | val length : t -> int 93 | val num_filtered_rows : t -> int 94 | val num_unfiltered_rows : t -> int 95 | val key_range : t -> Key.t Which_range.t 96 | val rank_range : t -> int Which_range.t 97 | 98 | include Legacy_diffable.S with type t := t 99 | include Streamable.S with type t := t 100 | 101 | (** This strange value just encodes the fact that this type does not yet implement 102 | [Ldiffable.S]. When it does, delete this and then the compiler will show you places 103 | to update. *) 104 | val this_type_does_not_support_ldiffable : unit 105 | 106 | val find_by_key : t -> Key.t -> Value.t option 107 | val prev : t -> Key.t -> (Key.t * Value.t) option 108 | val next : t -> Key.t -> (Key.t * Value.t) option 109 | end 110 | 111 | module type Collated = sig 112 | include Parametrized 113 | 114 | module type Concrete = Concrete with type ('k, 'v) parametrized = ('k, 'v) t 115 | 116 | module Make_concrete (Key : Bin_comp_sexp) (Value : Bin_comp_sexp) : 117 | Concrete with type Key.t = Key.t and type Value.t = Value.t 118 | end 119 | -------------------------------------------------------------------------------- /collate/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incr_map_collate) 3 | (public_name incr_map.collate) 4 | (libraries core incr_map incremental.memoize incremental legacy_diffable 5 | streamable opaque_map ppx_stable_witness.stable_witness) 6 | (preprocess 7 | (pps ppx_jane ppx_diff.ppx_diff ppx_pattern_bind))) 8 | -------------------------------------------------------------------------------- /collate/src/incr_map_collate.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Collate_params = Collate_params 3 | module Collated = Collated 4 | module Store_params = Incr_memoize.Store_params 5 | 6 | module Compare : sig 7 | (** Note: [Unchanged] and [Reversed] is with respect to ['cmp]. *) 8 | type ('k, 'v, 'cmp) t = 9 | | Unchanged 10 | | Reversed 11 | | Custom_by_value of { compare : 'v -> 'v -> int } 12 | | Custom_by_key_and_value of { compare : 'k * 'v -> 'k * 'v -> int } 13 | (** Partial orders are supported in Custom_by_*, i.e. returning 0 shouldn't cause 14 | issues. Rows will be then sorted by key. *) 15 | [@@deriving sexp_of] 16 | end 17 | 18 | module Fold : sig 19 | type ('k, 'v, 'acc) t 20 | 21 | val create 22 | : ?revert_to_init_when_empty:bool 23 | -> init:'acc 24 | -> add:(key:'k -> data:'v -> 'acc -> 'acc) 25 | -> ?update:(key:'k -> old_data:'v -> new_data:'v -> 'acc -> 'acc) 26 | -> remove:(key:'k -> data:'v -> 'acc -> 'acc) 27 | -> ?finalize:('acc -> 'acc) 28 | -> unit 29 | -> ('k, 'v, 'acc) t 30 | end 31 | 32 | type ('k, 'v, 'fold_result, 'w) t 33 | 34 | (** Perform filtering, sorting and restricting to ranges. 35 | 36 | The [Collate_params.t Incr.t] contains the parameters for filtering and sorting, and 37 | ranges. It can be updated incrementally, but note that filtering & sorting isn't 38 | really incremental on filter & order since we [bind] to these. 39 | 40 | For sorting & filtering, technically all this function should need is a compare 41 | function and a filtering predicate. However, the interface is slightly different: we 42 | require users to provide ['filter] and ['order] opaque types in [Collate_params.t], 43 | and ways to convert them to predicate & compare here. 44 | 45 | It is done this way for better interaction with [Incr]. We believe that most users 46 | would have such types, being simple algebraic data types, anyways. You can always set 47 | e.g. [filter_to_predicate=Fn.id], and just pass the functions directly, but be 48 | prepared to explore the fascinating world of functions' physical equality. *) 49 | val collate 50 | : ?operation_order:[ `Filter_first | `Sort_first ] (** default: `Sort_first *) 51 | -> filter_equal:('filter -> 'filter -> bool) 52 | -> order_equal:('order -> 'order -> bool) 53 | -> filter_to_predicate:('filter -> (key:'k -> data:'v -> bool) option) 54 | -> order_to_compare:('order -> ('k, 'v, 'cmp) Compare.t) 55 | -> (('k, 'v, 'cmp) Map.t, 'w) Incremental.t 56 | -> (('k, 'filter, 'order) Collate_params.t, 'w) Incremental.t 57 | -> ('k, 'v, unit, 'w) t 58 | 59 | val collate_and_fold 60 | : ?operation_order:[ `Filter_first | `Sort_first ] (** default: `Sort_first *) 61 | -> filter_equal:('filter -> 'filter -> bool) 62 | -> order_equal:('order -> 'order -> bool) 63 | -> filter_to_predicate:('filter -> (key:'k -> data:'v -> bool) option) 64 | -> order_to_compare:('order -> ('k, 'v, 'cmp) Compare.t) 65 | -> fold:('k, 'v, 'fold_result) Fold.t 66 | -> (('k, 'v, 'cmp) Map.t, 'w) Incremental.t 67 | -> (('k, 'filter, 'order) Collate_params.t, 'w) Incremental.t 68 | -> ('k, 'v, 'fold_result, 'w) t 69 | 70 | (** Gets the collated data produced by a collation function like [collate]. *) 71 | val collated : ('k, 'v, 'fold_result, 'w) t -> (('k, 'v) Collated.t, 'w) Incremental.t 72 | 73 | (** A function for finding the index into the collated map of a particular key. The 74 | resulting index is "pre-range-restriction", which means that even if the key is not in 75 | the collation range, [key_rank] can still respond with its index. However, the index 76 | is after filtering and ordering, which means that if it is filtered out of the map (or 77 | isn't in the original map), then the result will be [None]. *) 78 | val key_rank : ('k, 'v, 'fold_result, 'w) t -> ('k -> int option, 'w) Incremental.t 79 | 80 | val fold_result : ('k, 'v, 'fold_result, 'w) t -> ('fold_result, 'w) Incremental.t 81 | 82 | module With_caching : sig 83 | (** A version of [collate] with caching. 84 | 85 | We use [Incr_memoize] to cache incremental nodes for the result of a particular: 86 | 87 | - [order], 88 | - [(order, filter)], and 89 | - [(order, filter, range_bucket)] 90 | 91 | so that even if the [Collate_params.t Incr.t] changes, as long as it changes back 92 | before the result is evicted from the cache, we can resume a cached incremental 93 | computation instead of discarding it and computing it from scratch. 94 | 95 | Note that if an earlier incremental node is evicted from its cache, its children in 96 | subsequent caches are no longer used. This is to ensure we don't duplicate 97 | computations from building later nodes on top of semantically identical but 98 | physically distinct earlier nodes. 99 | 100 | For example, if the [order] cache is LRU with size 2, and [order_filter_range] is 101 | LRU with size 10, you could get 10 cached final values if they only use two distinct 102 | orderings, but if they were to each have a distinct ordering, only two will be 103 | usable. *) 104 | 105 | module Range_memoize_bucket : sig 106 | type t [@@deriving sexp_of, equal, hash, compare] 107 | 108 | include Comparable.S_plain with type t := t 109 | end 110 | 111 | val collate__sort_first 112 | : filter_equal:('filter -> 'filter -> bool) 113 | -> order_equal:('order -> 'order -> bool) 114 | -> ?order_cache_params:'order Store_params.t (** default: alist of size 10 *) 115 | -> ?order_filter_cache_params:('order * 'filter) Store_params.t 116 | (** default: alist of size 30 *) 117 | -> ?order_filter_range_cache_params: 118 | ('order * 'filter * Range_memoize_bucket.t) Store_params.t 119 | (** default: alist of size 50 *) 120 | -> ?range_memoize_bucket_size:int 121 | -> filter_to_predicate:('filter -> (key:'k -> data:'v -> bool) option) 122 | -> order_to_compare:('order -> ('k, 'v, 'cmp) Compare.t) 123 | -> (('k, 'v, 'cmp) Map.t, 'w) Incremental.t 124 | -> (('k, 'filter, 'order) Collate_params.t, 'w) Incremental.t 125 | -> ('k, 'v, unit, 'w) t 126 | 127 | (** Like [collate__sort_first], but also gives an opportunity to perform a fold over the 128 | post-filtered, pre-range-restricted data. *) 129 | val collate_and_fold__sort_first 130 | : filter_equal:('filter -> 'filter -> bool) 131 | -> order_equal:('order -> 'order -> bool) 132 | -> ?order_cache_params:'order Store_params.t (** default: alist of size 10 *) 133 | -> ?order_filter_cache_params:('order * 'filter) Store_params.t 134 | (** default: alist of size 30 *) 135 | -> ?order_filter_range_cache_params: 136 | ('order * 'filter * Range_memoize_bucket.t) Store_params.t 137 | (** default: alist of size 50 *) 138 | -> ?range_memoize_bucket_size:int 139 | -> filter_to_predicate:('filter -> (key:'k -> data:'v -> bool) option) 140 | -> order_to_compare:('order -> ('k, 'v, 'cmp) Compare.t) 141 | -> fold:('k, 'v, 'fold_result) Fold.t 142 | -> (('k, 'v, 'cmp) Map.t, 'w) Incremental.t 143 | -> (('k, 'filter, 'order) Collate_params.t, 'w) Incremental.t 144 | -> ('k, 'v, 'fold_result, 'w) t 145 | end 146 | -------------------------------------------------------------------------------- /collate/test/bench/bench.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Measurement = struct 4 | type t = 5 | { time : Time_ns.Span.t 6 | ; words : int 7 | } 8 | [@@deriving fields ~getters] 9 | 10 | let to_string ({ time; words } : t) = sprintf !"t=%{Time_ns.Span}, mem=%d Wd" time words 11 | end 12 | 13 | let measure thunk = 14 | let start = Time_ns.now () in 15 | let start_mem = Gc.major_plus_minor_words () in 16 | let res = thunk () in 17 | ( res 18 | , Measurement. 19 | { time = Time_ns.diff (Time_ns.now ()) start 20 | ; words = Gc.major_plus_minor_words () - start_mem 21 | } ) 22 | ;; 23 | 24 | let report ~name meas = printf !"%s: %{Measurement}\n%!" name meas 25 | 26 | module type Reportable = sig 27 | type t [@@deriving compare] 28 | 29 | val to_string : t -> string 30 | 31 | include Container.Summable with type t := t 32 | 33 | val scale : t -> float -> t 34 | end 35 | 36 | let report_results ~verbose (results : Measurement.t list) = 37 | let calculate_and_report 38 | (type a) 39 | ~name 40 | (results : a list) 41 | (module M : Reportable with type t = a) 42 | = 43 | let len = List.length results in 44 | let sum = List.sum (module M) ~f:Fn.id results in 45 | let sorted = List.sort results ~compare:M.compare in 46 | let p pct = 47 | let pos = float (len - 1) *. pct |> Int.of_float in 48 | List.nth_exn sorted pos 49 | in 50 | let min, p25, p50, p75, max = p 0., p 0.25, p 0.5, p 0.75, p 1. in 51 | let avg = M.scale sum (1. /. float len) in 52 | printf 53 | !"%s: min=%{M}, 25%%=%{M} 50%%=%{M}, avg=%{M}, 75%%=%{M}, max=%{M}\n" 54 | name 55 | min 56 | p25 57 | p50 58 | avg 59 | p75 60 | max 61 | in 62 | let len = List.length results in 63 | let times, mems = 64 | List.map ~f:(fun { time; words } -> time, words) results |> List.unzip 65 | in 66 | let total_time = List.sum (module Time_ns.Span) ~f:Fn.id times in 67 | if verbose then printf !"Results: %d runs in %{Time_ns.Span}\n" len total_time; 68 | calculate_and_report ~name:"Time" times (module Time_ns.Span); 69 | if verbose 70 | then 71 | calculate_and_report 72 | ~name:"Mem " 73 | mems 74 | (module struct 75 | include Int 76 | 77 | let scale i f = to_float i *. f |> of_float 78 | end) 79 | ;; 80 | 81 | let run ~verbose ~name ~init_f = 82 | if verbose then printf "\n=== %s ===\n%!" name else printf "%s:\n%!" name; 83 | let report ~name res = if verbose then report ~name res else () in 84 | let quota = Time_ns.Span.of_int_sec 1 in 85 | let thunk, init_res = measure init_f in 86 | report ~name:"Initialize" init_res; 87 | let (), gc_res = measure Gc.compact in 88 | report ~name:"Compact" gc_res; 89 | let (), res1 = measure (unstage thunk) in 90 | report ~name:"First run" res1; 91 | let results = ref [ res1 ] in 92 | let elapsed = ref (Measurement.time res1) in 93 | while Time_ns.Span.( < ) elapsed.contents quota do 94 | let res = measure (unstage thunk) |> snd in 95 | results := res :: !results; 96 | elapsed := Time_ns.Span.( + ) (Measurement.time res) !elapsed 97 | done; 98 | report_results ~verbose !results 99 | ;; 100 | -------------------------------------------------------------------------------- /collate/test/bench/bench.mli: -------------------------------------------------------------------------------- 1 | (* Simple benchmarking library. *) 2 | 3 | (*_ Why didn't I use inline_benchmarks you might ask? Clearly a benchmarking suite would 4 | be better for benchmarking? Well, no. It reported totally nonsensical results, including 5 | negative number of words allocated and 1_000_000x time difference on benchmarks that 6 | actually took the same amount of time. Well, apparently fitting a line to results helps 7 | only with some kinds of noise, and actually amplifies others. *) 8 | 9 | open Core 10 | 11 | val run : verbose:bool -> name:string -> init_f:(unit -> (unit -> unit) Staged.t) -> unit 12 | -------------------------------------------------------------------------------- /collate/test/bench/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names incr_map_collate_bench) 4 | (libraries core_unix.command_unix core incr_map_collate incr_map_test 5 | incremental) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /collate/test/bench/incr_map_collate_bench.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /collate/test/collate_and_fold_tests.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/incr_map/96296a99a98f9f3ee873533e5c507208c7372908/collate/test/collate_and_fold_tests.mli -------------------------------------------------------------------------------- /collate/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incr_map_collate_test) 3 | (libraries expectable incr_map_collate core expect_test_helpers_core 4 | incremental.memoize incremental) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /collate/test/key_and_range_tests.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Incr = Incremental.Make () 3 | open Incr_map_collate 4 | module Concrete = Collated.Make_concrete (String) (Int) 5 | module Order = Unit 6 | module Filter = Unit 7 | 8 | type t = 9 | { map : int String.Map.t Incr.Var.t 10 | ; collate : (string, unit, unit) Collate_params.t Incr.Var.t 11 | ; observer : Concrete.t Incr.Observer.t 12 | } 13 | 14 | let set_collate ?rank_range ?key_range t = 15 | let collate = Incr.Var.value t.collate in 16 | let collate = 17 | { Collate_params.filter = () 18 | ; key_range = Option.value key_range ~default:collate.key_range 19 | ; rank_range = Option.value rank_range ~default:collate.rank_range 20 | ; order = () 21 | } 22 | in 23 | Incr.Var.set t.collate collate 24 | ;; 25 | 26 | let do_collate input collate = 27 | Incr_map_collate.collate 28 | ~filter_to_predicate:(fun () -> None) 29 | ~order_to_compare:(fun () -> Compare.Unchanged) 30 | ~filter_equal:Filter.equal 31 | ~order_equal:Order.equal 32 | input 33 | collate 34 | ;; 35 | 36 | let init ~key_range ~rank_range map = 37 | let map = Incr.Var.create map in 38 | let collate = 39 | Incr.Var.create { Collate_params.filter = (); order = (); key_range; rank_range } 40 | in 41 | let observer = 42 | do_collate (Incr.Var.watch map) (Incr.Var.watch collate) 43 | |> Incr_map_collate.collated 44 | |> Incr.observe 45 | in 46 | Incr.Observer.on_update_exn observer ~f:(function 47 | | Invalidated -> () 48 | | Initialized result | Changed (_, result) -> 49 | result |> Collated.to_alist |> Expectable.print_alist [%sexp_of: int]); 50 | { map; collate; observer } 51 | ;; 52 | 53 | let%expect_test "key range followed by rank range (forewards)" = 54 | let map = 55 | String.Map.of_alist_exn [ "a", 1; "b", 2; "c", 3; "d", 4; "e", 5; "f", 6; "g", 7 ] 56 | in 57 | let t = init ~key_range:All_rows ~rank_range:All_rows map in 58 | Incr.stabilize (); 59 | [%expect 60 | {| 61 | ┌┬┬┬┬┬┬┬┐ 62 | ├┴┴┴┼┴┴┴┤ 63 | │ a │ 1 │ 64 | │ b │ 2 │ 65 | │ c │ 3 │ 66 | │ d │ 4 │ 67 | │ e │ 5 │ 68 | │ f │ 6 │ 69 | │ g │ 7 │ 70 | └───┴───┘ 71 | |}]; 72 | set_collate ~key_range:(From "c") t; 73 | Incr.stabilize (); 74 | [%expect 75 | {| 76 | ┌┬┬┬┬┬┬┬┐ 77 | ├┴┴┴┼┴┴┴┤ 78 | │ c │ 3 │ 79 | │ d │ 4 │ 80 | │ e │ 5 │ 81 | │ f │ 6 │ 82 | │ g │ 7 │ 83 | └───┴───┘ 84 | |}]; 85 | set_collate ~rank_range:(From (From_start 2)) t; 86 | Incr.stabilize (); 87 | [%expect 88 | {| 89 | ┌┬┬┬┬┬┬┬┐ 90 | ├┴┴┴┼┴┴┴┤ 91 | │ e │ 5 │ 92 | │ f │ 6 │ 93 | │ g │ 7 │ 94 | └───┴───┘ 95 | |}] 96 | ;; 97 | 98 | let%expect_test "key range followed by rank range (backwards)" = 99 | let map = 100 | String.Map.of_alist_exn [ "a", 1; "b", 2; "c", 3; "d", 4; "e", 5; "f", 6; "g", 7 ] 101 | in 102 | let t = init ~key_range:All_rows ~rank_range:All_rows map in 103 | Incr.stabilize (); 104 | [%expect 105 | {| 106 | ┌┬┬┬┬┬┬┬┐ 107 | ├┴┴┴┼┴┴┴┤ 108 | │ a │ 1 │ 109 | │ b │ 2 │ 110 | │ c │ 3 │ 111 | │ d │ 4 │ 112 | │ e │ 5 │ 113 | │ f │ 6 │ 114 | │ g │ 7 │ 115 | └───┴───┘ 116 | |}]; 117 | set_collate ~key_range:(To "e") t; 118 | Incr.stabilize (); 119 | [%expect 120 | {| 121 | ┌┬┬┬┬┬┬┬┐ 122 | ├┴┴┴┼┴┴┴┤ 123 | │ a │ 1 │ 124 | │ b │ 2 │ 125 | │ c │ 3 │ 126 | │ d │ 4 │ 127 | │ e │ 5 │ 128 | └───┴───┘ 129 | |}]; 130 | set_collate ~rank_range:(To (From_end 2)) t; 131 | Incr.stabilize (); 132 | [%expect 133 | {| 134 | ┌┬┬┬┬┬┬┬┐ 135 | ├┴┴┴┼┴┴┴┤ 136 | │ a │ 1 │ 137 | │ b │ 2 │ 138 | │ c │ 3 │ 139 | └───┴───┘ 140 | |}] 141 | ;; 142 | -------------------------------------------------------------------------------- /collate/test/key_and_range_tests.mli: -------------------------------------------------------------------------------- 1 | (* intentionally blank *) 2 | -------------------------------------------------------------------------------- /collate/test/key_rank_tests.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Expect_test_helpers_core 3 | module Incr = Incremental.Make () 4 | 5 | let%expect_test _ = 6 | let data_var = 7 | Incr.Var.create (Int.Map.of_alist_exn (List.init 10 ~f:(fun i -> i, i))) 8 | in 9 | let collate_var = 10 | Incr.Var.create 11 | { Incr_map_collate.Collate_params.filter = (fun ~key:_ ~data:_ -> true) 12 | ; order = Incr_map_collate.Compare.Unchanged 13 | ; key_range = All_rows 14 | ; rank_range = All_rows 15 | } 16 | in 17 | let t = 18 | Incr_map_collate.collate 19 | ~filter_equal:phys_equal 20 | ~order_equal:phys_equal 21 | ~filter_to_predicate:(fun f -> Some f) 22 | ~order_to_compare:Fn.id 23 | (Incr.Var.watch data_var) 24 | (Incr.Var.watch collate_var) 25 | in 26 | let collated_observer = Incr.observe (Incr_map_collate.collated t) in 27 | let key_rank_observer = Incr.observe (Incr_map_collate.key_rank t) in 28 | let stabilize_and_show () = 29 | Incr.stabilize (); 30 | let collated = Incr.Observer.value_exn collated_observer in 31 | let key_rank = Incr.Observer.value_exn key_rank_observer in 32 | let data_with_key_rank = 33 | Map.mapi (Incr.Var.value data_var) ~f:(fun ~key ~data -> data, key_rank key) 34 | in 35 | print_s 36 | [%message 37 | (collated : (int, int) Incr_map_collate.Collated.t) 38 | (data_with_key_rank : (int * int option) Int.Map.t)] 39 | in 40 | stabilize_and_show (); 41 | [%expect 42 | {| 43 | ((collated ( 44 | (data ( 45 | (0 (0 0)) 46 | (100 (1 1)) 47 | (200 (2 2)) 48 | (300 (3 3)) 49 | (400 (4 4)) 50 | (500 (5 5)) 51 | (600 (6 6)) 52 | (700 (7 7)) 53 | (800 (8 8)) 54 | (900 (9 9)))) 55 | (num_filtered_rows 10) 56 | (key_range All_rows) 57 | (rank_range All_rows) 58 | (num_before_range 0) 59 | (num_unfiltered_rows 10))) 60 | (data_with_key_rank ( 61 | (0 (0 (0))) 62 | (1 (1 (1))) 63 | (2 (2 (2))) 64 | (3 (3 (3))) 65 | (4 (4 (4))) 66 | (5 (5 (5))) 67 | (6 (6 (6))) 68 | (7 (7 (7))) 69 | (8 (8 (8))) 70 | (9 (9 (9)))))) 71 | |}]; 72 | Incr.Var.set 73 | collate_var 74 | { Incr_map_collate.Collate_params.filter = (fun ~key:_ ~data:_ -> true) 75 | ; order = Custom_by_value { compare = Comparable.reverse Int.compare } 76 | ; key_range = All_rows 77 | ; rank_range = All_rows 78 | }; 79 | stabilize_and_show (); 80 | [%expect 81 | {| 82 | ((collated ( 83 | (data ( 84 | (0 (9 9)) 85 | (100 (8 8)) 86 | (200 (7 7)) 87 | (300 (6 6)) 88 | (400 (5 5)) 89 | (500 (4 4)) 90 | (600 (3 3)) 91 | (700 (2 2)) 92 | (800 (1 1)) 93 | (900 (0 0)))) 94 | (num_filtered_rows 10) 95 | (key_range All_rows) 96 | (rank_range All_rows) 97 | (num_before_range 0) 98 | (num_unfiltered_rows 10))) 99 | (data_with_key_rank ( 100 | (0 (0 (9))) 101 | (1 (1 (8))) 102 | (2 (2 (7))) 103 | (3 (3 (6))) 104 | (4 (4 (5))) 105 | (5 (5 (4))) 106 | (6 (6 (3))) 107 | (7 (7 (2))) 108 | (8 (8 (1))) 109 | (9 (9 (0)))))) 110 | |}]; 111 | Incr.Var.set 112 | collate_var 113 | { Incr_map_collate.Collate_params.filter = (fun ~key:_ ~data:_ -> true) 114 | ; order = Custom_by_value { compare = Comparable.reverse Int.compare } 115 | ; key_range = Between (3, 6) 116 | ; rank_range = All_rows 117 | }; 118 | stabilize_and_show (); 119 | [%expect 120 | {| 121 | ((collated ( 122 | (data ()) 123 | (num_filtered_rows 10) 124 | (key_range (Between 3 6)) 125 | (rank_range All_rows) 126 | (num_before_range 6) 127 | (num_unfiltered_rows 10))) 128 | (data_with_key_rank ( 129 | (0 (0 (9))) 130 | (1 (1 (8))) 131 | (2 (2 (7))) 132 | (3 (3 (6))) 133 | (4 (4 (5))) 134 | (5 (5 (4))) 135 | (6 (6 (3))) 136 | (7 (7 (2))) 137 | (8 (8 (1))) 138 | (9 (9 (0)))))) 139 | |}]; 140 | Incr.Var.set 141 | collate_var 142 | { Incr_map_collate.Collate_params.filter = (fun ~key:_ ~data:_ -> true) 143 | ; order = Custom_by_value { compare = Comparable.reverse Int.compare } 144 | ; key_range = All_rows 145 | ; rank_range = Between (From_start 3, From_start 6) 146 | }; 147 | stabilize_and_show (); 148 | [%expect 149 | {| 150 | ((collated ( 151 | (data ( 152 | (0 (6 6)) 153 | (100 (5 5)) 154 | (200 (4 4)) 155 | (300 (3 3)))) 156 | (num_filtered_rows 10) 157 | (key_range All_rows) 158 | (rank_range (Between 3 6)) 159 | (num_before_range 3) 160 | (num_unfiltered_rows 10))) 161 | (data_with_key_rank ( 162 | (0 (0 (9))) 163 | (1 (1 (8))) 164 | (2 (2 (7))) 165 | (3 (3 (6))) 166 | (4 (4 (5))) 167 | (5 (5 (4))) 168 | (6 (6 (3))) 169 | (7 (7 (2))) 170 | (8 (8 (1))) 171 | (9 (9 (0)))))) 172 | |}]; 173 | Incr.Var.set 174 | collate_var 175 | { Incr_map_collate.Collate_params.filter = (fun ~key:_ ~data:_ -> true) 176 | ; order = Custom_by_value { compare = Comparable.reverse Int.compare } 177 | ; key_range = All_rows 178 | ; rank_range = Between (From_end 3, From_end 1) 179 | }; 180 | stabilize_and_show (); 181 | [%expect 182 | {| 183 | ((collated ( 184 | (data ( 185 | (0 (3 3)) 186 | (100 (2 2)) 187 | (200 (1 1)))) 188 | (num_filtered_rows 10) 189 | (key_range All_rows) 190 | (rank_range (Between 6 8)) 191 | (num_before_range 6) 192 | (num_unfiltered_rows 10))) 193 | (data_with_key_rank ( 194 | (0 (0 (9))) 195 | (1 (1 (8))) 196 | (2 (2 (7))) 197 | (3 (3 (6))) 198 | (4 (4 (5))) 199 | (5 (5 (4))) 200 | (6 (6 (3))) 201 | (7 (7 (2))) 202 | (8 (8 (1))) 203 | (9 (9 (0)))))) 204 | |}]; 205 | Incr.Var.set 206 | collate_var 207 | { Incr_map_collate.Collate_params.filter = (fun ~key:_ ~data -> data % 2 = 0) 208 | ; order = Custom_by_value { compare = Comparable.reverse Int.compare } 209 | ; key_range = All_rows 210 | ; rank_range = All_rows 211 | }; 212 | stabilize_and_show (); 213 | [%expect 214 | {| 215 | ((collated ( 216 | (data ( 217 | (0 (8 8)) 218 | (100 (6 6)) 219 | (200 (4 4)) 220 | (300 (2 2)) 221 | (400 (0 0)))) 222 | (num_filtered_rows 5) 223 | (key_range All_rows) 224 | (rank_range All_rows) 225 | (num_before_range 0) 226 | (num_unfiltered_rows 10))) 227 | (data_with_key_rank ( 228 | (0 (0 (4))) 229 | (1 (1 ())) 230 | (2 (2 (3))) 231 | (3 (3 ())) 232 | (4 (4 (2))) 233 | (5 (5 ())) 234 | (6 (6 (1))) 235 | (7 (7 ())) 236 | (8 (8 (0))) 237 | (9 (9 ()))))) 238 | |}] 239 | ;; 240 | -------------------------------------------------------------------------------- /collate/test/key_rank_tests.mli: -------------------------------------------------------------------------------- 1 | (*_ Intentionally left empty. *) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /erase_key/README.md: -------------------------------------------------------------------------------- 1 | # Opaque_map 2 | 3 | A small library for type-erasing the key from a map without introducing an 4 | existential type. 5 | 6 | -------------------------------------------------------------------------------- /erase_key/dune: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/incr_map/96296a99a98f9f3ee873533e5c507208c7372908/erase_key/dune -------------------------------------------------------------------------------- /erase_key/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name opaque_map) 3 | (public_name incr_map.erase_key) 4 | (preprocess 5 | (pps ppx_pattern_bind ppx_jane ppx_diff.ppx_diff)) 6 | (libraries core bignum.bigint bignum incr_map incremental)) 7 | -------------------------------------------------------------------------------- /erase_key/src/opaque_map.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Incremental.Let_syntax 3 | 4 | module Key = struct 5 | include Bignum 6 | include Bignum.Unstable 7 | 8 | let to_string s = 9 | (* It's important that different numbers serialize to different strings, 10 | since the partial render table uses the serialization as a virtual-dom 11 | key in a context which requires that all the keys be unique. Thus, we 12 | use [to_string_accurate] to ensure no loss of precision. *) 13 | to_string_accurate s 14 | ;; 15 | 16 | module Stable = struct 17 | module V1 = Bignum.Stable.V3 18 | end 19 | end 20 | 21 | type 'a t = 'a Map.M(Key).t [@@deriving sexp, compare, equal, bin_io] 22 | 23 | module Stable = struct 24 | module V1 = struct 25 | include Comparable.Stable.V1.With_stable_witness.Make (struct 26 | type t = Bignum.Stable.V3.t [@@deriving bin_io, sexp, compare, stable_witness] 27 | type comparator_witness = Bignum.comparator_witness 28 | 29 | let comparator = Bignum.comparator 30 | end) 31 | 32 | type 'a t = 'a Map.t [@@deriving sexp, bin_io, diff ~stable_version:1, stable_witness] 33 | end 34 | end 35 | 36 | module Diff = Stable.V1.Diff 37 | 38 | let with_comparator x f = 39 | Incremental.bind (Incremental.freeze (Incremental.map x ~f:Map.comparator_s)) ~f 40 | ;; 41 | 42 | let nearest map k = 43 | ( Map.closest_key map `Less_than k |> Option.map ~f:snd 44 | , Map.closest_key map `Greater_than k |> Option.map ~f:snd ) 45 | ;; 46 | 47 | let ( + ) = Bignum.( + ) 48 | let ( - ) = Bignum.( - ) 49 | let ( / ) = Bignum.( / ) 50 | let ( < ) = Bignum.( < ) 51 | let ( > ) = Bignum.( > ) 52 | let zero = Bignum.zero 53 | let two = Bignum.one + Bignum.one 54 | let denom_rebalance_cutoff = Bigint.of_int 100_000_000 55 | let separation = Bignum.of_int 100 56 | 57 | let erase_key_incrementally 58 | (type key data res cmp) 59 | ?data_equal 60 | (map : ((key, data, cmp) Map.t, 'w) Incremental.t) 61 | ~(get : key:key -> data:data -> res) 62 | : (res t, 'incr_witness) Incremental.t 63 | = 64 | let module Acc = struct 65 | type t = 66 | { key_to_bignum : (key, Bignum.t, cmp) Map.t 67 | ; out : res Bignum.Map.t 68 | ; comparator : (key, cmp) Comparator.Module.t 69 | ; additions : (key * data) list 70 | ; removals : key list 71 | ; rebalance_necessary : bool 72 | } 73 | 74 | let empty cmp = 75 | { key_to_bignum = Map.empty cmp 76 | ; out = Bignum.Map.empty 77 | ; comparator = cmp 78 | ; additions = [] 79 | ; removals = [] 80 | ; rebalance_necessary = false 81 | } 82 | ;; 83 | 84 | let of_maps cmp ~key_to_bignum ~out = 85 | { key_to_bignum 86 | ; out 87 | ; comparator = cmp 88 | ; additions = [] 89 | ; removals = [] 90 | ; rebalance_necessary = false 91 | } 92 | ;; 93 | 94 | let add ~key ~data ({ key_to_bignum; out; _ } as t) = 95 | let bignum = 96 | match nearest key_to_bignum key with 97 | | None, None -> zero 98 | | None, Some lowest -> 99 | (* Round to a nearby integer so that we don't retain the 100 | potentially large fractional part of the lowest key. 101 | We assume that [separation > 1] so that we don't round to a 102 | number greater than [lowest]. *) 103 | Bignum.truncate (lowest - separation) 104 | | Some highest, None -> Bignum.truncate (highest + separation) 105 | | Some low, Some high -> 106 | let precise = (low + high) / two in 107 | let truncated = Bignum.truncate precise in 108 | if truncated > low && truncated < high then truncated else precise 109 | in 110 | let rebalance_necessary = 111 | t.rebalance_necessary 112 | || Bigint.(Bignum.den_as_bigint bignum > denom_rebalance_cutoff) 113 | in 114 | let key_to_bignum = Map.add_exn key_to_bignum ~key ~data:bignum in 115 | let out = Map.add_exn out ~key:bignum ~data:(get ~key ~data) in 116 | { t with key_to_bignum; out; rebalance_necessary } 117 | ;; 118 | 119 | let remove ~key ({ key_to_bignum; out; _ } as t) = 120 | let bignum = Map.find_exn key_to_bignum key in 121 | let key_to_bignum = Map.remove key_to_bignum key in 122 | let out = Map.remove out bignum in 123 | { t with key_to_bignum; out } 124 | ;; 125 | 126 | let update ~key ~data ({ key_to_bignum; out; _ } as t) = 127 | let bignum = Map.find_exn key_to_bignum key in 128 | let out = Map.set out ~key:bignum ~data:(get ~key ~data) in 129 | { t with key_to_bignum; out } 130 | ;; 131 | 132 | let add_all l acc = 133 | List.fold l ~init:acc ~f:(fun acc (key, data) -> add ~key ~data acc) 134 | ;; 135 | 136 | let process_removals_and_additions 137 | (module M : Comparator.S with type comparator_witness = cmp and type t = key) 138 | acc 139 | = 140 | let acc = List.fold acc.removals ~init:acc ~f:(fun acc key -> remove ~key acc) in 141 | let acc = 142 | let lower_than_lowest, rest = 143 | match Map.min_elt acc.key_to_bignum with 144 | | None -> [], acc.additions 145 | | Some (lowest, _) -> 146 | List.partition_tf acc.additions ~f:(fun (a, _) -> 147 | Int.((Comparator.compare M.comparator) a lowest < 0)) 148 | in 149 | acc |> add_all lower_than_lowest |> add_all (List.rev rest) 150 | in 151 | { acc with removals = []; additions = [] } 152 | ;; 153 | 154 | let rebalance acc = 155 | let fresh = empty acc.comparator in 156 | let i = ref zero in 157 | let init = fresh.key_to_bignum, fresh.out in 158 | let key_to_bignum, out = 159 | Map.fold 160 | acc.key_to_bignum 161 | ~init 162 | ~f:(fun ~key ~data:prev_bignum (key_to_bignum, out) -> 163 | let prev_res = Map.find_exn acc.out prev_bignum in 164 | let k = !i in 165 | i := k + separation; 166 | Map.add_exn key_to_bignum ~key ~data:k, Map.add_exn out ~key:k ~data:prev_res) 167 | in 168 | of_maps acc.comparator ~key_to_bignum ~out 169 | ;; 170 | 171 | let finalize cmp acc = 172 | let acc = process_removals_and_additions cmp acc in 173 | if acc.rebalance_necessary then rebalance acc else acc 174 | ;; 175 | end 176 | in 177 | let%pattern_bind { Acc.out; _ } = 178 | with_comparator map (fun cmp -> 179 | Incr_map.unordered_fold 180 | ?data_equal 181 | ~init:(Acc.empty cmp) 182 | ~specialized_initial:(fun ~init data -> 183 | let i = ref zero in 184 | let init = init.key_to_bignum, init.out in 185 | let key_to_bignum, out = 186 | Map.fold data ~init ~f:(fun ~key ~data (key_to_bignum, out) -> 187 | let k = !i in 188 | i := k + separation; 189 | ( Map.add_exn key_to_bignum ~key ~data:k 190 | , Map.add_exn out ~key:k ~data:(get ~key ~data) )) 191 | in 192 | Acc.of_maps cmp ~key_to_bignum ~out) 193 | ~add:(fun ~key ~data acc -> { acc with additions = (key, data) :: acc.additions }) 194 | ~remove:(fun ~key ~data:_ acc -> { acc with removals = key :: acc.removals }) 195 | ~update:(fun ~key ~old_data:_ ~new_data:data acc -> Acc.update ~key ~data acc) 196 | ~finalize:(Acc.finalize cmp) 197 | map) 198 | in 199 | out 200 | ;; 201 | 202 | let empty = Bignum.Map.empty 203 | let of_list xs = Bignum.Map.of_alist_exn (List.mapi xs ~f:(fun i x -> Bignum.of_int i, x)) 204 | 205 | let of_array arr = 206 | Bignum.Map.of_sorted_array_unchecked (Array.mapi arr ~f:(fun i x -> Bignum.of_int i, x)) 207 | ;; 208 | -------------------------------------------------------------------------------- /erase_key/src/opaque_map.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Key : sig 4 | type t [@@deriving sexp, bin_io] 5 | 6 | include Comparable.S with type t := t 7 | 8 | val to_string : t -> string 9 | val zero : t 10 | 11 | module Stable : sig 12 | module V1 : sig 13 | type nonrec t = t [@@deriving bin_io, compare, equal, hash, sexp, stable_witness] 14 | end 15 | end 16 | end 17 | 18 | type 'a t = (Key.t, 'a, Key.comparator_witness) Map.t 19 | [@@deriving sexp, compare, equal, bin_io] 20 | 21 | include Diffable.S1 with type 'a t := 'a t 22 | 23 | (** When Opaque_maps are created incrementally we can be smart about insertion and get 24 | good performance around insertion and rebalancing. *) 25 | val erase_key_incrementally 26 | : ?data_equal:('data -> 'data -> bool) 27 | -> (('key, 'data, _) Map.t, 'w) Incremental.t 28 | -> get:(key:'key -> data:'data -> 'a) 29 | (** Make the result value from the key & data of the original map. Most of the time 30 | you just want [fun ~key ~data -> (key,data)], but the presence of this argument 31 | effectively lets you fuse a [mapi] operation into this one *) 32 | -> ('a t, 'w) Incremental.t 33 | 34 | (** [empty], [of_list], and [of_array] won't give you nice incrementality like 35 | [erase_key_incrementally], but they are still fine if the primary goal is using the 36 | type itself outside of an incremental context. 37 | 38 | But if possible, consider [erase_key_incrementally]. *) 39 | 40 | val empty : _ t 41 | val of_list : 'a list -> 'a t 42 | val of_array : 'a array -> 'a t 43 | 44 | module Stable : sig 45 | module V1 : sig 46 | type nonrec 'a t = 'a t [@@deriving sexp, bin_io, diff, stable_witness] 47 | end 48 | end 49 | -------------------------------------------------------------------------------- /erase_key/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name opaque_map_test) 3 | (libraries bignum core expect_test_helpers_core.expect_test_helpers_base 4 | expect_test_helpers_core incr_map_test opaque_map) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /erase_key/test/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | include Expect_test_helpers_core 3 | include Opaque_map 4 | -------------------------------------------------------------------------------- /erase_key/test/opaque_map_test.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Incr = Incr_map_test.Import.Incr 3 | module U = Incr_map_test.Rand_map_helper 4 | 5 | module Out = struct 6 | type t = (int * float) list [@@deriving compare, sexp, equal] 7 | end 8 | 9 | let check_invariants input_map derived_map = 10 | let input_list = Map.to_alist input_map in 11 | let derived_list = Map.data derived_map in 12 | Expect_test_helpers_base.require_compare_equal (module Out) input_list derived_list; 13 | assert ([%equal: Out.t] input_list derived_list); 14 | let (_ : _ String.Map.t) = 15 | (* The keys of the derived map should serialized to unique values. If that 16 | is not the case, then [of_alist_exn] will raise. *) 17 | Map.to_alist derived_map 18 | |> List.map ~f:(fun (key, data) -> Opaque_map.Key.to_string key, data) 19 | |> String.Map.of_alist_exn 20 | in 21 | () 22 | ;; 23 | 24 | let run_test ~size_of_initial_map ~iterations = 25 | let input_map = Incr.Var.create (U.init_rand_map ~from:0 ~to_:size_of_initial_map) in 26 | let derived_map = 27 | Opaque_map.erase_key_incrementally 28 | ~get:(fun ~key ~data -> key, data) 29 | (Incr.Var.watch input_map) 30 | in 31 | let both = Incr.both (Incr.Var.watch input_map) derived_map in 32 | let both = Incr.observe both in 33 | let test () = 34 | Incr.stabilize (); 35 | let input_map, derived_map = Incr.Observer.value_exn both in 36 | check_invariants input_map derived_map 37 | in 38 | for _ = 0 to iterations do 39 | if Float.( < ) (U.rand ()) 0.25 40 | then test () 41 | else Incr.Var.set input_map (U.rand_modify_map (Incr.Var.value input_map)) 42 | done 43 | ;; 44 | 45 | let%expect_test _ = run_test ~size_of_initial_map:0 ~iterations:1000 46 | let%expect_test _ = run_test ~size_of_initial_map:100 ~iterations:1000 47 | let%expect_test _ = run_test ~size_of_initial_map:1000 ~iterations:1000 48 | let%expect_test _ = run_test ~size_of_initial_map:1000 ~iterations:10000 49 | 50 | let%expect_test _ = 51 | let size = 1500 in 52 | let input_map = Incr.Var.create (Int.Map.of_alist_exn [ -1, 0.0; size + 1, 0.0 ]) in 53 | let derived_map = 54 | Opaque_map.erase_key_incrementally 55 | ~get:(fun ~key ~data -> key, data) 56 | (Incr.Var.watch input_map) 57 | in 58 | let both = Incr.both (Incr.Var.watch input_map) derived_map in 59 | let both = Incr.observe both in 60 | let test () = 61 | Incr.stabilize (); 62 | let input_map, derived_map = Incr.Observer.value_exn both in 63 | check_invariants input_map derived_map 64 | in 65 | for i = 0 to size - 1 do 66 | Incr.Var.set input_map (Map.set (Incr.Var.value input_map) ~key:i ~data:0.0); 67 | test () 68 | done 69 | ;; 70 | 71 | (* This is a regression-test for [Opaque_map] that demonstrates changes to an 72 | input map where the map never gets larger than size 3, but the denomonator for the 73 | bignum assigned to the key for the middle-most row grows explosively. *) 74 | let%expect_test _ = 75 | let needle = ref (Bignum.of_float_decimal 0.5) in 76 | let input_map = 77 | Incr.Var.create 78 | (Bignum.Map.of_alist_exn 79 | [ Bignum.of_int (-1), (); !needle, (); Bignum.of_int 1, () ]) 80 | in 81 | let derived_map = 82 | Opaque_map.erase_key_incrementally 83 | ~get:(fun ~key:_ ~data:_ -> ()) 84 | (Incr.Var.watch input_map) 85 | in 86 | let observer = Incr.observe derived_map in 87 | for _ = 0 to 1000 do 88 | Incr.Var.replace input_map ~f:(fun map -> 89 | let new_needle = Bignum.(!needle / (one + one)) in 90 | let map = Map.remove map !needle in 91 | let map = Map.add_exn map ~key:new_needle ~data:() in 92 | needle := new_needle; 93 | map); 94 | Incr.stabilize () 95 | done; 96 | observer |> Incr.Observer.value_exn |> [%sexp_of: unit Opaque_map.Key.Map.t] |> print_s; 97 | [%expect {| ((0 ()) (100 ()) (200 ())) |}] 98 | ;; 99 | 100 | (* This test is a regression-test for pathological inputs to incr_map_erase_key which 101 | cause the bignum key to grow explosively. This one utilizes two pointers which jump 102 | over one another repeatedly, each time multiplying the denomonator by two. *) 103 | let%expect_test _ = 104 | let needle = ref (Bignum.of_float_decimal 0.5) in 105 | let needle' = ref (Bignum.of_float_decimal 0.6) in 106 | let input_map = 107 | Incr.Var.create 108 | (Bignum.Map.of_alist_exn 109 | [ Bignum.of_int (-1), (); !needle, (); !needle', (); Bignum.of_int 1, () ]) 110 | in 111 | let derived_map = 112 | Opaque_map.erase_key_incrementally 113 | ~get:(fun ~key:_ ~data:_ -> ()) 114 | (Incr.Var.watch input_map) 115 | in 116 | let observer = Incr.observe derived_map in 117 | for _ = 0 to 1000 do 118 | Incr.Var.replace input_map ~f:(fun map -> 119 | let new_needle = Bignum.(!needle / (one + one)) in 120 | let map = Map.remove map !needle' in 121 | let map = Map.add_exn map ~key:new_needle ~data:() in 122 | needle' := !needle; 123 | needle := new_needle; 124 | map); 125 | Incr.stabilize () 126 | done; 127 | observer |> Incr.Observer.value_exn |> [%sexp_of: unit Opaque_map.Key.Map.t] |> print_s; 128 | [%expect {| ((0 ()) (0.0625 ()) (0.125 ()) (300 ())) |}] 129 | ;; 130 | 131 | let%expect_test "adding elements before and after existing elements" = 132 | let test inputs = 133 | let input_map = Incr.Var.create (Int.Map.of_alist_exn [ 0, () ]) in 134 | let derived_map = 135 | Opaque_map.erase_key_incrementally 136 | ~get:(fun ~key ~data:() -> key) 137 | (Incr.Var.watch input_map) 138 | in 139 | let observer = Incr.observe derived_map in 140 | Incr.stabilize (); 141 | Incr.Var.replace input_map ~f:(fun map -> 142 | List.fold inputs ~init:map ~f:(fun map key -> Map.set map ~key ~data:())); 143 | Incr.stabilize (); 144 | observer 145 | |> Incr.Observer.value_exn 146 | |> Map.iteri ~f:(fun ~key ~data -> 147 | print_s [%sexp (key : Opaque_map.Key.t), (data : int)]) 148 | in 149 | test []; 150 | [%expect {| (0 0) |}]; 151 | let one_through_nine = List.init 9 ~f:(fun i -> i + 1) in 152 | test one_through_nine; 153 | [%expect 154 | {| 155 | (0 0) 156 | (100 1) 157 | (200 2) 158 | (300 3) 159 | (400 4) 160 | (500 5) 161 | (600 6) 162 | (700 7) 163 | (800 8) 164 | (900 9) 165 | |}]; 166 | test (List.map one_through_nine ~f:Int.neg); 167 | [%expect 168 | {| 169 | (-900 -9) 170 | (-800 -8) 171 | (-700 -7) 172 | (-600 -6) 173 | (-500 -5) 174 | (-400 -4) 175 | (-300 -3) 176 | (-200 -2) 177 | (-100 -1) 178 | (0 0) 179 | |}]; 180 | test (one_through_nine @ List.map one_through_nine ~f:Int.neg); 181 | [%expect 182 | {| 183 | (-900 -9) 184 | (-800 -8) 185 | (-700 -7) 186 | (-600 -6) 187 | (-500 -5) 188 | (-400 -4) 189 | (-300 -3) 190 | (-200 -2) 191 | (-100 -1) 192 | (0 0) 193 | (100 1) 194 | (200 2) 195 | (300 3) 196 | (400 4) 197 | (500 5) 198 | (600 6) 199 | (700 7) 200 | (800 8) 201 | (900 9) 202 | |}] 203 | ;; 204 | -------------------------------------------------------------------------------- /incr_map.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/incr_map" 5 | bug-reports: "https://github.com/janestreet/incr_map/issues" 6 | dev-repo: "git+https://github.com/janestreet/incr_map.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/incr_map/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "abstract_algebra" 15 | "bignum" 16 | "core" 17 | "incremental" 18 | "legacy_diffable" 19 | "ppx_diff" 20 | "ppx_jane" 21 | "ppx_pattern_bind" 22 | "ppx_stable_witness" 23 | "streamable" 24 | "uopt" 25 | "dune" {>= "3.17.0"} 26 | ] 27 | available: arch != "arm32" & arch != "x86_32" 28 | synopsis: "Helpers for incremental operations on map like data structures" 29 | description: " 30 | A set of functions for operating incrementally and efficiently on map 31 | like data structures. This leverages new functionality in Incremental 32 | along with the ability to efficiently diff map data structures using 33 | =Map.symmetric_diff=. 34 | " 35 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incr_map) 3 | (public_name incr_map) 4 | (preprocess 5 | (pps ppx_pattern_bind ppx_jane)) 6 | (libraries abstract_algebra core incremental uopt)) 7 | -------------------------------------------------------------------------------- /src/incr_map.mli: -------------------------------------------------------------------------------- 1 | include Incr_map_intf.Incr_map 2 | -------------------------------------------------------------------------------- /test/benchmarks/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incr_map_benchmarks) 3 | (libraries core incremental incr_map incr_map_test) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /test/benchmarks/flamegraph_generation_tools/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names html_table) 4 | (libraries core_unix.command_unix core incr_map_benchmarks) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /test/benchmarks/flamegraph_generation_tools/generate_flamegraph_for_command.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # USAGE: ./generate_flamegraph_for_command [perf_box] [executable_name] [args] > file.svg 4 | perf_box_to_use=$1 5 | executable=$2 6 | shift 2 7 | args=$@ 8 | 9 | X_LIBRARY_INLINING=true, WITH_FRAME_POINTERS=true jenga -pr >/dev/null 2>&1 && 10 | scp $executable $perf_box_to_use:~/executable && 11 | ssh -t $perf_box_to_use "perf record -g ./executable $args 2> /dev/null && flamegraph 2>/dev/null; rm perf.data; rm executable" 12 | -------------------------------------------------------------------------------- /test/benchmarks/flamegraph_generation_tools/html_table.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | let () = Command_unix.run Incr_map_benchmarks.Html_table_like_benchmark.for_perf_cmd 4 | -------------------------------------------------------------------------------- /test/benchmarks/html_table_like_benchmark.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | (* This benchmark emulates Incr.Map operation patterns that occur when exploring a big, 5 | changing in realtime, html table built using incremental virtual DOM. It loops for 6 | a given time performing a random action every time and recomputing the 'view'. 7 | A random action is one of: 8 | + changing a single row 9 | + scrolling up/down a fixed, small number of lines 10 | + moving half a page up/down 11 | + going to the top or bottom of the table 12 | *) 13 | module Generator = Quickcheck.Generator 14 | 15 | let global_num_rows = 200000 16 | let global_range_length = 200 17 | let global_string_length = 20 18 | let global_scroll_length = 10 19 | let global_seed_for_benchmarks = "qwertyuiop" 20 | 21 | type t = 22 | { rows : string Int.Map.t Incr.Var.t 23 | ; num_rows : int 24 | ; string_length : int 25 | ; range_length : int 26 | ; scroll_length : int 27 | ; range_begin : int Incr.Var.t 28 | ; view : string Int.Map.t Incr.Observer.t 29 | } 30 | 31 | type direction = 32 | | Up 33 | | Down 34 | 35 | type action = 36 | | Update_cell of (int * string) list 37 | | Scroll of direction 38 | | Page_move of direction 39 | | Top_bottom_move of direction 40 | 41 | let create_view rows range_begin range_length = 42 | let range = 43 | Incr.map range_begin ~f:(fun range_begin -> 44 | Some (Incl range_begin, Incl (range_begin + range_length))) 45 | in 46 | Incr.observe (Incr.Map.subrange rows range) 47 | ;; 48 | 49 | let create ~num_rows ~range_length ~string_length ~scroll_length = 50 | let rows = List.init num_rows ~f:(fun i -> i, String.make string_length 'a') in 51 | let rows = Incr.Var.create (Int.Map.of_alist_exn rows) in 52 | let range_begin = Incr.Var.create (num_rows / 2) in 53 | { rows 54 | ; num_rows 55 | ; string_length 56 | ; range_length 57 | ; scroll_length 58 | ; range_begin 59 | ; view = create_view (Incr.Var.watch rows) (Incr.Var.watch range_begin) range_length 60 | } 61 | ;; 62 | 63 | let generate_view t = 64 | Incr.stabilize (); 65 | Incr.Observer.value_exn t.view 66 | ;; 67 | 68 | let cell_update t updates = 69 | let old_value = Incr.Var.latest_value t.rows in 70 | let new_value = 71 | List.fold updates ~init:old_value ~f:(fun rows (key, data) -> Map.set rows ~key ~data) 72 | in 73 | Incr.Var.set t.rows new_value; 74 | generate_view t 75 | ;; 76 | 77 | let move_begin t new_begin = 78 | let new_begin = Int.max 0 new_begin |> Int.min (t.num_rows - t.range_length) in 79 | Incr.Var.set t.range_begin new_begin; 80 | generate_view t 81 | ;; 82 | 83 | let move t direction abs_length = 84 | let length = 85 | match direction with 86 | | Up -> abs_length 87 | | Down -> -abs_length 88 | in 89 | let new_begin = length + Incr.Var.latest_value t.range_begin in 90 | move_begin t new_begin 91 | ;; 92 | 93 | let scroll t direction = move t direction t.scroll_length 94 | let page_move t direction = move t direction (t.range_length / 2) 95 | let top_bottom_move t direction = move t direction t.num_rows 96 | 97 | let handle_action t = function 98 | | Update_cell updates -> cell_update t updates 99 | | Scroll direction -> scroll t direction 100 | | Page_move direction -> page_move t direction 101 | | Top_bottom_move direction -> top_bottom_move t direction 102 | ;; 103 | 104 | let cell_update_generator t cell_update_batch_size = 105 | let tuple_gen = 106 | Generator.tuple2 107 | (Int.gen_incl 0 (t.num_rows - 1)) 108 | (String.gen_with_length t.string_length Char.quickcheck_generator) 109 | in 110 | let list_gen = List.gen_with_length cell_update_batch_size tuple_gen in 111 | Generator.map list_gen ~f:(fun x -> Update_cell x) 112 | ;; 113 | 114 | let create_action_generator 115 | t 116 | ~scroll_weight 117 | ~page_move_weight 118 | ~top_bottom_move_weight 119 | ~cell_update_weight 120 | ~cell_update_batch_size 121 | = 122 | let direction_generator = Generator.doubleton Up Down in 123 | Generator.weighted_union 124 | [ scroll_weight, Generator.map direction_generator ~f:(fun dir -> Scroll dir) 125 | ; page_move_weight, Generator.map direction_generator ~f:(fun dir -> Page_move dir) 126 | ; ( top_bottom_move_weight 127 | , Generator.map direction_generator ~f:(fun dir -> Top_bottom_move dir) ) 128 | ; cell_update_weight, cell_update_generator t cell_update_batch_size 129 | ] 130 | ;; 131 | 132 | let for_perf = 133 | let open Command.Let_syntax in 134 | let%map_open duration_string = 135 | flag 136 | "duration" 137 | (required string) 138 | ~doc:"TIMESPAN time for which the benchmark will run" 139 | and scroll_weight = 140 | flag "scroll-weight" (required float) ~doc:"FLOAT weight of a scroll event" 141 | and page_move_weight = 142 | flag 143 | "page-move-weight" 144 | (required float) 145 | ~doc:"FLOAT weight of a pageup/pagedown event" 146 | and top_bottom_move_weight = 147 | flag 148 | "top-bottom-move-weight" 149 | (required float) 150 | ~doc:"FLOAT weight of a 'go to top/bottom' event" 151 | and cell_update_weight = 152 | flag 153 | "cell-update-weight" 154 | (required float) 155 | ~doc:"FLOAT weight of a table cell update event" 156 | and cell_update_batch_size = 157 | flag 158 | "batch-size-of-cell-update" 159 | (required int) 160 | ~doc:"INT number of cell updates in one cell update event" 161 | and seed = 162 | flag 163 | "seed" 164 | (optional string) 165 | ~doc:"STRING seed to use for RNG, will use one from the OS if not provided" 166 | in 167 | fun () -> 168 | let seed = 169 | match seed with 170 | | None -> `Nondeterministic 171 | | Some seed -> `Deterministic seed 172 | in 173 | let t = 174 | create 175 | ~num_rows:global_num_rows 176 | ~range_length:global_range_length 177 | ~string_length:global_string_length 178 | ~scroll_length:global_scroll_length 179 | in 180 | let action_generator = 181 | create_action_generator 182 | t 183 | ~scroll_weight 184 | ~page_move_weight 185 | ~top_bottom_move_weight 186 | ~cell_update_weight 187 | ~cell_update_batch_size 188 | in 189 | let actions = Quickcheck.random_sequence ~seed action_generator in 190 | let duration = Time_float.Span.of_string duration_string in 191 | let started_at = Time_float.now () in 192 | Sequence.delayed_fold actions ~init:() ~finish:Fn.id ~f:(fun () action ~k -> 193 | if Time_float.Span.( > ) (Time_float.diff (Time_float.now ()) started_at) duration 194 | then () 195 | else ( 196 | let (_ : string Int.Map.t) = handle_action t action in 197 | k ())) 198 | ;; 199 | 200 | let for_perf_cmd = 201 | Command.basic for_perf ~summary:"Look into the ml file for a description." 202 | ;; 203 | 204 | module%bench [@name "inline_benchmarks"] _ = struct 205 | let setup 206 | ?(scroll_weight = 0.) 207 | ?(page_move_weight = 0.) 208 | ?(top_bottom_move_weight = 0.) 209 | ?(cell_update_weight = 0.) 210 | ?(cell_update_batch_size = 0) 211 | () 212 | = 213 | let t = 214 | create 215 | ~num_rows:global_num_rows 216 | ~range_length:global_range_length 217 | ~string_length:global_string_length 218 | ~scroll_length:global_scroll_length 219 | in 220 | let action_generator = 221 | create_action_generator 222 | t 223 | ~scroll_weight 224 | ~page_move_weight 225 | ~top_bottom_move_weight 226 | ~cell_update_weight 227 | ~cell_update_batch_size 228 | in 229 | t, action_generator 230 | ;; 231 | 232 | let benchmark (t, action_generator) num_actions = 233 | let seed = `Deterministic global_seed_for_benchmarks in 234 | let actions = Quickcheck.random_sequence ~seed action_generator in 235 | let actions = Sequence.take actions num_actions |> Sequence.force_eagerly in 236 | fun () -> 237 | Sequence.iter actions ~f:(fun action -> 238 | let (_ : string Int.Map.t) = handle_action t action in 239 | ()) 240 | ;; 241 | 242 | let%bench_fun "scroll" = benchmark (setup ~scroll_weight:1. ()) 350 243 | let%bench_fun "page-move" = benchmark (setup ~page_move_weight:1. ()) 70 244 | let%bench_fun "top-bottom-jumping" = benchmark (setup ~top_bottom_move_weight:1. ()) 500 245 | 246 | let%bench_fun "cell-update" = 247 | benchmark (setup ~cell_update_weight:1. ~cell_update_batch_size:50 ()) 10 248 | ;; 249 | end 250 | -------------------------------------------------------------------------------- /test/benchmarks/html_table_like_benchmark.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | val for_perf_cmd : Command.t 4 | -------------------------------------------------------------------------------- /test/benchmarks/import.ml: -------------------------------------------------------------------------------- 1 | module Incr = Incr_map_test.Import.Incr 2 | include Incr.Let_syntax 3 | -------------------------------------------------------------------------------- /test/benchmarks/incr_map_benchmarks.ml: -------------------------------------------------------------------------------- 1 | module Html_table_like_benchmark = Html_table_like_benchmark 2 | module Import = Import 3 | module Subrange_by_rank = Subrange_by_rank 4 | -------------------------------------------------------------------------------- /test/benchmarks/subrange_by_rank.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open Incr_map_test.Subrange_quickcheck_helper 4 | 5 | let global_seed_for_benchmarks = "31415925..." 6 | 7 | module%bench [@name "inline_benchmarks"] _ = struct 8 | let setup_incr map ~range = 9 | let map_var = Incr.Var.create map in 10 | let range_var = Incr.Var.create range in 11 | let sub = 12 | Incr.Map.subrange_by_rank (Incr.Var.watch map_var) (Incr.Var.watch range_var) 13 | in 14 | let obs = Incr.observe sub in 15 | map_var, range_var, obs 16 | ;; 17 | 18 | let setup_rand ~size ~num_ops = 19 | let seed = `Deterministic global_seed_for_benchmarks in 20 | let map = Quickcheck.random_value ~seed (map_with_length_gen size) in 21 | let ops = Quickcheck.random_sequence ~seed (map_op_gen ()) in 22 | let ops = Sequence.take ops num_ops |> Sequence.force_eagerly in 23 | map, ops 24 | ;; 25 | 26 | let apply_ops ~init ops = 27 | (* Applying ops is costly, so we just accumulate all maps and ranges in advance. *) 28 | Sequence.fold ops ~init:[ init ] ~f:(fun states (map_op, range_op) -> 29 | let map, range = List.hd_exn states in 30 | (apply_map_op map map_op, apply_range_op range range_op) :: states) 31 | ;; 32 | 33 | let benchmark_fun states map_var range_var obs () = 34 | let map, range = Sequence.hd_exn !states in 35 | states := Sequence.tl_eagerly_exn !states; 36 | Incr.Var.set map_var map; 37 | Incr.Var.set range_var range; 38 | Incr.stabilize (); 39 | let (_ : map) = Incr.Observer.value_exn obs in 40 | () 41 | ;; 42 | 43 | let benchmark_fixed_range ~range ~size ~num_ops = 44 | let map, ops = setup_rand ~size ~num_ops in 45 | let ops = Sequence.map ~f:(fun map_op -> map_op, `No_change) ops in 46 | let map_var, range_var, obs = setup_incr map ~range in 47 | let states = ref (Sequence.cycle_list_exn (apply_ops ~init:(map, range) ops)) in 48 | Incr.stabilize (); 49 | let (_ : map) = Incr.Observer.value_exn obs in 50 | benchmark_fun states map_var range_var obs 51 | ;; 52 | 53 | let benchmark_fixed_map ~range ~new_range ~size = 54 | let map, _ = setup_rand ~size ~num_ops:0 in 55 | let map_var, range_var, obs = setup_incr map ~range in 56 | let ops = Sequence.of_list [ `No_change, `Set_range new_range ] in 57 | let states = ref (Sequence.cycle_list_exn (apply_ops ~init:(map, range) ops)) in 58 | Incr.stabilize (); 59 | let (_ : map) = Incr.Observer.value_exn obs in 60 | benchmark_fun states map_var range_var obs 61 | ;; 62 | 63 | let benchmark_fixed_range_from_scratch ~range ~size ~num_ops = 64 | let map, ops = setup_rand ~size ~num_ops in 65 | let ops = Sequence.map ~f:(fun map_op -> map_op, `No_change) ops in 66 | let states = ref (Sequence.cycle_list_exn (apply_ops ~init:(map, range) ops)) in 67 | fun () -> 68 | let map_var, range_var, obs = setup_incr map ~range in 69 | benchmark_fun states map_var range_var obs (); 70 | Incr.Observer.disallow_future_use obs 71 | ;; 72 | 73 | let size = 1_000_000 74 | let num_ops = 200 75 | 76 | let%bench_fun "first page" = 77 | benchmark_fixed_range ~range:(Incl 0, Incl 30) ~size ~num_ops 78 | ;; 79 | 80 | let%bench_fun "first page from scratch" = 81 | benchmark_fixed_range_from_scratch ~range:(Incl 0, Incl 30) ~size ~num_ops 82 | ;; 83 | 84 | let%bench_fun "middle page" = 85 | benchmark_fixed_range ~range:(Incl (size / 2), Incl ((size / 2) + 30)) ~size ~num_ops 86 | ;; 87 | 88 | let%bench_fun "middle page from scratch" = 89 | benchmark_fixed_range_from_scratch 90 | ~range:(Incl (size / 2), Incl ((size / 2) + 30)) 91 | ~size 92 | ~num_ops 93 | ;; 94 | 95 | let%bench_fun "last page" = 96 | benchmark_fixed_range ~range:(Incl (size - 31), Incl (size - 1)) ~size ~num_ops 97 | ;; 98 | 99 | let%bench_fun "last page from scratch" = 100 | benchmark_fixed_range_from_scratch 101 | ~range:(Incl (size - 31), Incl (size - 1)) 102 | ~size 103 | ~num_ops 104 | ;; 105 | 106 | let%bench_fun "next page" = 107 | let x = 500_000 in 108 | benchmark_fixed_map 109 | ~range:(Incl x, Incl (x + 30)) 110 | ~new_range:(Incl (x + 31), Incl (x + 60)) 111 | ~size:1_000_000 112 | ;; 113 | end 114 | -------------------------------------------------------------------------------- /test/benchmarks/subrange_by_rank.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/incr_map/96296a99a98f9f3ee873533e5c507208c7372908/test/benchmarks/subrange_by_rank.mli -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incr_map_test) 3 | (libraries core incremental incr_map expect_test_helpers_core 4 | expect_test_sexp_diff core_unix.time_float_unix) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /test/import.ml: -------------------------------------------------------------------------------- 1 | module Time = Time_float_unix 2 | include Expect_test_helpers_core 3 | 4 | module Incr = struct 5 | module Z = Incremental.Make () 6 | include Z 7 | module Map = Incr_map.Make (Z) 8 | end 9 | 10 | include Incr.Let_syntax 11 | -------------------------------------------------------------------------------- /test/incr_map_test.ml: -------------------------------------------------------------------------------- 1 | module Import = Import 2 | module Map_operations = Map_operations 3 | module Merge_both_some = Merge_both_some 4 | module Merge_disjoint = Merge_disjoint 5 | module Rand_map_helper = Rand_map_helper 6 | module Subrange_quickcheck_helper = Subrange_quickcheck_helper 7 | module Test_cartesian_map = Test_cartesian_map 8 | module Test_collapse = Test_collapse 9 | module Test_counti = Test_counti 10 | module Test_counting_map = Test_counting_map 11 | module Test_cutoff = Test_cutoff 12 | module Test_expand = Test_expand 13 | module Test_flatten = Test_flatten 14 | module Test_for_alli_and_existsi = Test_for_alli_and_existsi 15 | module Test_generics = Test_generics 16 | module Test_index_by = Test_index_by 17 | module Test_instrument = Test_instrument 18 | module Test_join = Test_join 19 | module Test_keys = Test_keys 20 | module Test_lookup = Test_lookup 21 | module Test_mapping = Test_mapping 22 | module Test_merge = Test_merge 23 | module Test_observe_changes_exn = Test_observe_changes_exn 24 | module Test_of_set = Test_of_set 25 | module Test_partition_map = Test_partition_map 26 | module Test_rank = Test_rank 27 | module Test_rekey = Test_rekey 28 | module Test_separate = Test_separate 29 | module Test_subrange = Test_subrange 30 | module Test_sum = Test_sum 31 | module Test_transpose = Test_transpose 32 | module Test_unordered_fold = Test_unordered_fold 33 | module Test_unordered_fold_nested_maps = Test_unordered_fold_nested_maps 34 | module Test_unordered_fold_with_extra = Test_unordered_fold_with_extra 35 | module Test_unzip = Test_unzip 36 | module Test_unzip3 = Test_unzip3 37 | module Unzip_fails = Unzip_fails 38 | -------------------------------------------------------------------------------- /test/map_operations.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | module Without_stabilize = struct 5 | type ('key, 'data) t = 6 | [ `Add of 'key * 'data [@quickcheck.weight 10.] 7 | | `Remove of 'key [@quickcheck.weight 4.] 8 | ] 9 | [@@deriving quickcheck, sexp_of] 10 | 11 | let apply t map = 12 | match t with 13 | | `Add (key, data) -> Map.set map ~key ~data 14 | | `Remove key -> Map.remove map key 15 | ;; 16 | 17 | let apply_nested t ~inner_map_comparator map = 18 | match t with 19 | | `Add (key, nested_operations) -> 20 | Map.update map key ~f:(fun inner_map -> 21 | List.fold 22 | nested_operations 23 | ~init:(Option.value inner_map ~default:(Map.empty inner_map_comparator)) 24 | ~f:(fun inner_map t -> apply t inner_map)) 25 | | `Remove key -> Map.remove map key 26 | ;; 27 | 28 | let add ~key ~data = `Add (key, data) 29 | let remove key = `Remove key 30 | end 31 | 32 | type ('key, 'data) t = 33 | [ `Stabilize 34 | | ('key, 'data) Without_stabilize.t 35 | ] 36 | [@@deriving sexp_of] 37 | 38 | let add = Without_stabilize.add 39 | let remove = Without_stabilize.remove 40 | let stabilize = `Stabilize 41 | 42 | let int_key_gen ~keys_size = 43 | let open Quickcheck.Generator.Let_syntax in 44 | let%bind keys = 45 | let%bind len = 46 | match keys_size with 47 | | Some n -> return n 48 | | None -> Int.gen_incl 5 150 49 | in 50 | List.gen_with_length len Int.quickcheck_generator 51 | >>| List.dedup_and_sort ~compare:Int.compare 52 | in 53 | Quickcheck.Generator.of_list keys 54 | ;; 55 | 56 | let quickcheck_generator_with_stabilize ~key_gen ?operations data_gen = 57 | let open Quickcheck.Generator.Let_syntax in 58 | let elt_gen = 59 | Quickcheck.Generator.weighted_union 60 | [ 1., return `Stabilize 61 | ; 14., Without_stabilize.quickcheck_generator key_gen data_gen 62 | ] 63 | in 64 | match operations with 65 | | None -> List.quickcheck_generator elt_gen 66 | | Some len -> List.gen_with_length len elt_gen 67 | ;; 68 | 69 | let quickcheck_generator ?keys_size ?operations data_gen = 70 | quickcheck_generator_with_stabilize 71 | ~key_gen:(int_key_gen ~keys_size) 72 | ?operations 73 | data_gen 74 | ;; 75 | 76 | let tuple_key_quickcheck_generator ?(keys_size = 12) ?operations data_gen = 77 | quickcheck_generator_with_stabilize 78 | ~key_gen: 79 | (Quickcheck.Generator.both 80 | (int_key_gen ~keys_size:(Some keys_size)) 81 | (int_key_gen ~keys_size:(Some keys_size))) 82 | ?operations 83 | data_gen 84 | ;; 85 | 86 | let inner_map_generator ~keys_size ~operations data_gen = 87 | let elt_gen = 88 | Without_stabilize.quickcheck_generator (int_key_gen ~keys_size) data_gen 89 | in 90 | match operations with 91 | | None -> List.quickcheck_generator elt_gen 92 | | Some len -> List.gen_with_length len elt_gen 93 | ;; 94 | 95 | let nested_quickcheck_generator 96 | ?outer_map_keys_size 97 | ?outer_map_operations 98 | ?inner_map_keys_size 99 | ?inner_map_operations 100 | data_gen 101 | = 102 | quickcheck_generator 103 | ?keys_size:outer_map_keys_size 104 | ?operations:outer_map_operations 105 | (inner_map_generator 106 | ~keys_size:inner_map_keys_size 107 | ~operations:inner_map_operations 108 | data_gen) 109 | ;; 110 | 111 | let run_operations_general ~apply operations ~into:var ~after_stabilize = 112 | let init = Incr.Var.latest_value var in 113 | List.fold operations ~init ~f:(fun map oper -> 114 | match oper with 115 | | #Without_stabilize.t as without_stabilize -> apply without_stabilize map 116 | | `Stabilize -> 117 | Incr.Var.set var map; 118 | Incr.stabilize (); 119 | after_stabilize (); 120 | map) 121 | |> ignore 122 | ;; 123 | 124 | let run_operations operations ~into ~after_stabilize = 125 | run_operations_general ~apply:Without_stabilize.apply operations ~into ~after_stabilize 126 | ;; 127 | 128 | let nested_run_operations operations ~inner_map_comparator ~into ~after_stabilize = 129 | run_operations_general 130 | ~apply:(Without_stabilize.apply_nested ~inner_map_comparator) 131 | operations 132 | ~into 133 | ~after_stabilize 134 | ;; 135 | -------------------------------------------------------------------------------- /test/map_operations.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | module Without_stabilize : sig 5 | type ('key, 'data) t [@@deriving sexp_of] 6 | 7 | val add : key:'key -> data:'data -> ('key, 'data) t 8 | val remove : 'key -> ('key, _) t 9 | end 10 | 11 | type ('key, 'data) t [@@deriving sexp_of] 12 | 13 | val add : key:'key -> data:'data -> ('key, 'data) t 14 | val remove : 'key -> ('key, _) t 15 | val stabilize : _ t 16 | 17 | val run_operations 18 | : ('key, 'data) t list 19 | -> into:('key, 'data, _) Map.t Incr.Var.t 20 | -> after_stabilize:(unit -> unit) 21 | -> unit 22 | 23 | val nested_run_operations 24 | : ('outer_key, ('inner_key, 'data) Without_stabilize.t list) t list 25 | -> inner_map_comparator:('inner_key, 'inner_cmp) Comparator.Module.t 26 | -> into:('outer_key, ('inner_key, 'data, 'inner_cmp) Map.t, _) Map.t Incr.Var.t 27 | -> after_stabilize:(unit -> unit) 28 | -> unit 29 | 30 | val quickcheck_generator 31 | : ?keys_size:int 32 | -> ?operations:int 33 | -> 'data Base_quickcheck.Generator.t 34 | -> (int, 'data) t list Base_quickcheck.Generator.t 35 | 36 | val nested_quickcheck_generator 37 | : ?outer_map_keys_size:int 38 | -> ?outer_map_operations:int 39 | -> ?inner_map_keys_size:int 40 | -> ?inner_map_operations:int 41 | -> 'data Base_quickcheck.Generator.t 42 | -> (int, (int, 'data) Without_stabilize.t list) t list Base_quickcheck.Generator.t 43 | 44 | val tuple_key_quickcheck_generator 45 | : ?keys_size:int 46 | (** default is approximately the sqrt of the non-tuple variants to keep the 47 | probability of modifications approximately equivalent. *) 48 | -> ?operations:int 49 | -> 'data Base_quickcheck.Generator.t 50 | -> (int * int, 'data) t list Base_quickcheck.Generator.t 51 | -------------------------------------------------------------------------------- /test/merge_both_some.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%test_unit "merge_both_some" = 5 | Quickcheck.test 6 | ~sexp_of: 7 | [%sexp_of: (int, int) Map_operations.t list * (int, int) Map_operations.t list] 8 | (Quickcheck.Generator.both 9 | (Map_operations.quickcheck_generator Int.quickcheck_generator) 10 | (Map_operations.quickcheck_generator Int.quickcheck_generator)) 11 | ~f:(fun (a_ops, b_ops) -> 12 | let m1 = Incr.Var.create Int.Map.empty in 13 | let watch_m1 = Incr.Var.watch m1 in 14 | let m2 = Incr.Var.create Int.Map.empty in 15 | let watch_m2 = Incr.Var.watch m2 in 16 | let fast = 17 | Incr_map.merge_both_some watch_m1 watch_m2 ~f:(fun ~key:_ v1 v2 -> v1 + v2) 18 | in 19 | let slow = 20 | let%map watch_m1 and watch_m2 in 21 | Map.merge watch_m1 watch_m2 ~f:(fun ~key:_ -> function 22 | | `Left _ | `Right _ -> None 23 | | `Both (a, b) -> Some (a + b)) 24 | in 25 | let fast_obs = Incr.observe fast in 26 | let slow_obs = Incr.observe slow in 27 | Map_operations.run_operations a_ops ~into:m1 ~after_stabilize:(fun () -> 28 | [%test_result: int Int.Map.t] 29 | ~expect:(Incr.Observer.value_exn slow_obs) 30 | (Incr.Observer.value_exn fast_obs)); 31 | Map_operations.run_operations b_ops ~into:m2 ~after_stabilize:(fun () -> 32 | [%test_result: int Int.Map.t] 33 | ~expect:(Incr.Observer.value_exn slow_obs) 34 | (Incr.Observer.value_exn fast_obs))) 35 | ;; 36 | -------------------------------------------------------------------------------- /test/merge_disjoint.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%test_unit "merge_disjoint" = 5 | Quickcheck.test 6 | ~sexp_of: 7 | [%sexp_of: 8 | (int, int) Map_operations.t list 9 | * (int, int) Map_operations.t list 10 | * int Int.Map.t 11 | * int Int.Map.t] 12 | (let%map.Quickcheck.Generator a_ops = 13 | Map_operations.quickcheck_generator Int.quickcheck_generator 14 | and b_ops = Map_operations.quickcheck_generator Int.quickcheck_generator 15 | and a_initial = 16 | Map.quickcheck_generator 17 | (module Int) 18 | Int.quickcheck_generator 19 | Int.quickcheck_generator 20 | and b_initial = 21 | Map.quickcheck_generator 22 | (module Int) 23 | Int.quickcheck_generator 24 | Int.quickcheck_generator 25 | in 26 | a_ops, b_ops, a_initial, b_initial) 27 | ~f:(fun (a_ops, b_ops, a_initial, b_initial) -> 28 | let m1 = Incr.Var.create a_initial in 29 | let watch_m1 = Incr.Var.watch m1 in 30 | let m2 = Incr.Var.create b_initial in 31 | let watch_m2 = 32 | let%map m1 = watch_m1 33 | and m2 = Incr.Var.watch m2 in 34 | (* make sure they're disjoint *) 35 | Map.fold m1 ~init:m2 ~f:(fun ~key ~data:_ acc -> Map.remove acc key) 36 | in 37 | let fast = Incr_map.merge_disjoint watch_m1 watch_m2 in 38 | let slow = 39 | let%map watch_m1 and watch_m2 in 40 | Map.merge watch_m1 watch_m2 ~f:(fun ~key:_ -> function 41 | | `Left x | `Right x -> Some x 42 | | `Both _ -> assert false) 43 | in 44 | let fast_obs = Incr.observe fast in 45 | let slow_obs = Incr.observe slow in 46 | Map_operations.run_operations a_ops ~into:m1 ~after_stabilize:(fun () -> 47 | [%test_result: int Int.Map.t] 48 | ~expect:(Incr.Observer.value_exn slow_obs) 49 | (Incr.Observer.value_exn fast_obs)); 50 | Map_operations.run_operations b_ops ~into:m2 ~after_stabilize:(fun () -> 51 | [%test_result: int Int.Map.t] 52 | ~expect:(Incr.Observer.value_exn slow_obs) 53 | (Incr.Observer.value_exn fast_obs))) 54 | ;; 55 | -------------------------------------------------------------------------------- /test/rand_map_helper.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | let rs = Random.State.make [| 0 |] 5 | let get_rand_key ~max_key = Random.State.int rs max_key 6 | let get_rand_data () = Random.State.float rs 1. 7 | let rand () = Random.State.float rs 1. 8 | 9 | let init_rand_map ~from ~to_ = 10 | let alist = List.map (List.range from to_) ~f:(fun i -> i, get_rand_data ()) in 11 | Int.Map.of_alist_exn alist 12 | ;; 13 | 14 | let rec get_rand_nonexistent_key map = 15 | let key = get_rand_key ~max_key:(max 1000 (Map.length map * 3)) in 16 | if Map.mem map key then get_rand_nonexistent_key map else key 17 | ;; 18 | 19 | let get_rand_existing_key map = 20 | let keys = Map.keys map in 21 | assert (not (List.is_empty keys)); 22 | List.nth_exn keys (Random.State.int rs (List.length keys)) 23 | ;; 24 | 25 | let rand_add_to_map map = 26 | let key = get_rand_nonexistent_key map in 27 | let data = get_rand_data () in 28 | Map.set map ~key ~data 29 | ;; 30 | 31 | let rand_replace_in_map map = 32 | let key = get_rand_existing_key map in 33 | let data = get_rand_data () in 34 | Map.set map ~key ~data 35 | ;; 36 | 37 | let rand_remove_from_map map = 38 | let key = get_rand_existing_key map in 39 | Map.remove map key 40 | ;; 41 | 42 | let rand_modify_map map = 43 | if Map.is_empty map 44 | then rand_add_to_map map 45 | else ( 46 | let rand = rand () in 47 | if Float.O.(rand < 0.5) 48 | then rand_add_to_map map 49 | else if Float.O.(rand < 0.75) 50 | then rand_replace_in_map map 51 | else rand_remove_from_map map) 52 | ;; 53 | 54 | let rand_add_to_map_of_vars map = 55 | let key = get_rand_nonexistent_key map in 56 | let data = Incr.Var.create (get_rand_data ()) in 57 | Map.set map ~key ~data 58 | ;; 59 | 60 | let rand_replace_in_map_of_vars map = 61 | let key = get_rand_existing_key map in 62 | let data = Incr.Var.create (get_rand_data ()) in 63 | Map.set map ~key ~data 64 | ;; 65 | 66 | let rand_set_in_map_of_vars map = 67 | let key = get_rand_existing_key map in 68 | let data = Map.find_exn map key in 69 | Incr.Var.set data (get_rand_data ()) 70 | ;; 71 | 72 | let rand_modify_map_of_vars map = 73 | if Map.is_empty map 74 | then rand_add_to_map_of_vars map 75 | else ( 76 | let rand = rand () in 77 | if Float.O.(rand < 0.4) 78 | then rand_add_to_map_of_vars map 79 | else if Float.O.(rand < 0.6) 80 | then ( 81 | let () = rand_set_in_map_of_vars map in 82 | map) 83 | else if Float.O.(rand < 0.8) 84 | then rand_replace_in_map_of_vars map 85 | else rand_remove_from_map map) 86 | ;; 87 | -------------------------------------------------------------------------------- /test/rand_map_helper.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | (** Utility functions for randomly creating and modifying maps with int keys and float 5 | data between 0 and 1. *) 6 | 7 | (** [rand] returns uniformly distributed float between 0 and 1 *) 8 | val rand : unit -> float 9 | 10 | (** [init_rand_map] creates a map with keys from [from] (inclusive) to [to_] (exclusive) 11 | with randomly generated float data *) 12 | val init_rand_map : from:int -> to_:int -> float Int.Map.t 13 | 14 | (** [random_add_to_map] randomly chooses a key that is not already in the map and adds it 15 | to the map with randomly generated float data. *) 16 | val rand_add_to_map : float Int.Map.t -> float Int.Map.t 17 | 18 | (** [random_add_to_map_of_vars] is similar to [random_add_to_map], but instead of a 19 | [float] the data is a [float Incr.Var.t] initialized to a randomly generated float. *) 20 | val rand_add_to_map_of_vars : float Incr.Var.t Int.Map.t -> float Incr.Var.t Int.Map.t 21 | 22 | (** [random_replace_in_map] randomly chooses a key in the map and adds it to the map with 23 | new, randomly generated float data. *) 24 | val rand_replace_in_map : float Int.Map.t -> float Int.Map.t 25 | 26 | (** [random_replace_in_map_of_vars] is similar to [random_replace_in_map], but instead of 27 | a [float], the data is a [float Incr.Var.t] initialized to a randomly generated float. *) 28 | val rand_replace_in_map_of_vars : float Incr.Var.t Int.Map.t -> float Incr.Var.t Int.Map.t 29 | 30 | (** [random_set_in_map_of_vars] is similar to [random_replace_in_map_of_vars], but instead 31 | of creating a new [float Incr.Var.t], the existing [float Incr.Var.t] is set to a new 32 | randomly generated float. *) 33 | val rand_set_in_map_of_vars : float Incr.Var.t Int.Map.t -> unit 34 | 35 | (** [random_remove_from_map] randomly chooses a key in the map and removes it. *) 36 | val rand_remove_from_map : 'a Int.Map.t -> 'a Int.Map.t 37 | 38 | (** [rand_modify_map] randomly chooses and calls one of [rand_add_to_map], 39 | [rand_replace_in_map], and [rand_remove_from_map]. *) 40 | val rand_modify_map : float Int.Map.t -> float Int.Map.t 41 | 42 | (** [rand_modify_map_of_vars] randomly chooses and calls one of [rand_add_to_map_of_vars], 43 | [rand_replace_in_map_of_vars], [rand_set_in_map_of_vars], and 44 | [rand_remove_from_map_of_vars]. *) 45 | val rand_modify_map_of_vars : float Incr.Var.t Int.Map.t -> float Incr.Var.t Int.Map.t 46 | 47 | (* [get_rand_existing_key] returns a random key that is present in the map. *) 48 | val get_rand_existing_key : _ Int.Map.t -> int 49 | 50 | (* [get_rand_nonexisting_key] returns a random key that is not present in the 51 | map. *) 52 | val get_rand_nonexistent_key : _ Int.Map.t -> int 53 | -------------------------------------------------------------------------------- /test/subrange_quickcheck_helper.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open Quickcheck 4 | open Quickcheck.Generator.Let_syntax 5 | module Key = Int 6 | module Value = Int 7 | 8 | type map = Value.t Key.Map.t [@@deriving sexp_of, compare] 9 | 10 | type map_op = 11 | [ `Add_nearby of Key.t * Value.t 12 | | `Remove of Key.t 13 | | `Update of Key.t * Value.t 14 | | `No_change 15 | ] 16 | [@@deriving sexp_of] 17 | 18 | let map_with_length_gen ?key_range length : map Generator.t = 19 | let f, t = Option.value key_range ~default:(-10 * length, 10 * length) in 20 | let%map l = 21 | Generator.list_with_length 22 | (2 * length) 23 | (Generator.both (Int.gen_uniform_incl f t) (Int.gen_uniform_incl (-10) 20000)) 24 | in 25 | List.fold l ~init:Int.Map.empty ~f:(fun map (key, data) -> 26 | if Map.length map < length then Map.set map ~key ~data else map) 27 | ;; 28 | 29 | let map_gen : map Generator.t = 30 | let%bind l1 = Generator.small_non_negative_int in 31 | let%bind l2 = Generator.small_non_negative_int in 32 | map_with_length_gen ((4 * l1) + l2) 33 | ;; 34 | 35 | let map_op_gen ?key_range ?(none_ratio = 0.0) () : map_op Generator.t = 36 | let key_gen = 37 | match key_range with 38 | | None -> Generator.small_non_negative_int 39 | | Some (from, to_) -> Int.gen_incl from to_ 40 | in 41 | let val_gen = Int.gen_uniform_incl (-10) 20000 in 42 | Generator.weighted_union 43 | [ ( 1.0 -. none_ratio 44 | , Generator.union 45 | [ (let%map k = key_gen 46 | and v = val_gen in 47 | `Add_nearby (k, v)) 48 | ; (let%map k = key_gen 49 | and v = val_gen in 50 | `Update (k, v)) 51 | ; (let%map k = key_gen in 52 | `Remove k) 53 | ] ) 54 | ; none_ratio, Generator.singleton `No_change 55 | ] 56 | ;; 57 | 58 | let rec apply_map_op ~search_length map = function 59 | | `Add_nearby (key, data) -> 60 | if Map.mem map key && Int.( > ) search_length 0 61 | then apply_map_op map (`Add_nearby (key + 1, data)) ~search_length:(search_length - 1) 62 | else Map.set map ~key ~data 63 | | `Update (key, data) -> 64 | (match Map.closest_key map `Greater_or_equal_to key with 65 | | None -> map 66 | | Some (key, _) -> Map.set map ~key ~data) 67 | | `Remove key -> 68 | (match Map.closest_key map `Greater_or_equal_to key with 69 | | None -> map 70 | | Some (key, _) -> Map.remove map key) 71 | | `No_change -> map 72 | ;; 73 | 74 | let apply_map_op = apply_map_op ~search_length:10 75 | 76 | let apply_map_op_incr map_var op = 77 | let map = Incr.Var.value map_var in 78 | Incr.Var.set map_var (apply_map_op map op) 79 | ;; 80 | 81 | type range = int Maybe_bound.t * int Maybe_bound.t [@@deriving sexp_of] 82 | 83 | type range_op = 84 | [ `Move_start of int 85 | | `Move_end of int 86 | | `Next_page 87 | | `Prev_page 88 | | `Set_range of range (* not generated by default *) 89 | | `No_change 90 | ] 91 | [@@deriving sexp_of] 92 | 93 | let range_gen : range Generator.t = 94 | let%map a = Generator.small_non_negative_int 95 | and b = Generator.small_non_negative_int in 96 | if a < b then Incl a, Incl b else Incl b, Incl a 97 | ;; 98 | 99 | let range_op_gen ?(none_ratio = 0.0) () : range_op Generator.t = 100 | let offset_gen = 101 | let%map ch = Generator.small_positive_int 102 | and positive = Bool.quickcheck_generator in 103 | if positive then ch else Int.(-ch) 104 | in 105 | Generator.weighted_union 106 | [ ( 1.0 -. none_ratio 107 | , Generator.weighted_union 108 | [ ( 0.4 109 | , let%map diff = offset_gen in 110 | `Move_start diff ) 111 | ; ( 0.4 112 | , let%map diff = offset_gen in 113 | `Move_end diff ) 114 | ; 0.1, Generator.singleton `Next_page 115 | ; 0.1, Generator.singleton `Prev_page 116 | ] ) 117 | ; none_ratio, Generator.singleton `No_change 118 | ] 119 | ;; 120 | 121 | let bounds_contradictory ~lower ~upper = 122 | (* Returns true if there are provably no elements included in the given range. *) 123 | match lower, upper with 124 | | _, Unbounded | Unbounded, _ -> false 125 | | Incl l, Incl u -> l > u 126 | | Excl l, Incl u | Incl l, Excl u -> l >= u 127 | | Excl l, Excl u -> l >= u - 1 128 | ;; 129 | 130 | let some_upper_bound_so_that_non_empty ~lower = 131 | match lower with 132 | | Unbounded -> 133 | (* arbitrary *) 134 | Incl 0 135 | | Incl l -> 136 | (* Smallest possible *) 137 | Incl l 138 | | Excl l -> 139 | (* Smallest possible *) 140 | Incl (l + 1) 141 | ;; 142 | 143 | let replace_upper_bound_if_contradictory ~lower ~upper = 144 | let new_upper = 145 | if bounds_contradictory ~lower ~upper 146 | then some_upper_bound_so_that_non_empty ~lower 147 | else upper 148 | in 149 | lower, new_upper 150 | ;; 151 | 152 | let apply_range_op (start, end_) = function 153 | | `Move_start d -> 154 | let new_start = 155 | Maybe_bound.map start ~f:(fun start -> 156 | let new_start = Int.max 0 (start + d) in 157 | new_start) 158 | in 159 | replace_upper_bound_if_contradictory ~lower:new_start ~upper:end_ 160 | | `Move_end d -> 161 | let new_end = Maybe_bound.map end_ ~f:(( + ) d) in 162 | replace_upper_bound_if_contradictory ~lower:start ~upper:new_end 163 | | `Next_page -> 164 | let shift = 165 | match start, end_ with 166 | | (Incl s | Excl s), (Incl e | Excl e) -> ( + ) (e - s + 1) 167 | | _ -> Fn.id 168 | in 169 | Maybe_bound.map start ~f:shift, Maybe_bound.map end_ ~f:shift 170 | | `Prev_page -> 171 | let shift = 172 | match start, end_ with 173 | | (Incl s | Excl s), (Incl e | Excl e) -> fun x -> Int.max 0 (x - (e - s + 1)) 174 | | _ -> Fn.id 175 | in 176 | Maybe_bound.map start ~f:shift, Maybe_bound.map end_ ~f:shift 177 | | `Set_range range -> range 178 | | `No_change -> start, end_ 179 | ;; 180 | 181 | let apply_range_op_incr range_var op = 182 | let range = Incr.Var.value range_var in 183 | Incr.Var.set range_var (apply_range_op range op) 184 | ;; 185 | 186 | let map_and_range_op_gen ?key_range () : (map_op * range_op) Generator.t = 187 | let%map m = map_op_gen ?key_range ~none_ratio:0.5 () 188 | and r = range_op_gen ~none_ratio:0.5 () in 189 | m, r 190 | ;; 191 | -------------------------------------------------------------------------------- /test/subrange_quickcheck_helper.mli: -------------------------------------------------------------------------------- 1 | (* Quickcheck utils for subrange_by_rank, used in test and benchmarks *) 2 | 3 | open Core 4 | open Quickcheck 5 | open Import 6 | module Key = Int 7 | module Value = Int 8 | 9 | type map = Value.t Key.Map.t [@@deriving sexp_of, compare] 10 | 11 | type map_op = 12 | [ `Add_nearby of Key.t * Value.t 13 | | `Remove of Key.t 14 | | `Update of Key.t * Value.t 15 | | `No_change 16 | ] 17 | [@@deriving sexp_of] 18 | 19 | type range = int Maybe_bound.t * int Maybe_bound.t [@@deriving sexp_of] 20 | 21 | val map_with_length_gen : ?key_range:int * int -> int -> map Generator.t 22 | val map_gen : map Generator.t 23 | val map_op_gen : ?key_range:int * int -> ?none_ratio:float -> unit -> map_op Generator.t 24 | 25 | type range_op = 26 | [ `Move_start of int 27 | | `Move_end of int 28 | | `Next_page 29 | | `Prev_page 30 | | `Set_range of range (* not generated by default *) 31 | | `No_change 32 | ] 33 | [@@deriving sexp_of] 34 | 35 | val range_gen : range Generator.t 36 | val range_op_gen : ?none_ratio:float -> unit -> range_op Generator.t 37 | val apply_map_op : map -> map_op -> map 38 | val apply_map_op_incr : map Incr.Var.t -> map_op -> unit 39 | val apply_range_op : range -> range_op -> range 40 | val apply_range_op_incr : range Incr.Var.t -> range_op -> unit 41 | val map_and_range_op_gen : ?key_range:int * int -> unit -> (map_op * range_op) Generator.t 42 | -------------------------------------------------------------------------------- /test/test_cartesian_map.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | let%expect_test "cartesian_product" = 5 | let m1_var = Incr.Var.create String.Map.empty in 6 | let m2_var = Incr.Var.create Char.Map.empty in 7 | let observer = 8 | Incr.observe 9 | (Incr_map.cartesian_product 10 | (Incr.Var.watch m1_var) 11 | (Incr.Var.watch m2_var) 12 | ~data_equal_left:String.equal 13 | ~data_equal_right:equal) 14 | in 15 | let stabilize_and_show () = 16 | Incr.stabilize (); 17 | print_s 18 | [%sexp 19 | (Incr.Observer.value_exn observer |> Map.to_alist 20 | : ((String.t * Char.t) * (String.t * int)) list)] 21 | in 22 | stabilize_and_show (); 23 | [%expect {| () |}]; 24 | Incr.Var.set m1_var (String.Map.of_alist_exn [ "apple", "red"; "banana", "yellow" ]); 25 | stabilize_and_show (); 26 | [%expect {| () |}]; 27 | Incr.Var.set m2_var (Char.Map.of_alist_exn [ 'X', 200 ]); 28 | stabilize_and_show (); 29 | [%expect 30 | {| 31 | (((apple X) (red 200)) 32 | ((banana X) (yellow 200))) 33 | |}]; 34 | Incr.Var.set m1_var (String.Map.of_alist_exn [ "banana", "yellow"; "grape", "purple" ]); 35 | stabilize_and_show (); 36 | [%expect 37 | {| 38 | (((banana X) (yellow 200)) 39 | ((grape X) (purple 200))) 40 | |}]; 41 | Incr.Var.set m2_var (Char.Map.of_alist_exn [ 'Y', 400; 'Z', 500 ]); 42 | stabilize_and_show (); 43 | [%expect 44 | {| 45 | (((banana Y) (yellow 400)) 46 | ((banana Z) (yellow 500)) 47 | ((grape Y) (purple 400)) 48 | ((grape Z) (purple 500))) 49 | |}]; 50 | Incr.Var.set m2_var (Char.Map.of_alist_exn [ 'Y', 400; 'Z', 600 ]); 51 | stabilize_and_show (); 52 | [%expect 53 | {| 54 | (((banana Y) (yellow 400)) 55 | ((banana Z) (yellow 600)) 56 | ((grape Y) (purple 400)) 57 | ((grape Z) (purple 600))) 58 | |}]; 59 | Incr.Var.set m1_var String.Map.empty; 60 | stabilize_and_show (); 61 | [%expect {| () |}]; 62 | Incr.Var.set m1_var (String.Map.singleton "grape" "purple"); 63 | stabilize_and_show (); 64 | [%expect 65 | {| 66 | (((grape Y) (purple 400)) 67 | ((grape Z) (purple 600))) 68 | |}] 69 | ;; 70 | 71 | let%test_unit "randomly generated inputs for cartesian product should produce correct \ 72 | outputs" 73 | = 74 | let m1_var = Incr.Var.create Int.Map.empty in 75 | let m2_var = Incr.Var.create Int.Map.empty in 76 | let observer = 77 | Incr.observe 78 | (Incr_map.cartesian_product 79 | (Incr.Var.watch m1_var) 80 | (Incr.Var.watch m2_var) 81 | ~data_equal_left:equal 82 | ~data_equal_right:equal) 83 | in 84 | let all_at_once_impl m1 m2 = 85 | List.cartesian_product (Map.to_alist m1) (Map.to_alist m2) 86 | |> List.map ~f:(fun ((k1, v1), (k2, v2)) -> (k1, k2), (v1, v2)) 87 | |> Map.of_alist_exn (module Tuple.Comparator (Int) (Int)) 88 | in 89 | Quickcheck.test 90 | (Quickcheck.Generator.tuple2 91 | (Int.Map.quickcheck_generator 92 | Quickcheck.Generator.small_non_negative_int 93 | Quickcheck.Generator.small_non_negative_int) 94 | (Int.Map.quickcheck_generator 95 | Quickcheck.Generator.small_non_negative_int 96 | Quickcheck.Generator.small_non_negative_int)) 97 | ~f:(fun (m1, m2) -> 98 | Incr.Var.set m1_var m1; 99 | Incr.Var.set m2_var m2; 100 | Incr.stabilize (); 101 | [%test_result: ((int * int) * (int * int)) list] 102 | ~expect:(all_at_once_impl m1 m2 |> Map.to_alist) 103 | (Incr.Observer.value_exn observer |> Map.to_alist)) 104 | ;; 105 | -------------------------------------------------------------------------------- /test/test_cartesian_map.mli: -------------------------------------------------------------------------------- 1 | (* this file is intentionally empty *) 2 | -------------------------------------------------------------------------------- /test/test_counti.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%test_unit "correctness" = 5 | let f ~key ~data = String.contains data 'a' && key % 2 = 0 in 6 | let var = Incr.Var.create Int.Map.empty in 7 | let observer = Incremental.observe (Incr_map.counti (Incr.Var.watch var) ~f) in 8 | Quickcheck.test 9 | (Map_operations.quickcheck_generator [%quickcheck.generator: string]) 10 | ~f:(fun operations -> 11 | Map_operations.run_operations ~into:var operations ~after_stabilize:(fun () -> 12 | [%test_result: int] 13 | ~expect:(Map.counti (Incr.Var.latest_value var) ~f) 14 | (Incremental.Observer.value_exn observer))) 15 | ;; 16 | -------------------------------------------------------------------------------- /test/test_counti.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_counting_map.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | type ('a, 'here, 'message, 'equal) test = 5 | ?here:'here -> ?message:'message -> ?equal:'equal -> expect:'a -> 'a -> unit 6 | 7 | let run_test here ~incrementally ~all_at_once ~(test : _ test) = 8 | let int_map_operations_generator = 9 | Map_operations.quickcheck_generator (Base_quickcheck.Generator.int_inclusive 0 255) 10 | in 11 | Quickcheck.test int_map_operations_generator ~f:(fun operations -> 12 | let var = Incr.Var.create Int.Map.empty in 13 | let observer = Incremental.observe (incrementally (Incr.Var.watch var)) in 14 | Map_operations.run_operations ~into:var operations ~after_stabilize:(fun () -> 15 | let expected = all_at_once (Incr.Var.latest_value var) in 16 | let actual = Incremental.Observer.value_exn observer in 17 | test ~here:[ here ] ~expect:expected actual)) 18 | ;; 19 | 20 | let%test_unit "map_counti" = 21 | let incrementally input = 22 | Incr_map.mapi_count input ~comparator:(module Int) ~f:(fun ~key ~data -> key + data) 23 | in 24 | let all_at_once input = 25 | input 26 | |> Map.to_alist 27 | |> List.map ~f:(fun (k, v) -> k + v, ()) 28 | |> Map.of_alist_multi (module Int) 29 | |> Map.map ~f:(List.length :> _ -> _) 30 | in 31 | run_test [%here] ~incrementally ~all_at_once ~test:[%test_result: int Int.Map.t] 32 | ;; 33 | 34 | let%test_unit "map_count" = 35 | let incrementally input = Incr_map.map_count input ~comparator:(module Int) ~f:Fn.id in 36 | let all_at_once input = 37 | input 38 | |> Map.data 39 | |> List.map ~f:(fun d -> d, ()) 40 | |> Map.of_alist_multi (module Int) 41 | |> Map.map ~f:(List.length :> _ -> _) 42 | in 43 | run_test [%here] ~incrementally ~all_at_once ~test:[%test_result: int Int.Map.t] 44 | ;; 45 | 46 | let%test_unit "min_value" = 47 | let incrementally input = Incr_map.min_value input ~comparator:(module Int) in 48 | let all_at_once input = input |> Map.data |> List.min_elt ~compare:[%compare: int] in 49 | run_test [%here] ~incrementally ~all_at_once ~test:[%test_result: int option] 50 | ;; 51 | 52 | let%test_unit "max_value" = 53 | let incrementally input = Incr_map.max_value input ~comparator:(module Int) in 54 | let all_at_once input = input |> Map.data |> List.max_elt ~compare:[%compare: int] in 55 | run_test [%here] ~incrementally ~all_at_once ~test:[%test_result: int option] 56 | ;; 57 | 58 | let%test_unit "value_bounds" = 59 | let incrementally input = Incr_map.value_bounds input ~comparator:(module Int) in 60 | let all_at_once input = 61 | Option.both 62 | (input |> Map.data |> List.min_elt ~compare:[%compare: int]) 63 | (input |> Map.data |> List.max_elt ~compare:[%compare: int]) 64 | in 65 | run_test [%here] ~incrementally ~all_at_once ~test:[%test_result: (int * int) option] 66 | ;; 67 | -------------------------------------------------------------------------------- /test/test_counting_map.mli: -------------------------------------------------------------------------------- 1 | (* this file is intentionally empty *) 2 | -------------------------------------------------------------------------------- /test/test_cutoff.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let cutoff = Incremental.Cutoff.of_equal (fun a b -> Float.(abs (a - b) < 1.0)) 5 | 6 | let run_operations ~test_impl ~reference_impl ~f operations = 7 | let var = Incr.Var.create Int.Map.empty in 8 | let reference_observer = Incremental.observe (reference_impl (Incr.Var.watch var)) in 9 | let test_observer = Incremental.observe (test_impl (Incr.Var.watch var)) in 10 | Map_operations.run_operations ~into:var operations ~after_stabilize:(fun () -> 11 | let reference_v = Incremental.Observer.value_exn reference_observer in 12 | let test_v = Incremental.Observer.value_exn test_observer in 13 | f ~test_v ~reference_v) 14 | ;; 15 | 16 | let run_test ~test_impl ~reference_impl = 17 | let int_map_operations_generator = 18 | Map_operations.quickcheck_generator 19 | ~keys_size:10 20 | ~operations:100 21 | (Base_quickcheck.Generator.float_inclusive 0.0 10.0) 22 | in 23 | Quickcheck.test 24 | ~seed:(`Deterministic "this is the seed") 25 | int_map_operations_generator 26 | ~f: 27 | (run_operations ~test_impl ~reference_impl ~f:(fun ~test_v ~reference_v -> 28 | [%test_result: float Int.Map.t] test_v ~expect:reference_v)) 29 | ;; 30 | 31 | let reference_impl input = 32 | Incr_map.map' input ~f:(fun v -> 33 | Incr.set_cutoff v cutoff; 34 | v) 35 | ;; 36 | 37 | let%test_unit "quickcheck [Incr_map.cutoff] vs Map' with Incr.cutoff" = 38 | let test_impl input = Incr_map.cutoff input ~cutoff in 39 | run_test ~reference_impl ~test_impl 40 | ;; 41 | 42 | let%expect_test "naive data_equal" = 43 | (* You might expect this code to be equivalent to [Incr_map.cutoff]: 44 | 45 | {[ 46 | Incr_map.map 47 | input 48 | ~data_equal:(fun old_value new_value -> 49 | Incremental.Cutoff.should_cutoff cutoff ~old_value ~new_value) 50 | ~f:Fn.id 51 | ]} 52 | 53 | but it does not, because [map] always diffs the current map against the 54 | previous _input_ to the map, which can cause cutoff sliding. Let's say 55 | that our cutoff function is 56 | 57 | | a - b | <= 1 58 | 59 | and we have a map whose contents move from 60 | 61 | {v 62 | { a => 1 } 63 | to 64 | { a => 2 } 65 | to 66 | { a => 3 } 67 | v} 68 | 69 | The implementataion using [Incr_map.map'] and [Incr_map.cutoff] correctly report 70 | the map as changing from { a => 1 } -> { a => 1 } -> { a => 3 }, with the first 71 | update being blocked by the cutoff function, but the [Incr_map.map ~data_equal] 72 | implementaion will report { a => 1 } -> { a => 1 } -> { a => 1 }. *) 73 | let test_impl input = 74 | Incr_map.map 75 | input 76 | ~data_equal:(fun old_value new_value -> 77 | Incremental.Cutoff.should_cutoff cutoff ~old_value ~new_value) 78 | ~f:Fn.id 79 | in 80 | let operations = 81 | Map_operations. 82 | [ add ~key:0 ~data:0.0 83 | ; stabilize 84 | ; add ~key:0 ~data:0.5 85 | ; stabilize 86 | ; add ~key:0 ~data:1.0 87 | ; stabilize 88 | ; add ~key:0 ~data:1.5 89 | ; stabilize 90 | ; add ~key:0 ~data:2.0 91 | ; stabilize 92 | ] 93 | in 94 | print_endline " ref vs test"; 95 | run_operations operations ~test_impl ~reference_impl ~f:(fun ~test_v ~reference_v -> 96 | let test_value = Map.find_exn test_v 0 in 97 | let reference_value = Map.find_exn reference_v 0 in 98 | printf "%f vs %f\n" reference_value test_value); 99 | [%expect 100 | {| 101 | ref vs test 102 | 0.000000 vs 0.000000 103 | 0.000000 vs 0.000000 104 | 1.000000 vs 0.000000 105 | 1.000000 vs 0.000000 106 | 2.000000 vs 0.000000 107 | |}] 108 | ;; 109 | -------------------------------------------------------------------------------- /test/test_expand.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module%test _ = struct 5 | module Key = struct 6 | module T = struct 7 | type t = (int, int) Tuple2.t [@@deriving sexp_of] 8 | 9 | type comparator_witness = 10 | (Int.comparator_witness, Int.comparator_witness) Tuple2.comparator_witness 11 | 12 | let comparator = Tuple2.comparator Int.comparator Int.comparator 13 | end 14 | 15 | include T 16 | include Comparable.Make_plain_using_comparator (T) 17 | end 18 | 19 | let%expect_test "manual updates" = 20 | let var = [ (0, 1), "a"; (1, 2), "b" ] |> Key.Map.of_alist_exn |> Incr.Var.create in 21 | let observer = 22 | Incr.observe 23 | (Incr_map.expand 24 | ~outer_comparator:(module Int) 25 | ~inner_comparator:(module Int) 26 | (Incr.Var.watch var)) 27 | in 28 | let update_and_test ~f = 29 | Incr.Var.replace var ~f; 30 | Incr.stabilize (); 31 | print_s [%sexp (Incr.Observer.value_exn observer : string Int.Map.t Int.Map.t)] 32 | in 33 | update_and_test ~f:Fn.id; 34 | [%expect 35 | {| 36 | ((0 ((1 a))) 37 | (1 ((2 b)))) 38 | |}]; 39 | update_and_test ~f:(fun m -> Map.add_exn m ~key:(2, 4) ~data:"c"); 40 | [%expect 41 | {| 42 | ((0 ((1 a))) 43 | (1 ((2 b))) 44 | (2 ((4 c)))) 45 | |}]; 46 | update_and_test ~f:(fun m -> Map.remove m (1, 2)); 47 | [%expect 48 | {| 49 | ((0 ((1 a))) 50 | (2 ((4 c)))) 51 | |}]; 52 | update_and_test ~f:(fun m -> Map.set m ~key:(2, 0) ~data:"c"); 53 | [%expect 54 | {| 55 | ((0 ((1 a))) 56 | (2 ( 57 | (0 c) 58 | (4 c)))) 59 | |}]; 60 | update_and_test ~f:(fun m -> Map.set m ~key:(2, 1) ~data:"asdf"); 61 | [%expect 62 | {| 63 | ((0 ((1 a))) 64 | (2 ( 65 | (0 c) 66 | (1 asdf) 67 | (4 c)))) 68 | |}] 69 | ;; 70 | 71 | let all_at_once t = 72 | Map.fold t ~init:Int.Map.empty ~f:(fun ~key:(outer_key, inner_key) ~data acc -> 73 | Map.update acc outer_key ~f:(function 74 | | None -> Int.Map.singleton inner_key data 75 | | Some map -> Map.add_exn map ~key:inner_key ~data)) 76 | ;; 77 | 78 | let%test_unit "randomized map changes" = 79 | let var = Incr.Var.create Key.Map.empty in 80 | let observer = 81 | Incremental.observe 82 | (Incr_map.expand 83 | (Incr.Var.watch var) 84 | ~outer_comparator:(module Int) 85 | ~inner_comparator:(module Int)) 86 | in 87 | Quickcheck.test 88 | (Map_operations.tuple_key_quickcheck_generator String.quickcheck_generator) 89 | ~f:(fun operations -> 90 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 91 | [%test_result: string Int.Map.t Int.Map.t] 92 | ~expect:(all_at_once (Incr.Var.latest_value var)) 93 | (Incremental.Observer.value_exn observer))) 94 | ;; 95 | 96 | let%test_unit "expand collapse compose" = 97 | let var = Incr.Var.create Key.Map.empty in 98 | let observer = 99 | Incremental.observe 100 | (Incr_map.collapse 101 | ~comparator:(module Int) 102 | (Incr_map.expand 103 | (Incr.Var.watch var) 104 | ~outer_comparator:(module Int) 105 | ~inner_comparator:(module Int))) 106 | in 107 | Quickcheck.test 108 | (Map_operations.tuple_key_quickcheck_generator String.quickcheck_generator) 109 | ~f:(fun operations -> 110 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 111 | [%test_result: string Key.Map.t] 112 | ~expect:(Incr.Var.latest_value var) 113 | (Incremental.Observer.value_exn observer))) 114 | ;; 115 | end 116 | -------------------------------------------------------------------------------- /test/test_expand.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_flatten.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | module%test [@name "random tests"] _ = struct 5 | (* [Incr.Map.flatten] is tested as follows: 6 | 7 | First, create [map_of_incrs] of type [float Incr.t Int.Map.t] with initial values 8 | equal to those in [map]. 9 | 10 | Next, apply [Incr.Map.flatten] to [map_of_incrs] to get [result_incr]. 11 | 12 | At each of the [num_steps] steps, randomly change a single entry in [map_of_incrs] 13 | by setting the [Incr.Var.t] corresponding to its data to a new value. 14 | 15 | Every [stabilize_every_n] steps, check the result as follows: 16 | - call [Incr.stabilize ()] 17 | - check the value of [result_incr] 18 | *) 19 | let test_flatten map ~num_steps ~stabilize_every_n = 20 | let map_of_vars = Map.map map ~f:Incr.Var.create in 21 | let map_of_incrs = Map.map map_of_vars ~f:Incr.Var.watch in 22 | let result_incr = Incr.Map.flatten map_of_incrs in 23 | let result_obs = Incr.observe result_incr in 24 | let test_value () = 25 | (* Since [result_incr] was obtained as [Incr.Map.flatten map_of_incrs], check the 26 | value of [result_incr] against the data values in [map_of_incrs] *) 27 | [%test_result: float Int.Map.t] 28 | (Incr.Observer.value_exn result_obs) 29 | ~expect:(Map.map map_of_vars ~f:Incr.Var.value) 30 | in 31 | let stabilize_and_test_result () = 32 | Incr.stabilize (); 33 | test_value () 34 | in 35 | stabilize_and_test_result (); 36 | List.iter (List.range 0 num_steps) ~f:(fun i -> 37 | Rand_map_helper.rand_set_in_map_of_vars map_of_vars; 38 | if i % stabilize_every_n = 0 then stabilize_and_test_result ()) 39 | ;; 40 | 41 | let%test_unit "rand test: stabilize every step" = 42 | let start_map = Rand_map_helper.init_rand_map ~from:0 ~to_:30 in 43 | test_flatten start_map ~num_steps:100 ~stabilize_every_n:1 44 | ;; 45 | 46 | let%test_unit "rand test: stabilize every 10 steps" = 47 | let start_map = Rand_map_helper.init_rand_map ~from:0 ~to_:30 in 48 | test_flatten start_map ~num_steps:100 ~stabilize_every_n:10 49 | ;; 50 | 51 | (* [test_flatten_with_cutoff] is similar to [test_flatten]. 52 | However, here the cutoffs of all the data in [map_of_incrs] are set to [always], 53 | which means changes in [map_of_incrs] should not porpagate to [result_incr] 54 | *) 55 | let test_flatten_with_cutoff map ~num_steps = 56 | let map_of_vars = Map.map map ~f:Incr.Var.create in 57 | let map_of_incrs = Map.map map_of_vars ~f:Incr.Var.watch in 58 | let result_incr = Incr.Map.flatten map_of_incrs in 59 | let result_obs = Incr.observe result_incr in 60 | (* set the cutoff of the data in [map_of_incrs] to [always] *) 61 | Map.iter map_of_incrs ~f:(fun incr -> Incr.set_cutoff incr Incr.Cutoff.always); 62 | let test_value () = 63 | (* Check the value of [result_incr] against the initial data values of 64 | [map_of_incrs], which are equal to the values in [map] *) 65 | Incr.stabilize (); 66 | [%test_result: float Int.Map.t] (Incr.Observer.value_exn result_obs) ~expect:map 67 | in 68 | let stabilize_and_test_result () = 69 | Incr.stabilize (); 70 | test_value () 71 | in 72 | stabilize_and_test_result (); 73 | for _ = 0 to num_steps do 74 | Rand_map_helper.rand_set_in_map_of_vars map_of_vars; 75 | stabilize_and_test_result () 76 | done 77 | ;; 78 | 79 | let%test_unit "rand test: stabilize every step, always cut off" = 80 | let start_map = Rand_map_helper.init_rand_map ~from:0 ~to_:30 in 81 | test_flatten_with_cutoff start_map ~num_steps:10 82 | ;; 83 | end 84 | -------------------------------------------------------------------------------- /test/test_for_alli_and_existsi.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let quickcheck_test ~incremental ~non_incremental = 5 | let f ~key ~data = String.contains data 'a' && key % 2 = 0 in 6 | let var = Incr.Var.create Int.Map.empty in 7 | let observer = 8 | Incremental.observe (incremental ?data_equal:None (Incr.Var.watch var) ~f) 9 | in 10 | Quickcheck.test 11 | (Map_operations.quickcheck_generator [%quickcheck.generator: string]) 12 | ~f:(fun operations -> 13 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 14 | [%test_result: bool] 15 | ~expect:(non_incremental (Incr.Var.latest_value var) ~f) 16 | (Incremental.Observer.value_exn observer))) 17 | ;; 18 | 19 | let%test_unit "Incr_map.for_alli" = 20 | quickcheck_test 21 | ~incremental:(Incr_map.for_alli ?instrumentation:None) 22 | ~non_incremental:(Map.for_alli :> _ -> f:(key:_ -> data:_ -> _) -> _) 23 | ;; 24 | 25 | let%test_unit "Incr_map.existsi" = 26 | quickcheck_test 27 | ~incremental:(Incr_map.existsi ?instrumentation:None) 28 | ~non_incremental:(Map.existsi :> _ -> f:(key:_ -> data:_ -> _) -> _) 29 | ;; 30 | -------------------------------------------------------------------------------- /test/test_for_alli_and_existsi.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_generics.ml: -------------------------------------------------------------------------------- 1 | (* This code tests that generic functions can operate on [Incr_map.Make] values. *) 2 | 3 | open! Core 4 | open! Import 5 | module I = Incremental.Make () 6 | module M = Incr_map.Make (I) 7 | 8 | let%expect_test _ = 9 | let i = I.return (Map.singleton (module Int) 0 "hello") in 10 | let (_ : _) = M.mapi i ~f:(fun ~key:_ ~data -> data) in 11 | let (_ : _) = Incr_map.mapi i ~f:(fun ~key:_ ~data -> data) in 12 | let lookup = M.Lookup.create (module Int) i in 13 | let (_ : _) = M.Lookup.find lookup 0 in 14 | let (_ : _) = Incr_map.Lookup.find lookup 0 in 15 | [%expect {| |}] 16 | ;; 17 | -------------------------------------------------------------------------------- /test/test_generics.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_index_by.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | module Odd_or_even = struct 5 | module T = struct 6 | type t = 7 | | Even 8 | | Odd 9 | [@@deriving sexp_of, compare, equal] 10 | end 11 | 12 | include T 13 | 14 | let of_int i = if i % 2 = 0 then Even else Odd 15 | 16 | include Comparable.Make_plain (T) 17 | end 18 | 19 | let%expect_test "Simple usage example" = 20 | let m = String.Map.of_alist_exn [ "a", 1; "b", 2; "c", 3 ] |> Incr.Var.create in 21 | let ib = 22 | Incr_map.index_by 23 | (Incr.Var.watch m) 24 | ~comparator:(module Odd_or_even) 25 | ~index:(fun v -> Option.some_if (v >= 0) (Odd_or_even.of_int v)) 26 | in 27 | let sexp_of_map = [%sexp_of: int String.Map.t Odd_or_even.Map.t] in 28 | let stabilize_and_get_sexp = 29 | let obs = Incr.observe ib in 30 | fun () -> 31 | Incr.stabilize (); 32 | sexp_of_map (Incr.Observer.value_exn obs) 33 | in 34 | let print_changes f = 35 | let original = stabilize_and_get_sexp () in 36 | Incr.Var.set m (f (Incr.Var.value m)); 37 | let updated = stabilize_and_get_sexp () in 38 | Expect_test_sexp_diff.print_sexp_diff original updated 39 | in 40 | print_s (stabilize_and_get_sexp ()); 41 | [%expect 42 | {| 43 | ((Even ((b 2))) 44 | (Odd ( 45 | (a 1) 46 | (c 3)))) 47 | |}]; 48 | print_changes (fun m -> Map.set m ~key:"a" ~data:2); 49 | [%expect 50 | {| 51 | ((Even ((Even 52 | ( ( 53 | + (a 2) 54 | (b 2))) (b 2))) 55 | (Odd (Odd 56 | ( ( 57 | - (a 1) 58 | (c 3)))) (c 3)))) 59 | |}]; 60 | print_changes (fun m -> Map.add_exn m ~key:"d" ~data:57); 61 | [%expect 62 | {| 63 | ((Even ((a 2) (b 2))) ((Even ((a 2) (b 2))) 64 | (Odd (Odd 65 | ((c 3) ((c 3) 66 | + (d 57) 67 | ))) ))) 68 | |}]; 69 | print_changes (fun m -> Map.add_exn m ~key:"e" ~data:(-1)); 70 | [%expect {| |}]; 71 | print_changes (fun m -> Map.set m ~key:"e" ~data:1); 72 | [%expect 73 | {| 74 | ((Even ((a 2) (b 2))) ((Even ((a 2) (b 2))) 75 | (Odd (Odd 76 | ((c 3) ((c 3) 77 | (d 57) (d 57) 78 | + (e 1) 79 | ))) ))) 80 | |}]; 81 | print_changes (fun m -> Map.remove m "b"); 82 | [%expect 83 | {| 84 | ((Even ((Even 85 | ((a 2) ((a 2) 86 | - (b 2) 87 | )) )) 88 | (Odd ((c 3) (d 57) (e 1)))) (Odd ((c 3) (d 57) (e 1)))) 89 | |}]; 90 | print_changes (fun m -> Map.set m ~key:"a" ~data:5); 91 | [%expect 92 | {| 93 | ( ( 94 | - (Even ((a 2))) 95 | (Odd (Odd 96 | ( ( 97 | + (a 5) 98 | (c 3) (c 3) 99 | (d 57) (d 57) 100 | (e 1)))) (e 1)))) 101 | |}]; 102 | () 103 | ;; 104 | 105 | let%test_unit "[Incr_map.index_byi] quickcheck" = 106 | let index ~key ~data:_ = Some (Odd_or_even.of_int key) in 107 | let all_at_once map ~comparator ~index = 108 | Map.to_alist map 109 | |> List.filter_map ~f:(fun (key, data) -> 110 | match index ~key ~data with 111 | | None -> None 112 | | Some index -> Some (index, (key, data))) 113 | |> Map.of_alist_multi comparator 114 | |> Map.map ~f:(Map.of_alist_exn (Map.comparator_s map)) 115 | in 116 | let var = Incr.Var.create Int.Map.empty in 117 | let observer = 118 | Incr_map.index_byi (Incr.Var.watch var) ~comparator:(module Odd_or_even) ~index 119 | |> Incr.observe 120 | in 121 | Quickcheck.test 122 | (Map_operations.quickcheck_generator String.quickcheck_generator) 123 | ~f:(fun operations -> 124 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 125 | [%test_result: string Int.Map.t Odd_or_even.Map.t] 126 | ~expect:(Incr.Observer.value_exn observer) 127 | (all_at_once 128 | (Incr.Var.latest_value var) 129 | ~comparator:(module Odd_or_even) 130 | ~index))) 131 | ;; 132 | -------------------------------------------------------------------------------- /test/test_instrument.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | let instrumentation = 5 | { Incr_map.Instrumentation.f = 6 | (fun f -> 7 | print_endline "starting!"; 8 | let r = f () in 9 | print_endline "finishing!"; 10 | r) 11 | } 12 | ;; 13 | 14 | let%expect_test _ = 15 | let map = Incr.Var.create (String.Map.of_alist_exn [ "a", 1; "b", 2 ]) in 16 | let map_o = Incr.observe (Incr.Var.watch map) in 17 | let sum_o = 18 | Incr_map.unordered_fold 19 | ~instrumentation 20 | (Incr.Var.watch map) 21 | ~data_equal:Int.equal 22 | ~init:0 23 | ~add:(fun ~key:_ ~data:v acc -> acc + v) 24 | ~remove:(fun ~key:_ ~data:v acc -> acc - v) 25 | |> Incr.observe 26 | in 27 | let dump () = 28 | Incr.stabilize (); 29 | let value = Incr.Observer.value_exn in 30 | Sexp.to_string_hum ([%sexp_of: int * int String.Map.t] (value sum_o, value map_o)) 31 | |> print_endline 32 | in 33 | let change f = Incr.Var.set map (f (Incr.Var.value map)) in 34 | dump (); 35 | [%expect 36 | {| 37 | starting! 38 | finishing! 39 | (3 ((a 1) (b 2))) 40 | |}]; 41 | change (fun m -> Map.set m ~key:"c" ~data:4); 42 | dump (); 43 | [%expect 44 | {| 45 | starting! 46 | finishing! 47 | (7 ((a 1) (b 2) (c 4))) 48 | |}]; 49 | (* This doesn't trigger the instrumentation because of cutoff *) 50 | change (fun m -> m); 51 | dump (); 52 | [%expect {| (7 ((a 1) (b 2) (c 4))) |}] 53 | ;; 54 | -------------------------------------------------------------------------------- /test/test_join.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | let%expect_test "check join against slow implementation" = 5 | let input_shape = Incr.Var.create Int.Map.empty in 6 | let watch_shape = Incr.Var.watch input_shape in 7 | let via_incr = Incr.observe (Incr.Map.join watch_shape) 8 | and via_map = 9 | Incr.observe 10 | (let open Incr.Let_syntax in 11 | let%bind shape = watch_shape in 12 | let%map alist = 13 | Incr.all 14 | (Map.to_sequence shape 15 | |> Sequence.map ~f:(fun (key, data) -> Incr.map data ~f:(Tuple2.create key)) 16 | |> Sequence.to_list_rev) 17 | in 18 | Map.Using_comparator.of_alist_exn ~comparator:(Map.comparator shape) alist) 19 | in 20 | let test_now () = 21 | Incr.stabilize (); 22 | print_s [%sexp (Incr.Observer.value_exn via_map : string Int.Map.t)]; 23 | [%test_result: string Int.Map.t] 24 | ~expect:(Incr.Observer.value_exn via_map) 25 | (Incr.Observer.value_exn via_incr) 26 | and set_map alist = Incr.Var.set input_shape (Int.Map.of_alist_exn alist) in 27 | (* This tests for the empty map initialisation problem. *) 28 | test_now (); 29 | [%expect {| () |}]; 30 | (* Some other tests manually messing around with the vars. *) 31 | let one_var = Incr.Var.create "one" in 32 | let one_incr = Incr.Var.watch one_var in 33 | set_map [ 1, one_incr ]; 34 | test_now (); 35 | [%expect {| ((1 one)) |}]; 36 | let one_incr = 37 | let new_one_incr = Incr.map ~f:Fn.id one_incr in 38 | assert (not (phys_same one_incr new_one_incr)); 39 | assert (not (phys_equal one_incr new_one_incr)); 40 | new_one_incr 41 | in 42 | set_map [ 1, one_incr ]; 43 | test_now (); 44 | [%expect {| ((1 one)) |}]; 45 | Incr.Var.set one_var "two"; 46 | test_now (); 47 | [%expect {| ((1 two)) |}]; 48 | let two_var = Incr.Var.create "two" in 49 | let two_incr = Incr.Var.watch two_var in 50 | Incr.Var.set one_var "one"; 51 | set_map [ 1, one_incr; 2, two_incr ]; 52 | test_now (); 53 | [%expect 54 | {| 55 | ((1 one) 56 | (2 two)) 57 | |}]; 58 | let test_with = 59 | let vars = ref Int.Map.empty 60 | and incrs = ref Int.Map.empty 61 | and old_map = ref Int.Map.empty in 62 | fun alist -> 63 | let map = Int.Map.of_alist_exn alist in 64 | Map.symmetric_diff !old_map map ~data_equal:String.equal 65 | |> Sequence.iter ~f:(fun (key, change) -> 66 | match change with 67 | | `Left _ -> 68 | vars := Map.remove !vars key; 69 | incrs := Map.remove !incrs key 70 | | `Right new_value -> 71 | let new_var = Incr.Var.create new_value in 72 | vars := Map.set !vars ~key ~data:new_var; 73 | incrs := Map.set !incrs ~key ~data:(Incr.Var.watch new_var) 74 | | `Unequal (_, new_value) -> Incr.Var.set (Map.find_exn !vars key) new_value); 75 | old_map := map; 76 | Incr.Var.set input_shape !incrs; 77 | test_now () 78 | in 79 | test_with [ 1, "one" ]; 80 | [%expect {| ((1 one)) |}]; 81 | test_with [ 1, "two"; 3, "three" ]; 82 | [%expect 83 | {| 84 | ((1 two) 85 | (3 three)) 86 | |}]; 87 | test_with [ 1, "one"; 2, "two" ]; 88 | [%expect 89 | {| 90 | ((1 one) 91 | (2 two)) 92 | |}]; 93 | test_with [ 1, "five"; 3, "three"; 4, "four" ]; 94 | [%expect 95 | {| 96 | ((1 five) 97 | (3 three) 98 | (4 four)) 99 | |}]; 100 | test_with []; 101 | [%expect {| () |}]; 102 | test_with [ 1, "five"; 3, "three"; 4, "four" ]; 103 | [%expect 104 | {| 105 | ((1 five) 106 | (3 three) 107 | (4 four)) 108 | |}]; 109 | test_with [ 1, "one"; 2, "two" ]; 110 | [%expect 111 | {| 112 | ((1 one) 113 | (2 two)) 114 | |}] 115 | ;; 116 | 117 | module%test [@name "random tests"] _ = struct 118 | (* [Incr.Map.join] is tested as follows: 119 | 120 | First, create [map_of_incrs_incr] of type [float Incr.t Int.Map.t Incr.t] with 121 | initial values equal to those in [map]. 122 | 123 | Next, apply [Incr.Map.join] to [map_of_incrs_incr] to get [result_incr]. 124 | 125 | At each of the [num_steps] steps, randomly change the value of [map_of_incrs] in 126 | one of two ways: 127 | - add, remove, or replace a single entry in the map 128 | - set the [Incr.Var.t] corresponding to the data of a single entry to a new value 129 | 130 | Every [stabilize_every_n] steps, check the result as follows: 131 | - call [Incr.stabilize ()] 132 | - check the value of [result_incr] 133 | *) 134 | let test_join map ~steps ~stabilize_every_n = 135 | let map_of_vars_var = Incr.Var.create (Map.map map ~f:Incr.Var.create) in 136 | let map_of_vars_incr = Incr.Var.watch map_of_vars_var in 137 | let map_of_incrs_incr = Incr.map map_of_vars_incr ~f:(Map.map ~f:Incr.Var.watch) in 138 | let result_incr = Incr.Map.join map_of_incrs_incr in 139 | let result_obs = Incr.observe result_incr in 140 | (* Since [result_incr] was obtained as [Incr.Map.join map_of_incrs_incr], check the 141 | value of [result_incr] against the data values in [map_of_incrs_incr] *) 142 | let test_value () = 143 | Incr.stabilize (); 144 | [%test_result: float Int.Map.t] 145 | (Incr.Observer.value_exn result_obs) 146 | ~expect:(Map.map (Incr.Var.value map_of_vars_var) ~f:Incr.Var.value) 147 | in 148 | let stabilize_and_test_result () = 149 | Incr.stabilize (); 150 | test_value () 151 | in 152 | stabilize_and_test_result (); 153 | List.iter (List.range 0 steps) ~f:(fun i -> 154 | let map_of_vars = 155 | Rand_map_helper.rand_modify_map_of_vars (Incr.Var.value map_of_vars_var) 156 | in 157 | if i % stabilize_every_n = 0 158 | then ( 159 | Incr.Var.set map_of_vars_var map_of_vars; 160 | stabilize_and_test_result ())) 161 | ;; 162 | 163 | let%test_unit "rand test: start with empty map, stabilize every step" = 164 | test_join Int.Map.empty ~steps:100 ~stabilize_every_n:1 165 | ;; 166 | 167 | let%test_unit "rand test: start with non-empty map, stabilize every step" = 168 | let start_map = Rand_map_helper.init_rand_map ~from:0 ~to_:30 in 169 | test_join start_map ~steps:100 ~stabilize_every_n:1 170 | ;; 171 | 172 | let%test_unit "rand test: start with empty map, stabilize every 10 steps" = 173 | test_join Int.Map.empty ~steps:100 ~stabilize_every_n:10 174 | ;; 175 | end 176 | -------------------------------------------------------------------------------- /test/test_keys.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | let%test_unit "correctness" = 5 | let with_init_value init f = 6 | let map_var = Incr.Var.create init in 7 | let set_obs = map_var |> Incr.Var.watch |> Incr.Map.keys |> Incr.observe in 8 | let update_and_check m = 9 | let expect = Map.key_set m in 10 | Incr.Var.set map_var m; 11 | Incr.stabilize (); 12 | [%test_result: Int.Set.t] ~expect (Incr.Observer.value_exn set_obs) 13 | in 14 | f update_and_check 15 | in 16 | List.iter [ 0; 16; 32 ] ~f:(fun len -> 17 | let init = Int.Map.of_alist_exn (List.init len ~f:(fun i -> i, i)) in 18 | with_init_value init (fun update_and_check -> 19 | let current_set = ref init in 20 | Quickcheck.iter 21 | ~trials:100 22 | [%quickcheck.generator: 23 | bool 24 | * [%custom Quickcheck.Generator.small_positive_int] 25 | * [%custom Quickcheck.Generator.small_positive_int]] 26 | ~f:(fun (add, key, data) -> 27 | let updated_map = 28 | match add with 29 | | true -> Map.set !current_set ~key ~data 30 | | false -> Map.remove !current_set key 31 | in 32 | current_set := updated_map; 33 | update_and_check updated_map)); 34 | with_init_value init (fun update_and_check -> 35 | Quickcheck.test 36 | ~examples:[ [] ] 37 | ~trials:100 38 | [%quickcheck.generator: [%custom Quickcheck.Generator.small_positive_int] list] 39 | ~f:(fun l -> 40 | l |> List.mapi ~f:Tuple2.create |> Int.Map.of_alist_exn |> update_and_check))) 41 | ;; 42 | -------------------------------------------------------------------------------- /test/test_observe_changes_exn.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | let%expect_test "basic" = 4 | let module Incr = Incremental.Make () in 5 | let m = Incr.Var.create Int.Map.empty in 6 | let f update = 7 | [%sexp_of: (int, int) Map.Symmetric_diff_element.t] update |> Core.print_s 8 | in 9 | Incr_map.observe_changes_exn (Incr.Var.watch m) ~f; 10 | let set_to alist = 11 | Incr.Var.set m (Int.Map.of_alist_exn alist); 12 | Incr.stabilize () 13 | in 14 | set_to [ 3, 0; 4, 0; 5, 0 ]; 15 | [%expect 16 | {| 17 | (3 (Right 0)) 18 | (4 (Right 0)) 19 | (5 (Right 0)) 20 | |}]; 21 | set_to [ 3, 1; 5, 0 ]; 22 | [%expect 23 | {| 24 | (3 (Unequal (0 1))) 25 | (4 (Left 0)) 26 | |}] 27 | ;; 28 | 29 | let%expect_test "banned inside bind" = 30 | let module Incr = Incremental.Make () in 31 | let open Incr.Let_syntax in 32 | let b = Incr.Var.create true in 33 | let m = Incr.Var.create Int.Map.empty in 34 | let result = 35 | if%bind Incr.Var.watch b 36 | then ( 37 | let f update = 38 | [%sexp_of: (int, int) Map.Symmetric_diff_element.t] update |> Core.print_s 39 | in 40 | Incr_map.observe_changes_exn (Incr.Var.watch m) ~f; 41 | return ()) 42 | else return () 43 | in 44 | let (_ : unit Incr.Observer.t) = Incr.observe result in 45 | Expect_test_helpers_core.require_does_raise (fun () -> Incr.stabilize ()); 46 | [%expect 47 | {| 48 | (Failure 49 | "[Incr_map.observe_changes_exn] called in scope that is not top-level") 50 | |}] 51 | ;; 52 | -------------------------------------------------------------------------------- /test/test_observe_changes_exn.mli: -------------------------------------------------------------------------------- 1 | (* Empty *) 2 | -------------------------------------------------------------------------------- /test/test_of_set.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | let%test_unit "correctness" = 5 | let with_init_value init f = 6 | let set_var = Incr.Var.create init in 7 | let map_obs = set_var |> Incr.Var.watch |> Incr.Map.of_set |> Incr.observe in 8 | let update_and_check s = 9 | let comparator = Set.comparator s in 10 | let expect = 11 | s 12 | |> Set.to_list 13 | |> List.map ~f:(fun i -> i, ()) 14 | |> Map.Using_comparator.of_alist_exn ~comparator 15 | in 16 | Incr.Var.set set_var s; 17 | Incr.stabilize (); 18 | [%test_result: unit Int.Map.t] ~expect (Incr.Observer.value_exn map_obs) 19 | in 20 | f update_and_check 21 | in 22 | List.iter [ 0; 16; 32 ] ~f:(fun len -> 23 | let init = Int.Set.of_list (List.init len ~f:Fn.id) in 24 | with_init_value init (fun update_and_check -> 25 | let current_set = ref init in 26 | Quickcheck.iter 27 | ~trials:100 28 | (Quickcheck.Generator.tuple2 29 | Quickcheck.Generator.bool 30 | Quickcheck.Generator.small_positive_int) 31 | ~f:(fun (add, key) -> 32 | let change = if add then Set.add else Set.remove in 33 | current_set := change !current_set key; 34 | update_and_check !current_set)); 35 | with_init_value init (fun update_and_check -> 36 | Quickcheck.test 37 | ~examples:[ [] ] 38 | ~trials:100 39 | (Quickcheck.Generator.list Quickcheck.Generator.small_positive_int) 40 | ~f:(fun l -> update_and_check (Int.Set.of_list l)))) 41 | ;; 42 | -------------------------------------------------------------------------------- /test/test_partition_map.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module%test _ = struct 5 | let f ~key:_ ~data = 6 | match data mod 2 = 0 with 7 | | true -> First (sprintf "N=%d" data) 8 | | false -> Second data 9 | ;; 10 | 11 | let%expect_test "manual updates" = 12 | let var = [ "a", 1; "b", 2 ] |> String.Map.of_alist_exn |> Incr.Var.create in 13 | let observer = Incr.observe (Incr_map.partition_mapi ~f (Incr.Var.watch var)) in 14 | let update_and_test ~f = 15 | Incr.Var.replace var ~f; 16 | Incr.stabilize (); 17 | print_s 18 | [%sexp 19 | (Incr.Observer.value_exn observer : string String.Map.t * int String.Map.t)] 20 | in 21 | update_and_test ~f:Fn.id; 22 | [%expect 23 | {| 24 | (((b N=2)) 25 | ((a 1))) 26 | |}]; 27 | update_and_test ~f:(fun m -> Map.add_exn m ~key:"c" ~data:3); 28 | [%expect 29 | {| 30 | (((b N=2)) 31 | ((a 1) 32 | (c 3))) 33 | |}]; 34 | update_and_test ~f:(fun m -> Map.remove m "b"); 35 | [%expect 36 | {| 37 | (() 38 | ((a 1) 39 | (c 3))) 40 | |}]; 41 | update_and_test ~f:(fun m -> Map.set m ~key:"c" ~data:100); 42 | [%expect 43 | {| 44 | (((c N=100)) 45 | ((a 1))) 46 | |}]; 47 | update_and_test ~f:(fun m -> Map.set m ~key:"d" ~data:11); 48 | [%expect 49 | {| 50 | (((c N=100)) 51 | ((a 1) 52 | (d 11))) 53 | |}] 54 | ;; 55 | 56 | let%test_unit "randomized map changes" = 57 | let var = Incr.Var.create Int.Map.empty in 58 | let observer = 59 | Incremental.observe (Incr_map.partition_mapi (Incr.Var.watch var) ~f) 60 | in 61 | Quickcheck.test 62 | (Map_operations.quickcheck_generator [%quickcheck.generator: int]) 63 | ~f:(fun operations -> 64 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 65 | [%test_result: string Int.Map.t * int Int.Map.t] 66 | ~expect:(Map.partition_mapi (Incr.Var.latest_value var) ~f) 67 | (Incremental.Observer.value_exn observer))) 68 | ;; 69 | end 70 | 71 | module%test [@name "partition_mapi'"] _ = struct 72 | let f ~key:_ ~data = 73 | match data mod 2 = 0 with 74 | | true -> First (sprintf "N=%d" data) 75 | | false -> Second data 76 | ;; 77 | 78 | let incr_f ~key ~data = 79 | let%map data in 80 | f ~key ~data 81 | ;; 82 | 83 | let%expect_test "manual updates" = 84 | let var = [ "a", 1; "b", 2 ] |> String.Map.of_alist_exn |> Incr.Var.create in 85 | let observer = 86 | Incr.observe (Incr_map.partition_mapi' ~f:incr_f (Incr.Var.watch var)) 87 | in 88 | let update_and_test ~f = 89 | Incr.Var.replace var ~f; 90 | Incr.stabilize (); 91 | print_s 92 | [%sexp 93 | (Incr.Observer.value_exn observer : string String.Map.t * int String.Map.t)] 94 | in 95 | update_and_test ~f:Fn.id; 96 | [%expect 97 | {| 98 | (((b N=2)) 99 | ((a 1))) 100 | |}]; 101 | update_and_test ~f:(fun m -> Map.add_exn m ~key:"c" ~data:3); 102 | [%expect 103 | {| 104 | (((b N=2)) 105 | ((a 1) 106 | (c 3))) 107 | |}]; 108 | update_and_test ~f:(fun m -> Map.remove m "b"); 109 | [%expect 110 | {| 111 | (() 112 | ((a 1) 113 | (c 3))) 114 | |}]; 115 | update_and_test ~f:(fun m -> Map.set m ~key:"c" ~data:100); 116 | [%expect 117 | {| 118 | (((c N=100)) 119 | ((a 1))) 120 | |}]; 121 | update_and_test ~f:(fun m -> Map.set m ~key:"d" ~data:11); 122 | [%expect 123 | {| 124 | (((c N=100)) 125 | ((a 1) 126 | (d 11))) 127 | |}] 128 | ;; 129 | 130 | let%test_unit "randomized map changes" = 131 | let var = Incr.Var.create Int.Map.empty in 132 | let observer = 133 | Incremental.observe (Incr_map.partition_mapi' (Incr.Var.watch var) ~f:incr_f) 134 | in 135 | Quickcheck.test 136 | (Map_operations.quickcheck_generator [%quickcheck.generator: int]) 137 | ~f:(fun operations -> 138 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 139 | [%test_result: string Int.Map.t * int Int.Map.t] 140 | ~expect:(Map.partition_mapi (Incr.Var.latest_value var) ~f) 141 | (Incremental.Observer.value_exn observer))) 142 | ;; 143 | end 144 | -------------------------------------------------------------------------------- /test/test_rank.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module M = Rand_map_helper 4 | 5 | let assert_same ~iterations ~stabilize_every ~mutator = 6 | let map = M.init_rand_map ~from:25 ~to_:150 in 7 | let key = M.get_rand_existing_key map in 8 | let map_var = Incr.Var.create map in 9 | let key_var = Incr.Var.create key in 10 | let output = Incr_map.rank (Incr.Var.watch map_var) (Incr.Var.watch key_var) in 11 | let observed = Incr.observe output in 12 | (* this old_key ref is just for debugging *) 13 | let old_key = ref key in 14 | for i = 0 to iterations do 15 | let new_map, new_key = mutator (Incr.Var.value map_var) (Incr.Var.value key_var) in 16 | Incr.Var.set map_var new_map; 17 | Incr.Var.set key_var new_key; 18 | if 0 = i mod stabilize_every 19 | then ( 20 | Incr.stabilize (); 21 | let rank_computed_naively = Map.rank new_map new_key in 22 | let rank_computed_incrementally = Incr.Observer.value_exn observed in 23 | [%test_result: int option] rank_computed_incrementally ~expect:rank_computed_naively; 24 | old_key := new_key) 25 | done 26 | ;; 27 | 28 | let test ~mutator = 29 | for _ = 0 to 1000 do 30 | for stabilize_every = 1 to 5 do 31 | assert_same ~iterations:100 ~stabilize_every ~mutator 32 | done 33 | done 34 | ;; 35 | 36 | let%test_unit "make no changes" = test ~mutator:(fun map key -> map, key) 37 | let%test_unit "change map to empty" = test ~mutator:(fun _ key -> Int.Map.empty, key) 38 | 39 | let%test_unit "remove entries from map" = 40 | test ~mutator:(fun map key -> M.rand_remove_from_map map, key) 41 | ;; 42 | 43 | let%test_unit "add entries to map" = 44 | test ~mutator:(fun map key -> M.rand_add_to_map map, key) 45 | ;; 46 | 47 | let%test_unit "add and remove entries from map" = 48 | test ~mutator:(fun map key -> 49 | let map = 50 | if Float.O.(M.rand () < 0.5) then M.rand_add_to_map map else M.rand_add_to_map map 51 | in 52 | map, key) 53 | ;; 54 | 55 | let%test_unit "modify map" = test ~mutator:(fun map key -> M.rand_modify_map map, key) 56 | 57 | let%test_unit "if the key is in the map, remove it from the map, otherwise pick a new key" 58 | = 59 | test ~mutator:(fun map key -> 60 | if Map.mem map key then Map.remove map key, key else map, M.get_rand_existing_key map) 61 | ;; 62 | 63 | let%test_unit "pick random keys" = 64 | test ~mutator:(fun map _key -> map, M.get_rand_existing_key map) 65 | ;; 66 | 67 | let%test_unit "remove elements from map and pick random keys" = 68 | test ~mutator:(fun map _key -> 69 | let map = M.rand_remove_from_map map in 70 | map, M.get_rand_existing_key map) 71 | ;; 72 | 73 | let%test_unit "remove elements from map and pick random keys, but with a probability of \ 74 | picking the key that was just removed, oh no!" 75 | = 76 | test ~mutator:(fun map _key -> M.rand_remove_from_map map, M.get_rand_existing_key map) 77 | ;; 78 | 79 | let%test_unit "add elements to map and pick random keys, but with a probability of \ 80 | picking the key that was just added, oh no!" 81 | = 82 | test ~mutator:(fun map _key -> 83 | let map = M.rand_add_to_map map in 84 | map, M.get_rand_existing_key map) 85 | ;; 86 | 87 | let%test_unit "add elements to map and pick random keys" = 88 | test ~mutator:(fun map _key -> M.rand_add_to_map map, M.get_rand_existing_key map) 89 | ;; 90 | 91 | let%test_unit "modify map and pick random keys from new map" = 92 | test ~mutator:(fun map _key -> 93 | let map = M.rand_modify_map map in 94 | map, M.get_rand_existing_key map) 95 | ;; 96 | 97 | let%test_unit "modify map and pick random keys from old map" = 98 | test ~mutator:(fun map _key -> M.rand_modify_map map, M.get_rand_existing_key map) 99 | ;; 100 | 101 | let%test_unit "modify map and pick random keys, but with a 50% probabily of the key not \ 102 | being in new map" 103 | = 104 | test ~mutator:(fun map _key -> 105 | let map = M.rand_modify_map map in 106 | let key = 107 | if Float.O.(M.rand () < 0.5) 108 | then M.get_rand_existing_key map 109 | else M.get_rand_nonexistent_key map 110 | in 111 | map, key) 112 | ;; 113 | -------------------------------------------------------------------------------- /test/test_rekey.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%test_unit "rekey random test" = 5 | Quickcheck.test 6 | ~sexp_of:[%sexp_of: (int, int) Map_operations.t list] 7 | (Map_operations.quickcheck_generator Int.quickcheck_generator) 8 | ~f:(fun operations -> 9 | let m = Incr.Var.create Int.Map.empty in 10 | let watch_m = Incr.Var.watch m in 11 | let fast = 12 | Incr_map.rekey 13 | ~comparator:(module String) 14 | watch_m 15 | ~f:(fun ~key ~data:_ -> Int.to_string key) 16 | in 17 | let slow = 18 | let%map watch_m in 19 | watch_m 20 | |> Map.to_alist 21 | |> List.map ~f:(fun (k, v) -> Int.to_string k, v) 22 | |> Map.of_alist_exn (module String) 23 | in 24 | let fast_obs = Incr.observe fast in 25 | let slow_obs = Incr.observe slow in 26 | Map_operations.run_operations operations ~into:m ~after_stabilize:(fun () -> 27 | [%test_result: int String.Map.t] 28 | ~expect:(Incr.Observer.value_exn fast_obs) 29 | (Incr.Observer.value_exn slow_obs))) 30 | ;; 31 | 32 | let%expect_test "rekey should order adds and removes properly" = 33 | (* Rekey relies on the callback function not mapping two keys in the map to 34 | the same value. However, it should have no problem shrinking the key 35 | space, though this is less easily achieved. What could happen (and what 36 | this test checks for) is that at the same time one key is added and a 37 | different key removed, but both keys are mapped into the same final key. 38 | This should be legal, but it is easy for a naive implementation to 39 | accidentally add the element first, and then remove it immediately 40 | afterward (or, if it used [add_exn], it might raise before even removing). *) 41 | let m = Incr.Var.create Int.Map.empty in 42 | let watch_m = Incr.Var.watch m in 43 | let result = 44 | Incr_map.rekey ~comparator:(module Int) watch_m ~f:(fun ~key ~data:_ -> key mod 3) 45 | in 46 | let result_obs = Incr.observe result in 47 | let set_to alist = Incr.Var.set m (Int.Map.of_alist_exn alist) in 48 | let stabilize_and_print () = 49 | Incr.stabilize (); 50 | print_s [%sexp (Incr.Observer.value_exn result_obs : int Int.Map.t)] 51 | in 52 | stabilize_and_print (); 53 | [%expect {| () |}]; 54 | set_to [ 3, 0; 4, 1; 5, 2 ]; 55 | stabilize_and_print (); 56 | [%expect 57 | {| 58 | ((0 0) 59 | (1 1) 60 | (2 2)) 61 | |}]; 62 | set_to [ 0, 0; 1, 1; 2, 2 ]; 63 | stabilize_and_print (); 64 | [%expect 65 | {| 66 | ((0 0) 67 | (1 1) 68 | (2 2)) 69 | |}] 70 | ;; 71 | 72 | let%expect_test "rekey should order adds and removes properly (part 2)" = 73 | (* This test checks the situation in which an entry's value is updated such 74 | that the entry's key is mapped to a removed key. *) 75 | let m = Incr.Var.create Int.Map.empty in 76 | let watch_m = Incr.Var.watch m in 77 | let result = 78 | Incr_map.rekey 79 | ~comparator:(module Int) 80 | watch_m 81 | ~f:(fun ~key ~data -> (key mod 3) + data) 82 | in 83 | let result_obs = Incr.observe result in 84 | let set_to alist = Incr.Var.set m (Int.Map.of_alist_exn alist) in 85 | let stabilize_and_print () = 86 | Incr.stabilize (); 87 | print_s [%sexp (Incr.Observer.value_exn result_obs : int Int.Map.t)] 88 | in 89 | stabilize_and_print (); 90 | [%expect {| () |}]; 91 | set_to [ 3, 0; 4, 0; 5, 0 ]; 92 | stabilize_and_print (); 93 | [%expect 94 | {| 95 | ((0 0) 96 | (1 0) 97 | (2 0)) 98 | |}]; 99 | set_to [ 3, 1; 5, 0 ]; 100 | stabilize_and_print (); 101 | [%expect 102 | {| 103 | ((1 1) 104 | (2 0)) 105 | |}] 106 | ;; 107 | -------------------------------------------------------------------------------- /test/test_separate.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | let%expect_test "separate -> join" = 5 | let input_original_map = Incr.Var.create String.Map.empty in 6 | let original_map = Incr.observe (Incr.Var.watch input_original_map) in 7 | let separated_map = 8 | Incr.observe 9 | (Incr.Map.separate (Incr.Observer.observing original_map) ~data_equal:Int.equal) 10 | in 11 | Incr.Observer.on_update_exn separated_map ~f:(fun change -> 12 | let old_, new_ = 13 | match change with 14 | | Invalidated -> failwith "Should not be invalidated" 15 | | Initialized new_ -> String.Map.empty, new_ 16 | | Changed (old_, new_) -> old_, new_ 17 | in 18 | Map.symmetric_diff old_ new_ ~data_equal:phys_equal 19 | |> Sequence.iter ~f:(fun (key, change) -> 20 | match change with 21 | | `Left _ -> print_s [%message "removed_node" ~_:(key : string)] 22 | | `Right _ -> print_s [%message "added_node" ~_:(key : string)] 23 | | `Unequal _ -> failwith "Should not remake a node for a key")); 24 | let rejoined_map = 25 | Incr.observe (Incr.Map.join (Incr.Observer.observing separated_map)) 26 | in 27 | Incr.Observer.on_update_exn rejoined_map ~f:(fun change -> 28 | let old_, new_ = 29 | match change with 30 | | Invalidated -> failwith "Should not be invalidated" 31 | | Initialized new_ -> String.Map.empty, new_ 32 | | Changed (old_, new_) -> old_, new_ 33 | in 34 | print_s [%message "current_map" ~_:(new_ : int String.Map.t)]; 35 | Map.symmetric_diff old_ new_ ~data_equal:Int.equal 36 | |> Sequence.iter ~f:(fun (key, change) -> 37 | match change with 38 | | `Left x -> print_s [%message "removed" (key : string) ~_:(x : int)] 39 | | `Right x -> print_s [%message "added" (key : string) ~_:(x : int)] 40 | | `Unequal (from, into) -> 41 | print_s [%message "changed" (key : string) (from : int) (into : int)])); 42 | let run_test alist = 43 | Incr.Var.set input_original_map (String.Map.of_alist_exn alist); 44 | Incr.stabilize (); 45 | let original_map = Incr.Observer.value_exn original_map 46 | and rejoined_map = Incr.Observer.value_exn rejoined_map in 47 | require 48 | ([%compare.equal: int String.Map.t] original_map rejoined_map) 49 | ~if_false_then_print_s: 50 | (lazy 51 | [%message 52 | "maps_differ" 53 | (original_map : int String.Map.t) 54 | (rejoined_map : int String.Map.t)]) 55 | in 56 | run_test []; 57 | [%expect {| (current_map ()) |}]; 58 | run_test [ "a", 1 ]; 59 | [%expect 60 | {| 61 | (added_node a) 62 | (current_map ((a 1))) 63 | (added (key a) 1) 64 | |}]; 65 | run_test [ "a", 2 ]; 66 | [%expect 67 | {| 68 | (current_map ((a 2))) 69 | (changed 70 | (key a) 71 | (from 1) 72 | (into 2)) 73 | |}]; 74 | run_test [ "b", 3 ]; 75 | [%expect 76 | {| 77 | (removed_node a) 78 | (added_node b) 79 | (current_map ((b 3))) 80 | (removed (key a) 2) 81 | (added (key b) 3) 82 | |}]; 83 | run_test [ "b", 4 ]; 84 | [%expect 85 | {| 86 | (current_map ((b 4))) 87 | (changed 88 | (key b) 89 | (from 3) 90 | (into 4)) 91 | |}]; 92 | run_test [ "a", 1; "b", 2 ]; 93 | [%expect 94 | {| 95 | (added_node a) 96 | (current_map ( 97 | (a 1) 98 | (b 2))) 99 | (added (key a) 1) 100 | (changed 101 | (key b) 102 | (from 4) 103 | (into 2)) 104 | |}]; 105 | run_test [ "a", 10; "b", 20 ]; 106 | [%expect 107 | {| 108 | (current_map ( 109 | (a 10) 110 | (b 20))) 111 | (changed 112 | (key a) 113 | (from 1) 114 | (into 10)) 115 | (changed 116 | (key b) 117 | (from 2) 118 | (into 20)) 119 | |}]; 120 | run_test [ "a", 100; "b", 200 ]; 121 | [%expect 122 | {| 123 | (current_map ( 124 | (a 100) 125 | (b 200))) 126 | (changed 127 | (key a) 128 | (from 10) 129 | (into 100)) 130 | (changed 131 | (key b) 132 | (from 20) 133 | (into 200)) 134 | |}]; 135 | run_test [ "a", 100 ]; 136 | [%expect 137 | {| 138 | (removed_node b) 139 | (current_map ((a 100))) 140 | (removed (key b) 200) 141 | |}]; 142 | run_test [ "a", 100; "b", 3 ]; 143 | [%expect 144 | {| 145 | (added_node b) 146 | (current_map ( 147 | (a 100) 148 | (b 3))) 149 | (added (key b) 3) 150 | |}] 151 | ;; 152 | 153 | let%expect_test "separate -> join (but random)" = 154 | let input_original_map = 155 | Incr.Var.create (Rand_map_helper.init_rand_map ~from:0 ~to_:1000) 156 | in 157 | let original_map = Incr.observe (Incr.Var.watch input_original_map) in 158 | let rejoined_map = 159 | Incr.Var.watch input_original_map 160 | |> Incr.Map.separate ~data_equal:Float.equal 161 | |> Incr.Map.join 162 | |> Incr.observe 163 | in 164 | List.iter (List.range 0 1000) ~f:(fun _ -> 165 | let new_map = Rand_map_helper.rand_modify_map (Incr.Var.value input_original_map) in 166 | Incr.Var.set input_original_map new_map; 167 | Incr.stabilize (); 168 | let original_map = Incr.Observer.value_exn original_map 169 | and rejoined_map = Incr.Observer.value_exn rejoined_map in 170 | require 171 | ([%compare.equal: float Int.Map.t] original_map rejoined_map) 172 | ~if_false_then_print_s: 173 | (lazy 174 | [%message 175 | "maps_differ" 176 | (original_map : float Int.Map.t) 177 | (rejoined_map : float Int.Map.t)])) 178 | ;; 179 | 180 | let%expect_test "test for extra recalculations" = 181 | let the_var = Incr.Var.create String.Map.empty in 182 | let known_nodes = ref [] in 183 | let separated = Incr.Map.separate (Incr.Var.watch the_var) ~data_equal:Int.equal in 184 | Incr.set_cutoff separated Incr.Cutoff.never; 185 | let iter_over_map = 186 | Map.iteri ~f:(fun ~key ~data -> 187 | if not (List.mem ~equal:phys_equal !known_nodes data) 188 | then ( 189 | known_nodes := data :: !known_nodes; 190 | Incr.set_cutoff data Incr.Cutoff.never; 191 | Incr.Observer.on_update_exn (Incr.observe data) ~f:(function 192 | | Initialized v -> printf "Key %s initialized to %d\n" key v 193 | | Changed (old_v, new_v) -> 194 | printf "Key %s changed to %d (was %d)\n" key new_v old_v 195 | | Invalidated -> printf "Key %s invalidated\n" key))) 196 | in 197 | Incr.Observer.on_update_exn (Incr.observe separated) ~f:(function 198 | | Initialized initialized -> iter_over_map initialized 199 | | Changed (_old, new_map) -> iter_over_map new_map 200 | | Invalidated -> ()); 201 | let run_test alist = 202 | Incr.Var.set the_var (String.Map.of_alist_exn alist); 203 | Incr.stabilize (); 204 | Incr.stabilize () 205 | in 206 | run_test []; 207 | [%expect {| |}]; 208 | run_test [ "a", 1 ]; 209 | [%expect {| Key a initialized to 1 |}]; 210 | run_test [ "a", 2 ]; 211 | [%expect {| Key a changed to 2 (was 1) |}]; 212 | run_test [ "b", 3 ]; 213 | [%expect 214 | {| 215 | Key a invalidated 216 | Key b initialized to 3 217 | |}]; 218 | run_test [ "b", 4 ]; 219 | [%expect {| Key b changed to 4 (was 3) |}]; 220 | run_test [ "a", 1; "b", 2 ]; 221 | [%expect 222 | {| 223 | Key b changed to 2 (was 4) 224 | Key a initialized to 1 225 | |}]; 226 | run_test [ "a", 10; "b", 20 ]; 227 | [%expect 228 | {| 229 | Key b changed to 20 (was 2) 230 | Key a changed to 10 (was 1) 231 | |}]; 232 | run_test [ "a", 100; "b", 200 ]; 233 | [%expect 234 | {| 235 | Key b changed to 200 (was 20) 236 | Key a changed to 100 (was 10) 237 | |}]; 238 | run_test [ "a", 100 ]; 239 | [%expect {| Key b invalidated |}]; 240 | run_test [ "a", 100; "b", 3 ]; 241 | [%expect {| Key b initialized to 3 |}] 242 | ;; 243 | -------------------------------------------------------------------------------- /test/test_sum.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%test_unit "correctness" = 5 | let f x = x in 6 | let var = Incr.Var.create Int.Map.empty in 7 | let observer = 8 | Incremental.observe (Incr_map.sum (Incr.Var.watch var) (module Int) ~f) 9 | in 10 | Quickcheck.test 11 | (Map_operations.quickcheck_generator [%quickcheck.generator: int]) 12 | ~f:(fun operations -> 13 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 14 | [%test_result: int] 15 | ~expect:(Incr.Var.latest_value var |> Map.data |> List.sum (module Int) ~f) 16 | (Incremental.Observer.value_exn observer))) 17 | ;; 18 | -------------------------------------------------------------------------------- /test/test_sum.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_transpose.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%expect_test _ = 5 | let module K1 = String in 6 | let module K2 = Int in 7 | let module V = String in 8 | let m_v = Incr.Var.create K1.Map.empty in 9 | let change_m_v f = Incr.Var.set m_v (f (Incr.Var.value m_v)) in 10 | let change k1 k2 data = 11 | change_m_v (fun m -> 12 | Map.change m k1 ~f:(fun m_inner -> 13 | let m_inner = 14 | Map.change (Option.value m_inner ~default:K2.Map.empty) k2 ~f:(fun _ -> data) 15 | in 16 | if Map.is_empty m_inner then None else Some m_inner)) 17 | in 18 | let m_transposed = Incr_map.transpose (module K2) (Incr.Var.watch m_v) in 19 | let m_transposed_transposed = Incr_map.transpose (module K1) m_transposed in 20 | let m_transposed_o = Incr.observe m_transposed in 21 | let m_transposed_transposed_o = Incr.observe m_transposed_transposed in 22 | let show () = 23 | Incr.stabilize (); 24 | assert ( 25 | [%compare.equal: V.t K2.Map.t K1.Map.t] 26 | (Incr.Var.value m_v) 27 | (Incr.Observer.value m_transposed_transposed_o |> Or_error.ok_exn)); 28 | print_s 29 | [%message 30 | "" 31 | ~original:(Incr.Var.value m_v : V.t K2.Map.t K1.Map.t) 32 | ~tranposed: 33 | (Incr.Observer.value m_transposed_o |> Or_error.ok_exn 34 | : V.t K1.Map.t K2.Map.t)] 35 | in 36 | show (); 37 | [%expect 38 | {| 39 | ((original ()) 40 | (tranposed ())) 41 | |}]; 42 | change "a" 1 (Some "a_1"); 43 | change "b" 1 (Some "b_1"); 44 | show (); 45 | [%expect 46 | {| 47 | ((original ( 48 | (a ((1 a_1))) 49 | (b ((1 b_1))))) 50 | (tranposed (( 51 | 1 ( 52 | (a a_1) 53 | (b b_1)))))) 54 | |}]; 55 | change "c" 2 (Some "c_2"); 56 | change "d" 3 (Some "d_3"); 57 | change "e" 1 (Some "e_1"); 58 | change "a" 1 None; 59 | change "b" 1 (Some "b_1_prime"); 60 | show (); 61 | [%expect 62 | {| 63 | ((original ( 64 | (b ((1 b_1_prime))) 65 | (c ((2 c_2))) 66 | (d ((3 d_3))) 67 | (e ((1 e_1))))) 68 | (tranposed ( 69 | (1 ( 70 | (b b_1_prime) 71 | (e e_1))) 72 | (2 ((c c_2))) 73 | (3 ((d d_3)))))) 74 | |}] 75 | ;; 76 | -------------------------------------------------------------------------------- /test/test_unordered_fold_nested_maps.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module%test _ = struct 5 | let sum_nested_maps_incr map ~use_update = 6 | Incr.Map.unordered_fold_nested_maps 7 | ?update: 8 | (Option.some_if 9 | use_update 10 | (fun ~outer_key:_ ~inner_key:_ ~old_data ~new_data acc -> 11 | acc - old_data + new_data)) 12 | ~data_equal:( = ) 13 | map 14 | ~init:0 15 | ~add:(fun ~outer_key:_ ~inner_key:_ ~data:v acc -> acc + v) 16 | ~remove:(fun ~outer_key:_ ~inner_key:_ ~data:v acc -> acc - v) 17 | ;; 18 | 19 | let sum_nested_maps_all_at_once map = 20 | let%map map in 21 | Map.fold 22 | ~init:0 23 | ~f:(fun ~key:_ ~data:inner_map acc -> 24 | Map.fold inner_map ~init:acc ~f:(fun ~key:_ ~data acc -> data + acc)) 25 | map 26 | ;; 27 | 28 | let update_and_test ~initial_map ~dump = 29 | let map_var = Incr.Var.create initial_map in 30 | let map = Incr.Var.watch map_var in 31 | let all_at_once_observer = sum_nested_maps_all_at_once map |> Incr.observe in 32 | let incr_without_update_observer = 33 | sum_nested_maps_incr map ~use_update:false |> Incr.observe 34 | in 35 | let incr_with_update_observer = 36 | sum_nested_maps_incr map ~use_update:true |> Incr.observe 37 | in 38 | stage (fun ~f -> 39 | Incr.Var.set map_var (f (Incr.Var.value map_var)); 40 | Incr.stabilize (); 41 | let expect = Incr.Observer.value_exn all_at_once_observer in 42 | let result_without_update = Incr.Observer.value_exn incr_without_update_observer in 43 | let result_with_update = Incr.Observer.value_exn incr_with_update_observer in 44 | [%test_result: int] result_without_update ~message:"without update" ~expect; 45 | [%test_result: int] result_with_update ~message:"with update" ~expect; 46 | if dump 47 | then 48 | print_s 49 | [%sexp 50 | { sum = (result_without_update : int) 51 | ; map = (Incr.Var.value map_var : int String.Map.t String.Map.t) 52 | }]) 53 | ;; 54 | 55 | let%expect_test "manual updates" = 56 | let initial_map = 57 | String.Map.of_alist_exn 58 | (List.map 59 | ~f:(fun (outer_key, inner_alist) -> 60 | outer_key, String.Map.of_alist_exn inner_alist) 61 | [ "a", [ "a", 1 ]; "b", [ "b", 2 ] ]) 62 | in 63 | let update_and_test = update_and_test ~initial_map ~dump:true |> unstage in 64 | update_and_test ~f:Fn.id; 65 | [%expect 66 | {| 67 | ((sum 3) 68 | (map ( 69 | (a ((a 1))) 70 | (b ((b 2)))))) 71 | |}]; 72 | update_and_test ~f:(fun m -> 73 | Map.add_exn m ~key:"c" ~data:(String.Map.singleton "c" 4)); 74 | [%expect 75 | {| 76 | ((sum 7) 77 | (map ( 78 | (a ((a 1))) 79 | (b ((b 2))) 80 | (c ((c 4)))))) 81 | |}]; 82 | update_and_test ~f:(fun m -> Map.remove m "b"); 83 | [%expect 84 | {| 85 | ((sum 5) 86 | (map ( 87 | (a ((a 1))) 88 | (c ((c 4)))))) 89 | |}]; 90 | update_and_test ~f:(fun m -> Map.set m ~key:"c" ~data:(String.Map.singleton "c" 0)); 91 | [%expect 92 | {| 93 | ((sum 1) 94 | (map ( 95 | (a ((a 1))) 96 | (c ((c 0)))))) 97 | |}] 98 | ;; 99 | 100 | module Update = struct 101 | type t = 102 | | Remove_random_outer_key 103 | | Remove_random_inner_key 104 | | Add_key of 105 | { outer_key : string 106 | ; inner_key : string 107 | ; data : int 108 | } 109 | | Set_random_key of { data : int } 110 | [@@deriving quickcheck] 111 | end 112 | 113 | let%test_unit "unordered_fold_nested_maps is equivalent to all-at-once" = 114 | let initial_map = String.Map.empty in 115 | let random_map_key map = List.random_element (Map.keys map) in 116 | let apply_to_random_key m ~f = Option.value_map (random_map_key m) ~default:m ~f in 117 | let set_or_remove_random_value map data = 118 | apply_to_random_key map ~f:(fun outer_key -> 119 | Map.update map outer_key ~f:(function 120 | | None -> assert false 121 | | Some inner_map -> 122 | apply_to_random_key inner_map ~f:(fun inner_key -> 123 | Map.change inner_map inner_key ~f:(fun _ -> data)))) 124 | in 125 | let f (update : Update.t) map = 126 | match update with 127 | | Remove_random_outer_key -> apply_to_random_key map ~f:(Map.remove map) 128 | | Remove_random_inner_key -> set_or_remove_random_value map None 129 | | Set_random_key { data } -> set_or_remove_random_value map (Some data) 130 | | Add_key { outer_key; inner_key; data } -> 131 | Map.update map outer_key ~f:(fun inner_map -> 132 | Map.set (Option.value inner_map ~default:String.Map.empty) ~key:inner_key ~data) 133 | in 134 | let update_and_test = update_and_test ~initial_map ~dump:false |> unstage in 135 | update_and_test ~f:Fn.id; 136 | Quickcheck.test [%quickcheck.generator: Update.t list] ~f:(fun updates -> 137 | List.iter updates ~f:(fun update -> update_and_test ~f:(f update))) 138 | ;; 139 | end 140 | -------------------------------------------------------------------------------- /test/test_unordered_fold_with_extra.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let unordered_fold_with_extra 5 | (type k v a) 6 | ~(data_equal : v -> v -> bool) 7 | ~(acc_equal : a -> a -> bool) 8 | ?specialized_initial 9 | (m : (k, v, _) Map.t Incr.t) 10 | ~extra 11 | ~(init : a) 12 | ~add 13 | ~remove 14 | ~extra_changed 15 | = 16 | let a = 17 | Incr.Map.unordered_fold_with_extra 18 | ~data_equal 19 | ?specialized_initial 20 | m 21 | extra 22 | ~init 23 | ~add 24 | ~remove 25 | ~extra_changed 26 | in 27 | let b = 28 | let%map m and extra in 29 | Map.fold m ~init ~f:(fun ~key ~data acc -> add ~key ~data acc extra) 30 | in 31 | let%map a and b in 32 | require (acc_equal a b); 33 | a 34 | ;; 35 | 36 | let%expect_test _ = 37 | let map = Incr.Var.create (String.Map.of_alist_exn [ "a", 1; "b", 2 ]) in 38 | let extra = Incr.Var.create 2 in 39 | let sum_o = 40 | unordered_fold_with_extra 41 | (Incr.Var.watch map) 42 | ~extra:(Incr.Var.watch extra) 43 | ~data_equal:Int.equal 44 | ~acc_equal:Int.equal 45 | ~init:0 46 | ~add:(fun ~key:_ ~data:v acc extra -> acc + (v * extra)) 47 | ~remove:(fun ~key:_ ~data:v acc extra -> acc - (v * extra)) 48 | ~extra_changed:(fun ~old_extra ~new_extra ~input:_ acc -> 49 | acc / old_extra * new_extra) 50 | |> Incr.observe 51 | in 52 | let dump () = 53 | Incr.stabilize (); 54 | let value = Incr.Observer.value_exn in 55 | print_s ([%sexp_of: int] (value sum_o)) 56 | in 57 | let change f = Incr.Var.set map (f (Incr.Var.value map)) in 58 | let change_extra v = Incr.Var.set extra v in 59 | dump (); 60 | [%expect {| 6 |}]; 61 | change (fun m -> Map.set m ~key:"c" ~data:4); 62 | dump (); 63 | [%expect {| 14 |}]; 64 | change_extra 5; 65 | dump (); 66 | [%expect {| 35 |}]; 67 | change (fun m -> Map.set m ~key:"c" ~data:0); 68 | change_extra 3; 69 | dump (); 70 | [%expect {| 9 |}] 71 | ;; 72 | 73 | let%expect_test "test specialized_initial" = 74 | let map = Incr.Var.create (String.Map.of_alist_exn [ "a", 1; "b", 2 ]) in 75 | let map_o = Incr.observe (Incr.Var.watch map) in 76 | let extra = Incr.Var.create 2 in 77 | let specialized_initial_is_called = ref false in 78 | let sum_o = 79 | unordered_fold_with_extra 80 | (Incr.Var.watch map) 81 | ~extra:(Incr.Var.watch extra) 82 | ~data_equal:Int.equal 83 | ~acc_equal:Int.equal 84 | ~init:0 85 | ~add:(fun ~key:_ ~data:v acc extra -> acc + (v * extra)) 86 | ~remove:(fun ~key:_ -> assert false) 87 | ~extra_changed:(fun ~old_extra ~new_extra ~input:_ acc -> 88 | acc / old_extra * new_extra) 89 | ~specialized_initial:(fun ~init:_ map extra -> 90 | specialized_initial_is_called := true; 91 | extra * Core.List.sum (module Int) ~f:Fn.id (Map.data map)) 92 | |> Incr.observe 93 | in 94 | let dump () = 95 | Incr.stabilize (); 96 | let value = Incr.Observer.value_exn in 97 | print_s ([%sexp_of: int * int String.Map.t] (value sum_o, value map_o)) 98 | in 99 | dump (); 100 | assert !specialized_initial_is_called; 101 | [%expect 102 | {| 103 | (6 ( 104 | (a 1) 105 | (b 2))) 106 | |}] 107 | ;; 108 | 109 | let%expect_test "filter-reuse" = 110 | let map = 111 | Incr.Var.create (String.Map.of_alist_exn [ "aa", 1; "a", 2; "b", 3; "ab", 4 ]) 112 | in 113 | let extra = Incr.Var.create "" in 114 | let add ~key ~data acc substring = 115 | if String.is_substring key ~substring then Map.set acc ~key ~data else acc 116 | in 117 | let remove ~key ~data:_ acc _extra = Map.remove acc key in 118 | let extra_changed ~old_extra ~new_extra ~input acc = 119 | let to_filter = 120 | if String.is_substring new_extra ~substring:old_extra then acc else input 121 | in 122 | Map.filter_keys to_filter ~f:(String.is_substring ~substring:new_extra) 123 | in 124 | let sum_o = 125 | unordered_fold_with_extra 126 | (Incr.Var.watch map) 127 | ~extra:(Incr.Var.watch extra) 128 | ~data_equal:Int.equal 129 | ~acc_equal:[%equal: int String.Map.t] 130 | ~init:String.Map.empty 131 | ~add 132 | ~remove 133 | ~extra_changed 134 | |> Incr.observe 135 | in 136 | let dump () = 137 | Incr.stabilize (); 138 | let value = Incr.Observer.value_exn in 139 | print_s ([%sexp_of: string * int String.Map.t] (Incr.Var.value extra, value sum_o)) 140 | in 141 | dump (); 142 | [%expect 143 | {| 144 | ("" ( 145 | (a 2) 146 | (aa 1) 147 | (ab 4) 148 | (b 3))) 149 | |}]; 150 | Incr.Var.set extra "a"; 151 | dump (); 152 | [%expect 153 | {| 154 | (a ( 155 | (a 2) 156 | (aa 1) 157 | (ab 4))) 158 | |}]; 159 | Incr.Var.set extra "aa"; 160 | dump (); 161 | [%expect {| (aa ((aa 1))) |}]; 162 | Incr.Var.set extra "b"; 163 | dump (); 164 | [%expect 165 | {| 166 | (b ( 167 | (ab 4) 168 | (b 3))) 169 | |}] 170 | ;; 171 | -------------------------------------------------------------------------------- /test/test_unzip3.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | module type S = sig 5 | val unzip3_mapi' 6 | : data_equal:('d -> 'd -> bool) 7 | -> data_equal_left:('a -> 'a -> bool) 8 | -> data_equal_middle:('b -> 'b -> bool) 9 | -> data_equal_right:('c -> 'c -> bool) 10 | -> ('k, 'd, 'e) Map.t Incr.t 11 | -> f:(key:'k -> data:'d Incr.Z.t -> 'a Incr.t * 'b Incr.t * 'c Incr.t) 12 | -> ('k, 'a, 'e) Map.t Incr.t * ('k, 'b, 'e) Map.t Incr.t * ('k, 'c, 'e) Map.t Incr.t 13 | end 14 | 15 | module Make_test (S : S) = struct 16 | let%expect_test "simple unzip_mapi'" = 17 | let var = 18 | String.Map.of_alist_exn [ "foo", 3; "bar", 10; "snoo", 5 ] |> Incr.Var.create 19 | in 20 | let l, m, r = 21 | S.unzip3_mapi' 22 | ~data_equal:Int.equal 23 | ~data_equal_left:(Option.equal Int.equal) 24 | ~data_equal_middle:String.equal 25 | ~data_equal_right:Int.equal 26 | (Incr.Var.watch var) 27 | ~f:(fun ~key:_ ~data:x -> 28 | ( (let%map x in 29 | let y = x * x in 30 | if y > 10 then Some y else None) 31 | , Incr.map x ~f:Int.to_string 32 | , x )) 33 | in 34 | let obs = 35 | (let%map l and m and r in 36 | l, m, r) 37 | |> Incr.observe 38 | in 39 | let dump () = 40 | Incr.stabilize (); 41 | [%sexp_of: 42 | int String.Map.t 43 | * string 44 | * (int option String.Map.t * string String.Map.t * int String.Map.t)] 45 | (Incr.Var.value var, "->", Incr.Observer.value_exn obs) 46 | |> Sexp.to_string_hum 47 | |> print_endline 48 | in 49 | let change f = 50 | Incr.Var.set var (f (Incr.Var.value var)); 51 | dump () 52 | in 53 | dump (); 54 | [%expect 55 | {| 56 | (((bar 10) (foo 3) (snoo 5)) -> 57 | (((bar (100)) (foo ()) (snoo (25))) ((bar 10) (foo 3) (snoo 5)) 58 | ((bar 10) (foo 3) (snoo 5)))) 59 | |}]; 60 | change (fun m -> Map.set m ~key:"foo" ~data:9); 61 | [%expect 62 | {| 63 | (((bar 10) (foo 9) (snoo 5)) -> 64 | (((bar (100)) (foo (81)) (snoo (25))) ((bar 10) (foo 9) (snoo 5)) 65 | ((bar 10) (foo 9) (snoo 5)))) 66 | |}]; 67 | change (fun m -> Map.set m ~key:"bar" ~data:1); 68 | [%expect 69 | {| 70 | (((bar 1) (foo 9) (snoo 5)) -> 71 | (((bar ()) (foo (81)) (snoo (25))) ((bar 1) (foo 9) (snoo 5)) 72 | ((bar 1) (foo 9) (snoo 5)))) 73 | |}]; 74 | change (fun m -> Map.remove m "snoo"); 75 | [%expect 76 | {| 77 | (((bar 1) (foo 9)) -> 78 | (((bar ()) (foo (81))) ((bar 1) (foo 9)) ((bar 1) (foo 9)))) 79 | |}] 80 | ;; 81 | 82 | let%test_unit "unzip_mapi' randomised fuzz test" = 83 | Quickcheck.test 84 | ~sexp_of:[%sexp_of: (int, int) Map_operations.t list] 85 | (Map_operations.quickcheck_generator Int.quickcheck_generator) 86 | ~f:(fun operations -> 87 | let var = Incr.Var.create Int.Map.empty in 88 | let f ~key ~data = 89 | ( (let%map data in 90 | let y = data * data in 91 | Option.some_if (key + y > 33) y) 92 | , data >>| Int.to_string 93 | , data ) 94 | in 95 | let incr_left, incr_middle, incr_right = 96 | S.unzip3_mapi' 97 | (Incr.Var.watch var) 98 | ~data_equal:[%equal: int] 99 | ~data_equal_left:[%equal: int option] 100 | ~data_equal_middle:[%equal: string] 101 | ~data_equal_right:[%equal: int] 102 | ~f 103 | and slow_left, slow_middle, slow_right = 104 | let paired = 105 | Incr.Map.mapi' (Incr.Var.watch var) ~f:(fun ~key ~data -> 106 | let left, middle, right = f ~key ~data in 107 | let%map left and middle and right in 108 | left, middle, right) 109 | in 110 | ( Incr.Map.map paired ~f:Tuple3.get1 111 | , Incr.Map.map paired ~f:Tuple3.get2 112 | , Incr.Map.map paired ~f:Tuple3.get3 ) 113 | in 114 | let incr_left = Incr.observe incr_left 115 | and incr_middle = Incr.observe incr_middle 116 | and incr_right = Incr.observe incr_right 117 | and slow_left = Incr.observe slow_left 118 | and slow_middle = Incr.observe slow_middle 119 | and slow_right = Incr.observe slow_right in 120 | Map_operations.run_operations operations ~into:var ~after_stabilize:(fun () -> 121 | [%test_result: int option Int.Map.t] 122 | ~expect:(Incr.Observer.value_exn slow_left) 123 | (Incr.Observer.value_exn incr_left); 124 | [%test_result: string Int.Map.t] 125 | ~expect:(Incr.Observer.value_exn slow_middle) 126 | (Incr.Observer.value_exn incr_middle); 127 | [%test_result: int Int.Map.t] 128 | ~expect:(Incr.Observer.value_exn slow_right) 129 | (Incr.Observer.value_exn incr_right)); 130 | Incr.Observer.disallow_future_use incr_left; 131 | Incr.Observer.disallow_future_use incr_middle; 132 | Incr.Observer.disallow_future_use incr_right; 133 | Incr.Observer.disallow_future_use slow_left; 134 | Incr.Observer.disallow_future_use slow_middle; 135 | Incr.Observer.disallow_future_use slow_right) 136 | ;; 137 | end 138 | 139 | module Unzip_mapi_prime = struct 140 | (** version of unzip_mapi' that tests the real implementation against a simpler, less 141 | incremental one, and fails if the two implementations don't match. *) 142 | let unzip3_mapi' ~data_equal ~data_equal_left ~data_equal_middle ~data_equal_right m ~f = 143 | let a_left, a_middle, a_right = Incr.Map.unzip3_mapi' ~data_equal m ~f in 144 | let b_left, b_middle, b_right = 145 | let paired = 146 | Incr.Map.mapi' m ~f:(fun ~key ~data -> 147 | let left, middle, right = f ~key ~data in 148 | let%map left and middle and right in 149 | left, middle, right) 150 | in 151 | ( Incr.Map.map paired ~f:Tuple3.get1 152 | , Incr.Map.map paired ~f:Tuple3.get2 153 | , Incr.Map.map paired ~f:Tuple3.get3 ) 154 | in 155 | let left = 156 | let%map a_left and b_left in 157 | require (Map.equal data_equal_left a_left b_left); 158 | a_left 159 | in 160 | let middle = 161 | let%map a_middle and b_middle in 162 | require (Map.equal data_equal_middle a_middle b_middle); 163 | a_middle 164 | in 165 | let right = 166 | let%map a_right and b_right in 167 | require (Map.equal data_equal_right a_right b_right); 168 | a_right 169 | in 170 | left, middle, right 171 | ;; 172 | end 173 | 174 | module Prime_test = Make_test (Unzip_mapi_prime) 175 | -------------------------------------------------------------------------------- /test/unzip_fails.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | let%expect_test "unzip_mapi' dropping one map" = 5 | let m = String.Map.of_alist_exn [ "foo", 3; "bar", 10; "snoo", 5 ] |> Incr.Var.create in 6 | let a, _ = 7 | Incr.Var.watch m |> Incr.Map.unzip_mapi' ~f:(fun ~key:_ ~data -> data, data) 8 | in 9 | let observer = Incr.observe a in 10 | let dump () = 11 | Incr.stabilize (); 12 | observer |> Incr.Observer.value_exn |> [%sexp_of: int String.Map.t] |> print_s 13 | in 14 | let change f = 15 | Incr.Var.set m (f (Incr.Var.value m)); 16 | dump () 17 | in 18 | dump (); 19 | [%expect 20 | {| 21 | ((bar 10) 22 | (foo 3) 23 | (snoo 5)) 24 | |}]; 25 | change (fun m -> Map.set m ~key:"foo" ~data:9); 26 | [%expect 27 | {| 28 | ((bar 10) 29 | (foo 9) 30 | (snoo 5)) 31 | |}]; 32 | change (fun m -> Map.set m ~key:"bar" ~data:1); 33 | [%expect 34 | {| 35 | ((bar 1) 36 | (foo 9) 37 | (snoo 5)) 38 | |}]; 39 | change (fun m -> Map.remove m "snoo"); 40 | [%expect 41 | {| 42 | ((bar 1) 43 | (foo 9)) 44 | |}] 45 | ;; 46 | --------------------------------------------------------------------------------