diff --git a/CHANGES.md b/CHANGES.md index 028a6c45..d8db6872 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,13 @@ +- `Bonsai_web_ui_form` and `Bonsai_web_ui_form2` were merged into `Bonsai_web_ui_form` under +submodules `With_automatic_view` and `With_manual_view`, respectively. + +- Added `always_update_when_focused` to text inputs to make the current behavior (text value can't be updated if the input is focused) optional. + +- Remove the first-class Action module from + * `Bonsai_extra.state_machine0_dynamic_model` and + * `Bonsai_extra.state_machine1_dynamic_model` + in favor of an optional `sexp_of_action: 'action -> Sexp.t` parameter. + ## Release v0.16.0 - Formatting improvements: diff --git a/LICENSE.md b/LICENSE.md index f45a250e..55cdc790 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ The MIT License -Copyright (c) 2019--2023 Jane Street Group, LLC +Copyright (c) 2019--2024 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/bench/example/dune b/bench/example/dune index 95a570b3..79670d6e 100644 --- a/bench/example/dune +++ b/bench/example/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai bonsai_bench incr_dom.javascript_profiling js_of_ocaml) - (preprocess (pps ppx_bonsai ppx_jane js_of_ocaml-ppx))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane js_of_ocaml-ppx))) diff --git a/bench/src/dune b/bench/src/dune index a02113eb..b0cff986 100644 --- a/bench/src/dune +++ b/bench/src/dune @@ -1,4 +1,7 @@ -(library (name bonsai_bench) (public_name bonsai.bench) +(library + (name bonsai_bench) + (public_name bonsai.bench) (libraries bonsai bonsai_driver core_bench.js incr_dom.javascript_profiling - js_of_ocaml) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_pattern_bind))) \ No newline at end of file + js_of_ocaml) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_pattern_bind))) diff --git a/bench/src/profile.ml b/bench/src/profile.ml index d5a39097..2098b572 100644 --- a/bench/src/profile.ml +++ b/bench/src/profile.ml @@ -243,10 +243,10 @@ let profile (T { clock; component; get_inject; interaction; name } : Config.t) = in let component = Graph_info.iter_graph_updates - (Bonsai.Private.reveal_computation component) + (Bonsai.Private.top_level_handle component) ~on_update:(fun gi -> graph_info := gi) - |> Bonsai.Private.conceal_computation in + let component graph = Bonsai.Private.perform graph component in let performance_entries = ref [] in let performance_observer = if PerformanceObserver.is_supported () diff --git a/bindings/dygraph/src/dune b/bindings/dygraph/src/dune index 71b0c74f..dd0dc669 100644 --- a/bindings/dygraph/src/dune +++ b/bindings/dygraph/src/dune @@ -1,7 +1,8 @@ -(library (name dygraph) +(library + (name dygraph) (preprocess (pps ppx_jane js_of_ocaml-ppx gen_js_api.ppx ppx_bonsai ppx_pattern_bind)) (js_of_ocaml (javascript_files ../dist/dygraph.min.js ../dist/lodash_merge.js)) (libraries base bonsai_extra bonsai_web bonsai_web_ui_widget core - virtual_dom.css_gen gen_js_api js_of_ocaml timezone ppx_css.inline_css)) \ No newline at end of file + virtual_dom.css_gen gen_js_api js_of_ocaml timezone ppx_css.inline_css)) diff --git a/bindings/feather_icon/src/dune b/bindings/feather_icon/src/dune index 65a6a327..e096c890 100644 --- a/bindings/feather_icon/src/dune +++ b/bindings/feather_icon/src/dune @@ -1,88 +1,96 @@ -(library (name feather_icon) (public_name bonsai.feather_icon) - (libraries core bonsai_web) (preprocess (pps ppx_jane))) +(library + (name feather_icon) + (public_name bonsai.feather_icon) + (libraries core bonsai_web) + (preprocess + (pps ppx_jane))) -(rule (targets paths.ml paths.mli) +(rule + (targets paths.ml paths.mli) (deps %{bin:ocaml-embed-file} paths/activity.svg paths/corner-down-left.svg - paths/link.svg paths/shopping-bag.svg paths/airplay.svg - paths/corner-down-right.svg paths/list.svg paths/shopping-cart.svg - paths/alert-circle.svg paths/corner-left-down.svg paths/loader.svg - paths/shuffle.svg paths/alert-octagon.svg paths/corner-left-up.svg - paths/lock.svg paths/sidebar.svg paths/alert-triangle.svg - paths/corner-right-down.svg paths/log-in.svg paths/skip-back.svg - paths/align-center.svg paths/corner-right-up.svg paths/log-out.svg - paths/skip-forward.svg paths/align-justify.svg paths/corner-up-left.svg - paths/mail.svg paths/slack.svg paths/align-left.svg - paths/corner-up-right.svg paths/map-pin.svg paths/slash.svg - paths/align-right.svg paths/cpu.svg paths/map.svg paths/sliders.svg - paths/anchor.svg paths/credit-card.svg paths/maximize-2.svg - paths/smartphone.svg paths/aperture.svg paths/crop.svg paths/maximize.svg - paths/smile.svg paths/archive.svg paths/crosshair.svg paths/meh.svg - paths/speaker.svg paths/arrow-down-circle.svg paths/database.svg - paths/menu.svg paths/square.svg paths/arrow-down-left.svg paths/delete.svg - paths/message-circle.svg paths/star.svg paths/arrow-down-right.svg - paths/disc.svg paths/message-square.svg paths/stop-circle.svg - paths/arrow-down.svg paths/divide-circle.svg paths/mic-off.svg - paths/sunrise.svg paths/arrow-left-circle.svg paths/divide-square.svg - paths/mic.svg paths/sunset.svg paths/arrow-left.svg paths/divide.svg - paths/minimize-2.svg paths/sun.svg paths/arrow-right-circle.svg - paths/dollar-sign.svg paths/minimize.svg paths/tablet.svg - paths/arrow-right.svg paths/download-cloud.svg paths/minus-circle.svg - paths/tag.svg paths/arrow-up-circle.svg paths/download.svg - paths/minus-square.svg paths/target.svg paths/arrow-up-left.svg - paths/dribbble.svg paths/minus.svg paths/terminal.svg - paths/arrow-up-right.svg paths/droplet.svg paths/monitor.svg - paths/thermometer.svg paths/arrow-up.svg paths/edit-2.svg paths/moon.svg - paths/thumbs-down.svg paths/at-sign.svg paths/edit-3.svg - paths/more-horizontal.svg paths/thumbs-up.svg paths/award.svg - paths/edit.svg paths/more-vertical.svg paths/toggle-left.svg - paths/bar-chart-2.svg paths/external-link.svg paths/mouse-pointer.svg - paths/toggle-right.svg paths/bar-chart.svg paths/eye-off.svg paths/move.svg - paths/tool.svg paths/battery-charging.svg paths/eye.svg paths/music.svg - paths/trash-2.svg paths/battery.svg paths/facebook.svg - paths/navigation-2.svg paths/trash.svg paths/bell-off.svg - paths/fast-forward.svg paths/navigation.svg paths/trello.svg paths/bell.svg - paths/feather.svg paths/octagon.svg paths/trending-down.svg - paths/bluetooth.svg paths/figma.svg paths/package.svg paths/trending-up.svg - paths/bold.svg paths/file-minus.svg paths/paperclip.svg paths/triangle.svg - paths/bookmark.svg paths/file-plus.svg paths/pause-circle.svg - paths/truck.svg paths/book-open.svg paths/file.svg paths/pause.svg - paths/tv.svg paths/book.svg paths/file-text.svg paths/pen-tool.svg - paths/twitch.svg paths/box.svg paths/film.svg paths/percent.svg - paths/twitter.svg paths/briefcase.svg paths/filter.svg paths/phone-call.svg - paths/type.svg paths/calendar.svg paths/flag.svg paths/phone-forwarded.svg - paths/umbrella.svg paths/camera-off.svg paths/folder-minus.svg - paths/phone-incoming.svg paths/underline.svg paths/camera.svg - paths/folder-plus.svg paths/phone-missed.svg paths/unlock.svg - paths/cast.svg paths/folder.svg paths/phone-off.svg paths/upload-cloud.svg - paths/check-circle.svg paths/framer.svg paths/phone-outgoing.svg - paths/upload.svg paths/check-square.svg paths/frown.svg paths/phone.svg - paths/user-check.svg paths/check.svg paths/gift.svg paths/pie-chart.svg - paths/user-minus.svg paths/chevron-down.svg paths/git-branch.svg - paths/play-circle.svg paths/user-plus.svg paths/chevron-left.svg - paths/git-commit.svg paths/play.svg paths/users.svg paths/chevron-right.svg - paths/github.svg paths/plus-circle.svg paths/user.svg - paths/chevrons-down.svg paths/gitlab.svg paths/plus-square.svg - paths/user-x.svg paths/chevrons-left.svg paths/git-merge.svg paths/plus.svg - paths/video-off.svg paths/chevrons-right.svg paths/git-pull-request.svg - paths/pocket.svg paths/video.svg paths/chevrons-up.svg paths/globe.svg - paths/power.svg paths/voicemail.svg paths/chevron-up.svg paths/grid.svg - paths/printer.svg paths/volume-1.svg paths/chrome.svg paths/hard-drive.svg - paths/radio.svg paths/volume-2.svg paths/circle.svg paths/hash.svg - paths/refresh-ccw.svg paths/volume.svg paths/clipboard.svg - paths/headphones.svg paths/refresh-cw.svg paths/volume-x.svg - paths/clock.svg paths/heart.svg paths/repeat.svg paths/watch.svg - paths/cloud-drizzle.svg paths/help-circle.svg paths/rewind.svg - paths/wifi-off.svg paths/cloud-lightning.svg paths/hexagon.svg - paths/rotate-ccw.svg paths/wifi.svg paths/cloud-off.svg paths/home.svg - paths/rotate-cw.svg paths/wind.svg paths/cloud-rain.svg paths/image.svg - paths/rss.svg paths/x-circle.svg paths/cloud-snow.svg paths/inbox.svg - paths/save.svg paths/x-octagon.svg paths/cloud.svg paths/info.svg - paths/scissors.svg paths/x-square.svg paths/codepen.svg paths/instagram.svg - paths/search.svg paths/x.svg paths/codesandbox.svg paths/italic.svg - paths/send.svg paths/youtube.svg paths/code.svg paths/key.svg - paths/server.svg paths/zap-off.svg paths/coffee.svg paths/layers.svg - paths/settings.svg paths/zap.svg paths/columns.svg paths/layout.svg - paths/share-2.svg paths/zoom-in.svg paths/command.svg paths/life-buoy.svg - paths/share.svg paths/zoom-out.svg paths/compass.svg paths/link-2.svg - paths/shield-off.svg paths/copy.svg paths/linkedin.svg paths/shield.svg) - (action (bash "%{deps} -output paths"))) \ No newline at end of file + paths/link.svg paths/shopping-bag.svg paths/airplay.svg + paths/corner-down-right.svg paths/list.svg paths/shopping-cart.svg + paths/alert-circle.svg paths/corner-left-down.svg paths/loader.svg + paths/shuffle.svg paths/alert-octagon.svg paths/corner-left-up.svg + paths/lock.svg paths/sidebar.svg paths/alert-triangle.svg + paths/corner-right-down.svg paths/log-in.svg paths/skip-back.svg + paths/align-center.svg paths/corner-right-up.svg paths/log-out.svg + paths/skip-forward.svg paths/align-justify.svg paths/corner-up-left.svg + paths/mail.svg paths/slack.svg paths/align-left.svg + paths/corner-up-right.svg paths/map-pin.svg paths/slash.svg + paths/align-right.svg paths/cpu.svg paths/map.svg paths/sliders.svg + paths/anchor.svg paths/credit-card.svg paths/maximize-2.svg + paths/smartphone.svg paths/aperture.svg paths/crop.svg paths/maximize.svg + paths/smile.svg paths/archive.svg paths/crosshair.svg paths/meh.svg + paths/speaker.svg paths/arrow-down-circle.svg paths/database.svg + paths/menu.svg paths/square.svg paths/arrow-down-left.svg paths/delete.svg + paths/message-circle.svg paths/star.svg paths/arrow-down-right.svg + paths/disc.svg paths/message-square.svg paths/stop-circle.svg + paths/arrow-down.svg paths/divide-circle.svg paths/mic-off.svg + paths/sunrise.svg paths/arrow-left-circle.svg paths/divide-square.svg + paths/mic.svg paths/sunset.svg paths/arrow-left.svg paths/divide.svg + paths/minimize-2.svg paths/sun.svg paths/arrow-right-circle.svg + paths/dollar-sign.svg paths/minimize.svg paths/tablet.svg + paths/arrow-right.svg paths/download-cloud.svg paths/minus-circle.svg + paths/tag.svg paths/arrow-up-circle.svg paths/download.svg + paths/minus-square.svg paths/target.svg paths/arrow-up-left.svg + paths/dribbble.svg paths/minus.svg paths/terminal.svg + paths/arrow-up-right.svg paths/droplet.svg paths/monitor.svg + paths/thermometer.svg paths/arrow-up.svg paths/edit-2.svg paths/moon.svg + paths/thumbs-down.svg paths/at-sign.svg paths/edit-3.svg + paths/more-horizontal.svg paths/thumbs-up.svg paths/award.svg + paths/edit.svg paths/more-vertical.svg paths/toggle-left.svg + paths/bar-chart-2.svg paths/external-link.svg paths/mouse-pointer.svg + paths/toggle-right.svg paths/bar-chart.svg paths/eye-off.svg + paths/move.svg paths/tool.svg paths/battery-charging.svg paths/eye.svg + paths/music.svg paths/trash-2.svg paths/battery.svg paths/facebook.svg + paths/navigation-2.svg paths/trash.svg paths/bell-off.svg + paths/fast-forward.svg paths/navigation.svg paths/trello.svg + paths/bell.svg paths/feather.svg paths/octagon.svg paths/trending-down.svg + paths/bluetooth.svg paths/figma.svg paths/package.svg + paths/trending-up.svg paths/bold.svg paths/file-minus.svg + paths/paperclip.svg paths/triangle.svg paths/bookmark.svg + paths/file-plus.svg paths/pause-circle.svg paths/truck.svg + paths/book-open.svg paths/file.svg paths/pause.svg paths/tv.svg + paths/book.svg paths/file-text.svg paths/pen-tool.svg paths/twitch.svg + paths/box.svg paths/film.svg paths/percent.svg paths/twitter.svg + paths/briefcase.svg paths/filter.svg paths/phone-call.svg paths/type.svg + paths/calendar.svg paths/flag.svg paths/phone-forwarded.svg + paths/umbrella.svg paths/camera-off.svg paths/folder-minus.svg + paths/phone-incoming.svg paths/underline.svg paths/camera.svg + paths/folder-plus.svg paths/phone-missed.svg paths/unlock.svg + paths/cast.svg paths/folder.svg paths/phone-off.svg paths/upload-cloud.svg + paths/check-circle.svg paths/framer.svg paths/phone-outgoing.svg + paths/upload.svg paths/check-square.svg paths/frown.svg paths/phone.svg + paths/user-check.svg paths/check.svg paths/gift.svg paths/pie-chart.svg + paths/user-minus.svg paths/chevron-down.svg paths/git-branch.svg + paths/play-circle.svg paths/user-plus.svg paths/chevron-left.svg + paths/git-commit.svg paths/play.svg paths/users.svg + paths/chevron-right.svg paths/github.svg paths/plus-circle.svg + paths/user.svg paths/chevrons-down.svg paths/gitlab.svg + paths/plus-square.svg paths/user-x.svg paths/chevrons-left.svg + paths/git-merge.svg paths/plus.svg paths/video-off.svg + paths/chevrons-right.svg paths/git-pull-request.svg paths/pocket.svg + paths/video.svg paths/chevrons-up.svg paths/globe.svg paths/power.svg + paths/voicemail.svg paths/chevron-up.svg paths/grid.svg paths/printer.svg + paths/volume-1.svg paths/chrome.svg paths/hard-drive.svg paths/radio.svg + paths/volume-2.svg paths/circle.svg paths/hash.svg paths/refresh-ccw.svg + paths/volume.svg paths/clipboard.svg paths/headphones.svg + paths/refresh-cw.svg paths/volume-x.svg paths/clock.svg paths/heart.svg + paths/repeat.svg paths/watch.svg paths/cloud-drizzle.svg + paths/help-circle.svg paths/rewind.svg paths/wifi-off.svg + paths/cloud-lightning.svg paths/hexagon.svg paths/rotate-ccw.svg + paths/wifi.svg paths/cloud-off.svg paths/home.svg paths/rotate-cw.svg + paths/wind.svg paths/cloud-rain.svg paths/image.svg paths/rss.svg + paths/x-circle.svg paths/cloud-snow.svg paths/inbox.svg paths/save.svg + paths/x-octagon.svg paths/cloud.svg paths/info.svg paths/scissors.svg + paths/x-square.svg paths/codepen.svg paths/instagram.svg paths/search.svg + paths/x.svg paths/codesandbox.svg paths/italic.svg paths/send.svg + paths/youtube.svg paths/code.svg paths/key.svg paths/server.svg + paths/zap-off.svg paths/coffee.svg paths/layers.svg paths/settings.svg + paths/zap.svg paths/columns.svg paths/layout.svg paths/share-2.svg + paths/zoom-in.svg paths/command.svg paths/life-buoy.svg paths/share.svg + paths/zoom-out.svg paths/compass.svg paths/link-2.svg paths/shield-off.svg + paths/copy.svg paths/linkedin.svg paths/shield.svg) + (action + (bash "%{deps} -output paths"))) diff --git a/bonsai.opam b/bonsai.opam index 8b0f6bdf..a28e5cce 100644 --- a/bonsai.opam +++ b/bonsai.opam @@ -40,21 +40,23 @@ depends: [ "ppx_pattern_bind" "ppx_typed_fields" "profunctor" + "record_builder" "sexp_grammar" "sexplib0" "streamable" "textutils" + "versioned_polling_state_rpc" "virtual_dom" - "base64" {>= "3.4.0"} - "cohttp-async" {>= "2.5.7" & < "3.0.0" | >= "5.1.1" & < "6.0.0"} - "dune" {>= "2.0.0"} - "gen_js_api" {>= "1.0.8"} - "js_of_ocaml" {>= "5.1.1"} - "js_of_ocaml-ppx" {>= "5.1.1"} + "base64" {>= "3.4.0"} + "cohttp-async" {>= "2.5.7" & < "3.0.0" | >= "5.1.1" & < "6.0.0"} + "dune" {>= "2.0.0"} + "gen_js_api" {>= "1.0.8"} + "js_of_ocaml" {>= "5.1.1"} + "js_of_ocaml-ppx" {>= "5.1.1"} "ocaml-embed-file" - "ppxlib" {>= "0.28.0"} - "re" {>= "1.8.0"} - "uri" {>= "3.0.0"} + "ppxlib" {>= "0.28.0"} + "re" {>= "1.8.0"} + "uri" {>= "3.0.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "A library for building dynamic webapps, using Js_of_ocaml" diff --git a/docs/blogs/letsub.mdx b/docs/blogs/letsub.mdx index a7820933..1ec62e27 100644 --- a/docs/blogs/letsub.mdx +++ b/docs/blogs/letsub.mdx @@ -160,7 +160,8 @@ And here's a test that shows that by caching `x` we now only print let tripled = map x ~f:(fun i -> i * 3) in let y = add doubled tripled in printf "y = %d\n" (eval y); - [%expect {| + [%expect + {| got here y = 15 |}] ;; @@ -261,7 +262,8 @@ does that work? To see, let's add `sub` to our language: add doubled tripled) in printf "y = %d\n" (eval y); - [%expect {| + [%expect + {| got here y = 15 |}] ;; @@ -387,7 +389,8 @@ Here it is in action: add doubled tripled) in printf "y = %d\n" (eval y); - [%expect {| + [%expect + {| got here y = 15 |}] ;; diff --git a/docs/blogs/letsub/src/dune b/docs/blogs/letsub/src/dune index 97ec095d..123d1af2 100644 --- a/docs/blogs/letsub/src/dune +++ b/docs/blogs/letsub/src/dune @@ -1,2 +1,5 @@ -(library (name blog_letsub) (libraries core bonsai) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(library + (name blog_letsub) + (libraries core bonsai) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/docs/blogs/testing.mdx b/docs/blogs/testing.mdx index 67c2af68..723ab3d0 100644 --- a/docs/blogs/testing.mdx +++ b/docs/blogs/testing.mdx @@ -139,7 +139,8 @@ let%expect_test "shows hello to a user" = [%expect {| hello Bob |}]; Bonsai.Var.set user_var "Alice"; Handle.show_diff handle; - [%expect {| + [%expect + {| -| hello Bob +| hello Alice |}] ;; diff --git a/docs/getting_started/counters.mdx b/docs/getting_started/counters.mdx index b1651d86..66e81c59 100644 --- a/docs/getting_started/counters.mdx +++ b/docs/getting_started/counters.mdx @@ -242,7 +242,7 @@ monadic `bind`, but with this signature: # Bonsai.Let_syntax.Let_syntax.sub - : ?here:Lexing.position -> 'a Bonsai.Computation.t -> - f:('a Bonsai.Value.t -> 'b Bonsai.Computation.t) -> + f:('a Bonsai.Cont.t -> 'b Bonsai.Computation.t) -> 'b Bonsai.Computation.t = ``` @@ -254,10 +254,10 @@ is: ```ocaml # Bonsai.assoc - : ('key, 'cmp) Bonsai.comparator -> - ('key, 'data, 'cmp) Core.Map.t Bonsai.Value.t -> - f:('key Bonsai.Value.t -> - 'data Bonsai.Value.t -> 'result Bonsai.Computation.t) -> - ('key, 'result, 'cmp) Core.Map.t Bonsai.Computation.t + ('key, 'data, 'cmp) Base.Map.t Bonsai.Cont.t -> + f:('key Bonsai.Cont.t -> + 'data Bonsai.Cont.t -> 'result Bonsai.Computation.t) -> + ('key, 'result, 'cmp) Base.Map.t Bonsai.Computation.t = ``` diff --git a/docs/getting_started/open_source/counters.mdx b/docs/getting_started/open_source/counters.mdx index b1651d86..66e81c59 100644 --- a/docs/getting_started/open_source/counters.mdx +++ b/docs/getting_started/open_source/counters.mdx @@ -242,7 +242,7 @@ monadic `bind`, but with this signature: # Bonsai.Let_syntax.Let_syntax.sub - : ?here:Lexing.position -> 'a Bonsai.Computation.t -> - f:('a Bonsai.Value.t -> 'b Bonsai.Computation.t) -> + f:('a Bonsai.Cont.t -> 'b Bonsai.Computation.t) -> 'b Bonsai.Computation.t = ``` @@ -254,10 +254,10 @@ is: ```ocaml # Bonsai.assoc - : ('key, 'cmp) Bonsai.comparator -> - ('key, 'data, 'cmp) Core.Map.t Bonsai.Value.t -> - f:('key Bonsai.Value.t -> - 'data Bonsai.Value.t -> 'result Bonsai.Computation.t) -> - ('key, 'result, 'cmp) Core.Map.t Bonsai.Computation.t + ('key, 'data, 'cmp) Base.Map.t Bonsai.Cont.t -> + f:('key Bonsai.Cont.t -> + 'data Bonsai.Cont.t -> 'result Bonsai.Computation.t) -> + ('key, 'result, 'cmp) Base.Map.t Bonsai.Computation.t = ``` diff --git a/docs/guide/04-forms.md b/docs/guide/04-forms.md index 74e836cf..1bb749fb 100644 --- a/docs/guide/04-forms.md +++ b/docs/guide/04-forms.md @@ -15,7 +15,7 @@ For the rest of this doc, this module alias will be in effect: ``` ``` ocaml -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view ``` # Form.t diff --git a/docs/guide/11-rpcs.md b/docs/guide/11-rpcs.md index ac042e49..dead4d4b 100644 --- a/docs/guide/11-rpcs.md +++ b/docs/guide/11-rpcs.md @@ -328,7 +328,7 @@ let%expect_test "Clicking the button should double the number" = |}]; let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in - [%expect {| "RPC not handled because no connector has been provided." |}]; + [%expect {| (Failure "BUG: no bonsai-rpc handler installed") |}]; return () ;; ``` diff --git a/docs/upgrade/local-graph.mdx b/docs/upgrade/local-graph.mdx new file mode 100644 index 00000000..cb432c1f --- /dev/null +++ b/docs/upgrade/local-graph.mdx @@ -0,0 +1,60 @@ +# Upgrading to Bonsai's local graph API + +Bonsai's new local_ graph API is finally here! +We recommend looking through the[new mli file](https://cs/jane/lib/bonsai/src/cont.mli) +to see how types have changed. + + + +## Moving from `Value`/`Computation` to `local_ Bonsai.graph` and `Bonsai.t` + +You can convert your codebase to Bonsai's new API one file at a time! +The process is fairly mechanical and straightforward: + +1. Replace any `open! Bonsai_web` with `open! Bonsai_web.Cont` +2. Rename any `'a Value.t` to `'a Bonsai.t` +3. Rename any `'a Computation.t` to `local_ Bonsai.graph -> 'a Bonsai.t` +4. For the most part, `let%sub` is no longer needed. Instead, instantiate Bonsai + components by passing `graph` to them. +5. `let%arrs` can be replaced with `let%map`. +6. Components can now return tuples / records of `Bonsai.t`s! If you were previously + returning `('a * 'b) Bonsai.t`, consider returning `(a Bonsai.t * 'b Bonsai.t)` instead. + This is because we no longer need `let%sub`, so there's no longer anything enforcing + that our components must return a single `Computation.t`. + +Any Bonsai component that uses Bonsai primitives, either directly or transitively, will +need a `local_ graph` parameter. This is fine and expected. + +If anything breaks or you're unsure of something, please reach out! + +## Patterns + +We continue to recommend splitting non-trivial stateful components up into modular pieces +when possible. This should be even more flexible with the `local_ graph` API. + +It's also often good practice to split the part of your component that generates vdom +view into a separate, pure OCaml function. + +More pattterns to come soon! + +## API Changes + +Alongside the new `local_ graph` API, we'd like to do some housekeeping on the APIs Bonsai +provides, and how they are organized. Some of these are new features that are now +possible because of `local_ graph`, others are just cleanup we've been meaning to do for +a while. + +### Changed + +* `Bonsai.yoink` -> `Bonsai.peek`: still uses the same api (with graph changes) - just a + new name! Peek is a better representation of what is happening and is more inline with + what this operation is called on other data structures (stacks, Deferred.t, Mvar.t, etc). +* Most `Bonsai.Value.t` combinators are now available directly in the `Bonsai` module for + use with `Bonsai.t`s. + +### Removed + +Many combinators for dealing with `Bonsai.Value.t` and `Bonsai.Computation` are no longer +needed, and are not included in the new API. If you think we've forgotten something useful, +please reach out! diff --git a/dune-project b/dune-project index dba2e76e..e563d7e3 100644 --- a/dune-project +++ b/dune-project @@ -1 +1,3 @@ -(lang dune 1.11) \ No newline at end of file +(lang dune 2.0) + +(formatting disabled) diff --git a/examples/accordion/dune b/examples/accordion/dune index 233dbde1..d4c61c86 100644 --- a/examples/accordion/dune +++ b/examples/accordion/dune @@ -1,4 +1,6 @@ -(executables (names main) - (libraries async_js bonsai_web bonsai_web_ui_accordion - bonsai_web_ui_gallery) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries async_js bonsai_web bonsai_web_ui_accordion bonsai_web_ui_gallery) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) diff --git a/examples/animation/dune b/examples/animation/dune index f025d23d..796d8545 100644 --- a/examples/animation/dune +++ b/examples/animation/dune @@ -1,3 +1,6 @@ -(executables (names main) - (libraries bonsai_web bonsai_web_ui_form bonsai_experimental_animation) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_experimental_animation bonsai_web_ui_form) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/animation/main.ml b/examples/animation/main.ml index 1065db1b..f1ae0d80 100644 --- a/examples/animation/main.ml +++ b/examples/animation/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax module Animation = Bonsai_experimental_animation -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view let component = let%sub interpolator_form = diff --git a/examples/beforeunload/dune b/examples/beforeunload/dune index 98a5e03c..9349105a 100644 --- a/examples/beforeunload/dune +++ b/examples/beforeunload/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web virtual_dom) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web virtual_dom) + (preprocess + (pps ppx_jane))) diff --git a/examples/better_console_errors/dune b/examples/better_console_errors/dune index 81479bca..7e432bb4 100644 --- a/examples/better_console_errors/dune +++ b/examples/better_console_errors/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web async_js) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web async_js) + (preprocess + (pps ppx_jane))) diff --git a/examples/bonsai_guide_code/css_examples.ml b/examples/bonsai_guide_code/css_examples.ml index f682d136..f0c26326 100644 --- a/examples/bonsai_guide_code/css_examples.ml +++ b/examples/bonsai_guide_code/css_examples.ml @@ -236,6 +236,7 @@ module _ = struct end module _ = struct + (* $MDX part-begin=css-variables-css *) module Style = [%css stylesheet @@ -262,6 +263,7 @@ module _ = struct background-color: var(--blue); } |}] + (* $MDX part-end *) type theme = | Light diff --git a/examples/bonsai_guide_code/dune b/examples/bonsai_guide_code/dune index 5dc46818..9e2c0aa0 100644 --- a/examples/bonsai_guide_code/dune +++ b/examples/bonsai_guide_code/dune @@ -1,6 +1,9 @@ -(executables (names main) - (libraries bonsai_web async_js bonsai_web_ui_form bonsai_web_ui_extendy - legacy_diffable timezone) +(executables + (modes byte exe) + (names main) + (libraries bonsai_web async_js bonsai_web_ui_extendy bonsai_web_ui_form + legacy_diffable timezone) (preprocess (pps js_of_ocaml-ppx ppx_typed_fields ppx_bonsai ppx_css ppx_jane)) - (js_of_ocaml (javascript_files ./resize_iframe.js))) \ No newline at end of file + (js_of_ocaml + (javascript_files ./resize_iframe.js))) diff --git a/examples/bonsai_guide_code/effect_examples.ml b/examples/bonsai_guide_code/effect_examples.ml index 8db97154..0f846088 100644 --- a/examples/bonsai_guide_code/effect_examples.ml +++ b/examples/bonsai_guide_code/effect_examples.ml @@ -2,7 +2,7 @@ open! Core open! Async_kernel open! Bonsai_web open! Bonsai.Let_syntax -module Forms = Bonsai_web_ui_form +module Forms = Bonsai_web_ui_form.With_automatic_view let uppercase s = let open Async_kernel in diff --git a/examples/bonsai_guide_code/flow_examples.ml b/examples/bonsai_guide_code/flow_examples.ml index 3ebde976..be95634f 100644 --- a/examples/bonsai_guide_code/flow_examples.ml +++ b/examples/bonsai_guide_code/flow_examples.ml @@ -2,7 +2,7 @@ open! Core open! Async_kernel open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view let textbox ~placeholder = let%sub state, set_state = diff --git a/examples/bonsai_guide_code/form_examples.ml b/examples/bonsai_guide_code/form_examples.ml index a42d4eeb..16d5d54f 100644 --- a/examples/bonsai_guide_code/form_examples.ml +++ b/examples/bonsai_guide_code/form_examples.ml @@ -2,7 +2,7 @@ open! Core open! Async_kernel open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view (* $MDX part-begin=form_textbox_value *) let textbox_value = diff --git a/examples/bonsai_guide_code/rpc_examples.ml b/examples/bonsai_guide_code/rpc_examples.ml index 0b6f6aa1..8547da5f 100644 --- a/examples/bonsai_guide_code/rpc_examples.ml +++ b/examples/bonsai_guide_code/rpc_examples.ml @@ -121,7 +121,7 @@ module Css = [%css stylesheet {| |}] let zone_form = - let module Form = Bonsai_web_ui_form in + let module Form = Bonsai_web_ui_form.With_automatic_view in let%sub form = Form.Elements.Textbox.string ~placeholder:"timezone" diff --git a/examples/bonsai_guide_code/test/dune b/examples/bonsai_guide_code/test/dune index 7de215d3..414c7362 100644 --- a/examples/bonsai_guide_code/test/dune +++ b/examples/bonsai_guide_code/test/dune @@ -1,3 +1,6 @@ -(library (name bonsai_guide_code_test) (public_name bonsai.guide_code_test) +(library + (name bonsai_guide_code_test) + (public_name bonsai.guide_code_test) (libraries bonsai_web_test async_js.async_test) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/examples/bonsai_guide_code/test/rpc_examples_test.ml b/examples/bonsai_guide_code/test/rpc_examples_test.ml index 12c451f3..fb92b528 100644 --- a/examples/bonsai_guide_code/test/rpc_examples_test.ml +++ b/examples/bonsai_guide_code/test/rpc_examples_test.ml @@ -64,6 +64,12 @@ open Async_kernel open Async_js_test (* $MDX part-end *) +let%expect_test "Allowing the async effect of the previous test to run." = + let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in + [%expect {| (Failure "BUG: no bonsai-rpc handler installed") |}]; + return () +;; + (* $MDX part-begin=attempt-2 *) let%expect_test "Clicking the button should double the number" = let handle = Handle.create (Result_spec.vdom Fn.id) app in @@ -83,7 +89,7 @@ let%expect_test "Clicking the button should double the number" = |}]; let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in - [%expect {| "RPC not handled because no connector has been provided." |}]; + [%expect {| (Failure "BUG: no bonsai-rpc handler installed") |}]; return () ;; diff --git a/examples/bonsai_view/dune b/examples/bonsai_view/dune index d09f4eb2..49064166 100644 --- a/examples/bonsai_view/dune +++ b/examples/bonsai_view/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_web bonsai_web_ui_form bonsai_web_ui_gallery) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) \ No newline at end of file + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) diff --git a/examples/bonsai_view/main.ml b/examples/bonsai_view/main.ml index a122c07b..9d260c6b 100644 --- a/examples/bonsai_view/main.ml +++ b/examples/bonsai_view/main.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open! Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Gallery = Bonsai_web_ui_gallery let vbox c = View.vbox ~cross_axis_alignment:Start ~gap:(`Px 5) c diff --git a/examples/clipboard/dune b/examples/clipboard/dune index 3802de07..d76d2b18 100644 --- a/examples/clipboard/dune +++ b/examples/clipboard/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_form js_clipboard) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) diff --git a/examples/clipboard/main.ml b/examples/clipboard/main.ml index 8556e3a4..00ebafa2 100644 --- a/examples/clipboard/main.ml +++ b/examples/clipboard/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Js_of_ocaml open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view let component = let%sub form = Form.Elements.Textbox.string ~allow_updates_when_focused:`Never () in diff --git a/examples/clock_every/dune b/examples/clock_every/dune index 92929be7..f51922a9 100644 --- a/examples/clock_every/dune +++ b/examples/clock_every/dune @@ -1,4 +1,6 @@ -(executables (names main) - (libraries bonsai_web bonsai_web_ui_form bonsai_extra core virtual_dom.svg) +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_extra bonsai_web_ui_form core virtual_dom.svg) (preprocess - (pps ppx_jane ppx_bonsai ppx_css js_of_ocaml-ppx ppx_typed_fields))) \ No newline at end of file + (pps ppx_jane ppx_bonsai ppx_css js_of_ocaml-ppx ppx_typed_fields))) diff --git a/examples/clock_every/main.ml b/examples/clock_every/main.ml index 626f6436..6d1c421e 100644 --- a/examples/clock_every/main.ml +++ b/examples/clock_every/main.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Css = [%css diff --git a/examples/codemirror/dune b/examples/codemirror/dune index 99182ade..9a0cc14d 100644 --- a/examples/codemirror/dune +++ b/examples/codemirror/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_codemirror bonsai_web_ui_form codemirror - codemirror_rainbow_parentheses ppx_css.inline_css codemirror_themes) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file + codemirror_rainbow_parentheses ppx_css.inline_css codemirror_themes) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/codemirror/main.ml b/examples/codemirror/main.ml index 91b13ffe..2d20e83d 100644 --- a/examples/codemirror/main.ml +++ b/examples/codemirror/main.ml @@ -3,7 +3,7 @@ open! Bonsai_web open Bonsai.Let_syntax open Codemirror open Virtual_dom -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Codemirror = Bonsai_web_ui_codemirror (* Make the codemirror editor take up most of the view *) diff --git a/examples/codicons/dune b/examples/codicons/dune index 9daa13ff..2ff8627e 100644 --- a/examples/codicons/dune +++ b/examples/codicons/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_form codicons fuzzy_match.match - js_clipboard) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file + js_clipboard) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/codicons/main.ml b/examples/codicons/main.ml index 15ab0394..d232581e 100644 --- a/examples/codicons/main.ml +++ b/examples/codicons/main.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open! Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Style = struct include diff --git a/examples/counters/bin/dune b/examples/counters/bin/dune index e9ef3d60..c213223e 100644 --- a/examples/counters/bin/dune +++ b/examples/counters/bin/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web bonsai_web_counters_example) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_counters_example) + (preprocess + (pps ppx_jane))) diff --git a/examples/counters/lib/dune b/examples/counters/lib/dune index fa78acdd..14e59fcf 100644 --- a/examples/counters/lib/dune +++ b/examples/counters/lib/dune @@ -1,2 +1,5 @@ -(library (name bonsai_web_counters_example) (libraries bonsai_web) - (preprocess (pps ppx_bonsai ppx_jane ppx_pattern_bind))) \ No newline at end of file +(library + (name bonsai_web_counters_example) + (libraries bonsai_web) + (preprocess + (pps ppx_bonsai ppx_jane ppx_pattern_bind))) diff --git a/examples/counters_condensed/dune b/examples/counters_condensed/dune index 5e219b5b..3ccf9db2 100644 --- a/examples/counters_condensed/dune +++ b/examples/counters_condensed/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/counters_cont/dune b/examples/counters_cont/dune new file mode 100644 index 00000000..3804f179 --- /dev/null +++ b/examples/counters_cont/dune @@ -0,0 +1,6 @@ +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_jane))) diff --git a/examples/counters_cont/index.html b/examples/counters_cont/index.html new file mode 100644 index 00000000..a65ab927 --- /dev/null +++ b/examples/counters_cont/index.html @@ -0,0 +1,11 @@ + + + + + Counters! + + + +
+ + diff --git a/examples/counters_cont/main.ml b/examples/counters_cont/main.ml new file mode 100644 index 00000000..53d931d4 --- /dev/null +++ b/examples/counters_cont/main.ml @@ -0,0 +1,60 @@ +open! Core +open! Bonsai_web.Cont +open Bonsai.Let_syntax + +let add_counter_component graph = + let state, inject = + Bonsai.state_machine0 + graph + ~default_model:Int.Map.empty + ~apply_action:(fun _ctx model () -> + let key = Map.length model in + Map.add_exn model ~key ~data:()) + in + let view = + let%map inject = inject in + Vdom.Node.button + ~attrs:[ Vdom.Attr.on_click (fun _ -> inject ()) ] + [ Vdom.Node.text "Add Another Counter" ] + in + state, view +;; + +module Action = struct + type t = + | Increment + | Decrement + [@@deriving sexp_of] +end + +let single_counter graph = + let state, inject = + Bonsai.state_machine0 graph ~default_model:0 ~apply_action:(fun _ctx model -> function + | Action.Increment -> model + 1 + | Action.Decrement -> model - 1) + in + let%map state = state + and inject = inject in + let button label action = + Vdom.Node.button + ~attrs:[ Vdom.Attr.on_click (fun _ -> inject action) ] + [ Vdom.Node.text label ] + in + Vdom.Node.div + [ button "-1" Action.Decrement + ; Vdom.Node.text (Int.to_string state) + ; button "+1" Action.Increment + ] +;; + +let application graph = + let map, add_button = add_counter_component graph in + let counters = + Bonsai.assoc (module Int) map graph ~f:(fun _key _data graph -> single_counter graph) + in + let%map add_button = add_button + and counters = counters in + Vdom.Node.div [ add_button; Vdom.Node.div (Map.data counters) ] +;; + +let () = Bonsai_web.Start.start application diff --git a/examples/counters_cont/main.mli b/examples/counters_cont/main.mli new file mode 100644 index 00000000..472b62cf --- /dev/null +++ b/examples/counters_cont/main.mli @@ -0,0 +1 @@ +(* this file intentionally left blank *) diff --git a/examples/dagviz/dune b/examples/dagviz/dune index 16f9f944..a60bc9c3 100644 --- a/examples/dagviz/dune +++ b/examples/dagviz/dune @@ -1,5 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries virtual_dom.svg bonsai_web_ui_element_size_hooks - bonsai_experimental_dagviz bonsai_web tailwind_colors feather_icon) + bonsai_experimental_dagviz bonsai_web tailwind_colors feather_icon) (preprocess - (pps js_of_ocaml-ppx ppx_typed_fields ppx_jane ppx_css ppx_demo ppx_bonsai))) \ No newline at end of file + (pps js_of_ocaml-ppx ppx_typed_fields ppx_jane ppx_css ppx_demo ppx_bonsai))) diff --git a/examples/drag_and_drop/bin/dune b/examples/drag_and_drop/bin/dune index ce0a9333..c6b8ab82 100644 --- a/examples/drag_and_drop/bin/dune +++ b/examples/drag_and_drop/bin/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web bonsai_drag_and_drop_example) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_drag_and_drop_example) + (preprocess + (pps ppx_jane))) diff --git a/examples/drag_and_drop/lib/dune b/examples/drag_and_drop/lib/dune index 5e7419f6..3dd13d36 100644 --- a/examples/drag_and_drop/lib/dune +++ b/examples/drag_and_drop/lib/dune @@ -1,3 +1,5 @@ -(library (name bonsai_drag_and_drop_example) +(library + (name bonsai_drag_and_drop_example) (libraries bonsai_web bonsai_web_ui_drag_and_drop) - (preprocess (pps ppx_bonsai ppx_css ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_css ppx_jane))) diff --git a/examples/drag_and_drop/test/dune b/examples/drag_and_drop/test/dune index 121dde41..c4bef45f 100644 --- a/examples/drag_and_drop/test/dune +++ b/examples/drag_and_drop/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_drag_and_drop_example_test) +(library + (name bonsai_drag_and_drop_example_test) (libraries bonsai_drag_and_drop_example bonsai_web bonsai_web_test core) - (preprocess (pps js_of_ocaml-ppx ppx_jane))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_jane))) diff --git a/examples/drag_and_drop_list/dune b/examples/drag_and_drop_list/dune index d9b16c50..f4ae6750 100644 --- a/examples/drag_and_drop_list/dune +++ b/examples/drag_and_drop_list/dune @@ -1,4 +1,7 @@ -(executables (names main) - (libraries bonsai_web bonsai_web_ui_reorderable_list bonsai_web_ui_form - virtual_dom.input_widgets) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_form bonsai_web_ui_reorderable_list + virtual_dom.input_widgets) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/drag_and_drop_list/main.ml b/examples/drag_and_drop_list/main.ml index 353c9b1b..723947b5 100644 --- a/examples/drag_and_drop_list/main.ml +++ b/examples/drag_and_drop_list/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax module Reorderable_list = Bonsai_web_ui_reorderable_list -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module S = [%css diff --git a/examples/drilldown/dune b/examples/drilldown/dune index c2e1b550..6a7f21ee 100644 --- a/examples/drilldown/dune +++ b/examples/drilldown/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web virtual_dom bonsai_web_ui_drilldown - bonsai_web_ui_tree_layout) - (preprocess (pps ppx_jane ppx_css ppx_bonsai))) \ No newline at end of file + bonsai_web_ui_tree_layout) + (preprocess + (pps ppx_jane ppx_css ppx_bonsai))) diff --git a/examples/dygraph/dune b/examples/dygraph/dune index 67c1a96f..339e6491 100644 --- a/examples/dygraph/dune +++ b/examples/dygraph/dune @@ -1,4 +1,7 @@ -(executables (names main) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane)) +(executables + (modes byte exe) + (names main) + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane)) (libraries core dygraph dygraph_jane bonsai_web virtual_dom.input_widgets - timezone)) \ No newline at end of file + timezone)) diff --git a/examples/effect_poller/dune b/examples/effect_poller/dune index 5e219b5b..3ccf9db2 100644 --- a/examples/effect_poller/dune +++ b/examples/effect_poller/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/element_size_util/dune b/examples/element_size_util/dune index 7b590cd4..6dd51c65 100644 --- a/examples/element_size_util/dune +++ b/examples/element_size_util/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_element_size_hooks) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/extensible_list/dune b/examples/extensible_list/dune index f81580ed..d2723d0d 100644 --- a/examples/extensible_list/dune +++ b/examples/extensible_list/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_extendy bonsai_web_counters_example) - (preprocess (pps ppx_bonsai ppx_jane ppx_pattern_bind))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane ppx_pattern_bind))) diff --git a/examples/favicon_svg/dune b/examples/favicon_svg/dune index e03130e7..88ae5440 100644 --- a/examples/favicon_svg/dune +++ b/examples/favicon_svg/dune @@ -1,5 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_kernel async_js bonsai_web core favicon_svg - virtual_dom.input_widgets) + virtual_dom.input_widgets) (preprocess - (pps ppx_bonsai ppx_jane js_of_ocaml-ppx ppx_css ppx_pattern_bind))) \ No newline at end of file + (pps ppx_bonsai ppx_jane js_of_ocaml-ppx ppx_css ppx_pattern_bind))) diff --git a/examples/feather_icons/dune b/examples/feather_icons/dune index 5757ffcc..7b84d193 100644 --- a/examples/feather_icons/dune +++ b/examples/feather_icons/dune @@ -1,3 +1,6 @@ -(executables (names main) - (libraries bonsai_web feather_icon bonsai_web_ui_form fuzzy_match.match) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_form feather_icon fuzzy_match.match) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/feather_icons/import.ml b/examples/feather_icons/import.ml index cc0ada88..92e36c5f 100644 --- a/examples/feather_icons/import.ml +++ b/examples/feather_icons/import.ml @@ -1,7 +1,7 @@ open! Core include Bonsai_web include Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Card_like = [%css diff --git a/examples/file_download_button/dune b/examples/file_download_button/dune index 52ce70b7..81771375 100644 --- a/examples/file_download_button/dune +++ b/examples/file_download_button/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web incr_dom.vdom_file_download) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web incr_dom.vdom_file_download) + (preprocess + (pps ppx_jane))) diff --git a/examples/finalizer_test/dune b/examples/finalizer_test/dune index 36c84237..dc7056e2 100644 --- a/examples/finalizer_test/dune +++ b/examples/finalizer_test/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries core js_of_ocaml core_kernel.weak_pointer core_kernel.weak_array - core_kernel.weak_hashtbl) - (preprocess (pps js_of_ocaml-ppx ppx_string ppx_demo))) \ No newline at end of file + core_kernel.weak_hashtbl) + (preprocess + (pps js_of_ocaml-ppx ppx_string ppx_demo))) diff --git a/examples/focus/dune b/examples/focus/dune index 3c600ef4..511bd6a4 100644 --- a/examples/focus/dune +++ b/examples/focus/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/examples/font_hosting/dune b/examples/font_hosting/dune index 99193db1..4960afc9 100644 --- a/examples/font_hosting/dune +++ b/examples/font_hosting/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_jane ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_jane ppx_css))) diff --git a/examples/form_handle_enter/dune b/examples/form_handle_enter/dune index a41c1d6d..7a423590 100644 --- a/examples/form_handle_enter/dune +++ b/examples/form_handle_enter/dune @@ -1,4 +1,7 @@ -(executables (names main) - (libraries bonsai_web bonsai_web_ui_form bonsai_web_ui_auto_generated - bonsai_web_ui_notifications) - (preprocess (pps ppx_bonsai ppx_css ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_auto_generated bonsai_web_ui_form + bonsai_web_ui_notifications) + (preprocess + (pps ppx_bonsai ppx_css ppx_jane))) diff --git a/examples/form_handle_enter/main.ml b/examples/form_handle_enter/main.ml index dcf7c088..1e563e4f 100644 --- a/examples/form_handle_enter/main.ml +++ b/examples/form_handle_enter/main.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module One = struct type t = { a : string } [@@deriving sexp, sexp_grammar] diff --git a/examples/form_table/dune b/examples/form_table/dune index 56c490b1..99a41463 100644 --- a/examples/form_table/dune +++ b/examples/form_table/dune @@ -1,5 +1,8 @@ -(executables (names main) - (libraries bonsai_experimental_table_form bonsai_web bonsai_web_ui_form - bonsai_web_ui_extendy bonsai_extra username_kernel - bonsai_web_ui_partial_render_table) - (preprocess (pps ppx_typed_fields ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_experimental_table_form bonsai_web bonsai_web_ui_extendy + bonsai_web_ui_form bonsai_extra username_kernel + bonsai_web_ui_partial_render_table) + (preprocess + (pps ppx_typed_fields ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/form_table/main.ml b/examples/form_table/main.ml index e69c52f3..c23c255f 100644 --- a/examples/form_table/main.ml +++ b/examples/form_table/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax module Username = Username_kernel.Username -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Table_form = Bonsai_experimental_table_form (* All of the fields in this record are going to be editable in the form. *) diff --git a/examples/forms/big_form.ml b/examples/forms/big_form.ml index 911b1d66..0a2a1f1d 100644 --- a/examples/forms/big_form.ml +++ b/examples/forms/big_form.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Codemirror_form = Bonsai_web_ui_codemirror_form module E = Form.Elements diff --git a/examples/forms/dune b/examples/forms/dune index d5c9a358..0e4e5790 100644 --- a/examples/forms/dune +++ b/examples/forms/dune @@ -1,6 +1,8 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_codemirror_form bonsai_web_ui_file - bonsai_web_ui_form ppx_typed_fields.typed_variants_lib - ppx_typed_fields.typed_fields_lib) + bonsai_web_ui_form ppx_typed_fields.typed_variants_lib + ppx_typed_fields.typed_fields_lib) (preprocess - (pps js_of_ocaml-ppx ppx_typed_fields ppx_bonsai ppx_css ppx_jane))) \ No newline at end of file + (pps js_of_ocaml-ppx ppx_typed_fields ppx_bonsai ppx_css ppx_jane))) diff --git a/examples/forms/file_form.ml b/examples/forms/file_form.ml index 73f27190..1cffdeb5 100644 --- a/examples/forms/file_form.ml +++ b/examples/forms/file_form.ml @@ -3,10 +3,12 @@ open Bonsai_web open Bonsai.Let_syntax let form = - let%sub file_picker = Bonsai_web_ui_form.Elements.File_select.single () in + let%sub file_picker = + Bonsai_web_ui_form.With_automatic_view.Elements.File_select.single () + in let%sub file_from_form = let%arr file_picker = file_picker in - Bonsai_web_ui_form.value file_picker |> Or_error.ok + Bonsai_web_ui_form.With_automatic_view.value file_picker |> Or_error.ok in let%sub result = Bonsai_web_ui_file.Read_on_change.create_single_opt file_from_form in let%sub result = @@ -27,7 +29,7 @@ let form = and file_picker = file_picker in View.vbox [ Vdom.Node.h1 [ View.text "File form" ] - ; Bonsai_web_ui_form.view_as_vdom file_picker + ; Bonsai_web_ui_form.With_automatic_view.view_as_vdom file_picker ; result ] ;; diff --git a/examples/forms/form_with_submit.ml b/examples/forms/form_with_submit.ml index 4a695e85..09d64dd7 100644 --- a/examples/forms/form_with_submit.ml +++ b/examples/forms/form_with_submit.ml @@ -1,6 +1,6 @@ open! Core open! Bonsai_web -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module E = Form.Elements module T = struct diff --git a/examples/forms/list_form.ml b/examples/forms/list_form.ml index 41197d4a..8788d4e3 100644 --- a/examples/forms/list_form.ml +++ b/examples/forms/list_form.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module E = Form.Elements module S = diff --git a/examples/forms/typed.ml b/examples/forms/typed.ml index 5d99e3c5..544eb88e 100644 --- a/examples/forms/typed.ml +++ b/examples/forms/typed.ml @@ -1,6 +1,6 @@ open! Core open! Bonsai_web -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module E = Form.Elements module Person = struct diff --git a/examples/freeform_multiselect/dune b/examples/freeform_multiselect/dune index 9e8033cb..e5272348 100644 --- a/examples/freeform_multiselect/dune +++ b/examples/freeform_multiselect/dune @@ -1,10 +1,16 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_freeform_multiselect) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) -(rule (targets style.css) - (deps %{workspace_root}/lib/jane_web_style/src/css/style-7.css - app_style.css) - (action (bash "cat %{deps} > %{targets}"))) +(rule + (targets style.css) + (deps %{workspace_root}/lib/jane_web_style/src/css/style-7.css app_style.css) + (action + (bash "cat %{deps} > %{targets}"))) -(alias (name DEFAULT) (deps style.css)) \ No newline at end of file +(alias + (name DEFAULT) + (deps style.css)) diff --git a/examples/gauge/dune b/examples/gauge/dune index b461d1db..236794fd 100644 --- a/examples/gauge/dune +++ b/examples/gauge/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai bonsai_web bonsai_web_ui_gauge tailwind_colors) - (preprocess (pps ppx_jane ppx_css ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_css ppx_bonsai))) diff --git a/examples/handle_io/dune b/examples/handle_io/dune index 02ce3733..3804f179 100644 --- a/examples/handle_io/dune +++ b/examples/handle_io/dune @@ -1 +1,6 @@ -(executables (names main) (libraries bonsai_web) (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_jane))) diff --git a/examples/hello_view/dune b/examples/hello_view/dune index 155f3d86..2b35f01a 100644 --- a/examples/hello_view/dune +++ b/examples/hello_view/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web kado) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web kado) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/examples/hello_world/dune b/examples/hello_world/dune index 3c600ef4..511bd6a4 100644 --- a/examples/hello_world/dune +++ b/examples/hello_world/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/examples/inline_css/dune b/examples/inline_css/dune index 72ca6bd9..3d619b2f 100644 --- a/examples/inline_css/dune +++ b/examples/inline_css/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web ppx_css.inline_css) - (preprocess (pps ppx_jane ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web ppx_css.inline_css) + (preprocess + (pps ppx_jane ppx_css))) diff --git a/examples/inline_css_dynamic/dune b/examples/inline_css_dynamic/dune new file mode 100644 index 00000000..901597bd --- /dev/null +++ b/examples/inline_css_dynamic/dune @@ -0,0 +1,6 @@ +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_form ppx_css.inline_css) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/inline_css_dynamic/index.html b/examples/inline_css_dynamic/index.html new file mode 100644 index 00000000..08ae9fec --- /dev/null +++ b/examples/inline_css_dynamic/index.html @@ -0,0 +1,11 @@ + + + + + Inline CSS Dynamic! + + + +
+ + diff --git a/examples/inline_css_dynamic/main.ml b/examples/inline_css_dynamic/main.ml new file mode 100644 index 00000000..9c0ac198 --- /dev/null +++ b/examples/inline_css_dynamic/main.ml @@ -0,0 +1,57 @@ +open! Core +open! Bonsai_web +module Form = Bonsai_web_ui_form.With_automatic_view + +let tomato = `Hex "#FF6347" + +let component = + let open Bonsai.Let_syntax in + let%sub applied, toggle = Bonsai.toggle ~default_model:true in + let%sub color_form = + Form.Elements.Color_picker.hex () + |> Bonsai.sub ~f:(Form.Dynamic.with_default (Value.return tomato)) + in + let%sub toggle_button = + let%sub theme = View.Theme.current in + let%arr toggle = toggle + and applied = applied + and theme = theme in + View.button + theme + ~on_click:toggle + (match applied with + | false -> "Apply" + | true -> "Disable") + in + let%sub attr = + match%sub applied with + | false -> Bonsai.const Vdom.Attr.empty + | true -> + let%sub color = + let%arr color_form = color_form in + Form.value_or_default color_form ~default:tomato + in + let%arr color = color in + Inline_css.Private.Dynamic.attr + [%string + {| + :root { + background-color: %{Css_gen.Color.to_string_css color} + } + |}] + in + let%arr attr = attr + and color_form = color_form + and toggle_button = toggle_button in + Vdom.Node.div + ~attrs: + [ attr + ; [%css {| + display: flex; + flex-direction: row; + |}] + ] + [ toggle_button; Form.view_as_vdom color_form ] +;; + +let () = Bonsai_web.Start.start component diff --git a/examples/inline_css_dynamic/main.mli b/examples/inline_css_dynamic/main.mli new file mode 100644 index 00000000..53e67be6 --- /dev/null +++ b/examples/inline_css_dynamic/main.mli @@ -0,0 +1 @@ +(*_ Intentionally left empty. *) diff --git a/examples/inline_css_private_appending/dune b/examples/inline_css_private_appending/dune index 538c1ecf..10c309a0 100644 --- a/examples/inline_css_private_appending/dune +++ b/examples/inline_css_private_appending/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web ppx_css.inline_css) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web ppx_css.inline_css) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/inline_css_with_var/dune b/examples/inline_css_with_var/dune index 39415772..604462a7 100644 --- a/examples/inline_css_with_var/dune +++ b/examples/inline_css_with_var/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web ppx_css.inline_css) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web ppx_css.inline_css) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_css))) diff --git a/examples/inside_incr_dom/dune b/examples/inside_incr_dom/dune index 9194a6e4..70f36658 100644 --- a/examples/inside_incr_dom/dune +++ b/examples/inside_incr_dom/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries incr_dom bonsai_web bonsai_web_counters_example) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) diff --git a/examples/kado_specific/button.ml b/examples/kado_specific/button.ml index e44261ef..a8925669 100644 --- a/examples/kado_specific/button.ml +++ b/examples/kado_specific/button.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax module Autogen = Bonsai_web_ui_auto_generated -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Parameters = struct module Disabled = Bool diff --git a/examples/kado_specific/dune b/examples/kado_specific/dune index fbe82ed3..fc00e4cd 100644 --- a/examples/kado_specific/dune +++ b/examples/kado_specific/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_extra bonsai_web kado bonsai_web_ui_auto_generated - bonsai_web_ui_form) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + bonsai_web_ui_form) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/examples/keyboard/dune b/examples/keyboard/dune index afa1d480..8024d725 100644 --- a/examples/keyboard/dune +++ b/examples/keyboard/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web virtual_dom.keyboard) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_css ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web virtual_dom.keyboard) + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_css ppx_jane))) diff --git a/examples/modal/dune b/examples/modal/dune index 434bde98..ec5ecdf6 100644 --- a/examples/modal/dune +++ b/examples/modal/dune @@ -1,3 +1,7 @@ -(executables (names main) - (libraries bonsai_web bonsai_web_ui_modal draft_modal) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_modal draft_modal + virtual_dom.input_widgets) + (preprocess + (pps ppx_bonsai ppx_css ppx_jane js_of_ocaml-ppx))) diff --git a/examples/modal/main.ml b/examples/modal/main.ml index d0746463..43dbfec1 100644 --- a/examples/modal/main.ml +++ b/examples/modal/main.ml @@ -134,7 +134,7 @@ let stacking_example = and toggle_inner = toggle_inner in let inner_modal = let contents = dialog_contents (Vdom.Node.text "inner modal") in - Native_modal.view ~on_cancel:(fun _ -> toggle_inner) contents + Native_modal.view ~on_close:toggle_inner contents in let outer_modal = let contents = @@ -144,7 +144,7 @@ let stacking_example = ; (if not show_inner then Vdom.Node.none else inner_modal) ]) in - Native_modal.view ~on_cancel:(fun _ -> toggle_outer) contents + Native_modal.view ~on_close:toggle_outer contents in [ (if not show_outer then Vdom.Node.none else outer_modal) ; Vdom.Node.div [ toggle_button "Show stacking modal" toggle_outer ] @@ -157,10 +157,7 @@ let native_app = of creating several different similar variations. *) (* Creates the button to show/hide the modal and has state management. creator should be fun on_cancel -> modal *) - let create_modal_example creator button_text ?desc _ = - let%sub show, toggle = Bonsai.toggle ~default_model:false in - let%arr show = show - and toggle = toggle in + let create_modal_example' ?desc creator button_text ~show ~toggle () = let toggle_button text toggler = Vdom.Node.button ~attrs:[ Vdom.Attr.on_click (fun _ -> toggler) ] @@ -183,6 +180,12 @@ let native_app = ; Vdom.Node.div [ toggle_button button_text toggle; extra_desc_markup ] ] in + let create_modal_example ?desc creator button_text () = + let%sub show, toggle = Bonsai.toggle ~default_model:false in + let%arr show = show + and toggle = toggle in + create_modal_example' ?desc creator button_text ~show ~toggle () + in let%sub simple_modal = (* I have many examples so I factored out the logic that adds a button and manages show/hide with bonsai state, but you can just write that directly. @@ -195,7 +198,7 @@ let native_app = (Vdom.Node.div [ Vdom.Node.text "I'm a simple modal dialog (or dialog modal.)" ]) in - Native_modal.view ~on_cancel:(fun _ -> toggle) contents + Native_modal.view ~on_close:toggle contents in create_modal_example creator "Simple modal" () in @@ -207,10 +210,47 @@ let native_app = ~close_button:toggle (Vdom.Node.div [ Vdom.Node.text "I'm a side sheet modal." ]) in - Native_modal.view ~layout:`Right_side_sheet ~on_cancel:(fun _ -> toggle) contents + Native_modal.view ~layout:`Right_side_sheet ~on_close:toggle contents in create_modal_example creator "Side sheet" () in + let%sub confirm_modal = + let%sub contents, confirm_prompt = + let%sub value, set_value = Bonsai.state None in + let%arr value = value + and set_value = set_value in + let module N = Vdom.Node in + ( N.div + ~attrs:[ {%css| padding: 4px; |} ] + [ Vdom_input_widgets.Entry.text + ~value + ~on_input:set_value + ~allow_updates_when_focused:`Always + () + ] + , Option.map value ~f:(fun _ -> "Are you sure you want to close?") ) + in + let%sub show, toggle = Bonsai.toggle ~default_model:false in + let%arr contents = contents + and confirm_prompt = confirm_prompt + and show = show + and toggle = toggle in + let creator ~toggle = + Native_modal.view + ?on_cancel: + (Option.map confirm_prompt ~f:(fun prompt -> + Draft_modal.confirm_on_cancel ~prompt)) + ~cancel_on_overlay_click:true + ~on_close:toggle + contents + in + create_modal_example' + creator + "Show confirmation prompt on unsaved changes" + ~show + ~toggle + () + in let%sub transparent_modal = let creator ~toggle = let contents = @@ -222,7 +262,7 @@ let native_app = ~transparent_overlay:true ~animated:false ~disable_body_scroll:false - ~on_cancel:(fun _ -> toggle) + ~on_close:toggle contents in create_modal_example creator "Transparent backdrop, no animation" () @@ -245,6 +285,7 @@ let native_app = let%sub stacking_example = stacking_example in let%arr simple_modal = simple_modal and side_sheet_modal = side_sheet_modal + and confirm_modal = confirm_modal and transparent_modal = transparent_modal and stacking_example = stacking_example and add_lots_of_content_markup = add_lots_of_content_markup in @@ -256,6 +297,7 @@ let native_app = [ [ intro_text ] ; simple_modal ; side_sheet_modal + ; confirm_modal ; transparent_modal ; stacking_example ; add_lots_of_content_markup diff --git a/examples/mouse_position/client/bin/dune b/examples/mouse_position/client/bin/dune index e9730db5..4b1b3bb0 100644 --- a/examples/mouse_position/client/bin/dune +++ b/examples/mouse_position/client/bin/dune @@ -1,5 +1,8 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js polling_state_rpc async_kernel - bonsai_examples_mouse_position_lib bonsai_web core - bonsai_examples_mouse_position_common) - (preprocess (pps ppx_jane))) \ No newline at end of file + bonsai_examples_mouse_position_lib bonsai_web core + bonsai_examples_mouse_position_common) + (preprocess + (pps ppx_jane))) diff --git a/examples/mouse_position/client/src/dune b/examples/mouse_position/client/src/dune index 59095242..1f58ee87 100644 --- a/examples/mouse_position/client/src/dune +++ b/examples/mouse_position/client/src/dune @@ -1,9 +1,13 @@ -(library (name bonsai_examples_mouse_position_lib) +(library + (name bonsai_examples_mouse_position_lib) (libraries async_kernel bonsai_web core - bonsai_examples_mouse_position_common bonsai_web_ui_view tailwind_colors - ppx_css.inline_css) - (preprocess (pps js_of_ocaml-ppx ppx_jane ppx_bonsai))) + bonsai_examples_mouse_position_common bonsai_web_ui_view tailwind_colors + ppx_css.inline_css) + (preprocess + (pps js_of_ocaml-ppx ppx_jane ppx_bonsai))) -(rule (targets style.ml style.mli style__generated.ml style__generated.mli) +(rule + (targets style.ml style.mli style__generated.ml style__generated.mli) (deps style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) \ No newline at end of file + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) diff --git a/examples/mouse_position/client/test/dune b/examples/mouse_position/client/test/dune index 080bbe6d..92b04cbb 100644 --- a/examples/mouse_position/client/test/dune +++ b/examples/mouse_position/client/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_examples_mouse_position_test) +(library + (name bonsai_examples_mouse_position_test) (libraries async_kernel bonsai_examples_mouse_position_lib bonsai_web - bonsai_web_test core) - (preprocess (pps js_of_ocaml-ppx ppx_jane))) \ No newline at end of file + bonsai_web_test core) + (preprocess + (pps js_of_ocaml-ppx ppx_jane))) diff --git a/examples/mouse_position/common/bonsai_examples_mouse_position_common.ml b/examples/mouse_position/common/bonsai_examples_mouse_position_common.ml index ad2b30b9..7dfff3ec 100644 --- a/examples/mouse_position/common/bonsai_examples_mouse_position_common.ml +++ b/examples/mouse_position/common/bonsai_examples_mouse_position_common.ml @@ -13,8 +13,8 @@ end module Session = Unique_id.Int () module Active_users = struct - type t = { active_users : (Username.t[@atomic]) Session.Map.t [@ldiff.map] } - [@@deriving ldiff, bin_io, equal, sexp] + type t = { active_users : (Username.t[@atomic]) Session.Map.t [@diff.map] } + [@@deriving diff, bin_io, equal, sexp] end module Protocol = struct @@ -25,7 +25,7 @@ module Protocol = struct ~version:0 ~query_equal:[%equal: unit] ~bin_query:[%bin_type_class: unit] - (module Ldiffable_polling_state_rpc_response.Polling_state_rpc_response.Make + (module Diffable_polling_state_rpc_response.Polling_state_rpc_response.Make (Active_users)) ;; end diff --git a/examples/mouse_position/common/dune b/examples/mouse_position/common/dune index 3bff3ca9..0134763a 100644 --- a/examples/mouse_position/common/dune +++ b/examples/mouse_position/common/dune @@ -1,4 +1,6 @@ -(library (name bonsai_examples_mouse_position_common) - (preprocess (pps ppx_jane ppx_diff.ppx_diff)) +(library + (name bonsai_examples_mouse_position_common) + (preprocess + (pps ppx_jane ppx_diff.ppx_diff)) (libraries async_kernel polling_state_rpc async_rpc_kernel - ldiffable_polling_state_rpc_response core username_kernel)) \ No newline at end of file + diffable_polling_state_rpc_response core username_kernel)) diff --git a/examples/mouse_position/doc/dune b/examples/mouse_position/doc/dune index 8e999c83..8c2f0627 100644 --- a/examples/mouse_position/doc/dune +++ b/examples/mouse_position/doc/dune @@ -1,8 +1,16 @@ -(executables (names graph_generator) +(executables + (modes byte exe) + (names graph_generator) (libraries bonsai_examples_mouse_position_lib bonsai) - (preprocess (pps ppx_jane ppx_pattern_bind))) + (preprocess + (pps ppx_jane ppx_pattern_bind))) -(rule (targets graph.svg) (deps graph_generator.bc.js) - (action (bash "%{NODE} %{deps} | dot -T svg -ograph.svg"))) +(rule + (targets graph.svg) + (deps graph_generator.bc.js) + (action + (bash "%{NODE} %{deps} | dot -T svg -ograph.svg"))) -(alias (name DEFAULT) (deps graph.svg)) \ No newline at end of file +(alias + (name DEFAULT) + (deps graph.svg)) diff --git a/examples/mouse_position/server/bin/dune b/examples/mouse_position/server/bin/dune index 803f1ce1..962aead2 100644 --- a/examples/mouse_position/server/bin/dune +++ b/examples/mouse_position/server/bin/dune @@ -1,4 +1,6 @@ -(executables (names main) - (libraries core bonsai_examples_mouse_position_native - core_unix.command_unix) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries core bonsai_examples_mouse_position_native core_unix.command_unix) + (preprocess + (pps ppx_jane))) diff --git a/examples/mouse_position/server/src/bonsai_examples_mouse_position_native.ml b/examples/mouse_position/server/src/bonsai_examples_mouse_position_native.ml index f31230ba..7725f7e2 100644 --- a/examples/mouse_position/server/src/bonsai_examples_mouse_position_native.ml +++ b/examples/mouse_position/server/src/bonsai_examples_mouse_position_native.ml @@ -14,11 +14,15 @@ let main ~http_settings ~js_file = let%bind server = let open Cohttp_static_handler in let javascript = - Asset.local Asset.Kind.javascript (Asset.What_to_serve.file ~path:js_file) + Asset.local + Asset.Kind.javascript + (Asset.What_to_serve.file ~path:js_file ~relative_to:`Cwd) in let sourcemap_file = String.chop_suffix_exn js_file ~suffix:".js" ^ ".map" in let sourcemap = - Asset.local Asset.Kind.sourcemap (Asset.What_to_serve.file ~path:sourcemap_file) + Asset.local + Asset.Kind.sourcemap + (Asset.What_to_serve.file ~path:sourcemap_file ~relative_to:`Cwd) in let http_handler _principle = Single_page_handler.create_handler diff --git a/examples/mouse_position/server/src/dune b/examples/mouse_position/server/src/dune index fb06ab7a..4c46157e 100644 --- a/examples/mouse_position/server/src/dune +++ b/examples/mouse_position/server/src/dune @@ -1,5 +1,7 @@ -(library (name bonsai_examples_mouse_position_native) +(library + (name bonsai_examples_mouse_position_native) (libraries polling_state_rpc cohttp_static_handler csp_monoid - simple_web_server bonsai_examples_mouse_position_common exe_server_client - exe_server_protocol tempfile core_unix.filename_unix) - (preprocess (pps ppx_jane))) \ No newline at end of file + simple_web_server bonsai_examples_mouse_position_common exe_server_client + exe_server_protocol tempfile core_unix.filename_unix) + (preprocess + (pps ppx_jane))) diff --git a/examples/multi_select/dune b/examples/multi_select/dune index 0e4f71e5..5f40ec30 100644 --- a/examples/multi_select/dune +++ b/examples/multi_select/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web_ui_multi_select) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web_ui_multi_select) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/examples/node_with_map_children/dune b/examples/node_with_map_children/dune index fb425b25..8c0d8cd8 100644 --- a/examples/node_with_map_children/dune +++ b/examples/node_with_map_children/dune @@ -1,4 +1,8 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web feather_icon vdom_node_with_map_children) - (js_of_ocaml (javascript_files ./validate.js)) - (preprocess (pps ppx_jane ppx_bonsai ppx_css js_of_ocaml-ppx))) \ No newline at end of file + (js_of_ocaml + (javascript_files ./validate.js)) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css js_of_ocaml-ppx))) diff --git a/examples/not_connected_warning_box/dune b/examples/not_connected_warning_box/dune index 86c4a4fd..798ddcb8 100644 --- a/examples/not_connected_warning_box/dune +++ b/examples/not_connected_warning_box/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_not_connected_warning_box) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/notifications/dune b/examples/notifications/dune index 7d65d96b..3cc31d1f 100644 --- a/examples/notifications/dune +++ b/examples/notifications/dune @@ -1,5 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_notifications core_kernel.nonempty_list - bonsai_web_ui_gallery) + bonsai_web_ui_gallery) (preprocess - (pps js_of_ocaml-ppx ppx_bonsai ppx_jane ppx_demo ppx_typed_fields))) \ No newline at end of file + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane ppx_demo ppx_typed_fields))) diff --git a/examples/notifications_test/dune b/examples/notifications_test/dune index 55b424fd..aeef5050 100644 --- a/examples/notifications_test/dune +++ b/examples/notifications_test/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_notifications core_kernel.nonempty_list - bonsai_web_ui_gallery) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane ppx_demo))) \ No newline at end of file + bonsai_web_ui_gallery) + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane ppx_demo))) diff --git a/examples/oklab/dune b/examples/oklab/dune index b8912aa0..9808661c 100644 --- a/examples/oklab/dune +++ b/examples/oklab/dune @@ -1,3 +1,6 @@ -(executables (names main) - (libraries bonsai_web oklab bonsai_web_ui_form kado) - (preprocess (pps ppx_jane ppx_css ppx_typed_fields ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_form oklab kado) + (preprocess + (pps ppx_jane ppx_css ppx_typed_fields ppx_bonsai))) diff --git a/examples/oklab/knobs.ml b/examples/oklab/knobs.ml index 6aa7bf7f..f07a083e 100644 --- a/examples/oklab/knobs.ml +++ b/examples/oklab/knobs.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Style = [%css diff --git a/examples/on_display/dune b/examples/on_display/dune index 5e219b5b..3ccf9db2 100644 --- a/examples/on_display/dune +++ b/examples/on_display/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/open_source/rpc_chat/client/dune b/examples/open_source/rpc_chat/client/dune index 5e6f6042..dba31e0d 100644 --- a/examples/open_source/rpc_chat/client/dune +++ b/examples/open_source/rpc_chat/client/dune @@ -1,4 +1,7 @@ -(executables (names main) (modes js) +(executables + (names main) + (modes js) (libraries async_kernel async_js core_kernel.composition_infix core - bonsai_web bonsai_chat_open_source_common virtual_dom.input_widgets) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) \ No newline at end of file + bonsai_web bonsai_chat_open_source_common virtual_dom.input_widgets) + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) diff --git a/examples/open_source/rpc_chat/common/dune b/examples/open_source/rpc_chat/common/dune index f0aeb3e2..fe8c4b17 100644 --- a/examples/open_source/rpc_chat/common/dune +++ b/examples/open_source/rpc_chat/common/dune @@ -1,3 +1,6 @@ -(library (name bonsai_chat_open_source_common) +(library + (name bonsai_chat_open_source_common) (public_name bonsai.example_chat_open_source_native_common) - (libraries core async_kernel async_rpc_kernel) (preprocess (pps ppx_jane))) \ No newline at end of file + (libraries core async_kernel async_rpc_kernel) + (preprocess + (pps ppx_jane))) diff --git a/examples/open_source/rpc_chat/server/bin/dune b/examples/open_source/rpc_chat/server/bin/dune index 6efd3e5a..d064d5af 100644 --- a/examples/open_source/rpc_chat/server/bin/dune +++ b/examples/open_source/rpc_chat/server/bin/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_chat_open_source_native core_unix.command_unix) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/examples/open_source/rpc_chat/server/src/dune b/examples/open_source/rpc_chat/server/src/dune index c235816f..d994dcd7 100644 --- a/examples/open_source/rpc_chat/server/src/dune +++ b/examples/open_source/rpc_chat/server/src/dune @@ -1,9 +1,13 @@ -(library (name bonsai_chat_open_source_native) +(library + (name bonsai_chat_open_source_native) (public_name bonsai.example_chat_open_source_native) (libraries async_extra.async_bus bonsai_chat_open_source_common - async_rpc_websocket cohttp-async) - (preprocess (pps ppx_jane))) + async_rpc_websocket cohttp-async) + (preprocess + (pps ppx_jane))) -(rule (targets embedded_files.ml embedded_files.mli) +(rule + (targets embedded_files.ml embedded_files.mli) (deps ../../client/main.bc.js ../../client/style.css) - (action (bash "%{bin:ocaml-embed-file} %{deps} -output embedded_files"))) \ No newline at end of file + (action + (bash "%{bin:ocaml-embed-file} %{deps} -output embedded_files"))) diff --git a/examples/panels/dune b/examples/panels/dune index 0387da41..025d6e3e 100644 --- a/examples/panels/dune +++ b/examples/panels/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries core bonsai_web bonsai_web_ui_panels_experimental) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/partial_render_table/bin/dune b/examples/partial_render_table/bin/dune index 47e90e0b..9f9583bf 100644 --- a/examples/partial_render_table/bin/dune +++ b/examples/partial_render_table/bin/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_gallery - bonsai_partial_render_table_example) - (preprocess (pps ppx_bonsai))) \ No newline at end of file + bonsai_partial_render_table_example) + (preprocess + (pps ppx_bonsai))) diff --git a/examples/partial_render_table/bin/main.ml b/examples/partial_render_table/bin/main.ml index 026adaf3..ecb07222 100644 --- a/examples/partial_render_table/bin/main.ml +++ b/examples/partial_render_table/bin/main.ml @@ -4,23 +4,45 @@ open Bonsai.Let_syntax module PRT_example = Bonsai_partial_render_table_example let component ~theme_picker = - let%sub form_view, { themed; show_position; row_height; num_rows } = + let%sub ( form_view + , { themed; show_position; row_height; num_rows; cell_based_highlighting } ) + = PRT_example.Layout_form.component in let%sub data = let%arr num_rows = num_rows in PRT_example.Row.many_random num_rows in - let%sub table, focus_attr = - let base = - PRT_example.table_and_focus_attr - ~should_show_position:show_position - ~row_height - data - in - match%sub themed with - | false -> base ~theming:`Legacy_don't_use_theme - | true -> base ~theming:`Themed + let%sub { table; focus_attr; set_column_width } = + match%sub cell_based_highlighting with + | false -> + let base = + PRT_example.component + ~focus_kind:`Row + ~should_show_position:show_position + ~row_height + data + in + (match%sub themed with + | false -> base ~theming:`Legacy_don't_use_theme + | true -> base ~theming:`Themed) + | true -> + let base = + PRT_example.component + ~focus_kind:`Cell + ~should_show_position:show_position + ~row_height + data + in + (match%sub themed with + | false -> base ~theming:`Legacy_don't_use_theme + | true -> base ~theming:`Themed) + in + let%sub form_view = + let%sub width_form = PRT_example.Column_width_form.component ~set_column_width in + let%arr form_view = form_view + and width_form = width_form in + View.vbox [ form_view; width_form ] in let%arr form_view = form_view and table = table diff --git a/examples/partial_render_table/src/bonsai_partial_render_table_example.ml b/examples/partial_render_table/src/bonsai_partial_render_table_example.ml index 06fbfd58..069a7ef6 100644 --- a/examples/partial_render_table/src/bonsai_partial_render_table_example.ml +++ b/examples/partial_render_table/src/bonsai_partial_render_table_example.ml @@ -2,7 +2,8 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax module Table = Bonsai_web_ui_partial_render_table.Basic -module Form = Bonsai_web_ui_form +module Indexed_column_id = Bonsai_web_ui_partial_render_table.Indexed_column_id +module Form = Bonsai_web_ui_form.With_automatic_view module Row = Row module Time_ns_option = struct @@ -120,13 +121,28 @@ let columns ~should_show_position = |> Column.lift ;; -let table_and_focus_attr ?filter ~row_height ~theming ~should_show_position data = +type t = + { table : Vdom.Node.t + ; focus_attr : Vdom.Attr.t + ; set_column_width : + column_id:Indexed_column_id.t -> [ `Px_float of float ] -> unit Ui_effect.t + } + +let generic_table_and_focus_attr + ?filter + ~row_height + ~theming + ~should_show_position + ~focus + ~attr_of_focus + data + = let%sub table = Table.component (module String) ?filter ~theming - ~focus:(By_row { on_change = Value.return (Fn.const Effect.Ignore) }) + ~focus ~row_height ~columns:(columns ~should_show_position) data @@ -136,29 +152,79 @@ let table_and_focus_attr ?filter ~row_height ~theming ~should_show_position data ; sortable_state = _ ; num_filtered_rows ; focus + ; set_column_width } = table in - let focus_attr = - Vdom.Attr.on_keydown (fun kbc -> - let binding = - let module Focus_control = Table.Focus.By_row in - match Js_of_ocaml.Dom_html.Keyboard_code.of_event kbc with - | ArrowDown | KeyJ -> Some (Focus_control.focus_down focus) - | ArrowUp | KeyK -> Some (Focus_control.focus_up focus) - | PageDown -> Some (Focus_control.page_down focus) - | PageUp -> Some (Focus_control.page_up focus) - | Escape -> Some (Focus_control.unfocus focus) - | Home -> Some ((Focus_control.focus_index focus) 0) - | End -> Some ((Focus_control.focus_index focus) num_filtered_rows) - | _ -> None - in - match binding with - | Some b -> Effect.Many [ Effect.Prevent_default; b ] - | None -> Effect.Ignore) - in - table, focus_attr + let focus_attr = attr_of_focus focus ~num_filtered_rows in + { table; focus_attr; set_column_width } +;; + +let component ?filter ~focus_kind ~row_height ~theming ~should_show_position data = + match focus_kind with + | `Row -> + let module Focus_control = Table.Focus.By_row in + generic_table_and_focus_attr + ?filter + ~row_height + ~theming + ~should_show_position + ~focus:(By_row { on_change = Value.return (Fn.const Effect.Ignore) }) + ~attr_of_focus:(fun (focus : _ Table.Focus.By_row.t) ~num_filtered_rows -> + Vdom.Attr.on_keydown (fun kbc -> + let binding = + match Js_of_ocaml.Dom_html.Keyboard_code.of_event kbc with + | ArrowDown | KeyJ -> Some (Focus_control.focus_down focus) + | ArrowUp | KeyK -> Some (Focus_control.focus_up focus) + | PageDown -> Some (Focus_control.page_down focus) + | PageUp -> Some (Focus_control.page_up focus) + | Escape -> Some (Focus_control.unfocus focus) + | Home -> Some ((Focus_control.focus_index focus) 0) + | End -> Some ((Focus_control.focus_index focus) num_filtered_rows) + | _ -> None + in + match binding with + | Some b -> Effect.Many [ Effect.Prevent_default; b ] + | None -> Effect.Ignore)) + data + | `Cell -> + let module Focus_control = Table.Focus.By_cell in + generic_table_and_focus_attr + ?filter + ~row_height + ~theming + ~should_show_position + ~focus:(By_cell { on_change = Value.return (Fn.const Effect.Ignore) }) + ~attr_of_focus:(fun focus ~num_filtered_rows -> + let current_or_first_column = + match Focus_control.focused focus with + | None -> Indexed_column_id.of_int 0 + | Some (_, c) -> c + in + Vdom.Attr.on_keydown (fun kbc -> + let binding = + let module Focus_control = Table.Focus.By_cell in + match Js_of_ocaml.Dom_html.Keyboard_code.of_event kbc with + | ArrowDown | KeyJ -> Some (Focus_control.focus_down focus) + | ArrowUp | KeyK -> Some (Focus_control.focus_up focus) + | ArrowRight | KeyL -> Some (Focus_control.focus_right focus) + | ArrowLeft | KeyH -> Some (Focus_control.focus_left focus) + | PageDown -> Some (Focus_control.page_down focus) + | PageUp -> Some (Focus_control.page_up focus) + | Escape -> Some (Focus_control.unfocus focus) + | Home -> Some ((Focus_control.focus_index focus) 0 current_or_first_column) + | End -> + Some + ((Focus_control.focus_index focus) + num_filtered_rows + current_or_first_column) + | _ -> None + in + match binding with + | Some b -> Effect.Many [ Effect.Prevent_default; b ] + | None -> Effect.Ignore)) + data ;; module Layout_form = struct @@ -166,6 +232,7 @@ module Layout_form = struct type t = { themed : bool ; show_position : bool + ; cell_based_highlighting : bool ; row_height : [ `Px of int ] ; num_rows : int } @@ -174,6 +241,7 @@ module Layout_form = struct let form_for_field : type a. a Typed_field.t -> a Form.t Computation.t = function | Themed -> Form.Elements.Toggle.bool ~default:true () | Show_position -> Form.Elements.Toggle.bool ~default:true () + | Cell_based_highlighting -> Form.Elements.Toggle.bool ~default:false () | Row_height -> let%sub form = Form.Elements.Range.int @@ -189,7 +257,7 @@ module Layout_form = struct | Num_rows -> Form.Elements.Number.int ~allow_updates_when_focused:`Never - ~default:100_000 + ~default:10_000 ~step:1 () ;; @@ -204,9 +272,46 @@ module Layout_form = struct Form.value_or_default form ~default: - { themed = true; show_position = true; row_height = `Px 30; num_rows = 100_000 } + { themed = true + ; show_position = true + ; row_height = `Px 30 + ; num_rows = 10_000 + ; cell_based_highlighting = false + } in let view = Vdom.Node.div ~attrs:[ Style.form_container ] [ Form.view_as_vdom form ] in view, values ;; end + +module Column_width_form = struct + let component ~set_column_width = + let open Bonsai.Let_syntax in + let%sub form = + Form.Elements.Textbox.int + ~placeholder:"Symbol column width" + ~allow_updates_when_focused:`Always + () + in + let%sub button = + let%sub theme = View.Theme.current in + let%arr form = form + and theme = theme + and set_column_width = set_column_width in + let value = Form.value form in + let disabled = Or_error.is_error value in + let on_click = + match value with + | Error _ -> Effect.Ignore + | Ok value -> + set_column_width + ~column_id:(Indexed_column_id.of_int 0) + (`Px_float (Int.to_float value)) + in + View.button ~disabled theme ~on_click "Set width" + in + let%arr form = form + and button = button in + View.hbox [ Form.view_as_vdom form; button ] + ;; +end diff --git a/examples/partial_render_table/src/bonsai_partial_render_table_example.mli b/examples/partial_render_table/src/bonsai_partial_render_table_example.mli index b6b22244..08bfa258 100644 --- a/examples/partial_render_table/src/bonsai_partial_render_table_example.mli +++ b/examples/partial_render_table/src/bonsai_partial_render_table_example.mli @@ -2,19 +2,30 @@ open! Core open! Bonsai_web module Row = Row -val table_and_focus_attr +type t = + { table : Vdom.Node.t + ; focus_attr : Vdom.Attr.t + ; set_column_width : + column_id:Bonsai_web_ui_partial_render_table.Indexed_column_id.t + -> [ `Px_float of float ] + -> unit Ui_effect.t + } + +val component : ?filter:(key:string -> data:Row.t -> bool) Value.t + -> focus_kind:[ `Row | `Cell ] -> row_height:[ `Px of int ] Value.t -> theming:[ `Legacy_don't_use_theme | `Themed ] -> should_show_position:bool Value.t -> (string, Row.t, Base.String.comparator_witness) Base.Map.t Value.t - -> (Vdom.Node.t * Vdom.Attr.t) Computation.t + -> t Computation.t module Layout_form : sig module Params : sig type t = { themed : bool ; show_position : bool + ; cell_based_highlighting : bool ; row_height : [ `Px of int ] ; num_rows : int } @@ -22,3 +33,13 @@ module Layout_form : sig val component : (Vdom.Node.t * Params.t) Computation.t end + +module Column_width_form : sig + val component + : set_column_width: + (column_id:Bonsai_web_ui_partial_render_table.Indexed_column_id.t + -> [ `Px_float of float ] + -> unit Ui_effect.t) + Value.t + -> Vdom.Node.t Computation.t +end diff --git a/examples/partial_render_table/src/dune b/examples/partial_render_table/src/dune index 5b0178ca..2f3040b8 100644 --- a/examples/partial_render_table/src/dune +++ b/examples/partial_render_table/src/dune @@ -1,3 +1,5 @@ -(library (name bonsai_partial_render_table_example) - (libraries bonsai_web bonsai_web_ui_partial_render_table bonsai_web_ui_form) - (preprocess (pps ppx_bonsai ppx_css ppx_jane ppx_typed_fields))) \ No newline at end of file +(library + (name bonsai_partial_render_table_example) + (libraries bonsai_web bonsai_web_ui_form bonsai_web_ui_partial_render_table) + (preprocess + (pps ppx_bonsai ppx_css ppx_jane ppx_typed_fields))) diff --git a/examples/partial_render_table_fully_dynamic/dune b/examples/partial_render_table_fully_dynamic/dune index 3fc9139b..aae6fcdf 100644 --- a/examples/partial_render_table_fully_dynamic/dune +++ b/examples/partial_render_table_fully_dynamic/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_form kado - bonsai_web_ui_partial_render_table) - (preprocess (pps ppx_bonsai ppx_css ppx_jane ppx_typed_fields))) \ No newline at end of file + bonsai_web_ui_partial_render_table) + (preprocess + (pps ppx_bonsai ppx_css ppx_jane ppx_typed_fields))) diff --git a/examples/partial_render_table_fully_dynamic/main.ml b/examples/partial_render_table_fully_dynamic/main.ml index 293f246e..ce4e07f9 100644 --- a/examples/partial_render_table_fully_dynamic/main.ml +++ b/examples/partial_render_table_fully_dynamic/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax module Table = Bonsai_web_ui_partial_render_table.Basic -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Row = Row module Time_ns_option = struct @@ -68,6 +68,7 @@ let component ?filter (data : Row.t String.Map.t Value.t) = ; sortable_state = _ ; num_filtered_rows ; focus + ; set_column_width = _ } = table diff --git a/examples/persistent_var/dune b/examples/persistent_var/dune index cc965bbd..fb636a6e 100644 --- a/examples/persistent_var/dune +++ b/examples/persistent_var/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_bonsai))) diff --git a/examples/polling_state_rpc_stress_test/dune b/examples/polling_state_rpc_stress_test/dune index cafba3a0..82598659 100644 --- a/examples/polling_state_rpc_stress_test/dune +++ b/examples/polling_state_rpc_stress_test/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_rpc_kernel bonsai_web expect_test_helpers_core - ldiffable_polling_state_rpc_response) - (preprocess (pps ppx_jane ppx_diff.ppx_diff ppx_bonsai))) \ No newline at end of file + diffable_polling_state_rpc_response) + (preprocess + (pps ppx_jane ppx_diff.ppx_diff ppx_bonsai))) diff --git a/examples/polling_state_rpc_stress_test/main.ml b/examples/polling_state_rpc_stress_test/main.ml index da65d673..5a46cc63 100644 --- a/examples/polling_state_rpc_stress_test/main.ml +++ b/examples/polling_state_rpc_stress_test/main.ml @@ -14,7 +14,7 @@ open Bonsai.Let_syntax type Rpc_effect.Where_to_connect.Custom.t += Connection module T = struct - type t = { data : int Int.Map.t [@ldiff.map] } [@@deriving sexp, ldiff, bin_io, equal] + type t = { data : int Int.Map.t [@diff.map] } [@@deriving sexp, diff, bin_io, equal] end let rpc = @@ -23,7 +23,7 @@ let rpc = ~version:0 ~query_equal:[%equal: int] ~bin_query:[%bin_type_class: int] - (module Ldiffable_polling_state_rpc_response.Polling_state_rpc_response.Make (T)) + (module Diffable_polling_state_rpc_response.Polling_state_rpc_response.Make (T)) ;; let component = diff --git a/examples/popover/dune b/examples/popover/dune index 968eb2c3..608374b2 100644 --- a/examples/popover/dune +++ b/examples/popover/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_web bonsai_web_ui_gallery bonsai_web_ui_popover) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) \ No newline at end of file + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) diff --git a/examples/popover_test/dune b/examples/popover_test/dune index 968eb2c3..608374b2 100644 --- a/examples/popover_test/dune +++ b/examples/popover_test/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_web bonsai_web_ui_gallery bonsai_web_ui_popover) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) \ No newline at end of file + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) diff --git a/examples/query_box/dune b/examples/query_box/dune index 540c272b..85feb3a3 100644 --- a/examples/query_box/dune +++ b/examples/query_box/dune @@ -1,3 +1,6 @@ -(executables (names main) - (libraries bonsai_web bonsai_web_ui_query_box bonsai_web_ui_form) - (preprocess (pps ppx_jane ppx_bonsai ppx_css ppx_typed_fields))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_form bonsai_web_ui_query_box) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css ppx_typed_fields))) diff --git a/examples/query_box/main.ml b/examples/query_box/main.ml index a44b06f3..cfacc08b 100644 --- a/examples/query_box/main.ml +++ b/examples/query_box/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open! Vdom open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Query_box = Bonsai_web_ui_query_box module Css = diff --git a/examples/rpc_chat/client/bin/dune b/examples/rpc_chat/client/bin/dune index d6c32fb5..de8bd026 100644 --- a/examples/rpc_chat/client/bin/dune +++ b/examples/rpc_chat/client/bin/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_examples_rpc_chat_client) - (preprocess (pps js_of_ocaml-ppx ppx_css ppx_jane))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_css ppx_jane))) diff --git a/examples/rpc_chat/client/src/dune b/examples/rpc_chat/client/src/dune index 009c4b6a..250bcb07 100644 --- a/examples/rpc_chat/client/src/dune +++ b/examples/rpc_chat/client/src/dune @@ -1,4 +1,6 @@ -(library (name bonsai_examples_rpc_chat_client) +(library + (name bonsai_examples_rpc_chat_client) (libraries async_kernel core bonsai_web bonsai_chat_common - virtual_dom.input_widgets) - (preprocess (pps js_of_ocaml-ppx ppx_css ppx_jane ppx_bonsai))) \ No newline at end of file + virtual_dom.input_widgets) + (preprocess + (pps js_of_ocaml-ppx ppx_css ppx_jane ppx_bonsai))) diff --git a/examples/rpc_chat/common/dune b/examples/rpc_chat/common/dune index 9f4900b4..f97da432 100644 --- a/examples/rpc_chat/common/dune +++ b/examples/rpc_chat/common/dune @@ -1,2 +1,5 @@ -(library (name bonsai_chat_common) - (libraries core async_kernel async_rpc_kernel) (preprocess (pps ppx_jane))) \ No newline at end of file +(library + (name bonsai_chat_common) + (libraries core async_kernel async_rpc_kernel) + (preprocess + (pps ppx_jane))) diff --git a/examples/rpc_chat/server/bin/dune b/examples/rpc_chat/server/bin/dune index c80a9708..d96805f7 100644 --- a/examples/rpc_chat/server/bin/dune +++ b/examples/rpc_chat/server/bin/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_chat_native core_unix.command_unix) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/examples/rpc_chat/server/src/dune b/examples/rpc_chat/server/src/dune index d43bade4..ffa6ac20 100644 --- a/examples/rpc_chat/server/src/dune +++ b/examples/rpc_chat/server/src/dune @@ -1,8 +1,12 @@ -(library (name bonsai_chat_native) +(library + (name bonsai_chat_native) (libraries async_extra.async_bus bonsai_chat_common cohttp_static_handler - csp_monoid simple_web_server) - (preprocess (pps ppx_jane))) + csp_monoid simple_web_server) + (preprocess + (pps ppx_jane))) -(rule (targets embedded_files.ml embedded_files.mli) +(rule + (targets embedded_files.ml embedded_files.mli) (deps %{bin:ocaml-embed-file} ../../client/main.bc.js) - (action (bash "%{deps} -output embedded_files"))) \ No newline at end of file + (action + (bash "%{deps} -output embedded_files"))) diff --git a/examples/rpgdice/bin/dune b/examples/rpgdice/bin/dune index fbdef159..32ae51a0 100644 --- a/examples/rpgdice/bin/dune +++ b/examples/rpgdice/bin/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_kernel bonsai_web bonsai_web_rpgdice_example core - virtual_dom.input_widgets) - (preprocess (pps ppx_bonsai ppx_jane js_of_ocaml-ppx ppx_pattern_bind))) \ No newline at end of file + virtual_dom.input_widgets) + (preprocess + (pps ppx_bonsai ppx_jane js_of_ocaml-ppx ppx_pattern_bind))) diff --git a/examples/rpgdice/src/dune b/examples/rpgdice/src/dune index 68f436ed..3f6eb042 100644 --- a/examples/rpgdice/src/dune +++ b/examples/rpgdice/src/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_rpgdice_example) +(library + (name bonsai_web_rpgdice_example) (libraries angstrom core_kernel.composition_infix core) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/examples/rpgdice/test/dune b/examples/rpgdice/test/dune index fa6d8d91..96804f32 100644 --- a/examples/rpgdice/test/dune +++ b/examples/rpgdice/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_rpgdice_test) +(library + (name bonsai_web_rpgdice_test) (libraries bonsai_web_rpgdice_example core expect_test_helpers_core) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/examples/rpgdice/test/test_dice.ml b/examples/rpgdice/test/test_dice.ml index 1b7dff7e..d06d7632 100644 --- a/examples/rpgdice/test/test_dice.ml +++ b/examples/rpgdice/test/test_dice.ml @@ -26,17 +26,17 @@ let%expect_test "roll" = [%expect {| ((dice ( + ((num_faces 6) (result 4)) ((num_faces 6) (result 1)) - ((num_faces 6) (result 1)) - ((num_faces 4) (result 1)))) + ((num_faces 4) (result 2)))) (const 0)) |}]; test "d20 + 3d6"; [%expect {| ((dice ( - ((num_faces 20) (result 11)) + ((num_faces 20) (result 7)) ((num_faces 6) (result 1)) - ((num_faces 6) (result 4)) - ((num_faces 6) (result 4)))) + ((num_faces 6) (result 6)) + ((num_faces 6) (result 6)))) (const 0)) |}] ;; diff --git a/examples/search_bar/dune b/examples/search_bar/dune index a6590b6f..c80e2d3c 100644 --- a/examples/search_bar/dune +++ b/examples/search_bar/dune @@ -1,7 +1,12 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_kernel bonsai bonsai_web_ui_search_bar core) - (preprocess (pps ppx_bonsai ppx_jane ppx_pattern_bind))) + (preprocess + (pps ppx_bonsai ppx_jane ppx_pattern_bind))) -(rule (targets style.css) +(rule + (targets style.css) (deps %{workspace_root}/lib/jane_web_style/src/css/style-4.css) - (action (bash "cat %{deps} > %{targets}"))) \ No newline at end of file + (action + (bash "cat %{deps} > %{targets}"))) diff --git a/examples/sexp_grammar/dune b/examples/sexp_grammar/dune index feef7f21..8efe4a57 100644 --- a/examples/sexp_grammar/dune +++ b/examples/sexp_grammar/dune @@ -1,7 +1,13 @@ -(executables (names main) (libraries bonsai_web bonsai_web_ui_auto_generated) - (preprocess (pps ppx_bonsai ppx_jane))) +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_auto_generated) + (preprocess + (pps ppx_bonsai ppx_jane))) -(rule (targets embedded_files.ml embedded_files.mli) +(rule + (targets embedded_files.ml embedded_files.mli) (deps %{bin:ocaml-embed-file} - %{workspace_root}/lib/bonsai/examples/sexp_grammar/type_intf.ml) - (action (bash "%{deps} -output embedded_files"))) \ No newline at end of file + %{workspace_root}/lib/bonsai/examples/sexp_grammar/type_intf.ml) + (action + (bash "%{deps} -output embedded_files"))) diff --git a/examples/sexp_grammar/main.ml b/examples/sexp_grammar/main.ml index 2eec7197..a5996ca1 100644 --- a/examples/sexp_grammar/main.ml +++ b/examples/sexp_grammar/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open! Bonsai.Let_syntax module Auto_generated = Bonsai_web_ui_auto_generated -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view let generation_count = 100 diff --git a/examples/snips/dune b/examples/snips/dune index 03c26db4..82127f55 100644 --- a/examples/snips/dune +++ b/examples/snips/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_extra bonsai_experimental_snips bonsai_web - bonsai_web_ui_gallery) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) \ No newline at end of file + bonsai_web_ui_gallery) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css ppx_demo))) diff --git a/examples/snips_demo/dune b/examples/snips_demo/dune index 0c77bcb3..a5b79c24 100644 --- a/examples/snips_demo/dune +++ b/examples/snips_demo/dune @@ -1,7 +1,13 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_web ppx_css.inline_css kado - bonsai_experimental_snips) - (preprocess (pps ppx_jane ppx_bonsai))) + bonsai_experimental_snips) + (preprocess + (pps ppx_jane ppx_bonsai))) -(rule (targets style.ml style.mli style__generated.ml style__generated.mli) - (deps style.css) (action (bash "%{bin:css_inliner} %{deps}"))) \ No newline at end of file +(rule + (targets style.ml style.mli style__generated.ml style__generated.mli) + (deps style.css) + (action + (bash "%{bin:css_inliner} %{deps}"))) diff --git a/examples/split_pane/bin/dune b/examples/split_pane/bin/dune index 0967028d..bffb0ab6 100644 --- a/examples/split_pane/bin/dune +++ b/examples/split_pane/bin/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_web bonsai_web_ui_split_pane_example) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/examples/split_pane/src/bonsai_web_ui_split_pane_example.ml b/examples/split_pane/src/bonsai_web_ui_split_pane_example.ml index c42a5603..43462c10 100644 --- a/examples/split_pane/src/bonsai_web_ui_split_pane_example.ml +++ b/examples/split_pane/src/bonsai_web_ui_split_pane_example.ml @@ -3,7 +3,7 @@ open! Bonsai_web open! Bonsai.Let_syntax open! Vdom module Parameters = Bonsai_web_ui_split_pane.For_testing.Parameters -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Styles = [%css @@ -82,7 +82,9 @@ let create_demo ~parameters = let create_parameters_form = let%sub form = Bonsai_web_ui_auto_generated.form (module Parameters) () in let%sub form = - Bonsai_web_ui_form.Dynamic.with_default (Value.return Parameters.default) form + Bonsai_web_ui_form.With_automatic_view.Dynamic.with_default + (Value.return Parameters.default) + form in let%sub last_ok = Bonsai.most_recent_value_satisfying @@ -97,7 +99,7 @@ let create_parameters_form = and form = form in let form_vdom = Bonsai_web_ui_auto_generated.view_as_vdom form in let error = - match Bonsai_web_ui_form.value form with + match Bonsai_web_ui_form.With_automatic_view.value form with | Ok _ -> Node.none | Error e -> Node.sexp_for_debugging [%sexp (e : Error.t)] in diff --git a/examples/split_pane/src/dune b/examples/split_pane/src/dune index 99987672..e114fd01 100644 --- a/examples/split_pane/src/dune +++ b/examples/split_pane/src/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_split_pane_example) +(library + (name bonsai_web_ui_split_pane_example) (libraries core bonsai_web bonsai_web_ui_split_pane - bonsai_web_ui_auto_generated) - (preprocess (pps ppx_jane ppx_css ppx_bonsai))) \ No newline at end of file + bonsai_web_ui_auto_generated) + (preprocess + (pps ppx_jane ppx_css ppx_bonsai))) diff --git a/examples/string_duplicator/dune b/examples/string_duplicator/dune index e37cafc3..a563da85 100644 --- a/examples/string_duplicator/dune +++ b/examples/string_duplicator/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) diff --git a/examples/styled_components/dune b/examples/styled_components/dune index 4969a498..5f3f9f29 100644 --- a/examples/styled_components/dune +++ b/examples/styled_components/dune @@ -1,3 +1,6 @@ -(executables (names main) - (libraries async_js bonsai_web bonsai_web_ui_gallery bonsai_web_ui_form) - (preprocess (pps ppx_jane ppx_bonsai ppx_css ppx_demo ppx_typed_fields))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries async_js bonsai_web bonsai_web_ui_form bonsai_web_ui_gallery) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css ppx_demo ppx_typed_fields))) diff --git a/examples/styled_components/main.ml b/examples/styled_components/main.ml index 6599bda8..2de6212a 100644 --- a/examples/styled_components/main.ml +++ b/examples/styled_components/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open! Bonsai.Let_syntax module Gallery = Bonsai_web_ui_gallery -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Basic = struct let name = "Basic" diff --git a/examples/styled_components_internal/dune b/examples/styled_components_internal/dune index c1b19b5c..61570632 100644 --- a/examples/styled_components_internal/dune +++ b/examples/styled_components_internal/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries async_js bonsai_web bonsai_web_ui_gallery) - (preprocess (pps ppx_jane ppx_bonsai ppx_css ppx_demo))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai ppx_css ppx_demo))) diff --git a/examples/swap_input_node_positions_bug_demo/dune b/examples/swap_input_node_positions_bug_demo/dune index cce2fd3d..f67beb1c 100644 --- a/examples/swap_input_node_positions_bug_demo/dune +++ b/examples/swap_input_node_positions_bug_demo/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web virtual_dom.input_widgets) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web virtual_dom.input_widgets) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/tabs/dune b/examples/tabs/dune index c77f3856..f92db175 100644 --- a/examples/tabs/dune +++ b/examples/tabs/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web bonsai_web_ui_tabs) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_tabs) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/tailwind_colors/dune b/examples/tailwind_colors/dune index 1a9546fc..601f126e 100644 --- a/examples/tailwind_colors/dune +++ b/examples/tailwind_colors/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web tailwind_colors) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web tailwind_colors) + (preprocess + (pps ppx_jane))) diff --git a/examples/testing_example/lib/dune b/examples/testing_example/lib/dune index f9934472..aa526735 100644 --- a/examples/testing_example/lib/dune +++ b/examples/testing_example/lib/dune @@ -1,3 +1,5 @@ -(library (name bonsai_testing_example_lib) +(library + (name bonsai_testing_example_lib) (libraries async_kernel bonsai_web core) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane ppx_pattern_bind))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane ppx_pattern_bind))) diff --git a/examples/testing_example/test/dune b/examples/testing_example/test/dune index a9020637..09f1bedc 100644 --- a/examples/testing_example/test/dune +++ b/examples/testing_example/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_testing_example_test) +(library + (name bonsai_testing_example_test) (libraries async_kernel bonsai_testing_example_lib bonsai_web - bonsai_web_test core) - (preprocess (pps js_of_ocaml-ppx ppx_jane))) \ No newline at end of file + bonsai_web_test core) + (preprocess + (pps js_of_ocaml-ppx ppx_jane))) diff --git a/examples/time/bin/dune b/examples/time/bin/dune index 3c772806..360ff9ee 100644 --- a/examples/time/bin/dune +++ b/examples/time/bin/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web bonsai_time_example) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_time_example) + (preprocess + (pps ppx_jane))) diff --git a/examples/time/src/dune b/examples/time/src/dune index 70ff89b1..bbbc0680 100644 --- a/examples/time/src/dune +++ b/examples/time/src/dune @@ -1,2 +1,5 @@ -(library (name bonsai_time_example) (libraries bonsai_web) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file +(library + (name bonsai_time_example) + (libraries bonsai_web) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/examples/time/test/dune b/examples/time/test/dune index beed0b6f..c234eb5e 100644 --- a/examples/time/test/dune +++ b/examples/time/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_time_test) +(library + (name bonsai_time_test) (libraries bonsai_time_example bonsai_web bonsai_web_test core) - (preprocess (pps js_of_ocaml-ppx ppx_jane))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_jane))) diff --git a/examples/todomvc/dune b/examples/todomvc/dune index 919f0a69..ed670320 100644 --- a/examples/todomvc/dune +++ b/examples/todomvc/dune @@ -1,8 +1,12 @@ -(executables (names main) (libraries bonsai_web ppx_css.inline_css) - (preprocess (pps ppx_bonsai ppx_jane js_of_ocaml-ppx))) +(executables + (modes byte exe) + (names main) + (libraries bonsai_web ppx_css.inline_css) + (preprocess + (pps ppx_bonsai ppx_jane js_of_ocaml-ppx))) (rule - (targets todomvc.ml todomvc.mli todomvc__generated.ml - todomvc__generated.mli) + (targets todomvc.ml todomvc.mli todomvc__generated.ml todomvc__generated.mli) (deps todomvc.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) \ No newline at end of file + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) diff --git a/examples/treemapviz/dune b/examples/treemapviz/dune index 6870347e..03412446 100644 --- a/examples/treemapviz/dune +++ b/examples/treemapviz/dune @@ -1,4 +1,7 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_experimental_treemapviz bonsai_web feather_icon - bonsai_web_ui_element_size_hooks) - (preprocess (pps ppx_bonsai ppx_css ppx_jane))) \ No newline at end of file + bonsai_web_ui_element_size_hooks) + (preprocess + (pps ppx_bonsai ppx_css ppx_jane))) diff --git a/examples/two_instances_of_component/dune b/examples/two_instances_of_component/dune index 5e219b5b..3ccf9db2 100644 --- a/examples/two_instances_of_component/dune +++ b/examples/two_instances_of_component/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/typeahead/dune b/examples/typeahead/dune index 194b1c4a..fbec5cde 100644 --- a/examples/typeahead/dune +++ b/examples/typeahead/dune @@ -1,9 +1,16 @@ -(executables (names main) (libraries bonsai_web bonsai_web_ui_typeahead) - (preprocess (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_typeahead) + (preprocess + (pps js_of_ocaml-ppx ppx_bonsai ppx_jane))) -(rule (targets style.css) - (deps %{workspace_root}/lib/jane_web_style/src/css/style-6.css - app_style.css) - (action (bash "cat %{deps} > %{targets}"))) +(rule + (targets style.css) + (deps %{workspace_root}/lib/jane_web_style/src/css/style-6.css app_style.css) + (action + (bash "cat %{deps} > %{targets}"))) -(alias (name DEFAULT) (deps style.css)) \ No newline at end of file +(alias + (name DEFAULT) + (deps style.css)) diff --git a/examples/url_var/bin/dune b/examples/url_var/bin/dune index efa8b822..216640ea 100644 --- a/examples/url_var/bin/dune +++ b/examples/url_var/bin/dune @@ -1,4 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_url_var_example_urls) (preprocess - (pps js_of_ocaml-ppx ppx_typed_fields ppx_jane ppx_bonsai ppx_css ppx_demo))) \ No newline at end of file + (pps js_of_ocaml-ppx ppx_typed_fields ppx_jane ppx_bonsai ppx_css ppx_demo))) diff --git a/examples/url_var/lib/dune b/examples/url_var/lib/dune index 8970afb9..7ebc9570 100644 --- a/examples/url_var/lib/dune +++ b/examples/url_var/lib/dune @@ -1,6 +1,7 @@ -(library (name bonsai_web_ui_url_var_example_urls) - (libraries bonsai bonsai_extra bonsai_web tailwind_colors - bonsai_web_ui_url_var bonsai_web_ui_form core feather_icon - ppx_typed_fields.typed_fields_lib ppx_typed_fields.typed_variants_lib) +(library + (name bonsai_web_ui_url_var_example_urls) + (libraries bonsai bonsai_extra bonsai_web tailwind_colors bonsai_web_ui_form + bonsai_web_ui_url_var core feather_icon ppx_typed_fields.typed_fields_lib + ppx_typed_fields.typed_variants_lib) (preprocess - (pps ppx_jane ppx_css ppx_demo js_of_ocaml-ppx ppx_typed_fields ppx_bonsai))) \ No newline at end of file + (pps ppx_jane ppx_css ppx_demo js_of_ocaml-ppx ppx_typed_fields ppx_bonsai))) diff --git a/examples/url_var/lib/url_example.ml b/examples/url_var/lib/url_example.ml index dc5c2712..b143a85f 100644 --- a/examples/url_var/lib/url_example.ml +++ b/examples/url_var/lib/url_example.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax module Url_var = Bonsai_web_ui_url_var -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Projection = Url_var.For_testing.Projection module Parse_result = Url_var.For_testing.Parse_result module Typed = Url_var.Typed diff --git a/examples/url_var_all_features/bin/dune b/examples/url_var_all_features/bin/dune index a78a7191..ee78efa3 100644 --- a/examples/url_var_all_features/bin/dune +++ b/examples/url_var_all_features/bin/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web all_url_var_features_example bonsai_web_ui_url_var) - (preprocess (pps js_of_ocaml-ppx ppx_typed_fields ppx_jane ppx_css))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_typed_fields ppx_jane ppx_css))) diff --git a/examples/url_var_all_features/lib/all_url_var_features_example.ml b/examples/url_var_all_features/lib/all_url_var_features_example.ml index fb374b3f..2beea532 100644 --- a/examples/url_var_all_features/lib/all_url_var_features_example.ml +++ b/examples/url_var_all_features/lib/all_url_var_features_example.ml @@ -3,7 +3,7 @@ open! Bonsai_web open Bonsai.Let_syntax module Url_var = Bonsai_web_ui_url_var open Url_var.Typed -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Path_order = Url_var.Typed.Parser.Record.Path_order module Location = struct diff --git a/examples/url_var_all_features/lib/dune b/examples/url_var_all_features/lib/dune index 843a58d5..5e285ea9 100644 --- a/examples/url_var_all_features/lib/dune +++ b/examples/url_var_all_features/lib/dune @@ -1,4 +1,5 @@ -(library (name all_url_var_features_example) - (libraries bonsai bonsai_web bonsai_web_ui_url_var bonsai_web_ui_form core) +(library + (name all_url_var_features_example) + (libraries bonsai bonsai_web bonsai_web_ui_form bonsai_web_ui_url_var core) (preprocess - (pps ppx_jane ppx_css ppx_demo js_of_ocaml-ppx ppx_typed_fields ppx_bonsai))) \ No newline at end of file + (pps ppx_jane ppx_css ppx_demo js_of_ocaml-ppx ppx_typed_fields ppx_bonsai))) diff --git a/examples/use_ocamlgraph/dune b/examples/use_ocamlgraph/dune index 030f3bed..0dcb76e8 100644 --- a/examples/use_ocamlgraph/dune +++ b/examples/use_ocamlgraph/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web graph) - (preprocess (pps ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web graph) + (preprocess + (pps ppx_jane))) diff --git a/examples/use_tracing/dune b/examples/use_tracing/dune index 14c7d5eb..f195a8a1 100644 --- a/examples/use_tracing/dune +++ b/examples/use_tracing/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web tracing.tracing_zero) - (preprocess (pps ppx_jane ppx_bonsai ppx_tracing))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web tracing.tracing_zero) + (preprocess + (pps ppx_jane ppx_bonsai ppx_tracing))) diff --git a/examples/vdom_input_widgets_int_repro/dune b/examples/vdom_input_widgets_int_repro/dune index cce2fd3d..f67beb1c 100644 --- a/examples/vdom_input_widgets_int_repro/dune +++ b/examples/vdom_input_widgets_int_repro/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web virtual_dom.input_widgets) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web virtual_dom.input_widgets) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/examples/vdom_keyboard/dune b/examples/vdom_keyboard/dune index 39dd50b6..4eb67fcc 100644 --- a/examples/vdom_keyboard/dune +++ b/examples/vdom_keyboard/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web virtual_dom.keyboard) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web virtual_dom.keyboard) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/visibility/dune b/examples/visibility/dune index 1bdd1c2d..562f0518 100644 --- a/examples/visibility/dune +++ b/examples/visibility/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web bonsai_web_ui_visibility) - (preprocess (pps ppx_jane ppx_css ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web bonsai_web_ui_visibility) + (preprocess + (pps ppx_jane ppx_css ppx_bonsai))) diff --git a/examples/weird_prt_situations/dune b/examples/weird_prt_situations/dune index 8d3f42e7..9ff423c8 100644 --- a/examples/weird_prt_situations/dune +++ b/examples/weird_prt_situations/dune @@ -1,3 +1,6 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_form bonsai_web_ui_partial_render_table) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/examples/weird_prt_situations/main.ml b/examples/weird_prt_situations/main.ml index e803bdc9..f73bc470 100644 --- a/examples/weird_prt_situations/main.ml +++ b/examples/weird_prt_situations/main.ml @@ -5,7 +5,7 @@ open! Bonsai_web open Bonsai.Let_syntax module Table = Bonsai_web_ui_partial_render_table.Basic module Column = Table.Columns.Dynamic_cells -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view let header text = Column.Sortable.Header.with_icon (Vdom.Node.text text) |> Value.return diff --git a/examples/widget/dune b/examples/widget/dune index ac402d13..d8d9c711 100644 --- a/examples/widget/dune +++ b/examples/widget/dune @@ -1,4 +1,8 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_web bonsai_web_ui_form bonsai_web_ui_widget) - (js_of_ocaml (javascript_files runtime.js)) - (preprocess (pps ppx_jane ppx_bonsai js_of_ocaml-ppx))) \ No newline at end of file + (js_of_ocaml + (javascript_files runtime.js)) + (preprocess + (pps ppx_jane ppx_bonsai js_of_ocaml-ppx))) diff --git a/examples/widget/main.ml b/examples/widget/main.ml index ca65904e..098f627a 100644 --- a/examples/widget/main.ml +++ b/examples/widget/main.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax open Js_of_ocaml -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Widget = Bonsai_web_ui_widget module T = struct diff --git a/examples/widget_bug_repro/dune b/examples/widget_bug_repro/dune index 69fe6773..2facef6c 100644 --- a/examples/widget_bug_repro/dune +++ b/examples/widget_bug_repro/dune @@ -1,2 +1,6 @@ -(executables (names main) (libraries bonsai_web) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names main) + (libraries bonsai_web) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai))) diff --git a/experimental/animation/src/dune b/experimental/animation/src/dune index 81772a4f..61f4d516 100644 --- a/experimental/animation/src/dune +++ b/experimental/animation/src/dune @@ -1,2 +1,5 @@ -(library (name bonsai_experimental_animation) (libraries core bonsai) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file +(library + (name bonsai_experimental_animation) + (libraries core bonsai) + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/experimental/animation/test/dune b/experimental/animation/test/dune index 7ff3318c..b4f76213 100644 --- a/experimental/animation/test/dune +++ b/experimental/animation/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_experimental_animation_test) +(library + (name bonsai_experimental_animation_test) (libraries bonsai_experimental_animation core expect_test_helpers_core) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/experimental/dagviz/src/dune b/experimental/dagviz/src/dune index 99f8442d..9025dd5e 100644 --- a/experimental/dagviz/src/dune +++ b/experimental/dagviz/src/dune @@ -1,4 +1,6 @@ -(library (name bonsai_experimental_dagviz) +(library + (name bonsai_experimental_dagviz) (public_name bonsai.bonsai_experimental_dagviz) (libraries core bonsai_web bonsai_web_ui_element_size_hooks virtual_dom.svg) - (preprocess (pps ppx_jane ppx_css ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_css ppx_bonsai))) diff --git a/experimental/dagviz/test/dune b/experimental/dagviz/test/dune index f8d6b190..bcb096fe 100644 --- a/experimental/dagviz/test/dune +++ b/experimental/dagviz/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_experimental_dagviz_test) +(library + (name bonsai_experimental_dagviz_test) (libraries bonsai_experimental_dagviz core bonsai_web_test - expect_test_helpers_core) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + expect_test_helpers_core) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/experimental/form/example/dune b/experimental/form/example/dune index df72f4f0..562233d3 100644 --- a/experimental/form/example/dune +++ b/experimental/form/example/dune @@ -1,9 +1,16 @@ -(executables (names bonsai_form_example) +(executables + (modes byte exe) + (names bonsai_form_example) (libraries core bonsai_form_experimental bonsai_web virtual_dom.layout) - (preprocess (pps ppx_jane))) + (preprocess + (pps ppx_jane))) -(rule (targets jane-web-style.css) +(rule + (targets jane-web-style.css) (deps %{workspace_root}/lib/jane_web_style/src/css/style-4.css) - (action (bash "cat %{deps} > %{targets}"))) + (action + (bash "cat %{deps} > %{targets}"))) -(alias (name DEFAULT) (deps jane-web-style.css)) \ No newline at end of file +(alias + (name DEFAULT) + (deps jane-web-style.css)) diff --git a/experimental/form/src/dune b/experimental/form/src/dune index 0a33fcc7..7aa87b4e 100644 --- a/experimental/form/src/dune +++ b/experimental/form/src/dune @@ -1,3 +1,5 @@ -(library (name bonsai_form_experimental) +(library + (name bonsai_form_experimental) (libraries bonsai_extra bonsai_web core virtual_dom.input_widgets) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/experimental/table_form/src/bonsai_experimental_table_form.ml b/experimental/table_form/src/bonsai_experimental_table_form.ml index add8e9b8..6e3f0332 100644 --- a/experimental/table_form/src/bonsai_experimental_table_form.ml +++ b/experimental/table_form/src/bonsai_experimental_table_form.ml @@ -1,7 +1,7 @@ open! Core open! Bonsai_web open Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Table = Bonsai_web_ui_partial_render_table.Basic module C = Table.Columns.Dynamic_columns diff --git a/experimental/table_form/src/bonsai_experimental_table_form.mli b/experimental/table_form/src/bonsai_experimental_table_form.mli index 397639b1..3420d59d 100644 --- a/experimental/table_form/src/bonsai_experimental_table_form.mli +++ b/experimental/table_form/src/bonsai_experimental_table_form.mli @@ -1,6 +1,6 @@ open! Core open! Bonsai_web -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module type S = sig type t [@@deriving sexp, equal, compare] diff --git a/experimental/table_form/src/dune b/experimental/table_form/src/dune index 1dd6e5cb..f38342b7 100644 --- a/experimental/table_form/src/dune +++ b/experimental/table_form/src/dune @@ -1,4 +1,5 @@ -(library (name bonsai_experimental_table_form) - (preprocess (pps ppx_jane ppx_bonsai ppx_css)) - (libraries core bonsai bonsai_web_ui_form - bonsai_web_ui_partial_render_table)) \ No newline at end of file +(library + (name bonsai_experimental_table_form) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css)) + (libraries core bonsai bonsai_web_ui_form bonsai_web_ui_partial_render_table)) diff --git a/experimental/table_form/test/dune b/experimental/table_form/test/dune index c359a60e..e73662e7 100644 --- a/experimental/table_form/test/dune +++ b/experimental/table_form/test/dune @@ -1,2 +1,5 @@ -(library (name bonsai_experimental_table_form_test) - (libraries expect_test_helpers_core) (preprocess (pps ppx_jane))) \ No newline at end of file +(library + (name bonsai_experimental_table_form_test) + (libraries expect_test_helpers_core) + (preprocess + (pps ppx_jane))) diff --git a/extra/bonsai_extra.ml b/extra/bonsai_extra.ml index 992ea58f..716fab58 100644 --- a/extra/bonsai_extra.ml +++ b/extra/bonsai_extra.ml @@ -243,7 +243,7 @@ module Id_gen (T : Int_intf.S) () = struct ~equal:[%equal: T.t] ~sexp_of_action:[%sexp_of: Unit.t] ~default_model:T.zero - ~recv:(fun ~schedule_event:_ i () -> T.( + ) i T.one, i) + ~recv:(fun ~inject:_ ~schedule_event:_ i () -> T.( + ) i T.one, i) () in fetch () @@ -504,7 +504,7 @@ module One_at_a_time = struct ~equal:[%equal: Status.t] ~sexp_of_action:[%sexp_of: Lock_action.t] ~default_model:Idle - ~recv:(fun ~schedule_event:_ model action -> + ~recv:(fun ~inject:_ ~schedule_event:_ model action -> match action with | Acquire -> let response = diff --git a/extra/dune b/extra/dune index 05f71cce..c1dee44b 100644 --- a/extra/dune +++ b/extra/dune @@ -1,4 +1,6 @@ -(library (name bonsai_extra) +(library + (name bonsai_extra) (libraries bonsai virtual_dom.ui_effect incr_dom.ui_incr) (public_name bonsai.extra) - (preprocess (pps ppx_bonsai ppx_jane ppx_pattern_bind))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane ppx_pattern_bind))) diff --git a/jsoo_weak_collections/src/dune b/jsoo_weak_collections/src/dune index 57f608e9..c29e2efe 100644 --- a/jsoo_weak_collections/src/dune +++ b/jsoo_weak_collections/src/dune @@ -1,3 +1,6 @@ -(library (name jsoo_weak_collections) +(library + (name jsoo_weak_collections) (public_name bonsai.jsoo_weak_collections) - (libraries js_of_ocaml gen_js_api) (preprocess (pps gen_js_api.ppx))) \ No newline at end of file + (libraries js_of_ocaml gen_js_api) + (preprocess + (pps gen_js_api.ppx))) diff --git a/jsoo_weak_collections/test/dune b/jsoo_weak_collections/test/dune index b619ddc1..60b23473 100644 --- a/jsoo_weak_collections/test/dune +++ b/jsoo_weak_collections/test/dune @@ -1,3 +1,5 @@ -(library (name jsoo_weak_collections_test) +(library + (name jsoo_weak_collections_test) (libraries core jsoo_weak_collections) - (preprocess (pps ppx_jane js_of_ocaml-ppx))) \ No newline at end of file + (preprocess + (pps ppx_jane js_of_ocaml-ppx))) diff --git a/ppx_bonsai/src/dune b/ppx_bonsai/src/dune index 38121d7f..7c8fca4d 100644 --- a/ppx_bonsai/src/dune +++ b/ppx_bonsai/src/dune @@ -1,3 +1,7 @@ -(library (name ppx_bonsai) (public_name bonsai.ppx_bonsai) +(library + (name ppx_bonsai) + (public_name bonsai.ppx_bonsai) (libraries ppx_let.expander ppx_bonsai_expander) - (preprocess (pps ppxlib.metaquot)) (kind ppx_deriver)) \ No newline at end of file + (preprocess + (pps ppxlib.metaquot)) + (kind ppx_deriver)) diff --git a/ppx_bonsai/src/expander/dune b/ppx_bonsai/src/expander/dune index 25b8e2a4..4705b4f5 100644 --- a/ppx_bonsai/src/expander/dune +++ b/ppx_bonsai/src/expander/dune @@ -1,3 +1,6 @@ -(library (name ppx_bonsai_expander) (public_name bonsai.ppx_bonsai_expander) +(library + (name ppx_bonsai_expander) + (public_name bonsai.ppx_bonsai_expander) (libraries base ppxlib ppx_let.expander ppx_pattern_bind ppx_here.expander) - (preprocess (pps ppxlib.metaquot))) \ No newline at end of file + (preprocess + (pps ppxlib.metaquot))) diff --git a/ppx_bonsai/test/dune b/ppx_bonsai/test/dune index 52b3bdac..4b9746f1 100644 --- a/ppx_bonsai/test/dune +++ b/ppx_bonsai/test/dune @@ -1 +1,5 @@ -(executables (names test) (preprocess (pps ppx_let ppx_bonsai))) \ No newline at end of file +(executables + (modes byte exe) + (names test) + (preprocess + (pps ppx_let ppx_bonsai))) diff --git a/ppx_bonsai/test/inline/dune b/ppx_bonsai/test/inline/dune index 6856445d..f34fba56 100644 --- a/ppx_bonsai/test/inline/dune +++ b/ppx_bonsai/test/inline/dune @@ -1,3 +1,5 @@ -(library (name ppx_bonsai_test) +(library + (name ppx_bonsai_test) (libraries core ppxlib ppx_bonsai_expander ppx_let.expander ppx_bonsai) - (preprocess (pps ppx_expect ppx_bonsai ppxlib.metaquot))) \ No newline at end of file + (preprocess + (pps ppx_expect ppx_bonsai ppxlib.metaquot))) diff --git a/src/bonsai.ml b/src/bonsai.ml index 5095ac4d..910dce86 100644 --- a/src/bonsai.ml +++ b/src/bonsai.ml @@ -8,16 +8,6 @@ end open! Core open! Import -module type Model = Module_types.Model -module type Action = Module_types.Action -module type Enum = Module_types.Enum -module type Comparator = Module_types.Comparator - -type ('k, 'cmp) comparator = ('k, 'cmp) Module_types.comparator - -module Effect = Effect -module Time_source = Time_source - module Private = struct module Computation = Computation module Environment = Environment @@ -37,20 +27,18 @@ module Private = struct module Skeleton = Skeleton module Transform = Transform module Linter = Linter - module Pre_process = Pre_process - include Proc.Private - let path = Proc.path + let path = Proc_layer2.path let gather = Eval.gather let pre_process = Pre_process.pre_process + let reveal_value = Cont.Conv.reveal_value + let conceal_value = Cont.Conv.conceal_value + let top_level_handle = Cont.Conv.top_level_handle + let handle = Cont.Conv.handle + let perform = Cont.Conv.perform end -module Expert = struct - let thunk = Proc.thunk - let assoc_on = Proc.assoc_on -end - -include (Proc : module type of Proc with module Private := Proc.Private) +include Proc_layer2 module For_open = struct module Computation = Computation @@ -58,24 +46,7 @@ module For_open = struct module Value = Value end -module Debug = struct - let to_dot ?pre_process c = To_dot.to_dot ?pre_process (Private.reveal_computation c) - let instrument_computation = Instrumentation.instrument_computation - let enable_incremental_annotations = Annotate_incr.enable - let disable_incremental_annotations = Annotate_incr.disable - - open Let_syntax - - let on_change v ~f = - (* Use [after_display] because the incremental node is always considered to be in use.*) - Edge.after_display - (let%map v = v in - f v; - Effect.Ignore) - ;; - - let on_change_print_s v sexp_of = on_change v ~f:(fun a -> print_s (sexp_of a)) -end +module Cont = Cont module Arrow_deprecated = struct include Legacy_api diff --git a/src/bonsai.mli b/src/bonsai.mli index 0ac48c5b..2eb384c6 100644 --- a/src/bonsai.mli +++ b/src/bonsai.mli @@ -1,1020 +1,41 @@ +(** Bonsai documentation can be found in [proc_intf.ml]. + + The Bonsai API is currently in an intermediate state. It is transitioning from the + "old" [Proc] API to the "new" [Cont] API. Currently the [Proc] API is the default and + is included when you use [include Bonsai/_web/_web]. Current Bonsai documentation can + be found in [proc_intf.ml]. *) + open! Core open! Import module Private_computation := Computation module Private_value := Value -module type Model = Module_types.Model -module type Action = Module_types.Action -module type Enum = Module_types.Enum -module type Comparator = Module_types.Comparator - -type ('k, 'cmp) comparator = ('k, 'cmp) Module_types.comparator - -(** The functions found in this module are focused on the manipulation - of values of type ['a Computation.t] and ['a Value.t]. There are fine - descriptions of these types below and how to use them, but since it's - so common to convert between the two, here is a cheat-sheet matrix for - converting between values of different types: - - {v - - | Have \ Want | 'a Value.t | 'a Computation.t | - |------------------+------------------------+------------------| - | 'a | let v = Value.return a | let c = const a | - | 'a Value.t | | let c = read v | - | 'a Computation.t | let%sub v = c | | - - v} *) - -module Value : sig - (** A value of type ['a Value.t] represents a value that may change during the lifetime - of the program. For those familiar with the [Incremental] library, this type is - conceptually very similar to [Incr.t]. The main method by which you acquire values - of type [Value.t] is by using the [let%sub] syntax extension. - - {[ - val c : int Computation.t - - let%sub x = c in - (* [x] has type [int Value.t] here *) - ]} - - In the example above, we run a computation [c] and store the result of that - computation in [x] which has type [Value.t]. - - [Value.t] is an applicative, which means that you can combine multiple [Value]s into - one by using [Let_syntax]: - - {[ - val a : int Value.t - val b : int Value.t - - let open Let_syntax in - let%map a = a and b = b in - a + b - ]} *) - type 'a t - - include Applicative.S with type 'a t := 'a t - include Mapn with type 'a t := 'a t - - (** A [Value.t] transformed by [cutoff] will only trigger changes on its dependents when the equality - of the contained value has changed. - - Immediate nesting of cutoff nodes are combined into a single cutoff node whose equality function is - true when any of the composed nodes is true and is false when all of the composed nodes are false. - They're "or'ed together". *) - val cutoff : 'a t -> equal:('a -> 'a -> bool) -> 'a t - - (** flips the option position in a ['a Value.t option] into an ['a option Value.t]. It's - useful for optional args that take values. *) - val of_opt : 'a t option -> 'a option t -end - -module Computation : sig - (** A value of type ['a Computation.t] represents a computation which produces a value - that may change during the lifetime of a program, and the value may be influenced by - the internal state of that computation. - - The same ['a Computation.t] can be used in multiple places in a program, and these - uses will {e not} share the same state, nor will they share the work performed by - the computation. - - In this normal OCaml code, if we see the same function being called multiple times: - - {[ - let a = f () in - let b = f () in - a + b - ]} - - You would not be surprised to know that if [f] has side-effects (maybe - printing to the console), then those side-effects happen twice because - [f] was called twice. - - Similarly, if we wrote the code this way: - - {[ - let a = f () in - let b = a in - a + b - ]} - - You would (correctly) expect that the side-effect only happens once, when computing - [a]. In these examples, the {e code} [f ()] is analogous to [_ Computation.t]. If - you want to have two separate values whose computations maintain separate state, you - would use two instances of "let%sub" to bind them separately: - - {[ - val some_computation : int Computation.t - val add : int Value.t -> int Value.t -> int Computation.t - - let open Let_syntax in - let%sub a = some_computation in - let%sub b = some_computation in - add a b - ]} - - Here, [a] and [b] can take on different values depending on the states of the - computations that produce them. - - However, if you want to use just one value in multiple places, only use - [let%sub] once: - - {[ - let open Let_syntax in - let%sub a = some_computation in - let b = a in - add a b - ]} - - Here, [a] and [b] always take on the same value. *) - type 'a t - - include Applicative.S with type 'a t := 'a t - - (** Similar to [all] which pulls the computation outside of a list, - [all_map] does the same, but with the data in a map. This can - be a useful replacement for [assoc] in scenarios where the map - is a constant size. *) - val all_map : ('k, 'v t, 'cmp) Map.t -> ('k, 'v, 'cmp) Map.t t - - (** The analog of [List.reduce_balanced] for computations, but with [f] - operating on values instead of the computations themselves *) - val reduce_balanced : 'a t list -> f:('a Value.t -> 'a Value.t -> 'a t) -> 'a t option - - val fold_right - : 'a t list - -> f:('a Value.t -> 'acc Value.t -> 'acc t) - -> init:'acc Value.t - -> 'acc t - - module Let_syntax : sig - val return : 'a -> 'a t - - include Applicative.Applicative_infix with type 'a t := 'a t - - module Let_syntax : sig - val return : 'a -> 'a t - val map : 'a t -> f:('a -> 'b) -> 'b t - val both : 'a t -> 'b t -> ('a * 'b) t - - include Mapn with type 'a t := 'a t - end - end - - include Mapn with type 'a t := 'a t -end - -module Effect = Ui_effect - -module For_open : sig - module Computation = Computation - module Effect = Effect - module Value = Value -end - -module Var : sig - (** A [Var.t] is the primary method for making data obtained outside of Bonsai (maybe via - an RPC) accessible inside a Bonsai application. *) - type 'a t - - (** Creates a new [Var.t] with an initial value. *) - val create : 'a -> 'a t - - (** Updates the value inside of [t]. [f] is given the previous value of [t] so that you - can reuse parts of the value if applicable *) - val update : 'a t -> f:('a -> 'a) -> unit - - (** Sets the value inside of [t]. *) - val set : 'a t -> 'a -> unit - - (** Gets the value inside of [t]. *) - val get : 'a t -> 'a - - (** Provides read-only access to [t] by producing a {!Value.t} which is used inside of a - Bonsai computation. *) - val value : 'a t -> 'a Value.t - - (** Retrieves the underlying ['a t] Ui_incr.t var. *) - val incr_var : 'a t -> 'a Ui_incr.Var.t -end - -(** Converts a [Value.t] to a [Computation.t]. Unlike most Computations, the [Computation.t] - returned by [read] can be used in multiple locations without maintaining multiple copies of - any models or building duplicate incremental graphs. - - [read] is most commonly used in the final expression of a [let%sub] chain, like so: - - {[ - fun i -> - let%sub a = f i in - let%sub b = g i in - read - (let%map a = a - and b = b in - a + b) - ]} - - or to use some APIs that require [Computation.t] like so: - - {[ - val cond : bool Value.t - val x : 'a Value.t - val some_computation : 'a Computation.t - - let y = if_ cond ~then_:some_computation ~else_:(read x) - val y : 'a Computation.t - ]} -*) -val read : 'a Value.t -> 'a Computation.t - -(** Creates a [Computation.t] that provides a constant value. *) -val const : 'a -> 'a Computation.t - -(** Retrieves the path to the current computation as a string. This string is - not human-readable, but can be used as an ID which is unique to this - particular instance of a component. *) -val path_id : string Computation.t - -(** Lifts a regular OCaml function into one that takes a Value as input, and produces - a Computation as output. *) -val pure : ('a -> 'b) -> 'a Value.t -> 'b Computation.t - -module Computation_status : sig - (** Indicates whether a value is available, which depends on whether the - computation in which it is computed is active or not. Most of the time - values of this type are [Active], since it is unusual to interact with - inactive computations. - - A computation is considered inactive if it resides in the inactive arm of - a [match%sub] or in a removed entry of a [Bonsai.assoc]. *) - type 'input t = - | Active of 'input - | Inactive - [@@deriving sexp_of] -end - -(** A frequently used state-machine is the trivial 'set-state' transition, - where the action always replaces the value contained inside. This - helper-function implements that state-machine, providing access to the - current state, as well as an inject function that updates the state. *) -val state - : ?reset:('model -> 'model) - (** to learn more about [reset], read the docs on [with_model_resetter] *) - -> ?sexp_of_model:('model -> Sexp.t) - -> ?equal:('model -> 'model -> bool) - -> 'model - -> ('model * ('model -> unit Effect.t)) Computation.t - -(** Similar to [state], but stores an option of the model instead. - [default_model] is optional and defaults to [None]. *) -val state_opt - : ?reset:('model option -> 'model option) - -> ?default_model:'model - -> ?sexp_of_model:('model -> Sexp.t) - -> ?equal:('model -> 'model -> bool) - -> unit - -> ('model option * ('model option -> unit Effect.t)) Computation.t - -(** A bool-state which starts at [default_model] and flips whenever the - returned effect is scheduled. *) -val toggle : default_model:bool -> (bool * unit Effect.t) Computation.t - -module Toggle : sig - type t = - { state : bool - ; set_state : bool -> unit Effect.t - ; toggle : unit Effect.t - } -end - -(** Like [toggle], but also gives a handle to set the state directly *) -val toggle' : default_model:bool -> Toggle.t Computation.t - -module Apply_action_context : sig - type 'action t = 'action Apply_action_context.t - - val inject : 'action t -> 'action -> unit Effect.t - val schedule_event : _ t -> unit Effect.t -> unit -end - -(** A constructor for [Computation.t] that models a simple state machine. - The first-class module implementing [Model] describes the states in - the state machine, while the first-class module implementing [Action] - describes the transitions between states. - - [default_model] is the initial state for the state machine, and [apply_action] - implements the transition function that looks at the current state and the requested - transition, and produces a new state. - - (It is very common for [inject] and [schedule_event] to be unused) *) -val state_machine0 - : ?reset:('action Apply_action_context.t -> 'model -> 'model) - (** to learn more about [reset], read the docs on [with_model_resetter] *) - -> ?sexp_of_model:('model -> Sexp.t) - -> ?sexp_of_action:('action -> Sexp.t) - -> ?equal:('model -> 'model -> bool) - -> default_model:'model - -> apply_action:('action Apply_action_context.t -> 'model -> 'action -> 'model) - -> unit - -> ('model * ('action -> unit Effect.t)) Computation.t - -(** The same as {!state_machine0}, but [apply_action] also takes an input from - a [Value.t]. The input has type ['input Computation_status.t] instead of - plain ['input] to account for the possibility that an action gets sent - while the state machine is inactive. *) -val state_machine1 - : ?sexp_of_action:('action -> Sexp.t) - -> ?reset:('action Apply_action_context.t -> 'model -> 'model) - (** to learn more about [reset], read the docs on [with_model_resetter] *) - -> ?sexp_of_model:('model -> Sexp.t) - -> ?equal:('model -> 'model -> bool) - -> default_model:'model - -> apply_action: - ('action Apply_action_context.t - -> 'input Computation_status.t - -> 'model - -> 'action - -> 'model) - -> 'input Value.t - -> ('model * ('action -> unit Effect.t)) Computation.t - -(** Identical to [actor1] but it takes 0 inputs instead of 1. *) -val actor0 - : ?reset: - (inject:('action -> 'return Effect.t) - -> schedule_event:(unit Effect.t -> unit) - -> 'model - -> 'model) - (** to learn more about [reset], read the docs on [with_model_resetter] *) - -> ?sexp_of_model:('model -> Sexp.t) - -> ?sexp_of_action:('action -> Sexp.t) - -> ?equal:('model -> 'model -> bool) - -> default_model:'model - -> recv: - (schedule_event:(unit Effect.t -> unit) -> 'model -> 'action -> 'model * 'return) - -> unit - -> ('model * ('action -> 'return Effect.t)) Computation.t - -(** [actor1] is very similar to [state_machine1], with two major exceptions: - - the [apply-action] function for state-machine is renamed [recv], and it - returns a "response", in addition to a new model. - - the 2nd value returned by the component allows for the sender of an - action to handle the effect and read the response. - - Because the semantics of this function feel like an actor system, we've - decided to name the function accordingly. *) -val actor1 - : ?sexp_of_action:('action -> Sexp.t) - -> ?reset: - (inject:('action -> 'return Effect.t) - -> schedule_event:(unit Effect.t -> unit) - -> 'model - -> 'model) - (** to learn more about [reset], read the docs on [with_model_resetter] *) - -> ?sexp_of_model:('model -> Sexp.t) - -> ?equal:('model -> 'model -> bool) - -> default_model:'model - -> recv: - (schedule_event:(unit Effect.t -> unit) - -> 'input Computation_status.t - -> 'model - -> 'action - -> 'model * 'return) - -> 'input Value.t - -> ('model * ('action -> 'return Effect.t)) Computation.t - -(** Given a [state_machine]-type function, [narrow] can narrow down the provided value and - injection function to a subset of a larger type. For example, you could use [narrow] - a state containing a record to the value and injection function for a single field. *) -val narrow - : ('a * ('input_action -> unit Effect.t)) Value.t - -> get:('a -> 'b) - -> set:('a -> 'output_action -> 'input_action) - -> ('b * ('output_action -> unit Effect.t)) Computation.t - -(** Like [narrow], but [get] and [set] are implemented in terms of the given field. *) -val narrow_via_field - : ('a * ('a -> unit Effect.t)) Value.t - -> ('a, 'b) Field.t - -> ('b * ('b -> unit Effect.t)) Computation.t - -(** Given a first-class module that has no input (unit input type), and the default - value of the state machine, [of_module0] will create a [Computation] that produces - values of that module's [Result.t] type. *) -val of_module0 - : ?sexp_of_model:('m -> Sexp.t) - -> ?equal:('m -> 'm -> bool) - -> (unit, 'm, 'a, 'r) component_s - -> default_model:'m - -> 'r Computation.t - -(** The same as {!of_module0}, but this one has an input type ['i]. Because input to the - component is required, this function also expects a [Value.t] that provides its input. - It is common for this function to be partially applied like so: - - {[ - val a : int Value.t - val b : int Value.t - - let f = of_module1 (module struct ... end) ~default_model in - let%sub a = f a in - let%sub b = f b in - ... - ]} - - Where the [Value.t] values are passed in later. *) -val of_module1 - : ?sexp_of_model:('m -> Sexp.t) - -> ('i, 'm, 'a, 'r) component_s - -> ?equal:('m -> 'm -> bool) - -> default_model:'m - -> 'i Value.t - -> 'r Computation.t - -(** The same as {!of_module1} but with two inputs. *) -val of_module2 - : ?sexp_of_model:('m -> Sexp.t) - -> ('i1 * 'i2, 'm, 'a, 'r) component_s - -> ?equal:('m -> 'm -> bool) - -> default_model:'m - -> 'i1 Value.t - -> 'i2 Value.t - -> 'r Computation.t - -(** [freeze] takes a Value.t and returns a computation whose output is frozen - to be the first value that passed through the input. *) -val freeze - : ?sexp_of_model:('a -> Sexp.t) - -> ?equal:('a -> 'a -> bool) - -> 'a Value.t - -> 'a Computation.t - -(** Because all Bonsai computation-returning-functions are eagerly evaluated, attempting - to use "let rec" to construct a recursive component will recurse infinitely. One way - to avoid this is to use a lazy computation and [Bonsai.lazy_] to defer evaluating the - [Computation.t]. - - {[ - let rec some_component arg1 arg2 = - ... - let _ = Bonsai.lazy_ (lazy (some_component ...)) in - ... - ]} *) -val lazy_ : 'a Computation.t Lazy.t -> 'a Computation.t - [@@deprecated "[since 2023-07] Use Bonsai.fix "] - -(** A fixed-point combinator for bonsai components. This is used to build recursive - components like so: - - {[ - let my_recursive_component ~some_input = - Bonsai.fix some_input ~f:(fun ~recurse some_input -> - (* call [recurse] to instantiate a nested instance of the component *) - ) - ]} -*) -val fix - : 'input Value.t - -> f: - (recurse:('input Value.t -> 'result Computation.t) - -> 'input Value.t - -> 'result Computation.t) - -> 'result Computation.t - -(** Like [fix], but for two arguments instead of just one. *) -val fix2 - : 'a Value.t - -> 'b Value.t - -> f: - (recurse:('a Value.t -> 'b Value.t -> 'result Computation.t) - -> 'a Value.t - -> 'b Value.t - -> 'result Computation.t) - -> 'result Computation.t - -(** [scope_model] allows you to have a different model for the provided - computation, keyed by some other value. - - Suppose for example, that you had a form for editing details about a - person. This form should have different state for each person. You could - use scope_model, where the [~on] parameter is set to a user-id, and now when - that value changes, the model for the other computation is set to the model - for that particular user. - - [scope_model] also impacts lifecycle events; when [on] changes value, - edge triggers like [on_activate] and [on_deactivate] will run *) -val scope_model - : ('a, _) comparator - -> on:'a Value.t - -> 'b Computation.t - -> 'b Computation.t - -(** [most_recent_some] returns a value containing the most recent - output of [f] for which it returned [Some]. If the input value has never - contained a valid value, then the result is [None]. *) -val most_recent_some - : ?sexp_of_model:('b -> Sexp.t) - -> equal:('b -> 'b -> bool) - -> 'a Value.t - -> f:('a -> 'b option) - -> 'b option Computation.t - -(** [most_recent_value_satisfying] returns a value containing the most recent input - value for which [condition] returns true. If the input value has never - contained a valid value, then the result is [None]. *) -val most_recent_value_satisfying - : ?sexp_of_model:('a -> Sexp.t) - -> equal:('a -> 'a -> bool) - -> 'a Value.t - -> condition:('a -> bool) - -> 'a option Computation.t - -(** [previous_value] returns the previous contents of the input value if it - just changed, or the current contents of the value if it did not just - change. Initially starts out as [None]. - - Any values the input takes on while the output is inactive are ignored; any - changes to the input are assumed to have occurred exactly when the - component was re-activated. *) -val previous_value - : ?sexp_of_model:('a -> Sexp.t) - -> equal:('a -> 'a -> bool) - -> 'a Value.t - -> 'a option Computation.t - -(** [assoc] is used to apply a Bonsai computation to each element of a map. This function - signature is very similar to [Map.mapi] or [Incr_map.mapi'], and for good reason! - - It is doing the same thing (taking a map and a function and returning a new map with - the function applied to every key-value pair), but this function does it with the - Bonsai values, which means that the computation is done incrementally and also - maintains a state machine for every key-value pair. *) -val assoc - : ('key, 'cmp) comparator - -> ('key, 'data, 'cmp) Map.t Value.t - -> f:('key Value.t -> 'data Value.t -> 'result Computation.t) - -> ('key, 'result, 'cmp) Map.t Computation.t - -(** Like [assoc] except that the input value is a Set instead of a Map. *) -val assoc_set - : ('key, 'cmp) comparator - -> ('key, 'cmp) Set.t Value.t - -> f:('key Value.t -> 'result Computation.t) - -> ('key, 'result, 'cmp) Map.t Computation.t - -(** Like [assoc] except that the input value is a list instead of a Map. The output list - is in the same order as the input list. - - This function performs O(n log(n)) work (where n is the length of the list) any time - that anything in the input list changes, so it may be quite slow with large lists. *) -val assoc_list - : ('key, _) comparator - -> 'a list Value.t - -> get_key:('a -> 'key) - -> f:('key Value.t -> 'a Value.t -> 'b Computation.t) - -> [ `Duplicate_key of 'key | `Ok of 'b list ] Computation.t - -(** [enum] is used for matching on a value and providing different behaviors on different - values. The type of the value must be enumerable (there must be a finite number of - possible values), and it must be comparable and sexpable. - - The rest of the parameters are named like you might expect from pattern-matching - syntax, with [match_] taking the value to match on, and [with_] taking a function that - choose which behavior to use. *) -val enum - : (module Enum with type t = 'k) - -> match_:'k Value.t - -> with_:('k -> 'a Computation.t) - -> 'a Computation.t - -(** [wrap] wraps a Computation (built using [f]) and provides a model and - injection function that the wrapped component can use. Especially of note - is that the [apply_action] for this outer-model has access to the result - value of the Computation being wrapped. *) -val wrap - : ?reset:('action Apply_action_context.t -> 'model -> 'model) - -> ?sexp_of_model:('model -> Sexp.t) - -> ?equal:('model -> 'model -> bool) - -> default_model:'model - -> apply_action: - ('action Apply_action_context.t -> 'result -> 'model -> 'action -> 'model) - -> f:('model Value.t -> ('action -> unit Effect.t) Value.t -> 'result Computation.t) - -> unit - -> 'result Computation.t - -(** [with_model_resetter] extends a computation with the ability to reset all of the - models for components contained in that computation. The default behavior for - a stateful component is to have its model set to the value provided by - [default_model], though this behavior is overridable on a component-by-component - basis by providing a value for the optional [reset] argument on stateful components. *) -val with_model_resetter : 'a Computation.t -> ('a * unit Effect.t) Computation.t - -(** like [with_model_resetter], but makes the resetting effect available to the - computation being wrapped. *) -val with_model_resetter' - : (reset:unit Effect.t Value.t -> 'a Computation.t) - -> 'a Computation.t - -(** [yoink] is a function that takes a bonsai value and produces a - computation producing an effect which fetches the current value out of the - input. This can be useful inside of [let%bind.Effect] chains, where a - value that you've closed over is stale and you want to witness a value - after it's been changed by a previous effect. - - The ['a Computation_state.t] returned by the effect means that if the value - was inactive at the time it got yoinked, then the effect will be unable to - retrieve it. *) -val yoink : 'a Value.t -> 'a Computation_status.t Effect.t Computation.t - -(** [sub] instantiates a computation and provides a reference to its results to - [f] in the form of a [Value.t]. The main way to use this function is via - the [let%sub] syntax extension. [?here] is used by the Bonsai debugger - to tie visualizations to precise source locations. *) -val sub - : ?here:Source_code_position.t - -> 'a Computation.t - -> f:('a Value.t -> 'b Computation.t) - -> 'b Computation.t - -module Clock : sig - (** Functions allowing for the creation of time-dependent computations in - a testable way. *) - - (** The current time, updated at [tick_every] intervals. *) - val approx_now : tick_every:Time_ns.Span.t -> Time_ns.t Computation.t - - (** The current time, update as frequently as possible. *) - val now : Time_ns.t Computation.t - - module Before_or_after : sig - type t = Ui_incr.Before_or_after.t = - | Before - | After - [@@deriving sexp, equal] - end - - (** Mirrors [Incr.Clock.at], which changes from [Before] to [After] at the - specified time. *) - val at : Time_ns.t Value.t -> Before_or_after.t Computation.t - - (** An event passed to [every] is scheduled on an interval determined by - the time-span argument. - - [when_to_start_next_effect] has the following behavior - | `Wait_period_after_previous_effect_starts_blocking -> If the previous effect takes longer than [period], we wait until it finishes before starting the next effect. - | `Wait_period_after_previous_effect_finishes_blocking -> The effect will always be executed [period] after the previous effect finishes. - | `Every_multiple_of_period_non_blocking -> Executes the effect at a regular interval. - | `Every_multiple_of_period_blocking -> Same as `Every_multiple_of_second, but skips a beat if the previous effect is still running. - *) - val every - : when_to_start_next_effect: - [< `Wait_period_after_previous_effect_starts_blocking - | `Wait_period_after_previous_effect_finishes_blocking - | `Every_multiple_of_period_non_blocking - | `Every_multiple_of_period_blocking - ] - -> ?trigger_on_activate:bool - -> Time_ns.Span.t - -> unit Effect.t Value.t - -> unit Computation.t - - (** An effect for fetching the current time. *) - val get_current_time : Time_ns.t Effect.t Computation.t - - (** The function in this computation produces an effect that completes after - the specified amount of time. *) - val sleep : (Time_ns.Span.t -> unit Effect.t) Computation.t - - (** Like [sleep], but waits until a specific time, rather than a time - relative to now. *) - val until : (Time_ns.t -> unit Effect.t) Computation.t -end - -module Edge : sig - (** All the functions in this module incorporate the concept of "edge-triggering", - which is the terminology that we use to describe actions that occur when a value - changes. *) - - (** When given a value and a callback, [on_change] and [on_change'] will watch the - input variable and call the callback whenever the value changes. - - [callback] is also called when the component is initialized, passing in the - first 'a value that gets witnessed. *) - val on_change - : ?sexp_of_model:('a -> Sexp.t) - -> equal:('a -> 'a -> bool) - -> 'a Value.t - -> callback:('a -> unit Effect.t) Value.t - -> unit Computation.t - - (** The same as [on_change], but the callback function gets access to the - previous value that was witnessed. *) - val on_change' - : ?sexp_of_model:('a -> Sexp.t) - -> equal:('a -> 'a -> bool) - -> 'a Value.t - -> callback:('a option -> 'a -> unit Effect.t) Value.t - -> unit Computation.t - - (** [lifecycle] is a way to detect when a computation becomes active, - inactive, or an event is triggered after every rendering (roughly 60x / - second). By depending on this function (with let%sub), you can install - events that are scheduled on either case. - - When used, the events are scheduled in this order: - - All deactivations - - All activations - - All "after-display"s - - and an "after-display" won't occur before an activation, or after a - deactivation for a given computation. *) - val lifecycle - : ?on_activate:unit Effect.t Value.t - -> ?on_deactivate:unit Effect.t Value.t - -> ?after_display:unit Effect.t Value.t - -> unit - -> unit Computation.t - - (** Like [lifecycle], but the events are optional values. If the event value - is None when the action occurs, nothing will happen *) - val lifecycle' - : ?on_activate:unit Effect.t option Value.t - -> ?on_deactivate:unit Effect.t option Value.t - -> ?after_display:unit Effect.t option Value.t - -> unit - -> unit Computation.t - - (** [after_display] and [after_display'] are lower-level functions that - can be used to register an event to occur once-per-frame (after each - render). *) - val after_display : unit Effect.t Value.t -> unit Computation.t - - val after_display' : unit Effect.t option Value.t -> unit Computation.t - - (** [wait_after_display] is an effect that will complete after the next frame. *) - val wait_after_display : unit Effect.t Computation.t - - module Poll : sig - module Starting : sig - type ('o, 'r) t - - (** [empty] is an option to pass to the polling functions that changes - its return type to be ['o option Computation.t] and starting - value is [None] *) - val empty : ('o, 'o option) t - - (** [initial x] is an option to pass to the polling functions that - changes its return type to be ['o Computation.t] and the - starting value is [x] *) - val initial : 'o -> ('o, 'o) t - end - - (** This function runs an effect every time that the input value changes, - returning the most recent result as its computation. - - The [Starting.t] argument controls the type of the result, and - depending on the value, will either return an optional value - [Option.None] or a default value ['o] in the time in between the - computation starting and the first result coming back from the effect. *) - val effect_on_change - : ?sexp_of_input:('a -> Sexp.t) - -> ?sexp_of_result:('o -> Sexp.t) - -> equal_input:('a -> 'a -> bool) - -> ?equal_result:('o -> 'o -> bool) - -> ('o, 'r) Starting.t - -> 'a Value.t - -> effect:('a -> 'o Effect.t) Value.t - -> 'r Computation.t - - val manual_refresh - : ?sexp_of_model:('o -> Sexp.t) - -> ?equal:('o -> 'o -> bool) - -> ('o, 'r) Starting.t - -> effect:'o Effect.t Value.t - -> ('r * unit Effect.t) Computation.t - end -end - -module Memo : sig - (** The [Memo] module can be used to share a computation between multiple - components, meaning that if the shared computation is stateful, then - the users of that computation will see the same state. - - The way that [Memo] differs from just using [let%sub] on a computation - and then passing the resulting [Value.t] down to its children is twofold: - - The shared computation is not made active until it's actually requested - by another component - - Knowledge of any inputs to component are be deferred to "lookup time", when - components request an instance of the component. - - Shared computations are refcounted, so when the last user of a memoized component - deactivates, the shared component is deactivated as well. *) - - type ('input, 'result) t - - (** Creates a memo instance that can be used by calling [lookup] *) - val create - : ('input, 'cmp) comparator - -> f:('input Value.t -> 'result Computation.t) - -> ('input, 'result) t Computation.t - - (** Requests an instance of the shared computation for a given ['input] value. - If an instance doesn't already exist, it will request a new computation, which - results in [none] being returned for a brief period of time, after which it'll - return a [Some] containing the result of that computation *) - val lookup - : ?sexp_of_model:('input -> Sexp.t) - -> equal:('input -> 'input -> bool) - -> ('input, 'result) t Value.t - -> 'input Value.t - -> 'result option Computation.t -end - -module Effect_throttling : sig - module Poll_result : sig - type 'a t = - | Aborted - (** [Aborted] indicates that the effect was aborted before it even - started. If an effect starts, then it should complete with some kind - of result - [Effect] does not support cancellation in general. *) - | Finished of 'a - (** [Finished x] indicates that an effect successfully completed with value x. *) - [@@deriving sexp, equal] - - (** Collapses values of type ['a Or_error.t t] a plain Or_error.t, where - the Aborted case is transformed into an error. - - The [tag_s] parameter can be used to add additional info to the error. *) - val collapse_to_or_error : ?tag_s:Sexp.t lazy_t -> 'a Or_error.t t -> 'a Or_error.t - - (** Like [collapse_to_or_error], but transforms a function that returns an - ['a Or_error.t t] instead of just the value. *) - val collapse_fun_to_or_error - : ?sexp_of_input:('a -> Sexp.t) - -> ('a -> 'b Or_error.t t Effect.t) - -> 'a - -> 'b Or_error.t Effect.t - end - - (** Transforms an input effect into a new effect that enforces that invariant - that at most one instance of the effect is running at once. Attempting to - run the effect while a previous run is still ongoing will cause the new - effect to be enqueued. Any previously enqueued item gets kicked out, thus - maintaining the invariant that at most one effect will be enqueued. (this - is important so that things like RPCs calls don't pile up) - - CAUTION: This computation assumes that the input effect will always - complete. If a run of the effect raises, no more runs will ever get - executed, since they will all be waiting for the one that raised to - complete. *) - val poll - : ('a -> 'b Effect.t) Value.t - -> ('a -> 'b Poll_result.t Effect.t) Computation.t -end - -module Dynamic_scope : sig - (** This module implements dynamic variable scoping. Once a - dynamic variable is created, you can store values in it, and - lookup those same values. A lookup will find the nearest-most - grandparent [set_within] call. *) - - type 'a t - - (** Creates a new variable for use with the rest of the functions. - It is critically important that the exact same [Dynamic_scope.t] is used - in calls to [set_within] and the corresponding [lookup*]. *) - val create : ?sexp_of:('a -> Sexp.t) -> name:string -> fallback:'a -> unit -> 'a t - - (** Creates a variable which is derived from another. Typically this is used to - project out a field of another dynamic variable which contains a record. *) - val derived - : ?sexp_of:('a -> Sexp.t) - -> 'b t - -> get:('b -> 'a) - -> set:('b -> 'a -> 'b) - -> 'a t - - (** Given a ['a Dynamic_scope.t] and a ['a Value.t] evaluate a function - whose resulting Computation.t has access to the value via the - [lookup] function. *) - val set : 'a t -> 'a Value.t -> inside:'r Computation.t -> 'r Computation.t - - type revert = { revert : 'a. 'a Computation.t -> 'a Computation.t } - - (** like [set] but with the ability to revert the value in sub-computations. *) - val set' : 'a t -> 'a Value.t -> f:(revert -> 'r Computation.t) -> 'r Computation.t - - (** Lookup attempts to find the value inside the - nearest scope, but if there isn't one, it falls back to - default specified in [create]. *) - val lookup : 'a t -> 'a Computation.t - - val modify - : 'a t - -> change:('a Value.t -> 'a Value.t) - -> f:(revert -> 'r Computation.t) - -> 'r Computation.t -end - -module Incr : sig - (** A [Value.t] passed through [value_cutoff] will only trigger changes on its dependents when the - value changes according to the provided equality function *) - val value_cutoff : 'a Value.t -> equal:('a -> 'a -> bool) -> 'a Computation.t - - (** Use [compute] to move a function from the incremental world into the bonsai world. *) - val compute : 'a Value.t -> f:('a Incr.t -> 'b Incr.t) -> 'b Computation.t - - (** If you've got an incremental, you can convert it to a value with this function. *) - val to_value : 'a Incr.t -> 'a Value.t - - (** Compute some incremental value based on the time source. Using this time source - instead of [Incr.clock] is the more testable approach, since it allows tests - to control how time moves forward. *) - val with_clock : (Time_source.t -> 'a Incr.t) -> 'a Computation.t -end - -(** This [Let_syntax] module is basically just {!Value.Let_syntax} with the addition of - the [sub] function, which operates on Computations. - - By using the [let%sub] syntax extension, you can put a ['a Computation.t] on the RHS - and get a ['a Value.t] on the LHS. - - {[ - let%sub a = b in - ... - ]} - - In the code above, [b] has type ['a Computation.t], and [a] has type ['a Value.t]. *) -module Let_syntax : sig - (*_ [let%pattern_bind] requires that a function named [return] with these semantics - exist here. *) - val return : 'a Value.t -> 'a Computation.t - val ( >>| ) : 'a Value.t -> ('a -> 'b) -> 'b Value.t - val ( <*> ) : ('a -> 'b) Value.t -> 'a Value.t -> 'b Value.t - val ( <$> ) : ('a -> 'b) -> 'a Value.t -> 'b Value.t - - module Let_syntax : sig - (** [sub] instantiates a computation and provides a reference to its results to - [f] in the form of a [Value.t]. The main way to use this function is via - the [let%sub] syntax extension. [?here] is used by the Bonsai debugger - to tie visualizations to precise source locations. *) - val sub - : ?here:Source_code_position.t - -> 'a Computation.t - -> f:('a Value.t -> 'b Computation.t) - -> 'b Computation.t - - val cutoff : 'a Value.t -> equal:('a -> 'a -> bool) -> 'a Value.t - - val switch - : here:Source_code_position.t - -> match_:int Value.t - -> branches:int - -> with_:(int -> 'a Computation.t) - -> 'a Computation.t - - val map : ?here:Source_code_position.t -> 'a Value.t -> f:('a -> 'b) -> 'b Value.t - val return : 'a Value.t -> 'a Computation.t - val both : 'a Value.t -> 'b Value.t -> ('a * 'b) Value.t - - val arr - : ?here:Source_code_position.t - -> 'a Value.t - -> f:('a -> 'b) - -> 'b Computation.t - - include Mapn with type 'a t := 'a Value.t - end +module Cont : sig + include + module type of Cont + with module For_proc2 := Cont.For_proc2 + and module Conv := Cont.Conv end -module Time_source = Time_source - -module Debug : sig - (** [on_change v ~f] executes the function [f] every time that [v] is recomputed. *) - val on_change : 'a Value.t -> f:('a -> unit) -> unit Computation.t - - (** like [on_change], but specialized for printing a sexp of the value that you - are watching. *) - val on_change_print_s : 'a Value.t -> ('a -> Sexp.t) -> unit Computation.t - - val instrument_computation - : 'a Computation.t - -> start_timer:(string -> unit) - -> stop_timer:(string -> unit) - -> 'a Computation.t - - val to_dot : ?pre_process:bool -> 'a Computation.t -> string - val enable_incremental_annotations : unit -> unit - val disable_incremental_annotations : unit -> unit -end +include + Proc_intf.S + with module Private_computation := Private_computation + and module Private_value := Private_value + and type 'a Value.t = 'a Cont.t + and type 'a Computation.t = Cont.graph -> 'a Cont.t module Private : sig val reveal_value : 'a Value.t -> 'a Private_value.t val conceal_value : 'a Private_value.t -> 'a Value.t - val reveal_computation : 'a Computation.t -> 'a Private_computation.t - val conceal_computation : 'a Private_computation.t -> 'a Computation.t + val top_level_handle : (Cont.graph -> 'a Cont.t) -> 'a Private_computation.t + val handle : f:(Cont.graph -> 'a Cont.t) -> Cont.graph -> 'a Private_computation.t + + val perform + : ?here:Source_code_position.t + -> Cont.graph + -> 'a Private_computation.t + -> 'a Cont.t + val path : Path.t Computation.t module Value = Private_value @@ -1035,278 +56,11 @@ module Private : sig module Skeleton = Skeleton module Transform = Transform module Linter = Linter - module Pre_process = Pre_process val gather : 'result Computation.t -> 'result Computation.packed_info val pre_process : 'result Computation.t -> 'result Computation.t end -module Expert : sig - (** [thunk] will execute its argument exactly once per instantiation of the - computation. *) - val thunk : (unit -> 'a) -> 'a Computation.t - - (** [assoc_on] is similar to [assoc], but allows the model to be keyed differently than - the input map. This comes with a few caveats: - - - Inputs whose keys map to the same [model_key] will share the same model. - - The result of [get_model_key] is used in a bind, so it is expensive when it - changes. - - [assoc] should almost always be used instead. Consider whether you really need the - additional power before reaching for this function. - *) - val assoc_on - : ('io_key, 'io_cmp) comparator - -> ('model_key, 'model_cmp) comparator - -> ('io_key, 'data, 'io_cmp) Map.t Value.t - -> get_model_key:('io_key -> 'data -> 'model_key) - -> f:('io_key Value.t -> 'data Value.t -> 'result Computation.t) - -> ('io_key, 'result, 'io_cmp) Map.t Computation.t -end - -(** Analog to [Incr_map] functions in Bonsai. If you want access to the keys and values - in [Value.t] form, or want to produce a Computation as a result, then you should use - [Bonsai.assoc] *) -module Map : sig - val mapi - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v1 -> 'v2) - -> ('k, 'v2, 'cmp) Map.t Computation.t - - val map - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:('v1 -> 'v2) - -> ('k, 'v2, 'cmp) Map.t Computation.t - - val of_set : ('k, 'cmp) Set.t Value.t -> ('k, unit, 'cmp) Map.t Computation.t - - val filter_mapi - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v1 -> 'v2 option) - -> ('k, 'v2, 'cmp) Map.t Computation.t - - val filter_map - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:('v1 -> 'v2 option) - -> ('k, 'v2, 'cmp) Map.t Computation.t - - val partition_mapi - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v1 -> ('v2, 'v3) Either.t) - -> (('k, 'v2, 'cmp) Map.t * ('k, 'v3, 'cmp) Map.t) Computation.t - - val unordered_fold - : ?update:(key:'k -> old_data:'v -> new_data:'v -> 'acc -> 'acc) - -> ('k, 'v, 'cmp) Map.t Value.t - -> init:'acc - -> add:(key:'k -> data:'v -> 'acc -> 'acc) - -> remove:(key:'k -> data:'v -> 'acc -> 'acc) - -> 'acc Computation.t - - val unordered_fold_with_extra - : ?update:(key:'k -> old_data:'v -> new_data:'v -> 'acc -> 'extra -> 'acc) - -> ('k, 'v, 'e) Map.t Value.t - -> 'extra Value.t - -> init:'acc - -> add:(key:'k -> data:'v -> 'acc -> 'extra -> 'acc) - -> remove:(key:'k -> data:'v -> 'acc -> 'extra -> 'acc) - -> extra_changed: - (old_extra:'extra - -> new_extra:'extra - -> input:('k, 'v, 'e) Map.t - -> 'acc - -> 'acc) - -> 'acc Computation.t - - val cutoff - : ('k, 'v, 'cmp) Map.t Value.t - -> equal:('v -> 'v -> bool) - -> ('k, 'v, 'cmp) Map.t Computation.t - - val mapi_count - : ('k1, 'v, 'cmp1) Map.t Value.t - -> comparator:('k2, 'cmp2) comparator - -> f:(key:'k1 -> data:'v -> 'k2) - -> ('k2, int, 'cmp2) Map.t Computation.t - - val map_count - : ('k1, 'v, 'cmp1) Map.t Value.t - -> comparator:('k2, 'cmp2) comparator - -> f:('v -> 'k2) - -> ('k2, int, 'cmp2) Map.t Computation.t - - val mapi_min - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) comparator - -> f:(key:'k -> data:'v -> 'r) - -> 'r option Computation.t - - val mapi_max - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) comparator - -> f:(key:'k -> data:'v -> 'r) - -> 'r option Computation.t - - val map_min - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) comparator - -> f:('v -> 'r) - -> 'r option Computation.t - - val map_max - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) comparator - -> f:('v -> 'r) - -> 'r option Computation.t - - val min_value - : ('k, 'v, _) Map.t Value.t - -> comparator:('v, _) comparator - -> 'v option Computation.t - - val max_value - : ('k, 'v, _) Map.t Value.t - -> comparator:('v, _) comparator - -> 'v option Computation.t - - val mapi_bounds - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) comparator - -> f:(key:'k -> data:'v -> 'r) - -> ('r * 'r) option Computation.t - - val map_bounds - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) comparator - -> f:('v -> 'r) - -> ('r * 'r) option Computation.t - - val value_bounds - : ('k, 'v, _) Map.t Value.t - -> comparator:('v, _) comparator - -> ('v * 'v) option Computation.t - - val merge - : ('k, 'v1, 'cmp) Map.t Value.t - -> ('k, 'v2, 'cmp) Map.t Value.t - -> f:(key:'k -> ('v1, 'v2) Map.Merge_element.t -> 'v3 option) - -> ('k, 'v3, 'cmp) Map.t Computation.t - - val merge_both_some - : ('k, 'v1, 'cmp) Map.t Value.t - -> ('k, 'v2, 'cmp) Map.t Value.t - -> f:(key:'k -> 'v1 -> 'v2 -> 'v3) - -> ('k, 'v3, 'cmp) Map.t Computation.t - - val unzip - : ('k, 'a * 'b, 'cmp) Map.t Value.t - -> (('k, 'a, 'cmp) Map.t * ('k, 'b, 'cmp) Map.t) Computation.t - - val unzip_mapi - : ('k, 'v, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v -> 'v1 * 'v2) - -> (('k, 'v1, 'cmp) Map.t * ('k, 'v2, 'cmp) Map.t) Computation.t - - val keys : ('k, 'v, 'c) Map.t Value.t -> ('k, 'c) Set.t Computation.t - val rank : ('k, 'v, 'cmp) Map.t Value.t -> 'k Value.t -> int option Computation.t - - val subrange - : ('k, 'v, 'cmp) Map.t Value.t - -> ('k Maybe_bound.As_lower_bound.t * 'k Maybe_bound.As_upper_bound.t) option Value.t - -> ('k, 'v, 'cmp) Map.t Computation.t - - val subrange_by_rank - : ('k, 'v, 'cmp) Map.t Value.t - -> (int Maybe_bound.As_lower_bound.t * int Maybe_bound.As_upper_bound.t) Value.t - -> ('k, 'v, 'cmp) Map.t Computation.t - - val rekey - : ('k1, 'v, 'cmp1) Map.t Value.t - -> comparator:('k2, 'cmp2) comparator - -> f:(key:'k1 -> data:'v -> 'k2) - -> ('k2, 'v, 'cmp2) Map.t Computation.t - - val index_byi - : ('inner_key, 'v, 'inner_cmp) Map.t Value.t - -> comparator:('outer_key, 'outer_cmp) comparator - -> index:(key:'inner_key -> data:'v -> 'outer_key option) - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t - - val index_by - : ('inner_key, 'v, 'inner_cmp) Map.t Value.t - -> comparator:('outer_key, 'outer_cmp) comparator - -> index:('v -> 'outer_key option) - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t - - val unordered_fold_nested_maps - : ?update: - (outer_key:'outer_key - -> inner_key:'inner_key - -> old_data:'v - -> new_data:'v - -> 'acc - -> 'acc) - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t - -> init:'acc - -> add:(outer_key:'outer_key -> inner_key:'inner_key -> data:'v -> 'acc -> 'acc) - -> remove:(outer_key:'outer_key -> inner_key:'inner_key -> data:'v -> 'acc -> 'acc) - -> 'acc Computation.t - - val transpose - : ('k2, 'k2_cmp) comparator - -> ('k1, ('k2, 'v, 'k2_cmp) Map.t, 'k1_cmp) Map.t Value.t - -> ('k2, ('k1, 'v, 'k1_cmp) Map.t, 'k2_cmp) Map.t Computation.t - - val collapse - : ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t - -> comparator:('inner_key, 'inner_cmp) comparator - -> ( 'outer_key * 'inner_key - , 'v - , ('outer_cmp, 'inner_cmp) Tuple2.comparator_witness ) - Map.t - Computation.t - - val collapse_by - : ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t - -> merge_keys:('outer_key -> 'inner_key -> 'combined_key) - -> comparator:('combined_key, 'combined_cmp) comparator - -> ('combined_key, 'v, 'combined_cmp) Map.t Computation.t - - val expand - : ('outer_key * 'inner_key, 'v, 'tuple_cmp) Map.t Value.t - -> outer_comparator:('outer_key, 'outer_cmp) comparator - -> inner_comparator:('inner_key, 'inner_cmp) comparator - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t - - val counti - : ('k, 'v, _) Map.t Value.t - -> f:(key:'k -> data:'v -> bool) - -> int Computation.t - - val count : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> int Computation.t - - val for_alli - : ('k, 'v, _) Map.t Value.t - -> f:(key:'k -> data:'v -> bool) - -> bool Computation.t - - val for_all : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> bool Computation.t - - val existsi - : ('k, 'v, _) Map.t Value.t - -> f:(key:'k -> data:'v -> bool) - -> bool Computation.t - - val exists : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> bool Computation.t - - val sum - : (_, 'v, _) Map.t Value.t - -> (module Abstract_algebra.Commutative_group.Without_sexp with type t = 'u) - -> f:('v -> 'u) - -> 'u Computation.t -end - module Arrow_deprecated : sig include Legacy_api_intf.S diff --git a/src/cont.ml b/src/cont.ml new file mode 100644 index 00000000..19eed20c --- /dev/null +++ b/src/cont.ml @@ -0,0 +1,917 @@ +open! Core +open! Import +module Time_source = Time_source +module Apply_action_context = Apply_action_context + +module Cont_primitives : sig + (** Bonsai's [Cont] implementation is based on continuation-passing style. + + Previously, in [Proc], calls to [sub] and [arr] directly added the corresponding + evaluation/lookup nodes to the computation graph, which was available through + the [Computation.t]'s underlying type representation. + + As before, [Computation.t] is the static structure of the computation graph, + and [Bonsai.t = Value.t] is the incrementally-computed "runtime" value. + We now use that representation as an intermediate representation, + but end-users don't construct the computation graph directly. + + Instead, we pass around a ['graph'] value. When components are combined or + composed, Bonsai's internals add the new computation into the computation + graph. + + The primitive API (not exposed to end-users) tries to simulate algebraic effects. + - [perform] takes a [local_ graph -> Computation.t] component, + evaluates it, and adds it into the computation graph. + It returns a [Value.t] memoized alias to this new computation. + - [handle] places a [Value.t] in the context of a fresh computation graph. + It then wraps the result in a [Computation.t]. + This is generally used to construct a portion of the computation graph + in isolation. The subgraph is then added to the main graph via [perform]. + + At the top level, [top_level_handle] is similar to [handle], but only takes [f]. + In the context of a fresh graph, it runs [f graph] to obtain the total composed + [Value.t] for a Bonsai app. Then, it raises that to a [Computation.t], + and passes {i that i} through the [graph.f] that we've been assembling + all this time. + + But what's going on under the surface? And what is [graph]? + And why can the new Bonsai API use [let%map]? + + --- + + If you look at computation.ml, you'll see that [Computation.t] is a nested variant + of nodes that store things. These include state, assoc/switch, store/fetch for + Dynamic_scope, and most commonly used, sub. This is the memoization-like + pattern that powers work-sharing for incrementality: we can store a reusable + value with a unique name (via Type_equal.id), which downstream incremental [Value.t]s + can reference (and reuse!) instead of repeating work. [Sub] has 3 fields: + + - [from] is the computation being memoized + - [via] is the [Type_equal.id] identifier + - [into] is the downstream computation that uses the value of [from]. + + So if we want to depend on several [sub]ed computations, our graph will look as follows: + + {v + Sub { from=comp1; via=; into = + Sub { from=comp2; via=; into = + ... into = thing_we_want_to_compute ... + } + } + v} + + --- + + The [graph] we pass around is a ref to a function that will eventually compute this + [Computation.t]. We can't construct it eagerly as we go, since that would require + making the fields of [Computation.t] mutable, so we need to do some functional + trickery. + + [graph] starts as [Fn.id]. At each invocation of [perform], + we overwrite it to still return its input, but nested in a new layer of [Sub]. + Let's look at how this works in practice: + + {v + 1.let my_component graph = + 2. let%sub model1, _inject = Bonsai.state 5 in + 3. let%sub model2, _inject = Bonsai.state 6 in + 4. model2 + + 1. graph = { f = fun r -> r } + 2. graph = { f = fun r -> Sub { from=state 5; via=; into=r } } + 3. graph = { f = fun r -> Sub { from=state 5; via=; into=Sub { from=state 6; via=; into=r } } } + 4. graph.f () ==> Sub { from=state 5; via=; into=Sub { from=state 6; via=; into= } } + v} + + Instead of [state 5/6], we'd actually have something more like [Leaf0 { ... }], + but that's not really relevant. We also do some optimizations if [sub]ing isn't + actually necessary. + + Handle is much simpler: we run our [Value.t] construction function ([f]) on a fresh + [graph], which becomes constructed via calls to [perform] presumably inside [f]. + Then, we call [graph.f] on that result, so that it is inside the nested [Sub]s, + giving it access to those memoized aliases. Finally, we wrap this in a [Computation.t], + which can be [perform]ed into other computations. + + --- + + But why can we now use [let%map.Bonsai] instead of [let%sub] and [let%arr] combos? + After all, we're not passing [graph] to [let%map]... + + In short, we cheat and make [graph] global. We still require users to pass it + when possible, so that creating costly stateful nodes is an explicit operation. + However, we don't want people to use these "magic" [let%map] and [match%sub] calls + unless they are in the dynamic scope of a Bonsai top level. + We enforce this by maintaining a global boolean ref for whether we're in a top level, + and erroring on [perform] if we are not. + *) + + type graph + + (* Main primitives; see above for explanation. *) + val perform : ?here:Source_code_position.t -> graph -> 'a Computation.t -> 'a Value.t + val handle : f:(graph -> 'a Value.t) -> graph -> 'a Computation.t + + (* Special-use primitives for getting the global graph, and creating it in the top level. *) + val isolated : graph -> f:(unit -> 'a Value.t) -> 'a Computation.t + val top_level_handle : (graph -> 'a Value.t) -> 'a Computation.t + val handle_for_lazy : (graph -> 'a Value.t) -> 'a Computation.t + val with_global_graph : f:(graph -> 'a) -> no_graph:(unit -> 'a) -> 'a +end = struct + type graph = { mutable f : 'a. 'a Computation.t -> 'a Computation.t } + + let perform + : type a. ?here:Source_code_position.t -> graph -> a Computation.t -> a Value.t + = + fun ?here graph -> function + | Return { value = (Named _ | Constant _ | Exception _) as value; id; _ } -> + (* Introduce the optimization [let%sub a = return foo in use a] => [use foo] + This only makes sense if the Value.t being returned is either a constant or an + already-bound named value, otherwise you risk losing value sharing. *) + { Value.value; id; here = None } + | computation_to_perform -> + (* Mint a fresh type-id to hold the result of performing this graph modification *) + let via : a Type_equal.Id.t = Type_equal.Id.create ~name:"" [%sexp_of: opaque] in + (* Keep hold of the previous graph-modification function *) + let old_f : type b. b Computation.t -> b Computation.t = graph.f in + let new_f : type x. x Computation.t -> x Computation.t = function + | Return { value = Named _; id; _ } when Type_equal.Id.same via id -> + (* introduce the optimization {[ let%sub a = foo bar in return a ]} => {[ foo bar ]} *) + let T = Type_equal.Id.same_witness_exn via id in + old_f computation_to_perform + | eventual_result -> + (* old_f takes the eventual innermost result, and wraps it in 0+ layers of subs. + We replace it with a new function that adds another layer to the inside. *) + old_f + (Sub + { from = computation_to_perform; via; into = eventual_result; here = None }) + in + (* write the new hole into the graph, and return a new value referencing the + type-id that will be populated when [new_f] is invoked. *) + graph.f <- new_f; + Value.named (Sub here) via + ;; + + (* [isolated] runs [f] on a fresh graph context. As an implementation detail, we actually + mutate the same ['graph'], so that [the_one_and_only] is kept up to date. + [isolated] also has an exception handler that returns any exceptions inside a Value.t. + This restricts the return type of [isolated] to ['a Computation.t]. *) + let isolated graph ~f = + let backup_f = graph.f in + graph.f <- Fn.id; + try + let r = f () in + let r = graph.f (Proc.read r) in + graph.f <- backup_f; + r + with + | exn -> + graph.f <- backup_f; + Proc.read (Value.return_exn exn) + ;; + + (* A global value which stores the current graph. This is so that functions like + [Cont.map] can look up the current graph without being passed it explicitly. *) + let the_one_and_only = { f = (fun _ -> failwith "outside of a Bonsai toplevel") } + + (* If [Value.map] is called within a [top_level_handle], we can use the global graph to + deduplicate work. This counter keeps track of the number of nested [top_level_handle] + calls we're currently within. In theory, this could be a bool, since + [top_level_handle] calls shouldn't be nested, but this is a bit more defensive. *) + let num_nested_top_level_handles = ref 0 + + (* A small wrapper around isolated. All it does is ensure that you're using + the same graph that you passed in. *) + let handle ~f graph = isolated graph ~f:(fun () -> f graph) [@nontail] + + let handle_with_global_graph inside_a_lazy f = + (* nesting calls to this function is _fine_, but it should never happen, + unless you're inside of a lazy_, where it's begrudgingly expected *) + (match inside_a_lazy, !num_nested_top_level_handles > 0 with + | `Not_inside_lazy, true -> + eprintf + "BUG: nested calls (%d) to top_level_handle. Please report to bonsai-devs.\n" + !num_nested_top_level_handles + | `Inside_lazy, (true | false) | `Not_inside_lazy, false -> ()); + incr num_nested_top_level_handles; + Exn.protect + ~f:(fun () -> + let g = the_one_and_only in + let backup_f = g.f in + g.f <- Fn.id; + let v = f g in + let computation_context = g.f in + g.f <- backup_f; + (* You grit your teeth, plant your feet against the floor, and dredge a + Computation.t from the void. *) + computation_context (Proc_min.read v) [@nontail]) + ~finally:(fun () -> decr num_nested_top_level_handles) [@nontail] + ;; + + let handle_for_lazy f = handle_with_global_graph `Inside_lazy f + + (* Meant to be called at bonsai entrypoints only, [top_level_handle] uses the + singleton graph and sets [nested_top_level_handles] acordingly. *) + let top_level_handle f = handle_with_global_graph `Not_inside_lazy f + + (* provides a way to get the current graph or provide a fallback if we aren't inside a + call to top_level_handle. *) + let with_global_graph ~f ~no_graph = + if !num_nested_top_level_handles > 0 then f the_one_and_only else no_graph () + ;; +end + +type 'a t = 'a Value.t +type graph = Cont_primitives.graph + +open Cont_primitives + +let return = Value.return +let arr1 graph a ~f = perform graph (Proc.read (Proc.Value.map a ~f)) +let arr2 graph a b ~f = perform graph (Proc.read (Proc.Value.map2 a b ~f)) +let arr3 graph a b c ~f = perform graph (Proc.read (Proc.Value.map3 a b c ~f)) +let arr4 graph a b c d ~f = perform graph (Proc.read (Proc.Value.map4 a b c d ~f)) +let arr5 graph a b c d e ~f = perform graph (Proc.read (Proc.Value.map5 a b c d e ~f)) +let arr6 graph a b c d e g ~f = perform graph (Proc.read (Proc.Value.map6 a b c d e g ~f)) + +let arr7 graph a b c d e g h ~f = + perform graph (Proc.read (Proc.Value.map7 a b c d e g h ~f)) +;; + +(* If we aren't inside of a [top_level_handle], then fall back to using [Value.map] *) +let map a ~f = + with_global_graph ~f:(fun graph -> arr1 graph a ~f) ~no_graph:(fun () -> Value.map a ~f) +;; + +let map2 a b ~f = + with_global_graph + ~f:(fun graph -> arr2 graph a b ~f) + ~no_graph:(fun () -> Value.map2 a b ~f) +;; + +include Applicative.Make_using_map2 (struct + type nonrec 'a t = 'a t + + let return = return + let map2 = map2 + let map = `Custom map +end) + +let map3 a b c ~f = + with_global_graph + ~f:(fun graph -> arr3 graph a b c ~f) + ~no_graph:(fun () -> Value.map3 a b c ~f) +;; + +let map4 a b c d ~f = + with_global_graph + ~f:(fun graph -> arr4 graph a b c d ~f) + ~no_graph:(fun () -> Value.map4 a b c d ~f) +;; + +let map5 a b c d e ~f = + with_global_graph + ~f:(fun graph -> arr5 graph a b c d e ~f) + ~no_graph:(fun () -> Value.map5 a b c d e ~f) +;; + +let map6 a b c d e g ~f = + with_global_graph + ~f:(fun graph -> arr6 graph a b c d e g ~f) + ~no_graph:(fun () -> Value.map6 a b c d e g ~f) +;; + +let map7 a b c d e g h ~f = + with_global_graph + ~f:(fun graph -> arr7 graph a b c d e g h ~f) + ~no_graph:(fun () -> Value.map7 a b c d e g h ~f) +;; + +let both a b = map2 a b ~f:Tuple2.create + +let transpose_opt opt = + Option.value_map opt ~default:(return None) ~f:(map ~f:Option.some) +;; + +let path_id graph = perform graph Proc.path_id + +let split graph tuple = + let a = arr1 graph tuple ~f:Tuple2.get1 in + let b = arr1 graph tuple ~f:Tuple2.get2 in + a, b +;; + +let state__for_proc2 ?reset ?sexp_of_model ?equal default_model graph = + perform graph (Proc.state ?reset ?sexp_of_model ?equal default_model) +;; + +let state ?reset ?sexp_of_model ?equal default_model graph = + state__for_proc2 ?reset ?sexp_of_model ?equal default_model graph |> split graph +;; + +let state_opt__for_proc2 ?reset ?default_model ?sexp_of_model ?equal () graph = + perform graph (Proc.state_opt ?reset ?sexp_of_model ?equal ?default_model ()) +;; + +let state_opt ?reset ?sexp_of_model ?equal ?default_model graph = + state_opt__for_proc2 ?reset ?sexp_of_model ?equal ?default_model () graph |> split graph +;; + +let toggle__for_proc2 ~default_model graph = perform graph (Proc.toggle ~default_model) +let toggle ~default_model graph = toggle__for_proc2 ~default_model graph |> split graph + +module Toggle = struct + type 'a v = 'a t + + type t = + { state : bool v + ; set_state : (bool -> unit Effect.t) v + ; toggle : unit Effect.t v + } + [@@deriving fields ~getters] +end + +let toggle' ~default_model graph = + let all = perform graph (Proc.toggle' ~default_model) in + let state = arr1 graph all ~f:(fun { Proc.Toggle.state; _ } -> state) in + let set_state = arr1 graph all ~f:(fun { Proc.Toggle.set_state; _ } -> set_state) in + let toggle = arr1 graph all ~f:(fun { Proc.Toggle.toggle; _ } -> toggle) in + { Toggle.state; set_state; toggle } +;; + +module Path = Path + +let path graph = perform graph Proc.path + +let state_machine0__for_proc2 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~apply_action + () + graph + = + Proc.state_machine0 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + () + ~default_model + ~apply_action + |> perform graph +;; + +let state_machine0 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~apply_action + graph + = + state_machine0__for_proc2 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~apply_action + () + graph + |> split graph +;; + +module Computation_status = Proc.Computation_status + +let state_machine1__for_proc2 + ?sexp_of_action + ?reset + ?sexp_of_model + ?equal + ~default_model + ~apply_action + input + graph + = + Proc.state_machine1 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~apply_action + input + |> perform graph +;; + +let state_machine1 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~apply_action + input + graph + = + state_machine1__for_proc2 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~apply_action + input + graph + |> split graph +;; + +let actor0__for_proc2 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~recv + () + graph + = + Proc.actor0 ?reset ?sexp_of_model ?sexp_of_action ?equal ~default_model ~recv () + |> perform graph +;; + +let actor0 ?reset ?sexp_of_model ?sexp_of_action ?equal ~default_model ~recv graph = + actor0__for_proc2 + ?reset + ?sexp_of_model + ?sexp_of_action + ?equal + ~default_model + ~recv + () + graph + |> split graph +;; + +let actor1__for_proc2 + ?sexp_of_action + ?reset + ?sexp_of_model + ?equal + ~default_model + ~recv + input + graph + = + Proc.actor1 ?reset ?sexp_of_model ?sexp_of_action ?equal ~default_model ~recv input + |> perform graph +;; + +let actor1 ?sexp_of_action ?reset ?sexp_of_model ?equal ~default_model ~recv input graph = + actor1__for_proc2 + ?sexp_of_action + ?reset + ?sexp_of_model + ?equal + ~default_model + ~recv + input + graph + |> split graph +;; + +let delay ~f graph = Proc.lazy_ (lazy (handle_for_lazy f)) |> perform graph + +module Expert = struct + let thunk ~f graph = perform graph (Proc.thunk f) + + let assoc_on io_cmp model_cmp map ~get_model_key ~f graph = + Proc.assoc_on io_cmp model_cmp map ~get_model_key ~f:(fun k v -> + handle graph ~f:(fun graph -> f k v graph) [@nontail]) + |> perform graph + ;; + + let delay = delay +end + +let freeze ?sexp_of_model ?equal v graph = + perform graph (Proc.freeze ?sexp_of_model ?equal v) +;; + +let fix v ~f graph = + let rec recurse i2 graph = delay graph ~f:(fun graph -> f ~recurse i2 graph) in + f ~recurse v graph +;; + +let fix2 a b ~f graph = + let rec recurse a b graph = delay graph ~f:(fun graph -> f ~recurse a b graph) in + f ~recurse a b graph +;; + +let scope_model comparator ~on ~for_ graph = + Proc.scope_model comparator ~on (handle graph ~f:(fun graph -> for_ graph)) + |> perform graph +;; + +let most_recent_some ?sexp_of_model ~equal value ~f graph = + Proc.most_recent_some ?sexp_of_model ~equal value ~f |> perform graph +;; + +let most_recent_value_satisfying ?sexp_of_model ~equal value ~condition graph = + Proc.most_recent_value_satisfying ?sexp_of_model ~equal value ~condition + |> perform graph +;; + +let previous_value ?sexp_of_model ~equal value graph = + Proc.previous_value ?sexp_of_model ~equal value |> perform graph +;; + +let wrap__for_proc2 ?reset ?sexp_of_model ?equal ~default_model ~apply_action ~f () graph = + Proc_min.wrap + ?reset + ?sexp_of_model + ?equal + ~default_model + ~apply_action + () + ~f:(fun model inject -> + handle graph ~f:(fun graph -> f model inject graph) [@nontail]) + |> perform graph +;; + +let wrap ?reset ?sexp_of_model ?equal ~default_model ~apply_action ~f graph = + wrap__for_proc2 ?reset ?sexp_of_model ?equal ~default_model ~apply_action ~f () graph +;; + +let with_model_resetter__for_proc2 ~f graph = + perform graph (Proc.with_model_resetter (handle graph ~f:(fun graph -> f graph))) +;; + +let with_model_resetter ~f graph = with_model_resetter__for_proc2 ~f graph |> split graph + +let with_model_resetter' ~f graph = + Proc_min.with_model_resetter (fun ~reset -> + handle graph ~f:(fun graph -> f ~reset graph) [@nontail]) + |> perform graph +;; + +let peek value graph = perform graph (Proc.yoink value) +let ignore_t (_ : unit t) = () + +module Clock = struct + let approx_now ~tick_every graph = perform graph (Proc.Clock.approx_now ~tick_every) + let now graph = perform graph Proc.Clock.now + + module Before_or_after = struct + type t = Ui_incr.Before_or_after.t = + | Before + | After + [@@deriving sexp, equal] + end + + let at time graph = perform graph (Proc.Clock.at time) + + let every ~when_to_start_next_effect ?trigger_on_activate span callback graph = + Proc.Clock.every ~when_to_start_next_effect ?trigger_on_activate span callback + |> perform graph + |> ignore_t + ;; + + let get_current_time graph = perform graph Proc.Clock.get_current_time + let sleep graph = perform graph Proc.Clock.sleep + let until graph = perform graph Proc.Clock.until +end + +module Edge = struct + let on_change__for_proc2 ?sexp_of_model ~equal value ~callback graph = + perform graph (Proc.Edge.on_change ?sexp_of_model ~equal value ~callback) + ;; + + let on_change ?sexp_of_model ~equal value ~callback graph = + ignore_t (on_change__for_proc2 ?sexp_of_model ~equal value ~callback graph) + ;; + + let on_change'__for_proc2 ?sexp_of_model ~equal value ~callback graph = + perform graph (Proc.Edge.on_change' ?sexp_of_model ~equal value ~callback) + ;; + + let on_change' ?sexp_of_model ~equal value ~callback graph = + ignore_t (on_change'__for_proc2 ?sexp_of_model ~equal value ~callback graph) + ;; + + let lifecycle__for_proc2 ?on_activate ?on_deactivate ?after_display () graph = + perform graph (Proc.Edge.lifecycle ?on_activate ?on_deactivate ?after_display ()) + ;; + + let lifecycle ?on_activate ?on_deactivate ?after_display graph = + ignore_t (lifecycle__for_proc2 ?on_activate ?on_deactivate ?after_display () graph) + ;; + + let lifecycle'__for_proc2 ?on_activate ?on_deactivate ?after_display () graph = + perform graph (Proc.Edge.lifecycle' ?on_activate ?on_deactivate ?after_display ()) + ;; + + let lifecycle' ?on_activate ?on_deactivate ?after_display graph = + ignore_t (lifecycle'__for_proc2 ?on_activate ?on_deactivate ?after_display () graph) + ;; + + let after_display__for_proc2 callback graph = + perform graph (Proc.Edge.after_display callback) + ;; + + let after_display callback graph = ignore_t (after_display__for_proc2 callback graph) + + let after_display'__for_proc2 callback graph = + perform graph (Proc.Edge.after_display' callback) + ;; + + let after_display' callback graph = ignore_t (after_display'__for_proc2 callback graph) + let wait_after_display graph = perform graph Proc.Edge.wait_after_display + + module Poll = struct + module Starting = Proc.Edge.Poll.Starting + + let effect_on_change + ?sexp_of_input + ?sexp_of_result + ~equal_input + ?equal_result + starting + value + ~effect + graph + = + Proc.Edge.Poll.effect_on_change + ?sexp_of_input + ?sexp_of_result + ~equal_input + ?equal_result + starting + value + ~effect + |> perform graph + ;; + + let manual_refresh__for_proc2 ?sexp_of_model ?equal starting ~effect graph = + perform graph (Proc.Edge.Poll.manual_refresh ?sexp_of_model ?equal starting ~effect) + ;; + + let manual_refresh ?sexp_of_model ?equal starting ~effect graph = + manual_refresh__for_proc2 ?sexp_of_model ?equal starting ~effect graph + |> split graph + ;; + end +end + +module Memo = struct + type ('input, 'result) t = ('input, 'result) Proc.Memo.t + + let create cmp ~f graph = + Proc.Memo.create cmp ~f:(fun v -> handle graph ~f:(fun graph -> f v graph) [@nontail]) + |> perform graph + ;; + + let lookup ?sexp_of_model ~equal t input graph = + perform graph (Proc.Memo.lookup ?sexp_of_model ~equal t input) + ;; +end + +module Effect_throttling = struct + module Poll_result = Proc.Effect_throttling.Poll_result + + let poll callback graph = perform graph (Proc.Effect_throttling.poll callback) +end + +module Dynamic_scope = struct + type 'a bonsai_t = 'a t + type 'a t = 'a Proc.Dynamic_scope.t + type revert = { revert : 'a. (graph -> 'a bonsai_t) -> graph -> 'a bonsai_t } + + let create = Proc.Dynamic_scope.create + let derived = Proc.Dynamic_scope.derived + + let set var value ~inside graph = + let inside = handle graph ~f:(fun graph -> inside graph) in + perform graph (Proc.Dynamic_scope.set var value ~inside) + ;; + + let f_with_resetter ~f graph (resetter : Proc.Dynamic_scope.revert) = + let resetter : revert = + { revert = + (fun c graph -> + perform graph (resetter.revert (handle graph ~f:(fun graph -> c graph)))) + } + in + handle graph ~f:(fun graph -> f resetter graph) + ;; + + let set' var value ~f graph = + let f = f_with_resetter ~f graph in + perform graph (Proc.Dynamic_scope.set' var value ~f) + ;; + + let lookup var graph = perform graph (Proc.Dynamic_scope.lookup var) + + let modify var ~change ~f graph = + let f = f_with_resetter ~f graph in + perform graph (Proc.Dynamic_scope.modify var ~change ~f) + ;; +end + +module Incr = struct + let value_cutoff t ~equal graph = perform graph (Proc.Incr.value_cutoff t ~equal) + let compute t ~f graph = perform graph (Proc.Incr.compute t ~f) + let to_value incr = Proc.Incr.to_value incr + let with_clock ~f graph = perform graph (Proc.Incr.with_clock f) +end + +let assoc comparator map ~f graph = + (Proc.assoc comparator map ~f:(fun k v -> + handle graph ~f:(fun graph -> f k v graph) [@nontail]) [@nontail]) + |> perform graph +;; + +let assoc_set comparator set ~f graph = + Proc.assoc_set comparator set ~f:(fun k -> + handle graph ~f:(fun graph -> f k graph) [@nontail]) + |> perform graph +;; + +let assoc_list comparator list ~get_key ~f graph = + Proc.assoc_list comparator list ~get_key ~f:(fun k v -> + handle graph ~f:(fun graph -> f k v graph) [@nontail]) + |> perform graph +;; + +module Debug = struct + let on_change v ~f graph = + (* Use [after_display] because the incremental node is always considered to be in use.*) + let f = + arr1 graph v ~f:(fun v -> + f v; + Effect.Ignore) + in + Edge.after_display f graph + ;; + + let on_change_print_s v sexp_of = on_change v ~f:(fun a -> print_s (sexp_of a)) + let to_dot ?pre_process c = To_dot.to_dot ?pre_process (top_level_handle c) + let enable_incremental_annotations = Annotate_incr.enable + let disable_incremental_annotations = Annotate_incr.disable + + let instrument_computation c ~start_timer ~stop_timer graph = + Instrumentation.instrument_computation (handle graph ~f:c) ~start_timer ~stop_timer + |> perform graph + ;; +end + +let switch__for_proc2 ~match_ ~branches ~with_ graph = + let arms = + let arms = ref [] in + for i = 0 to branches - 1 do + let computation = isolated graph ~f:(fun () -> with_ i graph) in + arms := (i, computation) :: !arms + done; + !arms + in + Computation.Switch { match_; arms = Map.of_alist_exn (module Int) arms; here = [%here] } + |> perform graph +;; + +module Let_syntax = struct + let return = return + let ( >>| ) t f = map t ~f + + module Let_syntax = struct + let return = Fn.id + let map ?here:_ a ~f = map a ~f + let arr ?here:_ a ~f = map a ~f + let map2 = map2 + let map3 = map3 + let map4 = map4 + let map5 = map5 + let map6 = map6 + let map7 = map7 + let both = both + let cutoff v ~equal = Value.cutoff v ~equal ~added_by_let_syntax:true + + let switch ~here:_ ~match_ ~branches ~with_ graph = + let with_ i _graph = with_ i in + switch__for_proc2 ~match_ ~branches ~with_ graph [@nontail] + ;; + + let switch ~here ~match_ ~branches ~with_ = + with_global_graph + ~f:(fun graph -> switch ~here ~match_ ~branches ~with_ graph) + ~no_graph:(fun () -> + failwith "match%sub called outside of the context of a graph") [@nontail] + ;; + + let sub ?here:_ a ~f = f a + end +end + +(* These functions are here to provide the basis for the [proc_layer2.ml] which + wants versions of these functions that don't have calls to [split] in them *) +module For_proc2 = struct + let arr1_with_location ?here graph a ~f = + perform graph (Proc.read (Proc.Let_syntax.Let_syntax.map ?here a ~f)) + ;; + + let value_cutoff v ~equal = Value.cutoff v ~equal ~added_by_let_syntax:false + let conceal_value v = v + let state = state__for_proc2 + let state_opt = state_opt__for_proc2 + let toggle = toggle__for_proc2 + + module Toggle = Proc.Toggle + + let toggle' ~default_model graph = perform graph (Proc.toggle' ~default_model) + let state_machine0 = state_machine0__for_proc2 + let state_machine1 = state_machine1__for_proc2 + let actor0 = actor0__for_proc2 + let actor1 = actor1__for_proc2 + let wrap = wrap__for_proc2 + let with_model_resetter f graph = with_model_resetter__for_proc2 ~f graph + let with_model_resetter' f graph = with_model_resetter' ~f graph + let lazy_ f graph = delay ~f:(fun graph -> Lazy.force f graph) graph + + let switch ~match_ ~branches ~with_ graph = + switch__for_proc2 ~match_ ~branches ~with_ graph + ;; + + let on_change = Edge.on_change__for_proc2 + let on_change' = Edge.on_change'__for_proc2 + let lifecycle = Edge.lifecycle__for_proc2 + let lifecycle' = Edge.lifecycle'__for_proc2 + let after_display = Edge.after_display__for_proc2 + let after_display' = Edge.after_display'__for_proc2 + let manual_refresh = Edge.Poll.manual_refresh__for_proc2 + + let debug_on_change v ~f graph = + let f = + arr1 graph v ~f:(fun v -> + f v; + Effect.Ignore) + in + Edge.after_display__for_proc2 f graph + ;; + + let debug_on_change_print_s v sexp_of = + debug_on_change v ~f:(fun a -> print_s (sexp_of a)) + ;; + + let narrow state_and_inject ~get ~set graph = + let open Let_syntax in + let state, inject = state_and_inject |> split graph in + let inject = + let peek_state = peek state graph in + let%map peek_state = peek_state + and inject = inject in + fun a -> + match%bind.Effect peek_state with + | Inactive -> Effect.Ignore + | Active state -> inject (set state a) + in + let state = + let%map state = state in + get state + in + let%map state = state + and inject = inject in + state, inject + ;; + + let narrow_via_field state_and_inject field = + narrow state_and_inject ~get:(Field.get field) ~set:(Field.fset field) + ;; +end + +module Conv = struct + let handle = handle + let top_level_handle = top_level_handle + let perform = perform + let reveal_value = Fn.id + let conceal_value = Fn.id + let isolated = isolated +end + +module Map = Map0.Make (struct + module Value = struct + type nonrec 'a t = 'a t + + let both = both + end + + module Computation = struct + type nonrec 'a t = graph -> 'a t + end + + module Incr = struct + let compute = Incr.compute + end +end) diff --git a/src/cont.mli b/src/cont.mli new file mode 100644 index 00000000..027abbb8 --- /dev/null +++ b/src/cont.mli @@ -0,0 +1,687 @@ +open! Core +open! Import + +type 'a t +type graph + +include Applicative.S with type 'a t := 'a t +include Mapn with type 'a t := 'a t + +val return : 'a -> 'a t +val map : 'a t -> f:('a -> 'b) -> 'b t +val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t +val both : 'a t -> 'b t -> ('a * 'b) t + +(** Useful for optional args that take [Bonsai.t]s. + Note: the inverse operation is not possible. *) +val transpose_opt : 'a t option -> 'a option t + +val state + : ?reset:('model -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> 'model + -> graph + -> 'model t * ('model -> unit Effect.t) t + +val state_opt + : ?reset:('model option -> 'model option) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> ?default_model:'model + -> graph + -> 'model option t * ('model option -> unit Effect.t) t + +module Apply_action_context : sig + type 'action t = 'action Apply_action_context.t + + val inject : 'action t -> 'action -> unit Effect.t + val schedule_event : _ t -> unit Effect.t -> unit +end + +module Computation_status : sig + type 'input t = + | Active of 'input + | Inactive + [@@deriving sexp_of] +end + +type ('model, 'action, 'return) resetter := + 'action Apply_action_context.t -> 'model -> 'model + +module Toggle : sig + type nonrec t = + { state : bool t + ; set_state : (bool -> unit Effect.t) t + ; toggle : unit Effect.t t + } +end + +val toggle : default_model:bool -> graph -> bool t * unit Effect.t t +val toggle' : default_model:bool -> graph -> Toggle.t + +val state_machine0 + : ?reset:('model, 'action, unit) resetter + -> ?sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action:('action Apply_action_context.t -> 'model -> 'action -> 'model) + -> graph + -> 'model t * ('action -> unit Effect.t) t + +val state_machine1 + : ?reset:('model, 'action, unit) resetter + -> ?sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action: + ('action Apply_action_context.t + -> 'input Computation_status.t + -> 'model + -> 'action + -> 'model) + -> 'input t + -> graph + -> 'model t * ('action -> unit Effect.t) t + +val actor0 + : ?reset: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> recv: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'action + -> 'model * 'return) + -> graph + -> 'model t * ('action -> 'return Effect.t) t + +val actor1 + : ?sexp_of_action:('action -> Sexp.t) + -> ?reset: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> recv: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'input Computation_status.t + -> 'model + -> 'action + -> 'model * 'return) + -> 'input t + -> graph + -> 'model t * ('action -> 'return Effect.t) t + +val freeze + : ?sexp_of_model:('a -> Sexp.t) + -> ?equal:('a -> 'a -> bool) + -> 'a t + -> graph + -> 'a t + +val fix + : 'input t + -> f:(recurse:('input t -> graph -> 'result t) -> 'input t -> graph -> 'result t) + -> graph + -> 'result t + +val fix2 + : 'a t + -> 'b t + -> f: + (recurse:('a t -> 'b t -> graph -> 'result t) + -> 'a t + -> 'b t + -> graph + -> 'result t) + -> graph + -> 'result t + +val scope_model : ('a, _) comparator -> on:'a t -> for_:(graph -> 'b t) -> graph -> 'b t + +val most_recent_some + : ?sexp_of_model:('b -> Sexp.t) + -> equal:('b -> 'b -> bool) + -> 'a t + -> f:('a -> 'b option) + -> graph + -> 'b option t + +val most_recent_value_satisfying + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a t + -> condition:('a -> bool) + -> graph + -> 'a option t + +val previous_value + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a t + -> graph + -> 'a option t + +val wrap + : ?reset:('model, 'action, unit) resetter + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action: + ('action Apply_action_context.t -> 'result -> 'model -> 'action -> 'model) + -> f:('model t -> ('action -> unit Effect.t) t -> graph -> 'result t) + -> graph + -> 'result t + +val with_model_resetter : f:(graph -> 'a t) -> graph -> 'a t * unit Effect.t t +val with_model_resetter' : f:(reset:unit Effect.t t -> graph -> 'a t) -> graph -> 'a t + +(** [peek] maps a [Bonsai.t] to an [Effect.t] with the same underlying value. + This allows you to inspect the ['a] value from inside of a [let%bind.Effect] + chain which might have been changed by previous effects. It is analogous to + [peek] on other abstract data types, including [Deferred.t]s and [Mvar.t]s, + but more constrained in that you still can only read from within an effect bind. + + The ['a Computation_state.t] returned by the effect means that if the value + was inactive at the time it is peeked, then the effect will be unable to + retrieve it. *) +val peek : 'a t -> graph -> 'a Computation_status.t Effect.t t + +module Clock : sig + val approx_now : tick_every:Time_ns.Span.t -> graph -> Time_ns.t t + val now : graph -> Time_ns.t t + + module Before_or_after : sig + type t = Ui_incr.Before_or_after.t = + | Before + | After + [@@deriving sexp, equal] + end + + val at : Time_ns.t t -> graph -> Before_or_after.t t + + val every + : when_to_start_next_effect: + [< `Wait_period_after_previous_effect_starts_blocking + | `Wait_period_after_previous_effect_finishes_blocking + | `Every_multiple_of_period_non_blocking + | `Every_multiple_of_period_blocking + ] + -> ?trigger_on_activate:bool + -> Time_ns.Span.t + -> unit Effect.t t + -> graph + -> unit + + val get_current_time : graph -> Time_ns.t Effect.t t + val sleep : graph -> (Time_ns.Span.t -> unit Effect.t) t + val until : graph -> (Time_ns.t -> unit Effect.t) t +end + +module Edge : sig + val on_change + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a t + -> callback:('a -> unit Effect.t) t + -> graph + -> unit + + val on_change' + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a t + -> callback:('a option -> 'a -> unit Effect.t) t + -> graph + -> unit + + val lifecycle + : ?on_activate:unit Effect.t t + -> ?on_deactivate:unit Effect.t t + -> ?after_display:unit Effect.t t + -> graph + -> unit + + val lifecycle' + : ?on_activate:unit Effect.t option t + -> ?on_deactivate:unit Effect.t option t + -> ?after_display:unit Effect.t option t + -> graph + -> unit + + val after_display : unit Effect.t t -> graph -> unit + val after_display' : unit Effect.t option t -> graph -> unit + val wait_after_display : graph -> unit Effect.t t + + module Poll : sig + module Starting : sig + type ('o, 'r) t + + val empty : ('o, 'o option) t + val initial : 'o -> ('o, 'o) t + end + + val effect_on_change + : ?sexp_of_input:('a -> Sexp.t) + -> ?sexp_of_result:('o -> Sexp.t) + -> equal_input:('a -> 'a -> bool) + -> ?equal_result:('o -> 'o -> bool) + -> ('o, 'r) Starting.t + -> 'a t + -> effect:('a -> 'o Effect.t) t + -> graph + -> 'r t + + val manual_refresh + : ?sexp_of_model:('o -> Sexp.t) + -> ?equal:('o -> 'o -> bool) + -> ('o, 'r) Starting.t + -> effect:'o Effect.t t + -> graph + -> 'r t * unit Effect.t t + end +end + +module Memo : sig + type 'a bonsai_t := 'a t + type ('input, 'result) t + + val create + : ('input, 'cmp) comparator + -> f:('input bonsai_t -> graph -> 'result bonsai_t) + -> graph + -> ('input, 'result) t bonsai_t + + val lookup + : ?sexp_of_model:('input -> Sexp.t) + -> equal:('input -> 'input -> bool) + -> ('input, 'result) t bonsai_t + -> 'input bonsai_t + -> graph + -> 'result option bonsai_t +end + +module Effect_throttling : sig + module Poll_result : sig + type 'a t = + | Aborted + | Finished of 'a + [@@deriving sexp, equal] + + val collapse_to_or_error : ?tag_s:Sexp.t lazy_t -> 'a Or_error.t t -> 'a Or_error.t + + val collapse_fun_to_or_error + : ?sexp_of_input:('a -> Sexp.t) + -> ('a -> 'b Or_error.t t Effect.t) + -> 'a + -> 'b Or_error.t Effect.t + end + + val poll : ('a -> 'b Effect.t) t -> graph -> ('a -> 'b Poll_result.t Effect.t) t +end + +module Dynamic_scope : sig + type 'a bonsai_t := 'a t + type 'a t + + val create : ?sexp_of:('a -> Sexp.t) -> name:string -> fallback:'a -> unit -> 'a t + + val derived + : ?sexp_of:('a -> Sexp.t) + -> 'b t + -> get:('b -> 'a) + -> set:('b -> 'a -> 'b) + -> 'a t + + val set : 'a t -> 'a bonsai_t -> inside:(graph -> 'r bonsai_t) -> graph -> 'r bonsai_t + + type revert = { revert : 'a. (graph -> 'a bonsai_t) -> graph -> 'a bonsai_t } + + val set' + : 'a t + -> 'a bonsai_t + -> f:(revert -> graph -> 'r bonsai_t) + -> graph + -> 'r bonsai_t + + val lookup : 'a t -> graph -> 'a bonsai_t + + val modify + : 'a t + -> change:('a bonsai_t -> 'a bonsai_t) + -> f:(revert -> graph -> 'r bonsai_t) + -> graph + -> 'r bonsai_t +end + +module Incr : sig + val value_cutoff : 'a t -> equal:('a -> 'a -> bool) -> graph -> 'a t + val compute : 'a t -> f:('a Incr.t -> 'b Incr.t) -> graph -> 'b t + val to_value : 'a Incr.t -> 'a t + val with_clock : f:(Time_source.t -> 'a Incr.t) -> graph -> 'a t +end + +val assoc + : ('k, 'cmp) comparator + -> ('k, 'v, 'cmp) Map.t t + -> f:('k t -> 'v t -> graph -> 'a t) + -> graph + -> ('k, 'a, 'cmp) Map.t t + +val assoc_set + : ('key, 'cmp) comparator + -> ('key, 'cmp) Set.t t + -> f:('key t -> graph -> 'result t) + -> graph + -> ('key, 'result, 'cmp) Map.t t + +val assoc_list + : ('key, _) comparator + -> 'a list t + -> get_key:('a -> 'key) + -> f:('key t -> 'a t -> graph -> 'b t) + -> graph + -> [ `Duplicate_key of 'key | `Ok of 'b list ] t + +module Time_source = Time_source + +module Debug : sig + val on_change : 'a t -> f:('a -> unit) -> graph -> unit + val on_change_print_s : 'a t -> ('a -> Sexp.t) -> graph -> unit + + val instrument_computation + : (graph -> 'a t) + -> start_timer:(string -> unit) + -> stop_timer:(string -> unit) + -> graph + -> 'a t + + val to_dot : ?pre_process:bool -> (graph -> 'a t) -> string + val enable_incremental_annotations : unit -> unit + val disable_incremental_annotations : unit -> unit +end + +module Path : sig + type t = Path.t [@@deriving compare, sexp_of] + + include Comparable.S_plain with type t := t + + (** Converts the path to a "unique" string that contains only + lowercase letters and underscores. This makes it viable for e.g. HTML ids. + + The uniqueness of this string depends on the uniqueness of the sexp + function for any modules that are being used in "assoc". The + invariant that must be upheld by those modules is the following: + + [a != b] implies [sexp_of a != sexp_of b] *) + val to_unique_identifier_string : t -> string +end + +val path_id : graph -> string t +val path : graph -> Path.t t +val arr1 : graph -> 'a t -> f:('a -> 'b) -> 'b t +val arr2 : graph -> 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t + +module Conv : sig + val handle : f:(graph -> 'a t) -> graph -> 'a Computation.t + val top_level_handle : (graph -> 'a t) -> 'a Computation.t + val perform : ?here:Source_code_position.t -> graph -> 'a Computation.t -> 'a t + val reveal_value : 'a t -> 'a Value.t + val conceal_value : 'a Value.t -> 'a t + val isolated : graph -> f:(unit -> 'a Value.t) -> 'a Computation.t +end + +module Let_syntax : sig + val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t + val return : 'a -> 'a t + + module Let_syntax : sig + val map : ?here:Source_code_position.t -> 'a t -> f:('a -> 'b) -> 'b t + val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t + val both : 'a t -> 'b t -> ('a * 'b) t + val arr : ?here:Source_code_position.t -> 'a t -> f:('a -> 'b) -> 'b t + val return : 'a t -> 'a t + val cutoff : 'a t -> equal:('a -> 'a -> bool) -> 'a t + + val switch + : here:Source_code_position.t + -> match_:int t + -> branches:int + -> with_:(int -> 'a t) + -> 'a t + + val sub : ?here:_ -> 'a -> f:('a -> 'b) -> 'b + + include Mapn with type 'a t := 'a t + end +end + +module Map : + Map0_intf.Output + with type 'a Value.t := 'a t + and type 'a Computation.t := graph -> 'a t + and module Value := Value + and module Computation := Computation + +module Expert : sig + val thunk : f:(unit -> 'a) -> graph -> 'a t + + val assoc_on + : ('io_key, 'io_cmp) comparator + -> ('model_key, 'model_cmp) comparator + -> ('io_key, 'data, 'io_cmp) Core.Map.t t + -> get_model_key:('io_key -> 'data -> 'model_key) + -> f:('io_key t -> 'data t -> graph -> 'result t) + -> graph + -> ('io_key, 'result, 'io_cmp) Core.Map.t t + + val delay : f:(graph -> 'a t) -> graph -> 'a t + [@@deprecated "[since 2023-07] Use Bonsai.fix "] +end + +(** Just in subfeature to reimplement proc on top of cont *) +module For_proc2 : sig + val arr1_with_location + : ?here:Source_code_position.t + -> graph + -> 'a t + -> f:('a -> 'b) + -> 'b t + + val value_cutoff : 'a t -> equal:('a -> 'a -> bool) -> 'a t + val conceal_value : 'a Value.t -> 'a t + + val state + : ?reset:('model -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> 'model + -> graph + -> ('model * ('model -> unit Effect.t)) t + + val state_opt + : ?reset:('model option -> 'model option) + -> ?default_model:'model + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> unit + -> graph + -> ('model option * ('model option -> unit Effect.t)) t + + val toggle : default_model:bool -> graph -> (bool * unit Effect.t) t + + module Toggle : sig + type t = + { state : bool + ; set_state : bool -> unit Effect.t + ; toggle : unit Effect.t + } + end + + val toggle' : default_model:bool -> graph -> Toggle.t t + + val state_machine0 + : ?reset:('model, 'action, unit) resetter + -> ?sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action:('action Apply_action_context.t -> 'model -> 'action -> 'model) + -> unit + -> graph + -> ('model * ('action -> unit Effect.t)) t + + val state_machine1 + : ?sexp_of_action:('action -> Sexp.t) + -> ?reset:('model, 'action, unit) resetter + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action: + ('action Apply_action_context.t + -> 'input Computation_status.t + -> 'model + -> 'action + -> 'model) + -> 'input t + -> graph + -> ('model * ('action -> unit Effect.t)) t + + val actor0 + : ?reset: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> recv: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'action + -> 'model * 'return) + -> unit + -> graph + -> ('model * ('action -> 'return Effect.t)) t + + val actor1 + : ?sexp_of_action:('action -> Sexp.t) + -> ?reset: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'model) + (** to learn more about [reset], read the docs on [with_model_resetter] *) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> recv: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'input Computation_status.t + -> 'model + -> 'action + -> 'model * 'return) + -> 'input t + -> graph + -> ('model * ('action -> 'return Effect.t)) t + + val wrap + : ?reset:('action Apply_action_context.t -> 'model -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action: + ('action Apply_action_context.t -> 'result -> 'model -> 'action -> 'model) + -> f:('model t -> ('action -> unit Effect.t) t -> graph -> 'result t) + -> unit + -> graph + -> 'result t + + val switch + : match_:int t + -> branches:int + -> with_:(int -> graph -> 'a t) + -> graph + -> 'a t + + val with_model_resetter : (graph -> 'a t) -> graph -> ('a * unit Effect.t) t + val with_model_resetter' : (reset:unit Effect.t t -> graph -> 'a t) -> graph -> 'a t + + val on_change + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a t + -> callback:('a -> unit Effect.t) t + -> graph + -> unit t + + val on_change' + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a t + -> callback:('a option -> 'a -> unit Effect.t) t + -> graph + -> unit t + + val lifecycle + : ?on_activate:unit Effect.t t + -> ?on_deactivate:unit Effect.t t + -> ?after_display:unit Effect.t t + -> unit + -> graph + -> unit t + + val lifecycle' + : ?on_activate:unit Effect.t option t + -> ?on_deactivate:unit Effect.t option t + -> ?after_display:unit Effect.t option t + -> unit + -> graph + -> unit t + + val after_display : unit Effect.t t -> graph -> unit t + val after_display' : unit Effect.t option t -> graph -> unit t + + val manual_refresh + : ?sexp_of_model:('o -> Sexp.t) + -> ?equal:('o -> 'o -> bool) + -> ('o, 'r) Edge.Poll.Starting.t + -> effect:'o Effect.t t + -> graph + -> ('r * unit Effect.t) t + + val debug_on_change : 'a t -> f:('a -> unit) -> graph -> unit t + val debug_on_change_print_s : 'a t -> ('a -> Sexp.t) -> graph -> unit t + val lazy_ : (graph -> 'a t) lazy_t -> graph -> 'a t + + val narrow + : ('a * ('b -> unit Effect.t)) t + -> get:('a -> 'c) + -> set:('a -> 'd -> 'b) + -> graph + -> ('c * ('d -> unit Effect.t)) t + + val narrow_via_field + : ('a * ('a -> unit Effect.t)) t + -> ('a, 'b) Field.t + -> graph + -> ('b * ('b -> unit Effect.t)) t +end diff --git a/src/driver/bonsai_driver.ml b/src/driver/bonsai_driver.ml index d93d094c..fbb3232f 100644 --- a/src/driver/bonsai_driver.ml +++ b/src/driver/bonsai_driver.ml @@ -41,13 +41,16 @@ let assert_type_equalities () ;; -let create (type r) ?(optimize = true) ~clock (computation : r Bonsai.Computation.t) : r t +let create_direct + (type r) + ?(optimize = true) + ~clock + (computation : r Bonsai.Private.Computation.t) + : r t = - let unoptimized_info = - Bonsai.Private.gather (Bonsai.Private.reveal_computation computation) - in + let unoptimized_info = Bonsai.Private.gather computation in let optimized_info = - Bonsai.Private.reveal_computation computation + computation |> (if optimize then Bonsai.Private.pre_process else Fn.id) |> Bonsai.Private.gather in @@ -129,6 +132,10 @@ let create (type r) ?(optimize = true) ~clock (computation : r Bonsai.Computatio create_polymorphic computation_info apply_action ;; +let create (type r) ?(optimize = true) ~clock (computation : r Bonsai.Computation.t) = + create_direct ~optimize ~clock (Bonsai.Private.top_level_handle computation) +;; + let schedule_event _ = Ui_effect.Expert.handle let flush diff --git a/src/driver/dune b/src/driver/dune index 512fe3d9..e25928ec 100644 --- a/src/driver/dune +++ b/src/driver/dune @@ -1,2 +1,6 @@ -(library (name bonsai_driver) (public_name bonsai.driver) - (libraries bonsai core incr_map) (preprocess (pps ppx_jane))) \ No newline at end of file +(library + (name bonsai_driver) + (public_name bonsai.driver) + (libraries bonsai core incr_map) + (preprocess + (pps ppx_jane))) diff --git a/src/dune b/src/dune index 11c4dd5c..50871a44 100644 --- a/src/dune +++ b/src/dune @@ -1,5 +1,7 @@ -(library (name bonsai) +(library + (name bonsai) (libraries core core_kernel.reversed_list virtual_dom.ui_effect - incr_dom.ui_incr incr_dom.ui_time_source) - (preprocess (pps ppx_jane ppx_pattern_bind ppx_bonsai ppxlib.traverse)) - (public_name bonsai)) \ No newline at end of file + incr_dom.ui_incr incr_dom.ui_time_source) + (preprocess + (pps ppx_jane ppx_pattern_bind ppx_bonsai ppxlib.traverse)) + (public_name bonsai)) diff --git a/src/legacy_api.ml b/src/legacy_api.ml index 699a0bee..83ca49f5 100644 --- a/src/legacy_api.ml +++ b/src/legacy_api.ml @@ -1,5 +1,6 @@ open! Core open! Import +module Proc = Proc_layer2 module type S = Module_types.Component_s @@ -145,7 +146,9 @@ include struct end module With_incr = struct - let of_incr i _ = Proc.read (Proc.Private.conceal_value (Value.of_incr i)) + let of_incr i _ = Proc.read (Cont.Conv.conceal_value (Value.of_incr i)) + + open Proc.Let_syntax let of_module (type i m a r) @@ -156,9 +159,36 @@ module With_incr = struct input : r Proc.Computation.t = - let input = Proc.Private.reveal_value input in let (module M) = component in - Proc_min.Proc_incr.of_module (module M) ?sexp_of_model ~equal ~default_model input + let%sub state = + Proc.state_machine1 + ~sexp_of_action:M.Action.sexp_of_t + ?sexp_of_model + ~equal + ~default_model + ~apply_action:(fun ctx input model action -> + match input with + | Active input -> + M.apply_action + input + ~inject:(Proc.Apply_action_context.inject ctx) + ~schedule_event:(Proc.Apply_action_context.schedule_event ctx) + model + action + | Inactive -> + eprint_s + [%message + [%here] + "An action sent to an [of_module] has been dropped because its input \ + was not present. This happens when the [of_module] is inactive when \ + it receives a message." + (action : M.Action.t)]; + model) + input + in + Proc.Incr.compute (Cont.both input state) ~f:(fun input_and_state -> + let%pattern_bind.Ui_incr input, (model, inject) = input_and_state in + M.compute input model ~inject) ;; let pure ~f = Proc.Incr.compute ~f diff --git a/src/legacy_api.mli b/src/legacy_api.mli index e6de43f4..6ecb4555 100644 --- a/src/legacy_api.mli +++ b/src/legacy_api.mli @@ -3,4 +3,4 @@ open! Import include Legacy_api_intf.S - with type ('input, 'result) t = 'input Proc.Value.t -> 'result Proc.Computation.t + with type ('input, 'result) t = 'input Cont.t -> Cont.graph -> 'result Cont.t diff --git a/src/map0.ml b/src/map0.ml index fa4dd781..ab4557e3 100644 --- a/src/map0.ml +++ b/src/map0.ml @@ -1,203 +1,230 @@ open! Core open! Import -module Incr = Incr0 - -let map m ~f = Incr.compute m ~f:(Incr_map.map ~f) -let mapi m ~f = Incr.compute m ~f:(Incr_map.mapi ~f) -let of_set = Incr.compute ~f:Incr_map.of_set -let filter_mapi m ~f = Incr.compute m ~f:(Incr_map.filter_mapi ~f) -let filter_map m ~f = Incr.compute m ~f:(Incr_map.filter_map ~f) -let partition_mapi m ~f = Incr.compute m ~f:(Incr_map.partition_mapi ~f) - -let unordered_fold ?update m ~init ~add ~remove = - Incr.compute m ~f:(Incr_map.unordered_fold ?update ~init ~add ~remove) -;; - -let unordered_fold_with_extra ?update m e ~init ~add ~remove ~extra_changed = - Incr.compute (Value.both m e) ~f:(fun m_and_e -> - let%pattern_bind.Ui_incr m, e = m_and_e in - Incr_map.unordered_fold_with_extra ?update m e ~init ~add ~remove ~extra_changed) -;; - -let cutoff m ~equal = - Incr.compute m ~f:(Incr_map.cutoff ~cutoff:(Ui_incr.Cutoff.of_equal equal)) -;; - -let mapi_count - (type k cmp) - m - ~comparator:((module M) : (k, cmp) Module_types.comparator) - ~f - = - Incr.compute m ~f:(Incr_map.mapi_count ~comparator:(module M) ~f) -;; - -let map_count - (type k cmp) - m - ~comparator:((module M) : (k, cmp) Module_types.comparator) - ~f - = - Incr.compute m ~f:(Incr_map.map_count ~comparator:(module M) ~f) -;; - -let mapi_min (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) ~f - = - Incr.compute m ~f:(Incr_map.mapi_min ~comparator:(module M) ~f) -;; - -let mapi_max (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) ~f - = - Incr.compute m ~f:(Incr_map.mapi_max ~comparator:(module M) ~f) -;; - -let map_min (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) ~f = - Incr.compute m ~f:(Incr_map.map_min ~comparator:(module M) ~f) -;; - -let map_max (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) ~f = - Incr.compute m ~f:(Incr_map.map_max ~comparator:(module M) ~f) -;; - -let min_value (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) = - Incr.compute m ~f:(Incr_map.min_value ~comparator:(module M)) -;; - -let max_value (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) = - Incr.compute m ~f:(Incr_map.max_value ~comparator:(module M)) -;; - -let mapi_bounds - (type k cmp) - m - ~comparator:((module M) : (k, cmp) Module_types.comparator) - ~f - = - Incr.compute m ~f:(Incr_map.mapi_bounds ~comparator:(module M) ~f) -;; - -let map_bounds - (type k cmp) - m - ~comparator:((module M) : (k, cmp) Module_types.comparator) - ~f - = - Incr.compute m ~f:(Incr_map.map_bounds ~comparator:(module M) ~f) -;; - -let value_bounds - (type k cmp) - m - ~comparator:((module M) : (k, cmp) Module_types.comparator) - = - Incr.compute m ~f:(Incr_map.value_bounds ~comparator:(module M)) -;; - -let merge a b ~f = - Incr.compute (Value.both a b) ~f:(fun a_and_b -> - let%pattern_bind.Ui_incr a, b = a_and_b in - Incr_map.merge a b ~f) -;; - -let merge_both_some a b ~f = - Incr.compute (Value.both a b) ~f:(fun a_and_b -> - let%pattern_bind.Ui_incr a, b = a_and_b in - Incr_map.merge_both_some a b ~f) -;; - -let unzip m = - Incr.compute m ~f:(fun m -> - let l, r = Incr_map.unzip m in - Ui_incr.both l r) -;; - -let unzip_mapi m ~f = - Incr.compute m ~f:(fun m -> - let l, r = Incr_map.unzip_mapi m ~f in - Ui_incr.both l r) -;; - -let keys = Incr.compute ~f:Incr_map.keys - -let rank m k = - Incr.compute (Value.both m k) ~f:(fun m_and_k -> - let%pattern_bind.Ui_incr m, k = m_and_k in - Incr_map.rank m k) -;; - -let subrange m bounds = - Incr.compute (Value.both m bounds) ~f:(fun m_and_bounds -> - let%pattern_bind.Ui_incr m, bounds = m_and_bounds in - Incr_map.subrange m bounds) -;; - -let subrange_by_rank m bounds = - Incr.compute (Value.both m bounds) ~f:(fun m_and_bounds -> - let%pattern_bind.Ui_incr m, bounds = m_and_bounds in - Incr_map.subrange_by_rank m bounds) -;; - -let rekey (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) ~f = - Incr.compute m ~f:(Incr_map.rekey ~comparator:(module M) ~f) -;; - -let index_byi - (type k cmp) - m - ~comparator:((module M) : (k, cmp) Module_types.comparator) - ~index - = - Incr.compute m ~f:(Incr_map.index_byi ~comparator:(module M) ~index) -;; - -let index_by - (type k cmp) - m - ~comparator:((module M) : (k, cmp) Module_types.comparator) - ~index - = - Incr.compute m ~f:(Incr_map.index_by ~comparator:(module M) ~index) -;; - -let unordered_fold_nested_maps ?update m ~init ~add ~remove = - Incr.compute m ~f:(Incr_map.unordered_fold_nested_maps ?update ~init ~add ~remove) -;; - -let transpose (type k cmp) ((module M) : (k, cmp) Module_types.comparator) m = - Incr.compute m ~f:(Incr_map.transpose (module M)) -;; - -let collapse (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) = - Incr.compute m ~f:(Incr_map.collapse ~comparator:(module M)) -;; - -let collapse_by - (type k cmp) - m - ~merge_keys - ~comparator:((module M) : (k, cmp) Module_types.comparator) - = - Incr.compute m ~f:(Incr_map.collapse_by ~comparator:(module M) ~merge_keys) -;; - -let expand - (type k k2 cmp cmp2) - m - ~outer_comparator:((module M_outer) : (k, cmp) Module_types.comparator) - ~inner_comparator:((module M_inner) : (k2, cmp2) Module_types.comparator) - = - Incr.compute +include Map0_intf + +module Make (Input : Input) : sig + include + Output with module Value := Input.Value and module Computation := Input.Computation +end = struct + open Input + + let map m ~f = Incr.compute m ~f:(Incr_map.map ~f) + let mapi m ~f = Incr.compute m ~f:(Incr_map.mapi ~f) + let of_set = Incr.compute ~f:Incr_map.of_set + let filter_mapi m ~f = Incr.compute m ~f:(Incr_map.filter_mapi ~f) + let filter_map m ~f = Incr.compute m ~f:(Incr_map.filter_map ~f) + let partition_mapi m ~f = Incr.compute m ~f:(Incr_map.partition_mapi ~f) + + let unordered_fold ?update m ~init ~add ~remove = + Incr.compute m ~f:(Incr_map.unordered_fold ?update ~init ~add ~remove) + ;; + + let unordered_fold_with_extra ?update m e ~init ~add ~remove ~extra_changed = + Incr.compute (Value.both m e) ~f:(fun m_and_e -> + let%pattern_bind.Ui_incr m, e = m_and_e in + Incr_map.unordered_fold_with_extra ?update m e ~init ~add ~remove ~extra_changed) + ;; + + let cutoff m ~equal = + Incr.compute m ~f:(Incr_map.cutoff ~cutoff:(Ui_incr.Cutoff.of_equal equal)) + ;; + + let mapi_count + (type k cmp) m - ~f: - (Incr_map.expand - ~inner_comparator:(module M_inner) - ~outer_comparator:(module M_outer)) -;; - -let counti m ~f = Incr.compute m ~f:(Incr_map.counti ~f) -let count m ~f = Incr.compute m ~f:(Incr_map.count ~f) -let for_alli m ~f = Incr.compute m ~f:(Incr_map.for_alli ~f) -let for_all m ~f = Incr.compute m ~f:(Incr_map.for_all ~f) -let existsi m ~f = Incr.compute m ~f:(Incr_map.existsi ~f) -let exists m ~f = Incr.compute m ~f:(Incr_map.exists ~f) -let sum m algebra ~f = Incr.compute m ~f:(fun m -> Incr_map.sum m algebra ~f) + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.mapi_count ~comparator:(module M) ~f) + ;; + + let map_count + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.map_count ~comparator:(module M) ~f) + ;; + + let mapi_min + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.mapi_min ~comparator:(module M) ~f) + ;; + + let mapi_max + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.mapi_max ~comparator:(module M) ~f) + ;; + + let map_min + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.map_min ~comparator:(module M) ~f) + ;; + + let map_max + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.map_max ~comparator:(module M) ~f) + ;; + + let min_value (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) + = + Incr.compute m ~f:(Incr_map.min_value ~comparator:(module M)) + ;; + + let max_value (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) + = + Incr.compute m ~f:(Incr_map.max_value ~comparator:(module M)) + ;; + + let mapi_bounds + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.mapi_bounds ~comparator:(module M) ~f) + ;; + + let map_bounds + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~f + = + Incr.compute m ~f:(Incr_map.map_bounds ~comparator:(module M) ~f) + ;; + + let value_bounds + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + = + Incr.compute m ~f:(Incr_map.value_bounds ~comparator:(module M)) + ;; + + let merge a b ~f = + Incr.compute (Value.both a b) ~f:(fun a_and_b -> + let%pattern_bind.Ui_incr a, b = a_and_b in + Incr_map.merge a b ~f) + ;; + + let merge_both_some a b ~f = + Incr.compute (Value.both a b) ~f:(fun a_and_b -> + let%pattern_bind.Ui_incr a, b = a_and_b in + Incr_map.merge_both_some a b ~f) + ;; + + let unzip m = + Incr.compute m ~f:(fun m -> + let l, r = Incr_map.unzip m in + Ui_incr.both l r) + ;; + + let unzip_mapi m ~f = + Incr.compute m ~f:(fun m -> + let l, r = Incr_map.unzip_mapi m ~f in + Ui_incr.both l r) + ;; + + let keys = Incr.compute ~f:Incr_map.keys + + let rank m k = + Incr.compute (Value.both m k) ~f:(fun m_and_k -> + let%pattern_bind.Ui_incr m, k = m_and_k in + Incr_map.rank m k) + ;; + + let subrange m bounds = + Incr.compute (Value.both m bounds) ~f:(fun m_and_bounds -> + let%pattern_bind.Ui_incr m, bounds = m_and_bounds in + Incr_map.subrange m bounds) + ;; + + let subrange_by_rank m bounds = + Incr.compute (Value.both m bounds) ~f:(fun m_and_bounds -> + let%pattern_bind.Ui_incr m, bounds = m_and_bounds in + Incr_map.subrange_by_rank m bounds) + ;; + + let rekey (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) ~f = + Incr.compute m ~f:(Incr_map.rekey ~comparator:(module M) ~f) + ;; + + let index_byi + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~index + = + Incr.compute m ~f:(Incr_map.index_byi ~comparator:(module M) ~index) + ;; + + let index_by + (type k cmp) + m + ~comparator:((module M) : (k, cmp) Module_types.comparator) + ~index + = + Incr.compute m ~f:(Incr_map.index_by ~comparator:(module M) ~index) + ;; + + let unordered_fold_nested_maps ?update m ~init ~add ~remove = + Incr.compute m ~f:(Incr_map.unordered_fold_nested_maps ?update ~init ~add ~remove) + ;; + + let transpose (type k cmp) ((module M) : (k, cmp) Module_types.comparator) m = + Incr.compute m ~f:(Incr_map.transpose (module M)) + ;; + + let collapse (type k cmp) m ~comparator:((module M) : (k, cmp) Module_types.comparator) = + Incr.compute m ~f:(Incr_map.collapse ~comparator:(module M)) + ;; + + let collapse_by + (type k cmp) + m + ~merge_keys + ~comparator:((module M) : (k, cmp) Module_types.comparator) + = + Incr.compute m ~f:(Incr_map.collapse_by ~comparator:(module M) ~merge_keys) + ;; + + let expand + (type k k2 cmp cmp2) + m + ~outer_comparator:((module M_outer) : (k, cmp) Module_types.comparator) + ~inner_comparator:((module M_inner) : (k2, cmp2) Module_types.comparator) + = + Incr.compute + m + ~f: + (Incr_map.expand + ~inner_comparator:(module M_inner) + ~outer_comparator:(module M_outer)) + ;; + + let counti m ~f = Incr.compute m ~f:(Incr_map.counti ~f) + let count m ~f = Incr.compute m ~f:(Incr_map.count ~f) + let for_alli m ~f = Incr.compute m ~f:(Incr_map.for_alli ~f) + let for_all m ~f = Incr.compute m ~f:(Incr_map.for_all ~f) + let existsi m ~f = Incr.compute m ~f:(Incr_map.existsi ~f) + let exists m ~f = Incr.compute m ~f:(Incr_map.exists ~f) + let sum m algebra ~f = Incr.compute m ~f:(fun m -> Incr_map.sum m algebra ~f) +end diff --git a/src/map0.mli b/src/map0.mli index 7fa359c8..d40379b7 100644 --- a/src/map0.mli +++ b/src/map0.mli @@ -1,235 +1,3 @@ open! Core open! Import - -val mapi - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v1 -> 'v2) - -> ('k, 'v2, 'cmp) Map.t Computation.t - -val map - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:('v1 -> 'v2) - -> ('k, 'v2, 'cmp) Map.t Computation.t - -val of_set : ('k, 'cmp) Set.t Value.t -> ('k, unit, 'cmp) Map.t Computation.t - -val filter_mapi - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v1 -> 'v2 option) - -> ('k, 'v2, 'cmp) Map.t Computation.t - -val filter_map - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:('v1 -> 'v2 option) - -> ('k, 'v2, 'cmp) Map.t Computation.t - -val partition_mapi - : ('k, 'v1, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v1 -> ('v2, 'v3) Either.t) - -> (('k, 'v2, 'cmp) Map.t * ('k, 'v3, 'cmp) Map.t) Computation.t - -val unordered_fold - : ?update:(key:'k -> old_data:'v -> new_data:'v -> 'acc -> 'acc) - -> ('k, 'v, 'cmp) Map.t Value.t - -> init:'acc - -> add:(key:'k -> data:'v -> 'acc -> 'acc) - -> remove:(key:'k -> data:'v -> 'acc -> 'acc) - -> 'acc Computation.t - -val unordered_fold_with_extra - : ?update:(key:'k -> old_data:'v -> new_data:'v -> 'acc -> 'extra -> 'acc) - -> ('k, 'v, 'e) Map.t Value.t - -> 'extra Value.t - -> init:'acc - -> add:(key:'k -> data:'v -> 'acc -> 'extra -> 'acc) - -> remove:(key:'k -> data:'v -> 'acc -> 'extra -> 'acc) - -> extra_changed: - (old_extra:'extra -> new_extra:'extra -> input:('k, 'v, 'e) Map.t -> 'acc -> 'acc) - -> 'acc Computation.t - -val cutoff - : ('k, 'v, 'cmp) Map.t Value.t - -> equal:('v -> 'v -> bool) - -> ('k, 'v, 'cmp) Map.t Computation.t - -val mapi_count - : ('k1, 'v, 'cmp1) Map.t Value.t - -> comparator:('k2, 'cmp2) Module_types.comparator - -> f:(key:'k1 -> data:'v -> 'k2) - -> ('k2, int, 'cmp2) Map.t Computation.t - -val map_count - : ('k1, 'v, 'cmp1) Map.t Value.t - -> comparator:('k2, 'cmp2) Module_types.comparator - -> f:('v -> 'k2) - -> ('k2, int, 'cmp2) Map.t Computation.t - -val mapi_min - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) Module_types.comparator - -> f:(key:'k -> data:'v -> 'r) - -> 'r option Computation.t - -val mapi_max - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) Module_types.comparator - -> f:(key:'k -> data:'v -> 'r) - -> 'r option Computation.t - -val map_min - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) Module_types.comparator - -> f:('v -> 'r) - -> 'r option Computation.t - -val map_max - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) Module_types.comparator - -> f:('v -> 'r) - -> 'r option Computation.t - -val min_value - : ('k, 'v, _) Map.t Value.t - -> comparator:('v, _) Module_types.comparator - -> 'v option Computation.t - -val max_value - : ('k, 'v, _) Map.t Value.t - -> comparator:('v, _) Module_types.comparator - -> 'v option Computation.t - -val mapi_bounds - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) Module_types.comparator - -> f:(key:'k -> data:'v -> 'r) - -> ('r * 'r) option Computation.t - -val map_bounds - : ('k, 'v, _) Map.t Value.t - -> comparator:('r, _) Module_types.comparator - -> f:('v -> 'r) - -> ('r * 'r) option Computation.t - -val value_bounds - : ('k, 'v, _) Map.t Value.t - -> comparator:('v, _) Module_types.comparator - -> ('v * 'v) option Computation.t - -val merge - : ('k, 'v1, 'cmp) Map.t Value.t - -> ('k, 'v2, 'cmp) Map.t Value.t - -> f:(key:'k -> ('v1, 'v2) Map.Merge_element.t -> 'v3 option) - -> ('k, 'v3, 'cmp) Map.t Computation.t - -val merge_both_some - : ('k, 'v1, 'cmp) Map.t Value.t - -> ('k, 'v2, 'cmp) Map.t Value.t - -> f:(key:'k -> 'v1 -> 'v2 -> 'v3) - -> ('k, 'v3, 'cmp) Map.t Computation.t - -val unzip - : ('k, 'a * 'b, 'cmp) Map.t Value.t - -> (('k, 'a, 'cmp) Map.t * ('k, 'b, 'cmp) Map.t) Computation.t - -val unzip_mapi - : ('k, 'v, 'cmp) Map.t Value.t - -> f:(key:'k -> data:'v -> 'v1 * 'v2) - -> (('k, 'v1, 'cmp) Map.t * ('k, 'v2, 'cmp) Map.t) Computation.t - -val keys : ('k, 'v, 'c) Map.t Value.t -> ('k, 'c) Set.t Computation.t -val rank : ('k, 'v, 'cmp) Map.t Value.t -> 'k Value.t -> int option Computation.t - -val subrange - : ('k, 'v, 'cmp) Map.t Value.t - -> ('k Maybe_bound.As_lower_bound.t * 'k Maybe_bound.As_upper_bound.t) option Value.t - -> ('k, 'v, 'cmp) Map.t Computation.t - -val subrange_by_rank - : ('k, 'v, 'cmp) Map.t Value.t - -> (int Maybe_bound.As_lower_bound.t * int Maybe_bound.As_upper_bound.t) Value.t - -> ('k, 'v, 'cmp) Map.t Computation.t - -val rekey - : ('k1, 'v, 'cmp1) Map.t Value.t - -> comparator:('k2, 'cmp2) Module_types.comparator - -> f:(key:'k1 -> data:'v -> 'k2) - -> ('k2, 'v, 'cmp2) Map.t Computation.t - -val index_byi - : ('inner_key, 'v, 'inner_cmp) Map.t Value.t - -> comparator:('outer_key, 'outer_cmp) Module_types.comparator - -> index:(key:'inner_key -> data:'v -> 'outer_key option) - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t - -val index_by - : ('inner_key, 'v, 'inner_cmp) Map.t Value.t - -> comparator:('outer_key, 'outer_cmp) Module_types.comparator - -> index:('v -> 'outer_key option) - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t - -val unordered_fold_nested_maps - : ?update: - (outer_key:'outer_key - -> inner_key:'inner_key - -> old_data:'v - -> new_data:'v - -> 'acc - -> 'acc) - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t - -> init:'acc - -> add:(outer_key:'outer_key -> inner_key:'inner_key -> data:'v -> 'acc -> 'acc) - -> remove:(outer_key:'outer_key -> inner_key:'inner_key -> data:'v -> 'acc -> 'acc) - -> 'acc Computation.t - -val transpose - : ('k2, 'k2_cmp) Module_types.comparator - -> ('k1, ('k2, 'v, 'k2_cmp) Map.t, 'k1_cmp) Map.t Value.t - -> ('k2, ('k1, 'v, 'k1_cmp) Map.t, 'k2_cmp) Map.t Computation.t - -val collapse - : ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t - -> comparator:('inner_key, 'inner_cmp) Module_types.comparator - -> ( 'outer_key * 'inner_key - , 'v - , ('outer_cmp, 'inner_cmp) Tuple2.comparator_witness ) - Map.t - Computation.t - -val collapse_by - : ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t - -> merge_keys:('outer_key -> 'inner_key -> 'combined_key) - -> comparator:('combined_key, 'combined_cmp) Module_types.comparator - -> ('combined_key, 'v, 'combined_cmp) Map.t Computation.t - -val expand - : ('outer_key * 'inner_key, 'v, 'tuple_cmp) Map.t Value.t - -> outer_comparator:('outer_key, 'outer_cmp) Module_types.comparator - -> inner_comparator:('inner_key, 'inner_cmp) Module_types.comparator - -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t - -val counti - : ('k, 'v, _) Map.t Value.t - -> f:(key:'k -> data:'v -> bool) - -> int Computation.t - -val count : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> int Computation.t - -val for_alli - : ('k, 'v, _) Map.t Value.t - -> f:(key:'k -> data:'v -> bool) - -> bool Computation.t - -val for_all : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> bool Computation.t - -val existsi - : ('k, 'v, _) Map.t Value.t - -> f:(key:'k -> data:'v -> bool) - -> bool Computation.t - -val exists : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> bool Computation.t - -val sum - : (_, 'v, _) Map.t Value.t - -> (module Abstract_algebra.Commutative_group.Without_sexp with type t = 'u) - -> f:('v -> 'u) - -> 'u Computation.t +include Map0_intf.Map0.S diff --git a/src/map0_intf.ml b/src/map0_intf.ml new file mode 100644 index 00000000..05817aa3 --- /dev/null +++ b/src/map0_intf.ml @@ -0,0 +1,276 @@ +open! Core +open! Import + +module type Input = sig + module Value : sig + type 'a t + + val both : 'a t -> 'b t -> ('a * 'b) t + end + + module Computation : sig + type 'a t + end + + module Incr : sig + val compute : 'a Value.t -> f:('a Incr.t -> 'b Incr.t) -> 'b Computation.t + end +end + +module type Output = sig + module Value : sig + type 'a t + end + + module Computation : sig + type 'a t + end + + val mapi + : ('k, 'v1, 'cmp) Map.t Value.t + -> f:(key:'k -> data:'v1 -> 'v2) + -> ('k, 'v2, 'cmp) Map.t Computation.t + + val map + : ('k, 'v1, 'cmp) Map.t Value.t + -> f:('v1 -> 'v2) + -> ('k, 'v2, 'cmp) Map.t Computation.t + + val of_set : ('k, 'cmp) Set.t Value.t -> ('k, unit, 'cmp) Map.t Computation.t + + val filter_mapi + : ('k, 'v1, 'cmp) Map.t Value.t + -> f:(key:'k -> data:'v1 -> 'v2 option) + -> ('k, 'v2, 'cmp) Map.t Computation.t + + val filter_map + : ('k, 'v1, 'cmp) Map.t Value.t + -> f:('v1 -> 'v2 option) + -> ('k, 'v2, 'cmp) Map.t Computation.t + + val partition_mapi + : ('k, 'v1, 'cmp) Map.t Value.t + -> f:(key:'k -> data:'v1 -> ('v2, 'v3) Either.t) + -> (('k, 'v2, 'cmp) Map.t * ('k, 'v3, 'cmp) Map.t) Computation.t + + val unordered_fold + : ?update:(key:'k -> old_data:'v -> new_data:'v -> 'acc -> 'acc) + -> ('k, 'v, 'cmp) Map.t Value.t + -> init:'acc + -> add:(key:'k -> data:'v -> 'acc -> 'acc) + -> remove:(key:'k -> data:'v -> 'acc -> 'acc) + -> 'acc Computation.t + + val unordered_fold_with_extra + : ?update:(key:'k -> old_data:'v -> new_data:'v -> 'acc -> 'extra -> 'acc) + -> ('k, 'v, 'e) Map.t Value.t + -> 'extra Value.t + -> init:'acc + -> add:(key:'k -> data:'v -> 'acc -> 'extra -> 'acc) + -> remove:(key:'k -> data:'v -> 'acc -> 'extra -> 'acc) + -> extra_changed: + (old_extra:'extra + -> new_extra:'extra + -> input:('k, 'v, 'e) Map.t + -> 'acc + -> 'acc) + -> 'acc Computation.t + + val cutoff + : ('k, 'v, 'cmp) Map.t Value.t + -> equal:('v -> 'v -> bool) + -> ('k, 'v, 'cmp) Map.t Computation.t + + val mapi_count + : ('k1, 'v, 'cmp1) Map.t Value.t + -> comparator:('k2, 'cmp2) Module_types.comparator + -> f:(key:'k1 -> data:'v -> 'k2) + -> ('k2, int, 'cmp2) Map.t Computation.t + + val map_count + : ('k1, 'v, 'cmp1) Map.t Value.t + -> comparator:('k2, 'cmp2) Module_types.comparator + -> f:('v -> 'k2) + -> ('k2, int, 'cmp2) Map.t Computation.t + + val mapi_min + : ('k, 'v, _) Map.t Value.t + -> comparator:('r, _) Module_types.comparator + -> f:(key:'k -> data:'v -> 'r) + -> 'r option Computation.t + + val mapi_max + : ('k, 'v, _) Map.t Value.t + -> comparator:('r, _) Module_types.comparator + -> f:(key:'k -> data:'v -> 'r) + -> 'r option Computation.t + + val map_min + : ('k, 'v, _) Map.t Value.t + -> comparator:('r, _) Module_types.comparator + -> f:('v -> 'r) + -> 'r option Computation.t + + val map_max + : ('k, 'v, _) Map.t Value.t + -> comparator:('r, _) Module_types.comparator + -> f:('v -> 'r) + -> 'r option Computation.t + + val min_value + : ('k, 'v, _) Map.t Value.t + -> comparator:('v, _) Module_types.comparator + -> 'v option Computation.t + + val max_value + : ('k, 'v, _) Map.t Value.t + -> comparator:('v, _) Module_types.comparator + -> 'v option Computation.t + + val mapi_bounds + : ('k, 'v, _) Map.t Value.t + -> comparator:('r, _) Module_types.comparator + -> f:(key:'k -> data:'v -> 'r) + -> ('r * 'r) option Computation.t + + val map_bounds + : ('k, 'v, _) Map.t Value.t + -> comparator:('r, _) Module_types.comparator + -> f:('v -> 'r) + -> ('r * 'r) option Computation.t + + val value_bounds + : ('k, 'v, _) Map.t Value.t + -> comparator:('v, _) Module_types.comparator + -> ('v * 'v) option Computation.t + + val merge + : ('k, 'v1, 'cmp) Map.t Value.t + -> ('k, 'v2, 'cmp) Map.t Value.t + -> f:(key:'k -> ('v1, 'v2) Map.Merge_element.t -> 'v3 option) + -> ('k, 'v3, 'cmp) Map.t Computation.t + + val merge_both_some + : ('k, 'v1, 'cmp) Map.t Value.t + -> ('k, 'v2, 'cmp) Map.t Value.t + -> f:(key:'k -> 'v1 -> 'v2 -> 'v3) + -> ('k, 'v3, 'cmp) Map.t Computation.t + + val unzip + : ('k, 'a * 'b, 'cmp) Map.t Value.t + -> (('k, 'a, 'cmp) Map.t * ('k, 'b, 'cmp) Map.t) Computation.t + + val unzip_mapi + : ('k, 'v, 'cmp) Map.t Value.t + -> f:(key:'k -> data:'v -> 'v1 * 'v2) + -> (('k, 'v1, 'cmp) Map.t * ('k, 'v2, 'cmp) Map.t) Computation.t + + val keys : ('k, 'v, 'c) Map.t Value.t -> ('k, 'c) Set.t Computation.t + val rank : ('k, 'v, 'cmp) Map.t Value.t -> 'k Value.t -> int option Computation.t + + val subrange + : ('k, 'v, 'cmp) Map.t Value.t + -> ('k Maybe_bound.As_lower_bound.t * 'k Maybe_bound.As_upper_bound.t) option Value.t + -> ('k, 'v, 'cmp) Map.t Computation.t + + val subrange_by_rank + : ('k, 'v, 'cmp) Map.t Value.t + -> (int Maybe_bound.As_lower_bound.t * int Maybe_bound.As_upper_bound.t) Value.t + -> ('k, 'v, 'cmp) Map.t Computation.t + + val rekey + : ('k1, 'v, 'cmp1) Map.t Value.t + -> comparator:('k2, 'cmp2) Module_types.comparator + -> f:(key:'k1 -> data:'v -> 'k2) + -> ('k2, 'v, 'cmp2) Map.t Computation.t + + val index_byi + : ('inner_key, 'v, 'inner_cmp) Map.t Value.t + -> comparator:('outer_key, 'outer_cmp) Module_types.comparator + -> index:(key:'inner_key -> data:'v -> 'outer_key option) + -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t + + val index_by + : ('inner_key, 'v, 'inner_cmp) Map.t Value.t + -> comparator:('outer_key, 'outer_cmp) Module_types.comparator + -> index:('v -> 'outer_key option) + -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t + + val unordered_fold_nested_maps + : ?update: + (outer_key:'outer_key + -> inner_key:'inner_key + -> old_data:'v + -> new_data:'v + -> 'acc + -> 'acc) + -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t + -> init:'acc + -> add:(outer_key:'outer_key -> inner_key:'inner_key -> data:'v -> 'acc -> 'acc) + -> remove:(outer_key:'outer_key -> inner_key:'inner_key -> data:'v -> 'acc -> 'acc) + -> 'acc Computation.t + + val transpose + : ('k2, 'k2_cmp) Module_types.comparator + -> ('k1, ('k2, 'v, 'k2_cmp) Map.t, 'k1_cmp) Map.t Value.t + -> ('k2, ('k1, 'v, 'k1_cmp) Map.t, 'k2_cmp) Map.t Computation.t + + val collapse + : ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t + -> comparator:('inner_key, 'inner_cmp) Module_types.comparator + -> ( 'outer_key * 'inner_key + , 'v + , ('outer_cmp, 'inner_cmp) Tuple2.comparator_witness ) + Map.t + Computation.t + + val collapse_by + : ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Value.t + -> merge_keys:('outer_key -> 'inner_key -> 'combined_key) + -> comparator:('combined_key, 'combined_cmp) Module_types.comparator + -> ('combined_key, 'v, 'combined_cmp) Map.t Computation.t + + val expand + : ('outer_key * 'inner_key, 'v, 'tuple_cmp) Map.t Value.t + -> outer_comparator:('outer_key, 'outer_cmp) Module_types.comparator + -> inner_comparator:('inner_key, 'inner_cmp) Module_types.comparator + -> ('outer_key, ('inner_key, 'v, 'inner_cmp) Map.t, 'outer_cmp) Map.t Computation.t + + val counti + : ('k, 'v, _) Map.t Value.t + -> f:(key:'k -> data:'v -> bool) + -> int Computation.t + + val count : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> int Computation.t + + val for_alli + : ('k, 'v, _) Map.t Value.t + -> f:(key:'k -> data:'v -> bool) + -> bool Computation.t + + val for_all : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> bool Computation.t + + val existsi + : ('k, 'v, _) Map.t Value.t + -> f:(key:'k -> data:'v -> bool) + -> bool Computation.t + + val exists : (_, 'v, _) Map.t Value.t -> f:('v -> bool) -> bool Computation.t + + val sum + : (_, 'v, _) Map.t Value.t + -> (module Abstract_algebra.Commutative_group.Without_sexp with type t = 'u) + -> f:('v -> 'u) + -> 'u Computation.t +end + +module Map0 = struct + module type S = sig + module Make (Input : Input) : sig + include + Output + with module Value := Input.Value + and module Computation := Input.Computation + end + end +end diff --git a/src/proc.ml b/src/proc.ml index bbae1aa4..487e644e 100644 --- a/src/proc.ml +++ b/src/proc.ml @@ -12,6 +12,7 @@ module Let_syntax = struct let return = return let map ?here t ~f = { (Value.map t ~f) with here } let both = Value.both + let map2 = Value.map2 let arr ?here t ~f = read (map ?here t ~f) let cutoff t ~equal = Value.cutoff ~added_by_let_syntax:true t ~equal @@ -200,7 +201,8 @@ let actor1 -> ?equal:(model -> model -> bool) -> default_model:model -> recv: - (schedule_event:(unit Ui_effect.t -> unit) + (inject:(action -> return Effect.t) + -> schedule_event:(unit Effect.t -> unit) -> input Computation_status.t -> model -> action @@ -219,13 +221,14 @@ let actor1 let sexp_of_t cb = sexp_of_action (Effect.Private.Callback.request cb) end in + let make_inject ~inject ~schedule_event action = + Effect.Private.make ~request:action ~evaluator:(fun action -> + schedule_event (inject action)) + in let reset = Option.map reset ~f:(fun f context model -> let%tydi { inject; schedule_event } = Apply_action_context.Private.reveal context in - let inject action = - Effect.Private.make ~request:action ~evaluator:(fun action -> - schedule_event (inject action)) - in + let inject = make_inject ~inject ~schedule_event in f ~inject ~schedule_event model) in let%sub model, inject = @@ -236,20 +239,19 @@ let actor1 ?equal ~default_model ~apply_action:(fun context input model callback -> - let%tydi { inject = _; schedule_event } = + let%tydi { inject; schedule_event } = Apply_action_context.Private.reveal context in + let inject = make_inject ~inject ~schedule_event in let action = Effect.Private.Callback.request callback in - let new_model, response = recv ~schedule_event input model action in + let new_model, response = recv ~inject ~schedule_event input model action in schedule_event (Effect.Private.Callback.respond_to callback response); new_model) input in let%sub inject = let%arr inject = inject in - fun action -> - Effect.Private.make ~request:action ~evaluator:(fun action -> - Effect.Expert.handle (inject action)) + make_inject ~inject ~schedule_event:Effect.Expert.handle in let%arr model = model and inject = inject in @@ -257,7 +259,9 @@ let actor1 ;; let actor0 ?reset ?sexp_of_model ?sexp_of_action ?equal ~default_model ~recv () = - let recv ~schedule_event (_ : unit Computation_status.t) = recv ~schedule_event in + let recv ~inject ~schedule_event (_ : unit Computation_status.t) = + recv ~inject ~schedule_event + in actor1 ?sexp_of_action ?sexp_of_model @@ -345,7 +349,7 @@ let yoink a = ~sexp_of_model:[%sexp_of: Unit.t] ~sexp_of_action:[%sexp_of: Unit.t] ~equal:[%equal: Unit.t] - ~recv:(fun ~schedule_event:_ a () () -> (), a) + ~recv:(fun ~inject:_ ~schedule_event:_ a () () -> (), a) ~default_model:() a in @@ -353,30 +357,6 @@ let yoink a = result () ;; -let narrow state_and_inject ~get ~set = - let%sub state, inject = return state_and_inject in - let%sub inject = - let%sub get_state = yoink state in - let%arr get_state = get_state - and inject = inject in - fun a -> - match%bind.Effect get_state with - | Inactive -> Effect.Ignore - | Active state -> inject (set state a) - in - let%sub state = - let%arr state = state in - get state - in - let%arr state = state - and inject = inject in - state, inject -;; - -let narrow_via_field state_and_inject field = - narrow state_and_inject ~get:(Field.get field) ~set:(Field.fset field) -;; - module Edge = struct include Edge @@ -473,7 +453,7 @@ module Edge = struct ~sexp_of_action:[%sexp_of: Unit.t] ~equal:[%equal: Int.t] ~default_model:0 - ~recv:(fun ~schedule_event:_ i () -> i + 1, i) + ~recv:(fun ~inject:_ ~schedule_event:_ i () -> i + 1, i) () in let module State = struct @@ -749,6 +729,12 @@ module Incr = struct include Incr0 end +module Map0 = Map0.Make (struct + module Value = Value + module Computation = Computation + module Incr = Incr +end) + let freeze ?sexp_of_model ?equal value = let%sub state, set_state = state_opt ?sexp_of_model ?equal () in match%sub state with @@ -808,7 +794,7 @@ let previous_value let assoc_set m v ~f = let%sub as_map = Map0.of_set v in - assoc m as_map ~f:(fun k _ -> f k) + assoc m as_map ~f:(fun k _ -> f k) [@nontail] ;; let assoc_list (type key cmp) (m : (key, cmp) comparator) list ~get_key ~f = @@ -823,7 +809,7 @@ let assoc_list (type key cmp) (m : (key, cmp) comparator) list ~get_key ~f = in match%sub input_map with | `Ok input_map -> - let%sub output_map = assoc m input_map ~f in + let%sub output_map = assoc m input_map ~f:(fun k v -> f k v) [@nontail] in let%arr alist = alist and output_map = output_map in `Ok @@ -1320,11 +1306,9 @@ module Value = struct let cutoff t ~equal = cutoff ~added_by_let_syntax:false t ~equal end -module Private = struct - let conceal_value = Fn.id - let reveal_value = Fn.id - let conceal_computation = Fn.id - let reveal_computation = Fn.id +module Expert = struct + let thunk = thunk + let assoc_on = assoc_on end module Map = Map0 diff --git a/src/proc_intf.ml b/src/proc_intf.ml new file mode 100644 index 00000000..8b2897e2 --- /dev/null +++ b/src/proc_intf.ml @@ -0,0 +1,1064 @@ +open! Core +open! Import + +module type S = sig + module Private_computation : sig + type 'a t + end + + module Private_value : sig + type 'a t + end + + module type Model = Module_types.Model + module type Action = Module_types.Action + module type Enum = Module_types.Enum + module type Comparator = Module_types.Comparator + + type ('k, 'cmp) comparator = ('k, 'cmp) Module_types.comparator + + (** The functions found in this module are focused on the manipulation + of values of type ['a Computation.t] and ['a Value.t]. There are fine + descriptions of these types below and how to use them, but since it's + so common to convert between the two, here is a cheat-sheet matrix for + converting between values of different types: + + {v + + | Have \ Want | 'a Value.t | 'a Computation.t | + |------------------+------------------------+------------------| + | 'a | let v = Value.return a | let c = const a | + | 'a Value.t | | let c = read v | + | 'a Computation.t | let%sub v = c | | + + v} *) + + module Value : sig + (** A value of type ['a Value.t] represents a value that may change during the lifetime + of the program. For those familiar with the [Incremental] library, this type is + conceptually very similar to [Incr.t]. The main method by which you acquire values + of type [Value.t] is by using the [let%sub] syntax extension. + + {[ + val c : int Computation.t + + let%sub x = c in + (* [x] has type [int Value.t] here *) + ]} + + In the example above, we run a computation [c] and store the result of that + computation in [x] which has type [Value.t]. + + [Value.t] is an applicative, which means that you can combine multiple [Value]s into + one by using [Let_syntax]: + + {[ + val a : int Value.t + val b : int Value.t + + let open Let_syntax in + let%map a = a and b = b in + a + b + ]} *) + type 'a t + + include Applicative.S with type 'a t := 'a t + include Mapn with type 'a t := 'a t + + (** A [Value.t] transformed by [cutoff] will only trigger changes on its dependents when the equality + of the contained value has changed. + + Immediate nesting of cutoff nodes are combined into a single cutoff node whose equality function is + true when any of the composed nodes is true and is false when all of the composed nodes are false. + They're "or'ed together". *) + val cutoff : 'a t -> equal:('a -> 'a -> bool) -> 'a t + + (** flips the option position in a ['a Value.t option] into an ['a option Value.t]. It's + useful for optional args that take values. *) + val transpose_opt : 'a t option -> 'a option t + end + + module Computation : sig + (** A value of type ['a Computation.t] represents a computation which produces a value + that may change during the lifetime of a program, and the value may be influenced by + the internal state of that computation. + + The same ['a Computation.t] can be used in multiple places in a program, and these + uses will {e not} share the same state, nor will they share the work performed by + the computation. + + In this normal OCaml code, if we see the same function being called multiple times: + + {[ + let a = f () in + let b = f () in + a + b + ]} + + You would not be surprised to know that if [f] has side-effects (maybe + printing to the console), then those side-effects happen twice because + [f] was called twice. + + Similarly, if we wrote the code this way: + + {[ + let a = f () in + let b = a in + a + b + ]} + + You would (correctly) expect that the side-effect only happens once, when computing + [a]. In these examples, the {e code} [f ()] is analogous to [_ Computation.t]. If + you want to have two separate values whose computations maintain separate state, you + would use two instances of "let%sub" to bind them separately: + + {[ + val some_computation : int Computation.t + val add : int Value.t -> int Value.t -> int Computation.t + + let open Let_syntax in + let%sub a = some_computation in + let%sub b = some_computation in + add a b + ]} + + Here, [a] and [b] can take on different values depending on the states of the + computations that produce them. + + However, if you want to use just one value in multiple places, only use + [let%sub] once: + + {[ + let open Let_syntax in + let%sub a = some_computation in + let b = a in + add a b + ]} + + Here, [a] and [b] always take on the same value. *) + type 'a t + + include Applicative.S with type 'a t := 'a t + + (** Similar to [all] which pulls the computation outside of a list, + [all_map] does the same, but with the data in a map. This can + be a useful replacement for [assoc] in scenarios where the map + is a constant size. *) + val all_map : ('k, 'v t, 'cmp) Map.t -> ('k, 'v, 'cmp) Map.t t + + (** The analog of [List.reduce_balanced] for computations, but with [f] + operating on values instead of the computations themselves *) + val reduce_balanced : 'a t list -> f:('a Value.t -> 'a Value.t -> 'a t) -> 'a t option + + val fold_right + : 'a t list + -> f:('a Value.t -> 'acc Value.t -> 'acc t) + -> init:'acc Value.t + -> 'acc t + + module Let_syntax : sig + val return : 'a -> 'a t + + include Applicative.Applicative_infix with type 'a t := 'a t + + module Let_syntax : sig + val return : 'a -> 'a t + val map : 'a t -> f:('a -> 'b) -> 'b t + val both : 'a t -> 'b t -> ('a * 'b) t + + include Mapn with type 'a t := 'a t + end + end + + include Mapn with type 'a t := 'a t + end + + module Effect = Ui_effect + + module For_open : sig + module Computation = Computation + module Effect = Effect + module Value = Value + end + + module Var : sig + (** A [Var.t] is the primary method for making data obtained outside of Bonsai (maybe via + an RPC) accessible inside a Bonsai application. *) + type 'a t + + (** Creates a new [Var.t] with an initial value. *) + val create : 'a -> 'a t + + (** Updates the value inside of [t]. [f] is given the previous value of [t] so that you + can reuse parts of the value if applicable *) + val update : 'a t -> f:('a -> 'a) -> unit + + (** Sets the value inside of [t]. *) + val set : 'a t -> 'a -> unit + + (** Gets the value inside of [t]. *) + val get : 'a t -> 'a + + (** Provides read-only access to [t] by producing a {!Value.t} which is used inside of a + Bonsai computation. *) + val value : 'a t -> 'a Value.t + + (** Retrieves the underlying ['a t] Ui_incr.t var. *) + val incr_var : 'a t -> 'a Ui_incr.Var.t + end + + (** Converts a [Value.t] to a [Computation.t]. Unlike most Computations, the [Computation.t] + returned by [read] can be used in multiple locations without maintaining multiple copies of + any models or building duplicate incremental graphs. + + [read] is most commonly used in the final expression of a [let%sub] chain, like so: + + {[ + fun i -> + let%sub a = f i in + let%sub b = g i in + read + (let%map a = a + and b = b in + a + b) + ]} + + or to use some APIs that require [Computation.t] like so: + + {[ + val cond : bool Value.t + val x : 'a Value.t + val some_computation : 'a Computation.t + + let y = if_ cond ~then_:some_computation ~else_:(read x) + val y : 'a Computation.t + ]} + *) + val read : 'a Value.t -> 'a Computation.t + + (** Creates a [Computation.t] that provides a constant value. *) + val const : 'a -> 'a Computation.t + + (** Retrieves the path to the current computation as a string. This string is + not human-readable, but can be used as an ID which is unique to this + particular instance of a component. *) + val path_id : string Computation.t + + (** Lifts a regular OCaml function into one that takes a Value as input, and produces + a Computation as output. *) + val pure : ('a -> 'b) -> 'a Value.t -> 'b Computation.t + + module Computation_status : sig + (** Indicates whether a value is available, which depends on whether the + computation in which it is computed is active or not. Most of the time + values of this type are [Active], since it is unusual to interact with + inactive computations. + + A computation is considered inactive if it resides in the inactive arm of + a [match%sub] or in a removed entry of a [Bonsai.assoc]. *) + type 'input t = + | Active of 'input + | Inactive + [@@deriving sexp_of] + end + + (** A frequently used state-machine is the trivial 'set-state' transition, + where the action always replaces the value contained inside. This + helper-function implements that state-machine, providing access to the + current state, as well as an inject function that updates the state. *) + val state + : ?reset:('model -> 'model) + (** to learn more about [reset], read the docs on [with_model_resetter] *) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> 'model + -> ('model * ('model -> unit Effect.t)) Computation.t + + (** Similar to [state], but stores an option of the model instead. + [default_model] is optional and defaults to [None]. *) + val state_opt + : ?reset:('model option -> 'model option) + -> ?default_model:'model + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> unit + -> ('model option * ('model option -> unit Effect.t)) Computation.t + + (** A bool-state which starts at [default_model] and flips whenever the + returned effect is scheduled. *) + val toggle : default_model:bool -> (bool * unit Effect.t) Computation.t + + module Toggle : sig + type t = + { state : bool + ; set_state : bool -> unit Effect.t + ; toggle : unit Effect.t + } + end + + (** Like [toggle], but also gives a handle to set the state directly *) + val toggle' : default_model:bool -> Toggle.t Computation.t + + module Apply_action_context : sig + type 'action t = 'action Apply_action_context.t + + val inject : 'action t -> 'action -> unit Effect.t + val schedule_event : _ t -> unit Effect.t -> unit + end + + (** A constructor for [Computation.t] that models a simple state machine. + The first-class module implementing [Model] describes the states in + the state machine, while the first-class module implementing [Action] + describes the transitions between states. + + [default_model] is the initial state for the state machine, and [apply_action] + implements the transition function that looks at the current state and the requested + transition, and produces a new state. + + (It is very common for [inject] and [schedule_event] to be unused) *) + val state_machine0 + : ?reset:('action Apply_action_context.t -> 'model -> 'model) + (** to learn more about [reset], read the docs on [with_model_resetter] *) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action:('action Apply_action_context.t -> 'model -> 'action -> 'model) + -> unit + -> ('model * ('action -> unit Effect.t)) Computation.t + + (** The same as {!state_machine0}, but [apply_action] also takes an input from + a [Value.t]. The input has type ['input Computation_status.t] instead of + plain ['input] to account for the possibility that an action gets sent + while the state machine is inactive. *) + val state_machine1 + : ?sexp_of_action:('action -> Sexp.t) + -> ?reset:('action Apply_action_context.t -> 'model -> 'model) + (** to learn more about [reset], read the docs on [with_model_resetter] *) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action: + ('action Apply_action_context.t + -> 'input Computation_status.t + -> 'model + -> 'action + -> 'model) + -> 'input Value.t + -> ('model * ('action -> unit Effect.t)) Computation.t + + (** Identical to [actor1] but it takes 0 inputs instead of 1. *) + val actor0 + : ?reset: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'model) + (** to learn more about [reset], read the docs on [with_model_resetter] *) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?sexp_of_action:('action -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> recv: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'action + -> 'model * 'return) + -> unit + -> ('model * ('action -> 'return Effect.t)) Computation.t + + (** [actor1] is very similar to [state_machine1], with two major exceptions: + - the [apply-action] function for state-machine is renamed [recv], and it + returns a "response", in addition to a new model. + - the 2nd value returned by the component allows for the sender of an + action to handle the effect and read the response. + + Because the semantics of this function feel like an actor system, we've + decided to name the function accordingly. *) + val actor1 + : ?sexp_of_action:('action -> Sexp.t) + -> ?reset: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'model + -> 'model) + (** to learn more about [reset], read the docs on [with_model_resetter] *) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> recv: + (inject:('action -> 'return Effect.t) + -> schedule_event:(unit Effect.t -> unit) + -> 'input Computation_status.t + -> 'model + -> 'action + -> 'model * 'return) + -> 'input Value.t + -> ('model * ('action -> 'return Effect.t)) Computation.t + + (** Given a value containing the current state (like from a [Bonsai.state] or + [Bonsai.state_machine]), [narrow] gives you access to a subset of the state and a setter + for the subset of that type. + + For example, you could use [narrow] a state containing a record to the value and + injection function for a single field. *) + val narrow + : ('a * ('input_action -> unit Effect.t)) Value.t + -> get:('a -> 'b) + -> set:('a -> 'output_action -> 'input_action) + -> ('b * ('output_action -> unit Effect.t)) Computation.t + + (** Like [narrow], but [get] and [set] are implemented in terms of the given field. *) + val narrow_via_field + : ('a * ('a -> unit Effect.t)) Value.t + -> ('a, 'b) Field.t + -> ('b * ('b -> unit Effect.t)) Computation.t + + (** Given a first-class module that has no input (unit input type), and the default + value of the state machine, [of_module0] will create a [Computation] that produces + values of that module's [Result.t] type. *) + val of_module0 + : ?sexp_of_model:('m -> Sexp.t) + -> ?equal:('m -> 'm -> bool) + -> (unit, 'm, 'a, 'r) component_s + -> default_model:'m + -> 'r Computation.t + + (** The same as {!of_module0}, but this one has an input type ['i]. Because input to the + component is required, this function also expects a [Value.t] that provides its input. + It is common for this function to be partially applied like so: + + {[ + val a : int Value.t + val b : int Value.t + + let f = of_module1 (module struct ... end) ~default_model in + let%sub a = f a in + let%sub b = f b in + ... + ]} + + Where the [Value.t] values are passed in later. *) + val of_module1 + : ?sexp_of_model:('m -> Sexp.t) + -> ('i, 'm, 'a, 'r) component_s + -> ?equal:('m -> 'm -> bool) + -> default_model:'m + -> 'i Value.t + -> 'r Computation.t + + (** The same as {!of_module1} but with two inputs. *) + val of_module2 + : ?sexp_of_model:('m -> Sexp.t) + -> ('i1 * 'i2, 'm, 'a, 'r) component_s + -> ?equal:('m -> 'm -> bool) + -> default_model:'m + -> 'i1 Value.t + -> 'i2 Value.t + -> 'r Computation.t + + (** [freeze] takes a Value.t and returns a computation whose output is frozen + to be the first value that passed through the input. *) + val freeze + : ?sexp_of_model:('a -> Sexp.t) + -> ?equal:('a -> 'a -> bool) + -> 'a Value.t + -> 'a Computation.t + + (** Because all Bonsai computation-returning-functions are eagerly evaluated, attempting + to use "let rec" to construct a recursive component will recurse infinitely. One way + to avoid this is to use a lazy computation and [Bonsai.lazy_] to defer evaluating the + [Computation.t]. + + {[ + let rec some_component arg1 arg2 = + ... + let _ = Bonsai.lazy_ (lazy (some_component ...)) in + ... + ]} *) + val lazy_ : 'a Computation.t Lazy.t -> 'a Computation.t + [@@deprecated "[since 2023-07] Use Bonsai.fix "] + + (** A fixed-point combinator for bonsai components. This is used to build recursive + components like so: + + {[ + let my_recursive_component ~some_input = + Bonsai.fix some_input ~f:(fun ~recurse some_input -> + (* call [recurse] to instantiate a nested instance of the component *) + ) + ]} + *) + val fix + : 'input Value.t + -> f: + (recurse:('input Value.t -> 'result Computation.t) + -> 'input Value.t + -> 'result Computation.t) + -> 'result Computation.t + + (** Like [fix], but for two arguments instead of just one. *) + val fix2 + : 'a Value.t + -> 'b Value.t + -> f: + (recurse:('a Value.t -> 'b Value.t -> 'result Computation.t) + -> 'a Value.t + -> 'b Value.t + -> 'result Computation.t) + -> 'result Computation.t + + (** [scope_model] allows you to have a different model for the provided + computation, keyed by some other value. + + Suppose for example, that you had a form for editing details about a + person. This form should have different state for each person. You could + use scope_model, where the [~on] parameter is set to a user-id, and now when + that value changes, the model for the other computation is set to the model + for that particular user. + + [scope_model] also impacts lifecycle events; when [on] changes value, + edge triggers like [on_activate] and [on_deactivate] will run *) + val scope_model + : ('a, _) comparator + -> on:'a Value.t + -> 'b Computation.t + -> 'b Computation.t + + (** [most_recent_some] returns a value containing the most recent + output of [f] for which it returned [Some]. If the input value has never + contained a valid value, then the result is [None]. *) + val most_recent_some + : ?sexp_of_model:('b -> Sexp.t) + -> equal:('b -> 'b -> bool) + -> 'a Value.t + -> f:('a -> 'b option) + -> 'b option Computation.t + + (** [most_recent_value_satisfying] returns a value containing the most recent input + value for which [condition] returns true. If the input value has never + contained a valid value, then the result is [None]. *) + val most_recent_value_satisfying + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a Value.t + -> condition:('a -> bool) + -> 'a option Computation.t + + (** [previous_value] returns the previous contents of the input value if it + just changed, or the current contents of the value if it did not just + change. Initially starts out as [None]. + + Any values the input takes on while the output is inactive are ignored; any + changes to the input are assumed to have occurred exactly when the + component was re-activated. *) + val previous_value + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a Value.t + -> 'a option Computation.t + + (** [assoc] is used to apply a Bonsai computation to each element of a map. This function + signature is very similar to [Map.mapi] or [Incr_map.mapi'], and for good reason! + + It is doing the same thing (taking a map and a function and returning a new map with + the function applied to every key-value pair), but this function does it with the + Bonsai values, which means that the computation is done incrementally and also + maintains a state machine for every key-value pair. *) + val assoc + : ('key, 'cmp) comparator + -> ('key, 'data, 'cmp) Map.t Value.t + -> f:('key Value.t -> 'data Value.t -> 'result Computation.t) + -> ('key, 'result, 'cmp) Map.t Computation.t + + (** Like [assoc] except that the input value is a Set instead of a Map. *) + val assoc_set + : ('key, 'cmp) comparator + -> ('key, 'cmp) Set.t Value.t + -> f:('key Value.t -> 'result Computation.t) + -> ('key, 'result, 'cmp) Map.t Computation.t + + (** Like [assoc] except that the input value is a list instead of a Map. The output list + is in the same order as the input list. + + This function performs O(n log(n)) work (where n is the length of the list) any time + that anything in the input list changes, so it may be quite slow with large lists. *) + val assoc_list + : ('key, _) comparator + -> 'a list Value.t + -> get_key:('a -> 'key) + -> f:('key Value.t -> 'a Value.t -> 'b Computation.t) + -> [ `Duplicate_key of 'key | `Ok of 'b list ] Computation.t + + (** [enum] is used for matching on a value and providing different behaviors on different + values. The type of the value must be enumerable (there must be a finite number of + possible values), and it must be comparable and sexpable. + + The rest of the parameters are named like you might expect from pattern-matching + syntax, with [match_] taking the value to match on, and [with_] taking a function that + choose which behavior to use. *) + val enum + : (module Enum with type t = 'k) + -> match_:'k Value.t + -> with_:('k -> 'a Computation.t) + -> 'a Computation.t + + (** [wrap] wraps a Computation (built using [f]) and provides a model and + injection function that the wrapped component can use. Especially of note + is that the [apply_action] for this outer-model has access to the result + value of the Computation being wrapped. *) + val wrap + : ?reset:('action Apply_action_context.t -> 'model -> 'model) + -> ?sexp_of_model:('model -> Sexp.t) + -> ?equal:('model -> 'model -> bool) + -> default_model:'model + -> apply_action: + ('action Apply_action_context.t -> 'result -> 'model -> 'action -> 'model) + -> f:('model Value.t -> ('action -> unit Effect.t) Value.t -> 'result Computation.t) + -> unit + -> 'result Computation.t + + (** [with_model_resetter] extends a computation with the ability to reset all of the + models for components contained in that computation. The default behavior for + a stateful component is to have its model set to the value provided by + [default_model], though this behavior is overridable on a component-by-component + basis by providing a value for the optional [reset] argument on stateful components. *) + val with_model_resetter : 'a Computation.t -> ('a * unit Effect.t) Computation.t + + (** like [with_model_resetter], but makes the resetting effect available to the + computation being wrapped. *) + val with_model_resetter' + : (reset:unit Effect.t Value.t -> 'a Computation.t) + -> 'a Computation.t + + (** [yoink] is a function that takes a bonsai value and produces a + computation producing an effect which fetches the current value out of the + input. This can be useful inside of [let%bind.Effect] chains, where a + value that you've closed over is stale and you want to witness a value + after it's been changed by a previous effect. + + The ['a Computation_state.t] returned by the effect means that if the value + was inactive at the time it got yoinked, then the effect will be unable to + retrieve it. *) + val yoink : 'a Value.t -> 'a Computation_status.t Effect.t Computation.t + + (** [sub] instantiates a computation and provides a reference to its results to + [f] in the form of a [Value.t]. The main way to use this function is via + the [let%sub] syntax extension. [?here] is used by the Bonsai debugger + to tie visualizations to precise source locations. *) + val sub + : ?here:Source_code_position.t + -> 'a Computation.t + -> f:('a Value.t -> 'b Computation.t) + -> 'b Computation.t + + module Clock : sig + (** Functions allowing for the creation of time-dependent computations in + a testable way. *) + + (** The current time, updated at [tick_every] intervals. *) + val approx_now : tick_every:Time_ns.Span.t -> Time_ns.t Computation.t + + (** The current time, update as frequently as possible. *) + val now : Time_ns.t Computation.t + + module Before_or_after : sig + type t = Ui_incr.Before_or_after.t = + | Before + | After + [@@deriving sexp, equal] + end + + (** Mirrors [Incr.Clock.at], which changes from [Before] to [After] at the + specified time. *) + val at : Time_ns.t Value.t -> Before_or_after.t Computation.t + + (** An event passed to [every] is scheduled on an interval determined by + the time-span argument. + + [when_to_start_next_effect] has the following behavior + | `Wait_period_after_previous_effect_starts_blocking -> If the previous effect takes longer than [period], we wait until it finishes before starting the next effect. + | `Wait_period_after_previous_effect_finishes_blocking -> The effect will always be executed [period] after the previous effect finishes. + | `Every_multiple_of_period_non_blocking -> Executes the effect at a regular interval. + | `Every_multiple_of_period_blocking -> Same as `Every_multiple_of_second, but skips a beat if the previous effect is still running. + *) + val every + : when_to_start_next_effect: + [< `Wait_period_after_previous_effect_starts_blocking + | `Wait_period_after_previous_effect_finishes_blocking + | `Every_multiple_of_period_non_blocking + | `Every_multiple_of_period_blocking + ] + -> ?trigger_on_activate:bool + -> Time_ns.Span.t + -> unit Effect.t Value.t + -> unit Computation.t + + (** An effect for fetching the current time. *) + val get_current_time : Time_ns.t Effect.t Computation.t + + (** The function in this computation produces an effect that completes after + the specified amount of time. *) + val sleep : (Time_ns.Span.t -> unit Effect.t) Computation.t + + (** Like [sleep], but waits until a specific time, rather than a time + relative to now. *) + val until : (Time_ns.t -> unit Effect.t) Computation.t + end + + module Edge : sig + (** All the functions in this module incorporate the concept of "edge-triggering", + which is the terminology that we use to describe actions that occur when a value + changes. *) + + (** When given a value and a callback, [on_change] and [on_change'] will watch the + input variable and call the callback whenever the value changes. + + [callback] is also called when the component is initialized, passing in the + first 'a value that gets witnessed. + + These functions do not wait for previous calls to [callback] to complete before + calling it again. *) + val on_change + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a Value.t + -> callback:('a -> unit Effect.t) Value.t + -> unit Computation.t + + (** The same as [on_change], but the callback function gets access to the + previous value that was witnessed. *) + val on_change' + : ?sexp_of_model:('a -> Sexp.t) + -> equal:('a -> 'a -> bool) + -> 'a Value.t + -> callback:('a option -> 'a -> unit Effect.t) Value.t + -> unit Computation.t + + (** [lifecycle] is a way to detect when a computation becomes active, + inactive, or an event is triggered after every rendering (roughly 60x / + second). By depending on this function (with let%sub), you can install + events that are scheduled on either case. + + When used, the events are scheduled in this order: + - All deactivations + - All activations + - All "after-display"s + + and an "after-display" won't occur before an activation, or after a + deactivation for a given computation. *) + val lifecycle + : ?on_activate:unit Effect.t Value.t + -> ?on_deactivate:unit Effect.t Value.t + -> ?after_display:unit Effect.t Value.t + -> unit + -> unit Computation.t + + (** Like [lifecycle], but the events are optional values. If the event value + is None when the action occurs, nothing will happen *) + val lifecycle' + : ?on_activate:unit Effect.t option Value.t + -> ?on_deactivate:unit Effect.t option Value.t + -> ?after_display:unit Effect.t option Value.t + -> unit + -> unit Computation.t + + (** [after_display] and [after_display'] are lower-level functions that + can be used to register an event to occur once-per-frame (after each + render). *) + val after_display : unit Effect.t Value.t -> unit Computation.t + + val after_display' : unit Effect.t option Value.t -> unit Computation.t + + (** [wait_after_display] is an effect that will complete after the next frame. *) + val wait_after_display : unit Effect.t Computation.t + + module Poll : sig + module Starting : sig + type ('o, 'r) t + + (** [empty] is an option to pass to the polling functions that changes + its return type to be ['o option Computation.t] and starting + value is [None] *) + val empty : ('o, 'o option) t + + (** [initial x] is an option to pass to the polling functions that + changes its return type to be ['o Computation.t] and the + starting value is [x] *) + val initial : 'o -> ('o, 'o) t + end + + (** This function runs an effect every time that the input value changes, + returning the most recent result as its computation. + + The [Starting.t] argument controls the type of the result, and + depending on the value, will either return an optional value + [Option.None] or a default value ['o] in the time in between the + computation starting and the first result coming back from the effect. *) + val effect_on_change + : ?sexp_of_input:('a -> Sexp.t) + -> ?sexp_of_result:('o -> Sexp.t) + -> equal_input:('a -> 'a -> bool) + -> ?equal_result:('o -> 'o -> bool) + -> ('o, 'r) Starting.t + -> 'a Value.t + -> effect:('a -> 'o Effect.t) Value.t + -> 'r Computation.t + + val manual_refresh + : ?sexp_of_model:('o -> Sexp.t) + -> ?equal:('o -> 'o -> bool) + -> ('o, 'r) Starting.t + -> effect:'o Effect.t Value.t + -> ('r * unit Effect.t) Computation.t + end + end + + module Memo : sig + (** The [Memo] module can be used to share a computation between multiple + components, meaning that if the shared computation is stateful, then + the users of that computation will see the same state. + + The way that [Memo] differs from just using [let%sub] on a computation + and then passing the resulting [Value.t] down to its children is twofold: + - The shared computation is not made active until it's actually requested + by another component + - Knowledge of any inputs to component are be deferred to "lookup time", when + components request an instance of the component. + + Shared computations are refcounted, so when the last user of a memoized component + deactivates, the shared component is deactivated as well. *) + + type ('input, 'result) t + + (** Creates a memo instance that can be used by calling [lookup] *) + val create + : ('input, 'cmp) comparator + -> f:('input Value.t -> 'result Computation.t) + -> ('input, 'result) t Computation.t + + (** Requests an instance of the shared computation for a given ['input] value. + If an instance doesn't already exist, it will request a new computation, which + results in [none] being returned for a brief period of time, after which it'll + return a [Some] containing the result of that computation *) + val lookup + : ?sexp_of_model:('input -> Sexp.t) + -> equal:('input -> 'input -> bool) + -> ('input, 'result) t Value.t + -> 'input Value.t + -> 'result option Computation.t + end + + module Effect_throttling : sig + module Poll_result : sig + type 'a t = + | Aborted + (** [Aborted] indicates that the effect was aborted before it even + started. If an effect starts, then it should complete with some kind + of result - [Effect] does not support cancellation in general. *) + | Finished of 'a + (** [Finished x] indicates that an effect successfully completed with value x. *) + [@@deriving sexp, equal] + + (** Collapses values of type ['a Or_error.t t] a plain Or_error.t, where + the Aborted case is transformed into an error. + + The [tag_s] parameter can be used to add additional info to the error. *) + val collapse_to_or_error : ?tag_s:Sexp.t lazy_t -> 'a Or_error.t t -> 'a Or_error.t + + (** Like [collapse_to_or_error], but transforms a function that returns an + ['a Or_error.t t] instead of just the value. *) + val collapse_fun_to_or_error + : ?sexp_of_input:('a -> Sexp.t) + -> ('a -> 'b Or_error.t t Effect.t) + -> 'a + -> 'b Or_error.t Effect.t + end + + (** Transforms an input effect into a new effect that enforces that invariant + that at most one instance of the effect is running at once. Attempting to + run the effect while a previous run is still ongoing will cause the new + effect to be enqueued. Any previously enqueued item gets kicked out, thus + maintaining the invariant that at most one effect will be enqueued. (this + is important so that things like RPCs calls don't pile up) + + CAUTION: This computation assumes that the input effect will always + complete. If a run of the effect raises, no more runs will ever get + executed, since they will all be waiting for the one that raised to + complete. *) + val poll + : ('a -> 'b Effect.t) Value.t + -> ('a -> 'b Poll_result.t Effect.t) Computation.t + end + + module Dynamic_scope : sig + (** This module implements dynamic variable scoping. Once a + dynamic variable is created, you can store values in it, and + lookup those same values. A lookup will find the nearest-most + grandparent [set_within] call. *) + + type 'a t + + (** Creates a new variable for use with the rest of the functions. + It is critically important that the exact same [Dynamic_scope.t] is used + in calls to [set_within] and the corresponding [lookup*]. *) + val create : ?sexp_of:('a -> Sexp.t) -> name:string -> fallback:'a -> unit -> 'a t + + (** Creates a variable which is derived from another. Typically this is used to + project out a field of another dynamic variable which contains a record. *) + val derived + : ?sexp_of:('a -> Sexp.t) + -> 'b t + -> get:('b -> 'a) + -> set:('b -> 'a -> 'b) + -> 'a t + + (** Given a ['a Dynamic_scope.t] and a ['a Value.t] evaluate a function + whose resulting Computation.t has access to the value via the + [lookup] function. *) + val set : 'a t -> 'a Value.t -> inside:'r Computation.t -> 'r Computation.t + + type revert = { revert : 'a. 'a Computation.t -> 'a Computation.t } + + (** like [set] but with the ability to revert the value in sub-computations. *) + val set' : 'a t -> 'a Value.t -> f:(revert -> 'r Computation.t) -> 'r Computation.t + + (** Lookup attempts to find the value inside the + nearest scope, but if there isn't one, it falls back to + default specified in [create]. *) + val lookup : 'a t -> 'a Computation.t + + val modify + : 'a t + -> change:('a Value.t -> 'a Value.t) + -> f:(revert -> 'r Computation.t) + -> 'r Computation.t + end + + module Incr : sig + (** A [Value.t] passed through [value_cutoff] will only trigger changes on its dependents when the + value changes according to the provided equality function *) + val value_cutoff : 'a Value.t -> equal:('a -> 'a -> bool) -> 'a Computation.t + + (** Use [compute] to move a function from the incremental world into the bonsai world. *) + val compute : 'a Value.t -> f:('a Incr.t -> 'b Incr.t) -> 'b Computation.t + + (** If you've got an incremental, you can convert it to a value with this function. *) + val to_value : 'a Incr.t -> 'a Value.t + + (** Compute some incremental value based on the time source. Using this time source + instead of [Incr.clock] is the more testable approach, since it allows tests + to control how time moves forward. *) + val with_clock : (Time_source.t -> 'a Incr.t) -> 'a Computation.t + end + + (** This [Let_syntax] module is basically just {!Value.Let_syntax} with the addition of + the [sub] function, which operates on Computations. + + By using the [let%sub] syntax extension, you can put a ['a Computation.t] on the RHS + and get a ['a Value.t] on the LHS. + + {[ + let%sub a = b in + ... + ]} + + In the code above, [b] has type ['a Computation.t], and [a] has type ['a Value.t]. *) + module Let_syntax : sig + (*_ [let%pattern_bind] requires that a function named [return] with these semantics + exist here. *) + val return : 'a Value.t -> 'a Computation.t + val ( >>| ) : 'a Value.t -> ('a -> 'b) -> 'b Value.t + val ( <*> ) : ('a -> 'b) Value.t -> 'a Value.t -> 'b Value.t + val ( <$> ) : ('a -> 'b) -> 'a Value.t -> 'b Value.t + + module Let_syntax : sig + (** [sub] instantiates a computation and provides a reference to its results to + [f] in the form of a [Value.t]. The main way to use this function is via + the [let%sub] syntax extension. [?here] is used by the Bonsai debugger + to tie visualizations to precise source locations. *) + val sub + : ?here:Source_code_position.t + -> 'a Computation.t + -> f:('a Value.t -> 'b Computation.t) + -> 'b Computation.t + + val cutoff : 'a Value.t -> equal:('a -> 'a -> bool) -> 'a Value.t + + val switch + : here:Source_code_position.t + -> match_:int Value.t + -> branches:int + -> with_:(int -> 'a Computation.t) + -> 'a Computation.t + + val map : ?here:Source_code_position.t -> 'a Value.t -> f:('a -> 'b) -> 'b Value.t + val map2 : 'a Value.t -> 'b Value.t -> f:('a -> 'b -> 'c) -> 'c Value.t + val return : 'a Value.t -> 'a Computation.t + val both : 'a Value.t -> 'b Value.t -> ('a * 'b) Value.t + + val arr + : ?here:Source_code_position.t + -> 'a Value.t + -> f:('a -> 'b) + -> 'b Computation.t + + include Mapn with type 'a t := 'a Value.t + end + end + + module Time_source = Time_source + + module Expert : sig + (** [thunk] will execute its argument exactly once per instantiation of the + computation. *) + val thunk : (unit -> 'a) -> 'a Computation.t + + (** [assoc_on] is similar to [assoc], but allows the model to be keyed differently than + the input map. This comes with a few caveats: + + - Inputs whose keys map to the same [model_key] will share the same model. + - The result of [get_model_key] is used in a bind, so it is expensive when it + changes. + + [assoc] should almost always be used instead. Consider whether you really need the + additional power before reaching for this function. *) + val assoc_on + : ('io_key, 'io_cmp) comparator + -> ('model_key, 'model_cmp) comparator + -> ('io_key, 'data, 'io_cmp) Map.t Value.t + -> get_model_key:('io_key -> 'data -> 'model_key) + -> f:('io_key Value.t -> 'data Value.t -> 'result Computation.t) + -> ('io_key, 'result, 'io_cmp) Map.t Computation.t + end + + module Debug : sig + (** [on_change v ~f] executes the function [f] every time that [v] is recomputed. *) + val on_change : 'a Value.t -> f:('a -> unit) -> unit Computation.t + + (** like [on_change], but specialized for printing a sexp of the value that you + are watching. *) + val on_change_print_s : 'a Value.t -> ('a -> Sexp.t) -> unit Computation.t + + val instrument_computation + : 'a Computation.t + -> start_timer:(string -> unit) + -> stop_timer:(string -> unit) + -> 'a Computation.t + + val to_dot : ?pre_process:bool -> 'a Computation.t -> string + val enable_incremental_annotations : unit -> unit + val disable_incremental_annotations : unit -> unit + end + + val path : Path.t Computation.t + + (** Analog to [Incr_map] functions in Bonsai. In general, you should prefer to use + [Bonsai.assoc] where possible. For functions that are particularly easy to implement + in terms of [assoc], the function is stubbed with a [ `Use_assoc ] value instead. We + also skip wrapping the prime versions of [Incr_map] functions, since they more easily + allow [Incr.bind], which we want to make sure is used only when absolutely necessary. *) + module Map : + Map0_intf.Output with module Value := Value and module Computation := Computation +end diff --git a/src/proc_layer2.ml b/src/proc_layer2.ml new file mode 100644 index 00000000..4f5245f0 --- /dev/null +++ b/src/proc_layer2.ml @@ -0,0 +1,442 @@ +open! Core +open! Import + +(* > What is [proc_layer2] and why is it needed? + The tower of bonsai implementations are as follows + 1. proc_min : the bare minimum bonsai combinators + 2. proc : includes bonsai combinators that can be built on top of proc_min + 3. cont : implements the local-graph API on top of proc + 4. proc_layer2 : re-implements the proc API on top of cont + + The reason that the 4th layer is necessary is so that its `Computation.t` can be defined + to be exactly `local_ Cont.graph -> 'a Cont.t` and its `Value.t` can be defined to be + exactly `'a Cont.t`. *) + +module type Model = Module_types.Model +module type Action = Module_types.Action +module type Enum = Module_types.Enum +module type Comparator = Module_types.Comparator + +type ('k, 'cmp) comparator = ('k, 'cmp) Module_types.comparator + +module Apply_action_context = Proc.Apply_action_context + +module Value = struct + type 'a t = 'a Cont.t + + let return a = Value.return a |> Cont.Conv.conceal_value + + (* we depend on Proc's [map] function so that we can keep passing + the [here] parameter for the let%arr and let%sub ppxes. *) + let map ?here v ~f = + Proc.Let_syntax.Let_syntax.map ?here (Cont.Conv.reveal_value v) ~f + |> Cont.Conv.conceal_value + ;; + + let transpose_opt opt = + Option.value_map opt ~default:(return None) ~f:(map ~f:Option.some) + ;; + + let cutoff a ~equal = + Cont.Conv.reveal_value a + |> Value.cutoff ~added_by_let_syntax:false ~equal + |> Cont.Conv.conceal_value + ;; + + module Mapn = struct + let map2 = Cont.map2 + let map3 = Cont.map3 + let map4 = Cont.map4 + let map5 = Cont.map5 + let map6 = Cont.map6 + let map7 = Cont.map7 + end + + include Mapn + + include Applicative.Make_using_map2 (struct + type nonrec 'a t = 'a t + + let return = return + let map2 = map2 + let map a ~f = map a ~f + let map = `Custom map + end) + + let both a b = + Value.both (Cont.Conv.reveal_value a) (Cont.Conv.reveal_value b) + |> Cont.Conv.conceal_value + ;; + + module Let_syntax = struct + let ( >>| ) a f = Value.map (Cont.Conv.reveal_value a) ~f |> Cont.Conv.conceal_value + + let ( <*> ) f a = + Value.map2 (Cont.Conv.reveal_value a) (Cont.Conv.reveal_value f) ~f:(fun a f -> f a) + |> Cont.Conv.conceal_value + ;; + + let ( <$> ) f a = + Cont.Conv.reveal_value a |> Value.map ~f:(fun a -> f a) |> Cont.Conv.conceal_value + ;; + + module Let_syntax = struct + let map ?here v ~f = + Proc.Let_syntax.Let_syntax.map ?here (Cont.Conv.reveal_value v) ~f + |> Cont.Conv.conceal_value + ;; + + let cutoff a ~equal = + Cont.Conv.reveal_value a + |> Proc.Let_syntax.Let_syntax.cutoff ~equal + |> Cont.Conv.conceal_value + ;; + + let both a b = + Value.both (Cont.Conv.reveal_value a) (Cont.Conv.reveal_value b) + |> Cont.Conv.conceal_value + ;; + + include Mapn + end + end +end + +module This_let_syntax = struct + let comp_return v graph = Cont.Conv.perform graph (Proc.read (Cont.Conv.reveal_value v)) + + include Value.Let_syntax + + let return = comp_return + + module Let_syntax = struct + include Value.Let_syntax.Let_syntax + + let subcomputation ?here a graph = + Cont.Conv.handle graph ~f:(fun graph -> a graph) |> Cont.Conv.perform ?here graph + ;; + + let sub ?here a ~f graph = f (subcomputation ?here a graph) graph + let return = comp_return + let arr ?here v ~f graph = Cont.For_proc2.arr1_with_location ?here graph v ~f + + let switch ~here:_ ~match_ ~branches ~with_ graph = + Cont.For_proc2.switch ~match_ ~branches ~with_ graph + ;; + end +end + +module Computation = struct + type 'a t = Cont.graph -> 'a Cont.t + + include Applicative.Make_using_map2 (struct + type nonrec 'a t = 'a t + + let return (a : 'a) : 'a t = fun _graph -> Value.return a + + let map2 a b ~f graph = + let a = a graph + and b = b graph in + Cont.arr2 graph a b ~f + ;; + + let map a ~f graph = Cont.arr1 graph (a graph) ~f + let map = `Custom map + end) + + let read = This_let_syntax.return + let computation_return = return + + open This_let_syntax + + let return = computation_return + + module Mapn = struct + let map2 = map2 + + let map3 t1 t2 t3 ~f = + let%sub t1 = t1 in + let%sub t2 = t2 in + let%sub t3 = t3 in + read (Value.Let_syntax.Let_syntax.map3 t1 t2 t3 ~f) + ;; + + let map4 t1 t2 t3 t4 ~f = + let%sub t1 = t1 in + let%sub t2 = t2 in + let%sub t3 = t3 in + let%sub t4 = t4 in + read (Value.Let_syntax.Let_syntax.map4 t1 t2 t3 t4 ~f) + ;; + + let map5 t1 t2 t3 t4 t5 ~f = + let%sub t1 = t1 in + let%sub t2 = t2 in + let%sub t3 = t3 in + let%sub t4 = t4 in + let%sub t5 = t5 in + read (Value.Let_syntax.Let_syntax.map5 t1 t2 t3 t4 t5 ~f) + ;; + + let map6 t1 t2 t3 t4 t5 t6 ~f = + let%sub t1 = t1 in + let%sub t2 = t2 in + let%sub t3 = t3 in + let%sub t4 = t4 in + let%sub t5 = t5 in + let%sub t6 = t6 in + read (Value.Let_syntax.Let_syntax.map6 t1 t2 t3 t4 t5 t6 ~f) + ;; + + let map7 t1 t2 t3 t4 t5 t6 t7 ~f = + let%sub t1 = t1 in + let%sub t2 = t2 in + let%sub t3 = t3 in + let%sub t4 = t4 in + let%sub t5 = t5 in + let%sub t6 = t6 in + let%sub t7 = t7 in + read (Value.Let_syntax.Let_syntax.map7 t1 t2 t3 t4 t5 t6 t7 ~f) + ;; + end + + include Mapn + + let rec all = function + | [] -> return [] + | [ t1 ] -> map t1 ~f:(fun a1 -> [ a1 ]) + | [ t1; t2 ] -> map2 t1 t2 ~f:(fun a1 a2 -> [ a1; a2 ]) + | [ t1; t2; t3 ] -> map3 t1 t2 t3 ~f:(fun a1 a2 a3 -> [ a1; a2; a3 ]) + | [ t1; t2; t3; t4 ] -> map4 t1 t2 t3 t4 ~f:(fun a1 a2 a3 a4 -> [ a1; a2; a3; a4 ]) + | [ t1; t2; t3; t4; t5 ] -> + map5 t1 t2 t3 t4 t5 ~f:(fun a1 a2 a3 a4 a5 -> [ a1; a2; a3; a4; a5 ]) + | [ t1; t2; t3; t4; t5; t6 ] -> + map6 t1 t2 t3 t4 t5 t6 ~f:(fun a1 a2 a3 a4 a5 a6 -> [ a1; a2; a3; a4; a5; a6 ]) + | [ t1; t2; t3; t4; t5; t6; t7 ] -> + map7 t1 t2 t3 t4 t5 t6 t7 ~f:(fun a1 a2 a3 a4 a5 a6 a7 -> + [ a1; a2; a3; a4; a5; a6; a7 ]) + | t1 :: t2 :: t3 :: t4 :: t5 :: t6 :: t7 :: rest -> + let left = + map7 t1 t2 t3 t4 t5 t6 t7 ~f:(fun a1 a2 a3 a4 a5 a6 a7 -> + [ a1; a2; a3; a4; a5; a6; a7 ]) + in + let right = all rest in + map2 left right ~f:(fun left right -> left @ right) + ;; + + let all xs = Let_syntax.subcomputation (all xs) + + let reduce_balanced xs ~f = + List.reduce_balanced xs ~f:(fun a b -> + let%sub a = a in + let%sub b = b in + f a b) + ;; + + let reduce_balanced xs ~f = + match xs with + | [] -> None + | _ -> Some (Let_syntax.subcomputation (Option.value_exn (reduce_balanced xs ~f))) + ;; + + let fold_right xs ~f ~init = + List.fold_right xs ~init:(read init) ~f:(fun a b -> + let%sub a = a in + let%sub b = b in + f a b) + ;; + + let fold_right xs ~f ~init = Let_syntax.subcomputation (fold_right xs ~f ~init) + let all_unit xs = all xs |> map ~f:(fun (_ : unit list) -> ()) + let all_unit xs = Let_syntax.subcomputation (all_unit xs) + + let all_map map_of_computations = + map_of_computations + |> Map.to_alist + |> List.map ~f:(fun (key, data) -> map data ~f:(Tuple2.create key)) + |> all + |> map ~f:(Map.of_alist_exn (Map.comparator_s map_of_computations)) + ;; + + let all_map map_of_computations = + Let_syntax.subcomputation (all_map map_of_computations) + ;; + + module Let_syntax = struct + let return = return + + include Applicative_infix + + module Let_syntax = struct + let return = return + let map = map + let both = both + + include Mapn + end + end +end + +module Var = struct + include Proc.Var + + let value var = Cont.For_proc2.conceal_value (Proc.Var.value var) +end + +module Effect = Effect +module Private_value = Value +module Private_computation = Computation + +module For_open = struct + module Computation = Computation + module Effect = Effect + module Value = Value +end + +include ( + Cont : + module type of Cont + with module Let_syntax := Cont.Let_syntax + with module Apply_action_context := Apply_action_context) + +include Cont.For_proc2 +open Cont.Let_syntax + +open struct + module Map = Core.Map +end + +let read v _graph = v +let const a _graph = return a +let pure f i _graph = map i ~f +let scope_model cmp ~on for_ = scope_model cmp ~on ~for_ +let yoink = peek + +module Clock = struct + include Clock + + let every ~when_to_start_next_effect ?trigger_on_activate time_span callback graph = + every ~when_to_start_next_effect ?trigger_on_activate time_span callback graph; + return () + ;; +end + +module Incr = struct + include Incr + + let with_clock f = with_clock ~f +end + +module Edge = struct + include Edge + + let on_change = For_proc2.on_change + let on_change' = For_proc2.on_change' + let lifecycle = For_proc2.lifecycle + let lifecycle' = For_proc2.lifecycle' + let after_display = For_proc2.after_display + let after_display' = For_proc2.after_display' + + module Poll = struct + include Poll + + let manual_refresh = For_proc2.manual_refresh + end +end + +module Debug = struct + include Debug + + let on_change = debug_on_change + let on_change_print_s = debug_on_change_print_s +end + +module Expert = struct + include Expert + + let thunk f graph = thunk ~f graph +end + +let of_module1 + (type i m a r) + ?sexp_of_model + (component : (i, m, a, r) component_s) + ?equal + ~default_model + input + graph + = + let (module M) = component in + let model, inject = + Cont.state_machine1 + ~sexp_of_action:M.Action.sexp_of_t + ?sexp_of_model + ?equal + ~default_model + ~apply_action:(fun ctx input model action -> + match input with + | Active input -> M.apply_action ctx input model action + | Inactive -> + eprint_s + [%message + "An action sent to an [of_module1] has been dropped because its input was \ + not present. This happens when the [of_module1] is inactive when it \ + receives a message." + (action : M.Action.t)]; + model) + input + graph + in + let%map model = model + and inject = inject + and input = input in + M.compute ~inject input model +;; + +let of_module0 + (type m a r) + ?sexp_of_model + ?equal + (component : (unit, m, a, r) component_s) + ~default_model + graph + = + let (module M) = component in + let model, inject = + Cont.state_machine0 + ~sexp_of_action:M.Action.sexp_of_t + ?sexp_of_model + ?equal + ~default_model + ~apply_action:(fun ctx -> M.apply_action ctx ()) + graph + in + let%map model = model + and inject = inject in + M.compute ~inject () model +;; + +let of_module2 ?sexp_of_model c ?equal ~default_model i1 i2 = + of_module1 ?sexp_of_model c ?equal ~default_model (both i1 i2) +;; + +let enum (type k) (module E : Enum with type t = k) ~match_ ~with_ graph = + let module E = struct + include E + include Comparator.Make (E) + end + in + let forward_index = List.to_array E.all in + let reverse_index = + Map.of_alist_exn (module E) (List.mapi E.all ~f:(fun i k -> k, i)) + in + let match_ = match_ >>| Map.find_exn reverse_index in + let branches = Array.length forward_index in + let with_ i = with_ (Array.get forward_index i) in + For_proc2.switch ~match_ ~branches ~with_ graph +;; + +let sub = This_let_syntax.Let_syntax.sub + +module Map = Cont.Map +module Let_syntax = This_let_syntax diff --git a/src/proc_layer2.mli b/src/proc_layer2.mli new file mode 100644 index 00000000..4fa329e3 --- /dev/null +++ b/src/proc_layer2.mli @@ -0,0 +1,7 @@ +open! Core +open! Import + +include + Proc_intf.S + with type 'a Value.t = 'a Cont.t + and type 'a Computation.t = Cont.graph -> 'a Cont.t diff --git a/src/proc_min.ml b/src/proc_min.ml index fdb84652..cb96fd4c 100644 --- a/src/proc_min.ml +++ b/src/proc_min.ml @@ -21,14 +21,13 @@ let sub (type via) ?here (from : via Computation.t) ~f = let switch ~here ~match_ ~branches ~with_ = let arms = - Int.Map.of_increasing_sequence - (Sequence.map (Sequence.range 0 branches) ~f:(fun key -> - let computation = - try with_ key with - | exn -> read (Value.return_exn exn) - in - key, computation)) - |> Or_error.ok_exn + List.init branches ~f:(fun key -> + let computation = + try with_ key with + | exn -> read (Value.return_exn exn) + in + key, computation) + |> Int.Map.of_alist_exn in Switch { match_; arms; here } ;; diff --git a/src/proc_min.mli b/src/proc_min.mli index c01cc291..018997d4 100644 --- a/src/proc_min.mli +++ b/src/proc_min.mli @@ -88,17 +88,17 @@ val state_machine0 val assoc : ('k, 'cmp) comparator - -> ('k, 'v, 'cmp) Map_intf.Map.t Value.t + -> ('k, 'v, 'cmp) Map.t Value.t -> f:('k Value.t -> 'v Value.t -> 'result Computation.t) - -> ('k, 'result, 'cmp) Map_intf.Map.t Computation.t + -> ('k, 'result, 'cmp) Map.t Computation.t val assoc_on : ('io_k, 'io_cmp) comparator -> ('model_k, 'model_cmp) comparator - -> ('io_k, 'v, 'io_cmp) Map_intf.Map.t Value.t + -> ('io_k, 'v, 'io_cmp) Map.t Value.t -> get_model_key:('io_k -> 'v -> 'model_k) -> f:('io_k Value.t -> 'v Value.t -> 'a Computation.t) - -> ('io_k, 'a, 'io_cmp) Map_intf.Map.t Computation.t + -> ('io_k, 'a, 'io_cmp) Map.t Computation.t val lazy_ : 'a Computation.t lazy_t -> 'a Computation.t diff --git a/src/protocol/dune b/src/protocol/dune index fba4daea..851d7fdd 100644 --- a/src/protocol/dune +++ b/src/protocol/dune @@ -1,2 +1,6 @@ -(library (name bonsai_protocol) (libraries core bonsai core_kernel.uuid) - (public_name bonsai.protocol) (preprocess (pps ppx_jane))) \ No newline at end of file +(library + (name bonsai_protocol) + (libraries core bonsai core_kernel.uuid) + (public_name bonsai.protocol) + (preprocess + (pps ppx_jane))) diff --git a/src/value.ml b/src/value.ml index 7dc67e9e..ece2d0be 100644 --- a/src/value.ml +++ b/src/value.ml @@ -210,7 +210,10 @@ let eval env t = let return a = { value = Constant a; here = None; id = value_id "return" } let return_exn exn = { value = Exception exn; here = None; id = value_id "return exn" } -let of_opt opt = Option.value_map opt ~default:(return None) ~f:(map ~f:Option.some) + +let transpose_opt opt = + Option.value_map opt ~default:(return None) ~f:(map ~f:Option.some) +;; include Applicative.Make_using_map2 (struct type nonrec 'a t = 'a t diff --git a/src/value.mli b/src/value.mli index 6bd25ae0..f0c906d8 100644 --- a/src/value.mli +++ b/src/value.mli @@ -96,4 +96,4 @@ val cutoff : added_by_let_syntax:bool -> 'a t -> equal:('a -> 'a -> bool) -> 'a val eval : Environment.t -> 'a t -> 'a Incr.t val of_incr : 'a Incr.t -> 'a t val return_exn : exn -> 'a t -val of_opt : 'a t option -> 'a option t +val transpose_opt : 'a t option -> 'a option t diff --git a/test/driver.ml b/test/driver.ml index 05fe83ad..e7630890 100644 --- a/test/driver.ml +++ b/test/driver.ml @@ -3,18 +3,11 @@ open! Import type ('i, 'r) t = { input_var : 'i Incr.Var.t - ; mutable last_view : string + ; mutable last_view : string Lazy.t ; handle : 'r Bonsai_driver.t } -let create - (type i r) - ?(optimize = true) - ~clock - ~(initial_input : i) - (component : (i, r) Bonsai.Arrow_deprecated.t) - : (i, r) t - = +let create ?optimize ~clock ~initial_input component = let input_var, computation = let input_var = Incr.Var.create initial_input in let computation = @@ -26,8 +19,8 @@ let create in input_var, computation in - let handle = Bonsai_driver.create ~optimize ~clock computation in - { input_var; last_view = ""; handle } + let handle = Bonsai_driver.create ?optimize ~clock computation in + { input_var; last_view = lazy ""; handle } ;; let set_input { input_var; _ } input = Incr.Var.set input_var input diff --git a/test/driver.mli b/test/driver.mli index 6acf65b9..d9421a2f 100644 --- a/test/driver.mli +++ b/test/driver.mli @@ -7,7 +7,7 @@ val create : ?optimize:bool -> clock:Bonsai.Time_source.t -> initial_input:'i - -> ('i, 'r) Bonsai.Arrow_deprecated.t + -> ('i Bonsai.Value.t -> Bonsai.Cont.graph -> 'r Bonsai.Cont.t) -> ('i, 'r) t val set_input : ('i, _) t -> 'i -> unit @@ -17,8 +17,8 @@ val flush : _ t -> unit val schedule_event : _ t -> unit Ui_effect.t -> unit val result : (_, 'r) t -> 'r -val last_view : _ t -> string -val store_view : _ t -> string -> unit +val last_view : _ t -> string Lazy.t +val store_view : _ t -> string Lazy.t -> unit val trigger_lifecycles : _ t -> unit val has_after_display_events : _ t -> bool val sexp_of_model : _ t -> Sexp.t diff --git a/test/dune b/test/dune index 8e9f8339..e7c6c0e3 100644 --- a/test/dune +++ b/test/dune @@ -1,4 +1,7 @@ -(library (name bonsai_test) (public_name bonsai.test) +(library + (name bonsai_test) + (public_name bonsai.test) (libraries bonsai bonsai_driver patdiff.expect_test_patdiff core - expect_test_helpers_core) - (preprocess (pps ppx_jane ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + expect_test_helpers_core async_js.test_handle_garbage_collector) + (preprocess + (pps ppx_jane ppx_pattern_bind ppx_bonsai))) diff --git a/test/of_bonsai_itself/dune b/test/of_bonsai_itself/dune index dd72e620..c4130b7f 100644 --- a/test/of_bonsai_itself/dune +++ b/test/of_bonsai_itself/dune @@ -1,6 +1,8 @@ -(library (name bonsai_test_of_bonsai_itself) +(library + (name bonsai_test_of_bonsai_itself) (public_name bonsai.test_of_bonsai_itself) (libraries bonsai bonsai_test bonsai_extra bonsai_driver - patdiff.expect_test_patdiff core_kernel.composition_infix core - expect_test_helpers_core incr_map re) - (preprocess (pps ppx_jane ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + patdiff.expect_test_patdiff core_kernel.composition_infix core + expect_test_helpers_core incr_map re) + (preprocess + (pps ppx_jane ppx_pattern_bind ppx_bonsai))) diff --git a/test/test_action_stabilization.ml b/test/of_bonsai_itself/test_action_stabilization.ml similarity index 99% rename from test/test_action_stabilization.ml rename to test/of_bonsai_itself/test_action_stabilization.ml index ea50d71b..b888ea6e 100644 --- a/test/test_action_stabilization.ml +++ b/test/of_bonsai_itself/test_action_stabilization.ml @@ -2,7 +2,7 @@ open! Core open! Import open Bonsai.For_open open Bonsai.Let_syntax -open Proc +open Bonsai_test let no_op_sm0 = Bonsai.state_machine0 ~apply_action:(fun _context () () -> ()) ~default_model:() () @@ -708,7 +708,7 @@ let%test_module "pruning" = let%sub _, inject_second = no_op_sm1 in let%arr inject_first = inject_first and inject_second = inject_second in - Effect.Many [ inject_first (); inject_second () ] + Ui_effect.Many [ inject_first (); inject_second () ] ;; let run_assoc_test assoc_impl = diff --git a/test/test_action_stabilization.mli b/test/of_bonsai_itself/test_action_stabilization.mli similarity index 100% rename from test/test_action_stabilization.mli rename to test/of_bonsai_itself/test_action_stabilization.mli diff --git a/test/of_bonsai_itself/test_constant_fold.ml b/test/of_bonsai_itself/test_constant_fold.ml index c09e9809..2a87890d 100644 --- a/test/of_bonsai_itself/test_constant_fold.ml +++ b/test/of_bonsai_itself/test_constant_fold.ml @@ -4,27 +4,26 @@ open Bonsai.For_open open Bonsai.Let_syntax module Private = Bonsai.Private -let constant_fold computation = - computation - |> Private.reveal_computation +let constant_fold computation graph = + Private.handle graph ~f:computation |> Private.Constant_fold.constant_fold - |> Private.conceal_computation + |> Private.perform graph ;; let sexp_of_computation c = c - |> Private.reveal_computation |> Private.Skeleton.Computation.of_computation |> Private.Skeleton.Computation.sanitize_for_testing |> Private.Skeleton.Computation.minimal_sexp_of_t ;; -let print_computation c = print_s (sexp_of_computation c) +let print_computation c = print_s (sexp_of_computation (Private.top_level_handle c)) let constant_fold_and_assert_no_op computation = - let after_computation = constant_fold computation in - let before_sexp = sexp_of_computation computation in - let after_sexp = sexp_of_computation after_computation in + let lowered = Private.top_level_handle computation in + let optimized = Private.Constant_fold.constant_fold lowered in + let before_sexp = sexp_of_computation lowered in + let after_sexp = sexp_of_computation optimized in match Sexp.equal before_sexp after_sexp with | true -> print_s before_sexp | false -> @@ -35,9 +34,10 @@ let constant_fold_and_assert_no_op computation = ;; let constant_fold_and_diff computation = - let after_computation = constant_fold computation in - let before_sexp = sexp_of_computation computation in - let after_sexp = sexp_of_computation after_computation in + let lowered = Private.top_level_handle computation in + let optimized = Private.Constant_fold.constant_fold lowered in + let before_sexp = sexp_of_computation lowered in + let after_sexp = sexp_of_computation optimized in Expect_test_patdiff.print_patdiff_s before_sexp after_sexp ;; @@ -209,13 +209,9 @@ let%expect_test "lazies inside of a switch with static input are forced" = print_computation c; [%expect {| - (Sub - (from (Return (value (Constant (id (Test 0)))))) - (via (Test 1)) - (into ( - Switch - (match_ (Mapn (inputs ((Named (uid (Test 1))))))) - (arms ((Lazy (t ())) (Return (value Exception))))))) |}]; + (Switch + (match_ (Mapn (inputs ((Constant (id (Test 0))))))) + (arms ((Lazy (t ())) (Return (value Exception))))) |}]; print_computation (constant_fold c); [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; @@ -291,8 +287,7 @@ let%expect_test "map2_of_map2_of_constants_gets_folded" = (Constant (id (Test 0))) (Constant (id (Test 1))))))))))))))))) |}]; print_computation (constant_fold doubled); - [%expect {| - (Return (value (Constant (id (Test 0))))) |}] + [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; let%expect_test "cutoff" = @@ -300,8 +295,8 @@ let%expect_test "cutoff" = print_computation cutoff; [%expect {| - (Return ( - value (Cutoff (t (Constant (id (Test 0)))) (added_by_let_syntax false)))) |}]; + (Return ( + value (Cutoff (t (Constant (id (Test 0)))) (added_by_let_syntax false)))) |}]; print_computation (constant_fold cutoff); [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; @@ -323,8 +318,7 @@ let%expect_test "errors_propagate_but_are_not_thrown" = inputs (( Mapn (inputs ((Mapn (inputs ((Constant (id (Test 0)))))) Incr)))))))) |}]; print_computation (constant_fold c); - [%expect {| - (Return (value Exception)) |}] + [%expect {| (Return (value Exception)) |}] ;; let%expect_test "cutoff gets folded away" = @@ -514,8 +508,7 @@ let%expect_test "constant map + simplifiable assoc function => constant map" = (Named (uid (Test 1))) (Named (uid (Test 3))))))))))))) |}]; print_computation (constant_fold c); - [%expect {| - (Return (value (Constant (id (Test 0))))) |}] + [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; let%expect_test "a constant input with no external dependencies is folded into a constant" @@ -559,15 +552,11 @@ let%expect_test "a switch with constant input is optimized away" = print_computation c; [%expect {| - (Sub - (from (Return (value (Constant (id (Test 0)))))) - (via (Test 1)) - (into ( - Switch - (match_ (Mapn (inputs ((Named (uid (Test 1))))))) - (arms ( - (Return (value (Constant (id (Test 3))))) - (Return (value (Constant (id (Test 4)))))))))) |}]; + (Switch + (match_ (Mapn (inputs ((Constant (id (Test 0))))))) + (arms ( + (Return (value (Constant (id (Test 2))))) + (Return (value (Constant (id (Test 3)))))))) |}]; print_computation (constant_fold c); [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; @@ -581,14 +570,11 @@ let%expect_test "an assert-false is caught (and then optimized away)" = print_computation c; [%expect {| - (Sub - (from (Return (value (Constant (id (Test 0)))))) - (via (Test 1)) - (into ( - Switch - (match_ (Mapn (inputs ((Named (uid (Test 1))))))) - (arms ( - (Return (value (Constant (id (Test 3))))) (Return (value Exception))))))) |}]; + (Switch + (match_ (Mapn (inputs ((Constant (id (Test 0))))))) + (arms ((Return (value (Constant (id (Test 2))))) (Return (value Exception))))) |}]; + print_computation (constant_fold c); + [%expect {| (Return (value (Constant (id (Test 0))))) |}]; print_computation (constant_fold c); [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; diff --git a/test/of_bonsai_itself/test_cont_bonsai.ml b/test/of_bonsai_itself/test_cont_bonsai.ml new file mode 100644 index 00000000..57825d32 --- /dev/null +++ b/test/of_bonsai_itself/test_cont_bonsai.ml @@ -0,0 +1,6941 @@ +open! Core +open! Import +open! Bonsai_test + +module Bonsai = struct + include Bonsai.Cont + module Private = Bonsai.Private + module Var = Bonsai.Var + module Effect = Bonsai.Effect +end + +module Effect = Bonsai.Effect +open Bonsai.Let_syntax + +let sexp_of_computation : type a. ?optimize:bool -> (Bonsai.graph -> a Bonsai.t) -> Sexp.t + = + fun ?(optimize = true) c -> + Bonsai.Private.top_level_handle c + |> (if optimize then Bonsai.Private.pre_process else Fn.id) + |> Bonsai.Private.Skeleton.Computation.of_computation + |> Bonsai.Private.Skeleton.Computation.sanitize_for_testing + |> Bonsai.Private.Skeleton.Computation.minimal_sexp_of_t +;; + +let%expect_test "cutoff" = + let var = Bonsai.Var.create 0 in + let value = Bonsai.Var.value var in + let component graph = + Bonsai.Incr.value_cutoff value ~equal:(fun a b -> a % 2 = b % 2) graph + in + let handle = Handle.create (Result_spec.string (module Int)) component in + Handle.show handle; + [%expect {| 0 |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| 0 |}]; + Bonsai.Var.set var 1; + Handle.show handle; + [%expect {| 1 |}] +;; + +let%expect_test "debug on change" = + let var = Bonsai.Var.create 0 in + let value = Bonsai.Var.value var in + let component graph = + Bonsai.Debug.on_change value graph ~f:(fun i -> printf "%d" i); + return () + in + let handle = Handle.create Result_spec.invisible component in + Handle.show handle; + [%expect {| 0 |}]; + Bonsai.Var.set var 1; + Handle.show handle; + [%expect {| 1 |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| 2 |}] +;; + +let%expect_test "Setting cutoff on Bonsai values should not change previously set cutoffs" + = + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component graph = + let pair = Bonsai.Incr.value_cutoff value graph ~equal:phys_equal in + let (_ : _ Bonsai.t) = + Bonsai.Incr.value_cutoff value graph ~equal:(fun (a1, _) (a2, _) -> a1 = a2) + in + pair + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int * int [@@deriving sexp] + end)) + component + in + Handle.show handle; + [%expect {| (0 0) |}]; + Bonsai.Var.set var (1, 0); + Handle.show handle; + [%expect {| (1 0) |}]; + Bonsai.Var.set var (1, 2); + Handle.show handle; + [%expect {| (1 2) |}] +;; + +let%expect_test "Cutoff set by let%arr ppx should not be applied to different \ + incremental nodes" + = + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component _graph = + let%sub pair = value in + let%sub _ = + let%arr a, _ = value in + a + in + pair + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int * int [@@deriving sexp] + end)) + component + in + Handle.show handle; + [%expect {| (0 0) |}]; + Bonsai.Var.set var (1, 0); + Handle.show handle; + [%expect {| (1 0) |}]; + Bonsai.Var.set var (1, 2); + Handle.show handle; + [%expect {| (1 2) |}] +;; + +let%expect_test "Cutoff propragates on named values regression" = + (* This test tests against a regression on [cutoff]. + + Since named values are evaled into a map, and + [Value.cutoff] compiled to the mutable [Incremental.set_cutoff], everytime + that set_cutoff happens it affects all occurrences of the named value. + + This is tested for here by giving the same named value node different + cutoff functions (one for the left element and another for the second element) + and showcasing that each node is not affected by the other cutoff node. + *) + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component graph = + let tupled_input = value in + let left = + let tupled_input = + Bonsai.Incr.value_cutoff tupled_input graph ~equal:(fun (old, _) (new_, _) -> + phys_equal old new_) + in + let%map left, _ = tupled_input in + left + in + let right = + let tupled_input = + Bonsai.Incr.value_cutoff tupled_input graph ~equal:(fun (_, old) (_, new_) -> + phys_equal old new_) + in + let%map _, right = tupled_input in + right + in + let%map left = left + and right = right in + left, right + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int * int [@@deriving sexp] + end)) + component + in + Handle.show handle; + [%expect {| (0 0) |}]; + (* First element changes. *) + Bonsai.Var.set var (1, 0); + (* Missed trigger! *) + Handle.show handle; + [%expect {| (1 0) |}]; + Bonsai.Var.set var (1, 2); + (* When the second element changes, this is fine since its cutoff function + won.*) + Handle.show handle; + [%expect {| (1 2) |}] +;; + +let%expect_test "What happens when cutoff nodes are nested?" = + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component graph = + let first_cutoff = + Bonsai.Incr.value_cutoff value graph ~equal:(fun (_, a) (_, b) -> phys_equal a b) + in + let second_cutoff = + Bonsai.Incr.value_cutoff first_cutoff graph ~equal:(fun (a, _) (b, _) -> + phys_equal a b) + in + second_cutoff + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int * int [@@deriving sexp] + end)) + component + in + print_s (sexp_of_computation component); + [%expect + {| + (Sub + (from ( + Return ( + value ( + Cutoff + (t Incr) + (added_by_let_syntax false))))) + (via (Test 2)) + (into ( + Return ( + value (Cutoff (t (Named (uid (Test 2)))) (added_by_let_syntax false)))))) |}]; + Handle.show handle; + [%expect {| (0 0) |}]; + (* First element changes. *) + Bonsai.Var.set var (1, 0); + Handle.show handle; + (* Does not recompute! (first cutoff still says they're equal.) *) + [%expect {| (0 0) |}]; + (* Second element changes. *) + Bonsai.Var.set var (0, 2); + (* Does not recompute! (second cutoff still says they're equal.) *) + Handle.show handle; + [%expect {| (0 0) |}]; + Bonsai.Var.set var (1, 2); + Handle.show handle; + [%expect {| (0 0) |}]; + Bonsai.Var.set var (2, 3); + (* Only once both cutoffs say that they're unequal, recomputation happens. *) + Handle.show handle; + [%expect {| (2 3) |}] +;; + +let%expect_test "arrow-syntax" = + let component _graph = + let a = return "hi" in + let b = return 5 in + let%map a = a + and b = b in + sprintf "%s %d" a b + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| hi 5 |}] +;; + +let%expect_test "if%sub" = + let component (input : bool Bonsai.t) _graph = + let a = return "hello" in + let b = return "world" in + if%sub input then a else b + in + let var = Bonsai.Var.create true in + print_s (sexp_of_computation (component (Bonsai.Var.value var))); + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 2)) + (into ( + Switch + (match_ (Named (uid (Test 2)))) + (arms ( + (Return (value (Constant (id (Test 3))))) + (Return (value (Constant (id (Test 4)))))))))) |}]; + let handle = + Handle.create (Result_spec.string (module String)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| hello |}]; + Bonsai.Var.set var false; + Handle.show handle; + [%expect {| world |}] +;; + +let%expect_test "call component" = + let add_one x = + let%map x = x in + x + 1 + in + let component input _graph = add_one input in + let var = Bonsai.Var.create 1 in + let handle = + Handle.create (Result_spec.sexp (module Int)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| 2 |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| 3 |}] +;; + +let%expect_test "store named in a ref (simple)" = + (* see [test_cont_store_named_in_a_ref.ml] for a more complete example *) + let name_ref = ref None in + let component graph = + let x = + let a = opaque_const 5 graph in + name_ref := Some a; + let%map a = a in + a + in + let%map x = x + and y = Option.value_exn !name_ref in + x + y + in + (* does not raise *) + let (_ : _) = Handle.create (Result_spec.sexp (module Int)) component in + [%expect {| |}] +;; + +let%expect_test "on_display" = + let component graph = + let state, set_state = Bonsai.state 0 graph in + let update = + let%map state = state + and set_state = set_state in + set_state (state + 1) + in + let () = Bonsai.Edge.after_display update graph in + state + in + let handle = Handle.create (Result_spec.sexp (module Int)) component in + Handle.show handle; + [%expect {| 0 |}]; + Handle.show handle; + [%expect {| 1 |}]; + Handle.show handle; + [%expect {| 2 |}]; + Handle.show handle; + [%expect {| 3 |}] +;; + +let%expect_test "on_display for updating a state" = + let component input graph = + let state, set_state = Bonsai.state_opt graph in + let update = + match%sub state with + | None -> + let%map set_state = set_state + and input = input in + Some (set_state (Some input)) + | Some state -> + let%map state = state + and set_state = set_state + and input = input in + if Int.equal state input then None else Some (set_state (Some input)) + in + let () = Bonsai.Edge.after_display' update graph in + Bonsai.both input state + in + let var = Bonsai.Var.create 1 in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int * int option [@@deriving sexp_of] + end)) + (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| (1 ()) |}]; + Handle.show handle; + [%expect {| (1 (1)) |}]; + Handle.show handle; + [%expect {| (1 (1)) |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| (2 (1)) |}]; + Handle.show handle; + [%expect {| (2 (2)) |}]; + Handle.show handle; + [%expect {| (2 (2)) |}] +;; + +let%expect_test "path" = + let component graph = + let (_ : unit Bonsai.t) = opaque_const () graph in + let path = Bonsai.path graph in + Bonsai.map path ~f:Bonsai.Path.sexp_of_t + in + let handle = Handle.create (Result_spec.sexp (module Sexp)) component in + Handle.show handle; + (* The first of these "Subst_from" is actually a component that is + added by the testing helpers. *) + [%expect {| (Subst_from Subst_from) |}] +;; + +let%expect_test "path inside enum" = + let component graph = + let r = + Bonsai.Let_syntax.Let_syntax.switch + ~here:[%here] + ~match_:(opaque_const_value 0) + ~with_:(fun _ -> Bonsai.path graph) + ~branches:1 + in + r + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = Bonsai.Private.Path.t [@@deriving sexp_of] + end)) + component + in + Handle.show handle; + [%expect {| (Subst_from (Switch 0)) |}] +;; + +let%expect_test "assoc and enum path " = + let component graph = + Bonsai.assoc + (module Int) + (opaque_const_value (Int.Map.of_alist_exn [ -1, (); 1, () ])) + graph + ~f:(fun i _ graph -> + if%sub i >>| ( > ) 0 then Bonsai.path graph else Bonsai.path graph) + in + sexp_of_computation component |> print_s; + [%expect + {| + (Assoc + (map Incr) + (key_id (Test 1)) + (cmp_id (Test 2)) + (data_id (Test 3)) + (by ( + Sub + (from (Return (value (Mapn (inputs ((Named (uid (Test 1))))))))) + (via (Test 5)) + (into ( + Sub + (from (Return (value (Mapn (inputs ((Named (uid (Test 5))))))))) + (via (Test 7)) + (into (Switch (match_ (Named (uid (Test 7)))) (arms (Path Path))))))))) |}]; + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = Bonsai.Private.Path.t Int.Map.t [@@deriving sexp_of] + end)) + component + in + Handle.show handle; + [%expect + {| + ((-1 (Subst_from (Assoc -1) Subst_into Subst_into (Switch 0))) + (1 (Subst_from (Assoc 1) Subst_into Subst_into (Switch 1)))) |}] +;; + +let%expect_test "constant folded assoc path" = + let component graph = + Bonsai.assoc + (module Int) + (return (Int.Map.of_alist_exn [ -1, (); 1, () ])) + graph + ~f:(fun _ _ graph -> + (* NOTE: Since this test case uses both a constant map and previously + only made use of the path, then this combination resulted in the optimization + that makes a call to Map.mapi directly to trigger. To avoid this, we + artifically introduce some state, and more importantly, use the state trivially + such that the simplication optimization is not triggered. *) + let x, _ = Bonsai.state 0 graph in + let path = Bonsai.path graph in + let%sub path, _ = + let%map path = path + and x = x in + path, x + in + path) + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = Bonsai.Private.Path.t Int.Map.t [@@deriving sexp_of] + end)) + component + in + Handle.show handle; + [%expect + {| + ((-1 + (Subst_from Subst_from Subst_from Subst_from Subst_into Subst_into + Subst_into Subst_from)) + (1 + (Subst_from Subst_from Subst_into Subst_from Subst_from Subst_into + Subst_into Subst_into Subst_from))) |}] +;; + +let%expect_test "constant folded assoc lifecycles are unchanged" = + let runtest input = + let component graph = + let (_ : (int, unit, _) Map.t Bonsai.t) = + Bonsai.assoc + (module Int) + (input (Int.Map.of_alist_exn [ -1, (); 1, () ])) + graph + ~f:(fun key _ graph -> + Bonsai.Edge.lifecycle + ~on_activate: + (let%map key = key in + Bonsai.Effect.print_s [%message (key : int)]) + graph; + return ()) + in + return () + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.show handle + in + runtest opaque_const_value; + let unoptimized = Expect_test_helpers_base.expect_test_output [%here] in + runtest Bonsai.return; + let optimized = Expect_test_helpers_base.expect_test_output [%here] in + print_endline (Expect_test_patdiff.patdiff ~context:0 unoptimized optimized) +;; + +let%expect_test "constant map + simplifiable assoc ~f => constant map proper evaluation" = + (* This test case just tests that the map function is applied properly. *) + let component graph = + Bonsai.assoc + (module String) + (return (String.Map.of_alist_exn [ "hello", 0; "world", 5 ])) + graph + ~f:(fun _ v _graph -> + let%map v = v in + v + 100) + in + let module Model = struct + type t = int String.Map.t [@@deriving sexp, equal] + end + in + let handle = Handle.create (Result_spec.sexp (module Model)) component in + Handle.show handle; + [%expect {| ((hello 100) (world 105)) |}] +;; + +let%expect_test "assoc_on" = + let var = Bonsai.Var.create (Int.Map.of_alist_exn [ 0, (); 1, (); 2, () ]) in + let component = + Bonsai.Expert.assoc_on + (module Int) + (module Int) + (Bonsai.Var.value var) + ~get_model_key:(fun key _data -> key % 2) + ~f:(fun _key _data graph -> + let model, inject = + Bonsai.state_machine1 + ~default_model:0 + ~apply_action:(fun _ctx input model new_model -> + match input with + | Active () -> new_model + | Inactive -> + print_endline "inactive"; + model) + (opaque_const_value ()) + graph + in + Bonsai.both model inject) + in + let handle = + Handle.create + (module struct + type t = (int * (int -> unit Effect.t)) Int.Map.t + type incoming = Nothing.t + + let incoming _ = Nothing.unreachable_code + + let view (map : t) = + map + |> Map.to_alist + |> List.map ~f:(fun (i, (s, _)) -> i, s) + |> [%sexp_of: (int * int) list] + |> Sexp.to_string_hum + ;; + end) + component + in + Handle.show handle; + [%expect {| ((0 0) (1 0) (2 0)) |}]; + let result = Handle.last_result handle in + let set_two what = + let _, set = Map.find_exn result 2 in + Ui_effect.Expert.handle (set what) + in + set_two 3; + Handle.show handle; + [%expect {| ((0 3) (1 0) (2 3)) |}]; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, () ]); + Handle.show handle; + [%expect {| ((1 0)) |}]; + set_two 4; + Handle.show handle; + [%expect {| + inactive + ((1 0)) |}]; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, (); 2, () ]); + Handle.show handle; + [%expect {| ((1 0) (2 3)) |}] +;; + +let%expect_test "simplify assoc_on" = + let var = Bonsai.Var.create (Int.Map.of_alist_exn [ 0, (); 1, (); 2, () ]) in + let component graph = + Bonsai.Expert.assoc_on + (module Int) + (module Int) + (Bonsai.Var.value var) + graph + ~get_model_key:(fun key _data -> key % 2) + ~f:(fun _key data _graph -> data) + in + component |> sexp_of_computation ~optimize:true |> print_s; + [%expect {| (Assoc_simpl (map Incr)) |}] +;; + +let%expect_test "simple-assoc works with paths" = + let component = + Bonsai.assoc + (module String) + (opaque_const_value (String.Map.of_alist_exn [ "hello", (); "world", () ])) + ~f:(fun _ _ graph -> + let a = Bonsai.path graph in + let b = Bonsai.path graph in + Bonsai.both a b) + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = (Bonsai.Private.Path.t * Bonsai.Private.Path.t) String.Map.t + [@@deriving sexp_of] + end)) + component + in + Handle.show handle; + [%expect + {| + ((hello + ((Subst_from (Assoc hello) Subst_from) + (Subst_from (Assoc hello) Subst_into Subst_from))) + (world + ((Subst_from (Assoc world) Subst_from) + (Subst_from (Assoc world) Subst_into Subst_from)))) |}]; + component |> sexp_of_computation ~optimize:true |> print_s; + [%expect {| (Assoc_simpl (map Incr)) |}] +;; + +let test_assoc_simpl_on_cutoff ~added_by_let_syntax = + let cutoff value ~equal = + Bonsai.Private.reveal_value value + |> Bonsai.Private.Value.cutoff ~added_by_let_syntax ~equal + |> Bonsai.Private.conceal_value + in + let component graph = + Bonsai.assoc + (module String) + (opaque_const_value (String.Map.of_alist_exn [ "capy", (); "bara", () ])) + graph + ~f:(fun _ data _graph -> cutoff data ~equal:(fun _ _ -> true)) + in + print_s (sexp_of_computation ~optimize:true component) +;; + +let%expect_test "assoc simplification behavior on cutoffs" = + test_assoc_simpl_on_cutoff ~added_by_let_syntax:true; + [%expect {| (Assoc_simpl (map Incr)) |}]; + test_assoc_simpl_on_cutoff ~added_by_let_syntax:false; + [%expect + {| + (Assoc + (map Incr) + (key_id (Test 1)) + (cmp_id (Test 2)) + (data_id (Test 3)) + (by ( + Return ( + value (Cutoff (t (Named (uid (Test 3)))) (added_by_let_syntax false)))))) |}] +;; + +let%expect_test "assoc_list unique" = + let run input = + let component graph = + Bonsai.assoc_list + (module Int) + (opaque_const_value input) + graph + ~get_key:fst + ~f:(fun _ kv_pair _graph -> + let%sub _, value = kv_pair in + value) + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = + [ `Ok of string list + | `Duplicate_key of int + ] + [@@deriving sexp_of] + end)) + component + in + Handle.show handle + in + run [ 2, "a"; 1, "b"; 3, "c"; 1, "d" ]; + [%expect {| (Duplicate_key 1) |}]; + run [ 2, "a"; 1, "c"; 3, "b" ]; + [%expect {| (Ok (a c b)) |}] +;; + +let%expect_test "chain" = + let add_one = Bonsai.map ~f:(fun x -> x + 1) in + let double = Bonsai.map ~f:(fun x -> x * 2) in + let component input _graph = + let a = add_one input in + let b = double a in + b + in + let var = Bonsai.Var.create 1 in + let handle = + Handle.create (Result_spec.sexp (module Int)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| 4 |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| 6 |}] +;; + +let%expect_test "chain + both" = + let add_one = Bonsai.map ~f:(fun x -> x + 1) in + let double = Bonsai.map ~f:(fun x -> x * 2) in + let add = Bonsai.map ~f:(fun (x, y) -> x + y) in + let component input _graph = + let a = add_one input in + let b = double a in + let c = add (Bonsai.both a b) in + c + in + let var = Bonsai.Var.create 1 in + let handle = + Handle.create (Result_spec.sexp (module Int)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| 6 |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| 9 |}] +;; + +let%expect_test "wrap" = + let component graph = + Bonsai.wrap + graph + ~default_model:0 + ~apply_action:(fun _ctx (result, _) model () -> String.length result + model) + ~f:(fun model inject _graph -> + let%map model = model + and inject = inject in + Int.to_string model, inject) + in + let handle = + Handle.create + (module struct + type t = string * (unit -> unit Effect.t) + type incoming = unit + + let view = Tuple2.get1 + let incoming (_, x) () = x () + end) + component + in + Handle.show handle; + [%expect {| 0 |}]; + Handle.do_actions handle [ () ]; + Handle.show handle; + [%expect {| 1 |}]; + Handle.do_actions handle [ (); (); (); (); (); (); (); (); (); () ]; + Handle.show handle; + [%expect {| 12 |}]; + Handle.do_actions handle [ () ]; + Handle.show handle; + [%expect {| 14 |}] +;; + +let%expect_test "match%sub" = + let var : (string, int) Either.t Bonsai.Var.t = + Bonsai.Var.create (Either.First "hello") + in + let component _graph = + match%sub Bonsai.Var.value var with + | First s -> Bonsai.map s ~f:(sprintf "%s world") + | Second i -> Bonsai.map i ~f:Int.to_string + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| hello world |}]; + Bonsai.Var.set var (Second 2); + Handle.show handle; + [%expect {| 2 |}] +;; + +let%expect_test "match%sub" = + let var : (string, int) Either.t Bonsai.Var.t = + Bonsai.Var.create (Either.First "hello") + in + let component _graph = + match%sub Bonsai.Var.value var with + | First s -> Bonsai.map s ~f:(sprintf "%s world") + | Second i -> Bonsai.map i ~f:Int.to_string + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| hello world |}]; + Bonsai.Var.set var (Second 2); + Handle.show handle; + [%expect {| 2 |}] +;; + +type thing = + | Loading of string + | Search_results of int + +let%expect_test "match%sub repro" = + let open Bonsai.Let_syntax in + let component current_page _graph = + match%sub current_page with + | Loading x -> + let%map x = x in + "loading " ^ x + | Search_results s -> + let%map s = s in + sprintf "search results %d" s + in + let var = Bonsai.Var.create (Loading "hello") in + let handle = + Handle.create (Result_spec.string (module String)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| loading hello |}]; + Bonsai.Var.set var (Search_results 5); + Handle.show handle; + [%expect {| search results 5 |}] +;; + +let%expect_test "if%sub" = + let component input _graph = + let a = return "hello" in + let b = return "world" in + if%sub input then a else b + in + let var = Bonsai.Var.create true in + let handle = + Handle.create (Result_spec.string (module String)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| hello |}]; + Bonsai.Var.set var false; + Handle.show handle; + [%expect {| world |}] +;; + +let%expect_test "match%sub defers exceptions until runtime" = + let var = Bonsai.Var.create true in + let component _graph = + match%sub Bonsai.Var.value var with + | true -> return "yay!" + | false -> assert false + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| yay! |}] +;; + +let%expect_test "let%sub patterns" = + let component _graph = + let%sub a, _b = return ("hello world", 5) in + a + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| hello world |}] +;; + +let%expect_test "sub constant folding optimization" = + let component _graph = + let%map a = return 5 + and b = return 6 in + a + b + in + print_s (sexp_of_computation ~optimize:false component); + [%expect + {| + (Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Constant (id (Test 0))) + (Constant (id (Test 1))))))))) + (via (Test 3)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 3)))))))))) |}]; + print_s (sexp_of_computation component); + [%expect {| (Return (value (Constant (id (Test 0))))) |}] +;; + +let%expect_test "let%map constant folding optimization" = + let component _graph = + let a = + let%map a = return 5 in + a + 1 + in + let b = return 6 in + let%map a = a + and b = b in + a + b + in + print_s (sexp_of_computation ~optimize:false component); + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs ((Constant (id (Test 0))))))))) + (via (Test 2)) + (into ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Constant (id (Test 3))))))))) + (via (Test 5)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 5)))))))))))) |}]; + print_s (sexp_of_computation component); + [%expect {| (Return (value (Constant (id (Test 0))))) |}] +;; + +let%expect_test "assoc simplifies its inner computation, if possible" = + let value = opaque_const_value String.Map.empty in + let component graph = + Bonsai.assoc + (module String) + value + graph + ~f:(fun key data _graph -> Bonsai.both key data) + in + print_s (sexp_of_computation component); + [%expect {| (Assoc_simpl (map Incr)) |}] +;; + +let%expect_test "assoc with sub simplifies its inner computation, if possible" = + let value = opaque_const_value String.Map.empty in + let component graph = + Bonsai.assoc + (module String) + value + graph + ~f:(fun key data _graph -> Bonsai.both key data) + in + print_s (sexp_of_computation component); + [%expect {| (Assoc_simpl (map Incr)) |}] +;; + +let%expect_test "map > lazy" = + let open Bonsai.Let_syntax in + let module M = struct + type t = + { label : string + ; children : t Int.Map.t + } + end + in + let rec f ~t ~depth graph = + let%sub { M.label; M.children } = t in + let children = + Bonsai.assoc + (module Int) + children + graph + ~f:(fun _ v graph -> + let depth = + let%map depth = depth in + depth + 1 + in + (Bonsai.Expert.delay [@alert "-deprecated"]) graph ~f:(fun graph -> + f ~t:v ~depth graph)) + in + let%map label = label + and children = children + and depth = depth in + [%message label (depth : int) (children : Sexp.t Int.Map.t)] + in + let t_var = Bonsai.Var.create { M.label = "hi"; children = Int.Map.empty } in + let t_value = Bonsai.Var.value t_var in + let handle = + Handle.create (Result_spec.sexp (module Sexp)) (f ~t:t_value ~depth:(Bonsai.return 0)) + in + [%expect {||}]; + Handle.show handle; + [%expect {| (hi (depth 0) (children ())) |}]; + Bonsai.Var.set + t_var + { M.label = "hi" + ; children = Int.Map.singleton 0 { M.label = "hello"; children = Int.Map.empty } + }; + Handle.show handle; + [%expect {| (hi (depth 0) (children ((0 (hello (depth 1) (children ())))))) |}] +;; + +let%expect_test "map > fix2" = + let open Bonsai.Let_syntax in + let module M = struct + type t = + { label : string + ; children : t Int.Map.t + } + end + in + let f ~t ~depth graph = + Bonsai.fix2 t depth graph ~f:(fun ~recurse t depth graph -> + let%sub { M.label; children } = t in + let children = + Bonsai.assoc + (module Int) + children + graph + ~f:(fun _ v -> + let depth = + let%map depth = depth in + depth + 1 + in + recurse v depth) + in + let%map label = label + and children = children + and depth = depth in + [%message label (depth : int) (children : Sexp.t Int.Map.t)]) + in + let t_var = Bonsai.Var.create { M.label = "hi"; children = Int.Map.empty } in + let t_value = Bonsai.Var.value t_var in + let handle = + Handle.create + (Result_spec.sexp (module Sexp)) + (fun graph -> f ~t:t_value ~depth:(return 0) graph) + in + [%expect {| |}]; + Handle.show handle; + [%expect {| (hi (depth 0) (children ())) |}]; + Bonsai.Var.set + t_var + { M.label = "hi" + ; children = Int.Map.singleton 0 { M.label = "hello"; children = Int.Map.empty } + }; + Handle.show handle; + [%expect {| (hi (depth 0) (children ((0 (hello (depth 1) (children ())))))) |}] +;; + +let%expect_test "Using fix to implement mutual recursion (collatz)" = + let open Bonsai.Let_syntax in + let step ~f state even odd graph = + let%sub n, depth = state in + let n = + let%map n = n in + f n + in + let is_even = + let%map n = n in + n % 2 = 0 + in + let depth = + let%map depth = depth in + depth + 1 + in + let state = + let%map n = n + and depth = depth in + n, depth + in + if%sub is_even then even state graph else odd state graph + in + let even odd state graph = + Bonsai.fix state graph ~f:(fun ~recurse state graph -> + step ~f:(fun n -> n / 2) state recurse odd graph) + in + let odd state graph = + Bonsai.fix state graph ~f:(fun ~recurse state graph -> + let one = + let%map n, _ = state in + n = 1 + in + if%sub one + then ( + let%map _, depth = state in + depth) + else step ~f:(fun n -> (3 * n) + 1) state (even recurse) recurse graph) + in + let even = even odd in + let collatz n graph = + let state = + let%map n = n in + n, -1 + in + step ~f:(fun x -> x) state even odd graph + in + let var = Bonsai.Var.create 5 in + let value = Bonsai.Var.value var in + let handle = + Handle.create + (module struct + type t = int + type incoming = Nothing.t + + let view = Int.to_string + let incoming _ = Nothing.unreachable_code + end) + (fun graph -> collatz value graph) + in + Handle.show handle; + (* 5 -> 16 -> 8 -> 4 -> 2 -> 1 *) + [%expect {| 5 |}]; + Bonsai.Var.set var 6; + Handle.show handle; + (* 6 -> 3 -> 10 -> 5 -> 16 -> 8 -> 4 -> 2 -> 1 *) + [%expect {| 8 |}] +;; + +let%expect_test "dynamic action sent to non-existent assoc element" = + let var = Bonsai.Var.create (Int.Map.of_alist_exn [ 1, (); 2, () ]) in + let component graph = + Bonsai.assoc + (module Int) + (Bonsai.Var.value var) + graph + ~f:(fun _key _data graph -> + let model, inject = + Bonsai.state_machine1 + ~default_model:0 + ~apply_action:(fun _ctx input model new_model -> + match input with + | Active () -> new_model + | Inactive -> + print_endline "inactive"; + model) + (opaque_const_value ()) + graph + in + Bonsai.both model inject) + in + let handle = + Handle.create + (module struct + type t = (int * (int -> unit Effect.t)) Int.Map.t + type incoming = Nothing.t + + let incoming _ = Nothing.unreachable_code + + let view (map : t) = + map + |> Map.to_alist + |> List.map ~f:(fun (i, (s, _)) -> i, s) + |> [%sexp_of: (int * int) list] + |> Sexp.to_string_hum + ;; + end) + component + in + Handle.show handle; + [%expect {| ((1 0) (2 0)) |}]; + let result = Handle.last_result handle in + let set_two what = + let _, set = Map.find_exn result 2 in + Ui_effect.Expert.handle (set what) + in + set_two 3; + Handle.show handle; + [%expect {| ((1 0) (2 3)) |}]; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, () ]); + Handle.show handle; + [%expect {| ((1 0)) |}]; + set_two 4; + Handle.show handle; + [%expect {| + inactive + ((1 0)) |}]; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, (); 2, () ]); + Handle.show handle; + [%expect {| ((1 0) (2 3)) |}] +;; + +let%test_module "inactive delivery" = + (module struct + let rec censor_sexp = function + | Sexp.List l -> + (match List.filter_map l ~f:censor_sexp with + | [] -> None + | [ x ] -> Some x + | all -> Some (Sexp.List all)) + | Sexp.Atom s -> + if String.is_prefix s ~prefix:"lib/bonsai" then None else Some (Atom s) + ;; + + let print_computation computation = + computation (return ()) + |> sexp_of_computation + |> censor_sexp + |> Option.value ~default:(Sexp.List []) + |> print_s + ;; + + let test_delivery_to_inactive_component computation = + let run_test which_assoc = + let var = Bonsai.Var.create (Int.Map.of_alist_exn [ 1, (); 2, () ]) in + let component = + match which_assoc with + | `Assoc -> + let i = return () in + Bonsai.assoc + (module Int) + (Bonsai.Var.value var) + ~f:(fun _key _data -> computation i) + | `Assoc_on -> + let i = Bonsai.return () in + Bonsai.Expert.assoc_on + (module Int) + (module String) + (Bonsai.Var.value var) + ~get_model_key:(fun key _data -> Int.to_string key) + ~f:(fun _key _data -> computation i) + in + let handle = + Handle.create + (module struct + type t = (int * (int -> unit Effect.t)) Int.Map.t + type incoming = Nothing.t + + let incoming _ = Nothing.unreachable_code + + let view (map : t) = + map + |> Map.to_alist + |> List.map ~f:(fun (i, (s, _)) -> i, s) + |> [%sexp_of: (int * int) list] + |> Sexp.to_string_hum + ;; + end) + component + in + Handle.show handle; + let result = Handle.last_result handle in + let set_two what = + let _, set = Map.find_exn result 2 in + Ui_effect.Expert.handle (set what) + in + set_two 3; + Handle.show handle; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, () ]); + Handle.show handle; + set_two 4; + Handle.show handle; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, (); 2, () ]); + Handle.show handle; + Expect_test_helpers_base.expect_test_output [%here] + in + let assoc = run_test `Assoc in + let assoc_on = run_test `Assoc_on in + print_computation computation; + print_endline assoc; + print_endline "==== Diff between assoc and assoc_on: ===="; + print_endline (Expect_test_patdiff.patdiff ~context:0 assoc assoc_on) + ;; + + let%expect_test "state_machine1 inactive-delivery" = + (fun _ graph -> + let model, inject = + Bonsai.state_machine1 + ~default_model:0 + ~apply_action:(fun _ctx input _model new_model -> + (match input with + | Inactive -> print_endline "static action" + | Active () -> print_endline "dynamic action"); + new_model) + (return ()) + graph + in + Bonsai.both model inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from Leaf0) + (via (Test 0)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 4)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 4)))))))))))))) + ((1 0) (2 0)) + dynamic action + ((1 0) (2 3)) + ((1 0)) + dynamic action + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "race inactive-delivery (but an active input)" = + (fun input graph -> + let model, inject = + Bonsai.state_machine1 + ~default_model:0 + ~apply_action:(fun _ctx input _model new_model -> + (match input with + | Inactive -> print_endline "static action" + | Active () -> print_endline "dynamic action"); + new_model) + input + graph + in + Bonsai.both model inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from Leaf0) + (via (Test 0)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 4)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 4)))))))))))))) + ((1 0) (2 0)) + dynamic action + ((1 0) (2 3)) + ((1 0)) + dynamic action + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "dynamic action inactive-delivery" = + (fun _ graph -> + let model, inject = + Bonsai.state_machine1 + ~default_model:0 + ~apply_action:(fun _ctx input model new_model -> + match input with + | Active () -> new_model + | Inactive -> + print_endline "inactive"; + model) + (opaque_const_value ()) + graph + in + Bonsai.both model inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from (Leaf1 (input Incr))) + (via (Test 1)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 1)))))))) + (via (Test 3)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 1)))))))) + (via (Test 5)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 3))) + (Named (uid (Test 5)))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + inactive + ((1 0)) + ((1 0) (2 3)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "actor1 inactive-delivery" = + (fun _ graph -> + let model, inject = + Bonsai.actor1 + ~default_model:0 + ~recv:(fun ~inject:_ ~schedule_event:_ input model new_model -> + match input with + | Active () -> new_model, () + | Inactive -> + print_endline + "action sent to actor1 has been received while the input was inactive."; + model, ()) + (opaque_const_value ()) + graph + in + Bonsai.both model inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from ( + Sub + (from (Leaf1 (input Incr))) + (via (Test 1)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 1)))))))) + (via (Test 3)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 1)))))))) + (via (Test 5)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 5)))))))) + (via (Test 7)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 3))) + (Named (uid (Test 7))))))))))))))))) + (via (Test 9)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 9)))))))) + (via (Test 11)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 9)))))))) + (via (Test 13)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 11))) + (Named (uid (Test 13)))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + action sent to actor1 has been received while the input was inactive. + ((1 0)) + ((1 0) (2 3)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "actor0 inactive-delivery" = + (fun _ graph -> + let model, inject = + Bonsai.actor0 + ~default_model:0 + ~recv:(fun ~inject:_ ~schedule_event:_ _model new_model -> new_model, ()) + graph + in + Bonsai.both model inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from ( + Sub + (from Leaf0) + (via (Test 0)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 4)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 4)))))))) + (via (Test 6)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 6))))))))))))))))) + (via (Test 8)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 8)))))))) + (via (Test 10)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 8)))))))) + (via (Test 12)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 10))) + (Named (uid (Test 12)))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "actor1 with constant input downgrades to actor0" = + (fun _ graph -> + let model, inject = + Bonsai.actor1 + ~default_model:0 + ~recv:(fun ~inject:_ ~schedule_event:_ input model new_model -> + match input with + | Active () -> new_model, () + | Inactive -> + print_endline + "action sent to actor1 has been received while the input was inactive."; + model, ()) + (return ()) + graph + in + Bonsai.both model inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from ( + Sub + (from Leaf0) + (via (Test 0)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 4)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 4)))))))) + (via (Test 6)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 6))))))))))))))))) + (via (Test 8)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 8)))))))) + (via (Test 10)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 8)))))))) + (via (Test 12)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 10))) + (Named (uid (Test 12)))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "static action inactive-delivery" = + (fun _ graph -> + let state, inject = Bonsai.state 0 graph in + Bonsai.both state inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from Leaf0) + (via (Test 0)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 4)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 4)))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "static inside of a lazy" = + (fun _ -> + opaque_computation + ((Bonsai.Expert.delay [@alert "-deprecated"]) ~f:(fun graph -> + let state, inject = Bonsai.state 0 graph in + Bonsai.both state inject))) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from (Return (value Incr))) + (via (Test 1)) + (into ( + Switch + (match_ (Mapn (inputs (Named (uid (Test 1)))))) + (arms ((Lazy t) (Return (value Exception))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "static inside of a lazy (optimized away)" = + (fun _ -> + (Bonsai.Expert.delay [@alert "-deprecated"]) ~f:(fun graph -> + let model, inject = Bonsai.state 0 graph in + Bonsai.both model inject)) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from Leaf0) + (via (Test 0)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 0)))))))) + (via (Test 4)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 4)))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "static inside of a wrap" = + (fun _ graph -> + Bonsai.wrap + ~default_model:() + ~apply_action:(fun _ctx _ () () -> ()) + graph + ~f:(fun _model _inject graph -> + let model, inject = Bonsai.state 0 graph in + Bonsai.both model inject)) + |> test_delivery_to_inactive_component; + [%expect + {| + (Wrap + (model_id (Test 0)) + (inject_id (Test 1)) + (inner ( + Sub + (from Leaf0) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 2)))))))) + (via (Test 4)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 2)))))))) + (via (Test 6)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 4))) + (Named (uid (Test 6)))))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "static inside of a match%sub" = + (fun _ graph -> + match%sub opaque_const_value () with + | () -> + let state, inject = Bonsai.state 0 graph in + Bonsai.both state inject) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs Incr))))) + (via (Test 2)) + (into ( + Sub + (from Leaf0) + (via (Test 3)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 3)))))))) + (via (Test 5)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 3)))))))) + (via (Test 7)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 5))) + (Named (uid (Test 7)))))))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "static inside of a with_model_resetter" = + (fun _ graph -> + let r, _reset = + Bonsai.with_model_resetter graph ~f:(fun graph -> + let state, inject = Bonsai.state 0 graph in + Bonsai.both state inject) + in + r) + |> test_delivery_to_inactive_component; + [%expect + {| + (Sub + (from ( + With_model_resetter + (inner ( + Sub + (from ( + Sub + (from Leaf0) + (via (Test 1)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 1)))))))) + (via (Test 3)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 1)))))))) + (via (Test 5)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 3))) + (Named (uid (Test 5))))))))))))))) + (via (Test 7)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 7))) + (Named (uid (Test 0))))))))))) + (reset_id (Test 0)))) + (via (Test 9)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 9)))))))) + (via (Test 11)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 9)))))))) + (via (Test 13)) + (into (Return (value (Named (uid (Test 11))))))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) + + ==== Diff between assoc and assoc_on: ==== |}] + ;; + + let%expect_test "resetting while inactive" = + let which_branch = Bonsai.Var.create true in + let component graph = + if%sub Bonsai.Var.value which_branch + then ( + let result, reset = + Bonsai.with_model_resetter graph ~f:(fun graph -> + let state, inject = Bonsai.state 0 graph in + Bonsai.both state inject) + in + Bonsai.both result reset) + else return ((-1, fun _ -> Bonsai.Effect.Ignore), Bonsai.Effect.Ignore) + in + let handle = + Handle.create + (module struct + type t = (int * (int -> unit Effect.t)) * unit Effect.t + type incoming = Nothing.t + + let incoming _ = Nothing.unreachable_code + let view ((i, _), _) = Int.to_string i + end) + component + in + Handle.show handle; + let (_, set_value), reset = Handle.last_result handle in + let set_value i = Ui_effect.Expert.handle (set_value i) in + let reset () = Ui_effect.Expert.handle reset in + set_value 3; + Handle.show handle; + Bonsai.Var.set which_branch false; + Handle.show handle; + set_value 4; + Handle.show handle; + Bonsai.Var.set which_branch true; + Handle.show handle; + [%expect {| + 0 + 3 + -1 + -1 + 4 |}]; + Bonsai.Var.set which_branch false; + Handle.show handle; + [%expect {| -1 |}]; + reset (); + Bonsai.Var.set which_branch true; + Handle.show handle; + [%expect {| 0 |}] + ;; + + let%expect_test "resetting while inactive via the reset passed in" = + let which_branch = Bonsai.Var.create true in + let component graph = + if%sub Bonsai.Var.value which_branch + then + Bonsai.with_model_resetter' graph ~f:(fun ~reset graph -> + let model, inject = Bonsai.state 0 graph in + Bonsai.both (Bonsai.both model inject) reset) + else return ((-1, fun _ -> Bonsai.Effect.Ignore), Bonsai.Effect.Ignore) + in + let handle = + Handle.create + (module struct + type t = (int * (int -> unit Effect.t)) * unit Effect.t + type incoming = Nothing.t + + let incoming _ = Nothing.unreachable_code + let view ((i, _), _) = Int.to_string i + end) + component + in + Handle.show handle; + let (_, set_value), reset = Handle.last_result handle in + let set_value i = Ui_effect.Expert.handle (set_value i) in + let reset () = Ui_effect.Expert.handle reset in + set_value 3; + Handle.show handle; + Bonsai.Var.set which_branch false; + Handle.show handle; + set_value 4; + Handle.show handle; + Bonsai.Var.set which_branch true; + Handle.show handle; + [%expect {| + 0 + 3 + -1 + -1 + 4 |}]; + Bonsai.Var.set which_branch false; + Handle.show handle; + [%expect {| -1 |}]; + reset (); + Bonsai.Var.set which_branch true; + Handle.show handle; + [%expect {| 0 |}] + ;; + + let%test_module "component reset" = + (module struct + type 'a action = + | Action of 'a + | Reset + + let build_handle (type result incoming) component ~sexp_of = + Handle.create + (module struct + type t = (result * (incoming -> unit Effect.t)) * unit Effect.t + type nonrec incoming = incoming action + + let incoming ((_result, do_action), reset) = function + | Action action -> do_action action + | Reset -> reset + ;; + + let view ((result, _), _) = sexp_of result |> Sexp.to_string_hum + end) + (fun graph -> + let output, reset = + Bonsai.with_model_resetter graph ~f:(fun graph -> + let model, inject = component graph in + Bonsai.both model inject) + in + Bonsai.both output reset) + ;; + + let%expect_test "custom reset" = + let component graph = Bonsai.state 0 ~reset:(fun m -> m * 2) graph in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let set_value i = Handle.do_actions handle [ Action i ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + set_value 3; + Handle.show handle; + [%expect {| 3 |}]; + set_value 4; + Handle.show handle; + [%expect {| 4 |}]; + reset (); + Handle.show handle; + [%expect {| 8 |}]; + set_value 1; + reset (); + Handle.show handle; + [%expect {| 2 |}]; + set_value 1; + reset (); + set_value 10; + Handle.show handle; + [%expect {| 10 |}] + ;; + + let%expect_test "reset by bouncing back to an action (state_machine0)" = + let component graph = + Bonsai.state_machine0 + ~default_model:0 + ~apply_action:(fun _ctx model is_increment -> + if is_increment then model + 1 else 999) + ~reset:(fun ctx model -> + Bonsai.Apply_action_context.schedule_event + ctx + (Bonsai.Apply_action_context.inject ctx false); + model) + graph + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let increment () = Handle.do_actions handle [ Action true ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + increment (); + increment (); + Handle.show handle; + [%expect {| 2 |}]; + increment (); + Handle.show handle; + [%expect {| 3 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "reset by bouncing back to an action (state_machine1)" = + let component = + Bonsai.state_machine1 + (opaque_const_value ()) + ~default_model:0 + ~apply_action:(fun _ctx input model is_increment -> + match input with + | Active () -> if is_increment then model + 1 else 999 + | Inactive -> + print_endline "inactive"; + model) + ~reset:(fun ctx model -> + Bonsai.Apply_action_context.schedule_event + ctx + (Bonsai.Apply_action_context.inject ctx false); + model) + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let increment () = Handle.do_actions handle [ Action true ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + increment (); + Handle.show handle; + [%expect {| 1 |}]; + increment (); + Handle.show handle; + [%expect {| 2 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "inside match%sub" = + let component graph = + let%sub model, inject = + match%sub opaque_const_value true with + | true -> + let model, inject = Bonsai.state 0 ~reset:(fun _ -> 999) graph in + Bonsai.both model inject + | false -> assert false + in + model, inject + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let set_value i = Handle.do_actions handle [ Action i ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + set_value 3; + Handle.show handle; + [%expect {| 3 |}]; + set_value 4; + Handle.show handle; + [%expect {| 4 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "inside forced lazy" = + let component graph = + let%sub state, inject = + match%sub opaque_const_value true with + | true -> + (Bonsai.Expert.delay [@alert "-deprecated"]) graph ~f:(fun graph -> + let state, inject = Bonsai.state 0 ~reset:(fun _ -> 999) graph in + Bonsai.both state inject) + | false -> assert false + in + state, inject + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let set_value i = Handle.do_actions handle [ Action i ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + set_value 3; + Handle.show handle; + [%expect {| 3 |}]; + set_value 4; + Handle.show handle; + [%expect {| 4 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "next to an inactive infinitely-recursive lazy" = + let rec infinitely_recursive_component graph = + (Bonsai.Expert.delay [@alert "-deprecated"]) graph ~f:(fun graph -> + infinitely_recursive_component graph) + in + let component graph = + let%sub state, inject = + match%sub opaque_const_value true with + | true -> + let state, inject = Bonsai.state 0 ~reset:(fun _ -> 999) graph in + Bonsai.both state inject + | false -> infinitely_recursive_component graph + in + state, inject + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let set_value i = Handle.do_actions handle [ Action i ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + set_value 3; + Handle.show handle; + [%expect {| 3 |}]; + set_value 4; + Handle.show handle; + [%expect {| 4 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "inside assoc" = + let component graph = + let map = + Bonsai.assoc + (module Int) + (opaque_const_value (Int.Map.of_alist_exn [ 0, (); 1, () ])) + graph + ~f:(fun _ _ graph -> + let state, inject = + Bonsai.state + 0 + ~reset:(fun _ -> + print_endline "resetting"; + 999) + graph + in + Bonsai.both state inject) + in + let res = + let%map map = map in + Map.to_alist map |> List.map ~f:(fun (k, (v, _)) -> k, v) + in + let setter = + let%map map = map in + fun (i, v) -> (Map.find_exn map i |> Tuple2.get2) v + in + res, setter + in + let handle = build_handle component ~sexp_of:[%sexp_of: (int * int) list] in + Handle.show handle; + [%expect {| ((0 0) (1 0)) |}]; + let set_value i v = Handle.do_actions handle [ Action (i, v) ] in + let reset () = Handle.do_actions handle [ Reset ] in + set_value 0 3; + Handle.show handle; + [%expect {| ((0 3) (1 0)) |}]; + set_value 1 5; + Handle.show handle; + [%expect {| ((0 3) (1 5)) |}]; + reset (); + Handle.show handle; + [%expect + {| + resetting + resetting + ((0 999) (1 999)) |}] + ;; + + let%expect_test "reset by bouncing back to an action (race)" = + let component graph = + Bonsai.state_machine1 + (opaque_const_value ()) + ~default_model:0 + ~apply_action: + (fun + _ctx (_ : unit Bonsai.Computation_status.t) model is_increment -> + if is_increment then model + 1 else 999) + ~reset:(fun ctx model -> + Bonsai.Apply_action_context.schedule_event + ctx + (Bonsai.Apply_action_context.inject ctx false); + model) + graph + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let increment () = Handle.do_actions handle [ Action true ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + increment (); + Handle.show handle; + [%expect {| 1 |}]; + increment (); + Handle.show handle; + [%expect {| 2 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "for wrap" = + let component graph = + let%sub model, inject = + Bonsai.wrap + graph + ~default_model:0 + ~apply_action:(fun _ctx _ model is_increment -> + if is_increment then model + 1 else 999) + ~reset:(fun ctx model -> + Bonsai.Apply_action_context.schedule_event + ctx + (Bonsai.Apply_action_context.inject ctx false); + model) + ~f:(fun model inject _graph -> Bonsai.both model inject) + in + model, inject + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let increment () = Handle.do_actions handle [ Action true ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + increment (); + Handle.show handle; + [%expect {| 1 |}]; + increment (); + Handle.show handle; + [%expect {| 2 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "inside a wrap" = + let component graph = + let%sub model, inject = + Bonsai.wrap + graph + ~default_model:() + ~apply_action:(fun _ctx _ () () -> ()) + ~f:(fun _ _ graph -> + let model, inject = + Bonsai.state_machine0 + graph + ~default_model:0 + ~apply_action:(fun _ctx model is_increment -> + if is_increment then model + 1 else 999) + ~reset:(fun ctx model -> + Bonsai.Apply_action_context.schedule_event + ctx + (Bonsai.Apply_action_context.inject ctx false); + model) + in + Bonsai.both model inject) + in + model, inject + in + let handle = build_handle component ~sexp_of:[%sexp_of: int] in + let increment () = Handle.do_actions handle [ Action true ] in + let reset () = Handle.do_actions handle [ Reset ] in + Handle.show handle; + [%expect {| 0 |}]; + increment (); + Handle.show handle; + [%expect {| 1 |}]; + increment (); + Handle.show handle; + [%expect {| 2 |}]; + reset (); + Handle.show handle; + [%expect {| 999 |}] + ;; + + let%expect_test "inside assoc_on" = + let component graph = + let map = + Bonsai.Expert.assoc_on + (module Int) + (module Bool) + (opaque_const_value (Int.Map.of_alist_exn [ 0, true; 1, false; 2, true ])) + graph + ~get_model_key:(fun _ -> Fn.id) + ~f:(fun _ _ graph -> + let model, inject = + Bonsai.state + 0 + ~reset:(fun _ -> + print_endline "resetting"; + 999) + graph + in + Bonsai.both model inject) + in + let res = + let%map map = map in + Map.to_alist map |> List.map ~f:(fun (k, (v, _)) -> k, v) + in + let setter = + let%map map = map in + fun (i, v) -> (Map.find_exn map i |> Tuple2.get2) v + in + res, setter + in + let handle = build_handle component ~sexp_of:[%sexp_of: (int * int) list] in + Handle.show handle; + [%expect {| ((0 0) (1 0) (2 0)) |}]; + let set_value i v = Handle.do_actions handle [ Action (i, v) ] in + let reset () = Handle.do_actions handle [ Reset ] in + set_value 0 3; + Handle.show handle; + [%expect {| ((0 3) (1 0) (2 3)) |}]; + set_value 1 5; + Handle.show handle; + [%expect {| ((0 3) (1 5) (2 3)) |}]; + reset (); + Handle.recompute_view handle; + (* notice that there are two printings of 'resetting' because even though + there's three active components, there are only two models between them *) + [%expect {| + resetting + resetting |}]; + Handle.show handle; + [%expect {| ((0 999) (1 999) (2 999)) |}] + ;; + end) + ;; + + let%expect_test "inactive delivery to assoc_on with shared model keys" = + let var = Bonsai.Var.create (Int.Map.of_alist_exn [ 1, (); 2, () ]) in + let component graph = + Bonsai.Expert.assoc_on + (module Int) + (module Unit) + (Bonsai.Var.value var) + graph + ~get_model_key:(fun _key _data -> ()) + ~f:(fun _key _data graph -> + let model, inject = + Bonsai.state_machine1 + ~default_model:0 + ~apply_action:(fun _ctx input model new_model -> + match input with + | Active () -> new_model + | Inactive -> + print_endline "inactive"; + model) + (opaque_const_value ()) + graph + in + Bonsai.both model inject) + in + let handle = + Handle.create + (module struct + type t = (int * (int -> unit Effect.t)) Int.Map.t + type incoming = Nothing.t + + let incoming _ = Nothing.unreachable_code + + let view (map : t) = + map + |> Map.to_alist + |> List.map ~f:(fun (i, (s, _)) -> i, s) + |> [%sexp_of: (int * int) list] + |> Sexp.to_string_hum + ;; + end) + component + in + print_computation (fun _ -> component); + [%expect + {| + (Assoc_on + (map Incr) + (io_key_id (Test 1)) + (model_key_id (Test 2)) + (model_cmp_id (Test 3)) + (data_id (Test 4)) + (by ( + Sub + (from (Leaf1 (input Incr))) + (via (Test 6)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 6)))))))) + (via (Test 8)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Named (uid (Test 6)))))))) + (via (Test 10)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 8))) + (Named (uid (Test 10)))))))))))))))) |}]; + Handle.show handle; + let result = Handle.last_result handle in + let set key to_what = + let _, set = Map.find_exn result key in + Ui_effect.Expert.handle (set to_what) + in + let set_one = set 1 in + let set_two = set 2 in + (* Delivery to existing key in input map works *) + set_two 3; + Handle.show handle; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, () ]); + Handle.show handle; + (* 2 is no longer in the input map, so setting it should fail, even though its model + is still in the model map *) + set_two 4; + Handle.show handle; + (* 1 is still in the input map, however, so it can be set *) + set_one 5; + Handle.show handle; + (* Reintroducing 2 will have it share the model *) + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, (); 2, () ]); + Handle.show handle; + [%expect + {| + ((1 0) (2 0)) + ((1 3) (2 3)) + ((1 3)) + inactive + ((1 3)) + ((1 5)) + ((1 5) (2 5)) |}] + ;; + end) +;; + +let%test_module "testing Bonsai internals" = + (module struct + (* This module tests internal details of Bonsai, and the results are sensitive to + implementation changes. *) + [@@@alert "-rampantly_nondeterministic"] + + let%expect_test "remove unused models in assoc" = + let var = Bonsai.Var.create Int.Map.empty in + let module State_with_setter = struct + type t = + { state : string + ; set_state : string -> unit Effect.t + } + end + in + let module Action = struct + type t = Set of string + end + in + let component graph = + Bonsai.assoc + (module Int) + (Bonsai.Var.value var) + graph + ~f:(fun _key _data graph -> + let state, set_state = + Bonsai.state + "hello" + ~sexp_of_model:[%sexp_of: string] + ~equal:[%equal: String.t] + graph + in + let%map state = state + and set_state = set_state in + { State_with_setter.state; set_state }) + in + let handle = + Handle.create + (module struct + type t = State_with_setter.t Int.Map.t + type incoming = int * Action.t + + let incoming (map : t) (id, action) = + let t = Map.find_exn map id in + match (action : Action.t) with + | Set value -> t.set_state value + ;; + + let view (map : t) = + map + |> Map.to_alist + |> List.map ~f:(fun (i, { state; set_state = _ }) -> i, state) + |> [%sexp_of: (int * string) list] + |> Sexp.to_string_hum + ;; + end) + component + in + Handle.show_model handle; + [%expect {| () |}]; + Bonsai.Var.set var (Int.Map.of_alist_exn [ 1, (); 2, () ]); + Handle.show_model handle; + [%expect {| () |}]; + (* use the setter to re-establish the default *) + Handle.do_actions handle [ 1, Set "test" ]; + Handle.show_model handle; + [%expect {| ((1 test)) |}]; + Handle.do_actions handle [ 1, Set "hello" ]; + Handle.show_model handle; + [%expect {| () |}] + ;; + end) +;; + +let%expect_test "multiple maps respect cutoff" = + let component input _graph = + input + |> Bonsai.map ~f:(fun (_ : int) -> ()) + |> Bonsai.map ~f:(fun () -> print_endline "triggered") + in + let var = Bonsai.Var.create 1 in + let handle = + Handle.create (Result_spec.sexp (module Unit)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| + triggered + () |}]; + Bonsai.Var.set var 2; + (* Cutoff happens on the unit, so "triggered" isn't printed *) + Handle.show handle; + [%expect {| () |}] +;; + +let%expect_test "let syntax is collapsed upon eval" = + let computation _graph = + let%mapn () = opaque_const_value () + and () = opaque_const_value () + and () = opaque_const_value () + and () = opaque_const_value () + and () = opaque_const_value () + and () = opaque_const_value () + and () = opaque_const_value () in + () + in + let packed = + let open Bonsai.Private in + let computation = top_level_handle computation in + let (T { model; input = _; action; run; apply_action = _; reset = _ }) = + computation |> pre_process |> gather + in + let T = + Bonsai.Private.Action.Type_id.same_witness_exn + Bonsai.Private.Action.Type_id.nothing + action + in + let snapshot = + run + ~environment:Environment.empty + ~path:Path.empty + ~clock:(Bonsai.Time_source.create ~start:(Time_ns.now ())) + ~inject:(function + | Leaf_static _ -> .) + ~model:(Ui_incr.return model.default) + in + Snapshot.result snapshot |> Ui_incr.pack + in + let filename = Stdlib.Filename.temp_file "incr" "out" in + Ui_incr.Packed.save_dot_to_file filename [ packed ]; + let dot_contents = In_channel.read_all filename in + require + [%here] + ~if_false_then_print_s: + (lazy [%sexp "No Map7 node found", (sexp_of_computation computation : Sexp.t)]) + (String.is_substring dot_contents ~substring:"Map7") +;; + +let%expect_test "ignored result of assoc" = + let var = Bonsai.Var.create (Int.Map.of_alist_exn [ 1, (); 2, () ]) in + let component graph = + let (_ : _) = + Bonsai.assoc + (module Int) + (Bonsai.Var.value var) + graph + ~f:(fun _key data graph -> + (* this sub is here to make sure that bonsai doesn't + optimize the component into an "assoc_simple" *) + let (_ : _) = Bonsai.state () graph in + data) + in + return () + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set var (Int.Map.of_alist_exn []); + Expect_test_helpers_core.require_does_not_raise [%here] (fun () -> Handle.show handle); + [%expect {| () |}] +;; + +let%expect_test "constant_folding on assoc containing a lifecycle" = + let component graph = + Bonsai.assoc + (module Int) + (opaque_const_value Int.Map.empty) + graph + ~f:(fun _key data graph -> + let () = + Bonsai.Edge.lifecycle + graph + ~on_activate:(return (Ui_effect.print_s [%message "hello"])) + in + data) + in + print_s (sexp_of_computation component); + [%expect + {| + (Assoc + (map Incr) + (key_id (Test 1)) + (cmp_id (Test 2)) + (data_id (Test 3)) + (by ( + Sub + (from (Lifecycle (value (Constant (id (Test 4)))))) + (via (Test 5)) + (into (Return (value (Named (uid (Test 3))))))))) |}] +;; + +let%expect_test "constant_folding on assoc containing a lifecycle that depends on a \ + value bound outside" + = + let component graph = + let a = opaque_const "hello" graph in + Bonsai.assoc + (module Int) + (opaque_const_value Int.Map.empty) + graph + ~f:(fun _key data graph -> + let () = + Bonsai.Edge.lifecycle + graph + ~on_activate: + (let%map a = a in + Ui_effect.print_s [%message a]) + in + data) + in + print_s (sexp_of_computation ~optimize:false component); + [%expect + {| + (Assoc + (map Incr) + (key_id (Test 1)) + (cmp_id (Test 2)) + (data_id (Test 3)) + (by ( + Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 6)) + (into ( + Sub + (from ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs (( + Mapn ( + inputs ( + (Mapn (inputs ((Named (uid (Test 6)))))) + (Mapn ( + inputs ( + (Constant (id (Test 8))) + (Constant (id (Test 9))))))))))))))) + (via (Test 13)) + (into ( + Sub + (from (Return (value (Mapn (inputs ((Named (uid (Test 13))))))))) + (via (Test 15)) + (into (Lifecycle (value (Named (uid (Test 15)))))))))) + (via (Test 16)) + (into (Return (value (Named (uid (Test 3))))))))))) |}] +;; + +let%expect_test "constant_folding on assoc containing a dynamic_scope" = + let dyn_var = Bonsai.Dynamic_scope.create ~name:"dyn_var" ~fallback:0 () in + let component graph = + Bonsai.assoc + (module Int) + (opaque_const_value Int.Map.empty) + graph + ~f:(fun _key data -> + Bonsai.Dynamic_scope.set dyn_var (opaque_const_value 1) ~inside:(fun graph -> + let x = Bonsai.Dynamic_scope.lookup dyn_var graph in + Bonsai.both data x)) + in + component |> sexp_of_computation ~optimize:false |> print_s; + [%expect + {| + (Assoc + (map Incr) + (key_id (Test 1)) + (cmp_id (Test 2)) + (data_id (Test 3)) + (by ( + Store + (id (Test 4)) + (value Incr) + (inner ( + Sub + (from (Fetch (id (Test 4)))) + (via (Test 6)) + (into ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 3))) + (Named (uid (Test 6)))))))))))))) |}] +;; + +let%expect_test "on_display for updating a state (using on_change)" = + let callback = + Bonsai.return (fun prev cur -> + Ui_effect.print_s [%message "change!" (prev : int option) (cur : int)]) + in + let component input graph = + Bonsai.Edge.on_change' ~equal:[%equal: Int.t] ~callback input graph; + return () + in + let var = Bonsai.Var.create 1 in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = unit + + let sexp_of_t () = Sexp.Atom "rendering..." + end)) + (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| + rendering... + (change! (prev ()) (cur 1)) |}]; + Handle.show handle; + [%expect {| rendering... |}]; + Handle.show handle; + [%expect {| rendering... |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| + rendering... + (change! (prev (1)) (cur 2)) |}]; + Handle.show handle; + [%expect {| rendering... |}]; + Handle.show handle; + [%expect {| rendering... |}] +;; + +let%expect_test "actor" = + let print_int_effect = printf "%d\n" |> Bonsai.Effect.of_sync_fun in + let component graph = + let _, effect = + Bonsai.actor0 + ~default_model:0 + ~recv:(fun ~inject:_ ~schedule_event:_ v () -> v + 1, v) + graph + in + let%map effect = effect in + let%bind.Bonsai.Effect i = effect () in + print_int_effect i + in + let handle = + Handle.create + (module struct + type t = unit Effect.t + type incoming = unit + + let view _ = "" + let incoming t () = t + end) + component + in + Handle.do_actions handle [ () ]; + Handle.show handle; + [%expect {| 0 |}]; + Handle.do_actions handle [ (); (); () ]; + Handle.show handle; + [%expect {| + 1 + 2 + 3 |}] +;; + +let%expect_test "actor sending events to itself" = + let component graph = + let (_ : unit Bonsai.t), effect = + Bonsai.actor0 graph ~default_model:() ~recv:(fun ~inject ~schedule_event () i -> + schedule_event (Effect.print_s [%message "got" ~_:(i : int)]); + (match i with + | 0 -> () + | _ -> + schedule_event + (let%bind.Effect result = inject (i - 1) in + Effect.print_s [%message (result : int)])); + (), i * 2) + in + let%map effect = effect in + fun x -> Effect.ignore_m (effect x) + in + let handle = + Handle.create + (module struct + type t = int -> unit Effect.t + type incoming = int + + let view _ = "" + let incoming t x = t x + end) + component + in + Handle.do_actions handle [ 5 ]; + Handle.show handle; + [%expect + {| + (got 5) + (got 4) + (result 8) + (got 3) + (result 6) + (got 2) + (result 4) + (got 1) + (result 2) + (got 0) + (result 0) |}] +;; + +let%expect_test "lifecycle" = + let effect action on = + Bonsai.return (Ui_effect.print_s [%message (action : string) (on : string)]) + in + let component input graph = + let rendered = Bonsai.return "" in + if%sub input + then ( + Bonsai.Edge.lifecycle + ~on_activate:(effect "activate" "a") + ~on_deactivate:(effect "deactivate" "a") + ~after_display:(effect "after-display" "a") + graph; + rendered) + else ( + Bonsai.Edge.lifecycle + ~on_activate:(effect "activate" "b") + ~on_deactivate:(effect "deactivate" "b") + ~after_display:(effect "after-display" "b") + graph; + rendered) + in + let var = Bonsai.Var.create true in + let handle = + Handle.create (Result_spec.string (module String)) (component (Bonsai.Var.value var)) + in + Handle.show handle; + [%expect {| + ((action activate) (on a)) + ((action after-display) (on a)) |}]; + Bonsai.Var.set var false; + Handle.show handle; + [%expect + {| + ((action deactivate) (on a)) + ((action activate) (on b)) + ((action after-display) (on b)) |}]; + Bonsai.Var.set var true; + Handle.show handle; + [%expect + {| + ((action deactivate) (on b)) + ((action activate) (on a)) + ((action after-display) (on a)) |}] +;; + +let%test_module "Clock.every" = + (module struct + let%expect_test "Clocks that trigger immediately at the beginning" = + let print_hi = (fun () -> print_endline "hi") |> Bonsai.Effect.of_sync_fun in + let clocks = + [ Bonsai.Clock.every + ~when_to_start_next_effect:`Every_multiple_of_period_blocking + ~trigger_on_activate:true + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_finishes_blocking + ~trigger_on_activate:true + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect:`Wait_period_after_previous_effect_starts_blocking + ~trigger_on_activate:true + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect:`Every_multiple_of_period_non_blocking + ~trigger_on_activate:true + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ] + in + List.iter clocks ~f:(fun clock -> + let handle = + Handle.create + (Result_spec.sexp (module Unit)) + (fun graph -> + clock graph; + return ()) + in + let move_forward_and_show () = + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.recompute_view_until_stable handle + in + Handle.recompute_view_until_stable handle; + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| hi |}]) + ;; + + let%expect_test "Clocks that wait span length before triggering at the beginning" = + let print_hi = (fun () -> print_endline "hi") |> Bonsai.Effect.of_sync_fun in + let clocks = + [ Bonsai.Clock.every + ~when_to_start_next_effect:`Every_multiple_of_period_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_finishes_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect:`Wait_period_after_previous_effect_starts_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect:`Every_multiple_of_period_non_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 3.0) + (Bonsai.return (print_hi ())) + ] + in + List.iter clocks ~f:(fun clock -> + let handle = + Handle.create + (Result_spec.sexp (module Unit)) + (fun graph -> + clock graph; + return ()) + in + let move_forward_and_show () = + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.recompute_view_until_stable handle + in + Handle.recompute_view_until_stable handle; + [%expect {| |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| |}]; + move_forward_and_show (); + [%expect {| hi |}]) + ;; + + let%expect_test "Clocks that move with a span of 0" = + let print_hi = (fun () -> print_endline "hi") |> Bonsai.Effect.of_sync_fun in + let clocks = + [ Bonsai.Clock.every + ~when_to_start_next_effect:`Every_multiple_of_period_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 0.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_finishes_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 0.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect:`Wait_period_after_previous_effect_starts_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 0.0) + (Bonsai.return (print_hi ())) + ; Bonsai.Clock.every + ~when_to_start_next_effect:`Every_multiple_of_period_non_blocking + ~trigger_on_activate:false + (Time_ns.Span.of_sec 0.0) + (Bonsai.return (print_hi ())) + ] + in + List.iter clocks ~f:(fun clock -> + let handle = + Handle.create + (Result_spec.sexp (module Unit)) + (fun graph -> + clock graph; + return ()) + in + let move_forward_and_show () = + Handle.advance_clock_by handle (Time_ns.Span.next Time_ns.Span.zero); + Handle.recompute_view_until_stable handle + in + Handle.recompute_view_until_stable handle; + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| hi |}]; + move_forward_and_show (); + [%expect {| hi |}]) + ;; + + let create_clock_handle + ~start + ~svar + ~when_to_start_next_effect + ~trigger_on_activate + ~span + = + let action = + Bonsai.return + (let%bind.Effect () = + (Effect.of_sync_fun (fun () -> print_endline "[tick] - effect started")) () + in + let%bind.Effect () = (Effect.For_testing.of_svar_fun (fun () -> !svar)) () in + Effect.of_sync_fun (fun () -> print_endline "[tock] - effect ended") ()) + in + let clock = + Bonsai.Clock.every + ~when_to_start_next_effect + ~trigger_on_activate + (Time_ns.Span.of_sec span) + action + in + Handle.create + ~start_time:(Time_ns.of_span_since_epoch (Time_ns.Span.of_sec start)) + (Result_spec.sexp (module Unit)) + (fun graph -> + clock graph; + return ()) + ;; + + let print_time handle = + let clock = Handle.clock handle in + let now = + Bonsai.Time_source.now clock + |> Time_ns.to_string_abs_parts ~zone:Time_float.Zone.utc + in + print_endline (List.last_exn now) + ;; + + let move_forward_and_show ?(after_show = Fn.const ()) ~handle span = + printf "before: "; + print_time handle; + Handle.advance_clock_by handle (Time_ns.Span.of_sec span); + printf "after: "; + print_time handle; + Handle.recompute_view_until_stable handle; + after_show (); + printf "after paint: "; + print_time handle + ;; + + let fill_and_reset_svar ~svar = + Effect.For_testing.Svar.fill_if_empty !svar (); + svar := Effect.For_testing.Svar.create () + ;; + + let advance_and_clear_svar ~handle ~svar time = + Handle.advance_clock_by handle (Time_ns.Span.of_sec time); + fill_and_reset_svar ~svar + ;; + + let%expect_test "`Wait_period_after_previous_effect_finishes_blocking behavior" = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~start:7.0 + ~svar + ~when_to_start_next_effect:`Wait_period_after_previous_effect_finishes_blocking + ~span:3.0 + ~trigger_on_activate:false + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.recompute_view_until_stable handle; + move_forward_and_show 1.0; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 2.0; + [%expect + {| + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; + (* Does not trigger at 7s + 2 * 3s. *) + move_forward_and_show 2.8; + [%expect + {| + before: 00:00:10.200000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; + (* Triggers at 7s (initial) + 3s (first tick) + 0.2s (time taken by first tick) + 3s + (time after first click)*) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 0.2; + [%expect + {| + before: 00:00:13.000000000Z + after: 00:00:13.200000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.400000000Z |}]; + (* Starting next trigger without immediately finishing/filling the svar. *) + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:13.400000000Z + after: 00:00:16.400000000Z + [tick] - effect started + after paint: 00:00:16.400000000Z |}]; + (* Clock does not trigger before the current action is completed. *) + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:16.400000000Z + after: 00:00:19.400000000Z + after paint: 00:00:19.400000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:19.400000000Z + after: 00:00:22.400000000Z + after paint: 00:00:22.400000000Z |}]; + fill_and_reset_svar ~svar; + [%expect {| [tock] - effect ended |}]; + move_forward_and_show 2.9; + [%expect + {| + before: 00:00:22.400000000Z + after: 00:00:25.300000000Z + after paint: 00:00:25.300000000Z |}]; + move_forward_and_show 0.1; + [%expect + {| + before: 00:00:25.300000000Z + after: 00:00:25.400000000Z + [tick] - effect started + after paint: 00:00:25.400000000Z |}] + ;; + + let%expect_test "`Wait_period_after_previous_effect_starts_blocking behavior" = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect:`Wait_period_after_previous_effect_starts_blocking + ~span:3.0 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 1.0; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 2.0; + [%expect + {| + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; + (* Triggers at 7s + 6.0s unlike the + `Wait_period_after_previous_effect_finishes_blocking version of this + which would need to wait until 7s + 6.2s. *) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 2.8; + [%expect + {| + before: 00:00:10.200000000Z + after: 00:00:13.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.200000000Z |}]; + (* The next trigger will take a long time, 10 seconds! There will be a couple of + missed [ticks] and missed [tocks]. *) + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:13.200000000Z + after: 00:00:16.200000000Z + [tick] - effect started + after paint: 00:00:16.200000000Z |}]; + (* Clock does not tick in before the previous action is complete. *) + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:16.200000000Z + after: 00:00:19.200000000Z + after paint: 00:00:19.200000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:19.200000000Z + after: 00:00:22.200000000Z + after paint: 00:00:22.200000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:22.200000000Z + after: 00:00:25.200000000Z + after paint: 00:00:25.200000000Z |}]; + move_forward_and_show 1.0; + [%expect + {| + before: 00:00:25.200000000Z + after: 00:00:26.200000000Z + after paint: 00:00:26.200000000Z |}]; + fill_and_reset_svar ~svar; + [%expect {| [tock] - effect ended |}]; + (* Time moves slightly forward which results in another trigger. (hence the + `Wait_period_after_previous_effect_starts_blocking behavior on skips. )*) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 0.01; + [%expect + {| + before: 00:00:26.200000000Z + after: 00:00:26.210000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:26.410000000Z |}]; + (* Next expected trigger is at 7s + 19.21s + 3s, so going to 7s + 22.11s should not + trigger. *) + move_forward_and_show 2.7; + [%expect + {| + before: 00:00:26.410000000Z + after: 00:00:29.110000000Z + after paint: 00:00:29.110000000Z |}]; + (* Trigger occurs at 7s + 22.21s as expected! 1*) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 0.1; + [%expect + {| + before: 00:00:29.110000000Z + after: 00:00:29.210000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:29.410000000Z |}] + ;; + + let%test_module "Resilience against bugs from action time being equal to span time" = + (module struct + (* This test is the only one that initially presented a race condition. Although + the other kinds of clocks' implementations did not have a race condition when first implemented, + they are still tested in this module.*) + let%expect_test _ = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_starts_blocking + ~span:3.0 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + after paint: 00:00:10.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; + fill_and_reset_svar ~svar; + [%expect {| [tock] - effect ended |}]; + move_forward_and_show 0.000001; + [%expect + {| + before: 00:00:13.000000000Z + after: 00:00:13.000001000Z + [tick] - effect started + after paint: 00:00:13.000001000Z |}] + ;; + + let%expect_test _ = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_finishes_blocking + ~span:3.0 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 3.; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + after paint: 00:00:10.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; + fill_and_reset_svar ~svar; + [%expect {| [tock] - effect ended |}]; + move_forward_and_show 0.000001; + [%expect + {| + before: 00:00:13.000000000Z + after: 00:00:13.000001000Z + after paint: 00:00:13.000001000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:13.000001000Z + after: 00:00:16.000001000Z + [tick] - effect started + after paint: 00:00:16.000001000Z |}] + ;; + + let%expect_test _ = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:true + ~start:7.0 + ~svar + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_finishes_blocking + ~span:3.0 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + Handle.recompute_view handle; + [%expect {| + () + [tick] - effect started |}]; + move_forward_and_show 3.; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + after paint: 00:00:10.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; + fill_and_reset_svar ~svar; + [%expect {| [tock] - effect ended |}]; + Handle.recompute_view_until_stable handle + ;; + + let%expect_test "Next multiple clock" = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_starts_blocking + ~span:3.0 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + after paint: 00:00:10.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; + fill_and_reset_svar ~svar; + [%expect {| [tock] - effect ended |}]; + move_forward_and_show 0.000000001; + [%expect + {| + before: 00:00:13.000000000Z + after: 00:00:13.000000001Z + [tick] - effect started + after paint: 00:00:13.000000001Z |}] + ;; + end) + ;; + + let%expect_test "`Every_multiple_of_period_blocking clock skip behavior" = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect:`Every_multiple_of_period_blocking + ~span:3.0 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 1.0; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; + (* `Every_multiple_of_period_blocking clock triggers on every t where [(t % span) = (init_time % span)] + Since initial time is 7s, the clock will trigger on every multiple of 3, + but offset by 1, so on 10s, 13s, 15s independent of skips. + *) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 2.0; + [%expect + {| + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; + move_forward_and_show 2.7; + [%expect + {| + before: 00:00:10.200000000Z + after: 00:00:12.900000000Z + after paint: 00:00:12.900000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 0.1; + [%expect + {| + before: 00:00:12.900000000Z + after: 00:00:13.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.200000000Z |}]; + move_forward_and_show 2.8; + [%expect + {| + before: 00:00:13.200000000Z + after: 00:00:16.000000000Z + [tick] - effect started + after paint: 00:00:16.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:16.000000000Z + after: 00:00:19.000000000Z + after paint: 00:00:19.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:19.000000000Z + after: 00:00:22.000000000Z + after paint: 00:00:22.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:22.000000000Z + after: 00:00:25.000000000Z + after paint: 00:00:25.000000000Z |}]; + move_forward_and_show 1.0; + [%expect + {| + before: 00:00:25.000000000Z + after: 00:00:26.000000000Z + after paint: 00:00:26.000000000Z |}]; + fill_and_reset_svar ~svar; + [%expect {| [tock] - effect ended |}]; + move_forward_and_show 0.1; + [%expect + {| + before: 00:00:26.000000000Z + after: 00:00:26.100000000Z + after paint: 00:00:26.100000000Z |}]; + move_forward_and_show 1.8; + [%expect + {| + before: 00:00:26.100000000Z + after: 00:00:27.900000000Z + after paint: 00:00:27.900000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 0.1; + [%expect + {| + before: 00:00:27.900000000Z + after: 00:00:28.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:28.200000000Z |}] + ;; + + let%expect_test "`Every_multiple_of_period_non_blocking clock skip behavior" = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect:`Every_multiple_of_period_non_blocking + ~span:3.0 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 1.0; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; + (* `Every_multiple_of_period_blocking clock triggers on every t where [(t % span) = (init_time % span)] + Since initial time is 7s, the clock will trigger on every multiple of 3, + but offset by 1, so on 10s, 13s, 15s independent of skips. + *) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 2.0; + [%expect + {| + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; + move_forward_and_show 2.7; + [%expect + {| + before: 00:00:10.200000000Z + after: 00:00:12.900000000Z + after paint: 00:00:12.900000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 0.1; + [%expect + {| + before: 00:00:12.900000000Z + after: 00:00:13.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.200000000Z |}]; + move_forward_and_show 2.8; + [%expect + {| + before: 00:00:13.200000000Z + after: 00:00:16.000000000Z + [tick] - effect started + after paint: 00:00:16.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:16.000000000Z + after: 00:00:19.000000000Z + [tick] - effect started + after paint: 00:00:19.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:19.000000000Z + after: 00:00:22.000000000Z + [tick] - effect started + after paint: 00:00:22.000000000Z |}]; + move_forward_and_show 3.0; + [%expect + {| + before: 00:00:22.000000000Z + after: 00:00:25.000000000Z + [tick] - effect started + after paint: 00:00:25.000000000Z |}]; + move_forward_and_show 1.0; + [%expect + {| + before: 00:00:25.000000000Z + after: 00:00:26.000000000Z + after paint: 00:00:26.000000000Z |}]; + fill_and_reset_svar ~svar; + [%expect + {| + [tock] - effect ended + [tock] - effect ended + [tock] - effect ended + [tock] - effect ended |}]; + move_forward_and_show 0.1; + [%expect + {| + before: 00:00:26.000000000Z + after: 00:00:26.100000000Z + after paint: 00:00:26.100000000Z |}]; + move_forward_and_show 1.8; + [%expect + {| + before: 00:00:26.100000000Z + after: 00:00:27.900000000Z + after paint: 00:00:27.900000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) + 0.1; + [%expect + {| + before: 00:00:27.900000000Z + after: 00:00:28.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:28.200000000Z |}] + ;; + + let%test_module "Resilience against inactive clocks" = + (module struct + let%expect_test _ = + let print_sanitized_dropped_action_if_needed = + Effect.of_sync_fun (fun () -> + let out = [%expect.output] in + if String.is_empty out + then () + else print_endline "[Whoops! An action was dropped!]") + in + List.iter + [ `Wait_period_after_previous_effect_starts_blocking + ; `Wait_period_after_previous_effect_finishes_blocking + ; `Every_multiple_of_period_blocking + ; `Every_multiple_of_period_non_blocking + ] + ~f:(fun when_to_start_next_effect -> + let component graph = + let state, set_state = Bonsai.state true graph in + match%sub state with + | true -> + Bonsai.Clock.every + ~when_to_start_next_effect + ~trigger_on_activate:false + (Time_ns.Span.of_sec 3.0) + (let%map set_state = set_state in + let%bind.Effect () = + (Effect.of_sync_fun (fun () -> + print_endline "[tick tock] - (state := false)")) + () + in + let%bind.Effect () = set_state false in + print_sanitized_dropped_action_if_needed ()) + graph; + return true + | false -> + Bonsai.Edge.after_display + (let%map set_state = set_state in + let%bind.Effect () = + (Effect.of_sync_fun (fun () -> print_endline "(state := true)")) () + in + let%bind.Effect () = set_state true in + print_sanitized_dropped_action_if_needed ()) + graph; + return false + in + let start = Time_ns.of_span_since_epoch (Time_ns.Span.of_min 1.0) in + let handle = + Handle.create (Result_spec.sexp (module Bool)) ~start_time:start component + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| true |}]; + move_forward_and_show 3.0; + [%expect + {| + [Whoops! An action was dropped!] + after paint: 00:01:03.000000000Z |}]; + Handle.show handle; + [%expect {| true |}]; + move_forward_and_show 3.0; + [%expect + {| + [Whoops! An action was dropped!] + after paint: 00:01:06.000000000Z |}]; + Handle.show handle; + [%expect {| true |}]; + move_forward_and_show 3.0; + [%expect + {| + [Whoops! An action was dropped!] + after paint: 00:01:09.000000000Z |}]; + Handle.show handle; + [%expect {| true |}]; + move_forward_and_show 3.0; + [%expect + {| + [Whoops! An action was dropped!] + after paint: 00:01:12.000000000Z |}]; + Handle.show handle; + [%expect {| true |}]) + ;; + end) + ;; + + let%test_module "Super small timespans on clock" = + (module struct + let%expect_test _ = + List.iter + [ `Every_multiple_of_period_blocking + ; `Wait_period_after_previous_effect_finishes_blocking + ; `Wait_period_after_previous_effect_starts_blocking + ; `Every_multiple_of_period_non_blocking + ] + ~f:(fun when_to_start_next_effect -> + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:0.0 + ~svar + ~when_to_start_next_effect + ~span:0.01 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:00.000000000Z + after: 00:00:00.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.010000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:00.010000000Z + after: 00:00:00.020000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.020000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:00.020000000Z + after: 00:00:00.030000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.030000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:00.030000000Z + after: 00:00:00.040000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.040000000Z |}]) + ;; + + let%expect_test _ = + List.iter + [ `Every_multiple_of_period_blocking + ; `Wait_period_after_previous_effect_finishes_blocking + ; `Wait_period_after_previous_effect_starts_blocking + ; `Every_multiple_of_period_non_blocking + ] + ~f:(fun when_to_start_next_effect -> + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:0.0 + ~svar + ~when_to_start_next_effect + ~span:0.01 + in + let move_forward_and_show ?(after_show = Fn.const ()) ~handle span = + printf "before: "; + print_time handle; + Handle.advance_clock_by handle (Time_ns.Span.of_sec span); + printf "after: "; + print_time handle; + Handle.show handle; + (* Advancing the clock by one second (many time the clock's time span) before recomputing. *) + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.recompute_view handle; + after_show (); + printf "after paint: "; + print_time handle + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:00.000000000Z + after: 00:00:00.010000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:01.010000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:01.010000000Z + after: 00:00:01.020000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:02.020000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:02.020000000Z + after: 00:00:02.030000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:03.030000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) + 0.01; + [%expect + {| + before: 00:00:03.030000000Z + after: 00:00:03.040000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:04.040000000Z |}]) + ;; + + let%expect_test "`Wait_period_after_previous_effect_finishes_blocking skip \ + behavior" + = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_finishes_blocking + ~span:0.01 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 0.005; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:07.005000000Z + after paint: 00:00:07.005000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.005; + [%expect + {| + before: 00:00:07.005000000Z + after: 00:00:07.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.012000000Z |}]; + (* Does not trigger at 7s + 2 * 0.01. *) + move_forward_and_show 0.008; + [%expect + {| + before: 00:00:07.012000000Z + after: 00:00:07.020000000Z + after paint: 00:00:07.020000000Z |}]; + (* Triggers at 7s (initial) + 0.01s (first tick) + 0.002s (time taken by first tick) + 0.001s + (time after first click)*) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.002; + [%expect + {| + before: 00:00:07.020000000Z + after: 00:00:07.022000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.024000000Z |}] + ;; + + let%expect_test "`Wait_period_after_previous_effect_starts_blocking skip behavior" + = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect: + `Wait_period_after_previous_effect_starts_blocking + ~span:0.01 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 0.005; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:07.005000000Z + after paint: 00:00:07.005000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.005; + [%expect + {| + before: 00:00:07.005000000Z + after: 00:00:07.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.012000000Z |}]; + (* Triggers at 7s + 2 * 0.01s unlike the "minimum" version of this which would need to wait + until 7s + 2 * 0.01s + 0.002s. *) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.008; + [%expect + {| + before: 00:00:07.012000000Z + after: 00:00:07.020000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.022000000Z |}]; + (* The next trigger will take a long time, 10 seconds! There will be a couple of + missed [ticks] and missed [tocks]. *) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 10.) + 0.008; + [%expect + {| + before: 00:00:07.022000000Z + after: 00:00:07.030000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.030000000Z |}]; + (* Time moves slightly forward which results in another trigger. (hence the + `Wait_period_after_previous_effect_starts_blocking behavior on skips. )*) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.00001; + [%expect + {| + before: 00:00:17.030000000Z + after: 00:00:17.030010000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.032010000Z |}]; + move_forward_and_show 0.007; + [%expect + {| + before: 00:00:17.032010000Z + after: 00:00:17.039010000Z + after paint: 00:00:17.039010000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.001; + [%expect + {| + before: 00:00:17.039010000Z + after: 00:00:17.040010000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.042010000Z |}] + ;; + + let%expect_test "`Every_multiple_of_period_blocking behavior" = + let svar = ref (Effect.For_testing.Svar.create ()) in + let handle = + create_clock_handle + ~trigger_on_activate:false + ~start:7.0 + ~svar + ~when_to_start_next_effect:`Every_multiple_of_period_blocking + ~span:0.01 + in + let move_forward_and_show = move_forward_and_show ~handle in + Handle.show handle; + [%expect {| () |}]; + move_forward_and_show 0.005; + [%expect + {| + before: 00:00:07.000000000Z + after: 00:00:07.005000000Z + after paint: 00:00:07.005000000Z |}]; + (* Clock triggers on every t where [(t % span) = (init_time % span)] + Since initial time is 7s, the clock will trigger on every multiple of 3, + but offset by 1, so on 10s, 13s, 16s independent of skips. *) + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.005; + [%expect + {| + before: 00:00:07.005000000Z + after: 00:00:07.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.012000000Z |}]; + move_forward_and_show 0.007; + [%expect + {| + before: 00:00:07.012000000Z + after: 00:00:07.019000000Z + after paint: 00:00:07.019000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.001; + [%expect + {| + before: 00:00:07.019000000Z + after: 00:00:07.020000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.022000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 10.0) + 0.008; + [%expect + {| + before: 00:00:07.022000000Z + after: 00:00:07.030000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.030000000Z |}]; + move_forward_and_show 0.001; + [%expect + {| + before: 00:00:17.030000000Z + after: 00:00:17.031000000Z + after paint: 00:00:17.031000000Z |}]; + move_forward_and_show 0.008; + [%expect + {| + before: 00:00:17.031000000Z + after: 00:00:17.039000000Z + after paint: 00:00:17.039000000Z |}]; + move_forward_and_show + ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) + 0.001; + [%expect + {| + before: 00:00:17.039000000Z + after: 00:00:17.040000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.042000000Z |}] + ;; + end) + ;; + + let%expect_test {| [every] continues to trigger effects even when the action takes a long time |} + = + let match_var = Bonsai.Var.create true in + let component graph = + let (_ : unit Bonsai.t), inject = + let sleep = Bonsai.Clock.sleep graph in + Bonsai.state_machine1 + ~default_model:() + ~apply_action:(fun ctx sleep () () -> + match sleep with + | Active sleep -> + Bonsai.Apply_action_context.schedule_event + ctx + (let%bind.Effect () = sleep (Time_ns.Span.of_sec 5.0) in + Effect.of_sync_fun print_endline "did action") + | Inactive -> print_endline "inactive") + sleep + graph + in + match%sub Bonsai.Var.value match_var with + | true -> + Bonsai.Clock.every + ~when_to_start_next_effect:`Every_multiple_of_period_non_blocking + ~trigger_on_activate:true + (Time_ns.Span.of_sec 3.0) + (let%map inject = inject in + inject ()) + graph; + return () + | false -> return () + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.recompute_view handle; + [%expect {| |}]; + Handle.recompute_view handle; + [%expect {| |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); + Handle.recompute_view handle; + [%expect {| did action |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); + Handle.recompute_view handle; + [%expect {| |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); + Handle.recompute_view handle; + [%expect {| did action |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); + Handle.recompute_view handle; + [%expect {| |}] + ;; + end) +;; + +let%expect_test "wait_after_display" = + let component graph = + let effect name = + let wait_after_display = Bonsai.Edge.wait_after_display graph in + let%map wait_after_display = wait_after_display in + let%bind.Effect () = wait_after_display in + Effect.print_s [%message "after display" (name : string)] + in + let a = effect "a" in + let b = effect "b" in + Bonsai.both a b + in + let handle = + Handle.create + (module struct + type t = unit Effect.t * unit Effect.t + type incoming = bool + + let view _t = "" + let incoming (a, b) which = if which then a else b + end) + component + in + Handle.do_actions handle [ true; true; true ]; + Handle.show handle; + (* BUG: we expect that the "after display" effects are triggered _after_ the call to + [Handle.show]. i.e. the desired output of this test is: + {[ + [%expect + {| + view + ("after display" (name a)) + ("after display" (name a)) + ("after display" (name a)) |}] + ]} + *) + [%expect + {| + ("after display" (name a)) + ("after display" (name a)) + ("after display" (name a)) |}]; + Handle.show handle; + [%expect {| |}]; + Handle.do_actions handle [ true; false ]; + Handle.show handle; + [%expect {| + ("after display" (name a)) + ("after display" (name b)) |}]; + Handle.do_actions handle [ false; true ]; + Handle.show handle; + [%expect {| + ("after display" (name b)) + ("after display" (name a)) |}]; + Handle.do_actions handle [ false; false ]; + Handle.show handle; + [%expect {| + ("after display" (name b)) + ("after display" (name b)) |}]; + Handle.do_actions handle [ false; true; false; true; false; true; false; false; false ]; + Handle.show handle; + [%expect + {| + ("after display" (name b)) + ("after display" (name a)) + ("after display" (name b)) + ("after display" (name a)) + ("after display" (name b)) + ("after display" (name a)) + ("after display" (name b)) + ("after display" (name b)) + ("after display" (name b)) |}] +;; + +let%expect_test "wait_after_display twice in a row" = + let component graph = + let wait_after_display = Bonsai.Edge.wait_after_display graph in + let%map wait_after_display = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + Effect.print_s [%message "after display"] + in + let handle = + Handle.create + (module struct + type t = unit Effect.t + type incoming = unit + + let view _t = "view" + let incoming a () = a + end) + component + in + Handle.do_actions handle [ () ]; + Handle.show handle; + [%expect {| view |}]; + Handle.show handle; + [%expect {| + view + "after display" |}]; + Handle.show handle; + [%expect {| view |}] +;; + +let%expect_test "wait_after_display works with [recompute_view_until_stable]" = + let component graph = + let wait_after_display = Bonsai.Edge.wait_after_display graph in + let%map wait_after_display = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + let%bind.Effect () = wait_after_display in + Effect.print_s [%message "after display"] + in + let handle = + Handle.create + (module struct + type t = unit Effect.t + type incoming = unit + + let view _t = "view" + let incoming a () = a + end) + component + in + Handle.do_actions handle [ () ]; + Handle.recompute_view_until_stable handle; + [%expect {| "after display" |}]; + Handle.show handle; + [%expect {| view |}] +;; + +let%expect_test "sleep" = + let component graph = + let sleep = Bonsai.Clock.sleep graph in + let%map sleep = sleep in + fun seconds -> + let%bind.Effect () = sleep (Time_ns.Span.of_sec seconds) in + Effect.print_s [%message "after sleep" (seconds : float)] + in + let handle = + Handle.create + (module struct + type t = float -> unit Effect.t + type incoming = float + + let view _t = "" + let incoming f i = f i + end) + component + in + Handle.do_actions handle [ 0.0; 1.0; 2.0; 3.0 ]; + Handle.show handle; + [%expect {| ("after sleep" (seconds 0)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 1)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 2)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 3)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| |}]; + Handle.do_actions handle [ 3.0; 2.0; 1.0; 0.0 ]; + Handle.show handle; + [%expect {| ("after sleep" (seconds 0)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 1)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 2)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 3)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| |}] +;; + +let%expect_test "sleep twice in a row" = + let component graph = + let sleep = Bonsai.Clock.sleep graph in + let%map sleep = sleep in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + Effect.print_s [%message "slept"] + in + let handle = + Handle.create + (module struct + type t = unit Effect.t + type incoming = unit + + let view _t = "view" + let incoming a () = a + end) + component + in + Handle.do_actions handle [ () ]; + Handle.show handle; + [%expect {| view |}]; + Handle.show handle; + [%expect {| + slept + view |}] +;; + +let%expect_test "recompute_view_until_stable does not notice sleep effects" = + let component graph = + let sleep = Bonsai.Clock.sleep graph in + let%map sleep = sleep in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + let%bind.Effect () = sleep Time_ns.Span.zero in + Effect.print_s [%message "slept"] + in + let handle = + Handle.create + (module struct + type t = unit Effect.t + type incoming = unit + + let view _t = "view" + let incoming a () = a + end) + component + in + Handle.do_actions handle [ () ]; + Handle.recompute_view_until_stable handle; + [%expect {| |}]; + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| + slept + view |}]; + Handle.show handle; + [%expect {| view |}] +;; + +let%expect_test "sleep works even when switching between inactive and active" = + let active_var = Bonsai.Var.create true in + let component graph = + match%sub Bonsai.Var.value active_var with + | true -> + let sleep = Bonsai.Clock.sleep graph in + let%map sleep = sleep in + fun seconds -> + let%bind.Effect () = sleep (Time_ns.Span.of_sec seconds) in + Effect.print_s [%message "after sleep" (seconds : float)] + | false -> + return (fun seconds -> Effect.print_s [%message "inactive" (seconds : float)]) + in + let handle = + Handle.create + (module struct + type t = float -> unit Effect.t + type incoming = float + + let view _t = "" + let incoming f i = f i + end) + component + in + Handle.do_actions handle [ 0.0; 1.0; 2.0; 3.0 ]; + Bonsai.Var.set active_var false; + Handle.show handle; + [%expect {| ("after sleep" (seconds 0)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 1)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 2)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 3)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| |}]; + Handle.do_actions handle [ 3.0 ]; + Handle.show handle; + [%expect {| (inactive (seconds 3)) |}]; + Bonsai.Var.set active_var true; + Handle.do_actions handle [ 3.0; 2.0; 1.0; 0.0 ]; + Handle.show handle; + [%expect + {| + (inactive (seconds 3)) + (inactive (seconds 2)) + (inactive (seconds 1)) + (inactive (seconds 0)) |}]; + Handle.do_actions handle [ 3.0; 2.0; 1.0; 0.0 ]; + Handle.show handle; + [%expect {| ("after sleep" (seconds 0)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 1)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 2)) |}]; + Bonsai.Var.set active_var false; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| ("after sleep" (seconds 3)) |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); + Handle.show handle; + [%expect {| |}] +;; + +module Query_response_tracker = Bonsai.Effect.For_testing.Query_response_tracker + +let edge_poll_shared ~get_expect_output = + let effect_tracker = Query_response_tracker.create () in + let effect = Bonsai.Effect.For_testing.of_query_response_tracker effect_tracker in + let var = Bonsai.Var.create "hello" in + let component graph = + Bonsai.Edge.Poll.effect_on_change + ~sexp_of_input:[%sexp_of: String.t] + ~sexp_of_result:[%sexp_of: String.t] + ~equal_input:[%equal: String.t] + ~equal_result:[%equal: String.t] + Bonsai.Edge.Poll.Starting.empty + (Bonsai.Var.value var) + ~effect:(Bonsai.return effect) + graph + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = string option [@@deriving sexp] + end)) + component + in + let trigger_display () = + (* Polling is driven by [on_display] callbacks, which is triggered by + [Handle.show] *) + Handle.show handle; + let pending = Query_response_tracker.queries_pending_response effect_tracker in + let output = Sexp.of_string (get_expect_output ()) in + print_s [%message (pending : string list) (output : Sexp.t)] + in + var, effect_tracker, trigger_display +;; + +let%expect_test "Edge.poll in order" = + let get_expect_output () = [%expect.output] in + let var, effect_tracker, trigger_display = edge_poll_shared ~get_expect_output in + trigger_display (); + [%expect {| + ((pending ()) + (output ())) |}]; + trigger_display (); + [%expect {| ((pending (hello)) (output ())) |}]; + Bonsai.Var.set var "world"; + trigger_display (); + [%expect {| ((pending (hello)) (output ())) |}]; + trigger_display (); + [%expect {| ((pending (world hello)) (output ())) |}]; + Query_response_tracker.maybe_respond effect_tracker ~f:(fun s -> + Respond (String.uppercase s)); + trigger_display (); + [%expect {| ((pending ()) (output (WORLD))) |}] +;; + +(* When completing the requests out-of-order, the last-fired effect still + wins *) +let%expect_test "Edge.poll out of order" = + let get_expect_output () = [%expect.output] in + let var, effect_tracker, trigger_display = edge_poll_shared ~get_expect_output in + trigger_display (); + [%expect {| + ((pending ()) + (output ())) |}]; + trigger_display (); + [%expect {| ((pending (hello)) (output ())) |}]; + Bonsai.Var.set var "world"; + trigger_display (); + [%expect {| ((pending (hello)) (output ())) |}]; + trigger_display (); + [%expect {| ((pending (world hello)) (output ())) |}]; + Query_response_tracker.maybe_respond effect_tracker ~f:(function + | "world" as s -> Respond (String.uppercase s) + | _ -> No_response_yet); + trigger_display (); + [%expect {| + ((pending (hello)) + (output (WORLD))) |}]; + Query_response_tracker.maybe_respond effect_tracker ~f:(function + | "hello" as s -> Respond (String.uppercase s) + | _ -> No_response_yet); + trigger_display (); + [%expect {| ((pending ()) (output (WORLD))) |}] +;; + +let%expect_test "Clock.now" = + let component = Bonsai.Clock.now in + let handle = + Handle.create (Result_spec.sexp (module Time_ns.Alternate_sexp)) component + in + Handle.show handle; + [%expect {| "1970-01-01 00:00:00Z" |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 0.5); + Handle.show handle; + [%expect {| "1970-01-01 00:00:00.5Z" |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 0.7); + Handle.show handle; + [%expect {| "1970-01-01 00:00:01.2Z" |}] +;; + +let%expect_test "Clock.now" = + let component graph = + let get_time = Bonsai.Clock.get_current_time graph in + Bonsai.Edge.after_display + (let%map get_time = get_time in + let%bind.Effect now = get_time in + Effect.print_s [%sexp (now : Time_ns.Alternate_sexp.t)]) + graph; + return () + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.recompute_view handle; + [%expect {| "1970-01-01 00:00:00Z" |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 0.5); + Handle.recompute_view handle; + [%expect {| "1970-01-01 00:00:00.5Z" |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 0.7); + Handle.recompute_view handle; + [%expect {| "1970-01-01 00:00:01.2Z" |}] +;; + +let%expect_test "Clock.approx_now" = + let component = Bonsai.Clock.approx_now ~tick_every:(Time_ns.Span.of_sec 1.0) in + let handle = + Handle.create (Result_spec.sexp (module Time_ns.Alternate_sexp)) component + in + Handle.show handle; + [%expect {| "1970-01-01 00:00:00Z" |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 0.5); + Handle.show handle; + [%expect {| "1970-01-01 00:00:00Z" |}]; + Handle.advance_clock_by handle (Time_ns.Span.of_sec 0.7); + Handle.show handle; + [%expect {| "1970-01-01 00:00:01.2Z" |}] +;; + +(* $MDX part-begin=chain-computation *) +let chain_computation graph = + let a = return "x" in + let b, set_b = Bonsai.state " " graph in + let c, set_c = Bonsai.state " " graph in + let d, set_d = Bonsai.state " " graph in + Bonsai.Edge.on_change ~equal:equal_string ~callback:set_b a graph; + Bonsai.Edge.on_change ~equal:equal_string ~callback:set_c b graph; + Bonsai.Edge.on_change ~equal:equal_string ~callback:set_d c graph; + Bonsai.Let_syntax.Let_syntax.map4 a b c d ~f:(sprintf "a:%s b:%s c:%s d:%s") +;; + +(* $MDX part-end *) + +(* $MDX part-begin=chained-on-change *) +let%expect_test "chained on_change" = + let handle = Handle.create (Result_spec.string (module String)) chain_computation in + Handle.show handle; + [%expect {| a:x b: c: d: |}]; + Handle.show handle; + [%expect {| a:x b:x c: d: |}]; + Handle.show handle; + [%expect {| a:x b:x c:x d: |}]; + Handle.show handle; + [%expect {| a:x b:x c:x d:x |}]; + Handle.show handle; + [%expect {| a:x b:x c:x d:x |}] +;; + +(* $MDX part-end *) + +(* $MDX part-begin=chained-on-change-recompute *) +let%expect_test "chained on_change with recompute_view_until_stable" = + let handle = Handle.create (Result_spec.string (module String)) chain_computation in + Handle.recompute_view_until_stable handle; + Handle.show handle; + [%expect {| a:x b:x c:x d:x |}] +;; + +(* $MDX part-end *) + +let%expect_test "infinite chain!" = + let computation graph = + let state, set_state = Bonsai.state 0 graph in + let callback = + let%map set_state = set_state in + fun new_state -> set_state (new_state + 1) + in + Bonsai.Edge.on_change ~equal:[%equal: Int.t] ~callback state graph; + Bonsai.return () + in + let handle = Handle.create (Result_spec.string (module Unit)) computation in + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + Handle.recompute_view_until_stable handle); + [%expect {| (Failure "view not stable after 100 recomputations") |}] +;; + +let%expect_test "computation.all_map" = + let component graph = + let%map map = + List.fold + [ (1, fun _graph -> Bonsai.return "a"); (2, fun _graph -> Bonsai.return "b") ] + ~init:(Bonsai.return Int.Map.empty) + ~f:(fun acc (key, c) -> + let%map acc = acc + and data = c graph in + Map.add_exn acc ~key ~data) + in + [%sexp_of: string Int.Map.t] map + in + let handle = Handle.create (Result_spec.string (module Sexp)) component in + Handle.show handle; + [%expect {| ((1 a)(2 b)) |}] +;; + +let%expect_test "dynamic lookup" = + let id = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no" () in + let component = + Bonsai.Dynamic_scope.set + id + (Bonsai.return "hello") + ~inside:(Bonsai.Dynamic_scope.lookup id) + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| hello |}] +;; + +let%expect_test "dynamic lookup fails" = + let id = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no" () in + let component = Bonsai.Dynamic_scope.lookup id in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| no |}] +;; + +let%expect_test "eval inside one, use inside another" = + let id = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no" () in + let component graph = + let a graph = + Bonsai.Dynamic_scope.set + id + (Bonsai.return "hello") + ~inside:(Bonsai.Dynamic_scope.lookup id) + graph + in + Bonsai.Dynamic_scope.set + id + (Bonsai.return "world") + ~inside:(fun graph -> a graph) + graph + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| hello |}] +;; + +let%expect_test "sub outside, use inside" = + let id = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no" () in + let component graph = + let find = Bonsai.Dynamic_scope.lookup id graph in + Bonsai.Dynamic_scope.set id (Bonsai.return "hello") ~inside:(fun _graph -> find) graph + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| no |}] +;; + +let%expect_test "use resetter" = + let id = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no" () in + let component = + Bonsai.Dynamic_scope.set' id (Bonsai.return "hello") ~f:(fun { revert } -> + revert (Bonsai.Dynamic_scope.lookup id)) + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| no |}] +;; + +let%expect_test "nested resetter" = + let id = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no" () in + let component = + Bonsai.Dynamic_scope.set + id + (Bonsai.return "hello") + ~inside: + (Bonsai.Dynamic_scope.set' id (Bonsai.return "world") ~f:(fun { revert } -> + revert (Bonsai.Dynamic_scope.lookup id))) + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| hello |}] +;; + +let%expect_test "resetter only impacts the id you target" = + let id_a = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no-a" () in + let id_b = Bonsai.Dynamic_scope.create ~name:"my-id" ~fallback:"no-b" () in + let component graph = + Bonsai.Dynamic_scope.set' + id_a + (Bonsai.return "hello") + graph + ~f:(fun { revert } graph -> + Bonsai.Dynamic_scope.set + id_b + (Bonsai.return "world") + graph + ~inside: + (revert (fun graph -> + let a = Bonsai.Dynamic_scope.lookup id_a graph in + let b = Bonsai.Dynamic_scope.lookup id_b graph in + Bonsai.map2 a b ~f:(fun a b -> a ^ " " ^ b)))) + in + let handle = Handle.create (Result_spec.string (module String)) component in + Handle.show handle; + [%expect {| no-a world |}] +;; + +module M = struct + type t = + { a : string + ; b : int + } + [@@deriving sexp_of, fields ~getters ~setters ~iterators:(create, iter)] +end + +let%expect_test "derived value" = + let id = + Bonsai.Dynamic_scope.create + ~sexp_of:M.sexp_of_t + ~name:"my-id" + ~fallback:{ a = "hi"; b = 5 } + () + in + let a = Bonsai.Dynamic_scope.derived id ~get:M.a ~set:(Field.fset M.Fields.a) in + let component graph = + Bonsai.Dynamic_scope.set + a + (Bonsai.return "hello") + ~inside:(fun graph -> Bonsai.Dynamic_scope.lookup id graph) + graph + in + let handle = Handle.create (Result_spec.sexp (module M)) component in + Handle.show handle; + [%expect {| ((a hello) (b 5)) |}] +;; + +let%expect_test "derived value revert" = + let id = + Bonsai.Dynamic_scope.create + ~sexp_of:M.sexp_of_t + ~name:"my-id" + ~fallback:{ a = "hi"; b = 5 } + () + in + let a = Bonsai.Dynamic_scope.derived id ~get:M.a ~set:(Field.fset M.Fields.a) in + let component graph = + Bonsai.Dynamic_scope.set' a (Bonsai.return "hello") graph ~f:(fun { revert } graph -> + revert (Bonsai.Dynamic_scope.lookup id) graph) + in + let handle = Handle.create (Result_spec.sexp (module M)) component in + Handle.show handle; + [%expect {| ((a hi) (b 5)) |}] +;; + +let%expect_test "derived value nested revert inner" = + let id = + Bonsai.Dynamic_scope.create + ~sexp_of:M.sexp_of_t + ~name:"my-id" + ~fallback:{ a = "hi"; b = 5 } + () + in + let a = Bonsai.Dynamic_scope.derived id ~get:M.a ~set:(Field.fset M.Fields.a) in + let component graph = + Bonsai.Dynamic_scope.set a (Bonsai.return "hello") graph ~inside:(fun graph -> + Bonsai.Dynamic_scope.set' + a + (Bonsai.return "world") + graph + ~f:(fun { revert } graph -> + revert (fun graph -> Bonsai.Dynamic_scope.lookup id graph) graph)) + in + let handle = Handle.create (Result_spec.sexp (module M)) component in + Handle.show handle; + [%expect {| ((a hello) (b 5)) |}] +;; + +let%expect_test "derived value nested revert outer" = + let id = + Bonsai.Dynamic_scope.create + ~sexp_of:M.sexp_of_t + ~name:"my-id" + ~fallback:{ a = "hi"; b = 5 } + () + in + let a = Bonsai.Dynamic_scope.derived id ~get:M.a ~set:(Field.fset M.Fields.a) in + let b = Bonsai.Dynamic_scope.derived id ~get:M.b ~set:(Field.fset M.Fields.b) in + let component graph = + Bonsai.Dynamic_scope.set' a (Bonsai.return "hello") graph ~f:(fun { revert } graph -> + Bonsai.Dynamic_scope.set b (Bonsai.return 1000) graph ~inside:(fun graph -> + revert (fun graph -> Bonsai.Dynamic_scope.lookup id graph) graph)) + in + let handle = Handle.create (Result_spec.sexp (module M)) component in + Handle.show handle; + [%expect {| ((a hi) (b 1000)) |}] +;; + +let%expect_test "exactly once" = + let component graph = + Bonsai_extra.exactly_once + (Bonsai.return (Ui_effect.print_s [%message "hello!"])) + graph + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.show handle; + [%expect {| + () + hello! |}]; + Handle.show handle; + [%expect {| () |}] +;; + +let%expect_test "exactly once with value" = + let component graph = + Bonsai_extra.exactly_once_with_value + ~equal:[%equal: String.t] + (return + (let%bind.Ui_effect () = Ui_effect.print_s [%message "hello!"] in + Ui_effect.return "done")) + graph + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = string option [@@deriving sexp, equal] + end)) + component + in + Handle.show handle; + [%expect {| + () + hello! |}]; + Handle.show handle; + [%expect {| (done) |}] +;; + +let%expect_test "~yoink~ peek" = + let component graph = + let state, set_state = Bonsai.state 0 graph in + let peek_state = Bonsai.peek state graph in + Bonsai_extra.exactly_once + (let%map peek_state = peek_state + and set_state = set_state in + let%bind.Bonsai.Effect () = set_state 1 in + let%bind.Bonsai.Effect s = + match%bind.Effect peek_state with + | Active s -> Effect.return s + | Inactive -> Effect.never + in + Ui_effect.print_s [%message (s : int)]) + graph + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.show handle; + [%expect {| () |}]; + Handle.show handle; + [%expect {| + (s 1) + () |}] +;; + +let%expect_test "bonk" = + let component graph = + let (_ : unit Bonsai.t), inject_message = + Bonsai.state_machine0 + ~default_model:() + ~apply_action:(fun _context () message -> print_endline message) + graph + in + let bonk = Bonsai_extra.bonk graph in + let%map inject_message = inject_message + and bonk = bonk in + ( inject_message "immediate" + , bonk (inject_message "bonked") + , bonk (bonk (inject_message "double bonked")) ) + in + let handle = + Handle.create + (module struct + type t = unit Effect.t * unit Effect.t * unit Effect.t + + type incoming = + [ `Now + | `Bonked_once + | `Bonked_twice + ] + + let view _ = "" + + let incoming (now, bonked_once, bonked_twice) = function + | `Now -> now + | `Bonked_once -> bonked_once + | `Bonked_twice -> bonked_twice + ;; + end) + component + in + Handle.show handle; + Handle.do_actions + handle + [ `Now + ; `Bonked_once + ; `Bonked_twice + ; `Now + ; `Now + ; `Bonked_twice + ; `Bonked_once + ; `Bonked_twice + ; `Bonked_once + ; `Now + ]; + Handle.show handle; + [%expect + {| + immediate + immediate + immediate + immediate + bonked + bonked + bonked + double bonked + double bonked + double bonked |}] +;; + +let%expect_test "bonk sorts a list" = + let component graph = + let items_and_inject_item, reset = + Bonsai.with_model_resetter graph ~f:(fun graph -> + let model, inject = + Bonsai.state_machine0 + ~default_model:[] + ~apply_action:(fun _context l i -> l @ [ i ]) + graph + in + Bonsai.both model inject) + in + let bonk = Bonsai_extra.bonk graph in + let%map items, inject_item = items_and_inject_item + and bonk = bonk + and reset = reset in + let func l = + let%bind.Effect () = reset in + List.map l ~f:(fun n -> Fn.apply_n_times ~n bonk (inject_item n)) |> Effect.Many + in + items, func + in + let handle = + Handle.create + (module struct + type t = int list * (int list -> unit Effect.t) + type incoming = int list + + let view (l, _) = Sexp.to_string_hum [%sexp (l : int list)] + let incoming (_, f) = f + end) + component + in + Handle.show handle; + [%expect {| () |}]; + Handle.do_actions handle [ [ 6; 4; 1; 3; 2; 3; 5 ] ]; + Handle.show handle; + [%expect {| + (1 2 3 3 4 5 6) |}]; + Handle.do_actions handle [ [ 7; 1; 8; 2; 3; 1; 2; 4 ] ]; + Handle.show handle; + [%expect {| (1 1 2 2 3 4 7 8) |}] +;; + +let%expect_test "freeze" = + let var = Bonsai.Var.create "hello" in + let component graph = + Bonsai.freeze ~equal:[%equal: String.t] (Bonsai.Var.value var) graph + in + let handle = Handle.create (Result_spec.sexp (module String)) component in + Handle.show handle; + [%expect {| hello |}]; + Bonsai.Var.set var "world"; + Handle.show handle; + [%expect {| hello |}] +;; + +let%expect_test "effect-lazy" = + let message = Bonsai.Var.create "hello" in + let on = Bonsai.Var.create true in + let component graph = + let on_deactivate = + let%map message = Bonsai.Var.value message in + let a = + print_endline "computing a..."; + Effect.print_s [%sexp "a", (message : string)] + in + let b = + Effect.lazy_ + (lazy + (print_endline "computing b..."; + Effect.print_s [%sexp "b", (message : string)])) + in + Effect.Many [ a; b ] + in + if%sub Bonsai.Var.value on + then ( + Bonsai.Edge.lifecycle ~on_deactivate graph; + return ()) + else return () + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.show handle; + Bonsai.Var.set message "there"; + Handle.show handle; + Bonsai.Var.set message "world"; + Handle.show handle; + [%expect + {| + computing a... + () + computing a... + () + computing a... + () |}]; + Bonsai.Var.set on false; + Handle.show handle; + [%expect {| + () + (a world) + computing b... + (b world) |}] +;; + +let%expect_test "id_gen" = + let module Id = Bonsai_extra.Id_gen (Int) () in + let component graph = + let next = Id.component graph in + Bonsai.Edge.after_display + (let%map next = next in + let%bind.Bonsai.Effect id = next in + Ui_effect.print_s [%sexp (id : Id.t)]) + graph; + return () + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.recompute_view handle; + Handle.recompute_view handle; + [%expect {| + 0 + 1 + 2 + 3 |}] +;; + +let%expect_test "with_self_effect" = + let module Result_spec = struct + type action = + | Set of int + | Print + + type t = string * (action -> unit Effect.t) [@@deriving sexp] + type incoming = action + + let view (result, _) = result + let incoming (_, self_effect) = self_effect + end + in + let component graph = + Bonsai_extra.with_self_effect + () + ~f:(fun input graph -> + let number, set_number = Bonsai.state 0 graph in + let%map number = number + and set_number = set_number + and input = input in + let effect action = + match action with + | Result_spec.Print -> + (match%bind.Effect input with + | Active (computed, (_ : Result_spec.action -> unit Effect.t)) -> + Effect.print_s [%message "Active" (computed : string)] + | Inactive -> Effect.print_s [%message "Inactive"]) + | Set i -> set_number i + in + let computed = sprintf "the value: [%d]" number in + computed, effect) + graph + in + let handle = Handle.create (module Result_spec) component in + Handle.show handle; + [%expect {| the value: [0] |}]; + Handle.do_actions handle [ Print ]; + [%expect {| |}]; + Handle.show handle; + [%expect {| + (Active (computed "the value: [0]")) + the value: [0] |}]; + Handle.do_actions handle [ Set 1 ]; + Handle.show handle; + [%expect {| the value: [1] |}]; + Handle.do_actions handle [ Set 5; Print; Set 6; Print ]; + Handle.show handle; + [%expect + {| + (Active (computed "the value: [5]")) + (Active (computed "the value: [6]")) + the value: [6] |}] +;; + +let%expect_test "state_machine_dynamic_model" = + let component graph = + Bonsai_extra.state_machine0_dynamic_model + () + ~model: + (`Computed + (return (function + | None -> "not set " + | Some s -> sprintf "set %s" s))) + ~apply_action:(fun _ctx _model action -> action) + graph + in + let handle = + Handle.create + (module struct + type t = string * (string -> unit Effect.t) + type incoming = string + + let view (s, _) = s + let incoming (_, s) = s + end) + component + in + Handle.show handle; + [%expect {| not set |}]; + Handle.do_actions handle [ "here" ]; + Handle.show handle; + [%expect {| set here |}] +;; + +let%expect_test "portal" = + let var = Bonsai.Var.create (Sexp.Atom "hello") in + let component graph = + Bonsai_extra.with_inject_fixed_point + (fun inject graph -> + Bonsai.Edge.on_change + ~equal:[%equal: Sexp.t] + (Bonsai.Var.value var) + ~callback:inject + graph; + return ((), Ui_effect.print_s)) + graph + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + (* this is only necessary because I use on_change, which uses after-display. + In an action-handler, the actions would be scheduled on the same frame. *) + Handle.recompute_view_until_stable handle; + [%expect {| hello |}]; + Bonsai.Var.set var (Sexp.Atom "world"); + Handle.recompute_view_until_stable handle; + [%expect {| world |}] +;; + +let%expect_test "portal 2" = + let component = + Bonsai_extra.with_inject_fixed_point (fun inject_fix graph -> + let state1, inject1 = + Bonsai.state_machine1 + ~default_model:0 + ~apply_action:(fun ctx inject model action -> + match inject with + | Active inject -> + Bonsai.Apply_action_context.schedule_event ctx (inject (model + action)); + action + | Inactive -> + print_endline "inactive"; + model) + inject_fix + graph + in + let (_ : unit Bonsai.t), inject2 = + Bonsai.state_machine1 + ~default_model:() + ~apply_action:(fun ctx state1 _model action -> + Bonsai.Apply_action_context.schedule_event + ctx + (Ui_effect.print_s + [%message (state1 : int Bonsai.Computation_status.t) (action : int)]); + ()) + state1 + graph + in + Bonsai.both inject1 inject2) + in + let handle = + Handle.create + (module struct + type t = int -> unit Effect.t + type incoming = int + + let view _ = "" + let incoming = Fn.id + end) + component + in + Handle.show handle; + [%expect {| |}]; + Handle.do_actions handle [ 1 ]; + Handle.recompute_view handle; + [%expect {| ((state1 (Active 1)) (action 1)) |}]; + Handle.do_actions handle [ 5 ]; + Handle.recompute_view handle; + [%expect {| ((state1 (Active 5)) (action 6)) |}]; + Handle.do_actions handle [ 10 ]; + Handle.recompute_view handle; + [%expect {| ((state1 (Active 10)) (action 15)) |}] +;; + +let%expect_test "pipe" = + let component graph = + let push_and_pop = Bonsai_extra.pipe (module String) graph in + let%map push, pop = push_and_pop in + let pop s = + let%bind.Bonsai.Effect a = pop in + Ui_effect.print_s [%sexp "pop", (s : string), (a : string)] + in + push, pop + in + let handle = + Handle.create + (module struct + type t = (string -> unit Effect.t) * (string -> unit Effect.t) + + type incoming = + [ `Push of string + | `Pop of string + ] + + let view _ = "" + + let incoming (push, pop) = function + | `Push s -> push s + | `Pop s -> pop s + ;; + end) + component + in + Handle.do_actions handle [ `Push "hello"; `Pop "a" ]; + Handle.recompute_view handle; + [%expect {| (pop a hello) |}]; + Handle.do_actions handle [ `Push "world" ]; + Handle.recompute_view handle; + [%expect {| |}]; + Handle.do_actions handle [ `Pop "b" ]; + Handle.recompute_view handle; + [%expect {| (pop b world) |}]; + Handle.do_actions handle [ `Pop "c" ]; + Handle.recompute_view handle; + [%expect {| |}]; + Handle.do_actions handle [ `Push "foo" ]; + Handle.recompute_view handle; + [%expect {| (pop c foo) |}]; + Handle.do_actions + handle + [ `Push "hello"; `Push "world"; `Push "foo"; `Pop "a"; `Pop "b"; `Pop "c" ]; + Handle.recompute_view handle; + [%expect {| + (pop a hello) + (pop b world) + (pop c foo) |}] +;; + +let%expect_test "multi-thunk" = + let module Id = Core.Unique_id.Int () in + let id graph = + Bonsai.Expert.thunk graph ~f:(fun () -> + print_endline "pulling id!"; + Id.create ()) + in + let component graph = + let%map a = id graph + and b = id graph in + sprintf "%s %s" (Id.to_string a) (Id.to_string b) + in + let handle = Handle.create (Result_spec.sexp (module String)) component in + Handle.show handle; + [%expect {| + pulling id! + pulling id! + "1 0" |}] +;; + +let%expect_test "evaluation of pure values under a match%sub" = + let depending_on = Bonsai.Var.create 0 in + let determines_use = Bonsai.Var.create false in + let component graph = + let used_somewhere = + match%sub opaque_const_value true with + | true -> + let () = + Bonsai.Edge.lifecycle + ~on_activate:(return (Effect.print_s [%message "activating!"])) + graph + in + let%map depending_on = Bonsai.Var.value depending_on in + print_s [%message "doing work" (depending_on : int)]; + depending_on + | false -> assert false + in + match%sub Bonsai.Var.value determines_use with + | true -> used_somewhere + | false -> return (-1) + in + let handle = Handle.create (Result_spec.sexp (module Int)) component in + (* Even though [determines_use] is false in this and other cases, we do work + unnecessarily. *) + Handle.show handle; + [%expect {| + ("doing work" (depending_on 0)) + -1 + activating! |}]; + Bonsai.Var.set determines_use true; + Handle.show handle; + [%expect {| 0 |}]; + Bonsai.Var.set determines_use false; + Handle.show handle; + [%expect {| -1 |}]; + Bonsai.Var.set depending_on 1; + Handle.show handle; + [%expect {| + ("doing work" (depending_on 1)) + -1 |}]; + Bonsai.Var.set depending_on 2; + Handle.show handle; + [%expect {| + ("doing work" (depending_on 2)) + -1 |}] +;; + +let%expect_test "evaluation of pure values under an assoc" = + let depending_on = Bonsai.Var.create 0 in + let determines_use = Bonsai.Var.create false in + let component graph = + let used_somewhere = + Bonsai.assoc + (module Int) + (opaque_const_value (Int.Map.of_alist_exn [ 1, () ])) + graph + ~f:(fun _key data graph -> + let () = + Bonsai.Edge.lifecycle + ~on_activate:(return (Effect.print_s [%message "activating!"])) + graph + in + let%map depending_on = Bonsai.Var.value depending_on + and () = data in + print_s [%message "doing work" (depending_on : int)]; + depending_on) + in + match%sub Bonsai.Var.value determines_use with + | true -> used_somewhere + | false -> return Int.Map.empty + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int Map.M(Int).t [@@deriving sexp_of] + end)) + component + in + Handle.show handle; + [%expect {| + ("doing work" (depending_on 0)) + () + activating! |}]; + Bonsai.Var.set determines_use true; + Handle.show handle; + [%expect {| ((1 0)) |}]; + Bonsai.Var.set determines_use false; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set depending_on 1; + Handle.show handle; + [%expect {| + ("doing work" (depending_on 1)) + () |}]; + Bonsai.Var.set depending_on 2; + Handle.show handle; + [%expect {| + ("doing work" (depending_on 2)) + () |}] +;; + +let%expect_test "evaluation of pure values as an input to an assoc (with a state in the \ + assoc)" + = + let depending_on = Bonsai.Var.create 0 in + let determines_use = Bonsai.Var.create false in + let component graph = + let input_map = + let%map depending_on = Bonsai.Var.value depending_on in + print_endline "doing work"; + Int.Map.of_alist_exn [ depending_on, () ] + in + let used_somewhere = + let intermediate = + Bonsai.assoc + (module Int) + input_map + graph + ~f:(fun _key _data graph -> + let (_ : _) = Bonsai.state () graph in + return ()) + in + Bonsai.Map.cutoff intermediate ~equal:phys_equal graph + in + match%sub Bonsai.Var.value determines_use with + | true -> used_somewhere + | false -> return Int.Map.empty + in + let handle = + Handle.create + (module struct + type t = unit Map.M(Int).t + + include Result_spec.No_incoming + + let view map = [%sexp (map : unit Map.M(Int).t)] |> Sexp.to_string + end) + component + in + Handle.show handle; + [%expect {| + doing work + () |}]; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set depending_on 1; + Handle.show handle; + [%expect {| + doing work + () |}]; + Bonsai.Var.set depending_on 2; + Handle.show handle; + [%expect {| + doing work + () |}] +;; + +let%expect_test "evaluation of pure values as an input to an assoc (without a state in \ + the assoc)" + = + let depending_on = Bonsai.Var.create 0 in + let determines_use = Bonsai.Var.create false in + let component graph = + let input_map = + let%map depending_on = Bonsai.Var.value depending_on in + print_endline "doing work"; + Int.Map.of_alist_exn [ depending_on, () ] + in + let used_somewhere = + let intermediate = + Bonsai.assoc (module Int) input_map graph ~f:(fun _key _data _graph -> return ()) + in + Bonsai.Map.cutoff intermediate ~equal:phys_equal graph + in + match%sub Bonsai.Var.value determines_use with + | true -> used_somewhere + | false -> return Int.Map.empty + in + let handle = + Handle.create + (module struct + type t = unit Map.M(Int).t + + include Result_spec.No_incoming + + let view map = [%sexp (map : unit Map.M(Int).t)] |> Sexp.to_string + end) + component + in + Handle.show handle; + [%expect {| () |}]; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set depending_on 1; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set depending_on 2; + Handle.show handle; + [%expect {| () |}] +;; + +let%expect_test "scope_model" = + let var = Bonsai.Var.create true in + let component graph = + Bonsai.scope_model + (module Bool) + ~on:(Bonsai.Var.value var) + ~for_:(fun graph -> + let state, set_state = Bonsai.state "default" graph in + Bonsai.both state set_state) + graph + in + let handle = + Handle.create + (module struct + type t = string * (string -> unit Effect.t) + type incoming = string + + let view (s, _) = s + let incoming (_, s) = s + end) + component + in + Handle.show handle; + [%expect {| + default |}]; + Handle.do_actions handle [ "a" ]; + Handle.show handle; + [%expect {| a |}]; + Bonsai.Var.set var false; + Handle.show handle; + [%expect {| default |}]; + Handle.do_actions handle [ "b" ]; + Handle.show handle; + [%expect {| b |}]; + Bonsai.Var.set var true; + Handle.show handle; + [%expect {| a |}] +;; + +let%expect_test "thunk-storage" = + let module Id = Core.Unique_id.Int () in + let var = Bonsai.Var.create true in + let id graph = + Bonsai.Expert.thunk graph ~f:(fun () -> + print_endline "pulling id!"; + Id.create ()) + in + let component graph = + if%sub Bonsai.Var.value var + then ( + let%map id = id graph in + Id.to_string id) + else return "" + in + let handle = Handle.create (Result_spec.sexp (module String)) component in + Handle.show handle; + [%expect {| + pulling id! + 0 |}]; + Bonsai.Var.set var false; + Handle.show handle; + [%expect {| "" |}]; + Bonsai.Var.set var true; + Handle.show handle; + [%expect {| 0 |}] +;; + +let%expect_test "action dropped in match%sub" = + let component graph = + let x, set_x = Bonsai.state true graph in + match%sub x with + | true -> + let (_ : unit Bonsai.t), inject = + Bonsai.state_machine1 + ~default_model:() + ~apply_action:(fun _ctx input () () -> + match input with + | Active () -> print_endline "active" + | Inactive -> print_endline "inactive") + (opaque_const_value ()) + graph + in + Bonsai.Edge.lifecycle + graph + ~on_activate: + (let%map inject = inject + and set_x = set_x in + let%bind.Effect () = set_x false in + (* This call to [inject] below successfully schedules the effect, + but the effect never gets run because the effect that + just got executed switched which branch of the [match%sub] was + active, thus making it impossible to run the [apply_action] + function of the [state_machine1]. A similar component that uses + [state_machine0] would not have this problem. *) + inject ()); + return () + | false -> return () + in + let handle = Handle.create (Result_spec.sexp (module Unit)) component in + Handle.show handle; + [%expect {| () |}]; + Handle.show handle; + [%expect {| + inactive + () |}] +;; + +let%test_module "mirror" = + (module struct + let prepare_test ~store ~interactive = + let store = Bonsai.Var.create store in + let interactive = Bonsai.Var.create interactive in + let store_set = + (fun value -> + printf "store set to \"%s\"" value; + Bonsai.Var.set store value) + |> Ui_effect.of_sync_fun + in + let interactive_set = + (fun value -> + printf "interactive set to \"%s\"" value; + Bonsai.Var.set interactive value) + |> Ui_effect.of_sync_fun + in + let component graph = + let (_ : unit Bonsai.t) = + Bonsai_extra.mirror + ~equal:[%equal: String.t] + ~store_set:(return store_set) + ~interactive_set:(return interactive_set) + ~store_value:(Bonsai.Var.value store) + ~interactive_value:(Bonsai.Var.value interactive) + () + graph + in + let%map store = Bonsai.Var.value store + and interactive = Bonsai.Var.value interactive in + sprintf "store: %s, interactive: %s" store interactive + in + let handle = Handle.create (Result_spec.string (module String)) component in + handle, store, interactive + ;; + + let%expect_test "starts stable" = + let handle, _store, _interactive = prepare_test ~store:"a" ~interactive:"a" in + Handle.show handle; + [%expect {| store: a, interactive: a |}] + ;; + + let%expect_test "starts unstable" = + let handle, _store, _interactive = prepare_test ~store:"a" ~interactive:"b" in + Handle.show handle; + [%expect {| + store: a, interactive: b + interactive set to "a" |}]; + Handle.show handle; + [%expect {| store: a, interactive: a |}] + ;; + + let%expect_test "starts stable and then interactive changes" = + let handle, _store, interactive = prepare_test ~store:"a" ~interactive:"a" in + Handle.show handle; + [%expect {| store: a, interactive: a |}]; + Bonsai.Var.set interactive "b"; + Handle.show handle; + [%expect {| + store: a, interactive: b + store set to "b" |}]; + Handle.show handle; + [%expect {| store: b, interactive: b |}] + ;; + + let%expect_test "starts stable and then store changes" = + let handle, store, _interactive = prepare_test ~store:"a" ~interactive:"a" in + Handle.show handle; + [%expect {| store: a, interactive: a |}]; + Bonsai.Var.set store "b"; + Handle.show handle; + [%expect {| + store: b, interactive: a + interactive set to "b" |}]; + Handle.show handle; + [%expect {| store: b, interactive: b |}] + ;; + + let%expect_test "starts stable and then both change at the same time" = + let handle, store, interactive = prepare_test ~store:"a" ~interactive:"a" in + Handle.show handle; + [%expect {| store: a, interactive: a |}]; + Bonsai.Var.set store "b"; + Bonsai.Var.set interactive "c"; + Handle.show handle; + [%expect {| + store: b, interactive: c + store set to "c" |}]; + Handle.show handle; + [%expect {| store: c, interactive: c |}] + ;; + end) +;; + +let%test_module "mirror'" = + (module struct + let prepare_test ~store ~interactive = + let store = Bonsai.Var.create store in + let interactive = Bonsai.Var.create interactive in + let store_set = + (fun value -> + printf "store set to \"%s\"" value; + Bonsai.Var.set store (Some value)) + |> Ui_effect.of_sync_fun + in + let interactive_set = + (fun value -> + printf "interactive set to \"%s\"" value; + Bonsai.Var.set interactive (Some value)) + |> Ui_effect.of_sync_fun + in + let component graph = + let (_ : unit Bonsai.t) = + Bonsai_extra.mirror' + () + ~equal:[%equal: String.t] + ~store_set:(return store_set) + ~interactive_set:(return interactive_set) + ~store_value:(Bonsai.Var.value store) + ~interactive_value:(Bonsai.Var.value interactive) + graph + in + let%map store = Bonsai.Var.value store + and interactive = Bonsai.Var.value interactive in + sprintf + "store: %s, interactive: %s" + (Option.value store ~default:"") + (Option.value interactive ~default:"") + in + let handle = Handle.create (Result_spec.string (module String)) component in + handle, store, interactive + ;; + + let%expect_test "starts both none" = + let handle, _store, _interactive = prepare_test ~store:None ~interactive:None in + Handle.show handle; + [%expect {| store: , interactive: |}] + ;; + + let%expect_test "starts interactive some" = + let handle, _store, _interactive = + prepare_test ~store:None ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| + store: , interactive: hi + store set to "hi" |}]; + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts store some" = + let handle, _store, _interactive = + prepare_test ~store:(Some "hi") ~interactive:None + in + Handle.show handle; + [%expect + {| + store: hi, interactive: + interactive set to "hi" |}]; + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts both some (same value)" = + let handle, _store, _interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts both some (different values)" = + let handle, _store, _interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hello") + in + Handle.show handle; + [%expect + {| + store: hi, interactive: hello + interactive set to "hi" |}]; + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts both none, store set " = + let handle, store, _interactive = prepare_test ~store:None ~interactive:None in + Handle.show handle; + [%expect {| store: , interactive: |}]; + Bonsai.Var.set store (Some "hi"); + Handle.show handle; + [%expect + {| + store: hi, interactive: + interactive set to "hi" |}]; + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts both none, interactive set " = + let handle, _store, interactive = prepare_test ~store:None ~interactive:None in + Handle.show handle; + [%expect {| store: , interactive: |}]; + Bonsai.Var.set interactive (Some "hi"); + Handle.show handle; + [%expect {| + store: , interactive: hi + store set to "hi" |}]; + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts both none, both set to same value" = + let handle, store, interactive = prepare_test ~store:None ~interactive:None in + Handle.show handle; + [%expect {| store: , interactive: |}]; + Bonsai.Var.set interactive (Some "hi"); + Bonsai.Var.set store (Some "hi"); + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts both none, both set to different values" = + let handle, store, interactive = prepare_test ~store:None ~interactive:None in + Handle.show handle; + [%expect {| store: , interactive: |}]; + Bonsai.Var.set interactive (Some "hi"); + Bonsai.Var.set store (Some "hello"); + Handle.show handle; + [%expect {| + store: hello, interactive: hi + store set to "hi" |}]; + Handle.show handle; + [%expect {| store: hi, interactive: hi |}] + ;; + + let%expect_test "starts both some, both set to different values" = + let handle, store, interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| store: hi, interactive: hi |}]; + Bonsai.Var.set interactive (Some "abc"); + Bonsai.Var.set store (Some "def"); + Handle.show handle; + [%expect {| + store: def, interactive: abc + store set to "abc" |}]; + Handle.show handle; + [%expect {| store: abc, interactive: abc |}] + ;; + + let%expect_test "starts both some (same value), store reset to none" = + let handle, store, _interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| store: hi, interactive: hi |}]; + Bonsai.Var.set store None; + Handle.show handle; + (* The noneness isn't propagated to interactive *) + [%expect {| store: , interactive: hi |}] + ;; + + let%expect_test "starts both some (same value), interactive reset to none" = + let handle, _store, interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| store: hi, interactive: hi |}]; + Bonsai.Var.set interactive None; + Handle.show handle; + (* The noneness isn't propagated to the store *) + [%expect {| store: hi, interactive: |}] + ;; + + let%expect_test "starts both some (same value), both set to none" = + let handle, store, interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| store: hi, interactive: hi |}]; + Bonsai.Var.set store None; + Bonsai.Var.set interactive None; + Handle.show handle; + (* The noneness isn't propagated to the store *) + [%expect {| store: , interactive: |}] + ;; + + let%expect_test "starts both some (same value), interactive set to none, both swap" = + let handle, store, interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| store: hi, interactive: hi |}]; + Bonsai.Var.set store None; + Handle.show handle; + [%expect {| store: , interactive: hi |}]; + Bonsai.Var.set store (Some "abc"); + Bonsai.Var.set interactive None; + Handle.show handle; + [%expect + {| + store: abc, interactive: + interactive set to "abc" |}]; + Handle.show handle; + [%expect {| store: abc, interactive: abc |}] + ;; + + let%expect_test "starts both some (same value), store set to none, both swap" = + let handle, store, interactive = + prepare_test ~store:(Some "hi") ~interactive:(Some "hi") + in + Handle.show handle; + [%expect {| store: hi, interactive: hi |}]; + Bonsai.Var.set interactive None; + Handle.show handle; + [%expect {| store: hi, interactive: |}]; + Bonsai.Var.set interactive (Some "abc"); + Bonsai.Var.set store None; + Handle.show handle; + [%expect {| + store: , interactive: abc + store set to "abc" |}]; + Handle.show handle; + [%expect {| store: abc, interactive: abc |}] + ;; + end) +;; + +let%expect_test "let%arr cutoff destruction" = + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component _graph = + let%arr a, _ = value in + print_endline "performing work!"; + a + in + let handle = Handle.create (Result_spec.string (module Int)) component in + Handle.show handle; + [%expect {| + performing work! + 0 |}]; + Bonsai.Var.set var (0, 1); + Handle.show handle; + (* No work is performed! *) + [%expect {| 0 |}]; + Bonsai.Var.set var (1, 1); + Handle.show handle; + [%expect {| + performing work! + 1 |}] +;; + +let%expect_test "let%pattern_map cutoff destruction" = + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component _graph = + let%pattern_map a, _ = value in + print_endline "performing work!"; + a + in + let handle = Handle.create (Result_spec.string (module Int)) component in + Handle.show handle; + [%expect {| + performing work! + 0 |}]; + Bonsai.Var.set var (0, 1); + Handle.show handle; + (* No work is performed! *) + [%expect {| 0 |}]; + Bonsai.Var.set var (1, 1); + Handle.show handle; + [%expect {| + performing work! + 1 |}] +;; + +let%expect_test "let%arr cutoff destruction" = + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component _graph = + let%arr a, _ = value in + print_endline "performing work!"; + a + in + let handle = Handle.create (Result_spec.string (module Int)) component in + Handle.show handle; + [%expect {| + performing work! + 0 |}]; + Bonsai.Var.set var (0, 1); + Handle.show handle; + (* No work is performed! *) + [%expect {| 0 |}]; + Bonsai.Var.set var (1, 1); + Handle.show handle; + [%expect {| + performing work! + 1 |}] +;; + +let%test_module "regression" = + (module struct + (* The regression in question is caused by calling [Value.both] on a dynamic + [Value.Map] and a constant one. Instead of returning a [Value.Both] node, we'd + return a [Value.Fast_map], where the constant value is added to the tuple inside + the folded mapping function. However, when the mapping function that we're folding + into is used for getting better cutoff behavior, this "optimization" actually + undoes it by introducing a fresly-allocated tuple which will not cutoff correctly + anymore. *) + module State = struct + type t = + { a : int + ; b : int + ; c : int + } + [@@deriving fields ~getters] + end + + let%expect_test "" = + let state_var = Bonsai.Var.create { State.a = 2; b = 3; c = 4 } in + let state = Bonsai.Var.value state_var in + let a _graph = Bonsai.map state ~f:State.a in + let component b graph = + let%map a = a graph + and b = b in + printf "Recomputing ; a = %d\n" a; + a + b + in + let c graph = component (Bonsai.map state ~f:State.b) graph in + let handle = Handle.create (Result_spec.string (module Int)) c in + Handle.show handle; + [%expect {| + Recomputing ; a = 2 + 5 |}]; + Bonsai.Var.update state_var ~f:(fun state -> { state with c = 4 }); + Handle.show handle; + [%expect {| 5 |}] + ;; + + let%expect_test "" = + let state_var = Bonsai.Var.create { State.a = 2; b = 3; c = 4 } in + let state = Bonsai.Var.value state_var in + let a _graph = Bonsai.map state ~f:State.a in + let component b graph = + let%map a = a graph + and b = b in + printf "Recomputing ; a = %d\n" a; + a + b + in + let c graph = component (return 3) graph in + let handle = Handle.create (Result_spec.string (module Int)) c in + Handle.show handle; + [%expect {| + Recomputing ; a = 2 + 5 |}]; + Bonsai.Var.update state_var ~f:(fun state -> { state with c = 4 }); + Handle.show handle; + [%expect {| 5 |}] + ;; + end) +;; + +let%expect_test "value_with_override" = + let default_var = Bonsai.Var.create "First Model Value" in + let value = Bonsai.Var.value default_var in + let component graph = + Bonsai_extra.value_with_override ~equal:[%equal: String.t] value graph + in + let handle = + Handle.create + (module struct + type t = string * (string -> unit Effect.t) + type incoming = string + + let view (s, _) = s + let incoming (_, s) = s + end) + component + in + Handle.show handle; + [%expect {| First Model Value |}]; + Bonsai.Var.set default_var "Second Model Value"; + Handle.show handle; + [%expect {| Second Model Value |}]; + Handle.do_actions handle [ "First Override" ]; + Handle.show handle; + [%expect {| First Override |}]; + Bonsai.Var.set default_var "Third Model Value"; + Handle.show handle; + (* Changes to the variable don't matter, now that we have an override. *) + [%expect {| First Override |}]; + Handle.do_actions handle [ "Second Override" ]; + Handle.show handle; + [%expect {| Second Override |}] +;; + +let%expect_test "value_with_override in resetter" = + let default_var = Bonsai.Var.create "First Model Value" in + let handle = + let value = Bonsai.Var.value default_var in + let component graph = + let result, reset_effect = + Bonsai.with_model_resetter graph ~f:(fun graph -> + Bonsai_extra.value_with_override value graph) + in + Bonsai.both result reset_effect + in + Handle.create + (module struct + type t = (string * (string -> unit Effect.t)) * unit Effect.t + + type incoming = + [ `Override of string + | `Reset + ] + + let view ((s, _), _) = s + + let incoming ((_, override), reset) action = + match action with + | `Override s -> override s + | `Reset -> reset + ;; + end) + component + in + Handle.show handle; + [%expect {| First Model Value |}]; + Bonsai.Var.set default_var "Second Model Value"; + Handle.show handle; + [%expect {| Second Model Value |}]; + Handle.do_actions handle [ `Override "First Override" ]; + Handle.show handle; + [%expect {| First Override |}]; + Bonsai.Var.set default_var "Third Model Value"; + Handle.show handle; + (* Changes to the variable don't matter, now that we have an override. *) + [%expect {| First Override |}]; + Handle.do_actions handle [ `Reset ]; + Handle.show handle; + (* Now, the change to the variable becomes visible. *) + [%expect {| Third Model Value |}]; + (* But we can still override *) + Handle.do_actions handle [ `Override "Second Override" ]; + Handle.show handle; + [%expect {| Second Override |}] +;; + +let%expect_test "ordering behavior of skeleton traversal" = + (* NOTE: This test just showcases current traversal order behavior in case it + were to change/matter in the future. *) + let c graph = + let all_values = + [ return () + ; Bonsai.Var.value (Bonsai.Var.create ()) + ; Bonsai.Incr.value_cutoff (return ()) ~equal:phys_equal graph + ; Bonsai.map + (Bonsai.both (Bonsai.return ()) (Bonsai.return ())) + ~f:(fun ((), ()) -> ()) + ] + |> List.reduce_exn ~f:(Bonsai.map2 ~f:(fun () () -> ())) + in + let c1, _inject_c1 = + Bonsai.state_machine1 + ~default_model:() + all_values + graph + ~apply_action:(fun _ctx (_ : unit Bonsai.Computation_status.t) () () -> ()) + in + let c2, _inject_c2 = Bonsai.state () graph in + let c3 = + Bonsai.assoc + (module Unit) + (Bonsai.return Unit.Map.empty) + graph + ~f:(fun _ _ _graph -> return ()) + in + let c4 = + match%sub all_values with + | () -> return () + in + let%map () = all_values + and () = c1 + and () = c2 + and _ = c3 + and () = c4 in + () + in + let skeleton = + Bonsai.Private.Skeleton.Computation.of_computation (Bonsai.Private.top_level_handle c) + in + let pre_order_printer = + object + inherit Bonsai.Private.Skeleton.Traverse.map as super + + method! value value = + printf "value - "; + print_s [%message "" ~_:(Lazy.force value.node_path : Bonsai.Private.Node_path.t)]; + super#value value + + method! computation computation = + printf "computation - "; + print_s + [%message "" ~_:(Lazy.force computation.node_path : Bonsai.Private.Node_path.t)]; + super#computation computation + end + in + pre_order_printer#computation skeleton + |> (ignore : Bonsai.Private.Skeleton.Computation.t -> unit); + [%expect + {| + computation - _1 + computation - 1_1 + value - 1_2 + value - 1-1_1 + value - 1-2_1 + computation - 2_1 + computation - 2-1_1 + value - 2-1_2 + value - 2-1-1_1 + computation - 2-2_1 + computation - 2-2-1_1 + value - 2-2-1_2 + value - 2-2-1-1_1 + computation - 2-2-2_1 + computation - 2-2-2-1_1 + value - 2-2-2-1_2 + value - 2-2-2-1-1_1 + value - 2-2-2-1-2_1 + computation - 2-2-2-2_1 + computation - 2-2-2-2-1_1 + value - 2-2-2-2-1_2 + value - 2-2-2-2-1-1_1 + value - 2-2-2-2-1-2_1 + computation - 2-2-2-2-2_1 + computation - 2-2-2-2-2-1_1 + value - 2-2-2-2-2-1_2 + value - 2-2-2-2-2-1-1_1 + value - 2-2-2-2-2-1-2_1 + computation - 2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-1_2 + computation - 2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-1-1_1 + computation - 2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-1-1_1 + computation - 2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-1_1 + computation - 2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-2-2-1-1_1 + computation - 2-2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-2-2-2-1-1_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-1-1_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-1-2_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-1-2_2 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-1-1_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_2 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-1_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1-2_1 + computation - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2_1 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2_2 + value - 2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-2-1_1 |}] +;; + +let%expect_test "on_activate lifecycle events are run the second frame after the \ + component becomes active" + = + let input_var = Bonsai.Var.create () in + let active_var = Bonsai.Var.create true in + let component graph = + let (_ : unit Bonsai.t), inject = + Bonsai.state_machine1 + ~default_model:() + ~apply_action:(fun _ctx (_ : unit Bonsai.Computation_status.t) () () -> + print_endline "on_activate") + (Bonsai.Var.value input_var) + graph + in + let on_activate = + let%map inject = inject in + inject () + in + Bonsai.Edge.lifecycle ~on_activate graph; + return () + in + let handle = + Handle.create + (Result_spec.sexp (module Unit)) + (fun graph -> + if%sub Bonsai.Var.value active_var then component graph else component graph) + in + (* The on_activate does not run in the first frame; rather, it is enqueued in the effect + handler *) + Handle.recompute_view handle; + [%expect {| |}]; + (* Indeed, it does run the second frame *) + Handle.recompute_view handle; + [%expect {| on_activate |}]; + (* Flip the var to switch the active branch *) + Bonsai.Var.set active_var false; + (* Once again, it's enqueued on the first frame, not run *) + Handle.recompute_view handle; + [%expect {| |}]; + (* But now, if the active branch flips, the on_activate action is dropped! *) + Bonsai.Var.set active_var true; + Handle.recompute_view handle; + [%expect {| on_activate |}] +;; + +let%expect_test "State machine actions that are scheduled while running the actions for \ + a frame are run on the same frame" + = + let component graph = + let model, inject = + Bonsai.state_machine0 + ~default_model:() + ~apply_action:(fun ctx () n -> + let schedule_event = Bonsai.Apply_action_context.schedule_event ctx in + let inject = Bonsai.Apply_action_context.inject ctx in + print_s [%message (n : int)]; + if n <= 0 then () else schedule_event (inject (n - 1))) + graph + in + Bonsai.both model inject + in + let handle = + Handle.create + (module struct + type t = unit * (int -> unit Effect.t) + type incoming = int + + let view _ = "" + let incoming ((), inject) n = inject n + end) + component + in + (* Schedules the action, but does not run it yet *) + Handle.do_actions handle [ 10 ]; + [%expect {| |}]; + (* Runs the action, which schedules more actions that all get run in the same frame *) + Handle.recompute_view handle; + [%expect + {| + (n 10) + (n 9) + (n 8) + (n 7) + (n 6) + (n 5) + (n 4) + (n 3) + (n 2) + (n 1) + (n 0) |}] +;; + +let%expect_test "Bonsai.previous_value" = + let input_var = Bonsai.Var.create 0 in + let active_var = Bonsai.Var.create true in + let component graph = + match%sub Bonsai.Var.value active_var with + | true -> + Bonsai.previous_value ~equal:[%equal: Int.t] (Bonsai.Var.value input_var) graph + | false -> return None + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int option [@@deriving sexp, equal] + end)) + component + in + Handle.show handle; + [%expect {| () |}]; + Handle.show handle; + [%expect {| (0) |}]; + Bonsai.Var.set input_var 1; + Handle.show handle; + [%expect {| (0) |}]; + Bonsai.Var.set input_var 2; + Handle.show handle; + [%expect {| (1) |}]; + Handle.show handle; + [%expect {| (2) |}]; + Bonsai.Var.set active_var false; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set input_var 3; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set active_var true; + Handle.show handle; + [%expect {| (2) |}]; + Handle.show handle; + [%expect {| (3) |}] +;; + +let%expect_test "most_recent_some" = + let var = Bonsai.Var.create 1 in + let active = Bonsai.Var.create true in + let component graph = + match%sub Bonsai.Var.value active with + | true -> + Bonsai.most_recent_some + (Bonsai.Var.value var) + ~equal:[%equal: Int.t] + ~f:(fun x -> if x mod 2 = 0 then Some x else None) + graph + | false -> return None + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int option [@@deriving sexp] + end)) + component + in + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set var 2; + Handle.show handle; + [%expect {| (2) |}]; + Handle.show handle; + [%expect {| (2) |}]; + Bonsai.Var.set active false; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set active true; + Handle.show handle; + [%expect {| (2) |}]; + Bonsai.Var.set active false; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set var 6; + Handle.show handle; + [%expect {| () |}]; + Bonsai.Var.set active true; + Handle.show handle; + [%expect {| (6) |}] +;; + +let%test_module "Action delivery paths" = + (module struct + let%expect_test "Sub/Leaf1/Leaf0" = + let component graph = + let dummy_sm0 = + Bonsai.state_machine0 ~apply_action:(fun _context () () -> ()) ~default_model:() + in + let dummy_sm1 = + Bonsai.state_machine1 + (opaque_const_value ()) + ~apply_action:(fun _context _input () () -> ()) + ~default_model:() + in + let _, inject1 = dummy_sm0 graph in + let _, inject2 = dummy_sm1 graph in + let _, inject3 = dummy_sm0 graph in + let _, inject4 = dummy_sm1 graph in + let%map inject1 = inject1 + and inject2 = inject2 + and inject3 = inject3 + and inject4 = inject4 in + inject1 (), inject2 (), inject3 (), inject4 () + in + let module Action = struct + type t = + | One + | Two + | Three + | Four + [@@deriving sexp_of] + end + in + let handle = + Handle.create + (module struct + type t = unit Effect.t * unit Effect.t * unit Effect.t * unit Effect.t + type incoming = Action.t + + let view _ = "" + + let incoming (i1, i2, i3, i4) = function + | Action.One -> i1 + | Two -> i2 + | Three -> i3 + | Four -> i4 + ;; + end) + component + in + Handle.print_actions handle; + Handle.do_actions handle [ One ]; + Handle.show handle; + [%expect {| ("Processed action" (action (Sub_from (Leaf_static )))) |}]; + Handle.do_actions handle [ Two ]; + Handle.show handle; + [%expect + {| ("Processed action" (action (Sub_into (Sub_from (Leaf_dynamic ))))) |}]; + Handle.do_actions handle [ Three ]; + Handle.show handle; + [%expect + {| + ("Processed action" + (action (Sub_into (Sub_into (Sub_from (Leaf_static )))))) |}]; + Handle.do_actions handle [ Four ]; + Handle.show handle; + (* Does not have a Sub_from, because nothing else is added to the graph after it, + so there's no continuation. *) + [%expect + {| + ("Processed action" + (action (Sub_into (Sub_into (Sub_into (Leaf_dynamic )))))) |}] + ;; + + let%expect_test "Wrap/Model_resetter" = + let component graph = + Bonsai.wrap + graph + ~default_model:() + ~apply_action:(fun _context _ () () -> ()) + ~f:(fun (_ : unit Bonsai.t) inject_outer graph -> + let model_and_inject, inject_reset = + Bonsai.with_model_resetter graph ~f:(fun graph -> + let model, inject = + Bonsai.state_machine1 + ~default_model:() + ~apply_action:(fun _context _input () () -> ()) + (opaque_const_value ()) + graph + in + Bonsai.both model inject) + in + let%map inject_outer = inject_outer + and inject_reset = inject_reset + and _model, inject = model_and_inject in + inject_outer (), inject_reset, inject ()) + in + let module Action = struct + type t = + | Wrap_outer + | Model_reset + | Inject_dynamic + [@@deriving sexp_of] + end + in + let handle = + Handle.create + (module struct + type t = unit Effect.t * unit Effect.t * unit Effect.t + type incoming = Action.t + + let view _ = "" + + let incoming (wrap_outer, model_reset, inject) = function + | Action.Wrap_outer -> wrap_outer + | Model_reset -> model_reset + | Inject_dynamic -> inject + ;; + end) + component + in + Handle.print_actions handle; + Handle.do_actions handle [ Wrap_outer ]; + Handle.show handle; + [%expect {| ("Processed action" (action (Wrap_outer ))) |}]; + Handle.do_actions handle [ Model_reset ]; + Handle.show handle; + [%expect {| + ("Processed action" (action (Wrap_inner Model_reset_outer))) |}]; + Handle.do_actions handle [ Inject_dynamic ]; + Handle.show handle; + [%expect + {| + ("Processed action" + (action (Wrap_inner (Model_reset_inner (Leaf_dynamic ))))) |}] + ;; + + (* Note: Lazy doesn't have a branch point, so its use doesn't affect the action path, + but this test does demonstrate that action paths work as intended with lazy + components. *) + let%expect_test "Switch/Lazy" = + let lazy_branch_var = Bonsai.Var.create false in + let lazy_branch = Bonsai.Var.value lazy_branch_var in + let component graph = + match%sub lazy_branch with + | false -> + let _, inject = + Bonsai.state_machine0 + ~default_model:() + ~apply_action:(fun _context () () -> ()) + graph + in + let%map inject = inject in + inject () + | true -> + (Bonsai.Expert.delay [@alert "-deprecated"]) graph ~f:(fun graph -> + let _, inject = + Bonsai.state_machine0 + ~default_model:() + ~apply_action:(fun _context () () -> ()) + graph + in + let%map inject = inject in + inject ()) + in + let module Action = struct + type t = Inject [@@deriving sexp_of] + end + in + let handle = + Handle.create + (module struct + type t = unit Effect.t + type incoming = Action.t + + let view _ = "" + + let incoming inject = function + | Action.Inject -> inject + ;; + end) + component + in + Handle.print_actions handle; + (* In this case, we should go through the first switch branch and not hit the lazy + case *) + Handle.do_actions handle [ Inject ]; + Handle.show handle; + [%expect {| ("Processed action" (action (Switch 0 (Leaf_static )))) |}]; + Bonsai.Var.set lazy_branch_var true; + Handle.recompute_view_until_stable handle; + (* And alternatively, in this case, we should go through the second branch and hit + the lazy case *) + Handle.do_actions handle [ Inject ]; + Handle.show handle; + [%expect + {| ("Processed action" (action (Switch 1 (Lazy (Leaf_static ))))) |}] + ;; + + let%expect_test "Assoc" = + let input = Bonsai.Var.create (Int.Map.of_alist_exn [ 1, (); 2, () ]) in + let component graph = + Bonsai.assoc + (module Int) + (Bonsai.Var.value input) + graph + ~f:(fun _ _ graph -> + let _, inject = + Bonsai.state_machine0 + ~default_model:() + ~apply_action:(fun _context () () -> ()) + graph + in + let%map inject = inject in + inject ()) + in + let module Action = struct + type t = Entry of int [@@deriving sexp_of] + end + in + let handle = + Handle.create + (module struct + type t = unit Effect.t Int.Map.t + type incoming = Action.t + + let view _ = "" + let incoming m (Action.Entry i) = Map.find_exn m i + end) + component + in + Handle.print_actions handle; + Handle.do_actions handle [ Entry 1 ]; + Handle.show handle; + [%expect {| ("Processed action" (action (Assoc 1 (Leaf_static )))) |}]; + Handle.do_actions handle [ Entry 2 ]; + Handle.show handle; + [%expect {| ("Processed action" (action (Assoc 2 (Leaf_static )))) |}] + ;; + + let%expect_test "Assoc_on" = + let input = Bonsai.Var.create (Int.Map.of_alist_exn [ 1, (); 2, () ]) in + let component graph = + Bonsai.Expert.assoc_on + (module Int) + (module Unit) + ~get_model_key:(fun _ _ -> ()) + ~f:(fun _ _ graph -> + let model, inject = Bonsai.state 0 graph in + Bonsai.both model inject) + (Bonsai.Var.value input) + graph + in + let module Action = struct + type t = + | Entry of + { key : int + ; set_to : int + } + [@@deriving sexp_of] + end + in + let handle = + Handle.create + (module struct + type t = (int * (int -> unit Effect.t)) Int.Map.t + type incoming = Action.t + + let view m = + Map.to_alist m + |> List.map ~f:(fun (i, (state, _inject)) -> i, state) + |> [%sexp_of: (int * int) list] + |> Sexp.to_string_hum + ;; + + let incoming m (Action.Entry { key; set_to }) = + let _state, inject = Map.find_exn m key in + inject set_to + ;; + end) + component + in + Handle.print_actions handle; + Handle.do_actions handle [ Entry { key = 1; set_to = 1 } ]; + Handle.show handle; + [%expect + {| + ("Processed action" (action (Assoc_on 1 () (Leaf_static )))) + ((1 1) (2 1)) |}]; + Handle.do_actions handle [ Entry { key = 2; set_to = 2 } ]; + Handle.show handle; + [%expect + {| + ("Processed action" (action (Assoc_on 2 () (Leaf_static )))) + ((1 2) (2 2)) |}] + ;; + end) +;; + +let%expect_test "use of match%sub outside of graph context" = + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + let (_ : int Bonsai.t) = + match%sub opaque_const_value true with + | true -> Bonsai.return 5 + | false -> Bonsai.return 10 + in + ()); + [%expect {| (Failure "match%sub called outside of the context of a graph") |}] +;; diff --git a/test/of_bonsai_itself/test_cont_bonsai.mli b/test/of_bonsai_itself/test_cont_bonsai.mli new file mode 100644 index 00000000..537e8f54 --- /dev/null +++ b/test/of_bonsai_itself/test_cont_bonsai.mli @@ -0,0 +1 @@ +(*_ This file intentionally left blank *) diff --git a/test/of_bonsai_itself/test_cont_store_named_in_a_ref.ml b/test/of_bonsai_itself/test_cont_store_named_in_a_ref.ml new file mode 100644 index 00000000..ad4fd3ae --- /dev/null +++ b/test/of_bonsai_itself/test_cont_store_named_in_a_ref.ml @@ -0,0 +1,36 @@ +open! Core +open! Import +open Bonsai_test +open Bonsai.Cont.Let_syntax + +(* this test needs to be in its own file because the crash happens at runtime and will + end the incremental universe *) +let%expect_test "store named in a ref" = + let branch = Bonsai.Var.create false in + let name_ref = ref None in + let component graph = + match%sub Bonsai.Var.value branch with + | false -> + let a, _ = Bonsai.Cont.state 5 graph in + name_ref := Some a; + let%map a = a + and branch = Bonsai.Var.value branch in + sprintf "%d %b" a branch + | true -> + (Bonsai.lazy_ [@alert "-deprecated"]) + (lazy + (fun _graph -> + let%map a = Option.value_exn !name_ref + and branch = Bonsai.Var.value branch in + sprintf "%d %b" a branch)) + graph + in + let handle = Handle.create (Result_spec.sexp (module String)) component in + Handle.show handle; + [%expect {| "5 false" |}]; + assert (Option.is_some !name_ref); + Bonsai.Var.set branch true; + Expect_test_helpers_core.require_does_raise [%here] (fun () -> Handle.show handle); + [%expect + {| "A Value.t introduced by some [let%sub] expression was used outside of the scope that it was declared in. Make sure that you aren't storing it inside a ref." |}] +;; diff --git a/test/of_bonsai_itself/test_cont_store_named_in_a_ref.mli b/test/of_bonsai_itself/test_cont_store_named_in_a_ref.mli new file mode 100644 index 00000000..537e8f54 --- /dev/null +++ b/test/of_bonsai_itself/test_cont_store_named_in_a_ref.mli @@ -0,0 +1 @@ +(*_ This file intentionally left blank *) diff --git a/test/of_bonsai_itself/test_cse.ml b/test/of_bonsai_itself/test_cse.ml index 1f621b4a..4a1535ff 100644 --- a/test/of_bonsai_itself/test_cse.ml +++ b/test/of_bonsai_itself/test_cse.ml @@ -16,7 +16,7 @@ let use_two_unit_values a b = let sexp_of_computation c = let module Private = Bonsai.Private in c - |> Private.reveal_computation + |> Private.top_level_handle |> Private.Skeleton.Computation.of_computation |> Private.Skeleton.Computation.sanitize_for_testing |> Private.Skeleton.Computation.minimal_sexp_of_t @@ -49,6 +49,36 @@ let%expect_test "double-use of a Value.t" = computing! |}] ;; +let%expect_test "double-use of a Value.t (inside a computation)" = + let component graph = + (let%sub () = Bonsai.const () in + let dummy_value = + Bonsai.Value.map (opaque_const_value ()) ~f:(fun () -> print_endline "computing!") + in + let%arr () = dummy_value + and () = dummy_value in + ()) + graph + in + evaluate component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs ((Constant (id (Test 0))))))))) + (via (Test 2)) + (into ( + Return ( + value ( + Mapn ( + inputs (( + Mapn ( + inputs ( + (Mapn (inputs (Incr))) + (Mapn (inputs (Incr))))))))))))) + computing! + computing! |}] +;; + let%expect_test "double-use spanning match%sub with value previously computed" = let component = let%sub a = return dummy_value in @@ -195,14 +225,14 @@ let%expect_test "double-use inside of some nested subs" = (from ( Sub (from (Return (value Incr))) - (via (Test 1)) + (via (Test 7)) (into ( Return ( value ( Mapn ( inputs (( - Mapn (inputs ((Named (uid (Test 1))) (Mapn (inputs (Incr)))))))))))))) - (via (Test 7)) + Mapn (inputs ((Named (uid (Test 7))) (Mapn (inputs (Incr)))))))))))))) + (via (Test 10)) (into ( Return ( value ( @@ -211,7 +241,7 @@ let%expect_test "double-use inside of some nested subs" = Mapn ( inputs ( (Named (uid (Test 6))) - (Named (uid (Test 7))))))))))))))) + (Named (uid (Test 10))))))))))))))) computing! computing! |}] ;; @@ -251,7 +281,7 @@ let%expect_test "double-use inside supercomponent" = Mapn ( inputs (( Mapn (inputs ((Named (uid (Test 1))) (Mapn (inputs (Incr)))))))))))) - (via (Test 7)) + (via (Test 8)) (into ( Return ( value ( @@ -260,7 +290,7 @@ let%expect_test "double-use inside supercomponent" = Mapn ( inputs ( (Named (uid (Test 6))) - (Named (uid (Test 7))))))))))))))))) + (Named (uid (Test 8))))))))))))))))) computing! computing! more computing diff --git a/test/of_bonsai_itself/test_cse_cont.ml b/test/of_bonsai_itself/test_cse_cont.ml new file mode 100644 index 00000000..3a592261 --- /dev/null +++ b/test/of_bonsai_itself/test_cse_cont.ml @@ -0,0 +1,305 @@ +open! Core +open! Import +open Bonsai_test + +module Bonsai = struct + include Bonsai.Cont + module Private = Bonsai.Private +end + +open Bonsai.Let_syntax + +let dummy_value () = + Bonsai.map (opaque_const_value ()) ~f:(fun () -> print_endline "computing!") +;; + +let use_two_unit_values a b = + let%arr () = a + and () = b in + () +;; + +let sexp_of_computation c = + let module Private = Bonsai.Private in + c + |> Private.top_level_handle + |> Private.Skeleton.Computation.of_computation + |> Private.Skeleton.Computation.sanitize_for_testing + |> Private.Skeleton.Computation.minimal_sexp_of_t +;; + +let print_computation c = print_s (sexp_of_computation c) + +let evaluate component = + print_computation component; + let _handle = + Handle.create ~optimize:true (Result_spec.string (module Unit)) component + in + () +;; + +let%expect_test "double-use of a Value.t" = + let component _graph = + let dummy = dummy_value () in + let%map () = dummy + and () = dummy in + () + in + evaluate component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 2)) + (into ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 2))))))))) + (via (Test 4)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 4)))))))))))) + computing! |}] +;; + +let%expect_test "double-use spanning match%sub with value previously computed" = + let component _graph = + let a = dummy_value () in + let b = + match%sub opaque_const_value true with + | true -> a + | false -> a + in + use_two_unit_values a b + in + evaluate component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 5)) + (into ( + Sub + (from ( + Switch + (match_ (Named (uid (Test 5)))) + (arms ( + (Return (value (Named (uid (Test 2))))) + (Return (value (Named (uid (Test 2))))))))) + (via (Test 6)) + (into ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 6))))))))) + (via (Test 8)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 8)))))))))))))))) + computing! |}] +;; + +let%expect_test "double-use with first use inside scope" = + let component _graph = + let dummy_value = dummy_value () in + let a = + match%sub opaque_const_value true with + | true -> dummy_value + | false -> dummy_value + in + let b = dummy_value in + use_two_unit_values a b + in + evaluate component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 5)) + (into ( + Sub + (from ( + Switch + (match_ (Named (uid (Test 5)))) + (arms ( + (Return (value (Named (uid (Test 2))))) + (Return (value (Named (uid (Test 2))))))))) + (via (Test 6)) + (into ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 6))) + (Named (uid (Test 2))))))))) + (via (Test 8)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 8)))))))))))))))) + computing! |}] +;; + +let%expect_test "double-use inside of some subs" = + let component graph = + let v = dummy_value () in + let subcomponent _graph = v in + let a = subcomponent graph in + let b = subcomponent graph in + use_two_unit_values a b + in + evaluate component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 2)) + (into ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Named (uid (Test 2))))))))) + (via (Test 4)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 4)))))))))))) + computing! |}] +;; + +let%expect_test "double-use inside of some nested subs" = + let component graph = + let dummy_value = dummy_value () in + let subcomponent graph = + let a = opaque_const () graph in + let%map () = a + and () = dummy_value in + () + in + let a = subcomponent graph in + let b = subcomponent graph in + use_two_unit_values a b + in + evaluate component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Incr (Named (uid (Test 2))))))))) + (via (Test 5)) + (into ( + Sub + (from (Return (value (Mapn (inputs ((Named (uid (Test 5))))))))) + (via (Test 7)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Incr (Named (uid (Test 2))))))))) + (via (Test 10)) + (into ( + Sub + (from (Return (value (Mapn (inputs ((Named (uid (Test 10))))))))) + (via (Test 12)) + (into ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 7))) + (Named (uid (Test 12))))))))) + (via (Test 14)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 14)))))))))))))))))))) + computing! |}] +;; + +let%expect_test "double-use inside supercomponent" = + let component graph = + let i = opaque_const () graph in + let dummy_value = dummy_value () in + let subcomponent _graph = + let%map () = i + and () = dummy_value in + print_endline "more computing" + in + let a = subcomponent graph in + let b = subcomponent graph in + use_two_unit_values a b + in + evaluate component; + [%expect + {| + (Sub + (from (Return (value (Mapn (inputs (Incr)))))) + (via (Test 2)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Incr (Named (uid (Test 2))))))))) + (via (Test 5)) + (into ( + Sub + (from (Return (value (Mapn (inputs ((Named (uid (Test 5))))))))) + (via (Test 7)) + (into ( + Sub + (from (Return (value (Mapn (inputs (Incr (Named (uid (Test 2))))))))) + (via (Test 9)) + (into ( + Sub + (from (Return (value (Mapn (inputs ((Named (uid (Test 9))))))))) + (via (Test 11)) + (into ( + Sub + (from ( + Return ( + value ( + Mapn ( + inputs ( + (Named (uid (Test 7))) + (Named (uid (Test 11))))))))) + (via (Test 13)) + (into (Return (value (Mapn (inputs ((Named (uid (Test 13)))))))))))))))))))) + computing! + more computing + more computing |}] +;; + +let%expect_test "double-use with first use inside scope" = + let component graph = + let subcomponent graph = + let path = Bonsai.path_id graph in + let%map path = path in + print_endline ("computing " ^ path); + path + in + let a = subcomponent graph in + let b = subcomponent graph in + let%map a = a + and b = b in + a ^ " " ^ b + in + let handle = + Handle.create ~optimize:false (Result_spec.string (module String)) component + in + [%expect {| + computing bonsai_path_x_y_y_x_x + computing bonsai_path_x_x_x |}]; + Handle.show handle; + [%expect {| bonsai_path_x_x_x bonsai_path_x_y_y_x_x |}] +;; diff --git a/test/of_bonsai_itself/test_cse_cont.mli b/test/of_bonsai_itself/test_cse_cont.mli new file mode 100644 index 00000000..40e0a78a --- /dev/null +++ b/test/of_bonsai_itself/test_cse_cont.mli @@ -0,0 +1 @@ +(** this file is intentionally left blank *) diff --git a/test/of_bonsai_itself/test_handle_compute_lazy.ml b/test/of_bonsai_itself/test_handle_compute_lazy.ml new file mode 100644 index 00000000..f2e7ef49 --- /dev/null +++ b/test/of_bonsai_itself/test_handle_compute_lazy.ml @@ -0,0 +1,50 @@ +open! Core +open! Import +open Bonsai_test +open Bonsai.For_open + +let handle () = + let var = Bonsai.Var.create 0 in + let handle = + Handle.create + (module struct + type t = int + type incoming = unit + + let view i = + print_endline "computing the view!"; + Int.to_string i + ;; + + let incoming _i () = Effect.Ignore + end) + (Bonsai.read (Bonsai.Var.value var)) + in + handle, var +;; + +let%expect_test "Handle.show forces the view" = + let handle, var = handle () in + Handle.show handle; + [%expect {| + computing the view! + 0 |}]; + Bonsai.Var.set var 1; + Handle.show handle; + [%expect {| + computing the view! + 1 |}] +;; + +let%expect_test "Handle.recompute_view should _not_ force the view" = + let handle, var = handle () in + Handle.recompute_view handle; + [%expect {| |}]; + Bonsai.Var.set var 1; + Handle.recompute_view handle; + [%expect {| |}]; + Handle.show handle; + [%expect {| + computing the view! + 1 |}] +;; diff --git a/test/of_bonsai_itself/test_handle_compute_lazy.mli b/test/of_bonsai_itself/test_handle_compute_lazy.mli new file mode 100644 index 00000000..c3904d79 --- /dev/null +++ b/test/of_bonsai_itself/test_handle_compute_lazy.mli @@ -0,0 +1 @@ +(** this file intentionally left blank *) diff --git a/test/of_bonsai_itself/test_legacy_bonsai.ml b/test/of_bonsai_itself/test_legacy_bonsai.ml index 2432942f..d346ebe1 100644 --- a/test/of_bonsai_itself/test_legacy_bonsai.ml +++ b/test/of_bonsai_itself/test_legacy_bonsai.ml @@ -137,10 +137,9 @@ let%expect_test "enum with action handling `Warn" = ]; [%expect {| - (lib/bonsai/src/proc.ml:102:14 - "An action sent to an [of_module1] has been dropped because its input was not present. This happens when the [of_module1] is inactive when it receives a message." - (action Increment)) - pure 3|}]; + ("An action sent to an [of_module1] has been dropped because its input was not present. This happens when the [of_module1] is inactive when it receives a message." + (action Increment)) + pure 3 |}]; H.do_actions [ Outer Increment ]; [%expect "counter 2"]) ;; @@ -468,12 +467,12 @@ let%expect_test "compose, pure" = let component_b = Bonsai.Arrow_deprecated.pure ~f:(fun input -> input + 2) in let component = component_a >>> component_b in run_test ~component ~initial_input:0 ~f:(fun driver -> - [%expect {| |}]; + [%expect {||}]; let (module H) = Helpers.make ~driver ~sexp_of_result:[%sexp_of: int] in H.show (); - [%expect "2"]; + [%expect {| 2 |}]; H.set_input 11; - [%expect "3"]) + [%expect {| 3 |}]) ;; let%expect_test "pure_incr" = @@ -485,12 +484,12 @@ let%expect_test "pure_incr" = in let component = component_a >>> component_b in run_test ~component ~initial_input:0 ~f:(fun driver -> - [%expect {| |}]; + [%expect {||}]; let (module H) = Helpers.make ~driver ~sexp_of_result:[%sexp_of: int] in H.show (); - [%expect "2"]; + [%expect {| 2 |}]; H.set_input 11; - [%expect "3"]) + [%expect {| 3 |}]) ;; let%expect_test "input projection" = @@ -499,12 +498,12 @@ let%expect_test "input projection" = String.length @>> Bonsai.Arrow_deprecated.pure ~f:(fun input -> input + 1) in run_test ~component ~initial_input:"hi" ~f:(fun driver -> - [%expect {| |}]; + [%expect {||}]; let (module H) = Helpers.make ~driver ~sexp_of_result:[%sexp_of: int] in H.show (); - [%expect "3"]; + [%expect {| 3 |}]; H.set_input "hello"; - [%expect "6"]) + [%expect {| 6 |}]) ;; let%expect_test "assoc on input" = diff --git a/test/of_bonsai_itself/test_linter.ml b/test/of_bonsai_itself/test_linter.ml index 0dd9fa66..051f4d02 100644 --- a/test/of_bonsai_itself/test_linter.ml +++ b/test/of_bonsai_itself/test_linter.ml @@ -10,18 +10,17 @@ let test_location_reference_point = ref [%here] let test_start here = test_location_reference_point := here let test_lint computation = - let computation = Private.reveal_computation computation in + let computation = Private.top_level_handle computation in List.iter (Private.Linter.list_warnings computation) ~f:(fun warning -> print_endline (Private.Linter.Warning.to_string (Private.Linter.Warning.relative_to !test_location_reference_point warning))) ;; -let constant_fold computation = - computation - |> Private.reveal_computation +let constant_fold computation graph = + Private.handle graph ~f:computation |> Private.Constant_fold.constant_fold - |> Private.conceal_computation + |> Private.perform graph ;; let%expect_test "map2_unfolded_constant_warnings" = @@ -32,9 +31,7 @@ let%expect_test "map2_unfolded_constant_warnings" = a + b in test_lint c; - [%expect - {| - lib/bonsai/test/of_bonsai_itself/test_linter.ml:2:4: unfolded constant |}] + [%expect {| lib/bonsai/test/of_bonsai_itself/test_linter.ml:2:4: unfolded constant |}] ;; let%expect_test "map2_optimized_gets_no_warnings" = @@ -131,6 +128,6 @@ let%expect_test "map2_with_unfolded_constants_and_sm1_with_const_input_both_warn test_lint c; [%expect {| - lib/bonsai/test/of_bonsai_itself/test_linter.ml:2:4: state_machine1 can be optimized to a state_machine0 + _none_:0:0: state_machine1 can be optimized to a state_machine0 lib/bonsai/test/of_bonsai_itself/test_linter.ml:11:4: unfolded constant |}] ;; diff --git a/test/of_bonsai_itself/test_model_action_and_input_shapes.ml b/test/of_bonsai_itself/test_model_action_and_input_shapes.ml index c2f5ff0a..065c8c5a 100644 --- a/test/of_bonsai_itself/test_model_action_and_input_shapes.ml +++ b/test/of_bonsai_itself/test_model_action_and_input_shapes.ml @@ -16,8 +16,8 @@ let rec censor_sexp : Sexp.t -> Sexp.t = function let graph_stats c = let driver = Bonsai_driver.create - c - (* we explicitly optimize the computation ourselves inside of [print], so don't do anything here. *) + (fun graph -> Bonsai.Private.perform graph c) + (* we explicitly optimize the computation ourselves inside of [print], so don't do anything here. *) ~optimize:false ~clock:(Ui_time_source.create ~start:Time_ns.epoch) in @@ -34,8 +34,8 @@ let graph_stats c = let description c = let module Meta = Bonsai.Private.Meta in let module Action = Bonsai.Private.Action in - let (T { model; action; input; _ }) = - Bonsai.Private.reveal_computation c |> Bonsai.Private.gather + let (Bonsai.Private.Computation.T { model; action; input; _ }) = + Bonsai.Private.gather c in let model = Meta.Model.Type_id.sexp_of_t [%sexp_of: opaque] model.type_id in let action = Action.Type_id.sexp_of_t action in @@ -53,12 +53,9 @@ let prepend_sexp s : Sexp.t -> Sexp.t = function ;; let print c = - let pre_optimization = description c + let pre_optimization = description (Bonsai.Private.top_level_handle c) and post_optimization = - Bonsai.Private.reveal_computation c - |> Bonsai.Private.pre_process - |> Bonsai.Private.conceal_computation - |> description + Bonsai.Private.top_level_handle c |> Bonsai.Private.pre_process |> description in if Sexp.equal pre_optimization post_optimization then pre_optimization |> prepend_sexp "with and without optimizations" |> print_s diff --git a/test/of_bonsai_itself/test_proc_bonsai.ml b/test/of_bonsai_itself/test_proc_bonsai.ml index c98ab142..8204879c 100644 --- a/test/of_bonsai_itself/test_proc_bonsai.ml +++ b/test/of_bonsai_itself/test_proc_bonsai.ml @@ -11,9 +11,13 @@ let unreachable_action : Nothing.t Action.leaf Action.t -> 'b = function | Leaf_static _ -> . ;; -let sexp_of_packed_computation : type a. a Bonsai.Private.Computation.t -> Sexp.t = - fun t -> - Bonsai.Private.Skeleton.Computation.of_computation t +let sexp_of_packed_computation + : type a. ?optimize:bool -> a Bonsai.Private.Computation.t -> Sexp.t + = + fun ?(optimize = true) t -> + t + |> (if optimize then Bonsai.Private.pre_process else Fn.id) + |> Bonsai.Private.Skeleton.Computation.of_computation |> Bonsai.Private.Skeleton.Computation.sanitize_for_testing |> Bonsai.Private.Skeleton.Computation.minimal_sexp_of_t ;; @@ -179,6 +183,14 @@ let%expect_test "What happens when cutoff nodes are nested?" = end)) component in + print_s (sexp_of_packed_computation (Bonsai.Private.top_level_handle component)); + [%expect + {| + (Return ( + value ( + Cutoff + (t Incr) + (added_by_let_syntax false)))) |}]; Handle.show handle; [%expect {| (0 0) |}]; (* First element changes. *) @@ -197,6 +209,62 @@ let%expect_test "What happens when cutoff nodes are nested?" = [%expect {| (1 2) |}] ;; +let%expect_test "What happens when cutoff nodes are nested (return and sub are used)" = + let var = Bonsai.Var.create (0, 0) in + let value = Bonsai.Var.value var in + let component = + let%sub first_cutoff = + return (Value.cutoff value ~equal:(fun (_, a) (_, b) -> phys_equal a b)) + in + let%sub second_cutoff = + return (Value.cutoff first_cutoff ~equal:(fun (a, _) (b, _) -> phys_equal a b)) + in + return second_cutoff + in + let handle = + Handle.create + (Result_spec.sexp + (module struct + type t = int * int [@@deriving sexp] + end)) + component + in + print_s (sexp_of_packed_computation (Bonsai.Private.top_level_handle component)); + [%expect + {| + (Sub + (from ( + Return ( + value ( + Cutoff + (t Incr) + (added_by_let_syntax false))))) + (via (Test 2)) + (into ( + Return ( + value (Cutoff (t (Named (uid (Test 2)))) (added_by_let_syntax false)))))) |}]; + Handle.show handle; + [%expect {| (0 0) |}]; + (* First element changes. *) + Bonsai.Var.set var (1, 0); + Handle.show handle; + (* Does not recompute! (first cutoff still says they're equal.) *) + [%expect {| (0 0) |}]; + (* Second element changes. *) + Bonsai.Var.set var (0, 2); + (* Does not recompute! (second cutoff still says they're equal.) *) + Handle.show handle; + [%expect {| (0 0) |}]; + Bonsai.Var.set var (1, 2); + (* Does not recompute! (first cutoff still says they're equal.) *) + Handle.show handle; + [%expect {| (0 0) |}]; + Bonsai.Var.set var (2, 3); + (* Only once both cutoffs say that they're unequal at the same time does recomputation happens. *) + Handle.show handle; + [%expect {| (2 3) |}] +;; + let%expect_test "arrow-syntax" = let component = let%sub a = Bonsai.const "hi" in @@ -254,25 +322,6 @@ let%expect_test "call component" = [%expect {| 3 |}] ;; -let%expect_test "store named in a ref" = - let name_ref = ref None in - let component = - let%sub x = - let%sub a = opaque_const 5 in - name_ref := Some a; - let%arr a = a in - a - in - let%arr x = x - and y = Option.value_exn !name_ref in - x + y - in - Expect_test_helpers_core.require_does_raise [%here] (fun () -> - Handle.create (Result_spec.sexp (module Int)) component); - [%expect - {| "A Value.t introduced by the [let%sub] expression at TEST_FILENAME:0:0 was used outside of the scope that it was declared in. Make sure that you aren't storing it inside a ref." |}] -;; - let%expect_test "on_display" = let component = let%sub state, set_state = @@ -543,7 +592,7 @@ let%expect_test "simplify assoc_on" = ~f:(fun _key data -> return data) in component - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.pre_process |> sexp_of_packed_computation |> print_s; @@ -579,12 +628,11 @@ let%expect_test "simple-assoc works with paths" = ((Subst_from (Assoc world) Subst_from) (Subst_from (Assoc world) Subst_into Subst_from)))) |}]; component - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.pre_process |> sexp_of_packed_computation |> print_s; - [%expect {| - (Assoc_simpl (map Incr)) |}] + [%expect {| (Assoc_simpl (map Incr)) |}] ;; let test_assoc_simpl_on_cutoff ~added_by_let_syntax = @@ -601,8 +649,7 @@ let test_assoc_simpl_on_cutoff ~added_by_let_syntax = in print_s Bonsai.Private.( - sexp_of_packed_computation - (Bonsai.Private.Pre_process.pre_process (reveal_computation component))) + sexp_of_packed_computation (Bonsai.Private.pre_process (top_level_handle component))) ;; let%expect_test "assoc simplification behavior on cutoffs" = @@ -902,37 +949,20 @@ let%expect_test "sub constant folding optimization" = and b = b in a + b) in - print_s Bonsai.Private.(sexp_of_packed_computation (reveal_computation component)); + print_s + Bonsai.Private.( + sexp_of_packed_computation ~optimize:false (top_level_handle component)); [%expect {| - (Sub - (from (Return (value (Constant (id (Test 0)))))) - (via (Test 1)) - (into ( - Sub - (from (Return (value (Constant (id (Test 2)))))) - (via (Test 3)) - (into ( - Return ( - value ( - Mapn ( - inputs (( - Mapn ( - inputs ( - (Named (uid (Test 1))) - (Named (uid (Test 3))))))))))))))) |}]; - let component = - component - |> Bonsai.Private.reveal_computation - |> Bonsai.Private.Constant_fold.constant_fold - |> Bonsai.Private.conceal_computation - in - print_s Bonsai.Private.(sexp_of_packed_computation (reveal_computation component)); - [%expect {| (Return (value (Constant (id (Test 0))))) |}]; - let component = - component |> Bonsai.Private.reveal_computation |> Bonsai.Private.conceal_computation - in - print_s Bonsai.Private.(sexp_of_packed_computation (reveal_computation component)); + (Return ( + value ( + Mapn ( + inputs (( + Mapn ( + inputs ( + (Constant (id (Test 0))) + (Constant (id (Test 1))))))))))) |}]; + print_s (sexp_of_packed_computation (Bonsai.Private.top_level_handle component)); [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; @@ -948,37 +978,29 @@ let%expect_test "let%map constant folding optimization" = and b = b in a + b) in - print_s Bonsai.Private.(sexp_of_packed_computation (reveal_computation component)); + print_s + Bonsai.Private.( + sexp_of_packed_computation ~optimize:false (top_level_handle component)); [%expect {| (Sub (from (Return (value (Mapn (inputs ((Constant (id (Test 0))))))))) (via (Test 2)) (into ( - Sub - (from (Return (value (Constant (id (Test 3)))))) - (via (Test 4)) - (into ( - Return ( - value ( - Mapn ( - inputs (( - Mapn ( - inputs ( - (Named (uid (Test 2))) - (Named (uid (Test 4))))))))))))))) |}]; + Return ( + value ( + Mapn ( + inputs (( + Mapn ( + inputs ( + (Named (uid (Test 2))) + (Constant (id (Test 3))))))))))))) |}]; let component = component - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.Constant_fold.constant_fold - |> Bonsai.Private.conceal_computation in - print_s Bonsai.Private.(sexp_of_packed_computation (reveal_computation component)); - [%expect {| (Return (value (Constant (id (Test 0))))) |}]; - let component = - component |> Bonsai.Private.reveal_computation |> Bonsai.Private.conceal_computation - in - print_s Bonsai.Private.(sexp_of_packed_computation (reveal_computation component)); + print_s (sexp_of_packed_computation component); [%expect {| (Return (value (Constant (id (Test 0))))) |}] ;; @@ -991,8 +1013,7 @@ let%expect_test "assoc simplifies its inner computation, if possible" = ~f:(fun key data -> Bonsai.read (Value.both key data)) in print_s - Bonsai.Private.( - sexp_of_packed_computation (pre_process (reveal_computation component))); + Bonsai.Private.(sexp_of_packed_computation (pre_process (top_level_handle component))); [%expect {| (Assoc_simpl (map Incr)) |}] ;; @@ -1008,8 +1029,7 @@ let%expect_test "assoc with sub simplifies its inner computation, if possible" = Bonsai.read (Bonsai.Value.both key data)) in print_s - Bonsai.Private.( - sexp_of_packed_computation (pre_process (reveal_computation component))); + Bonsai.Private.(sexp_of_packed_computation (pre_process (top_level_handle component))); [%expect {| (Assoc_simpl (map Incr)) |}] ;; @@ -1025,8 +1045,7 @@ let%expect_test "assoc with sub simplifies its inner computation, if possible" = Bonsai.read (Bonsai.Value.both key data)) in print_s - Bonsai.Private.( - sexp_of_packed_computation (pre_process (reveal_computation component))); + Bonsai.Private.(sexp_of_packed_computation (pre_process (top_level_handle component))); [%expect {| (Assoc_simpl (map Incr)) |}] ;; @@ -1067,7 +1086,7 @@ let%expect_test "map > lazy" = (Result_spec.sexp (module Sexp)) (f ~t:t_value ~depth:(Bonsai.Value.return 0)) in - [%expect {| |}]; + [%expect {||}]; Handle.show handle; [%expect {| (hi (depth 0) (children ())) |}]; Bonsai.Var.set @@ -1273,7 +1292,7 @@ let%test_module "inactive delivery" = let print_computation computation = computation (Bonsai.Value.return ()) - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.pre_process |> sexp_of_packed_computation |> censor_sexp @@ -1440,7 +1459,7 @@ let%test_module "inactive delivery" = ~equal:[%equal: Int.t] ~sexp_of_action:[%sexp_of: Int.t] ~default_model:0 - ~recv:(fun ~schedule_event:_ input model new_model -> + ~recv:(fun ~inject:_ ~schedule_event:_ input model new_model -> match input with | Active () -> new_model, () | Inactive -> @@ -1491,7 +1510,7 @@ let%test_module "inactive delivery" = ~equal:[%equal: Int.t] ~sexp_of_action:[%sexp_of: Int.t] ~default_model:0 - ~recv:(fun ~schedule_event:_ _model new_model -> new_model, ())) + ~recv:(fun ~inject:_ ~schedule_event:_ _model new_model -> new_model, ())) |> test_delivery_to_inactive_component; [%expect {| @@ -1533,7 +1552,7 @@ let%test_module "inactive delivery" = ~equal:[%equal: Int.t] ~sexp_of_action:[%sexp_of: Int.t] ~default_model:0 - ~recv:(fun ~schedule_event:_ input model new_model -> + ~recv:(fun ~inject:_ ~schedule_event:_ input model new_model -> match input with | Active () -> new_model, () | Inactive -> @@ -1643,28 +1662,28 @@ let%test_module "inactive delivery" = |> test_delivery_to_inactive_component; [%expect {| - (Sub - (from (Return (value Incr))) - (via (Test 1)) - (into ( - Switch - (match_ (Mapn (inputs (Named (uid (Test 1)))))) - (arms ( - (Sub - (from (Return (value Incr))) - (via (Test 4)) - (into ( - Switch - (match_ (Mapn (inputs (Named (uid (Test 4)))))) - (arms ((Lazy t) Leaf0))))) - (Return (value Exception))))))) - ((1 0) (2 0)) - ((1 0) (2 3)) - ((1 0)) - ((1 0)) - ((1 0) (2 4)) + (Sub + (from (Return (value Incr))) + (via (Test 1)) + (into ( + Switch + (match_ (Mapn (inputs (Named (uid (Test 1)))))) + (arms ( + (Sub + (from (Return (value Incr))) + (via (Test 4)) + (into ( + Switch + (match_ (Mapn (inputs (Named (uid (Test 4)))))) + (arms ((Lazy t) Leaf0))))) + (Return (value Exception))))))) + ((1 0) (2 0)) + ((1 0) (2 3)) + ((1 0)) + ((1 0)) + ((1 0) (2 4)) - ==== Diff between assoc and assoc_on: ==== |}] + ==== Diff between assoc and assoc_on: ==== |}] ;; let%expect_test "static inside of a fix (optimized away)" = @@ -2315,8 +2334,8 @@ let%test_module "inactive delivery" = (* notice that there are two printings of 'resetting' because even though there's three active components, there are only two models between them *) [%expect {| - resetting - resetting |}]; + resetting + resetting |}]; Handle.show handle; [%expect {| ((0 999) (1 999) (2 999)) |}] ;; @@ -2366,6 +2385,15 @@ let%test_module "inactive delivery" = component in print_computation (fun _ -> component); + [%expect + {| + (Assoc_on + (map Incr) + (io_key_id (Test 1)) + (model_key_id (Test 2)) + (model_cmp_id (Test 3)) + (data_id (Test 4)) + (by (Leaf1 (input Incr)))) |}]; Handle.show handle; let result = Handle.last_result handle in let set key to_what = @@ -2391,20 +2419,13 @@ let%test_module "inactive delivery" = Handle.show handle; [%expect {| - (Assoc_on - (map Incr) - (io_key_id (Test 1)) - (model_key_id (Test 2)) - (model_cmp_id (Test 3)) - (data_id (Test 4)) - (by (Leaf1 (input Incr)))) - ((1 0) (2 0)) - ((1 3) (2 3)) - ((1 3)) - inactive - ((1 3)) - ((1 5)) - ((1 5) (2 5)) |}] + ((1 0) (2 0)) + ((1 3) (2 3)) + ((1 3)) + inactive + ((1 3)) + ((1 5)) + ((1 5) (2 5)) |}] ;; end) ;; @@ -2495,8 +2516,8 @@ let%expect_test "multiple maps respect cutoff" = in Handle.show handle; [%expect {| - triggered - () |}]; + triggered + () |}]; Bonsai.Var.set var 2; (* Cutoff happens on the unit, so "triggered" isn't printed *) Handle.show handle; @@ -2516,7 +2537,7 @@ let%expect_test "let syntax is collapsed upon eval" = in let packed = let open Bonsai.Private in - let computation = reveal_computation computation in + let computation = top_level_handle computation in let (T { model; input = _; apply_action = _; action; run; reset = _ }) = computation |> pre_process |> gather in @@ -2539,7 +2560,8 @@ let%expect_test "let syntax is collapsed upon eval" = require [%here] ~if_false_then_print_s:(lazy [%message "No Map7 node found"]) - (String.is_substring dot_contents ~substring:"Map7") + (String.is_substring dot_contents ~substring:"Map7"); + [%expect {| |}] ;; let%test_unit "constant prop doesn't happen" = @@ -2569,8 +2591,7 @@ let%expect_test "ignored result of assoc" = in let handle = Handle.create (Result_spec.sexp (module Unit)) component in Handle.show handle; - [%expect {| - () |}]; + [%expect {| () |}]; Bonsai.Var.set var (Int.Map.of_alist_exn []); Expect_test_helpers_core.require_does_not_raise [%here] (fun () -> Handle.show handle); [%expect {| () |}] @@ -2590,7 +2611,7 @@ let%expect_test "constant_folding on assoc containing a lifecycle" = return data) in component - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.pre_process |> sexp_of_packed_computation |> print_s; @@ -2631,7 +2652,7 @@ let%expect_test "constant_folding on assoc containing a lifecycle that depends o return data) in component - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.pre_process |> sexp_of_packed_computation |> print_s; @@ -2687,7 +2708,7 @@ let%expect_test "constant_folding on assoc containing a dynamic_scope" = return (Value.both data x))) in component - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.pre_process |> sexp_of_packed_computation |> print_s; @@ -2740,8 +2761,8 @@ let%expect_test "on_display for updating a state (using on_change)" = in Handle.show handle; [%expect {| - rendering... - (change! (prev ()) (cur 1)) |}]; + rendering... + (change! (prev ()) (cur 1)) |}]; Handle.show handle; [%expect {| rendering... |}]; Handle.show handle; @@ -2749,8 +2770,8 @@ let%expect_test "on_display for updating a state (using on_change)" = Bonsai.Var.set var 2; Handle.show handle; [%expect {| - rendering... - (change! (prev (1)) (cur 2)) |}]; + rendering... + (change! (prev (1)) (cur 2)) |}]; Handle.show handle; [%expect {| rendering... |}]; Handle.show handle; @@ -2767,7 +2788,7 @@ let%expect_test "actor" = ~equal:[%equal: Int.t] ~sexp_of_action:[%sexp_of: Unit.t] ~default_model:0 - ~recv:(fun ~schedule_event:_ v () -> v + 1, v) + ~recv:(fun ~inject:_ ~schedule_event:_ v () -> v + 1, v) in return @@ @@ -2792,9 +2813,53 @@ let%expect_test "actor" = Handle.do_actions handle [ (); (); () ]; Handle.show handle; [%expect {| - 1 - 2 - 3 |}] + 1 + 2 + 3 |}] +;; + +let%expect_test "actor sending events to itself" = + let component = + let%sub (), effect = + Bonsai.actor0 () ~default_model:() ~recv:(fun ~inject ~schedule_event () i -> + schedule_event (Effect.print_s [%message "got" ~_:(i : int)]); + (match i with + | 0 -> () + | _ -> + schedule_event + (let%bind.Effect result = inject (i - 1) in + Effect.print_s [%message (result : int)])); + (), i * 2) + in + let%arr effect = effect in + fun x -> Effect.ignore_m (effect x) + in + let handle = + Handle.create + (module struct + type t = int -> unit Effect.t + type incoming = int + + let view _ = "" + let incoming t x = t x + end) + component + in + Handle.do_actions handle [ 5 ]; + Handle.show handle; + [%expect + {| + (got 5) + (got 4) + (result 8) + (got 3) + (result 6) + (got 2) + (result 4) + (got 1) + (result 2) + (got 0) + (result 0) |}] ;; let%expect_test "lifecycle" = @@ -2828,24 +2893,23 @@ let%expect_test "lifecycle" = Handle.create (Result_spec.string (module String)) (component (Bonsai.Var.value var)) in Handle.show handle; - [%expect - {| - ((action activate) (on a)) - ((action after-display) (on a)) |}]; + [%expect {| + ((action activate) (on a)) + ((action after-display) (on a)) |}]; Bonsai.Var.set var false; Handle.show handle; [%expect {| - ((action deactivate) (on a)) - ((action activate) (on b)) - ((action after-display) (on b)) |}]; + ((action deactivate) (on a)) + ((action activate) (on b)) + ((action after-display) (on b)) |}]; Bonsai.Var.set var true; Handle.show handle; [%expect {| - ((action deactivate) (on b)) - ((action activate) (on a)) - ((action after-display) (on a)) |}] + ((action deactivate) (on b)) + ((action activate) (on a)) + ((action after-display) (on a)) |}] ;; let%test_module "Clock.every" = @@ -2885,15 +2949,15 @@ let%test_module "Clock.every" = Handle.recompute_view_until_stable handle; [%expect {| hi |}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); [%expect {| hi |}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); [%expect {| hi |}]) ;; @@ -2931,17 +2995,17 @@ let%test_module "Clock.every" = Handle.recompute_view_until_stable handle in Handle.recompute_view_until_stable handle; - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); [%expect {| hi |}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); - [%expect {| |}]; + [%expect {||}]; move_forward_and_show (); [%expect {| hi |}]) ;; @@ -3068,26 +3132,26 @@ let%test_module "Clock.every" = move_forward_and_show 1.0; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:08.000000000Z - after paint: 00:00:08.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) 2.0; [%expect {| - before: 00:00:08.000000000Z - after: 00:00:10.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:10.200000000Z |}]; + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; (* Does not trigger at 7s + 2 * 3s. *) move_forward_and_show 2.8; [%expect {| - before: 00:00:10.200000000Z - after: 00:00:13.000000000Z - after paint: 00:00:13.000000000Z |}]; + before: 00:00:10.200000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; (* Triggers at 7s (initial) + 3s (first tick) + 0.2s (time taken by first tick) + 3s (time after first click)*) move_forward_and_show @@ -3095,47 +3159,47 @@ let%test_module "Clock.every" = 0.2; [%expect {| - before: 00:00:13.000000000Z - after: 00:00:13.200000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:13.400000000Z |}]; + before: 00:00:13.000000000Z + after: 00:00:13.200000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.400000000Z |}]; (* Starting next trigger without immediately finishing/filling the svar. *) move_forward_and_show 3.0; [%expect {| - before: 00:00:13.400000000Z - after: 00:00:16.400000000Z - [tick] - effect started - after paint: 00:00:16.400000000Z |}]; + before: 00:00:13.400000000Z + after: 00:00:16.400000000Z + [tick] - effect started + after paint: 00:00:16.400000000Z |}]; (* Clock does not trigger before the current action is completed. *) move_forward_and_show 3.0; [%expect {| - before: 00:00:16.400000000Z - after: 00:00:19.400000000Z - after paint: 00:00:19.400000000Z |}]; + before: 00:00:16.400000000Z + after: 00:00:19.400000000Z + after paint: 00:00:19.400000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:19.400000000Z - after: 00:00:22.400000000Z - after paint: 00:00:22.400000000Z |}]; + before: 00:00:19.400000000Z + after: 00:00:22.400000000Z + after paint: 00:00:22.400000000Z |}]; fill_and_reset_svar ~svar; [%expect {| [tock] - effect ended |}]; move_forward_and_show 2.9; [%expect {| - before: 00:00:22.400000000Z - after: 00:00:25.300000000Z - after paint: 00:00:25.300000000Z |}]; + before: 00:00:22.400000000Z + after: 00:00:25.300000000Z + after paint: 00:00:25.300000000Z |}]; move_forward_and_show 0.1; [%expect {| - before: 00:00:25.300000000Z - after: 00:00:25.400000000Z - [tick] - effect started - after paint: 00:00:25.400000000Z |}] + before: 00:00:25.300000000Z + after: 00:00:25.400000000Z + [tick] - effect started + after paint: 00:00:25.400000000Z |}] ;; let%expect_test "`Wait_period_after_previous_effect_starts_blocking behavior" = @@ -3154,19 +3218,19 @@ let%test_module "Clock.every" = move_forward_and_show 1.0; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:08.000000000Z - after paint: 00:00:08.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) 2.0; [%expect {| - before: 00:00:08.000000000Z - after: 00:00:10.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:10.200000000Z |}]; + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; (* Triggers at 7s + 6.0s unlike the `Wait_period_after_previous_effect_finishes_blocking version of this which would need to wait until 7s + 6.2s. *) @@ -3175,45 +3239,45 @@ let%test_module "Clock.every" = 2.8; [%expect {| - before: 00:00:10.200000000Z - after: 00:00:13.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:13.200000000Z |}]; + before: 00:00:10.200000000Z + after: 00:00:13.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.200000000Z |}]; (* The next trigger will take a long time, 10 seconds! There will be a couple of missed [ticks] and missed [tocks]. *) move_forward_and_show 3.0; [%expect {| - before: 00:00:13.200000000Z - after: 00:00:16.200000000Z - [tick] - effect started - after paint: 00:00:16.200000000Z |}]; + before: 00:00:13.200000000Z + after: 00:00:16.200000000Z + [tick] - effect started + after paint: 00:00:16.200000000Z |}]; (* Clock does not tick in before the previous action is complete. *) move_forward_and_show 3.0; [%expect {| - before: 00:00:16.200000000Z - after: 00:00:19.200000000Z - after paint: 00:00:19.200000000Z |}]; + before: 00:00:16.200000000Z + after: 00:00:19.200000000Z + after paint: 00:00:19.200000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:19.200000000Z - after: 00:00:22.200000000Z - after paint: 00:00:22.200000000Z |}]; + before: 00:00:19.200000000Z + after: 00:00:22.200000000Z + after paint: 00:00:22.200000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:22.200000000Z - after: 00:00:25.200000000Z - after paint: 00:00:25.200000000Z |}]; + before: 00:00:22.200000000Z + after: 00:00:25.200000000Z + after paint: 00:00:25.200000000Z |}]; move_forward_and_show 1.0; [%expect {| - before: 00:00:25.200000000Z - after: 00:00:26.200000000Z - after paint: 00:00:26.200000000Z |}]; + before: 00:00:25.200000000Z + after: 00:00:26.200000000Z + after paint: 00:00:26.200000000Z |}]; fill_and_reset_svar ~svar; [%expect {| [tock] - effect ended |}]; (* Time moves slightly forward which results in another trigger. (hence the @@ -3223,30 +3287,30 @@ let%test_module "Clock.every" = 0.01; [%expect {| - before: 00:00:26.200000000Z - after: 00:00:26.210000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:26.410000000Z |}]; + before: 00:00:26.200000000Z + after: 00:00:26.210000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:26.410000000Z |}]; (* Next expected trigger is at 7s + 19.21s + 3s, so going to 7s + 22.11s should not trigger. *) move_forward_and_show 2.7; [%expect {| - before: 00:00:26.410000000Z - after: 00:00:29.110000000Z - after paint: 00:00:29.110000000Z |}]; + before: 00:00:26.410000000Z + after: 00:00:29.110000000Z + after paint: 00:00:29.110000000Z |}]; (* Trigger occurs at 7s + 22.21s as expected! 1*) move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) 0.1; [%expect {| - before: 00:00:29.110000000Z - after: 00:00:29.210000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:29.410000000Z |}] + before: 00:00:29.110000000Z + after: 00:00:29.210000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:29.410000000Z |}] ;; let%test_module "Resilience against bugs from action time being equal to span time" = @@ -3271,25 +3335,25 @@ let%test_module "Clock.every" = move_forward_and_show 3.0; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:10.000000000Z - [tick] - effect started - after paint: 00:00:10.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + after paint: 00:00:10.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:10.000000000Z - after: 00:00:13.000000000Z - after paint: 00:00:13.000000000Z |}]; + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; fill_and_reset_svar ~svar; [%expect {| [tock] - effect ended |}]; move_forward_and_show 0.000001; [%expect {| - before: 00:00:13.000000000Z - after: 00:00:13.000001000Z - [tick] - effect started - after paint: 00:00:13.000001000Z |}] + before: 00:00:13.000000000Z + after: 00:00:13.000001000Z + [tick] - effect started + after paint: 00:00:13.000001000Z |}] ;; let%expect_test _ = @@ -3309,31 +3373,31 @@ let%test_module "Clock.every" = move_forward_and_show 3.; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:10.000000000Z - [tick] - effect started - after paint: 00:00:10.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + after paint: 00:00:10.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:10.000000000Z - after: 00:00:13.000000000Z - after paint: 00:00:13.000000000Z |}]; + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; fill_and_reset_svar ~svar; [%expect {| [tock] - effect ended |}]; move_forward_and_show 0.000001; [%expect {| - before: 00:00:13.000000000Z - after: 00:00:13.000001000Z - after paint: 00:00:13.000001000Z |}]; + before: 00:00:13.000000000Z + after: 00:00:13.000001000Z + after paint: 00:00:13.000001000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:13.000001000Z - after: 00:00:16.000001000Z - [tick] - effect started - after paint: 00:00:16.000001000Z |}] + before: 00:00:13.000001000Z + after: 00:00:16.000001000Z + [tick] - effect started + after paint: 00:00:16.000001000Z |}] ;; let%expect_test _ = @@ -3351,20 +3415,20 @@ let%test_module "Clock.every" = Handle.show handle; Handle.recompute_view handle; [%expect {| - () - [tick] - effect started |}]; + () + [tick] - effect started |}]; move_forward_and_show 3.; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:10.000000000Z - after paint: 00:00:10.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + after paint: 00:00:10.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:10.000000000Z - after: 00:00:13.000000000Z - after paint: 00:00:13.000000000Z |}]; + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; fill_and_reset_svar ~svar; [%expect {| [tock] - effect ended |}]; Handle.recompute_view_until_stable handle @@ -3387,25 +3451,25 @@ let%test_module "Clock.every" = move_forward_and_show 3.0; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:10.000000000Z - [tick] - effect started - after paint: 00:00:10.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + after paint: 00:00:10.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:10.000000000Z - after: 00:00:13.000000000Z - after paint: 00:00:13.000000000Z |}]; + before: 00:00:10.000000000Z + after: 00:00:13.000000000Z + after paint: 00:00:13.000000000Z |}]; fill_and_reset_svar ~svar; [%expect {| [tock] - effect ended |}]; move_forward_and_show 0.000000001; [%expect {| - before: 00:00:13.000000000Z - after: 00:00:13.000000001Z - [tick] - effect started - after paint: 00:00:13.000000001Z |}] + before: 00:00:13.000000000Z + after: 00:00:13.000000001Z + [tick] - effect started + after paint: 00:00:13.000000001Z |}] ;; end) ;; @@ -3426,9 +3490,9 @@ let%test_module "Clock.every" = move_forward_and_show 1.0; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:08.000000000Z - after paint: 00:00:08.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; (* `Every_multiple_of_period_blocking clock triggers on every t where [(t % span) = (init_time % span)] Since initial time is 7s, the clock will trigger on every multiple of 3, but offset by 1, so on 10s, 13s, 15s independent of skips. @@ -3438,82 +3502,82 @@ let%test_module "Clock.every" = 2.0; [%expect {| - before: 00:00:08.000000000Z - after: 00:00:10.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:10.200000000Z |}]; + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; move_forward_and_show 2.7; [%expect {| - before: 00:00:10.200000000Z - after: 00:00:12.900000000Z - after paint: 00:00:12.900000000Z |}]; + before: 00:00:10.200000000Z + after: 00:00:12.900000000Z + after paint: 00:00:12.900000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) 0.1; [%expect {| - before: 00:00:12.900000000Z - after: 00:00:13.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:13.200000000Z |}]; + before: 00:00:12.900000000Z + after: 00:00:13.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.200000000Z |}]; move_forward_and_show 2.8; [%expect {| - before: 00:00:13.200000000Z - after: 00:00:16.000000000Z - [tick] - effect started - after paint: 00:00:16.000000000Z |}]; + before: 00:00:13.200000000Z + after: 00:00:16.000000000Z + [tick] - effect started + after paint: 00:00:16.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:16.000000000Z - after: 00:00:19.000000000Z - after paint: 00:00:19.000000000Z |}]; + before: 00:00:16.000000000Z + after: 00:00:19.000000000Z + after paint: 00:00:19.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:19.000000000Z - after: 00:00:22.000000000Z - after paint: 00:00:22.000000000Z |}]; + before: 00:00:19.000000000Z + after: 00:00:22.000000000Z + after paint: 00:00:22.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:22.000000000Z - after: 00:00:25.000000000Z - after paint: 00:00:25.000000000Z |}]; + before: 00:00:22.000000000Z + after: 00:00:25.000000000Z + after paint: 00:00:25.000000000Z |}]; move_forward_and_show 1.0; [%expect {| - before: 00:00:25.000000000Z - after: 00:00:26.000000000Z - after paint: 00:00:26.000000000Z |}]; + before: 00:00:25.000000000Z + after: 00:00:26.000000000Z + after paint: 00:00:26.000000000Z |}]; fill_and_reset_svar ~svar; [%expect {| [tock] - effect ended |}]; move_forward_and_show 0.1; [%expect {| - before: 00:00:26.000000000Z - after: 00:00:26.100000000Z - after paint: 00:00:26.100000000Z |}]; + before: 00:00:26.000000000Z + after: 00:00:26.100000000Z + after paint: 00:00:26.100000000Z |}]; move_forward_and_show 1.8; [%expect {| - before: 00:00:26.100000000Z - after: 00:00:27.900000000Z - after paint: 00:00:27.900000000Z |}]; + before: 00:00:26.100000000Z + after: 00:00:27.900000000Z + after paint: 00:00:27.900000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) 0.1; [%expect {| - before: 00:00:27.900000000Z - after: 00:00:28.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:28.200000000Z |}] + before: 00:00:27.900000000Z + after: 00:00:28.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:28.200000000Z |}] ;; let%expect_test "`Every_multiple_of_period_non_blocking clock skip behavior" = @@ -3532,9 +3596,9 @@ let%test_module "Clock.every" = move_forward_and_show 1.0; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:08.000000000Z - after paint: 00:00:08.000000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:08.000000000Z + after paint: 00:00:08.000000000Z |}]; (* `Every_multiple_of_period_blocking clock triggers on every t where [(t % span) = (init_time % span)] Since initial time is 7s, the clock will trigger on every multiple of 3, but offset by 1, so on 10s, 13s, 15s independent of skips. @@ -3544,90 +3608,90 @@ let%test_module "Clock.every" = 2.0; [%expect {| - before: 00:00:08.000000000Z - after: 00:00:10.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:10.200000000Z |}]; + before: 00:00:08.000000000Z + after: 00:00:10.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:10.200000000Z |}]; move_forward_and_show 2.7; [%expect {| - before: 00:00:10.200000000Z - after: 00:00:12.900000000Z - after paint: 00:00:12.900000000Z |}]; + before: 00:00:10.200000000Z + after: 00:00:12.900000000Z + after paint: 00:00:12.900000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) 0.1; [%expect {| - before: 00:00:12.900000000Z - after: 00:00:13.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:13.200000000Z |}]; + before: 00:00:12.900000000Z + after: 00:00:13.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:13.200000000Z |}]; move_forward_and_show 2.8; [%expect {| - before: 00:00:13.200000000Z - after: 00:00:16.000000000Z - [tick] - effect started - after paint: 00:00:16.000000000Z |}]; + before: 00:00:13.200000000Z + after: 00:00:16.000000000Z + [tick] - effect started + after paint: 00:00:16.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:16.000000000Z - after: 00:00:19.000000000Z - [tick] - effect started - after paint: 00:00:19.000000000Z |}]; + before: 00:00:16.000000000Z + after: 00:00:19.000000000Z + [tick] - effect started + after paint: 00:00:19.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:19.000000000Z - after: 00:00:22.000000000Z - [tick] - effect started - after paint: 00:00:22.000000000Z |}]; + before: 00:00:19.000000000Z + after: 00:00:22.000000000Z + [tick] - effect started + after paint: 00:00:22.000000000Z |}]; move_forward_and_show 3.0; [%expect {| - before: 00:00:22.000000000Z - after: 00:00:25.000000000Z - [tick] - effect started - after paint: 00:00:25.000000000Z |}]; + before: 00:00:22.000000000Z + after: 00:00:25.000000000Z + [tick] - effect started + after paint: 00:00:25.000000000Z |}]; move_forward_and_show 1.0; [%expect {| - before: 00:00:25.000000000Z - after: 00:00:26.000000000Z - after paint: 00:00:26.000000000Z |}]; + before: 00:00:25.000000000Z + after: 00:00:26.000000000Z + after paint: 00:00:26.000000000Z |}]; fill_and_reset_svar ~svar; [%expect {| - [tock] - effect ended - [tock] - effect ended - [tock] - effect ended - [tock] - effect ended |}]; + [tock] - effect ended + [tock] - effect ended + [tock] - effect ended + [tock] - effect ended |}]; move_forward_and_show 0.1; [%expect {| - before: 00:00:26.000000000Z - after: 00:00:26.100000000Z - after paint: 00:00:26.100000000Z |}]; + before: 00:00:26.000000000Z + after: 00:00:26.100000000Z + after paint: 00:00:26.100000000Z |}]; move_forward_and_show 1.8; [%expect {| - before: 00:00:26.100000000Z - after: 00:00:27.900000000Z - after paint: 00:00:27.900000000Z |}]; + before: 00:00:26.100000000Z + after: 00:00:27.900000000Z + after paint: 00:00:27.900000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.2) 0.1; [%expect {| - before: 00:00:27.900000000Z - after: 00:00:28.000000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:28.200000000Z |}] + before: 00:00:27.900000000Z + after: 00:00:28.000000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:28.200000000Z |}] ;; let%test_module "Resilience against inactive clocks" = @@ -3693,29 +3757,29 @@ let%test_module "Clock.every" = move_forward_and_show 3.0; [%expect {| - [Whoops! An action was dropped!] - after paint: 00:01:03.000000000Z |}]; + [Whoops! An action was dropped!] + after paint: 00:01:03.000000000Z |}]; Handle.show handle; [%expect {| true |}]; move_forward_and_show 3.0; [%expect {| - [Whoops! An action was dropped!] - after paint: 00:01:06.000000000Z |}]; + [Whoops! An action was dropped!] + after paint: 00:01:06.000000000Z |}]; Handle.show handle; [%expect {| true |}]; move_forward_and_show 3.0; [%expect {| - [Whoops! An action was dropped!] - after paint: 00:01:09.000000000Z |}]; + [Whoops! An action was dropped!] + after paint: 00:01:09.000000000Z |}]; Handle.show handle; [%expect {| true |}]; move_forward_and_show 3.0; [%expect {| - [Whoops! An action was dropped!] - after paint: 00:01:12.000000000Z |}]; + [Whoops! An action was dropped!] + after paint: 00:01:12.000000000Z |}]; Handle.show handle; [%expect {| true |}]) ;; @@ -3749,41 +3813,41 @@ let%test_module "Clock.every" = 0.01; [%expect {| - before: 00:00:00.000000000Z - after: 00:00:00.010000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:00.010000000Z |}]; + before: 00:00:00.000000000Z + after: 00:00:00.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.010000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) 0.01; [%expect {| - before: 00:00:00.010000000Z - after: 00:00:00.020000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:00.020000000Z |}]; + before: 00:00:00.010000000Z + after: 00:00:00.020000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.020000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) 0.01; [%expect {| - before: 00:00:00.020000000Z - after: 00:00:00.030000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:00.030000000Z |}]; + before: 00:00:00.020000000Z + after: 00:00:00.030000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.030000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) 0.01; [%expect {| - before: 00:00:00.030000000Z - after: 00:00:00.040000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:00.040000000Z |}]) + before: 00:00:00.030000000Z + after: 00:00:00.040000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:00.040000000Z |}]) ;; let%expect_test _ = @@ -3825,45 +3889,45 @@ let%test_module "Clock.every" = 0.01; [%expect {| - before: 00:00:00.000000000Z - after: 00:00:00.010000000Z - () - [tick] - effect started - [tock] - effect ended - after paint: 00:00:01.010000000Z |}]; + before: 00:00:00.000000000Z + after: 00:00:00.010000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:01.010000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) 0.01; [%expect {| - before: 00:00:01.010000000Z - after: 00:00:01.020000000Z - () - [tick] - effect started - [tock] - effect ended - after paint: 00:00:02.020000000Z |}]; + before: 00:00:01.010000000Z + after: 00:00:01.020000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:02.020000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) 0.01; [%expect {| - before: 00:00:02.020000000Z - after: 00:00:02.030000000Z - () - [tick] - effect started - [tock] - effect ended - after paint: 00:00:03.030000000Z |}]; + before: 00:00:02.020000000Z + after: 00:00:02.030000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:03.030000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.) 0.01; [%expect {| - before: 00:00:03.030000000Z - after: 00:00:03.040000000Z - () - [tick] - effect started - [tock] - effect ended - after paint: 00:00:04.040000000Z |}]) + before: 00:00:03.030000000Z + after: 00:00:03.040000000Z + () + [tick] - effect started + [tock] - effect ended + after paint: 00:00:04.040000000Z |}]) ;; let%expect_test "`Wait_period_after_previous_effect_finishes_blocking skip \ @@ -3885,26 +3949,26 @@ let%test_module "Clock.every" = move_forward_and_show 0.005; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:07.005000000Z - after paint: 00:00:07.005000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:07.005000000Z + after paint: 00:00:07.005000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) 0.005; [%expect {| - before: 00:00:07.005000000Z - after: 00:00:07.010000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:07.012000000Z |}]; + before: 00:00:07.005000000Z + after: 00:00:07.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.012000000Z |}]; (* Does not trigger at 7s + 2 * 0.01. *) move_forward_and_show 0.008; [%expect {| - before: 00:00:07.012000000Z - after: 00:00:07.020000000Z - after paint: 00:00:07.020000000Z |}]; + before: 00:00:07.012000000Z + after: 00:00:07.020000000Z + after paint: 00:00:07.020000000Z |}]; (* Triggers at 7s (initial) + 0.01s (first tick) + 0.002s (time taken by first tick) + 0.001s (time after first click)*) move_forward_and_show @@ -3912,11 +3976,11 @@ let%test_module "Clock.every" = 0.002; [%expect {| - before: 00:00:07.020000000Z - after: 00:00:07.022000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:07.024000000Z |}] + before: 00:00:07.020000000Z + after: 00:00:07.022000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.024000000Z |}] ;; let%expect_test "`Wait_period_after_previous_effect_starts_blocking skip behavior" @@ -3937,19 +4001,19 @@ let%test_module "Clock.every" = move_forward_and_show 0.005; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:07.005000000Z - after paint: 00:00:07.005000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:07.005000000Z + after paint: 00:00:07.005000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) 0.005; [%expect {| - before: 00:00:07.005000000Z - after: 00:00:07.010000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:07.012000000Z |}]; + before: 00:00:07.005000000Z + after: 00:00:07.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.012000000Z |}]; (* Triggers at 7s + 2 * 0.01s unlike the "minimum" version of this which would need to wait until 7s + 2 * 0.01s + 0.002s. *) move_forward_and_show @@ -3957,11 +4021,11 @@ let%test_module "Clock.every" = 0.008; [%expect {| - before: 00:00:07.012000000Z - after: 00:00:07.020000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:07.022000000Z |}]; + before: 00:00:07.012000000Z + after: 00:00:07.020000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.022000000Z |}]; (* The next trigger will take a long time, 10 seconds! There will be a couple of missed [ticks] and missed [tocks]. *) move_forward_and_show @@ -3969,11 +4033,11 @@ let%test_module "Clock.every" = 0.008; [%expect {| - before: 00:00:07.022000000Z - after: 00:00:07.030000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:17.030000000Z |}]; + before: 00:00:07.022000000Z + after: 00:00:07.030000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.030000000Z |}]; (* Time moves slightly forward which results in another trigger. (hence the `Wait_period_after_previous_effect_starts_blocking behavior on skips. )*) move_forward_and_show @@ -3981,27 +4045,27 @@ let%test_module "Clock.every" = 0.00001; [%expect {| - before: 00:00:17.030000000Z - after: 00:00:17.030010000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:17.032010000Z |}]; + before: 00:00:17.030000000Z + after: 00:00:17.030010000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.032010000Z |}]; move_forward_and_show 0.007; [%expect {| - before: 00:00:17.032010000Z - after: 00:00:17.039010000Z - after paint: 00:00:17.039010000Z |}]; + before: 00:00:17.032010000Z + after: 00:00:17.039010000Z + after paint: 00:00:17.039010000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) 0.001; [%expect {| - before: 00:00:17.039010000Z - after: 00:00:17.040010000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:17.042010000Z |}] + before: 00:00:17.039010000Z + after: 00:00:17.040010000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.042010000Z |}] ;; let%expect_test "`Every_multiple_of_period_blocking behavior" = @@ -4020,9 +4084,9 @@ let%test_module "Clock.every" = move_forward_and_show 0.005; [%expect {| - before: 00:00:07.000000000Z - after: 00:00:07.005000000Z - after paint: 00:00:07.005000000Z |}]; + before: 00:00:07.000000000Z + after: 00:00:07.005000000Z + after paint: 00:00:07.005000000Z |}]; (* Clock triggers on every t where [(t % span) = (init_time % span)] Since initial time is 7s, the clock will trigger on every multiple of 3, but offset by 1, so on 10s, 13s, 16s independent of skips. *) @@ -4031,59 +4095,59 @@ let%test_module "Clock.every" = 0.005; [%expect {| - before: 00:00:07.005000000Z - after: 00:00:07.010000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:07.012000000Z |}]; + before: 00:00:07.005000000Z + after: 00:00:07.010000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.012000000Z |}]; move_forward_and_show 0.007; [%expect {| - before: 00:00:07.012000000Z - after: 00:00:07.019000000Z - after paint: 00:00:07.019000000Z |}]; + before: 00:00:07.012000000Z + after: 00:00:07.019000000Z + after paint: 00:00:07.019000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) 0.001; [%expect {| - before: 00:00:07.019000000Z - after: 00:00:07.020000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:07.022000000Z |}]; + before: 00:00:07.019000000Z + after: 00:00:07.020000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:07.022000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 10.0) 0.008; [%expect {| - before: 00:00:07.022000000Z - after: 00:00:07.030000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:17.030000000Z |}]; + before: 00:00:07.022000000Z + after: 00:00:07.030000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.030000000Z |}]; move_forward_and_show 0.001; [%expect {| - before: 00:00:17.030000000Z - after: 00:00:17.031000000Z - after paint: 00:00:17.031000000Z |}]; + before: 00:00:17.030000000Z + after: 00:00:17.031000000Z + after paint: 00:00:17.031000000Z |}]; move_forward_and_show 0.008; [%expect {| - before: 00:00:17.031000000Z - after: 00:00:17.039000000Z - after paint: 00:00:17.039000000Z |}]; + before: 00:00:17.031000000Z + after: 00:00:17.039000000Z + after paint: 00:00:17.039000000Z |}]; move_forward_and_show ~after_show:(fun () -> advance_and_clear_svar ~handle ~svar 0.002) 0.001; [%expect {| - before: 00:00:17.039000000Z - after: 00:00:17.040000000Z - [tick] - effect started - [tock] - effect ended - after paint: 00:00:17.042000000Z |}] + before: 00:00:17.039000000Z + after: 00:00:17.040000000Z + [tick] - effect started + [tock] - effect ended + after paint: 00:00:17.042000000Z |}] ;; end) ;; @@ -4121,21 +4185,21 @@ let%test_module "Clock.every" = in let handle = Handle.create (Result_spec.sexp (module Unit)) component in Handle.recompute_view handle; - [%expect {| |}]; + [%expect {||}]; Handle.recompute_view handle; - [%expect {| |}]; + [%expect {||}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); Handle.recompute_view handle; [%expect {| did action |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); Handle.recompute_view handle; - [%expect {| |}]; + [%expect {||}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); Handle.recompute_view handle; [%expect {| did action |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 10.0); Handle.recompute_view handle; - [%expect {| |}] + [%expect {||}] ;; end) ;; @@ -4414,8 +4478,7 @@ let%expect_test "recompute_view_until_stable does not notice sleep effects" = slept view |}]; Handle.show handle; - [%expect {| - view |}] + [%expect {| view |}] ;; let%expect_test "sleep works even when switching between inactive and active" = @@ -4457,7 +4520,7 @@ let%expect_test "sleep works even when switching between inactive and active" = [%expect {| ("after sleep" (seconds 3)) |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); Handle.show handle; - [%expect {| |}]; + [%expect {||}]; Handle.do_actions handle [ 3.0 ]; Handle.show handle; [%expect {| (inactive (seconds 3)) |}]; @@ -4485,7 +4548,7 @@ let%expect_test "sleep works even when switching between inactive and active" = [%expect {| ("after sleep" (seconds 3)) |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); Handle.show handle; - [%expect {| |}] + [%expect {||}] ;; let edge_poll_shared ~get_expect_output = @@ -4526,18 +4589,15 @@ let%expect_test "Edge.poll in order" = let var, effect_tracker, trigger_display = edge_poll_shared ~get_expect_output in trigger_display (); [%expect {| - ((pending ()) - (output ())) |}]; + ((pending ()) + (output ())) |}]; trigger_display (); - [%expect {| - ((pending (hello)) (output ())) |}]; + [%expect {| ((pending (hello)) (output ())) |}]; Bonsai.Var.set var "world"; trigger_display (); - [%expect {| - ((pending (hello)) (output ())) |}]; + [%expect {| ((pending (hello)) (output ())) |}]; trigger_display (); - [%expect {| - ((pending (world hello)) (output ())) |}]; + [%expect {| ((pending (world hello)) (output ())) |}]; Query_response_tracker.maybe_respond effect_tracker ~f:(fun s -> Respond (String.uppercase s)); trigger_display (); @@ -4551,31 +4611,27 @@ let%expect_test "Edge.poll out of order" = let var, effect_tracker, trigger_display = edge_poll_shared ~get_expect_output in trigger_display (); [%expect {| - ((pending ()) - (output ())) |}]; + ((pending ()) + (output ())) |}]; trigger_display (); - [%expect {| - ((pending (hello)) (output ())) |}]; + [%expect {| ((pending (hello)) (output ())) |}]; Bonsai.Var.set var "world"; trigger_display (); - [%expect {| - ((pending (hello)) (output ())) |}]; + [%expect {| ((pending (hello)) (output ())) |}]; trigger_display (); - [%expect {| - ((pending (world hello)) (output ())) |}]; + [%expect {| ((pending (world hello)) (output ())) |}]; Query_response_tracker.maybe_respond effect_tracker ~f:(function | "world" as s -> Respond (String.uppercase s) | _ -> No_response_yet); trigger_display (); [%expect {| - ((pending (hello)) - (output (WORLD))) |}]; + ((pending (hello)) + (output (WORLD))) |}]; Query_response_tracker.maybe_respond effect_tracker ~f:(function | "hello" as s -> Respond (String.uppercase s) | _ -> No_response_yet); trigger_display (); - [%expect {| - ((pending ()) (output (WORLD))) |}] + [%expect {| ((pending ()) (output (WORLD))) |}] ;; let%expect_test "Clock.now" = @@ -4925,8 +4981,8 @@ let%expect_test "exactly once" = let handle = Handle.create (Result_spec.sexp (module Unit)) component in Handle.show handle; [%expect {| - () - hello! |}]; + () + hello! |}]; Handle.show handle; [%expect {| () |}] ;; @@ -4950,8 +5006,8 @@ let%expect_test "exactly once with value" = in Handle.show handle; [%expect {| - () - hello! |}]; + () + hello! |}]; Handle.show handle; [%expect {| (done) |}] ;; @@ -4978,8 +5034,8 @@ let%expect_test "yoink" = [%expect {| () |}]; Handle.show handle; [%expect {| - (s 1) - () |}] + (s 1) + () |}] ;; let%expect_test "bonk" = @@ -5134,20 +5190,19 @@ let%expect_test "effect-lazy" = Handle.show handle; [%expect {| - computing a... - () - computing a... - () - computing a... - () |}]; + computing a... + () + computing a... + () + computing a... + () |}]; Bonsai.Var.set on false; Handle.show handle; - [%expect - {| - () - (a world) - computing b... - (b world) |}] + [%expect {| + () + (a world) + computing b... + (b world) |}] ;; let%expect_test "id_gen" = @@ -5166,10 +5221,10 @@ let%expect_test "id_gen" = Handle.recompute_view handle; Handle.recompute_view handle; [%expect {| - 0 - 1 - 2 - 3 |}] + 0 + 1 + 2 + 3 |}] ;; let%expect_test "with_self_effect" = @@ -5380,13 +5435,13 @@ let%expect_test "pipe" = [%expect {| (pop a hello) |}]; Handle.do_actions handle [ `Push "world" ]; Handle.recompute_view handle; - [%expect {| |}]; + [%expect {||}]; Handle.do_actions handle [ `Pop "b" ]; Handle.recompute_view handle; [%expect {| (pop b world) |}]; Handle.do_actions handle [ `Pop "c" ]; Handle.recompute_view handle; - [%expect {| |}]; + [%expect {||}]; Handle.do_actions handle [ `Push "foo" ]; Handle.recompute_view handle; [%expect {| (pop c foo) |}]; @@ -5395,9 +5450,9 @@ let%expect_test "pipe" = [ `Push "hello"; `Push "world"; `Push "foo"; `Pop "a"; `Pop "b"; `Pop "c" ]; Handle.recompute_view handle; [%expect {| - (pop a hello) - (pop b world) - (pop c foo) |}] + (pop a hello) + (pop b world) + (pop c foo) |}] ;; let%expect_test "multi-thunk" = @@ -5677,8 +5732,8 @@ let%expect_test "thunk-storage" = let handle = Handle.create (Result_spec.sexp (module String)) component in Handle.show handle; [%expect {| - pulling id! - 0 |}]; + pulling id! + 0 |}]; Bonsai.Var.set var false; Handle.show handle; [%expect {| "" |}]; @@ -5777,8 +5832,8 @@ let%test_module "mirror" = let handle, _store, _interactive = prepare_test ~store:"a" ~interactive:"b" in Handle.show handle; [%expect {| - store: a, interactive: b - interactive set to "a" |}]; + store: a, interactive: b + interactive set to "a" |}]; Handle.show handle; [%expect {| store: a, interactive: a |}] ;; @@ -5790,8 +5845,8 @@ let%test_module "mirror" = Bonsai.Var.set interactive "b"; Handle.show handle; [%expect {| - store: a, interactive: b - store set to "b" |}]; + store: a, interactive: b + store set to "b" |}]; Handle.show handle; [%expect {| store: b, interactive: b |}] ;; @@ -5803,8 +5858,8 @@ let%test_module "mirror" = Bonsai.Var.set store "b"; Handle.show handle; [%expect {| - store: b, interactive: a - interactive set to "b" |}]; + store: b, interactive: a + interactive set to "b" |}]; Handle.show handle; [%expect {| store: b, interactive: b |}] ;; @@ -5817,8 +5872,8 @@ let%test_module "mirror" = Bonsai.Var.set interactive "c"; Handle.show handle; [%expect {| - store: b, interactive: c - store set to "c" |}]; + store: b, interactive: c + store set to "c" |}]; Handle.show handle; [%expect {| store: c, interactive: c |}] ;; @@ -6117,12 +6172,11 @@ let%test_module "regression" = let handle = Handle.create (Result_spec.string (module Int)) c in Handle.show handle; [%expect {| - Recomputing ; a = 2 - 5 |}]; + Recomputing ; a = 2 + 5 |}]; Bonsai.Var.update state_var ~f:(fun state -> { state with c = 4 }); Handle.show handle; - [%expect {| - 5 |}] + [%expect {| 5 |}] ;; let%expect_test "" = @@ -6139,8 +6193,8 @@ let%test_module "regression" = let handle = Handle.create (Result_spec.string (module Int)) c in Handle.show handle; [%expect {| - Recomputing ; a = 2 - 5 |}]; + Recomputing ; a = 2 + 5 |}]; Bonsai.Var.update state_var ~f:(fun state -> { state with c = 4 }); Handle.show handle; [%expect {| 5 |}] @@ -6286,8 +6340,7 @@ let%expect_test "ordering behavior of skeleton traversal" = () in let skeleton = - Bonsai.Private.Skeleton.Computation.of_computation - (Bonsai.Private.reveal_computation c) + Bonsai.Private.Skeleton.Computation.of_computation (Bonsai.Private.top_level_handle c) in let pre_order_printer = object @@ -6390,7 +6443,7 @@ let%expect_test "on_activate lifecycle events are run the second frame after the (* The on_activate does not run in the first frame; rather, it is enqueued in the effect handler *) Handle.recompute_view handle; - [%expect {| |}]; + [%expect {||}]; (* Indeed, it does run the second frame *) Handle.recompute_view handle; [%expect {| on_activate |}]; @@ -6398,12 +6451,11 @@ let%expect_test "on_activate lifecycle events are run the second frame after the Bonsai.Var.set active_var false; (* Once again, it's enqueued on the first frame, not run *) Handle.recompute_view handle; - [%expect {| |}]; + [%expect {||}]; (* But now, if the active branch flips, the on_activate action is dropped! *) Bonsai.Var.set active_var true; Handle.recompute_view handle; - [%expect {| - on_activate |}] + [%expect {| on_activate |}] ;; let%expect_test "State machine actions that are scheduled while running the actions for \ @@ -6438,7 +6490,7 @@ let%expect_test "State machine actions that are scheduled while running the acti in (* Schedules the action, but does not run it yet *) Handle.do_actions handle [ 10 ]; - [%expect {| |}]; + [%expect {||}]; (* Runs the action, which schedules more actions that all get run in the same frame *) Handle.recompute_view handle; [%expect @@ -6617,3 +6669,13 @@ let%expect_test "match%sub implicit tuples" = Handle.show handle; [%expect {| (1 capybara false) |}] ;; + +let%expect_test "There are 0 nodes currently being observed. (This test should ideally \ + be at the end of the file.)" + = + (* This test is a regression test of a behavior where nodes were still being observed + across test runs. *) + let number_of_observed_nodes = Incremental.State.num_active_observers Ui_incr.State.t in + print_s [%message (number_of_observed_nodes : int)]; + [%expect {| (number_of_observed_nodes 0) |}] +;; diff --git a/test/of_bonsai_itself/test_proc_store_named_in_a_ref.ml b/test/of_bonsai_itself/test_proc_store_named_in_a_ref.ml new file mode 100644 index 00000000..521db0b5 --- /dev/null +++ b/test/of_bonsai_itself/test_proc_store_named_in_a_ref.ml @@ -0,0 +1,34 @@ +open! Core +open! Import +open Bonsai_test +open Bonsai.Let_syntax + +(* this test needs to be in its own file because the crash happens at runtime and will + end the incremental universe *) +let%expect_test "store named in a ref" = + let branch = Bonsai.Var.create false in + let name_ref = ref None in + let component = + match%sub Bonsai.Var.value branch with + | false -> + let%sub a, _ = Bonsai.state 5 in + name_ref := Some a; + let%arr a = a + and branch = Bonsai.Var.value branch in + sprintf "%d %b" a branch + | true -> + (Bonsai.lazy_ [@alert "-deprecated"]) + (lazy + (let%arr a = Option.value_exn !name_ref + and branch = Bonsai.Var.value branch in + sprintf "%d %b" a branch)) + in + let handle = Handle.create (Result_spec.sexp (module String)) component in + Handle.show handle; + [%expect {| "5 false" |}]; + assert (Option.is_some !name_ref); + Bonsai.Var.set branch true; + Expect_test_helpers_core.require_does_raise [%here] (fun () -> Handle.show handle); + [%expect + {| "A Value.t introduced by the [let%sub] expression at TEST_FILENAME:0:0 was used outside of the scope that it was declared in. Make sure that you aren't storing it inside a ref." |}] +;; diff --git a/test/of_bonsai_itself/test_proc_store_named_in_a_ref.mli b/test/of_bonsai_itself/test_proc_store_named_in_a_ref.mli new file mode 100644 index 00000000..537e8f54 --- /dev/null +++ b/test/of_bonsai_itself/test_proc_store_named_in_a_ref.mli @@ -0,0 +1 @@ +(*_ This file intentionally left blank *) diff --git a/test/proc.ml b/test/proc.ml index a02ad076..6b6b9c79 100644 --- a/test/proc.ml +++ b/test/proc.ml @@ -2,6 +2,18 @@ open! Core open Bonsai.For_open open! Import +module Expect_test_config = struct + module IO = Monad.Ident + + let run f = + f (); + Bonsai_test_handle_garbage_collector.garbage_collect () + ;; + + let sanitize = Fn.id + let upon_unreleasable_issue = `CR +end + module Result_spec = struct module type S = sig type t @@ -67,7 +79,7 @@ end module Handle = struct type ('result, 'incoming) t = - (unit, 'result * string * ('incoming -> unit Effect.t)) Driver.t + (unit, 'result * string Lazy.t * ('incoming -> unit Effect.t)) Driver.t let create (type result incoming) @@ -82,10 +94,13 @@ module Handle = struct let%sub result = computation in return (let%map result = result in - result, R.view result, R.incoming result) + result, lazy (R.view result), R.incoming result) in let clock = Bonsai.Time_source.create ~start:start_time in - Driver.create ~optimize ~initial_input:() ~clock component + let handle = Driver.create ~optimize ~initial_input:() ~clock component in + Bonsai_test_handle_garbage_collector.register_cleanup (fun () -> + Driver.invalidate_observers handle); + handle ;; let node_paths_from_skeleton @@ -176,7 +191,7 @@ module Handle = struct if false then assert_node_paths_identical_between_transform_and_skeleton_nodepaths - (Bonsai.Private.reveal_computation computation); + (Bonsai.Private.top_level_handle computation); create ?start_time ~optimize result_spec computation ;; @@ -222,7 +237,8 @@ module Handle = struct ;; let show handle = - generic_show handle ~before:(Fn.const ()) ~f:(fun () view -> print_endline view) + generic_show handle ~before:(Fn.const ()) ~f:(fun () view -> + print_endline (Lazy.force view)) ;; let show_diff @@ -230,10 +246,12 @@ module Handle = struct ?(diff_context = 16) handle = - generic_show - handle - ~before:Driver.last_view - ~f:(Expect_test_patdiff.print_patdiff ~location_style ~context:diff_context) + generic_show handle ~before:Driver.last_view ~f:(fun a b -> + Expect_test_patdiff.print_patdiff + ~location_style + ~context:diff_context + (Lazy.force a) + (Lazy.force b)) ;; let store_view handle = generic_show handle ~before:(Fn.const ()) ~f:(fun () _ -> ()) diff --git a/test/proc.mli b/test/proc.mli index c58e6e44..4a285e59 100644 --- a/test/proc.mli +++ b/test/proc.mli @@ -111,3 +111,5 @@ module Handle : sig val print_stabilizations : _ t -> unit val print_stabilization_tracker_stats : _ t -> unit end + +module Expect_test_config : Expect_test_config_types.S with module IO = Monad.Ident diff --git a/test/test_dot/bin/dune b/test/test_dot/bin/dune index 7a9be54f..a7937d99 100644 --- a/test/test_dot/bin/dune +++ b/test/test_dot/bin/dune @@ -1,16 +1,29 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries core core_unix.command_unix bonsai_test_dot) - (preprocess (pps ppx_jane))) + (preprocess + (pps ppx_jane))) (rule (targets tests.md cutoff.svg state.svg dynamic_state.svg diamond.svg - subst_tree.svg many_aliases.svg dynamic_scope.svg assoc_simpl.svg assoc.svg - nested_values.svg enum.svg lazy.svg lazy_forced.svg name_used_twice.svg) - (deps main.exe) (action (bash ./main.exe))) + subst_tree.svg many_aliases.svg dynamic_scope.svg assoc_simpl.svg + assoc.svg nested_values.svg enum.svg lazy.svg lazy_forced.svg + name_used_twice.svg) + (deps main.exe) + (action + (bash ./main.exe))) -(rule (targets tests.html) (deps tests.md) - (action (bash "pandoc tests.md > tests.html"))) +(rule + (targets tests.html) + (deps tests.md) + (action + (bash "pandoc tests.md > tests.html"))) -(alias (name DEFAULT) (deps ./tests.md)) +(alias + (name DEFAULT) + (deps ./tests.md)) -(alias (name generate-html) (deps ./tests.html)) \ No newline at end of file +(alias + (name generate-html) + (deps ./tests.html)) diff --git a/test/test_dot/src/dune b/test/test_dot/src/dune index 7bdcf709..e09d1587 100644 --- a/test/test_dot/src/dune +++ b/test/test_dot/src/dune @@ -1,4 +1,7 @@ -(library (name bonsai_test_dot) (public_name bonsai.test.dot) +(library + (name bonsai_test_dot) + (public_name bonsai.test.dot) (libraries async bonsai core_kernel.composition_infix core - expect_test_helpers_core incr_map bonsai_test core_unix.sys_unix) - (preprocess (pps ppx_jane ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + expect_test_helpers_core incr_map bonsai_test core_unix.sys_unix) + (preprocess + (pps ppx_jane ppx_pattern_bind ppx_bonsai))) diff --git a/test/test_dot/src/test_instrumentation.ml b/test/test_dot/src/test_instrumentation.ml index f2d2a1f2..f2509b28 100644 --- a/test/test_dot/src/test_instrumentation.ml +++ b/test/test_dot/src/test_instrumentation.ml @@ -7,6 +7,12 @@ open Bonsai.Private.Instrumentation module Node_path = Bonsai.Private.Node_path module Graph_info = Bonsai.Private.Graph_info +(** These tests are for our instrumentation of the incremental computation graph. + They can be read as follows: + + {v (opaque-const) --feeds into-> leaf1 --named-as-> _0 v} +*) + let start_timer label = print_endline [%string "start-%{label}"] let stop_timer label = print_endline [%string "stop-%{label}"] @@ -71,7 +77,7 @@ let print_graph_info (graph_info : Graph_info.t) = ;; let write_computation_to_dot filename component = - let component = Private.reveal_computation component in + let component = Private.top_level_handle component in let component = Private.pre_process component in let graph_info = ref Graph_info.empty in let (_ : _ Private.Computation.t) = @@ -83,18 +89,16 @@ let write_computation_to_dot filename component = let instrument_computation component = let graph_info = ref Graph_info.empty in let print_graph_info_on_update = ref false in - let c = - Graph_info.iter_graph_updates - (Bonsai.Private.reveal_computation component) - ~on_update:(fun gm -> + let raw_computation = Bonsai.Private.top_level_handle component in + let instrumented_computation = + Graph_info.iter_graph_updates raw_computation ~on_update:(fun gm -> graph_info := gm; if !print_graph_info_on_update then print_graph_info !graph_info) |> instrument_computation ~start_timer ~stop_timer - |> Bonsai.Private.conceal_computation in print_graph_info !graph_info; print_graph_info_on_update := true; - c + fun graph -> Bonsai.Private.perform graph instrumented_computation ;; let many_aliases () = @@ -116,31 +120,31 @@ let%expect_test _ = [%expect {| tree: - 1_1 return -> _1 sub @ 1:2 + 1_1 return -> _1 sub 1_2 incr -> 1_1 return - 2-1_1 return -> 2_1 sub @ 6:2 + 2-1_1 return -> 2_1 sub 2-1_2 incr -> 2-1_1 return 2-2-1-1_1 named -> 2-2-1_2 map @ 6:2 - 2-2-1_1 return -> 2-2_1 sub @ 6:2 + 2-2-1_1 return -> 2-2_1 sub 2-2-1_2 map @ 6:2 -> 2-2-1_1 return - 2-2-2_1 return -> 2-2_1 sub @ 6:2 - 2-2-2_2 named @ 9:2 -> 2-2-2_1 return - 2-2_1 sub @ 6:2 -> 2_1 sub @ 6:2 - 2_1 sub @ 6:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 + 2-2-2_1 return -> 2-2_1 sub + 2-2-2_2 named -> 2-2-2_1 return + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 dag: - 1_1 return -> 2-2-2_2 named @ 9:2, _1 sub @ 1:2 + 1_1 return -> 2-2-2_2 named, _1 sub 1_2 incr -> 1_1 return - 2-1_1 return -> 2-2-1-1_1 named, 2_1 sub @ 6:2 + 2-1_1 return -> 2-2-1-1_1 named, 2_1 sub 2-1_2 incr -> 2-1_1 return 2-2-1-1_1 named -> 2-2-1_2 map @ 6:2 - 2-2-1_1 return -> 2-2_1 sub @ 6:2 + 2-2-1_1 return -> 2-2_1 sub 2-2-1_2 map @ 6:2 -> 2-2-1_1 return - 2-2-2_1 return -> 2-2_1 sub @ 6:2 - 2-2-2_2 named @ 9:2 -> 2-2-2_1 return - 2-2_1 sub @ 6:2 -> 2_1 sub @ 6:2 - 2_1 sub @ 6:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 |}] + 2-2-2_1 return -> 2-2_1 sub + 2-2-2_2 named -> 2-2-2_1 return + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 |}] ;; let many_aliases_constant_folding () = @@ -164,31 +168,19 @@ let%expect_test _ = [%expect {| tree: - 1_1 return -> _1 sub @ 1:2 - 1_2 constant -> 1_1 return - 2-1_1 return -> 2_1 sub @ 6:2 - 2-1_2 constant -> 2-1_1 return - 2-2-1-1_1 named -> 2-2-1_2 map @ 6:2 - 2-2-1_1 return -> 2-2_1 sub @ 6:2 - 2-2-1_2 map @ 6:2 -> 2-2-1_1 return - 2-2-2_1 return -> 2-2_1 sub @ 6:2 - 2-2-2_2 named @ 9:2 -> 2-2-2_1 return - 2-2_1 sub @ 6:2 -> 2_1 sub @ 6:2 - 2_1 sub @ 6:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 + 1-1_1 constant -> 1_2 map @ 6:2 + 1_1 return -> _1 sub + 1_2 map @ 6:2 -> 1_1 return + 2_1 return -> _1 sub + 2_2 constant -> 2_1 return + _1 sub -> _0 dag: - 1_1 return -> 2-2-2_2 named @ 9:2, _1 sub @ 1:2 - 1_2 constant -> 1_1 return - 2-1_1 return -> 2-2-1-1_1 named, 2_1 sub @ 6:2 - 2-1_2 constant -> 2-1_1 return - 2-2-1-1_1 named -> 2-2-1_2 map @ 6:2 - 2-2-1_1 return -> 2-2_1 sub @ 6:2 - 2-2-1_2 map @ 6:2 -> 2-2-1_1 return - 2-2-2_1 return -> 2-2_1 sub @ 6:2 - 2-2-2_2 named @ 9:2 -> 2-2-2_1 return - 2-2_1 sub @ 6:2 -> 2_1 sub @ 6:2 - 2_1 sub @ 6:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 |}] + 1-1_1 constant -> 1_2 map @ 6:2 + 1_1 return -> _1 sub + 1_2 map @ 6:2 -> 1_1 return + 2_1 return -> _1 sub + 2_2 constant -> 2_1 return + _1 sub -> _0 |}] ;; let subst_tree () = @@ -211,15 +203,15 @@ let%expect_test _ = [%expect {| tree: - 1_1 return -> _1 sub @ 1:2 + 1_1 return -> _1 sub 1_2 incr -> 1_1 return - 2-1_1 return -> 2_1 sub @ 2:2 + 2-1_1 return -> 2_1 sub 2-1_2 incr -> 2-1_1 return - 2-2-1_1 return -> 2-2_1 sub @ 3:2 + 2-2-1_1 return -> 2-2_1 sub 2-2-1_2 incr -> 2-2-1_1 return - 2-2-2-1_1 return -> 2-2-2_1 sub @ 4:2 + 2-2-2-1_1 return -> 2-2-2_1 sub 2-2-2-1_2 incr -> 2-2-2-1_1 return - 2-2-2-2-1_1 return -> 2-2-2-2_1 sub @ 5:2 + 2-2-2-2-1_1 return -> 2-2-2-2_1 sub 2-2-2-2-1_2 incr -> 2-2-2-2-1_1 return 2-2-2-2-2-1-1_1 named -> 2-2-2-2-2-1_1 both 2-2-2-2-2-1-2-1_1 named -> 2-2-2-2-2-1-2_1 both @@ -230,23 +222,23 @@ tree: 2-2-2-2-2-1-2-2_1 both -> 2-2-2-2-2-1-2_1 both 2-2-2-2-2-1-2_1 both -> 2-2-2-2-2-1_1 both 2-2-2-2-2-1_1 both -> 2-2-2-2-2_2 map @ 6:2 - 2-2-2-2-2_1 return -> 2-2-2-2_1 sub @ 5:2 + 2-2-2-2-2_1 return -> 2-2-2-2_1 sub 2-2-2-2-2_2 map @ 6:2 -> 2-2-2-2-2_1 return - 2-2-2-2_1 sub @ 5:2 -> 2-2-2_1 sub @ 4:2 - 2-2-2_1 sub @ 4:2 -> 2-2_1 sub @ 3:2 - 2-2_1 sub @ 3:2 -> 2_1 sub @ 2:2 - 2_1 sub @ 2:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 + 2-2-2-2_1 sub -> 2-2-2_1 sub + 2-2-2_1 sub -> 2-2_1 sub + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 dag: - 1_1 return -> 2-2-2-2-2-1-1_1 named, _1 sub @ 1:2 + 1_1 return -> 2-2-2-2-2-1-1_1 named, _1 sub 1_2 incr -> 1_1 return - 2-1_1 return -> 2-2-2-2-2-1-2-1_1 named, 2_1 sub @ 2:2 + 2-1_1 return -> 2-2-2-2-2-1-2-1_1 named, 2_1 sub 2-1_2 incr -> 2-1_1 return - 2-2-1_1 return -> 2-2-2-2-2-1-2-2-1_1 named, 2-2_1 sub @ 3:2 + 2-2-1_1 return -> 2-2-2-2-2-1-2-2-1_1 named, 2-2_1 sub 2-2-1_2 incr -> 2-2-1_1 return - 2-2-2-1_1 return -> 2-2-2-2-2-1-2-2-2-1_1 named, 2-2-2_1 sub @ 4:2 + 2-2-2-1_1 return -> 2-2-2-2-2-1-2-2-2-1_1 named, 2-2-2_1 sub 2-2-2-1_2 incr -> 2-2-2-1_1 return - 2-2-2-2-1_1 return -> 2-2-2-2-2-1-2-2-2-2_1 named, 2-2-2-2_1 sub @ 5:2 + 2-2-2-2-1_1 return -> 2-2-2-2-2-1-2-2-2-2_1 named, 2-2-2-2_1 sub 2-2-2-2-1_2 incr -> 2-2-2-2-1_1 return 2-2-2-2-2-1-1_1 named -> 2-2-2-2-2-1_1 both 2-2-2-2-2-1-2-1_1 named -> 2-2-2-2-2-1-2_1 both @@ -257,19 +249,19 @@ dag: 2-2-2-2-2-1-2-2_1 both -> 2-2-2-2-2-1-2_1 both 2-2-2-2-2-1-2_1 both -> 2-2-2-2-2-1_1 both 2-2-2-2-2-1_1 both -> 2-2-2-2-2_2 map @ 6:2 - 2-2-2-2-2_1 return -> 2-2-2-2_1 sub @ 5:2 + 2-2-2-2-2_1 return -> 2-2-2-2_1 sub 2-2-2-2-2_2 map @ 6:2 -> 2-2-2-2-2_1 return - 2-2-2-2_1 sub @ 5:2 -> 2-2-2_1 sub @ 4:2 - 2-2-2_1 sub @ 4:2 -> 2-2_1 sub @ 3:2 - 2-2_1 sub @ 3:2 -> 2_1 sub @ 2:2 - 2_1 sub @ 2:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 |}]; + 2-2-2-2_1 sub -> 2-2-2_1 sub + 2-2-2_1 sub -> 2-2_1 sub + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 |}]; let handle = Handle.create (Result_spec.string (module Int)) c in Handle.show handle; [%expect {| - start-##map 2-2-2-2-2_2 - stop-##map 2-2-2-2-2_2 - 15 |}] + start-##map 2-2-2-2-2_2 + stop-##map 2-2-2-2-2_2 + 15 |}] ;; let diamond () = @@ -287,39 +279,39 @@ let%expect_test "diamond" = [%expect {| tree: - 1_1 return -> _1 sub @ 1:2 + 1_1 return -> _1 sub 1_2 incr -> 1_1 return 2-1-1_1 named -> 2-1_2 map - 2-1_1 return -> 2_1 sub @ 2:2 + 2-1_1 return -> 2_1 sub 2-1_2 map -> 2-1_1 return 2-2-1-1_1 named -> 2-2-1_2 map - 2-2-1_1 return -> 2-2_1 sub @ 3:2 + 2-2-1_1 return -> 2-2_1 sub 2-2-1_2 map -> 2-2-1_1 return 2-2-2-1-1_1 named -> 2-2-2-1_1 both 2-2-2-1-2_1 named -> 2-2-2-1_1 both 2-2-2-1_1 both -> 2-2-2_2 map @ 4:2 - 2-2-2_1 return -> 2-2_1 sub @ 3:2 + 2-2-2_1 return -> 2-2_1 sub 2-2-2_2 map @ 4:2 -> 2-2-2_1 return - 2-2_1 sub @ 3:2 -> 2_1 sub @ 2:2 - 2_1 sub @ 2:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 dag: - 1_1 return -> 2-2-1-1_1 named, 2-1-1_1 named, _1 sub @ 1:2 + 1_1 return -> 2-2-1-1_1 named, 2-1-1_1 named, _1 sub 1_2 incr -> 1_1 return 2-1-1_1 named -> 2-1_2 map - 2-1_1 return -> 2-2-2-1-1_1 named, 2_1 sub @ 2:2 + 2-1_1 return -> 2-2-2-1-1_1 named, 2_1 sub 2-1_2 map -> 2-1_1 return 2-2-1-1_1 named -> 2-2-1_2 map - 2-2-1_1 return -> 2-2-2-1-2_1 named, 2-2_1 sub @ 3:2 + 2-2-1_1 return -> 2-2-2-1-2_1 named, 2-2_1 sub 2-2-1_2 map -> 2-2-1_1 return 2-2-2-1-1_1 named -> 2-2-2-1_1 both 2-2-2-1-2_1 named -> 2-2-2-1_1 both 2-2-2-1_1 both -> 2-2-2_2 map @ 4:2 - 2-2-2_1 return -> 2-2_1 sub @ 3:2 + 2-2-2_1 return -> 2-2_1 sub 2-2-2_2 map @ 4:2 -> 2-2-2_1 return - 2-2_1 sub @ 3:2 -> 2_1 sub @ 2:2 - 2_1 sub @ 2:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 |}] + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 |}] ;; let state () = @@ -332,18 +324,11 @@ let state () = let%expect_test "state" = let c = instrument_computation (state ()) in - [%expect - {| + [%expect {| tree: - 1_1 leaf0 -> _1 sub @ 1:2 - 2_1 return -> _1 sub @ 1:2 - 2_2 named -> 2_1 return - _1 sub @ 1:2 -> _0 + _1 leaf0 -> _0 dag: - 1_1 leaf0 -> 2_2 named, _1 sub @ 1:2 - 2_1 return -> _1 sub @ 1:2 - 2_2 named -> 2_1 return - _1 sub @ 1:2 -> _0 |}]; + _1 leaf0 -> _0 |}]; let handle = Handle.create (module struct @@ -361,11 +346,11 @@ let%expect_test "state" = Handle.show handle; [%expect {| - start-##leaf0-apply_action 1_1 - stop-##leaf0-apply_action 1_1 - start-##leaf0-apply_action 1_1 - stop-##leaf0-apply_action 1_1 - 2 |}] + start-##leaf0-apply_action _1 + stop-##leaf0-apply_action _1 + start-##leaf0-apply_action _1 + stop-##leaf0-apply_action _1 + 2 |}] ;; let dynamic_state () = @@ -392,17 +377,11 @@ let%expect_test "dynamic_state" = [%expect {| tree: - 1_1 leaf1 -> _1 sub @ 1:2 - 1_2 incr -> 1_1 leaf1 - 2_1 return -> _1 sub @ 1:2 - 2_2 named -> 2_1 return - _1 sub @ 1:2 -> _0 + _1 leaf1 -> _0 + _2 incr -> _1 leaf1 dag: - 1_1 leaf1 -> 2_2 named, _1 sub @ 1:2 - 1_2 incr -> 1_1 leaf1 - 2_1 return -> _1 sub @ 1:2 - 2_2 named -> 2_1 return - _1 sub @ 1:2 -> _0 |}]; + _1 leaf1 -> _0 + _2 incr -> _1 leaf1 |}]; let handle = Handle.create (module struct @@ -420,10 +399,10 @@ let%expect_test "dynamic_state" = Handle.recompute_view handle; [%expect {| - start-##leaf1-apply_action 1_1 - stop-##leaf1-apply_action 1_1 - start-##leaf1-apply_action 1_1 - stop-##leaf1-apply_action 1_1 |}]; + start-##leaf1-apply_action _1 + stop-##leaf1-apply_action _1 + start-##leaf1-apply_action _1 + stop-##leaf1-apply_action _1 |}]; Handle.show handle; [%expect {| 2 |}] ;; @@ -446,19 +425,19 @@ let%expect_test "dynamic scope" = {| tree: 1_1 constant -> _1 store - 2-1_1 fetch -> 2_1 sub @ 6:7 + 2-1_1 fetch -> 2_1 sub 2-2-1_1 named -> 2-2_2 map @ 7:7 - 2-2_1 return -> 2_1 sub @ 6:7 + 2-2_1 return -> 2_1 sub 2-2_2 map @ 7:7 -> 2-2_1 return - 2_1 sub @ 6:7 -> _1 store + 2_1 sub -> _1 store _1 store -> _0 dag: 1_1 constant -> 2-1_1 fetch, _1 store - 2-1_1 fetch -> 2-2-1_1 named, 2_1 sub @ 6:7 + 2-1_1 fetch -> 2-2-1_1 named, 2_1 sub 2-2-1_1 named -> 2-2_2 map @ 7:7 - 2-2_1 return -> 2_1 sub @ 6:7 + 2-2_1 return -> 2_1 sub 2-2_2 map @ 7:7 -> 2-2_1 return - 2_1 sub @ 6:7 -> _1 store + 2_1 sub -> _1 store _1 store -> _0 |}] ;; @@ -544,23 +523,23 @@ let%expect_test "assoc" = [%expect {| tree: - 1_1 return -> _1 sub @ 1:2 + 1_1 return -> _1 sub 1_2 incr -> 1_1 return 2-1_1 constant -> 2_1 assoc 2-2-1_1 named -> 2-2_2 map @ 6:6 2-2_1 return -> 2_1 assoc 2-2_2 map @ 6:6 -> 2-2_1 return - 2_1 assoc -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 + 2_1 assoc -> _1 sub + _1 sub -> _0 dag: - 1_1 return -> 2-2-1_1 named, _1 sub @ 1:2 + 1_1 return -> 2-2-1_1 named, _1 sub 1_2 incr -> 1_1 return 2-1_1 constant -> 2_1 assoc 2-2-1_1 named -> 2-2_2 map @ 6:6 2-2_1 return -> 2_1 assoc 2-2_2 map @ 6:6 -> 2-2_1 return - 2_1 assoc -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 |}]; + 2_1 assoc -> _1 sub + _1 sub -> _0 |}]; let handle = Handle.create (Result_spec.sexp @@ -572,11 +551,11 @@ let%expect_test "assoc" = Handle.show handle; [%expect {| - start-##map 2-2_2 - stop-##map 2-2_2 - start-##map 2-2_2 - stop-##map 2-2_2 - ((-1 0) (1 0)) |}] + start-##map 2-2_2 + stop-##map 2-2_2 + start-##map 2-2_2 + stop-##map 2-2_2 + ((-1 0) (1 0)) |}] ;; let assoc_constant_folding () = @@ -595,23 +574,17 @@ let%expect_test "assoc constant folding" = [%expect {| tree: - 1_1 return -> _1 sub @ 1:2 - 1_2 constant -> 1_1 return - 2-1_1 constant -> 2_1 assoc - 2-2-1_1 named -> 2-2_2 map @ 6:6 - 2-2_1 return -> 2_1 assoc - 2-2_2 map @ 6:6 -> 2-2_1 return - 2_1 assoc -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 + 1_1 constant -> _1 assoc + 2-1_1 constant -> 2_2 map @ 6:6 + 2_1 return -> _1 assoc + 2_2 map @ 6:6 -> 2_1 return + _1 assoc -> _0 dag: - 1_1 return -> 2-2-1_1 named, _1 sub @ 1:2 - 1_2 constant -> 1_1 return - 2-1_1 constant -> 2_1 assoc - 2-2-1_1 named -> 2-2_2 map @ 6:6 - 2-2_1 return -> 2_1 assoc - 2-2_2 map @ 6:6 -> 2-2_1 return - 2_1 assoc -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 |}]; + 1_1 constant -> _1 assoc + 2-1_1 constant -> 2_2 map @ 6:6 + 2_1 return -> _1 assoc + 2_2 map @ 6:6 -> 2_1 return + _1 assoc -> _0 |}]; let handle = Handle.create (Result_spec.sexp @@ -623,10 +596,10 @@ let%expect_test "assoc constant folding" = Handle.show handle; [%expect {| - start-##map 2-2_2 - stop-##map 2-2_2 - start-##map 2-2_2 - stop-##map 2-2_2 + start-##map 2_2 + stop-##map 2_2 + start-##map 2_2 + stop-##map 2_2 ((-1 0) (1 0)) |}] ;; @@ -673,26 +646,24 @@ let%expect_test "nested values" = Handle.show handle; [%expect {| - start-##map 1-1_1 - stop-##map 1-1_1 - start-##map 1_1 - stop-##map 1_1 - start-##map _2 - stop-##map _2 - 0 - |}]; + start-##map 1-1_1 + stop-##map 1-1_1 + start-##map 1_1 + stop-##map 1_1 + start-##map _2 + stop-##map _2 + 0 |}]; Bonsai.Var.set a_var 2; Handle.show handle; [%expect {| - start-##map 1-1_1 - stop-##map 1-1_1 - start-##map 1_1 - stop-##map 1_1 - start-##map _2 - stop-##map _2 - 2 - |}]; + start-##map 1-1_1 + stop-##map 1-1_1 + start-##map 1_1 + stop-##map 1_1 + start-##map _2 + stop-##map _2 + 2 |}]; Handle.show handle; [%expect {| 2 |}] ;; @@ -718,39 +689,45 @@ let%expect_test "enum" = [%expect {| tree: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 incr -> 2_1 return - 3-1_1 incr -> 3_2 map @ 6:8 - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 map @ 6:8 -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 + 1-1_1 incr -> 1_2 map + 1_1 return -> _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 incr -> 2-2_1 return + 2-3-1_1 incr -> 2-3_2 map @ 6:8 + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 map @ 6:8 -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 dag: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 incr -> 2_1 return - 3-1_1 incr -> 3_2 map @ 6:8 - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 map @ 6:8 -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 + 1-1_1 incr -> 1_2 map + 1_1 return -> 2-1_1 named, _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 incr -> 2-2_1 return + 2-3-1_1 incr -> 2-3_2 map @ 6:8 + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 map @ 6:8 -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 |}]; let handle = Handle.create (Result_spec.sexp (module Bool)) c in Handle.show handle; [%expect {| - start-##map 1_1 - stop-##map 1_1 - start-##map 3_2 - stop-##map 3_2 - false |}]; + start-##map 1_2 + stop-##map 1_2 + start-##map 2-3_2 + stop-##map 2-3_2 + false |}]; Bonsai.Var.set match_var false; Handle.show handle; [%expect {| - start-##map 1_1 - stop-##map 1_1 - false |}]; + start-##map 1_2 + stop-##map 1_2 + false |}]; Bonsai.Var.set a_var 5; Handle.show handle; [%expect {| false |}]; @@ -758,17 +735,17 @@ let%expect_test "enum" = Handle.show handle; [%expect {| - start-##map 1_1 - stop-##map 1_1 - start-##map 3_2 - stop-##map 3_2 - true |}]; + start-##map 1_2 + stop-##map 1_2 + start-##map 2-3_2 + stop-##map 2-3_2 + true |}]; Bonsai.Var.set a_var 10; Handle.show handle; [%expect {| - start-##map 3_2 - stop-##map 3_2 - true |}] + start-##map 2-3_2 + stop-##map 2-3_2 + true |}] ;; let lazy_computation ?(match_ = Value.return true) () = @@ -789,99 +766,129 @@ let%expect_test "lazy" = [%expect {| tree: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 + 1-1_1 incr -> 1_2 map + 1_1 return -> _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 dag: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 + 1-1_1 incr -> 1_2 map + 1_1 return -> 2-1_1 named, _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 |}]; let handle = Handle.create (Result_spec.sexp (module Int)) c in Handle.show handle; [%expect {| - start-##map 1_1 - stop-##map 1_1 - 0 |}]; + start-##map 1_2 + stop-##map 1_2 + 0 |}]; Bonsai.Var.set match_var false; Handle.show handle; [%expect {| - start-##map 1_1 - stop-##map 1_1 - tree: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 return -> 2_1 lazy - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - dag: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - tree: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 return -> 2_1 lazy - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - dag: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 return -> 2_1 lazy - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - tree: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 return -> 2_1 lazy - 2_3 constant -> 2_2 return - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - dag: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 return -> 2_1 lazy - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - tree: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 return -> 2_1 lazy - 2_3 constant -> 2_2 return - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - dag: - 1-1_1 incr -> 1_1 map - 1_1 map -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_1 lazy -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 2_2 return -> 2_1 lazy - 2_3 constant -> 2_2 return - 3_1 return -> _1 switch @ lib/bonsai/src/proc.ml:61:26 - 3_2 constant -> 3_1 return - _1 switch @ lib/bonsai/src/proc.ml:61:26 -> _0 - 0 |}] + start-##map 1_2 + stop-##map 1_2 + tree: + 1-1_1 incr -> 1_2 map + 1_1 return -> _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 return -> 2-2_1 lazy + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + dag: + 1-1_1 incr -> 1_2 map + 1_1 return -> 2-1_1 named, _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + tree: + 1-1_1 incr -> 1_2 map + 1_1 return -> _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 return -> 2-2_1 lazy + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + dag: + 1-1_1 incr -> 1_2 map + 1_1 return -> 2-1_1 named, _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 return -> 2-2_1 lazy + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + tree: + 1-1_1 incr -> 1_2 map + 1_1 return -> _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 return -> 2-2_1 lazy + 2-2_3 constant -> 2-2_2 return + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + dag: + 1-1_1 incr -> 1_2 map + 1_1 return -> 2-1_1 named, _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 return -> 2-2_1 lazy + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + tree: + 1-1_1 incr -> 1_2 map + 1_1 return -> _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 return -> 2-2_1 lazy + 2-2_3 constant -> 2-2_2 return + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + dag: + 1-1_1 incr -> 1_2 map + 1_1 return -> 2-1_1 named, _1 sub + 1_2 map -> 1_1 return + 2-1_1 named -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_1 lazy -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-2_2 return -> 2-2_1 lazy + 2-2_3 constant -> 2-2_2 return + 2-3_1 return -> 2_1 switch @ lib/bonsai/src/cont.ml:826:81 + 2-3_2 constant -> 2-3_1 return + 2_1 switch @ lib/bonsai/src/cont.ml:826:81 -> _1 sub + _1 sub -> _0 + 0 |}] ;; let shared = @@ -901,67 +908,67 @@ let%expect_test "name_used_twice" = [%expect {| tree: - 1-1_1 return -> 1_1 sub @ -5:2 + 1-1_1 return -> 1_1 sub 1-1_2 incr -> 1-1_1 return 1-2-1-1_1 named -> 1-2-1_2 map @ -5:2 - 1-2-1_1 return -> 1-2_1 sub @ -5:2 + 1-2-1_1 return -> 1-2_1 sub 1-2-1_2 map @ -5:2 -> 1-2-1_1 return - 1-2-2_1 return -> 1-2_1 sub @ -5:2 + 1-2-2_1 return -> 1-2_1 sub 1-2-2_2 incr -> 1-2-2_1 return - 1-2_1 sub @ -5:2 -> 1_1 sub @ -5:2 - 1_1 sub @ -5:2 -> _1 sub @ 1:2 + 1-2_1 sub -> 1_1 sub + 1_1 sub -> _1 sub 2-1-1_1 named -> 2-1_2 map @ 1:2 - 2-1_1 return -> 2_1 sub @ 1:2 + 2-1_1 return -> 2_1 sub 2-1_2 map @ 1:2 -> 2-1_1 return - 2-2-1-1_1 return -> 2-2-1_1 sub @ -5:2 + 2-2-1-1_1 return -> 2-2-1_1 sub 2-2-1-1_2 incr -> 2-2-1-1_1 return 2-2-1-2-1-1_1 named -> 2-2-1-2-1_2 map @ -5:2 - 2-2-1-2-1_1 return -> 2-2-1-2_1 sub @ -5:2 + 2-2-1-2-1_1 return -> 2-2-1-2_1 sub 2-2-1-2-1_2 map @ -5:2 -> 2-2-1-2-1_1 return - 2-2-1-2-2_1 return -> 2-2-1-2_1 sub @ -5:2 + 2-2-1-2-2_1 return -> 2-2-1-2_1 sub 2-2-1-2-2_2 incr -> 2-2-1-2-2_1 return - 2-2-1-2_1 sub @ -5:2 -> 2-2-1_1 sub @ -5:2 - 2-2-1_1 sub @ -5:2 -> 2-2_1 sub @ 2:2 + 2-2-1-2_1 sub -> 2-2-1_1 sub + 2-2-1_1 sub -> 2-2_1 sub 2-2-2-1-1_1 named -> 2-2-2-1_2 map @ 2:2 - 2-2-2-1_1 return -> 2-2-2_1 sub @ 2:2 + 2-2-2-1_1 return -> 2-2-2_1 sub 2-2-2-1_2 map @ 2:2 -> 2-2-2-1_1 return - 2-2-2-2_1 return -> 2-2-2_1 sub @ 2:2 + 2-2-2-2_1 return -> 2-2-2_1 sub 2-2-2-2_2 constant -> 2-2-2-2_1 return - 2-2-2_1 sub @ 2:2 -> 2-2_1 sub @ 2:2 - 2-2_1 sub @ 2:2 -> 2_1 sub @ 1:2 - 2_1 sub @ 1:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 + 2-2-2_1 sub -> 2-2_1 sub + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 dag: - 1-1_1 return -> 1-2-1-1_1 named, 1_1 sub @ -5:2 + 1-1_1 return -> 1-2-1-1_1 named, 1_1 sub 1-1_2 incr -> 1-1_1 return 1-2-1-1_1 named -> 1-2-1_2 map @ -5:2 - 1-2-1_1 return -> 1-2_1 sub @ -5:2 + 1-2-1_1 return -> 1-2_1 sub 1-2-1_2 map @ -5:2 -> 1-2-1_1 return - 1-2-2_1 return -> 1-2_1 sub @ -5:2 + 1-2-2_1 return -> 1-2_1 sub 1-2-2_2 incr -> 1-2-2_1 return - 1-2_1 sub @ -5:2 -> 1_1 sub @ -5:2 - 1_1 sub @ -5:2 -> 2-1-1_1 named, _1 sub @ 1:2 + 1-2_1 sub -> 1_1 sub + 1_1 sub -> 2-1-1_1 named, _1 sub 2-1-1_1 named -> 2-1_2 map @ 1:2 - 2-1_1 return -> 2_1 sub @ 1:2 + 2-1_1 return -> 2_1 sub 2-1_2 map @ 1:2 -> 2-1_1 return - 2-2-1-1_1 return -> 2-2-1-2-1-1_1 named, 2-2-1_1 sub @ -5:2 + 2-2-1-1_1 return -> 2-2-1-2-1-1_1 named, 2-2-1_1 sub 2-2-1-1_2 incr -> 2-2-1-1_1 return 2-2-1-2-1-1_1 named -> 2-2-1-2-1_2 map @ -5:2 - 2-2-1-2-1_1 return -> 2-2-1-2_1 sub @ -5:2 + 2-2-1-2-1_1 return -> 2-2-1-2_1 sub 2-2-1-2-1_2 map @ -5:2 -> 2-2-1-2-1_1 return - 2-2-1-2-2_1 return -> 2-2-1-2_1 sub @ -5:2 + 2-2-1-2-2_1 return -> 2-2-1-2_1 sub 2-2-1-2-2_2 incr -> 2-2-1-2-2_1 return - 2-2-1-2_1 sub @ -5:2 -> 2-2-1_1 sub @ -5:2 - 2-2-1_1 sub @ -5:2 -> 2-2-2-1-1_1 named, 2-2_1 sub @ 2:2 + 2-2-1-2_1 sub -> 2-2-1_1 sub + 2-2-1_1 sub -> 2-2-2-1-1_1 named, 2-2_1 sub 2-2-2-1-1_1 named -> 2-2-2-1_2 map @ 2:2 - 2-2-2-1_1 return -> 2-2-2_1 sub @ 2:2 + 2-2-2-1_1 return -> 2-2-2_1 sub 2-2-2-1_2 map @ 2:2 -> 2-2-2-1_1 return - 2-2-2-2_1 return -> 2-2-2_1 sub @ 2:2 + 2-2-2-2_1 return -> 2-2-2_1 sub 2-2-2-2_2 constant -> 2-2-2-2_1 return - 2-2-2_1 sub @ 2:2 -> 2-2_1 sub @ 2:2 - 2-2_1 sub @ 2:2 -> 2_1 sub @ 1:2 - 2_1 sub @ 1:2 -> _1 sub @ 1:2 - _1 sub @ 1:2 -> _0 |}] + 2-2-2_1 sub -> 2-2_1 sub + 2-2_1 sub -> 2_1 sub + 2_1 sub -> _1 sub + _1 sub -> _0 |}] ;; type packed = T : (unit -> 'a Computation.t) -> packed @@ -1017,13 +1024,13 @@ let command = let graph_info = ref Graph_info.empty in let (component : _ Private.Computation.t) = Graph_info.iter_graph_updates - (Bonsai.Private.reveal_computation component) + (Bonsai.Private.top_level_handle component) ~on_update:(fun gm -> graph_info := gm) in let handle = Handle.create (Result_spec.sexp (module Int)) - (Bonsai.Private.conceal_computation component) + (fun graph -> Private.perform graph component) in Handle.recompute_view handle; graph_info_to_dot filename !graph_info @@ -1036,5 +1043,4 @@ let command = Writer.flushed writer in return ()))) - ~behave_nicely_in_pipeline:false ;; diff --git a/uri_parsing/src/dune b/uri_parsing/src/dune index 5a8ea9a5..d1806878 100644 --- a/uri_parsing/src/dune +++ b/uri_parsing/src/dune @@ -1,5 +1,8 @@ -(library (name uri_parsing) (public_name bonsai.uri_parsing) +(library + (name uri_parsing) + (public_name bonsai.uri_parsing) (libraries uri base64 textutils.ascii_table_kernel core re - ppx_typed_fields.typed_fields_lib ppx_typed_fields.typed_variants_lib - ppx_typed_fields.typed_field_map) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_typed_fields))) \ No newline at end of file + ppx_typed_fields.typed_fields_lib ppx_typed_fields.typed_variants_lib + ppx_typed_fields.typed_field_map) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_typed_fields))) diff --git a/uri_parsing/src/uri_parsing.ml b/uri_parsing/src/uri_parsing.ml index 5999c549..3cd530e4 100644 --- a/uri_parsing/src/uri_parsing.ml +++ b/uri_parsing/src/uri_parsing.ml @@ -242,9 +242,16 @@ module Components = struct String.concat ~sep:"/" (List.map ~f:(Uri.pct_encode ~component:`Path) path) ;; + let split_if_nonempty = function + (* NOTE: We need to special case this situation as we would + prefer for String.split to return `[]` instead of `[""]` *) + | "" -> [] + | p -> String.split ~on:'/' p + ;; + let decode_path path = String.chop_prefix_if_exists ~prefix:"/" path - |> String.split ~on:'/' + |> split_if_nonempty |> List.map ~f:Uri.pct_decode ;; @@ -261,7 +268,7 @@ module Components = struct let path = match encoding_behavior with | Percent_encoding_behavior.Legacy_incorrect -> - Uri.path uri |> String.chop_prefix_if_exists ~prefix:"/" |> String.split ~on:'/' + Uri.path uri |> String.chop_prefix_if_exists ~prefix:"/" |> split_if_nonempty | Correct -> decode_path (Uri.path uri) in let query = @@ -742,6 +749,11 @@ module Parser = struct then raise_s [%message "Expected a value in query field, but nothing was present"] ;; + let raise_if_empty_path values = + if List.is_empty values + then raise_s [%message "Expected a value in path, but nothing was present"] + ;; + let namespace_for_record_field ~current_namespace ~override_namespace @@ -943,7 +955,7 @@ module Parser = struct let parse_exn (components : Components.t) = let result, remaining_path = let path = components.path in - raise_if_empty path; + raise_if_empty_path path; value_projection.parse_exn (List.hd_exn path), List.tl_exn path in let remaining = { components with path = remaining_path } in diff --git a/uri_parsing/test/dune b/uri_parsing/test/dune index 29e97877..12c69e5b 100644 --- a/uri_parsing/test/dune +++ b/uri_parsing/test/dune @@ -1,4 +1,6 @@ -(library (name uri_parsing_test) +(library + (name uri_parsing_test) (libraries base64 core patdiff.expect_test_patdiff expect_test_helpers_core - base_quickcheck uri_parsing) - (preprocess (pps ppx_jane ppx_typed_fields ppx_quick_test))) \ No newline at end of file + base_quickcheck uri_parsing uri_jane) + (preprocess + (pps ppx_jane ppx_typed_fields ppx_quick_test))) diff --git a/uri_parsing/test/empty_path_test.ml b/uri_parsing/test/empty_path_test.ml new file mode 100644 index 00000000..b514c10e --- /dev/null +++ b/uri_parsing/test/empty_path_test.ml @@ -0,0 +1,411 @@ +open! Core +open Uri_parsing + +(** These tests are designed to illustrate behavior when `/ paths + are provided an empty string, and how that might conflict with a + `/` path. We also test the analogous `/prefix` + `/prefix/` cases. *) + +let%test_module "Homepage and param if both use `with_prefix`" = + (module struct + module Url = struct + type t = + | Homepage + | Param of string + [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Homepage -> Parser.with_prefix [] Parser.unit + | Param -> Parser.with_prefix [] (Parser.from_path Value_parser.string) + ;; + end + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "This is ambiguous" = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + Error with parser. + ┌─────────────────────────────────────────────────────────┬───────────────────────────────────────────────────────────────┐ + │ Check name │ Error message │ + ├─────────────────────────────────────────────────────────┼───────────────────────────────────────────────────────────────┤ + │ Ambiguous choices for picking variant constructor check │ ("Duplicate patterns found!" │ + │ │ (duplicate_patterns (((pattern ()) (needed_match Prefix))))) │ + └─────────────────────────────────────────────────────────┴───────────────────────────────────────────────────────────────┘ |}] + ;; + end) +;; + +let%test_module "Homepage and param" = + (module struct + module Url = struct + type t = + | Homepage + | Param of string + [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Homepage -> Parser.end_of_path Parser.unit + | Param -> Parser.with_prefix [] (Parser.from_path Value_parser.string) + ;; + end + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "Sanity_check" = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + URL parser looks good! + ┌───────────┐ + │ All urls │ + ├───────────┤ + │ / │ + │ / │ + └───────────┘ |}] + ;; + + let projection = Versioned_parser.eval_for_uri versioned_parser + + let%expect_test "Empty URL round trip" = + let uri = Uri.empty in + let { Parse_result.result = parsed; _ } = projection.parse_exn uri in + print_s [%message (parsed : Url.t)]; + [%expect {| (parsed Homepage) |}]; + let unparsed = projection.unparse (Parse_result.create parsed) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed "") |}]; + [%test_eq: Uri_jane.t] uri unparsed + ;; + + let%expect_test "Homepage roundtrip" = + let url = Url.Homepage in + let unparsed = projection.unparse (Parse_result.create url) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed "") |}]; + let { Parse_result.result = reparsed; _ } = projection.parse_exn unparsed in + print_s [%message (reparsed : Url.t)]; + [%expect {| (reparsed Homepage) |}]; + [%test_eq: Url.t] url reparsed + ;; + + let%expect_test "BUG: Param roundtrip" = + let url = Url.Param "" in + let unparsed = projection.unparse (Parse_result.create url) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed "") |}]; + let { Parse_result.result = reparsed; _ } = projection.parse_exn unparsed in + print_s [%message (reparsed : Url.t)]; + [%expect {| (reparsed Homepage) |}]; + (* These should have been equal. *) + Expect_test_patdiff.print_patdiff_s + ([%sexp_of: Url.t] url) + ([%sexp_of: Url.t] reparsed); + [%expect {| + -1,1 +1,1 + -|(Param "") + +|Homepage |}] + ;; + end) +;; + +let%test_module "Only Homepage" = + (module struct + module Url = struct + type t = Homepage [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Homepage -> Parser.end_of_path Parser.unit + ;; + end + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "Sanity_check" = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + URL parser looks good! + ┌──────────┐ + │ All urls │ + ├──────────┤ + │ / │ + └──────────┘ |}] + ;; + + let projection = Versioned_parser.eval_for_uri versioned_parser + + let%expect_test "Empty URL round trip" = + let uri = Uri.empty in + let { Parse_result.result = parsed; _ } = projection.parse_exn uri in + print_s [%message (parsed : Url.t)]; + [%expect {| (parsed Homepage) |}]; + let unparsed = projection.unparse (Parse_result.create parsed) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed "") |}]; + [%test_eq: Uri_jane.t] uri unparsed + ;; + + let%expect_test "Homepage roundtrip" = + let url = Url.Homepage in + let unparsed = projection.unparse (Parse_result.create url) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed "") |}]; + let { Parse_result.result = reparsed; _ } = projection.parse_exn unparsed in + print_s [%message (reparsed : Url.t)]; + [%expect {| (reparsed Homepage) |}]; + [%test_eq: Url.t] url reparsed + ;; + end) +;; + +let%test_module "Only Param" = + (module struct + module Url = struct + type t = Param of string [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Param -> Parser.with_prefix [] (Parser.from_path Value_parser.string) + ;; + end + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "Sanity_check" = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + URL parser looks good! + ┌───────────┐ + │ All urls │ + ├───────────┤ + │ / │ + └───────────┘ |}] + ;; + + let projection = Versioned_parser.eval_for_uri versioned_parser + + let%expect_test "BUG: Empty URL round trip" = + let uri = Uri.empty in + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + projection.parse_exn uri); + [%expect {| + "Expected a value in path, but nothing was present" |}] + ;; + + let%expect_test "BUG: Param roundtrip" = + let url = Url.Param "" in + let unparsed = projection.unparse (Parse_result.create url) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed "") |}]; + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + projection.parse_exn unparsed); + [%expect {| + "Expected a value in path, but nothing was present" |}] + ;; + end) +;; + +let%test_module "Prefixed Home and param if both use `with_prefix`" = + (module struct + module Url = struct + type t = + | Homepage + | Param of string + [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Homepage -> Parser.with_prefix [ "prefix" ] Parser.unit + | Param -> Parser.with_prefix [ "prefix" ] (Parser.from_path Value_parser.string) + ;; + end + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "If there's a prefix, it's considered an ambiguity." = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + Error with parser. + ┌─────────────────────────────────────────────────────────┬─────────────────────────────────────────────────────────────────────────────┐ + │ Check name │ Error message │ + ├─────────────────────────────────────────────────────────┼─────────────────────────────────────────────────────────────────────────────┤ + │ Ambiguous choices for picking variant constructor check │ ("Duplicate patterns found!" │ + │ │ (duplicate_patterns (((pattern ((Match prefix))) (needed_match Prefix))))) │ + └─────────────────────────────────────────────────────────┴─────────────────────────────────────────────────────────────────────────────┘ |}] + ;; + end) +;; + +let%test_module "Prefixed home and param" = + (module struct + module Url = struct + type t = + | Homepage + | Param of string + [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Homepage -> Parser.with_remaining_path [ "prefix" ] Parser.unit + | Param -> Parser.with_prefix [ "prefix" ] (Parser.from_path Value_parser.string) + ;; + end + + include Url + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "If there's a prefix, it's considered an ambiguity." = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + URL parser looks good! + ┌──────────────────┐ + │ All urls │ + ├──────────────────┤ + │ /prefix │ + │ /prefix/ │ + └──────────────────┘ |}] + ;; + + let projection = Versioned_parser.eval_for_uri versioned_parser + + let%expect_test "roundtrip" = + let uri = Uri.of_string "prefix" in + let { Parse_result.result = parsed; _ } = projection.parse_exn uri in + print_s [%message (parsed : Url.t)]; + [%expect {| (parsed Homepage) |}]; + let unparsed = projection.unparse (Parse_result.create parsed) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed prefix) |}]; + [%test_eq: Uri_jane.t] uri unparsed; + [%expect {| |}] + ;; + + let%expect_test "roundtrip with ending slash" = + let uri = Uri.of_string "prefix/" in + let { Parse_result.result = parsed; _ } = projection.parse_exn uri in + print_s [%message (parsed : Url.t)]; + [%expect {| + (parsed (Param "")) |}]; + let unparsed = projection.unparse (Parse_result.create parsed) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| + (unparsed prefix/) |}]; + [%test_eq: Uri_jane.t] uri unparsed; + [%expect {| |}] + ;; + end) +;; + +let%test_module "Prefixed Only Homepage" = + (module struct + module Url = struct + type t = Homepage [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Homepage -> Parser.with_prefix [ "prefix" ] Parser.unit + ;; + end + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "Sanity_check" = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + URL parser looks good! + ┌──────────┐ + │ All urls │ + ├──────────┤ + │ /prefix │ + └──────────┘ |}] + ;; + + let projection = Versioned_parser.eval_for_uri versioned_parser + + let%expect_test "roundtrip with ending slash" = + let uri = Uri.of_string "prefix/" in + let { Parse_result.result = parsed; _ } = projection.parse_exn uri in + print_s [%message (parsed : Url.t)]; + [%expect {| (parsed Homepage) |}]; + let unparsed = projection.unparse (Parse_result.create parsed) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed prefix) |}]; + Expect_test_patdiff.print_patdiff_s + ([%sexp_of: Uri_jane.t] uri) + ([%sexp_of: Uri_jane.t] unparsed); + [%expect {| + -1,1 +1,1 + -|prefix/ + +|prefix |}] + ;; + + let%expect_test "roundtrip" = + let uri = Uri.of_string "prefix" in + let { Parse_result.result = parsed; _ } = projection.parse_exn uri in + print_s [%message (parsed : Url.t)]; + [%expect {| (parsed Homepage) |}]; + let unparsed = projection.unparse (Parse_result.create parsed) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed prefix) |}]; + [%test_eq: Uri_jane.t] uri unparsed + ;; + end) +;; + +let%test_module "Prefixed Only Param" = + (module struct + module Url = struct + type t = Param of string [@@deriving typed_variants, sexp, equal, compare] + + let parser_for_variant : type a. a Typed_variant.t -> a Parser.t = function + | Param -> Parser.with_prefix [ "prefix" ] (Parser.from_path Value_parser.string) + ;; + end + + let parser = Parser.Variant.make (module Url) + let versioned_parser = Versioned_parser.first_parser parser + + let%expect_test "Sanity_check" = + Versioned_parser.check_ok_and_print_urls_or_errors versioned_parser; + [%expect + {| + URL parser looks good! + ┌──────────────────┐ + │ All urls │ + ├──────────────────┤ + │ /prefix/ │ + └──────────────────┘ |}] + ;; + + let projection = Versioned_parser.eval_for_uri versioned_parser + + let%expect_test "roundtrip with ending slash" = + let uri = Uri.of_string "prefix/" in + let { Parse_result.result = parsed; _ } = projection.parse_exn uri in + print_s [%message (parsed : Url.t)]; + [%expect {| (parsed (Param "")) |}]; + let unparsed = projection.unparse (Parse_result.create parsed) in + print_s [%message (unparsed : Uri_jane.t)]; + [%expect {| (unparsed prefix/) |}]; + [%test_eq: Uri_jane.t] uri unparsed; + [%expect {| |}] + ;; + + let%expect_test "cannot parse without ending slash" = + let uri = Uri.of_string "prefix" in + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + projection.parse_exn uri); + [%expect {| + "Expected a value in path, but nothing was present" |}] + ;; + end) +;; diff --git a/uri_parsing/test/empty_path_test.mli b/uri_parsing/test/empty_path_test.mli new file mode 100644 index 00000000..74bb7298 --- /dev/null +++ b/uri_parsing/test/empty_path_test.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/uri_parsing/test/uri_parsing_test.ml b/uri_parsing/test/uri_parsing_test.ml index 6ed33b4f..6ffb781c 100644 --- a/uri_parsing/test/uri_parsing_test.ml +++ b/uri_parsing/test/uri_parsing_test.ml @@ -3455,7 +3455,7 @@ let%test_module "query-based variant" = [%expect {| ?page=a&a=beep%20boop |}]; let parsed = projection.parse_exn original in print_s [%sexp (parsed : Well_behaved_url.t Parse_result.t)]; - [%expect {| ((result (A "beep boop")) (remaining ((path ("")) (query ())))) |}]; + [%expect {| ((result (A "beep boop")) (remaining ((path ()) (query ())))) |}]; let unparsed = projection.unparse parsed in print_endline (Uri.to_string unparsed); [%expect {| ?a=beep%20boop&page=a |}] @@ -3467,7 +3467,7 @@ let%test_module "query-based variant" = [%expect {| ?page=bee |}]; let parsed = projection.parse_exn original in print_s [%sexp (parsed : Well_behaved_url.t Parse_result.t)]; - [%expect {| ((result B) (remaining ((path ("")) (query ())))) |}]; + [%expect {| ((result B) (remaining ((path ()) (query ())))) |}]; let unparsed = projection.unparse parsed in print_endline (Uri.to_string unparsed); [%expect {| ?page=bee |}] @@ -3681,7 +3681,7 @@ let%expect_test "query parsing encode decode" = [%expect {| ?q=beep%20boop |}]; let parsed = projection.parse_exn original in print_s [%sexp (parsed : string Parse_result.t)]; - [%expect {| ((result "beep boop") (remaining ((path ("")) (query ())))) |}]; + [%expect {| ((result "beep boop") (remaining ((path ()) (query ())))) |}]; let unparsed = projection.unparse parsed in print_endline (Uri.to_string unparsed); [%expect {| ?q=beep%20boop |}] @@ -3746,7 +3746,7 @@ let%expect_test "double query parsing encode decode" = [%expect {| ?q=beep%2520boop |}]; let parsed = projection.parse_exn original in print_s [%sexp (parsed : string Parse_result.t)]; - [%expect {| ((result beep%20boop) (remaining ((path ("")) (query ())))) |}]; + [%expect {| ((result beep%20boop) (remaining ((path ()) (query ())))) |}]; let unparsed = projection.unparse parsed in print_endline (Uri.to_string unparsed); [%expect {| ?q=beep%2520boop |}] diff --git a/web/bonsai_web.ml b/web/bonsai_web.ml index 25228844..a0e7c0e1 100644 --- a/web/bonsai_web.ml +++ b/web/bonsai_web.ml @@ -28,3 +28,15 @@ end include Bonsai.For_open include Util module Effect = Bonsai_web_effect + +module Cont = struct + module Start = Start + module Bonsai = Bonsai.Cont + module Incr = Incr + module Vdom = Vdom + module View = Bonsai_web_ui_view + module To_incr_dom = To_incr_dom + module Persistent_var = Persistent_var + module Rpc_effect = Rpc_effect + module Effect = Bonsai_web_effect +end diff --git a/web/dune b/web/dune index 9f4913a6..4edce0d0 100644 --- a/web/dune +++ b/web/dune @@ -1,8 +1,11 @@ -(library (name bonsai_web) - (libraries async_kernel bonsai core_kernel.bus core incr_dom - core_kernel.moption core_kernel.reversed_list bonsai_web_ui_view - virtual_dom.ui_effect incr_dom.ui_incr virtual_dom bonsai_protocol - async_rpc_kernel polling_state_rpc async_durable babel uri async_js - incr_dom.javascript_profiling streamable) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai)) - (public_name bonsai.web)) \ No newline at end of file +(library + (name bonsai_web) + (libraries async_kernel bonsai core_kernel.bus core + async_kernel.eager_deferred incr_dom core_kernel.moption + core_kernel.reversed_list bonsai_web_ui_view virtual_dom.ui_effect + incr_dom.ui_incr virtual_dom bonsai_protocol async_rpc_kernel + polling_state_rpc versioned_polling_state_rpc async_durable babel uri + async_js incr_dom.javascript_profiling streamable) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai)) + (public_name bonsai.web)) diff --git a/web/rpc_effect.ml b/web/rpc_effect.ml index 81293eb8..181fc270 100644 --- a/web/rpc_effect.ml +++ b/web/rpc_effect.ml @@ -17,6 +17,8 @@ module Rvar : sig (** A "Refreshable" var. *) type 'a t + val const : 'a -> 'a t + (** Makes a new container that asynchronously computes its contents on demand. *) val create : (unit -> 'a Deferred.Or_error.t) -> 'a t @@ -33,59 +35,122 @@ module Rvar : sig If [invalidate] is called in the middle of computing the result, the computation starts over. *) val contents : 'a t -> 'a Deferred.Or_error.t + + val derived : 'a t -> ('a -> 'b Deferred.Or_error.t) -> 'b t + val destroy : _ t -> unit end = struct type 'a state = | Invalid | Pending | Value of 'a - type 'a t = + type 'a common = { mutable state : 'a state ; f : unit -> 'a Deferred.Or_error.t ; finished : ('a Or_error.t, read_write) Bvar.t + ; invalidated : (unit -> unit, read_write) Bus.t } - let create f = { state = Invalid; f; finished = Bvar.create () } - let invalidate t = t.state <- Invalid + type 'a t = + | Standard of 'a common + | Derived of + { common : 'a common + ; on_destroy : unit -> unit + } + | Const of 'a + + let create_common f = + let invalidated = + Bus.create_exn + [%here] + Arity1 + ~on_subscription_after_first_write:Allow + ~on_callback_raise:Error.raise + in + { state = Invalid; f; finished = Bvar.create (); invalidated } + ;; + + let const v = Const v + let create f = Standard (create_common f) let return_result t result = Deferred.return - (match result with - | Ok value -> - t.state <- Value value; - Bvar.broadcast t.finished (Ok value); - Ok value - | Error e -> - t.state <- Invalid; - Bvar.broadcast t.finished (Error e); - Error e) - ;; - - let rec contents t = - match t.state with - | Invalid -> - t.state <- Pending; - (match%bind Monitor.try_with_join_or_error t.f with - | Ok value -> - (match t.state with - | Invalid -> - (* If [t] has been invalidated in the middle of computing its - result, try again. This recursive call shouldn't cause an infinite - loop because [t.f] is passed when the [t] is created, which - means it cannot possibly unconditionally call [invalidate] - on itself. Undoubtedly there is a way around this that will cause - an infinite loop, but in that case the infinite loop is not - surprising. *) - contents t - | Pending -> return_result t (Ok value) - | Value value -> - eprint_s - [%message - "BUG: Skipped computing Rvar result because it has already been computed."]; - return_result t (Ok value)) - | Error e -> return_result t (Error e)) - | Pending -> Bvar.wait t.finished - | Value value -> Deferred.Or_error.return value + (match t with + | Const _ -> result + | Standard t | Derived { common = t; _ } -> + (match result with + | Ok value -> + t.state <- Value value; + Bvar.broadcast t.finished (Ok value); + Ok value + | Error e -> + t.state <- Invalid; + Bvar.broadcast t.finished (Error e); + Error e)) + ;; + + let rec contents = function + | Const v -> Deferred.Or_error.return v + | (Standard t | Derived { common = t; _ }) as self -> + (match t.state with + | Invalid -> + t.state <- Pending; + (match%bind Monitor.try_with_join_or_error t.f with + | Ok value -> + (match t.state with + | Invalid -> + (* If [t] has been invalidated in the middle of computing its + result, try again. This recursive call shouldn't cause an infinite + loop because [t.f] is passed when the [t] is created, which + means it cannot possibly unconditionally call [invalidate] + on itself. Undoubtedly there is a way around this that will cause + an infinite loop, but in that case the infinite loop is not + surprising. *) + contents self + | Pending -> return_result self (Ok value) + | Value value -> + eprint_s + [%message + "BUG: Skipped computing Rvar result because it has already been \ + computed."]; + return_result self (Ok value)) + | Error e -> return_result self (Error e)) + | Pending -> Bvar.wait t.finished + | Value value -> Deferred.Or_error.return value) + ;; + + let invalidate = function + | Const _ -> () + | Standard t | Derived { common = t; _ } -> + t.state <- Invalid; + Bus.write t.invalidated () + ;; + + let derived inner f = + match inner with + | Const v -> create (fun () -> f v) + | Standard { invalidated = inner_invalidated; _ } + | Derived { common = { invalidated = inner_invalidated; _ }; _ } -> + let f () = Deferred.Or_error.bind (contents inner) ~f in + let rec me = + lazy + (let subscriber = Lazy.force subscriber in + let on_destroy () = Bus.unsubscribe inner_invalidated subscriber in + Derived { common = create_common f; on_destroy }) + and subscriber = + lazy + (Bus.subscribe_exn inner_invalidated [%here] ~f:(fun () -> + invalidate (Lazy.force me))) + in + Lazy.force me + ;; + + let destroy = function + | Const _ -> () + | Standard _ as t -> invalidate t + | Derived { on_destroy; _ } as t -> + invalidate t; + on_destroy () ;; end @@ -112,6 +177,13 @@ module Connector = struct -> t | Test_fallback : t + let menu_rvar = function + | Async_durable { menu : Versioned_rpc.Menu.t Rvar.t; _ } -> Some menu + | Persistent_connection { menu : Versioned_rpc.Menu.t Rvar.t; _ } -> Some menu + | Connection { menu : Versioned_rpc.Menu.t Rvar.t; _ } -> Some menu + | Test_fallback -> None + ;; + let persistent_connection (type conn) (module Conn : Persistent_connection.S @@ -709,15 +781,19 @@ module Our_rpc = struct end module Polling_state_rpc = struct - let dispatcher ?(on_forget_client_error = fun _ -> Effect.Ignore) rpc ~where_to_connect = + let dispatcher' + ?(on_forget_client_error = fun _ -> Effect.Ignore) + create_client_rvar + ~destroy_after_forget + ~where_to_connect + = let open Bonsai.Let_syntax in let%sub connector = Bonsai.Dynamic_scope.lookup connector_var in - let%sub client = - Bonsai.Expert.thunk (fun () -> Polling_state_rpc.Client.create rpc) - in + let%sub client_rvar = create_client_rvar ~connector in let%sub forget_client_on_server = - let perform_dispatch (connector, client) = + let perform_dispatch (connector, client_rvar) = Connector.with_connection connector ~where_to_connect ~callback:(fun connection -> + let%bind.Eager_deferred.Or_error client = Rvar.contents client_rvar in match%map.Deferred Polling_state_rpc.Client.forget_on_server client connection with @@ -730,35 +806,75 @@ module Polling_state_rpc = struct | Error error -> Error error) in let%arr connector = connector - and client = client in - match%bind.Effect Effect.of_deferred_fun perform_dispatch (connector, client) with - | Ok () -> Effect.Ignore - | Error error -> on_forget_client_error error + and client_rvar = client_rvar in + let%bind.Effect () = + match%bind.Effect + Effect.of_deferred_fun perform_dispatch (connector, client_rvar) + with + | Ok () -> Effect.Ignore + | Error error -> on_forget_client_error error + in + if destroy_after_forget + then Effect.of_thunk (fun () -> Rvar.destroy client_rvar) + else Effect.Ignore in let%sub () = Bonsai.Edge.lifecycle ~on_deactivate:forget_client_on_server () in let perform_query (connector, client) query = Connector.with_connection connector ~where_to_connect ~callback:(fun connection -> + let%bind.Eager_deferred.Or_error client = Rvar.contents client in Polling_state_rpc.Client.dispatch client connection query) in let%arr connector = connector - and client = client in - Effect.of_deferred_fun (perform_query (connector, client)) + and client_rvar = client_rvar in + Effect.of_deferred_fun (perform_query (connector, client_rvar)) ;; - let poll + let babel_dispatcher ?on_forget_client_error caller ~where_to_connect = + let create_client_rvar ~connector = + let%arr.Bonsai connector = connector in + match Connector.menu_rvar (connector where_to_connect) with + | None -> raise_s [%message [%here]] + | Some menu_rvar -> + Rvar.derived menu_rvar (fun _ -> + Connector.with_connection_with_menu + connector + ~where_to_connect + ~callback:(fun connection_with_menu -> + Versioned_polling_state_rpc.Client.negotiate_client + caller + connection_with_menu + |> Deferred.return)) + in + dispatcher' + ?on_forget_client_error + ~destroy_after_forget:true + ~where_to_connect + create_client_rvar + ;; + + let dispatcher ?on_forget_client_error rpc ~where_to_connect = + let create_client_rvar ~connector:_ = + Bonsai.Expert.thunk (fun () -> Rvar.const (Polling_state_rpc.Client.create rpc)) + in + dispatcher' + ?on_forget_client_error + ~destroy_after_forget:false + ~where_to_connect + create_client_rvar + ;; + + let generic_poll ?sexp_of_query ?sexp_of_response ~equal_query ?equal_response ?clear_when_deactivated ?on_response_received - rpc - ~where_to_connect ~every query + ~dispatcher = let open Bonsai.Let_syntax in - let%sub dispatcher = dispatcher rpc ~where_to_connect in let%sub dispatcher = let%arr dispatcher = dispatcher in fun query -> @@ -778,6 +894,58 @@ module Polling_state_rpc = struct query ;; + let poll + ?sexp_of_query + ?sexp_of_response + ~equal_query + ?equal_response + ?clear_when_deactivated + ?on_response_received + rpc + ~where_to_connect + ~every + query + = + let open Bonsai.Let_syntax in + let%sub dispatcher = dispatcher rpc ~where_to_connect in + generic_poll + ?sexp_of_query + ?sexp_of_response + ~equal_query + ?equal_response + ?clear_when_deactivated + ?on_response_received + ~every + query + ~dispatcher + ;; + + let babel_poll + ?sexp_of_query + ?sexp_of_response + ~equal_query + ?equal_response + ?clear_when_deactivated + ?on_response_received + rpc + ~where_to_connect + ~every + query + = + let open Bonsai.Let_syntax in + let%sub dispatcher = babel_dispatcher rpc ~where_to_connect in + generic_poll + ?sexp_of_query + ?sexp_of_response + ~equal_query + ?equal_response + ?clear_when_deactivated + ?on_response_received + ~every + query + ~dispatcher + ;; + let shared_poller (type q cmp) (module Q : Bonsai.Comparator with type t = q and type comparator_witness = cmp) diff --git a/web/rpc_effect.mli b/web/rpc_effect.mli index 71bd2867..c270fbb4 100644 --- a/web/rpc_effect.mli +++ b/web/rpc_effect.mli @@ -88,8 +88,8 @@ module Rpc : sig -> where_to_connect:Where_to_connect.t -> ('query -> 'response Or_error.t Effect.t) Computation.t - (** A computation that periodically dispatches on an RPC and - keeps track of the most recent response. + (** A computation that periodically dispatches on an RPC and keeps track of the most + recent response. Only one request will be in-flight at any point in time. [clear_when_deactivated] determines whether the most recent response should be discarded when the component is deactivated. Default is true. *) @@ -187,6 +187,12 @@ module Polling_state_rpc : sig -> where_to_connect:Where_to_connect.t -> ('query -> 'response Or_error.t Effect.t) Computation.t + val babel_dispatcher + : ?on_forget_client_error:(Error.t -> unit Effect.t) + -> ('query, 'response) Versioned_polling_state_rpc.Client.caller + -> where_to_connect:Where_to_connect.t + -> ('query -> 'response Or_error.t Effect.t) Computation.t + (** A computation that periodically dispatches on a polling_state_rpc and keeps track of the most recent response. To explicitly re-send the RPC, schedule the [refresh] field of the result. It also keeps track of the current @@ -204,6 +210,19 @@ module Polling_state_rpc : sig -> 'query Value.t -> ('query, 'response) Poll_result.t Computation.t + val babel_poll + : ?sexp_of_query:('query -> Sexp.t) + -> ?sexp_of_response:('response -> Sexp.t) + -> equal_query:('query -> 'query -> bool) + -> ?equal_response:('response -> 'response -> bool) + -> ?clear_when_deactivated:bool + -> ?on_response_received:('query -> 'response Or_error.t -> unit Effect.t) Value.t + -> ('query, 'response) Versioned_polling_state_rpc.Client.caller + -> where_to_connect:Where_to_connect.t + -> every:Time_ns.Span.t + -> 'query Value.t + -> ('query, 'response) Poll_result.t Computation.t + val shared_poller : ('query, _) Bonsai.comparator -> ?sexp_of_response:('response -> Sexp.t) diff --git a/web/start.ml b/web/start.ml index abddaec3..23961427 100644 --- a/web/start.ml +++ b/web/start.ml @@ -346,7 +346,7 @@ module Arrow_deprecated = struct in let computation = component var - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> if optimize then Bonsai.Private.pre_process else Fn.id in let (T info) = Bonsai.Private.gather computation in diff --git a/web/start.mli b/web/start.mli index b0cc6195..41cbe342 100644 --- a/web/start.mli +++ b/web/start.mli @@ -137,7 +137,9 @@ module Proc : sig (** If the application provides some "extra data" that is computed alongside the view of the application, (see [Result_spec.S.extra]), then you can subscribe to those - changes using the bus returned by [extra] *) + values using the bus returned by [extra] + + A value is placed into the Bus on every frame regardless of if it changed or not. *) val extra : ('extra, _) t -> ('extra -> unit) Bus.Read_only.t (** Like [extra], but only fetches the last ['extra] produced by the computation. If diff --git a/web/to_incr_dom.ml b/web/to_incr_dom.ml index 56315fda..9a4170e7 100644 --- a/web/to_incr_dom.ml +++ b/web/to_incr_dom.ml @@ -96,7 +96,7 @@ let convert_with_extra ?(optimize = false) component = let maybe_optimize = if optimize then Bonsai.Private.pre_process else Fn.id in let (T { model; input = _; action; apply_action; run; reset = _ }) = component var - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> maybe_optimize |> Bonsai.Private.gather in diff --git a/web_test/async/bonsai_web_test_async.ml b/web_test/async/bonsai_web_test_async.ml new file mode 100644 index 00000000..b2a6d5d6 --- /dev/null +++ b/web_test/async/bonsai_web_test_async.ml @@ -0,0 +1,8 @@ +open! Base + +(* Bonsai_web_test_async is a wrapper library over [bonsai_web_test] that lets you write + bonsai tests that use async. *) + +include Bonsai.For_open +include Bonsai_web_test +include Async_js_test diff --git a/web_test/async/dune b/web_test/async/dune new file mode 100644 index 00000000..618b3e44 --- /dev/null +++ b/web_test/async/dune @@ -0,0 +1,6 @@ +(library + (name bonsai_web_test_async) + (public_name bonsai.web_test_async) + (libraries async_js.async_test base bonsai_web bonsai_web_test) + (preprocess + (pps ppx_jane))) diff --git a/web_test/dune b/web_test/dune index b8557399..fc2fc19c 100644 --- a/web_test/dune +++ b/web_test/dune @@ -1,6 +1,8 @@ -(library (name bonsai_web_test) (public_name bonsai.web_test) +(library + (name bonsai_web_test) + (public_name bonsai.web_test) (libraries bonsai_web core async_kernel.eager_deferred bonsai_test - patdiff.expect_test_patdiff virtual_dom.vdom_test_helpers - bonsai_web_ui_drag_and_drop bonsai_web_ui_element_size_hooks) + patdiff.expect_test_patdiff virtual_dom.vdom_test_helpers + bonsai_web_ui_drag_and_drop bonsai_web_ui_element_size_hooks) (preprocess - (pps ppx_jane js_of_ocaml-ppx ppx_css ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + (pps ppx_jane js_of_ocaml-ppx ppx_css ppx_pattern_bind ppx_bonsai))) diff --git a/web_test/of_bonsai_itself/dune b/web_test/of_bonsai_itself/dune index 9eef5637..187ac597 100644 --- a/web_test/of_bonsai_itself/dune +++ b/web_test/of_bonsai_itself/dune @@ -1,26 +1,37 @@ -(library (name bonsai_web_test_of_bonsai_itself) +(library + (name bonsai_web_test_of_bonsai_itself) (public_name bonsai.web_test_of_bonsai_itself) (libraries bonsai_web bonsai_web_test bonsai_extra async_js.async_test core - legacy_diffable expect_test_helpers_core patdiff.expect_test_patdiff - bonsai_test incr_map bonsai_web_ui_drag_and_drop async_rpc_kernel async_js) - (preprocess (pps ppx_jane ppx_pattern_bind ppx_bonsai))) + legacy_diffable expect_test_helpers_core patdiff.expect_test_patdiff + bonsai_test incr_map bonsai_web_ui_drag_and_drop async_rpc_kernel async_js) + (preprocess + (pps ppx_jane ppx_pattern_bind ppx_bonsai))) -(rule (targets test_legacy_bonsai.ml) +(rule + (targets test_legacy_bonsai.ml) (deps ../../test/of_bonsai_itself/test_legacy_bonsai.ml) - (action (bash "cp %{deps} %{targets}"))) + (action + (bash "cp %{deps} %{targets}"))) -(rule (targets test_legacy_bonsai.mli) +(rule + (targets test_legacy_bonsai.mli) (deps ../../test/of_bonsai_itself/test_legacy_bonsai.mli) - (action (bash "cp %{deps} %{targets}"))) + (action + (bash "cp %{deps} %{targets}"))) -(rule (targets test_proc_bonsai.ml) +(rule + (targets test_proc_bonsai.ml) (deps ../../test/of_bonsai_itself/test_proc_bonsai.ml) - (action (bash "cp %{deps} %{targets}"))) + (action + (bash "cp %{deps} %{targets}"))) -(rule (targets test_proc_bonsai.mli) +(rule + (targets test_proc_bonsai.mli) (deps ../../test/of_bonsai_itself/test_proc_bonsai.mli) - (action (bash "cp %{deps} %{targets}"))) + (action + (bash "cp %{deps} %{targets}"))) -(alias (name DEFAULT) +(alias + (name DEFAULT) (deps test_legacy_bonsai.ml test_legacy_bonsai.mli test_proc_bonsai.ml - test_proc_bonsai.mli)) \ No newline at end of file + test_proc_bonsai.mli)) diff --git a/web_test/of_bonsai_itself/rpc_effect_tests.ml b/web_test/of_bonsai_itself/rpc_effect_tests.ml index 571b2d00..52759714 100644 --- a/web_test/of_bonsai_itself/rpc_effect_tests.ml +++ b/web_test/of_bonsai_itself/rpc_effect_tests.ml @@ -113,11 +113,20 @@ end let%expect_test "test fallback" = let computation = Rpc_effect.Rpc.dispatcher rpc_a ~where_to_connect:Self in - let handle = Handle.create (module Int_to_int_or_error) computation in + let handle = + Handle.create + ~connectors:(fun _ -> Bonsai_web.Rpc_effect.Connector.test_fallback) + (module Int_to_int_or_error) + computation + in (* Invoking the RPC before providing an implementation of it to the handle will yield an error as a response. *) let%bind.Deferred () = async_do_actions handle [ 0 ] in - [%expect {| (Error "RPC not handled because no connector has been provided.") |}]; + [%expect + {| + (Error + ((rpc_error (Unimplemented_rpc a (Version 0))) + (connection_description ) (rpc_name a) (rpc_version 0))) |}]; Deferred.unit ;; @@ -288,7 +297,8 @@ let%expect_test "inactive delivery of a response will be ignored when \ Bonsai.Var.set is_active false; Handle.show handle; let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in - [%expect {| () |}]; + [%expect {| + () |}]; Handle.show handle; let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in [%expect {| () |}]; @@ -420,7 +430,8 @@ let%expect_test "multiple polling_state_rpc" = Bonsai.Var.update map_var ~f:(fun map -> Map.remove map 10); Handle.recompute_view handle; let%bind () = async_do_actions handle [ 10 ] in - [%expect {| ("Query does not exist in map" (query 10)) |}]; + [%expect {| + ("Query does not exist in map" (query 10)) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.set map ~key:10 ~data:()); Handle.recompute_view handle; (* Having been de-activated, this map entry does not trigger a diff @@ -576,6 +587,342 @@ let%expect_test "disconnect and re-connect with polling_state_rpc" = return () ;; +let%test_module "versioned polling state rpc" = + (module struct + module Response = struct + type t = string [@@deriving bin_io] + + module Update = String + + let diffs ~from:_ ~to_ = to_ + let update _ update = update + end + + (* this module contains the _old_ implementation of V1 without the conversion functor *) + module V1_old = struct + module Response = struct + include Int.Stable.V1 + module Update = Int.Stable.V1 + + let diffs ~from:_ ~to_ = to_ + let update _prev next = next + end + + let rpc = + Polling_state_rpc.create + ~name:"foo" + ~version:1 + ~query_equal:[%equal: int] + ~bin_query:bin_int + (module Response) + ;; + end + + module V1 = struct + module Response = + Versioned_polling_state_rpc.Make_stable_response + (Response) + (V1_old.Response (* This is modeling a V1 that used ints instead of strings *)) + (struct + let to_stable = Int.of_string + let of_stable = Int.to_string + + module Update = struct + let to_stable = Int.of_string + let of_stable = Int.to_string + end + end) + + let rpc = + Polling_state_rpc.create + ~name:"foo" + ~version:1 + ~query_equal:[%equal: int] + ~bin_query:bin_int + (module Response) + ;; + end + + module V2 = struct + let rpc = + Polling_state_rpc.create + ~name:"foo" + ~version:2 + ~query_equal:[%equal: int] + ~bin_query:bin_int + (module Response) + ;; + end + + module Erased_implementation = struct + type t = + | T : + { rpc : (int, 'result) Polling_state_rpc.t + ; latest_result_of_int : int -> 'result + } + -> t + end + + let implementations rpcs = + let implement (Erased_implementation.T { rpc; latest_result_of_int }) = + Polling_state_rpc.implement + ~on_client_and_server_out_of_sync:print_s + rpc + (fun (_ : Rpc.Connection.t) query -> + let rpc = + Polling_state_rpc.babel_generic_rpc rpc |> Babel.Generic_rpc.description + in + print_s [%message (rpc : Rpc.Description.t)]; + latest_result_of_int (query * 2) |> Deferred.return) + in + List.map rpcs ~f:implement + ;; + + let v1_caller = Versioned_polling_state_rpc.Client.create_caller V1.rpc + let v2_caller = Versioned_polling_state_rpc.Client.create_caller V2.rpc + + module Spec = struct + type t = { dispatch : int -> string Or_error.t Effect.t } + type incoming = Query of int + + let view _ = "" + + let incoming t incoming = + match incoming with + | Query query -> + let%bind.Effect result = t.dispatch query in + Effect.print_s ([%sexp_of: string Or_error.t] result) + ;; + end + + let setup_test_env ~rpcs_on_server ~rpcs_on_client = + let caller = Babel.Caller.of_list_decreasing_preference rpcs_on_client in + let make_implementations rpcs = + Versioned_rpc.Menu.add + (List.map + (implementations rpcs) + ~f:(Rpc.Implementation.lift ~f:(fun connection -> connection, connection))) + in + let is_broken = ref false in + let implementations = ref (make_implementations rpcs_on_server) in + let connector = + Rpc_effect.Connector.async_durable + (Async_durable.create + ~to_create:(fun () -> + is_broken := false; + print_endline "creating rpc connection"; + create_connection !implementations) + ~is_broken:(fun _ -> !is_broken) + ()) + in + let activated = Bonsai.Var.create true in + let computation = + let open Bonsai.Let_syntax in + let%sub dispatch = + match%sub Bonsai.Var.value activated with + | true -> + Rpc_effect.Polling_state_rpc.babel_dispatcher caller ~where_to_connect:Self + | false -> + Bonsai.const + (Effect.of_sync_fun (fun (_ : int) -> Ok "fake rpc implementation")) + in + let%arr dispatch = dispatch in + { Spec.dispatch } + in + let handle = + Handle.create ~connectors:(fun _ -> connector) (module Spec) computation + in + let break_connection () = is_broken := true in + let set_implementations l = implementations := make_implementations l in + activated, handle, break_connection, set_implementations + ;; + + let%expect_test "client and server pick latest (v2) version" = + let _activated, handle, _break_connection, _set_implementations = + setup_test_env + ~rpcs_on_server: + [ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } + ; T { rpc = V2.rpc; latest_result_of_int = Int.to_string } + ] + ~rpcs_on_client:[ v2_caller; v1_caller ] + in + let%bind.Deferred () = async_do_actions handle [ Query 8 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 2))) + (Ok 16) |}]; + let%bind.Deferred () = async_do_actions handle [ Query 9 ] in + Handle.show handle; + [%expect {| + (rpc ((name foo) (version 2))) + (Ok 18) |}]; + return () + ;; + + let%expect_test "client can downgrade" = + let _activated, handle, _break_connection, _set_implementations = + setup_test_env + ~rpcs_on_server:[ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } ] + ~rpcs_on_client:[ v2_caller; v1_caller ] + in + let%bind.Deferred () = async_do_actions handle [ Query 8 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 1))) + (Ok 16) |}]; + let%bind.Deferred () = async_do_actions handle [ Query 9 ] in + Handle.show handle; + [%expect {| + (rpc ((name foo) (version 1))) + (Ok 18) |}]; + return () + ;; + + let%expect_test "server can downgrade" = + let _activated, handle, _break_connection, _set_implementations = + setup_test_env + ~rpcs_on_server: + [ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } + ; T { rpc = V2.rpc; latest_result_of_int = Int.to_string } + ] + ~rpcs_on_client:[ v1_caller ] + in + let%bind.Deferred () = async_do_actions handle [ Query 8 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 1))) + (Ok 16) |}]; + let%bind.Deferred () = async_do_actions handle [ Query 9 ] in + Handle.show handle; + [%expect {| + (rpc ((name foo) (version 1))) + (Ok 18) |}]; + return () + ;; + + let%expect_test "server rolls back and then forward while client is still active" = + let server_impls : Erased_implementation.t list = + [ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } + ; T { rpc = V1_old.rpc; latest_result_of_int = Fn.id } + ] + in + Deferred.List.iter ~how:`Sequential server_impls ~f:(fun v1_server_impl -> + let _activated, handle, break_connection, set_implementations = + setup_test_env + ~rpcs_on_server: + [ v1_server_impl; T { rpc = V2.rpc; latest_result_of_int = Int.to_string } ] + ~rpcs_on_client:[ v2_caller; v1_caller ] + in + let%bind.Deferred () = async_do_actions handle [ Query 8 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 2))) + (Ok 16) |}]; + (* simulate the server going down, and then coming back up on a previous + version that doesn't have the V2 RPC. *) + break_connection (); + set_implementations [ v1_server_impl ]; + let%bind () = async_do_actions handle [ Query 7 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 1))) + (Ok 14) |}]; + (* simulate the server going down, and then coming back up on a + that _does_ have the V2 RPC. *) + break_connection (); + set_implementations + [ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } + ; T { rpc = V2.rpc; latest_result_of_int = Int.to_string } + ]; + let%bind () = async_do_actions handle [ Query 6 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 2))) + (Ok 12) |}]; + return ()) + ;; + + let%expect_test "deactivate and reactivate component" = + let activated, handle, _break_connection, _set_implementations = + setup_test_env + ~rpcs_on_server: + [ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } + ; T { rpc = V2.rpc; latest_result_of_int = Int.to_string } + ] + ~rpcs_on_client:[ v2_caller; v1_caller ] + in + let%bind.Deferred () = async_do_actions handle [ Query 8 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 2))) + (Ok 16) |}]; + Bonsai.Var.set activated false; + Handle.show handle; + let%bind () = Handle.flush_async_and_bonsai handle in + [%expect {| |}]; + let%bind () = async_do_actions handle [ Query 7 ] in + Handle.show handle; + [%expect {| (Ok "fake rpc implementation") |}]; + Bonsai.Var.set activated true; + Handle.show handle; + let%bind () = async_do_actions handle [ Query 42 ] in + [%expect {| + (rpc ((name foo) (version 2))) + (Ok 84) |}]; + Deferred.unit + ;; + + let%expect_test "downgrade rpc when component is deactivated" = + let activated, handle, break_connection, set_implementations = + setup_test_env + ~rpcs_on_server: + [ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } + ; T { rpc = V2.rpc; latest_result_of_int = Int.to_string } + ] + ~rpcs_on_client:[ v2_caller; v1_caller ] + in + let%bind.Deferred () = async_do_actions handle [ Query 8 ] in + Handle.show handle; + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 2))) + (Ok 16) |}]; + Bonsai.Var.set activated false; + let%bind () = async_do_actions handle [ Query 7 ] in + Handle.show handle; + [%expect {| + (rpc ((name foo) (version 2))) + (Ok 14) |}]; + break_connection (); + set_implementations [ T { rpc = V1.rpc; latest_result_of_int = Int.to_string } ]; + Bonsai.Var.set activated true; + Handle.show handle; + let%bind () = async_do_actions handle [ Query 42 ] in + [%expect + {| + creating rpc connection + (rpc ((name foo) (version 1))) + (Ok 84) |}]; + Deferred.unit + ;; + end) +;; + let%test_module "Rvar tests" = (module struct module Rvar = Rpc_effect.Private.For_tests.Rvar @@ -597,17 +944,17 @@ let%test_module "Rvar tests" = in [%expect {| - (iteration (!i 1)) - (iteration (!i 2)) - (iteration (!i 3)) - (iteration (!i 4)) - (iteration (!i 5)) - (iteration (!i 6)) - (iteration (!i 7)) - (iteration (!i 8)) - (iteration (!i 9)) - (iteration (!i 10)) - ("final result" (x 10)) |}]; + (iteration (!i 1)) + (iteration (!i 2)) + (iteration (!i 3)) + (iteration (!i 4)) + (iteration (!i 5)) + (iteration (!i 6)) + (iteration (!i 7)) + (iteration (!i 8)) + (iteration (!i 9)) + (iteration (!i 10)) + ("final result" (x 10)) |}]; return () ;; end) @@ -668,16 +1015,18 @@ let%test_module "Status.state" = [%expect {| ((state Connecting) (connecting_since ("1970-01-01 00:00:00Z"))) |}]; let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in Handle.show handle; - [%expect {| ((state Connected) (connecting_since ())) |}]; + [%expect {| + ((state Connected) (connecting_since ())) |}]; let%bind () = kill_connection connection in Handle.show handle; [%expect {| - ((state (Disconnected Rpc.Connection.close)) - (connecting_since ("1970-01-01 00:00:00Z"))) |}]; + ((state (Disconnected Rpc.Connection.close)) + (connecting_since ("1970-01-01 00:00:00Z"))) |}]; let%bind () = next_connection connection in Handle.show handle; - [%expect {| ((state Connected) (connecting_since ())) |}]; + [%expect {| + ((state Connected) (connecting_since ())) |}]; return () ;; @@ -698,18 +1047,20 @@ let%test_module "Status.state" = let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); Handle.show handle; - [%expect {| ((state Connected) (connecting_since ())) |}]; + [%expect {| + ((state Connected) (connecting_since ())) |}]; let%bind () = kill_connection connection in Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); Handle.show handle; [%expect {| - ((state (Disconnected Rpc.Connection.close)) - (connecting_since ("1970-01-01 00:00:03Z"))) |}]; + ((state (Disconnected Rpc.Connection.close)) + (connecting_since ("1970-01-01 00:00:03Z"))) |}]; let%bind () = next_connection connection in Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); Handle.show handle; - [%expect {| ((state Connected) (connecting_since ())) |}]; + [%expect {| + ((state Connected) (connecting_since ())) |}]; return () ;; @@ -737,7 +1088,8 @@ let%test_module "Status.state" = [%expect {| (((state Connecting) (connecting_since ("1970-01-01 00:00:00Z")))) |}]; let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in Handle.show handle; - [%expect {| (((state Connected) (connecting_since ()))) |}]; + [%expect {| + (((state Connected) (connecting_since ()))) |}]; Bonsai.Var.set is_active false; Handle.show handle; [%expect {| () |}]; @@ -748,14 +1100,15 @@ let%test_module "Status.state" = Handle.show handle; [%expect {| - (((state (Disconnected Rpc.Connection.close)) - (connecting_since ("1970-01-01 00:00:00Z")))) |}]; + (((state (Disconnected Rpc.Connection.close)) + (connecting_since ("1970-01-01 00:00:00Z")))) |}]; let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in Handle.show handle; [%expect {| (((state Connecting) (connecting_since ("1970-01-01 00:00:00Z")))) |}]; let%bind () = next_connection connection in Handle.show handle; - [%expect {| (((state Connected) (connecting_since ()))) |}]; + [%expect {| + (((state Connected) (connecting_since ()))) |}]; return () ;; @@ -786,8 +1139,8 @@ let%test_module "Status.state" = let%bind () = Async_kernel_scheduler.yield_until_no_jobs_remain () in Handle.show handle; [%expect {| - () - () |}]; + () + () |}]; Bonsai.Var.set is_active true; Handle.show handle; [%expect {| (((state Connected) (connecting_since ()))) |}]; @@ -806,10 +1159,8 @@ let%test_module "Status.state" = Handle.show handle; [%expect {| - ((state - (Failed_to_connect - "RPC not handled because no connector has been provided.")) - (connecting_since ("1970-01-01 00:00:00Z"))) |}]; + ((state (Failed_to_connect (Failure "BUG: no bonsai-rpc handler installed"))) + (connecting_since ("1970-01-01 00:00:00Z"))) |}]; return () ;; end) @@ -858,42 +1209,42 @@ let%test_module "Polling_state_rpc.poll" = (* Initially, there is no response, but initial request got sent. *) [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )) - ("For first request" (query 1)) |}]; + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )) + ("For first request" (query 1)) |}]; let%bind () = async_show handle in (* Because the clock triggers on activate, the next frame both receives the first request's response and also sets off the first polling request. *) [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh )) |}]; let%bind () = async_show handle in (* The result stays steady this frame, and no new requests are sent off. *) [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh )) |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); let%bind () = async_show handle in (* After waiting a second, apparently the clock loop needs another frame to realize that its time is up. *) [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh )) |}]; let%bind () = async_show handle in (* But it eventually causes the next polling request to be sent. *) [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query (1)) - (refresh )) - ("Computing diff" (from 1) (to_ 2)) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query (1)) + (refresh )) + ("Computing diff" (from 1) (to_ 2)) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh )) |}]; Bonsai.Var.set input_var 2; let%bind () = async_show handle in (* We also trigger poll requests on query changes. Observe that the @@ -901,15 +1252,15 @@ let%test_module "Polling_state_rpc.poll" = in this case is different from the current query. *) [%expect {| - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh )) - ("For first request" (query 2)) - ("Computing diff" (from 2) (to_ 6)) |}]; + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh )) + ("For first request" (query 2)) + ("Computing diff" (from 2) (to_ 6)) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 6))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((2 6))) (last_error ()) (inflight_query ()) + (refresh )) |}]; Deferred.unit ;; @@ -944,20 +1295,20 @@ let%test_module "Polling_state_rpc.poll" = (* On page load; sends rpc request.*) [%expect {| - ((last_ok_response())(last_error())(inflight_query())(refresh )) |}]; + ((last_ok_response())(last_error())(inflight_query())(refresh )) |}]; Bvar.broadcast bvar (); let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response())(last_error())(inflight_query())(refresh )) - +|((last_ok_response())(last_error())(inflight_query(1))(refresh )) - ("For first request" (query 1)) |}]; + -|((last_ok_response())(last_error())(inflight_query())(refresh )) + +|((last_ok_response())(last_error())(inflight_query(1))(refresh )) + ("For first request" (query 1)) |}]; let%bind () = async_show_diff handle in (* First response is received. *) [%expect {| - -|((last_ok_response())(last_error())(inflight_query(1))(refresh )) - +|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) |}]; + -|((last_ok_response())(last_error())(inflight_query(1))(refresh )) + +|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) |}]; Bvar.broadcast bvar (); let%bind () = async_show_diff handle in Bvar.broadcast bvar (); @@ -970,15 +1321,15 @@ let%test_module "Polling_state_rpc.poll" = let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) - +|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) - ("Computing diff" (from 1) (to_ 2)) |}]; + -|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) + +|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) + ("Computing diff" (from 1) (to_ 2)) |}]; Bvar.broadcast bvar (); let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) - +|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) |}]; + -|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) + +|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) |}]; let%bind () = async_show_diff handle in [%expect {| |}]; (* Doing two actions in a row does not dispatch RPC twice. *) @@ -986,15 +1337,15 @@ let%test_module "Polling_state_rpc.poll" = let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) - +|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) - ("Computing diff" (from 2) (to_ 3)) |}]; + -|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) + +|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) + ("Computing diff" (from 2) (to_ 3)) |}]; let%bind () = async_show_diff handle in Bvar.broadcast bvar (); [%expect {| - -|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) - +|((last_ok_response((1 3)))(last_error())(inflight_query())(refresh )) |}]; + -|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) + +|((last_ok_response((1 3)))(last_error())(inflight_query())(refresh )) |}]; let%bind () = async_show_diff handle in [%expect {| |}]; return () @@ -1027,22 +1378,22 @@ let%test_module "Polling_state_rpc.poll" = let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )) - ("For first request" (query 1)) |}]; + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )) + ("For first request" (query 1)) |}]; Bonsai.Var.set input_var 2; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh )) - ("For first request" (query 2)) - ("Computing diff" (from 1) (to_ 4)) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh )) + ("For first request" (query 2)) + ("Computing diff" (from 1) (to_ 4)) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh )) |}]; Deferred.unit ;; @@ -1101,78 +1452,78 @@ let%test_module "Polling_state_rpc.poll" = let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )) - (on_response_received (query 1) - (response - (Error + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )) + (on_response_received (query 1) + (response + (Error + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error ("Error response" (query 1))))))) + (connection_description ) + (rpc_name polling_state_rpc_a) (rpc_version 0))))) |}]; + let%bind () = async_show handle in + [%expect + {| + ((last_ok_response ()) + (last_error + ((1 ((rpc_error (Uncaught_exn ((location "server-side rpc computation") (exn (monitor.ml.Error ("Error response" (query 1))))))) (connection_description ) - (rpc_name polling_state_rpc_a) (rpc_version 0))))) |}]; + (rpc_name polling_state_rpc_a) (rpc_version 0))))) + (inflight_query ()) (refresh )) |}]; + Bonsai.Var.set input_var 2; let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) - (last_error - ((1 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error ("Error response" (query 1))))))) - (connection_description ) - (rpc_name polling_state_rpc_a) (rpc_version 0))))) - (inflight_query ()) (refresh )) |}]; - Bonsai.Var.set input_var 2; + ((last_ok_response ()) + (last_error + ((1 + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error ("Error response" (query 1))))))) + (connection_description ) + (rpc_name polling_state_rpc_a) (rpc_version 0))))) + (inflight_query ()) (refresh )) + (on_response_received (query 2) (response (Ok 0))) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) - (last_error - ((1 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error ("Error response" (query 1))))))) - (connection_description ) - (rpc_name polling_state_rpc_a) (rpc_version 0))))) - (inflight_query ()) (refresh )) - (on_response_received (query 2) (response (Ok 0))) |}]; + ((last_ok_response ((2 0))) (last_error ()) (inflight_query ()) + (refresh )) |}]; + Bonsai.Var.set input_var 3; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 0))) (last_error ()) (inflight_query ()) - (refresh )) |}]; - Bonsai.Var.set input_var 3; + ((last_ok_response ((2 0))) (last_error ()) (inflight_query ()) + (refresh )) + (on_response_received (query 3) + (response + (Error + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error ("Error response" (query 3))))))) + (connection_description ) + (rpc_name polling_state_rpc_a) (rpc_version 0))))) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 0))) (last_error ()) (inflight_query ()) - (refresh )) - (on_response_received (query 3) - (response - (Error + ((last_ok_response ((2 0))) + (last_error + ((3 ((rpc_error (Uncaught_exn ((location "server-side rpc computation") (exn (monitor.ml.Error ("Error response" (query 3))))))) (connection_description ) - (rpc_name polling_state_rpc_a) (rpc_version 0))))) |}]; - let%bind () = async_show handle in - [%expect - {| - ((last_ok_response ((2 0))) - (last_error - ((3 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error ("Error response" (query 3))))))) - (connection_description ) - (rpc_name polling_state_rpc_a) (rpc_version 0))))) - (inflight_query ()) (refresh )) |}]; + (rpc_name polling_state_rpc_a) (rpc_version 0))))) + (inflight_query ()) (refresh )) |}]; Deferred.unit ;; @@ -1206,94 +1557,94 @@ let%test_module "Polling_state_rpc.poll" = let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )))) - ("For first request" (query 2)) - ("For first request" (query 1)) - ("For first request" (query 10)) |}]; + ((1 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )))) + ("For first request" (query 2)) + ("For first request" (query 1)) + ("For first request" (query 10)) |}]; let%bind () = async_show handle in (* NOTE: The order of the response is [2 -> 1 -> 10] hence the response of [1] and [2] are the same because [2 * 1] = [1 * 2].*) [%expect {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; - let%bind () = async_show handle in - [%expect - {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; + let%bind () = async_show handle in + [%expect + {| + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.remove map 10); let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.set map ~key:10 ~data:()); let%bind () = async_show handle in (* since we clear the map entry when it gets de-activated, it does not remember its last response, and thus must poll for it again. *) [%expect {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )))) - ("For first request" (query 10)) |}]; - let%bind () = async_show handle in - [%expect - {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 40))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; - let%bind () = async_show handle in - [%expect - {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 40))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )))) + ("For first request" (query 10)) |}]; + let%bind () = async_show handle in + [%expect + {| + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 40))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; + let%bind () = async_show handle in + [%expect + {| + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 40))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Deferred.unit ;; @@ -1328,68 +1679,68 @@ let%test_module "Polling_state_rpc.poll" = let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )))) - ("For first request" (query 2)) - ("For first request" (query 1)) - ("For first request" (query 10)) |}]; + ((1 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )))) + ("For first request" (query 2)) + ("For first request" (query 1)) + ("For first request" (query 10)) |}]; let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; - let%bind () = async_show handle in - [%expect - {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; + let%bind () = async_show handle in + [%expect + {| + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.remove map 10); let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.set map ~key:10 ~data:()); let%bind () = async_show handle in (* since we do not clear the map entry when it gets de-activated, it does remember its last response, and thus does not need to poll for it again. *) [%expect {| - ((1 - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) - ("For first request" (query 10)) |}]; + ((1 + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 2))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) + ("For first request" (query 10)) |}]; Deferred.unit ;; end) @@ -1438,55 +1789,55 @@ let%test_module "Rpc.poll" = let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query (1)) - (refresh )) |}]; + ((last_ok_response ()) (last_error ()) (inflight_query (1)) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh )) |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query (1)) - (refresh )) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query (1)) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh )) |}]; Bonsai.Var.set input_var 2; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((1 2))) (last_error ()) (inflight_query ()) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 2))) (last_error ()) (inflight_query (2)) - (refresh )) |}]; + ((last_ok_response ((1 2))) (last_error ()) (inflight_query (2)) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 6))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((2 6))) (last_error ()) (inflight_query ()) + (refresh )) |}]; Deferred.unit ;; @@ -1523,18 +1874,18 @@ let%test_module "Rpc.poll" = let%bind () = async_show handle in [%expect {| - ((last_ok_response())(last_error())(inflight_query())(refresh )) |}]; + ((last_ok_response())(last_error())(inflight_query())(refresh )) |}]; let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response())(last_error())(inflight_query())(refresh )) - +|((last_ok_response())(last_error())(inflight_query(1))(refresh )) |}]; + -|((last_ok_response())(last_error())(inflight_query())(refresh )) + +|((last_ok_response())(last_error())(inflight_query(1))(refresh )) |}]; let%bind () = broadcast () in let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response())(last_error())(inflight_query(1))(refresh )) - +|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) |}]; + -|((last_ok_response())(last_error())(inflight_query(1))(refresh )) + +|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) |}]; let%bind () = broadcast () in let%bind () = async_show_diff handle in let%bind () = broadcast () in @@ -1543,34 +1894,34 @@ let%test_module "Rpc.poll" = let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) - +|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) |}]; + -|((last_ok_response((1 1)))(last_error())(inflight_query())(refresh )) + +|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) |}]; let%bind () = broadcast () in let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) - +|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) |}]; + -|((last_ok_response((1 1)))(last_error())(inflight_query(1))(refresh )) + +|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) |}]; (* Doing two actions causes them to be dispatched in sequence, rather than twice in a row. *) Handle.do_actions handle [ (); (); () ]; let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) - +|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) |}]; + -|((last_ok_response((1 2)))(last_error())(inflight_query())(refresh )) + +|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) |}]; let%bind () = broadcast () in let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) - +|((last_ok_response((1 3)))(last_error())(inflight_query(1))(refresh )) |}]; + -|((last_ok_response((1 2)))(last_error())(inflight_query(1))(refresh )) + +|((last_ok_response((1 3)))(last_error())(inflight_query(1))(refresh )) |}]; let%bind () = broadcast () in let%bind () = async_show_diff handle in [%expect {| - -|((last_ok_response((1 3)))(last_error())(inflight_query(1))(refresh )) - +|((last_ok_response((1 4)))(last_error())(inflight_query())(refresh )) |}]; + -|((last_ok_response((1 3)))(last_error())(inflight_query(1))(refresh )) + +|((last_ok_response((1 4)))(last_error())(inflight_query())(refresh )) |}]; return () ;; @@ -1622,83 +1973,83 @@ let%test_module "Rpc.poll" = let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query (1)) - (refresh )) - (on_response_received (query 1) - (response - (Error - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error ("Error response" (query 1))))))) - (connection_description ) (rpc_name rpc) - (rpc_version 0))))) |}]; + ((last_ok_response ()) (last_error ()) (inflight_query (1)) + (refresh )) + (on_response_received (query 1) + (response + (Error + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error ("Error response" (query 1))))))) + (connection_description ) (rpc_name rpc) + (rpc_version 0))))) |}]; Bonsai.Var.set input_var 2; let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) - (last_error - ((1 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error ("Error response" (query 1))))))) - (connection_description ) (rpc_name rpc) - (rpc_version 0))))) - (inflight_query ()) (refresh )) |}]; + ((last_ok_response ()) + (last_error + ((1 + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error ("Error response" (query 1))))))) + (connection_description ) (rpc_name rpc) + (rpc_version 0))))) + (inflight_query ()) (refresh )) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) - (last_error - ((1 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error ("Error response" (query 1))))))) - (connection_description ) (rpc_name rpc) - (rpc_version 0))))) - (inflight_query (2)) (refresh )) - (on_response_received (query 2) (response (Ok 4))) |}]; + ((last_ok_response ()) + (last_error + ((1 + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error ("Error response" (query 1))))))) + (connection_description ) (rpc_name rpc) + (rpc_version 0))))) + (inflight_query (2)) (refresh )) + (on_response_received (query 2) (response (Ok 4))) |}]; Bonsai.Var.set input_var 3; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh )) |}]; + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh )) |}]; + let%bind () = async_show handle in + [%expect + {| + ((last_ok_response ((2 4))) (last_error ()) (inflight_query (3)) + (refresh )) + (on_response_received (query 3) + (response + (Error + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error ("Error response" (query 3))))))) + (connection_description ) (rpc_name rpc) + (rpc_version 0))))) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 4))) (last_error ()) (inflight_query (3)) - (refresh )) - (on_response_received (query 3) - (response - (Error + ((last_ok_response ((2 4))) + (last_error + ((3 ((rpc_error (Uncaught_exn ((location "server-side rpc computation") (exn (monitor.ml.Error ("Error response" (query 3))))))) (connection_description ) (rpc_name rpc) - (rpc_version 0))))) |}]; - let%bind () = async_show handle in - [%expect - {| - ((last_ok_response ((2 4))) - (last_error - ((3 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error ("Error response" (query 3))))))) - (connection_description ) (rpc_name rpc) - (rpc_version 0))))) - (inflight_query ()) (refresh )) |}]; + (rpc_version 0))))) + (inflight_query ()) (refresh )) |}]; Deferred.unit ;; @@ -1732,88 +2083,88 @@ let%test_module "Rpc.poll" = let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )))) |}]; let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ()) (last_error ()) (inflight_query (1)) - (refresh ))) - (2 - ((last_ok_response ()) (last_error ()) (inflight_query (2)) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query (10)) - (refresh )))) |}]; - let%bind () = async_show handle in - [%expect - {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ()) (last_error ()) (inflight_query (1)) + (refresh ))) + (2 + ((last_ok_response ()) (last_error ()) (inflight_query (2)) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query (10)) + (refresh )))) |}]; + let%bind () = async_show handle in + [%expect + {| + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.remove map 10); let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.set map ~key:10 ~data:()); let%bind () = async_show handle in (* since we clear the map entry when it gets de-activated, it does not remember its last response, and thus must poll for it again. *) [%expect {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )))) |}]; let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query (10)) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query (10)) + (refresh )))) |}]; let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 40))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 40))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Deferred.unit ;; @@ -1848,64 +2199,64 @@ let%test_module "Rpc.poll" = let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query ()) + (refresh )))) |}]; let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ()) (last_error ()) (inflight_query (1)) - (refresh ))) - (2 - ((last_ok_response ()) (last_error ()) (inflight_query (2)) - (refresh ))) - (10 - ((last_ok_response ()) (last_error ()) (inflight_query (10)) - (refresh )))) |}]; - let%bind () = async_show handle in - [%expect - {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ()) (last_error ()) (inflight_query (1)) + (refresh ))) + (2 + ((last_ok_response ()) (last_error ()) (inflight_query (2)) + (refresh ))) + (10 + ((last_ok_response ()) (last_error ()) (inflight_query (10)) + (refresh )))) |}]; + let%bind () = async_show handle in + [%expect + {| + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.remove map 10); let%bind () = async_show handle in [%expect {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Bonsai.Var.update map_var ~f:(fun map -> Map.set map ~key:10 ~data:()); let%bind () = async_show handle in (* since we do not clear the map entry when it gets de-activated, it does remember its last response, and thus does not need to poll for it again. *) [%expect {| - ((1 - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) - (refresh ))) - (2 - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) - (refresh ))) - (10 - ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) - (refresh )))) |}]; + ((1 + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ()) + (refresh ))) + (2 + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ()) + (refresh ))) + (10 + ((last_ok_response ((10 30))) (last_error ()) (inflight_query ()) + (refresh )))) |}]; Deferred.unit ;; end) @@ -1980,18 +2331,18 @@ let%test_module "Rpc.poll_until_ok" = in let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ()) (last_error ()) (inflight_query ())) |}]; let%bind () = async_recompute_view handle in [%expect {| - received rpc! |}]; + received rpc! |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; (* Despite clock advancing, an rpc is not sent. *) Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); let%bind () = async_recompute_view handle in @@ -1999,22 +2350,22 @@ let%test_module "Rpc.poll_until_ok" = let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; (* Even after stopping, if the query changes, the rpc is sent again. *) Bonsai.Var.set input_var 2; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query (2))) - received rpc! |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query (2))) + received rpc! |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((2 4))) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ((2 4))) (last_error ()) (inflight_query ())) |}]; Deferred.unit ;; @@ -2043,59 +2394,59 @@ let%test_module "Rpc.poll_until_ok" = [%expect {| ((last_ok_response ()) (last_error ()) (inflight_query ())) |}]; let%bind () = async_recompute_view handle in [%expect {| - received rpc! |}]; + received rpc! |}]; let%bind () = async_show handle in (* First error. *) [%expect {| - ((last_ok_response ()) - (last_error - ((1 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error (Failure "too early!")))))) - (connection_description ) (rpc_name rpc) - (rpc_version 0))))) - (inflight_query ())) |}]; + ((last_ok_response ()) + (last_error + ((1 + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error (Failure "too early!")))))) + (connection_description ) (rpc_name rpc) + (rpc_version 0))))) + (inflight_query ())) |}]; (* Advancing clock to send another rpc.*) Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); let%bind () = async_recompute_view handle in (* Retried rpc sent.*) let%bind () = async_recompute_view handle in [%expect {| - received rpc! |}]; + received rpc! |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ()) - (last_error - ((1 - ((rpc_error - (Uncaught_exn - ((location "server-side rpc computation") - (exn (monitor.ml.Error (Failure "too early!")))))) - (connection_description ) (rpc_name rpc) - (rpc_version 0))))) - (inflight_query ())) |}]; + ((last_ok_response ()) + (last_error + ((1 + ((rpc_error + (Uncaught_exn + ((location "server-side rpc computation") + (exn (monitor.ml.Error (Failure "too early!")))))) + (connection_description ) (rpc_name rpc) + (rpc_version 0))))) + (inflight_query ())) |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); let%bind () = async_recompute_view handle in (* Retried rpc sent.*) let%bind () = async_recompute_view handle in [%expect {| - received rpc! |}]; + received rpc! |}]; (* Third rpc returns ok. *) let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 3))) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ((1 3))) (last_error ()) (inflight_query ())) |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); (* No more rpc's are sent. *) let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in - [%expect {||}]; + [%expect {| |}]; Deferred.unit ;; @@ -2123,28 +2474,26 @@ let%test_module "Rpc.poll_until_ok" = let%bind () = async_show handle in [%expect {| ((last_ok_response ()) (last_error ()) (inflight_query ())) |}]; let%bind () = async_recompute_view handle in - [%expect {| - received rpc! |}]; + [%expect {| received rpc! |}]; let%bind () = async_show handle in [%expect {| - ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; + ((last_ok_response ((1 1))) (last_error ()) (inflight_query ())) |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in - [%expect {||}]; + [%expect {| |}]; Handle.advance_clock_by handle (Time_ns.Span.of_sec 1.0); let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in - [%expect {||}]; + [%expect {| |}]; (* Rpc is sent when refresh is scheduled *) Handle.do_actions handle [ Refresh ]; let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in - [%expect {| - received rpc! |}]; + [%expect {| received rpc! |}]; let%bind () = async_show handle in [%expect {| ((last_ok_response ((1 2))) (last_error ()) (inflight_query ())) |}]; (* Rpc is not resent afterwards when refresh is scheduled *) @@ -2152,7 +2501,7 @@ let%test_module "Rpc.poll_until_ok" = let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in let%bind () = async_recompute_view handle in - [%expect {||}]; + [%expect {| |}]; Deferred.unit ;; end) @@ -2204,8 +2553,8 @@ let%test_module "multi-poller" = [%expect {| () |}]; Handle.show handle; [%expect {| - ((5 hello)) - (start 5) |}]; + ((5 hello)) + (start 5) |}]; Handle.show handle; [%expect {| ((5 hello)) |}]; return () @@ -2245,8 +2594,8 @@ let%test_module "multi-poller" = [%expect {| ((a ()) (b ())) |}]; Handle.show handle; [%expect {| - ((a ((5 hello))) (b ((5 hello)))) - (start 5) |}]; + ((a ((5 hello))) (b ((5 hello)))) + (start 5) |}]; Handle.show handle; [%expect {| ((a ((5 hello))) (b ((5 hello)))) |}]; return () @@ -2287,9 +2636,9 @@ let%test_module "multi-poller" = Handle.show handle; [%expect {| - ((a ((5 hello))) (b ((10 hello)))) - (start 5) - (start 10) |}]; + ((a ((5 hello))) (b ((10 hello)))) + (start 5) + (start 10) |}]; Handle.show handle; [%expect {| ((a ((5 hello))) (b ((10 hello)))) |}]; return () @@ -2328,8 +2677,8 @@ let%test_module "multi-poller" = [%expect {| () |}]; Handle.show handle; [%expect {| - ((5 hello)) - (start 5) |}]; + ((5 hello)) + (start 5) |}]; Handle.show handle; [%expect {| ((5 hello)) |}]; Bonsai.Var.set bool_var false; @@ -2337,8 +2686,8 @@ let%test_module "multi-poller" = [%expect {| ((5 INACTIVE)) |}]; Handle.show handle; [%expect {| - ((5 INACTIVE)) - (stop 5) |}]; + ((5 INACTIVE)) + (stop 5) |}]; return () ;; @@ -2386,8 +2735,8 @@ let%test_module "multi-poller" = [%expect {| ((a ()) (b ())) |}]; Handle.show handle; [%expect {| - ((a ((5 hello))) (b ((5 hello)))) - (start 5) |}]; + ((a ((5 hello))) (b ((5 hello)))) + (start 5) |}]; Handle.show handle; [%expect {| ((a ((5 hello))) (b ((5 hello)))) |}]; Bonsai.Var.set bool_var false; @@ -2441,9 +2790,9 @@ let%test_module "multi-poller" = Handle.show handle; [%expect {| - ((a ((5 hello))) (b ((10 hello)))) - (start 5) - (start 10) |}]; + ((a ((5 hello))) (b ((10 hello)))) + (start 5) + (start 10) |}]; Handle.show handle; [%expect {| ((a ((5 hello))) (b ((10 hello)))) |}]; Bonsai.Var.set bool_var false; @@ -2451,9 +2800,21 @@ let%test_module "multi-poller" = [%expect {| ((a ((5 hello))) (b ((10 INACTIVE)))) |}]; Handle.show handle; [%expect {| - ((a ((5 hello))) (b ((10 INACTIVE)))) - (stop 10) |}]; + ((a ((5 hello))) (b ((10 INACTIVE)))) + (stop 10) |}]; return () ;; end) ;; + +let%expect_test "There should be 0 nodes being observed. (This test should ideally be at \ + the end of the file.)" + = + (* This test is a test against a regression test where many incremental nodes were still + observed across test runs. This test tests that the [Expect_test_config] in + [Async_js_test] works. *) + let number_of_observed_nodes = Incremental.State.num_active_observers Ui_incr.State.t in + print_s [%message (number_of_observed_nodes : int)]; + [%expect {| (number_of_observed_nodes 0) |}]; + return () +;; diff --git a/web_test/proc.ml b/web_test/proc.ml index 27d4dcde..2b486f72 100644 --- a/web_test/proc.ml +++ b/web_test/proc.ml @@ -35,9 +35,15 @@ module Result_spec = struct ;; end -let add_rpc_implementations_to_connectors ~rpc_implementations ~connectors = - match rpc_implementations with - | Some rpc_implementations -> +let add_rpc_implementations_to_computation ~rpc_implementations ~connectors computation = + match rpc_implementations, connectors with + | None, None -> computation + | _ -> + let rpc_implementations = Option.value rpc_implementations ~default:[] in + let connectors = + Option.value connectors ~default:(fun _ -> + Bonsai_web.Rpc_effect.Connector.test_fallback) + in let test_fallback_connector = let open Async_rpc_kernel in Rpc_effect.Connector.for_test @@ -46,12 +52,13 @@ let add_rpc_implementations_to_connectors ~rpc_implementations ~connectors = ~implementations:(Versioned_rpc.Menu.add rpc_implementations)) ~connection_state:Fn.id in - fun where_to_connect -> + let connectors where_to_connect = let connector = connectors where_to_connect in if Bonsai_web.Rpc_effect.Private.is_test_fallback connector then test_fallback_connector else connector - | None -> connectors + in + Bonsai_web.Rpc_effect.Private.with_connector connectors computation ;; module Handle = struct @@ -60,18 +67,14 @@ module Handle = struct let create result_spec ?rpc_implementations - ?(connectors = fun _ -> Bonsai_web.Rpc_effect.Connector.test_fallback) + ?connectors ?start_time ?optimize computation = - let connectors = - add_rpc_implementations_to_connectors ~rpc_implementations ~connectors - in - let computation = - Bonsai_web.Rpc_effect.Private.with_connector connectors computation - in - Bonsai_test.Handle.create result_spec ?start_time ?optimize computation + computation + |> add_rpc_implementations_to_computation ~rpc_implementations ~connectors + |> Bonsai_test.Handle.create result_spec ?start_time ?optimize ;; let flush_async_and_bonsai @@ -382,29 +385,31 @@ module Experimental = struct module Handle = struct type ('result, 'incoming) t = - (unit, 'result * Vdom.Node.t * string * ('incoming -> unit Effect.t)) Driver.t + ( unit + , 'result * Vdom.Node.t * string Lazy.t * ('incoming -> unit Effect.t) ) + Driver.t let create (type result incoming) (result_spec : (result, incoming) Result_spec.t) ?rpc_implementations - ?(connectors = fun _ -> Bonsai_web.Rpc_effect.Connector.test_fallback) + ?connectors ?(start_time = Time_ns.epoch) ?(optimize = true) computation = - let connectors = - add_rpc_implementations_to_connectors ~rpc_implementations ~connectors - in let computation = - Bonsai_web.Rpc_effect.Private.with_connector connectors computation + add_rpc_implementations_to_computation + ~rpc_implementations + ~connectors + computation in let (module R) = result_spec in let component (_ : unit Value.t) = let open Bonsai.Let_syntax in let%sub result = computation in let%arr result = result in - result, R.to_vdom result, R.view result, R.incoming result + result, R.to_vdom result, lazy (R.view result), R.incoming result in let clock = Bonsai.Time_source.create ~start:start_time in Driver.create ~optimize ~initial_input:() ~clock component @@ -467,7 +472,8 @@ module Experimental = struct ;; let show handle = - generic_show handle ~before:(Fn.const ()) ~f:(fun () view -> print_endline view) + generic_show handle ~before:(Fn.const ()) ~f:(fun () view -> + print_endline (Lazy.force view)) ;; let show_diff @@ -475,10 +481,12 @@ module Experimental = struct ?(diff_context = 16) handle = - generic_show - handle - ~before:Driver.last_view - ~f:(Expect_test_patdiff.print_patdiff ~location_style ~context:diff_context) + generic_show handle ~before:Driver.last_view ~f:(fun a b -> + Expect_test_patdiff.print_patdiff + ~location_style + ~context:diff_context + (Lazy.force a) + (Lazy.force b)) ;; let store_view handle = generic_show handle ~before:(Fn.const ()) ~f:(fun () _ -> ()) @@ -680,3 +688,5 @@ module Experimental = struct end end end + +module Expect_test_config = Bonsai_test.Expect_test_config diff --git a/web_test/proc.mli b/web_test/proc.mli index 0f99823c..9049694c 100644 --- a/web_test/proc.mli +++ b/web_test/proc.mli @@ -482,3 +482,5 @@ module Experimental : sig end end end + +module Expect_test_config : Expect_test_config_types.S with module IO = Monad.Ident diff --git a/web_ui/accordion/src/dune b/web_ui/accordion/src/dune index e781a525..c6526d9d 100644 --- a/web_ui/accordion/src/dune +++ b/web_ui/accordion/src/dune @@ -1,7 +1,12 @@ -(library (name bonsai_web_ui_accordion) (public_name bonsai.web_ui_accordion) - (preprocess (pps js_of_ocaml-ppx ppx_jane ppx_bonsai ppx_css)) +(library + (name bonsai_web_ui_accordion) + (public_name bonsai.web_ui_accordion) + (preprocess + (pps js_of_ocaml-ppx ppx_jane ppx_bonsai ppx_css)) (libraries bonsai bonsai_web core ppx_css.inline_css)) -(rule (targets style.ml style.mli style__generated.ml style__generated.mli) +(rule + (targets style.ml style.mli style__generated.ml style__generated.mli) (deps style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) \ No newline at end of file + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) diff --git a/web_ui/accordion/test/dune b/web_ui/accordion/test/dune index 70692d6e..20fa959a 100644 --- a/web_ui/accordion/test/dune +++ b/web_ui/accordion/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_accordion_test) +(library + (name bonsai_web_ui_accordion_test) (libraries bonsai_web_ui_accordion bonsai_web bonsai_web_test core) - (preprocess (pps ppx_jane ppx_bonsai js_of_ocaml-ppx))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai js_of_ocaml-ppx))) diff --git a/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.ml b/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.ml index 0fd769e2..aa38b937 100644 --- a/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.ml +++ b/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.ml @@ -3,7 +3,7 @@ open! Bonsai_web open Bonsai.Let_syntax module N = Vdom.Node module A = Vdom.Attr -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module E = Form.Elements module type S = sig diff --git a/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.mli b/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.mli index 8d3a759a..dcd0c6ee 100644 --- a/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.mli +++ b/web_ui/auto_generated/src/bonsai_web_ui_auto_generated.mli @@ -1,6 +1,6 @@ open! Core open! Bonsai_web -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module type S = sig type t [@@deriving sexp, sexp_grammar] @@ -118,7 +118,7 @@ val form' (** [view_as_vdom] provides a custom rendering function for the form generated by [form], which is optimized to look good, even with many levels of nesting. *) val view_as_vdom - : ?on_submit:'a Bonsai_web_ui_form.Submit.t + : ?on_submit:'a Bonsai_web_ui_form.With_automatic_view.Submit.t -> ?editable:[ `Yes_always | `Currently_yes | `Currently_no ] -> 'a Form.t -> Vdom.Node.t diff --git a/web_ui/auto_generated/src/dune b/web_ui/auto_generated/src/dune index f706bc34..d7b347d6 100644 --- a/web_ui/auto_generated/src/dune +++ b/web_ui/auto_generated/src/dune @@ -1,5 +1,7 @@ -(library (name bonsai_web_ui_auto_generated) +(library + (name bonsai_web_ui_auto_generated) (public_name bonsai.web_ui_auto_generated) - (preprocess (pps ppx_bonsai ppx_css ppx_jane)) + (preprocess + (pps ppx_bonsai ppx_css ppx_jane)) (libraries bonsai bonsai_extra bonsai_web bonsai_web_ui_form core - ordinal_abbreviation sexplib0 sexp_grammar virtual_dom.input_widgets)) \ No newline at end of file + ordinal_abbreviation sexplib0 sexp_grammar virtual_dom.input_widgets)) diff --git a/web_ui/auto_generated/src/render_form.ml b/web_ui/auto_generated/src/render_form.ml index 493536b9..f02ea583 100644 --- a/web_ui/auto_generated/src/render_form.ml +++ b/web_ui/auto_generated/src/render_form.ml @@ -1,7 +1,7 @@ open! Core open Bonsai_web module Attr = Vdom.Attr -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Node = Vdom.Node module Form_view = Form.View diff --git a/web_ui/auto_generated/src/render_form.mli b/web_ui/auto_generated/src/render_form.mli index 29eda45c..c47e25a1 100644 --- a/web_ui/auto_generated/src/render_form.mli +++ b/web_ui/auto_generated/src/render_form.mli @@ -3,7 +3,7 @@ open Bonsai_web val to_vdom : ?theme:View.Theme.t - -> ?on_submit:Bonsai_web_ui_form.View.submission_options - -> ?editable:Bonsai_web_ui_form.View.editable - -> Bonsai_web_ui_form.View.t + -> ?on_submit:Bonsai_web_ui_form.With_automatic_view.View.submission_options + -> ?editable:Bonsai_web_ui_form.With_automatic_view.View.editable + -> Bonsai_web_ui_form.With_automatic_view.View.t -> Vdom.Node.t diff --git a/web_ui/auto_generated/test/dune b/web_ui/auto_generated/test/dune index 5c6fff28..022a0a18 100644 --- a/web_ui/auto_generated/test/dune +++ b/web_ui/auto_generated/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_auto_generated_test) - (preprocess (pps ppx_bonsai ppx_jane)) - (libraries bonsai_web_ui_auto_generated bonsai_web_ui_form bonsai_web - bonsai_web_test core virtual_dom)) \ No newline at end of file +(library + (name bonsai_web_ui_auto_generated_test) + (preprocess + (pps ppx_bonsai ppx_jane)) + (libraries bonsai_web_ui_auto_generated bonsai_web bonsai_web_test + bonsai_web_ui_form core virtual_dom)) diff --git a/web_ui/auto_generated/test/import.ml b/web_ui/auto_generated/test/import.ml index 654ee782..2425c760 100644 --- a/web_ui/auto_generated/test/import.ml +++ b/web_ui/auto_generated/test/import.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open! Bonsai_web_test open! Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view module Auto_generated = Bonsai_web_ui_auto_generated let get_vdom form = diff --git a/web_ui/auto_generated/test/test_computation_shape.ml b/web_ui/auto_generated/test/test_computation_shape.ml index 30dbf62d..9eb59b9b 100644 --- a/web_ui/auto_generated/test/test_computation_shape.ml +++ b/web_ui/auto_generated/test/test_computation_shape.ml @@ -5,16 +5,9 @@ open! Bonsai_web_test module Private = Bonsai.Private module Auto_generated = Bonsai_web_ui_auto_generated -let pre_process computation = - computation - |> Private.reveal_computation - |> Private.pre_process - |> Private.conceal_computation -;; - let count_computation_nodes name c = let skeleton = - Private.Skeleton.Computation.of_computation (Private.reveal_computation c) + Private.Skeleton.Computation.of_computation (Private.top_level_handle c) in let o = object @@ -32,21 +25,24 @@ module type S = sig end let test_form (type a) (module M : S with type t = a) (ts : a list) = - let run c = - let handle = Handle.create ~optimize:false (form_result_spec M.sexp_of_t) c in + let run ~optimize c = + let handle = Handle.create ~optimize (form_result_spec M.sexp_of_t) c in List.iter ts ~f:(fun t -> Handle.do_actions handle [ t ]; Handle.recompute_view handle) in + let computation = Auto_generated.form (module M) () in let no_opt_count = - let computation = Auto_generated.form (module M) () in - run computation; - count_computation_nodes "no optimization" computation + let raw_computation = Private.top_level_handle computation in + run (fun graph -> Private.perform graph raw_computation) ~optimize:false; + count_computation_nodes "no optimization" (fun graph -> + Private.perform graph raw_computation) in let with_opt_count = - let computation = Auto_generated.form (module M) () |> pre_process in - run computation; - count_computation_nodes "with optimization" computation + let raw_computation = Private.top_level_handle computation |> Private.pre_process in + run (fun graph -> Private.perform graph raw_computation) ~optimize:true; + count_computation_nodes "with optimization" (fun graph -> + Private.perform graph raw_computation) in print_endline (sprintf @@ -59,9 +55,9 @@ let%expect_test "int" = test_form (module Int) [ 5 ]; [%expect {| - no optimization: 455 nodes + no optimization: 443 nodes with optimization: 31 nodes - reduced to 6.8% + reduced to 7.0% |}] ;; @@ -84,9 +80,9 @@ let%expect_test "option>variant>record form" = test_form (module T) [ None; Some A; Some (B { a = 5; b = "hello" }) ]; [%expect {| - no optimization: 3791 nodes - with optimization: 233 nodes - reduced to 6.1% + no optimization: 3657 nodes + with optimization: 225 nodes + reduced to 6.2% |}] ;; @@ -101,8 +97,8 @@ let%expect_test "variant form" = test_form (module T) [ A; B 5 ]; [%expect {| - no optimization: 1609 nodes - with optimization: 113 nodes + no optimization: 1553 nodes + with optimization: 109 nodes reduced to 7.0% |}] ;; @@ -118,9 +114,9 @@ let%expect_test "record form" = test_form (module T) [ { a = 5; b = "hello" } ]; [%expect {| - no optimization: 1739 nodes + no optimization: 1673 nodes with optimization: 105 nodes - reduced to 6.0% |}] + reduced to 6.3% |}] ;; let%expect_test "option form" = @@ -131,7 +127,7 @@ let%expect_test "option form" = test_form (module T) [ None; Some 5 ]; [%expect {| - no optimization: 1353 nodes - with optimization: 77 nodes - reduced to 5.7% |}] + no optimization: 1317 nodes + with optimization: 73 nodes + reduced to 5.5% |}] ;; diff --git a/web_ui/common_components/dune b/web_ui/common_components/dune index 4d6cc4ba..fbc9634b 100644 --- a/web_ui/common_components/dune +++ b/web_ui/common_components/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_common_components) - (public_name bonsai.web_ui_common_components) (libraries core bonsai_web) - (preprocess (pps ppx_jane ppx_bonsai ppx_css))) \ No newline at end of file +(library + (name bonsai_web_ui_common_components) + (public_name bonsai.web_ui_common_components) + (libraries core bonsai_web) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css))) diff --git a/web_ui/drag_and_drop/src/dune b/web_ui/drag_and_drop/src/dune index 248de1f5..0e6a2de0 100644 --- a/web_ui/drag_and_drop/src/dune +++ b/web_ui/drag_and_drop/src/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_drag_and_drop) +(library + (name bonsai_web_ui_drag_and_drop) (libraries core bonsai bonsai_web virtual_dom) - (preprocess (pps ppx_css js_of_ocaml-ppx ppx_jane ppx_bonsai)) - (public_name bonsai.web_ui_drag_and_drop)) \ No newline at end of file + (preprocess + (pps ppx_css js_of_ocaml-ppx ppx_jane ppx_bonsai)) + (public_name bonsai.web_ui_drag_and_drop)) diff --git a/web_ui/drag_and_drop/test/dune b/web_ui/drag_and_drop/test/dune index d211e57c..c1698a7c 100644 --- a/web_ui/drag_and_drop/test/dune +++ b/web_ui/drag_and_drop/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_drag_and_drop_test) +(library + (name bonsai_web_ui_drag_and_drop_test) (libraries bonsai_web_ui_drag_and_drop bonsai_web_test core) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/element_size_hooks/src/dune b/web_ui/element_size_hooks/src/dune index 67cdf65d..29240329 100644 --- a/web_ui/element_size_hooks/src/dune +++ b/web_ui/element_size_hooks/src/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_element_size_hooks) +(library + (name bonsai_web_ui_element_size_hooks) (public_name bonsai.web_ui_element_size_hooks) (libraries bonsai_web core core_kernel.reversed_list jsoo_weak_collections) - (preprocess (pps js_of_ocaml-ppx ppx_jane gen_js_api.ppx ppx_bonsai))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_jane gen_js_api.ppx ppx_bonsai))) diff --git a/web_ui/element_size_hooks/src/size_tracker.ml b/web_ui/element_size_hooks/src/size_tracker.ml index 26aa075e..9acbfd4c 100644 --- a/web_ui/element_size_hooks/src/size_tracker.ml +++ b/web_ui/element_size_hooks/src/size_tracker.ml @@ -66,9 +66,16 @@ module T = struct let on_mount _ state element = state.observer <- Some (observe ~state element) - let update ~old_input:_ ~new_input state _ = - state.callback <- wrap_with_handle ~f:new_input; - state.callback ~width:state.last_width ~height:state.last_height + let update ~old_input ~new_input state _ = + if phys_equal old_input new_input + then () + else ( + state.callback <- wrap_with_handle ~f:new_input; + (* if the "size change" callback function changes, we should send it what we + currently think the size is, otherwise if the element never changes size, + the function would never get called, so whatever is ttracking the size would + always remain clueless... *) + state.callback ~width:state.last_width ~height:state.last_height) ;; let destroy _ state _ = diff --git a/web_ui/element_size_hooks/test/dune b/web_ui/element_size_hooks/test/dune index 84e650c5..fefcc9e0 100644 --- a/web_ui/element_size_hooks/test/dune +++ b/web_ui/element_size_hooks/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_element_size_hooks_test) +(library + (name bonsai_web_ui_element_size_hooks_test) (libraries core bonsai_web_ui_element_size_hooks bonsai_web_test) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/web_ui/extendy/src/dune b/web_ui/extendy/src/dune index ff4d3bc0..135d9bd6 100644 --- a/web_ui/extendy/src/dune +++ b/web_ui/extendy/src/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_extendy) (public_name bonsai.web_ui_extendy) +(library + (name bonsai_web_ui_extendy) + (public_name bonsai.web_ui_extendy) (libraries bonsai bonsai_web core) - (preprocess (pps ppx_jane ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_pattern_bind ppx_bonsai))) diff --git a/web_ui/extendy/test/dune b/web_ui/extendy/test/dune index 0d1fcf25..d810d429 100644 --- a/web_ui/extendy/test/dune +++ b/web_ui/extendy/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_extendy_test) +(library + (name bonsai_web_ui_extendy_test) (libraries bonsai_web_ui_extendy bonsai_web_test core) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/web_ui/favicon_svg/src/dune b/web_ui/favicon_svg/src/dune index 295a508d..a2d89a69 100644 --- a/web_ui/favicon_svg/src/dune +++ b/web_ui/favicon_svg/src/dune @@ -1,2 +1,6 @@ -(library (name favicon_svg) (public_name bonsai.web_ui_favicon_svg) - (libraries base64 core virtual_dom.css_gen uri) (preprocess (pps ppx_jane))) \ No newline at end of file +(library + (name favicon_svg) + (public_name bonsai.web_ui_favicon_svg) + (libraries base64 core virtual_dom.css_gen uri) + (preprocess + (pps ppx_jane))) diff --git a/web_ui/file/from_web_file/dune b/web_ui/file/from_web_file/dune index 63d75db7..087e089b 100644 --- a/web_ui/file/from_web_file/dune +++ b/web_ui/file/from_web_file/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_file_from_web_file) +(library + (name bonsai_web_ui_file_from_web_file) (public_name bonsai.web_ui_file_from_web_file) (libraries bonsai_web bonsai_web_ui_file) - (preprocess (pps ppx_jane js_of_ocaml-ppx))) \ No newline at end of file + (preprocess + (pps ppx_jane js_of_ocaml-ppx))) diff --git a/web_ui/file/src/dune b/web_ui/file/src/dune index b553d20a..7dbcb61c 100644 --- a/web_ui/file/src/dune +++ b/web_ui/file/src/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_file) (public_name bonsai.web_ui_file) +(library + (name bonsai_web_ui_file) + (public_name bonsai.web_ui_file) (libraries core bonsai) - (preprocess (pps ppx_bonsai ppx_jane js_of_ocaml-ppx ppx_pattern_bind))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane js_of_ocaml-ppx ppx_pattern_bind))) diff --git a/web_ui/file/test/dune b/web_ui/file/test/dune index 8b4a53cc..336869b7 100644 --- a/web_ui/file/test/dune +++ b/web_ui/file/test/dune @@ -1,3 +1,5 @@ -(library (name test_bonsai_web_ui_file) +(library + (name test_bonsai_web_ui_file) (libraries bonsai_web_ui_file bonsai_test) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane))) diff --git a/web_ui/form/src/bonsai_web_ui_form.ml b/web_ui/form/src/bonsai_web_ui_form.ml index 4715e950..00a51c00 100644 --- a/web_ui/form/src/bonsai_web_ui_form.ml +++ b/web_ui/form/src/bonsai_web_ui_form.ml @@ -1,4 +1,29 @@ open! Core -include Form -module Elements = Elements -module Typed = Typed + +(** [With_manual_view] forms are now the recommended way to build forms in Bonsai. You get + full control over how you'd like to combine them. Historically, [With_automatic_view] + was the default, but they are quite restrictive and hard to customize, so we recommend + choosing [With_manual_view] for new forms. *) +module With_manual_view = struct + include Form_manual + + module Elements = struct + include Elements_manual + include Typed_elements_manual + end + + module Typed = Typed_manual + + module Private = struct + include Elements_manual.Private + end +end + +(** [With_automatic_view] forms have their views composed in an opinionated way. This used + to be the default and recommended way to build forms in Bonsai, but now people should + prefer [With_manual_view] where possible. *) +module With_automatic_view = struct + include Form_automatic + module Elements = Elements_automatic + module Typed = Typed_automatic +end diff --git a/web_ui/form/src/dune b/web_ui/form/src/dune index f84746f7..e1cdcd9d 100644 --- a/web_ui/form/src/dune +++ b/web_ui/form/src/dune @@ -1,10 +1,14 @@ -(library (name bonsai_web_ui_form) (public_name bonsai.web_ui_form) - (flags :standard -alert -private_bonsai_view_library -alert - -experimental_forms_library) +(library + (name bonsai_web_ui_form) + (public_name bonsai.web_ui_form) + (flags :standard -alert -private_bonsai_view_library) (preprocess (pps js_of_ocaml-ppx ppx_jane ppx_bonsai ppx_css ppx_typed_fields)) - (libraries bonsai bonsai_web bonsai_web_ui_form_view bonsai_web_ui_form2 - bonsai_web_ui_file bonsai_web_ui_multi_select bonsai_web_ui_query_box - bonsai_web_ui_reorderable_list core profunctor - ppx_typed_fields.typed_fields_lib ppx_typed_fields.typed_variants_lib - virtual_dom.input_widgets)) \ No newline at end of file + (libraries bonsai bonsai_web bonsai_web_ui_common_components + bonsai_web_ui_extendy bonsai_web_ui_file bonsai_extra + bonsai_web_ui_file_from_web_file bonsai_web_ui_form_view + bonsai_web_ui_freeform_multiselect bonsai_web_ui_multi_select + bonsai_web_ui_query_box bonsai_web_ui_reorderable_list + bonsai_web_ui_typeahead core fuzzy_match.match profunctor record_builder + ppx_typed_fields.typed_field_map ppx_typed_fields.typed_fields_lib + ppx_typed_fields.typed_variants_lib virtual_dom.input_widgets)) diff --git a/web_ui/form/src/elements.ml b/web_ui/form/src/elements_automatic.ml similarity index 99% rename from web_ui/form/src/elements.ml rename to web_ui/form/src/elements_automatic.ml index 1fc10b10..433b1a6a 100644 --- a/web_ui/form/src/elements.ml +++ b/web_ui/form/src/elements_automatic.ml @@ -1,5 +1,5 @@ open! Core -module Private_view = View +module Private_view = View_automatic open! Bonsai_web open Bonsai.Let_syntax module View = Private_view @@ -9,13 +9,14 @@ let path = path_id, Vdom.Attr.id path_id ;; -open Bonsai_web_ui_form2 -open Bonsai_web_ui_form2.Elements +open Form_manual +open Elements_manual module type Model = Model module type Stringable_model = Stringable_model module Selectable_style = Selectable_style +module Form = Form_automatic module Conversion = struct (* [with_extra_attr] adds an id attr to the [extra_attr] argument of a [Form2.Elements] @@ -991,7 +992,7 @@ module Query_box = struct end module Optional = struct - open Optional + open Typed_elements_manual.Optional let dropdown (type a) ?some_label ?none_label (form : a Form.t Computation.t) = let%sub form = dropdown ?some_label ?none_label form in diff --git a/web_ui/form/src/elements.mli b/web_ui/form/src/elements_automatic.mli similarity index 99% rename from web_ui/form/src/elements.mli rename to web_ui/form/src/elements_automatic.mli index 681864b8..d500c107 100644 --- a/web_ui/form/src/elements.mli +++ b/web_ui/form/src/elements_automatic.mli @@ -1,5 +1,6 @@ open! Core open! Bonsai_web +module Form := Form_automatic module type Model = sig type t [@@deriving sexp_of] @@ -15,7 +16,7 @@ end (** For checkboxes and radio buttons, you can choose between having their visual display be the default native rendering, or if you want them to look like actual buttons, then the input element is hidden, which gives you much better control over the styling. *) -module Selectable_style = Bonsai_web_ui_form2.Elements.Selectable_style +module Selectable_style = Elements_manual.Selectable_style module Non_interactive : sig (** This form always contains the specified value. Setting the form has no diff --git a/web_ui/form2/src/elements.ml b/web_ui/form/src/elements_manual.ml similarity index 99% rename from web_ui/form2/src/elements.ml rename to web_ui/form/src/elements_manual.ml index e3768b94..4f3e47d6 100644 --- a/web_ui/form2/src/elements.ml +++ b/web_ui/form/src/elements_manual.ml @@ -3,6 +3,7 @@ open! Bonsai_web open Bonsai.Let_syntax module Extendy = Bonsai_web_ui_extendy module Selectable_style = Vdom_input_widgets.Selectable_style +module Form = Form_manual module type Model = sig type t [@@deriving sexp_of] diff --git a/web_ui/form2/src/elements.mli b/web_ui/form/src/elements_manual.mli similarity index 99% rename from web_ui/form2/src/elements.mli rename to web_ui/form/src/elements_manual.mli index 554fe1de..09c67ea9 100644 --- a/web_ui/form2/src/elements.mli +++ b/web_ui/form/src/elements_manual.mli @@ -1,5 +1,6 @@ open! Core open! Bonsai_web +module Form = Form_manual module type Model = sig type t [@@deriving sexp_of] diff --git a/web_ui/form/src/form.ml b/web_ui/form/src/form_automatic.ml similarity index 94% rename from web_ui/form/src/form.ml rename to web_ui/form/src/form_automatic.ml index fdf4a2e1..8ff8b4c3 100644 --- a/web_ui/form/src/form.ml +++ b/web_ui/form/src/form_automatic.ml @@ -1,10 +1,11 @@ open! Core open (Bonsai_web : module type of Bonsai_web with module View := Bonsai_web.View) open Bonsai.Let_syntax -open Bonsai_web_ui_form2 +open Form_manual +module View = View_automatic module T = struct - type nonrec 'a t = ('a, View.t) Bonsai_web_ui_form2.t + type nonrec 'a t = ('a, View.t) Form_manual.t let value t = t.value let view t = t.view @@ -42,8 +43,6 @@ module Submit = struct ;; end -module View = View - let view_as_vdom ?theme ?on_submit ?editable t = let on_submit = Option.map @@ -151,7 +150,7 @@ module Expert = struct let create = create end -include Bonsai_web_ui_form2 +include Form_manual module Dynamic = struct include Dynamic @@ -227,6 +226,20 @@ end include T +let to_form2 form = map_view form ~f:(fun old_view -> View.to_vdom old_view) + +let to_form2' form = + let%arr form = form in + to_form2 form +;; + +let of_form2 form2 = + let%sub path = Bonsai.path_id in + let%arr form2 = form2 + and path = path in + map_view form2 ~f:(fun old_view -> View.of_vdom old_view ~unique_key:path) +;; + let return ?sexp_of_t value = map_view (return ?sexp_of_t value) ~f:(fun () -> View.empty) let return_settable ?sexp_of_model ~equal value = diff --git a/web_ui/form/src/form.mli b/web_ui/form/src/form_automatic.mli similarity index 94% rename from web_ui/form/src/form.mli rename to web_ui/form/src/form_automatic.mli index a8fc4964..cead72b3 100644 --- a/web_ui/form/src/form.mli +++ b/web_ui/form/src/form_automatic.mli @@ -1,9 +1,21 @@ open! Core -module View = View +module View = View_automatic module Form_view := View open Bonsai_web -type 'a t = ('a, Form_view.t) Bonsai_web_ui_form2.t +type 'a t = ('a, Form_view.t) Form_manual.t + +(** [to_form2] turns the current [t] into a [Form2.t] by calling [Form.View.to_vdom] on + the [view]. *) +val to_form2 : 'a t -> ('a, Vdom.Node.t) Form_manual.t + +(** [to_form2'] is identical to [to_form2], but it handles the [let%arr] for you. *) +val to_form2' : 'a t Value.t -> ('a, Vdom.Node.t) Form_manual.t Computation.t + +(** [of_form2] creates a [t] from a [Form2.t]. Unlike [to_form2], this function needs to + be stateful because creating a [t] requires a [unique_key] which is generated with + [Bonsai.path_id]. *) +val of_form2 : ('a, Vdom.Node.t) Form_manual.t Value.t -> 'a t Computation.t (** [return] produces a bonsai form that will always produce the same value. [set] and [normalize] will do nothing to the form provided by this. [sexp_of_t] can be provided diff --git a/web_ui/form2/src/form.ml b/web_ui/form/src/form_manual.ml similarity index 100% rename from web_ui/form2/src/form.ml rename to web_ui/form/src/form_manual.ml diff --git a/web_ui/form2/src/form.mli b/web_ui/form/src/form_manual.mli similarity index 100% rename from web_ui/form2/src/form.mli rename to web_ui/form/src/form_manual.mli diff --git a/web_ui/form/src/typed.ml b/web_ui/form/src/typed_automatic.ml similarity index 97% rename from web_ui/form/src/typed.ml rename to web_ui/form/src/typed_automatic.ml index 753a7cdf..983d8b45 100644 --- a/web_ui/form/src/typed.ml +++ b/web_ui/form/src/typed_automatic.ml @@ -1,9 +1,9 @@ open! Core -module Form_view = View +module Form_view = View_automatic open! Bonsai_web open! Bonsai.Let_syntax -module Form2 = Bonsai_web_ui_form2 -open Form2.Typed +module Form = Form_automatic +open Typed_manual module Record = struct module type S = sig @@ -50,7 +50,7 @@ module Record = struct ;; type form_of_field_fn = - { f : 'a. 'a Typed_field.t -> ('a, field_view) Form2.t Value.t } + { f : 'a. 'a Typed_field.t -> ('a, field_view) Form_manual.t Value.t } let finalize_view { f } = let all_fields = @@ -93,14 +93,14 @@ module Record = struct attach_fieldname_to_error label form in let%arr form = form in - Form2.map_view form ~f:Form.View.to_vdom + Form_manual.map_view form ~f:Form.View.to_vdom ;; end) in let%sub path = Bonsai.path_id in let%arr table = table and path = path in - Form2.map_view table ~f:(Form.View.of_vdom ~unique_key:path) + Form_manual.map_view table ~f:(Form.View.of_vdom ~unique_key:path) ;; end @@ -240,7 +240,7 @@ module Variant = struct | None -> Error (Error.of_string "a value is required") in let set value = set_picker_value (Some value) in - ({ value; set; view } : (M.t, Vdom.Node.t) Form2.t) + ({ value; set; view } : (M.t, Vdom.Node.t) Form_manual.t) ;; let make diff --git a/web_ui/form/src/typed.mli b/web_ui/form/src/typed_automatic.mli similarity index 99% rename from web_ui/form/src/typed.mli rename to web_ui/form/src/typed_automatic.mli index 94213709..6fac6c25 100644 --- a/web_ui/form/src/typed.mli +++ b/web_ui/form/src/typed_automatic.mli @@ -1,5 +1,6 @@ open! Core open! Bonsai_web +module Form := Form_automatic (** The functions in this module can be hard to understand Please look at the examples in lib/bonsai/examples/forms/typed.ml *) diff --git a/web_ui/form2/src/typed_elements.ml b/web_ui/form/src/typed_elements_manual.ml similarity index 95% rename from web_ui/form2/src/typed_elements.ml rename to web_ui/form/src/typed_elements_manual.ml index a439eab8..4f026816 100644 --- a/web_ui/form2/src/typed_elements.ml +++ b/web_ui/form/src/typed_elements_manual.ml @@ -1,6 +1,8 @@ open! Core open! Bonsai_web open! Bonsai.Let_syntax +module Form = Form_manual +module Elements = Elements_manual module Optional = struct let dropdown @@ -28,7 +30,7 @@ module Optional = struct end in let%map.Computation form = - Typed.Variant.make + Typed_manual.Variant.make (module struct module Typed_variant = M.Typed_variant diff --git a/web_ui/form2/src/typed_elements.mli b/web_ui/form/src/typed_elements_manual.mli similarity index 95% rename from web_ui/form2/src/typed_elements.mli rename to web_ui/form/src/typed_elements_manual.mli index 22c6be09..4c6003fe 100644 --- a/web_ui/form2/src/typed_elements.mli +++ b/web_ui/form/src/typed_elements_manual.mli @@ -1,5 +1,6 @@ open! Core open! Bonsai_web +module Form := Form_manual module Optional : sig (* [dropdown] takes an existing form, and adds a dropdown with [some_label] and diff --git a/web_ui/form2/src/typed.ml b/web_ui/form/src/typed_manual.ml similarity index 99% rename from web_ui/form2/src/typed.ml rename to web_ui/form/src/typed_manual.ml index 553b3aa9..d14c524d 100644 --- a/web_ui/form2/src/typed.ml +++ b/web_ui/form/src/typed_manual.ml @@ -1,6 +1,8 @@ open! Core open! Bonsai_web open! Bonsai.Let_syntax +module Form = Form_manual +module Elements = Elements_manual let sexp_to_pretty_string sexp_of_t t = t diff --git a/web_ui/form2/src/typed.mli b/web_ui/form/src/typed_manual.mli similarity index 99% rename from web_ui/form2/src/typed.mli rename to web_ui/form/src/typed_manual.mli index ecfc85bc..12f5c3ba 100644 --- a/web_ui/form2/src/typed.mli +++ b/web_ui/form/src/typed_manual.mli @@ -1,5 +1,6 @@ open! Core open! Bonsai_web +module Form := Form_manual (** The functions in this module can be hard to understand Please look at the examples in lib/bonsai/examples/forms/typed.ml *) diff --git a/web_ui/form/src/view.ml b/web_ui/form/src/view_automatic.ml similarity index 100% rename from web_ui/form/src/view.ml rename to web_ui/form/src/view_automatic.ml diff --git a/web_ui/form/src/view.mli b/web_ui/form/src/view_automatic.mli similarity index 100% rename from web_ui/form/src/view.mli rename to web_ui/form/src/view_automatic.mli diff --git a/web_ui/form/test/bonsai_web_ui_form_test.ml b/web_ui/form/test/bonsai_web_ui_form_automatic_test.ml similarity index 99% rename from web_ui/form/test/bonsai_web_ui_form_test.ml rename to web_ui/form/test/bonsai_web_ui_form_automatic_test.ml index 193395be..050e22c9 100644 --- a/web_ui/form/test/bonsai_web_ui_form_test.ml +++ b/web_ui/form/test/bonsai_web_ui_form_automatic_test.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open! Bonsai_web_test open! Bonsai.Let_syntax -module Form = Bonsai_web_ui_form +module Form = Bonsai_web_ui_form.With_automatic_view let get_vdom form = match Form.View.to_vdom_plain (Form.view form) with diff --git a/web_ui/form/test/bonsai_web_ui_form_automatic_test.mli b/web_ui/form/test/bonsai_web_ui_form_automatic_test.mli new file mode 100644 index 00000000..537e8f54 --- /dev/null +++ b/web_ui/form/test/bonsai_web_ui_form_automatic_test.mli @@ -0,0 +1 @@ +(*_ This file intentionally left blank *) diff --git a/web_ui/form2/test/bonsai_web_ui_form2_test.ml b/web_ui/form/test/bonsai_web_ui_form_manual_test.ml similarity index 99% rename from web_ui/form2/test/bonsai_web_ui_form2_test.ml rename to web_ui/form/test/bonsai_web_ui_form_manual_test.ml index c171424e..1e4b9eb3 100644 --- a/web_ui/form2/test/bonsai_web_ui_form2_test.ml +++ b/web_ui/form/test/bonsai_web_ui_form_manual_test.ml @@ -2,7 +2,7 @@ open! Core open! Bonsai_web open! Bonsai_web_test.Experimental open! Bonsai.Let_syntax -module Form = Bonsai_web_ui_form2 +module Form = Bonsai_web_ui_form.With_manual_view let viewless_form_result_spec (type a) sexp_of_a : ((a, unit) Form.t, a) Result_spec.t = (module struct diff --git a/web_ui/form/test/bonsai_web_ui_form_manual_test.mli b/web_ui/form/test/bonsai_web_ui_form_manual_test.mli new file mode 100644 index 00000000..537e8f54 --- /dev/null +++ b/web_ui/form/test/bonsai_web_ui_form_manual_test.mli @@ -0,0 +1 @@ +(*_ This file intentionally left blank *) diff --git a/web_ui/form/test/dune b/web_ui/form/test/dune index 8ac70eff..937ac65a 100644 --- a/web_ui/form/test/dune +++ b/web_ui/form/test/dune @@ -1,4 +1,7 @@ -(library (name bonsai_web_ui_form_test) - (libraries bonsai_web_ui_form bonsai_web bonsai_web_test core - patdiff.expect_test_patdiff) - (preprocess (pps ppx_jane ppx_typed_fields ppx_bonsai))) \ No newline at end of file +(library + (name bonsai_web_ui_form_test) + (public_name bonsai.web_ui_form_test) + (libraries bonsai_web bonsai_web_test bonsai_web_ui_form core + patdiff.expect_test_patdiff) + (preprocess + (pps ppx_jane ppx_typed_fields ppx_bonsai))) diff --git a/web_ui/form2/README.md b/web_ui/form2/README.md deleted file mode 100644 index c2fb8eb0..00000000 --- a/web_ui/form2/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# Bonsai Form 2 - -This library is still experimental. More to come. diff --git a/web_ui/form2/dune b/web_ui/form2/dune deleted file mode 100644 index e69de29b..00000000 diff --git a/web_ui/form2/src/bonsai_web_ui_form2.ml b/web_ui/form2/src/bonsai_web_ui_form2.ml deleted file mode 100644 index 77aa8c40..00000000 --- a/web_ui/form2/src/bonsai_web_ui_form2.ml +++ /dev/null @@ -1,13 +0,0 @@ -open! Core -include Form - -module Elements = struct - include Elements - include Typed_elements -end - -module Typed = Typed - -module Private = struct - include Elements.Private -end diff --git a/web_ui/form2/src/dune b/web_ui/form2/src/dune deleted file mode 100644 index c43f5d04..00000000 --- a/web_ui/form2/src/dune +++ /dev/null @@ -1,11 +0,0 @@ -(library (name bonsai_web_ui_form2) (public_name bonsai.web_ui_form2) - (preprocess - (pps js_of_ocaml-ppx ppx_jane ppx_bonsai ppx_css ppx_typed_fields)) - (libraries bonsai bonsai_web bonsai_web_ui_common_components - bonsai_web_ui_extendy bonsai_web_ui_file bonsai_extra - bonsai_web_ui_file_from_web_file bonsai_web_ui_freeform_multiselect - bonsai_web_ui_multi_select bonsai_web_ui_query_box - bonsai_web_ui_reorderable_list bonsai_web_ui_typeahead core - fuzzy_match.match ppx_typed_fields.typed_field_map - ppx_typed_fields.typed_fields_lib ppx_typed_fields.typed_variants_lib - virtual_dom.input_widgets)) \ No newline at end of file diff --git a/web_ui/form2/test/dune b/web_ui/form2/test/dune deleted file mode 100644 index fd0778a6..00000000 --- a/web_ui/form2/test/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library (name bonsai_web_ui_form2_test) - (public_name bonsai.web_ui_form2_test) - (libraries bonsai_web_ui_form2 bonsai_web bonsai_web_test core - patdiff.expect_test_patdiff) - (preprocess (pps ppx_jane ppx_typed_fields ppx_bonsai))) \ No newline at end of file diff --git a/web_ui/freeform_multiselect/src/dune b/web_ui/freeform_multiselect/src/dune index e2a13161..a312424b 100644 --- a/web_ui/freeform_multiselect/src/dune +++ b/web_ui/freeform_multiselect/src/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_freeform_multiselect) - (public_name bonsai.web_ui_freeform_multiselect) (libraries core bonsai_web) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file +(library + (name bonsai_web_ui_freeform_multiselect) + (public_name bonsai.web_ui_freeform_multiselect) + (libraries core bonsai_web) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/freeform_multiselect/test/dune b/web_ui/freeform_multiselect/test/dune index c278abee..dd28b1bc 100644 --- a/web_ui/freeform_multiselect/test/dune +++ b/web_ui/freeform_multiselect/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_ui_components_freeform_multiselect_test) +(library + (name bonsai_ui_components_freeform_multiselect_test) (libraries bonsai_web_ui_freeform_multiselect bonsai_web bonsai_web_test - core) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + core) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/gauge/src/dune b/web_ui/gauge/src/dune index 65b221dd..f1677f67 100644 --- a/web_ui/gauge/src/dune +++ b/web_ui/gauge/src/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_gauge) (public_name bonsai.web_ui_gauge) +(library + (name bonsai_web_ui_gauge) + (public_name bonsai.web_ui_gauge) (libraries bonsai_web tailwind_colors virtual_dom.svg) - (preprocess (pps ppx_jane ppx_css))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_css))) diff --git a/web_ui/gauge/test/dune b/web_ui/gauge/test/dune index 77af7f18..5cd4b3bd 100644 --- a/web_ui/gauge/test/dune +++ b/web_ui/gauge/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_gauge_test) +(library + (name bonsai_web_ui_gauge_test) (libraries bonsai_web bonsai_web_test bonsai_web_ui_gauge) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/kado/src/dune b/web_ui/kado/src/dune index 7790eb6b..7d0e152a 100644 --- a/web_ui/kado/src/dune +++ b/web_ui/kado/src/dune @@ -1,43 +1,54 @@ -(library (name kado) (public_name bonsai.kado) +(library + (name kado) + (public_name bonsai.kado) (libraries core virtual_dom bonsai bonsai_web_ui_view) - (preprocess (pps ppx_jane ppx_css js_of_ocaml-ppx ppx_bonsai))) + (preprocess + (pps ppx_jane ppx_css js_of_ocaml-ppx ppx_bonsai))) (rule (targets tabs_style.ml tabs_style.mli tabs_style__generated.ml - tabs_style__generated.mli) + tabs_style__generated.mli) (deps tabs_style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) (rule (targets checkbox_style.ml checkbox_style.mli checkbox_style__generated.ml - checkbox_style__generated.mli) + checkbox_style__generated.mli) (deps checkbox_style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) (rule (targets input_style.ml input_style.mli input_style__generated.ml - input_style__generated.mli) + input_style__generated.mli) (deps input_style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) (rule (targets devbar_style.ml devbar_style.mli devbar_style__generated.ml - devbar_style__generated.mli) + devbar_style__generated.mli) (deps devbar_style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) -(rule (targets app.ml app.mli app__generated.ml app__generated.mli) +(rule + (targets app.ml app.mli app__generated.ml app__generated.mli) (deps app.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) (rule (targets cards_style.ml cards_style.mli cards_style__generated.ml - cards_style__generated.mli) + cards_style__generated.mli) (deps cards_style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) (rule (targets button_style.ml button_style.mli button_style__generated.ml - button_style__generated.mli) + button_style__generated.mli) (deps button_style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) \ No newline at end of file + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) diff --git a/web_ui/kado/src/kado.ml b/web_ui/kado/src/kado.ml index fff53366..0512258b 100644 --- a/web_ui/kado/src/kado.ml +++ b/web_ui/kado/src/kado.ml @@ -39,6 +39,7 @@ let dark_mode_constants = { body_row_even = table_even ; body_row_odd = primary ; body_row_focused = c ~fg:primary.foreground ~bg:(`Hex "#4b3038") + ; body_cell_focused = c ~fg:primary.foreground ~bg:(`Hex "#4b3038") ; header_row = header ; header_header_border = extreme_primary_border ; header_body_border = extreme_primary_border @@ -76,6 +77,7 @@ let light_mode_constants = { body_row_even = table_even ; body_row_odd = primary ; body_row_focused = c ~fg:primary.foreground ~bg:(`Hex "#7D648A") + ; body_cell_focused = c ~fg:primary.foreground ~bg:(`Hex "#7D648A") ; header_row = header ; header_header_border ; header_body_border = header_header_border @@ -113,10 +115,11 @@ let v1 ~constants ~codemirror_theme ~is_dark ~name ~version_name ~set_min_height method! constants = constants method! app_attr = - app_attr - ~is_dark - ~color:self#constants.primary.background - ~set_min_height_to_100vh + lazy + (app_attr + ~is_dark + ~color:self#constants.primary.background + ~set_min_height_to_100vh) method! devbar = Devbar.make self#constants ~is_dark method! tabs = Tabs.make diff --git a/web_ui/multi_select/focus_ring/src/dune b/web_ui/multi_select/focus_ring/src/dune index 9d39960c..3aa25d58 100644 --- a/web_ui/multi_select/focus_ring/src/dune +++ b/web_ui/multi_select/focus_ring/src/dune @@ -1,2 +1,6 @@ -(library (name focus_ring) (public_name bonsai.focus_ring) (libraries core) - (preprocess (pps ppx_jane))) \ No newline at end of file +(library + (name focus_ring) + (public_name bonsai.focus_ring) + (libraries core) + (preprocess + (pps ppx_jane))) diff --git a/web_ui/multi_select/src/dune b/web_ui/multi_select/src/dune index 3c0f27d2..86cd3a5f 100644 --- a/web_ui/multi_select/src/dune +++ b/web_ui/multi_select/src/dune @@ -1,6 +1,8 @@ -(library (name bonsai_web_ui_multi_select) +(library + (name bonsai_web_ui_multi_select) (public_name bonsai.web_ui_multi_select) (libraries textutils.ascii_table_kernel bonsai bonsai_web core focus_ring - virtual_dom.keyboard virtual_dom.layout virtual_dom.input_widgets - virtual_dom) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai))) \ No newline at end of file + virtual_dom.keyboard virtual_dom.layout virtual_dom.input_widgets + virtual_dom) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai))) diff --git a/web_ui/multi_select/test/dune b/web_ui/multi_select/test/dune index 91594bda..02491bf4 100644 --- a/web_ui/multi_select/test/dune +++ b/web_ui/multi_select/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_multi_select_test) +(library + (name bonsai_web_ui_multi_select_test) (libraries bonsai_web_test bonsai_web_ui_multi_select core - virtual_dom.vdom_test_helpers) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + virtual_dom.vdom_test_helpers) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/nav_link/src/dune b/web_ui/nav_link/src/dune index ecf02d19..bfba4203 100644 --- a/web_ui/nav_link/src/dune +++ b/web_ui/nav_link/src/dune @@ -1,2 +1,6 @@ -(library (name bonsai_web_ui_nav_link) (public_name bonsai.web_ui_nav_link) - (preprocess (pps js_of_ocaml-ppx)) (libraries bonsai_web core)) \ No newline at end of file +(library + (name bonsai_web_ui_nav_link) + (public_name bonsai.web_ui_nav_link) + (preprocess + (pps js_of_ocaml-ppx)) + (libraries bonsai_web core)) diff --git a/web_ui/nav_link/test/dune b/web_ui/nav_link/test/dune index 75d19656..3150908b 100644 --- a/web_ui/nav_link/test/dune +++ b/web_ui/nav_link/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_nav_link_test) +(library + (name bonsai_web_ui_nav_link_test) (libraries bonsai_web_ui_nav_link bonsai_web_test async_js.async_test core - expect_test_helpers_core.expect_test_helpers_base) - (preprocess (pps ppx_jane ppx_quick_test))) \ No newline at end of file + expect_test_helpers_core.expect_test_helpers_base) + (preprocess + (pps ppx_jane ppx_quick_test))) diff --git a/web_ui/not_connected_warning_box/src/dune b/web_ui/not_connected_warning_box/src/dune index 7f68f736..bea58f15 100644 --- a/web_ui/not_connected_warning_box/src/dune +++ b/web_ui/not_connected_warning_box/src/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_not_connected_warning_box) +(library + (name bonsai_web_ui_not_connected_warning_box) (libraries core bonsai virtual_dom) - (preprocess (pps ppx_css js_of_ocaml-ppx ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_css js_of_ocaml-ppx ppx_jane ppx_bonsai))) diff --git a/web_ui/not_connected_warning_box/test/dune b/web_ui/not_connected_warning_box/test/dune index e45fd962..d8ea6544 100644 --- a/web_ui/not_connected_warning_box/test/dune +++ b/web_ui/not_connected_warning_box/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_not_connected_warning_box_test) +(library + (name bonsai_web_ui_not_connected_warning_box_test) (libraries bonsai_web_ui_not_connected_warning_box bonsai_web_test core) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/web_ui/notifications/src/dune b/web_ui/notifications/src/dune index 89a0d016..6759de23 100644 --- a/web_ui/notifications/src/dune +++ b/web_ui/notifications/src/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_notifications) +(library + (name bonsai_web_ui_notifications) (libraries bonsai bonsai_extra bonsai_web core) - (preprocess (pps ppx_jane ppx_css ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_css ppx_bonsai))) diff --git a/web_ui/notifications/test/dune b/web_ui/notifications/test/dune index 3bf3f870..c7bf48c5 100644 --- a/web_ui/notifications/test/dune +++ b/web_ui/notifications/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_notifications_test) +(library + (name bonsai_web_ui_notifications_test) (libraries bonsai bonsai_web bonsai_web_ui_notifications bonsai_web_test - core) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + core) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/partial_render_table/bench/bin/dune b/web_ui/partial_render_table/bench/bin/dune index c959fcfb..c0d39160 100644 --- a/web_ui/partial_render_table/bench/bin/dune +++ b/web_ui/partial_render_table/bench/bin/dune @@ -1,5 +1,8 @@ -(executables (names main) +(executables + (modes byte exe) + (names main) (libraries bonsai_bench bonsai_web_ui_partial_render_table - bonsai_web_ui_partial_render_table_test - bonsai_web_ui_partial_render_table_bench) - (preprocess (pps ppx_jane ppx_bench ppx_bonsai))) \ No newline at end of file + bonsai_web_ui_partial_render_table_test + bonsai_web_ui_partial_render_table_bench) + (preprocess + (pps ppx_jane ppx_bench ppx_bonsai))) diff --git a/web_ui/partial_render_table/bench/bin/main.ml b/web_ui/partial_render_table/bench/bin/main.ml index e275b28a..d678259b 100644 --- a/web_ui/partial_render_table/bench/bin/main.ml +++ b/web_ui/partial_render_table/bench/bin/main.ml @@ -8,26 +8,53 @@ open! Bonsai_web_ui_partial_render_table_test.Shared_with_bench open! Incr_map_collate module Config = struct - type 'col_id t = + type ('data, 'column_id) t = { name : string - ; columns : ('col_id, Row.t) Expert.Columns.t + ; columns : (int, 'data, 'column_id) Expert.Columns.t + ; first_column : 'column_id } - let dynamic_cells = { name = "Dynamic_cells"; columns = Dynamic_cells.all } - let dynamic_columns = { name = "Dynamic_columns"; columns = Dynamic_columns.all } + let dynamic_cells = + { name = "Dynamic_cells" + ; columns = Dynamic_cells.all + ; first_column = Dynamic_cells.first_column + } + ;; + + let dynamic_columns = + { name = "Dynamic_columns" + ; columns = Dynamic_columns.all + ; first_column = Dynamic_columns.first_column + } + ;; let dynamic_experimental = - { name = "Dynamic_experimental"; columns = Dynamic_experimental.all } + { name = "Dynamic_experimental" + ; columns = Dynamic_experimental.all + ; first_column = Dynamic_experimental.first_column + } ;; - let create { name; columns } ~test_name = - create_bench ~columns ~test_name:[%string "%{name}: %{test_name}"] + let create + { name; columns; first_column = _ } + key_cmp + ~test_name + ~initial_vars + ~interaction + = + create_bench + key_cmp + ~columns + ~test_name:[%string "%{name}: %{test_name}"] + ~initial_vars + ~interaction ;; end -let focus_and_unfocus ~config ~size ~in_range = +let focus_and_unfocus ~(config : _ Config.t) ~size ~in_range = let starting_map = Row.init_rows size in let not_ = if in_range then "" else "not " in + let column = config.first_column in Config.create config (module Int) @@ -36,7 +63,7 @@ let focus_and_unfocus ~config ~size ~in_range = [%string "Focus by key (key %{not_}present) and unfocus in %{size#Int} element map"] ~interaction:(fun _ -> let index = if in_range then 1 else size + 1 in - [ Interaction.inject (Action.Focus index) + [ Interaction.inject (Action.Focus (index, column)) ; Interaction.inject Action.Unfocus ; Interaction.reset_model ] @@ -55,6 +82,21 @@ let focus_up_and_down ~config ~size = |> Interaction.many_with_stabilizations) ;; +(* It doesn't make a lot of sense to have a really large number of columns for left/right + focus benchmarks, so we just do it within the same size table as everything else which + seems more realistic. *) +let focus_left_and_right ~config ~num_rows = + let starting_map = Row.init_rows num_rows in + Config.create + config + (module Int) + ~initial_vars:(Input.create starting_map) + ~test_name:[%string "Focus left and right in a map with %{num_rows#Int} rows"] + ~interaction:(fun _ -> + [ Interaction.inject Action.Focus_left; Interaction.inject Action.Focus_right ] + |> Interaction.many_with_stabilizations) +;; + let page_up_and_down ~config ~size = let starting_map = Row.init_rows size in Config.create @@ -173,6 +215,11 @@ let benchmarks_for config = ; focus_up_and_down ~config ~size:101 ; focus_up_and_down ~config ~size:1000 ; focus_up_and_down ~config ~size:10000 + ; focus_left_and_right ~config ~num_rows:10 + ; focus_left_and_right ~config ~num_rows:100 + ; focus_left_and_right ~config ~num_rows:101 + ; focus_left_and_right ~config ~num_rows:1000 + ; focus_left_and_right ~config ~num_rows:10000 ; page_up_and_down ~config ~size:10 ; focus_up_and_down ~config ~size:10 ; focus_up_and_down ~config ~size:100 diff --git a/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.ml b/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.ml index 04ae4c00..1cffe22e 100644 --- a/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.ml +++ b/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.ml @@ -7,24 +7,26 @@ open Bonsai.Let_syntax module Table = Expert module Action = struct - type 'a t = + type ('key, 'column_id) t = | Unfocus | Focus_up | Focus_down + | Focus_left + | Focus_right | Page_up | Page_down - | Focus of 'a + | Focus of ('key * 'column_id) [@@deriving sexp, equal] end module Input = struct - type ('key, 'data, 'cmp) t = + type ('key, 'column_id, 'data, 'cmp) t = { filter : (key:'key -> data:'data -> bool) option Bonsai.Var.t ; order : ('key, 'data, 'cmp) Incr_map_collate.Compare.t Bonsai.Var.t ; rank_range : int Collate.Which_range.t Bonsai.Var.t ; key_range : 'key Collate.Which_range.t Bonsai.Var.t ; map : ('key, 'data, 'cmp) Map.t Bonsai.Var.t - ; on_change : ('key option -> unit Effect.t) Bonsai.Var.t + ; on_change : (('key * 'column_id) option -> unit Effect.t) Bonsai.Var.t } let create @@ -94,7 +96,7 @@ let component_for_bench ~theming:`Themed ?preload_rows comparator - ~focus:(Table.Focus.By_row { on_change; compute_presence = return }) + ~focus:(Table.Focus.By_cell { on_change; compute_presence = return }) ~row_height:(Value.return (`Px 1)) ~columns collate @@ -103,14 +105,16 @@ let component_for_bench let create_bench ?preload_rows comparator ~initial_vars ~columns ~interaction ~test_name = let interaction = interaction initial_vars in let component = component_for_bench comparator ?preload_rows ~columns initial_vars in - let module Focus_control = Table.Focus.By_row in + let module Focus_control = Table.Focus.By_cell in let get_inject { Table.Result.focus; _ } = function | Action.Unfocus -> Focus_control.unfocus focus | Focus_up -> Focus_control.focus_up focus | Focus_down -> Focus_control.focus_down focus + | Focus_left -> Focus_control.focus_left focus + | Focus_right -> Focus_control.focus_right focus | Page_up -> Focus_control.page_up focus | Page_down -> Focus_control.page_down focus - | Focus key -> (Focus_control.focus focus) key + | Focus (key, column_id) -> (Focus_control.focus focus) key column_id in Bonsai_bench.create ~name:test_name ~component ~get_inject interaction ;; diff --git a/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.mli b/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.mli index e435ea98..b74e06d9 100644 --- a/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.mli +++ b/web_ui/partial_render_table/bench/src/bonsai_web_ui_partial_render_table_bench.mli @@ -7,20 +7,22 @@ open! Bonsai_bench (** An [Action.t] represents the possible actions that can be performed on a partial render table. *) module Action : sig - type 'a t = + type ('key, 'column_id) t = | Unfocus | Focus_up | Focus_down + | Focus_left + | Focus_right | Page_up | Page_down - | Focus of 'a + | Focus of ('key * 'column_id) [@@deriving sexp, equal] end (** An [Input.t] packages up all of the inputs to the partial render table and provides facilities for modifying individual components. *) module Input : sig - type ('key, 'data, 'cmp) t + type ('key, 'column_id, 'data, 'cmp) t (** [create] produces a [t], with defaults for most components of the input. *) val create @@ -30,13 +32,15 @@ module Input : sig ('key, 'data, 'cmp) Incr_map_collate.Compare.t -> ?rank_range:(* default: Which_range.To 100 *) int Collate.Which_range.t -> ?key_range:(* default: Which_range.All_rows *) 'key Collate.Which_range.t - -> ?on_change:((* default: Fn.const Effect.Ignore *) 'key option -> unit Effect.t) + -> ?on_change: + ((* default: Fn.const Effect.Ignore *) ('key * 'column_id) option + -> unit Effect.t) -> ('key, 'data, 'cmp) Map.t - -> ('key, 'data, 'cmp) t + -> ('key, 'column_id, 'data, 'cmp) t (** [apply_filter] produces an interaction to change the current filter. *) val apply_filter - : ('key, 'data, 'cmp) t + : ('key, _, 'data, 'cmp) t -> (key:'key -> data:'data -> bool) -> 'action Bonsai_bench.Interaction.t @@ -46,13 +50,13 @@ module Input : sig (** [set_map] produces an interaction to change the map whose data is being rendered in the table. *) val set_map - : ('key, 'data, 'cmp) t + : ('key, _, 'data, 'cmp) t -> ('key, 'data, 'cmp) Map.t -> 'action Bonsai_bench.Interaction.t (** [set_order] produces an interaction to change the current ordering. *) val set_order - : ('key, 'data, 'cmp) t + : ('key, _, 'data, 'cmp) t -> ('key, 'data, 'cmp) Incr_map_collate.Compare.t -> 'action Bonsai_bench.Interaction.t @@ -64,8 +68,8 @@ module Input : sig (** [set_on_change] produces an interaction to change the current [on_change] function. *) val set_on_change - : ('key, _, _) t - -> ('key option -> unit Effect.t) + : ('key, 'column_id, _, _) t + -> (('key * 'column_id) option -> unit Effect.t) -> 'action Bonsai_bench.Interaction.t (** [scroll] generates an interaction with abs(start-stop) [change_input]s, which set the @@ -85,8 +89,10 @@ end val create_bench : ?preload_rows:int -> ('key, 'cmp) Bonsai.comparator - -> initial_vars:('key, 'data, 'cmp) Input.t - -> columns:('key, 'data) Expert.Columns.t - -> interaction:(('key, 'data, 'cmp) Input.t -> 'key Action.t Bonsai_bench.Interaction.t) + -> initial_vars:('key, 'column_id, 'data, 'cmp) Input.t + -> columns:('key, 'data, 'column_id) Expert.Columns.t + -> interaction: + (('key, 'column_id, 'data, 'cmp) Input.t + -> ('key, 'column_id) Action.t Bonsai_bench.Interaction.t) -> test_name:string -> Bonsai_bench.t diff --git a/web_ui/partial_render_table/bench/src/dune b/web_ui/partial_render_table/bench/src/dune index 78fc14d5..bc2dd75c 100644 --- a/web_ui/partial_render_table/bench/src/dune +++ b/web_ui/partial_render_table/bench/src/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_partial_render_table_bench) - (preprocess (pps ppx_bonsai ppx_jane)) +(library + (name bonsai_web_ui_partial_render_table_bench) + (preprocess + (pps ppx_bonsai ppx_jane)) (libraries bonsai bonsai_bench bonsai_web bonsai_web_ui_partial_render_table - core incr_map.collate)) \ No newline at end of file + core incr_map.collate)) diff --git a/web_ui/partial_render_table/protocol/dune b/web_ui/partial_render_table/protocol/dune index 745acf50..be07bde1 100644 --- a/web_ui/partial_render_table/protocol/dune +++ b/web_ui/partial_render_table/protocol/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_partial_render_table_protocol) +(library + (name bonsai_web_ui_partial_render_table_protocol) (public_name bonsai.web_ui_partial_render_table_protocol) - (libraries core incr_map.collate) (preprocess (pps ppx_jane))) \ No newline at end of file + (libraries core incr_map.collate) + (preprocess + (pps ppx_jane))) diff --git a/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.ml b/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.ml index 5e76d809..f12082ef 100644 --- a/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.ml +++ b/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.ml @@ -7,7 +7,9 @@ module Bbox = Bonsai_web_ui_element_size_hooks.Visibility_tracker.Bbox module Order = Order module Sortable = Sortable module Focus_by_row = Focus.By_row +module Focus_by_cell = Focus.By_cell module Scroll = Bonsai_web_ui_scroll_utilities +module Indexed_column_id = Column.Indexed_column_id module For_testing = struct module Table_body = Table_body.For_testing @@ -24,17 +26,20 @@ module Expert = struct end module Result = struct - type 'focus t = + type ('focus, 'column_id) t = { view : Vdom.Node.t ; range : int * int ; for_testing : For_testing.t Lazy.t ; focus : 'focus + ; set_column_width : column_id:'column_id -> [ `Px_float of float ] -> unit Effect.t } [@@deriving fields ~getters] end module Columns = struct - type ('key, 'data) t = ('key, 'data) Column_intf.t + module Indexed_column_id = Indexed_column_id + + type ('key, 'data, 'column) t = ('key, 'data, 'column) Column_intf.t module Dynamic_cells = Column.Dynamic_cells module Dynamic_columns = Column.Dynamic_columns @@ -52,11 +57,12 @@ module Expert = struct ;; let implementation - (type key presence data cmp) + (type key presence data cmp column column_cmp key presence data cmp) ~theming ~preload_rows - (key : (key, cmp) Bonsai.comparator) - ~(focus : (_, presence, key) Focus.Kind.t) + (key_comparator : (key, cmp) Bonsai.comparator) + (column_id_comparator : (column, column_cmp) Bonsai.comparator) + ~(focus : (_, presence, key, column) Focus.Kind.t) ~row_height ~headers ~assoc @@ -82,7 +88,6 @@ module Expert = struct let%arr private_body_classname = private_body_classname in "." ^ private_body_classname in - let%sub leaves = Bonsai.pure Header_tree.leaves headers in let%sub header_client_rect, set_header_client_rect = Bonsai.state_opt () in let%sub header_client_rect = return (Value.cutoff ~equal:[%equal: Bbox.t option] header_client_rect) @@ -103,8 +108,9 @@ module Expert = struct let%sub table_body_client_rect = return (Value.cutoff ~equal:[%equal: Bbox.t option] table_body_client_rect) in + let module Column_cmp = (val column_id_comparator) in let module Column_widths_model = struct - type t = Column_size.t Int.Map.t [@@deriving sexp, equal] + type t = Column_size.t Map.M(Column_cmp).t [@@deriving sexp_of, equal] end in let%sub column_widths, set_column_width = @@ -112,30 +118,29 @@ module Expert = struct () ~sexp_of_model:[%sexp_of: Column_widths_model.t] ~equal:[%equal: Column_widths_model.t] - ~sexp_of_action:[%sexp_of: int * [ `Px_float of float ]] - ~default_model:Int.Map.empty + ~default_model:(Map.empty (module Column_cmp)) ~apply_action: (fun - (_ : _ Bonsai.Apply_action_context.t) model (idx, `Px_float width) -> - (* While checking for float equality is usually not a good idea, + (_ : _ Bonsai.Apply_action_context.t) model (column_id, `Px_float width) -> + (* While checking for float equality is usually not a good idea, this is meant to handle the specific case when a column has "display:none", in which case the width will be exactly 0.0, so there is no concern about float rounding errors. *) - Map.update model idx ~f:(fun prev -> - if Float.equal width 0.0 - then ( - match prev with - | None -> Hidden { prev_width_px = None } - | Some (Visible { width_px }) -> Hidden { prev_width_px = Some width_px } - | Some (Hidden _ as prev) -> prev) - else Visible { width_px = width })) + Map.update model column_id ~f:(fun prev -> + if Float.equal width 0.0 + then ( + match prev with + | None -> Hidden { prev_width_px = None } + | Some (Visible { width_px }) -> Hidden { prev_width_px = Some width_px } + | Some (Hidden _ as prev) -> prev) + else Visible { width_px = width })) in let%sub column_widths = return (Value.cutoff ~equal:[%equal: Column_widths_model.t] column_widths) in let%sub set_column_width = let%arr set_column_width = set_column_width in - fun ~index width -> set_column_width (index, width) + fun ~column_id width -> set_column_width (column_id, width) in let row_count = collated >>| Collated.num_filtered_rows in let%sub header_height_px = @@ -176,13 +181,13 @@ module Expert = struct let%sub midpoint_of_container = let%arr table_body_visible_rect = table_body_visible_rect in match table_body_visible_rect with - | None -> 0.0 - | Some rect -> (rect.max_x +. rect.min_x) /. 2.0 + | None -> 0.0, 0.0 + | Some rect -> (rect.max_x +. rect.min_x) /. 2.0, (rect.max_y -. rect.min_y) /. 2.0 in let%sub scroll_to_index = let%arr header_height_px = header_height_px and range_without_preload = range_without_preload - and midpoint_of_container = midpoint_of_container + and midpoint_of_container_x, _ = midpoint_of_container and table_body_selector = table_body_selector and (`Px row_height_px) = row_height in fun index -> @@ -223,7 +228,7 @@ module Expert = struct [%string "scrolling to index %{index#Int} at %{y_px#Float}0px"]) in Scroll.to_position_inside_element - ~x_px:midpoint_of_container + ~x_px:midpoint_of_container_x ~y_px ~selector:table_body_selector `Minimal @@ -231,10 +236,69 @@ module Expert = struct | None -> print_in_tests (fun () -> "skipping scroll because target already in view") in + let%sub leaves = Bonsai.pure Header_tree.leaves headers in + let%sub scroll_to_column = + let width (column : Column_size.t) = + match column with + | Visible { width_px } -> width_px + | Hidden { prev_width_px = _ } -> 0.0 + in + let%sub get_offset_and_width = + let%arr column_widths = column_widths + and leaves = leaves in + fun column_id -> + List.fold_until + ~init:0.0 + leaves + ~finish:(fun _ -> None) + ~f:(fun offset leaf -> + let column_width = + Option.map (Map.find column_widths leaf.column_id) ~f:width + |> Option.value ~default:0.0 + in + match + Comparable.equal Column_cmp.comparator.compare leaf.column_id column_id + with + | true -> Stop (Some (offset, column_width)) + | false -> Continue (offset +. column_width)) + in + let%arr get_offset_and_width = get_offset_and_width + and table_body_visible_rect = table_body_visible_rect + and table_body_selector = table_body_selector + and _, midpoint_of_container_y = midpoint_of_container in + fun column_id -> + match table_body_visible_rect with + | None -> Effect.Ignore + | Some rect -> + let offset_and_width = get_offset_and_width column_id in + (match offset_and_width with + | None -> Effect.Ignore + | Some (offset, width) -> + let scroll_me offset = + Scroll.to_position_inside_element + ~x_px:offset + ~y_px:midpoint_of_container_y + ~selector:table_body_selector + `Minimal + |> Effect.ignore_m + in + let%bind.Effect () = + print_in_tests (fun () -> + let column_id = + [%sexp (column_id : Column_cmp.t)] |> Sexp.to_string_hum + in + [%string "scrolling column with id %{column_id} into view, if necessary"]) + in + if Float.( < ) offset rect.min_x + then scroll_me offset + else if Float.( > ) (offset +. width) rect.max_x + then scroll_me (offset +. width) + else Effect.Ignore) + in let%sub keep_top_row_in_position = let%arr range_without_preload = range_without_preload and header_height_px = header_height_px - and midpoint_of_container = midpoint_of_container + and midpoint_of_container_x, _ = midpoint_of_container and table_body_selector = table_body_selector and table_body_visible_rect = table_body_visible_rect in fun (`Px old_row_height_px) (`Px new_row_height_px) -> @@ -275,7 +339,7 @@ module Expert = struct [%string "scrolling position %{y_px#Float}px into view"]) in Scroll.to_position_inside_element - ~x_px:midpoint_of_container + ~x_px:midpoint_of_container_x ~y_px ~selector:table_body_selector `Minimal @@ -323,23 +387,27 @@ module Expert = struct let%sub { focus; visually_focused } = Focus.component focus_kind - key + key_comparator + column_id_comparator + ~leaves ~collated ~range:range_without_preload ~scroll_to_index + ~scroll_to_column in - let on_row_click = Focus.get_on_row_click focus_kind focus in + let on_cell_click = Focus.get_on_cell_click focus_kind focus in let%sub body, body_for_testing = Table_body.component ~themed_attrs - ~comparator:key + ~key_comparator + ~column_id_comparator ~row_height - ~leaves ~headers + ~leaves ~assoc ~column_widths ~visually_focused - ~on_row_click + ~on_cell_click collated input_map in @@ -395,29 +463,39 @@ module Expert = struct let%arr view = view and range = range and body_for_testing = body_for_testing - and focus = focus in + and focus = focus + and set_column_width = set_column_width in let for_testing = let%map.Lazy body = body_for_testing in { For_testing.body } in - { Result.view; range; for_testing; focus } + { Result.view; range; for_testing; focus; set_column_width } ;; let component - (type key focus presence data cmp) + (type key focus presence data cmp column_id column_id_cmp) ~theming ?(preload_rows = default_preload) - (key : (key, cmp) Bonsai.comparator) - ~(focus : (focus, presence, key) Focus.Kind.t) + (key_comparator : (key, cmp) Bonsai.comparator) + ~(focus : (focus, presence, key, column_id) Focus.Kind.t) ~row_height - ~(columns : (key, data) Column_intf.t) + ~(columns : (key, data, column_id) Column_intf.t) (collated : (key, data) Collated.t Value.t) = - let (T { value; vtable }) = columns in + let (T { value; vtable; column_id }) = columns in let module T = (val vtable) in let%sub headers = T.headers value in - let assoc = T.instantiate_cells value key in - implementation ~preload_rows ~theming key ~focus ~row_height ~headers ~assoc collated + let assoc cells = T.instantiate_cells value key_comparator cells in + implementation + ~preload_rows + ~theming + key_comparator + column_id + ~focus + ~row_height + ~headers + ~assoc + collated ;; let collate @@ -450,11 +528,14 @@ module Basic = struct module Focus = struct include Focus - type ('a, 'p, 'k) t = - | None : (unit, unit, 'k) t + type ('a, 'p, 'k, 'c) t = + | None : (unit, unit, 'k, 'c) t | By_row : { on_change : ('k option -> unit Effect.t) Value.t } - -> ('k By_row.optional, 'k option, 'k) t + -> ('k Focus_by_row.optional, 'k option, 'k, 'c) t + | By_cell : + { on_change : (('k * 'c) option -> unit Effect.t) Value.t } + -> (('k, 'c) By_cell.optional, ('k * 'c) option, 'k, 'c) t end module Result = struct @@ -464,14 +545,16 @@ module Basic = struct ; focus : 'focus ; num_filtered_rows : int ; sortable_state : 'column_id Sortable.t + ; set_column_width : column_id:'column_id -> [ `Px_float of float ] -> unit Effect.t } [@@deriving fields ~getters] end module Columns = struct + module Indexed_column_id = Indexed_column_id + type ('key, 'data, 'column_id) t = ('key, 'data, 'column_id) Column_intf.with_sorter - module Indexed_col_id = Column.Indexed_col_id module Dynamic_cells = Column.Dynamic_cells_with_sorter module Dynamic_columns = Column.Dynamic_columns_with_sorter module Dynamic_experimental = Column.Dynamic_experimental_with_sorter @@ -492,7 +575,7 @@ module Basic = struct -> ?default_sort:(key * data) compare Value.t -> ?preload_rows:int -> (key, cmp) Bonsai.comparator - -> focus:(focus, presence, key) Focus.t + -> focus:(focus, presence, key, column_id) Focus.t -> row_height:[ `Px of int ] Value.t -> columns:(key, data, column_id) Column_intf.with_sorter -> (key, data, cmp) Map.t Value.t @@ -503,13 +586,13 @@ module Basic = struct ?override_sort ?default_sort ?(preload_rows = default_preload) - comparator + key_comparator ~focus ~row_height ~columns map -> - let module Cmp = (val comparator) in - let focus : (focus, presence, key) Expert.Focus.Kind.t = + let module Key_cmp = (val key_comparator) in + let focus : (focus, presence, key, column_id) Expert.Focus.Kind.t = match focus with | None -> None | By_row { on_change } -> @@ -521,21 +604,31 @@ module Basic = struct | Some focus -> if Map.mem map focus then Some focus else None in By_row { on_change; compute_presence } + | By_cell { on_change } -> + let compute_presence focus = + let%arr focus = focus + and map = map in + match focus with + | None -> None + | Some ((focused_key, _) as focus) -> + if Map.mem map focused_key then Some focus else None + in + By_cell { on_change; compute_presence } in - let filter = Value.of_opt filter in + let filter = Value.transpose_opt filter in let%sub rank_range, set_rank_range = Bonsai.state (Collate.Which_range.To 0) ~sexp_of_model:[%sexp_of: Rank_range.t] ~equal:[%equal: Rank_range.t] in - let (Y { value; vtable; col_id }) = columns in - let module Col_id = (val col_id) in + let (Y { value; vtable; column_id }) = columns in + let module Col_id = (val column_id) in let%sub sortable_state = Sortable.state ~equal:(Comparable.equal Col_id.comparator.compare) () in let module Column = (val vtable) in - let assoc = Column.instantiate_cells value comparator in + let assoc cells = Column.instantiate_cells value key_comparator cells in let default_sort = match default_sort with | None -> Value.return None @@ -555,7 +648,7 @@ module Basic = struct and override_sort = override_sort in let override_sort = Option.map override_sort ~f:(fun override_sort -> - override_sort Cmp.comparator.compare) + override_sort Key_cmp.comparator.compare) in Order.to_compare (Sortable.order sortable_state) @@ -586,7 +679,8 @@ module Basic = struct Expert.implementation ~preload_rows ~theming - comparator + key_comparator + column_id ~focus ~row_height ~headers @@ -602,9 +696,15 @@ module Basic = struct (let%map set_rank_range = set_rank_range in fun (low, high) -> set_rank_range (Collate.Which_range.Between (low, high))) in - let%arr { view; for_testing; range = _; focus } = result + let%arr { view; for_testing; range = _; focus; set_column_width } = result and num_filtered_rows = num_filtered_rows and sortable_state = sortable_state in - { Result.view; for_testing; focus; num_filtered_rows; sortable_state } + { Result.view + ; for_testing + ; focus + ; num_filtered_rows + ; sortable_state + ; set_column_width + } ;; end diff --git a/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.mli b/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.mli index ead180b3..51a62fda 100644 --- a/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.mli +++ b/web_ui/partial_render_table/src/bonsai_web_ui_partial_render_table.mli @@ -11,16 +11,28 @@ module For_testing : sig end module Focus_by_row = Focus.By_row +module Focus_by_cell = Focus.By_cell + +module Indexed_column_id : sig + type t [@@deriving equal, sexp] + + val of_int : int -> t + val to_int : t -> int +end module Basic : sig module Focus : sig module By_row = Focus.By_row + module By_cell = Focus.By_cell - type ('a, 'p, 'k) t = - | None : (unit, unit, 'k) t + type ('a, 'p, 'k, 'c) t = + | None : (unit, unit, 'k, 'c) t | By_row : { on_change : ('k option -> unit Effect.t) Value.t } - -> ('k Focus_by_row.optional, 'k option, 'k) t + -> ('k Focus_by_row.optional, 'k option, 'k, 'c) t + | By_cell : + { on_change : (('k * 'c) option -> unit Effect.t) Value.t } + -> (('k, 'c) By_cell.optional, ('k * 'c) option, 'k, 'c) t end module Result : sig @@ -30,6 +42,9 @@ module Basic : sig ; focus : 'focus ; num_filtered_rows : int ; sortable_state : 'column_id Sortable.t + ; set_column_width : column_id:'column_id -> [ `Px_float of float ] -> unit Effect.t + (** [set_column_width] cannot set the width of the column smaller than the minimum + width of the header. *) } [@@deriving fields ~getters] end @@ -39,17 +54,11 @@ module Basic : sig and they each have their own tradeoffs and capibilities. You can not mix-and-match column kinds. Read the doc comments for each of the submodules to learn more. *) + module Indexed_column_id = Indexed_column_id type ('key, 'data, 'column_id) t type ('key, 'data, 'column_id) columns := ('key, 'data, 'column_id) t - module Indexed_col_id : sig - type t [@@deriving equal] - - val of_int : int -> t - val to_int : t -> int - end - module Dynamic_experimental : sig val build : ?sorts:('column_id Value.t -> ('key, 'data) Sort_kind.t option Computation.t) @@ -103,7 +112,7 @@ module Basic : sig val expand : label:Vdom.Node.t Value.t -> ('key, 'data) t -> ('key, 'data) t (** [lift] pulls a list of columns out into a column specification for use in the primary APIs *) - val lift : ('key, 'data) t list -> ('key, 'data, Indexed_col_id.t) columns + val lift : ('key, 'data) t list -> ('key, 'data, Indexed_column_id.t) columns (** [Sortable] provides types, state, and ui helper functions to sort your table data by one or more columns. *) @@ -139,7 +148,9 @@ module Basic : sig val group : label:Vdom.Node.t -> ('key, 'data) t list -> ('key, 'data) t (** [lift] pulls a list of columns out into a column specification for use in the primary APIs *) - val lift : ('key, 'data) t list Value.t -> ('key, 'data, Indexed_col_id.t) columns + val lift + : ('key, 'data) t list Value.t + -> ('key, 'data, Indexed_column_id.t) columns (** [Sortable] provides types, state, and ui helper functions to sort your table data by one or more columns. *) @@ -167,7 +178,7 @@ module Basic : sig (** An optional function may be provided to sort the table. *) -> ?preload_rows:int -> ('key, 'cmp) Bonsai.comparator - -> focus:('focus, 'presence, 'key) Focus.t + -> focus:('focus, 'presence, 'key, 'column_id) Focus.t -> row_height:[ `Px of int ] Value.t (** [row_height] is the height of every row in the table. If the row height is specified to be 0px or less, we instead use 1px. *) @@ -187,9 +198,10 @@ module Expert : sig module Focus : sig module By_row = Focus.By_row + module By_cell = Focus.By_cell - type ('a, 'p, 'k) t = ('a, 'p, 'k) Focus.Kind.t = - | None : (unit, unit, 'k) t + type ('a, 'p, 'k, 'c) t = ('a, 'p, 'k, 'c) Focus.Kind.t = + | None : (unit, unit, 'k, 'c) t | By_row : { on_change : ('k option -> unit Effect.t) Value.t (** Row-selection is not required to be inside the viewport, so the selected row @@ -197,22 +209,32 @@ module Expert : sig forces the user to consider if a row is considered 'focused' or not. *) ; compute_presence : 'k option Value.t -> 'p Computation.t } - -> (('k, 'p) Focus_by_row.t, 'p, 'k) t + -> (('k, 'p) Focus_by_row.t, 'p, 'k, 'c) t + | By_cell : + { on_change : (('k * 'c) option -> unit Effect.t) Value.t + ; compute_presence : ('k * 'c) option Value.t -> 'presence Computation.t + } + -> (('k, 'c, 'presence) By_cell.t, 'presence, 'k, 'c) t end module Result : sig - type 'focus t = + type ('focus, 'column_id) t = { view : Vdom.Node.t ; range : int * int ; for_testing : For_testing.t Lazy.t ; focus : 'focus + ; set_column_width : column_id:'column_id -> [ `Px_float of float ] -> unit Effect.t + (** [set_column_width] cannot set the width of the column smaller than the minimum + width of the header. *) } [@@deriving fields ~getters] end module Columns : sig - type ('key, 'data) t - type ('key, 'data) columns := ('key, 'data) t + module Indexed_column_id = Indexed_column_id + + type ('key, 'data, 'column_id) t + type ('key, 'data, 'column_id) columns := ('key, 'data, 'column_id) t module Dynamic_experimental : sig val build @@ -224,7 +246,7 @@ module Expert : sig -> 'key Value.t -> 'data Value.t -> Vdom.Node.t Computation.t) - -> ('key, 'data) columns + -> ('key, 'data, 'column_id) columns (** [Sortable] provides types, state, and ui helper functions to sort your table data by one or more columns. *) @@ -243,7 +265,7 @@ module Expert : sig -> ('key, 'data) t val group : label:Vdom.Node.t Value.t -> ('key, 'data) t list -> ('key, 'data) t - val lift : ('key, 'data) t list -> ('key, 'data) columns + val lift : ('key, 'data) t list -> ('key, 'data, Indexed_column_id.t) columns (** [Sortable] provides types, state, and ui helper functions to sort your table data by one or more columns. *) @@ -262,7 +284,10 @@ module Expert : sig -> ('key, 'data) t val group : label:Vdom.Node.t -> ('key, 'data) t list -> ('key, 'data) t - val lift : ('key, 'data) t list Value.t -> ('key, 'data) columns + + val lift + : ('key, 'data) t list Value.t + -> ('key, 'data, Indexed_column_id.t) columns (** [Sortable] provides types, state, and ui helper functions to sort your table data by one or more columns. *) @@ -301,15 +326,15 @@ module Expert : sig small and scrolling might be choppy; too large and you start to lose some of the benefits of partial rendering. *) -> ('key, 'cmp) Bonsai.comparator - -> focus:('focus, 'presence, 'key) Focus.t + -> focus:('focus, 'presence, 'key, 'column_id) Focus.t -> row_height:[ `Px of int ] Value.t (** [row_height] is the height of every row in the table. If the row height is specified to be 0px or less, we instead use 1px. *) - -> columns:('key, 'row) Columns.t + -> columns:('key, 'row, 'column_id) Columns.t -> ('key, 'row) Collated.t Value.t (** The collated value is the proper input to the component. You can use [Expert.collate] to get a Collated.t value, or do the collation manually on the server by using the Incr_map_collate library manually. *) - -> 'focus Result.t Computation.t + -> ('focus, 'column_id) Result.t Computation.t end diff --git a/web_ui/partial_render_table/src/column.ml b/web_ui/partial_render_table/src/column.ml index 896a30f2..6a3f9045 100644 --- a/web_ui/partial_render_table/src/column.ml +++ b/web_ui/partial_render_table/src/column.ml @@ -4,8 +4,8 @@ open! Bonsai.Let_syntax module Sort_kind = Column_intf.Sort_kind module Sort_state = Bonsai_web_ui_partial_render_table_protocol.Sort_state -module Indexed_col_id = struct - type t = int [@@deriving equal] +module Indexed_column_id = struct + type t = int [@@deriving sexp, equal] let to_int = Fn.id let of_int = Fn.id @@ -26,63 +26,106 @@ module Dynamic_cells = struct } | Org_group of ('key, 'data) t list - let rec headers = function - | Leaf { leaf_header; visible; initial_width; cell = _ } -> - let%map header = leaf_header - and visible = visible in - Header_tree.leaf ~header ~visible ~initial_width - | Group { children; group_header } -> - let%map header = group_header - and children = Value.all (List.map children ~f:headers) in - Header_tree.group ~header children - | Org_group children -> - let%map children = List.map children ~f:headers |> Value.all in - Header_tree.org_group children + let headers t = + let rec loop ~next_id = function + | Leaf { leaf_header; visible; initial_width; cell = _ } -> + let tree = + let%map header = leaf_header + and visible = visible in + Header_tree.leaf + ~header + ~visible + ~initial_width + ~column_id:(Indexed_column_id.of_int next_id) + in + tree, next_id + 1 + | Group { children; group_header } -> + let next_id, children = + List.fold_map ~init:next_id children ~f:(fun next_id child -> + let child, next_id = loop ~next_id child in + next_id, child) + in + let tree = + let%map header = group_header + and children = Value.all children in + Header_tree.group ~header children + in + tree, next_id + | Org_group children -> + let next_id, children = + List.fold_map ~init:next_id children ~f:(fun next_id child -> + let child, next_id = loop ~next_id child in + next_id, child) + in + let tree = + let%map children = Value.all children in + Header_tree.org_group children + in + tree, next_id + in + let tree, _ = loop ~next_id:0 t in + tree ;; let headers t = return (headers t) - let rec visible_leaves - : type k v cmp. - (k * v) Opaque_map.t Value.t - -> (k, cmp) Bonsai.comparator - -> (k, v) t - -> (k * Vdom.Node.t) Opaque_map.t Computation.t list - = - fun map comparator -> function - | Leaf { cell; visible; _ } -> - [ (if%sub visible - then - Bonsai.Expert.assoc_on - (module Opaque_map.Key) - comparator - map - ~get_model_key:(fun _ (k, _) -> k) - ~f:(fun _ data -> - let%sub key, data = return data in - let%sub r = cell ~key ~data in - let%arr key = key - and r = r in - key, r) - else ( - let f = Ui_incr.Map.map ~f:(fun (k, _) -> k, Vdom.Node.none) in - Bonsai.Incr.compute map ~f)) - ] - | Group { children; _ } | Org_group children -> - List.bind children ~f:(visible_leaves map comparator) + let visible_leaves map comparator t = + let rec loop + : type k v cmp. + next_id:int + -> (k * v) Opaque_map.t Value.t + -> (k, cmp) Bonsai.comparator + -> (k, v) t + -> ((k * Vdom.Node.t) Opaque_map.t Computation.t * Indexed_column_id.t) list + * int + = + fun ~next_id map comparator -> function + | Leaf { cell; visible; _ } -> + let leaf = + if%sub visible + then + Bonsai.Expert.assoc_on + (module Opaque_map.Key) + comparator + map + ~get_model_key:(fun _ (k, _) -> k) + ~f:(fun _ data -> + let%sub key, data = return data in + let%sub r = cell ~key ~data in + let%arr key = key + and r = r in + key, r) + else ( + let f = Ui_incr.Map.map ~f:(fun (k, _) -> k, Vdom.Node.none) in + Bonsai.Incr.compute map ~f) + in + [ leaf, Indexed_column_id.of_int next_id ], next_id + 1 + | Group { children; _ } | Org_group children -> + let next_id, leaves = + List.fold_map children ~init:next_id ~f:(fun next_id child -> + let leaves, next_id = loop ~next_id map comparator child in + next_id, leaves) + in + let leaves = List.concat leaves in + leaves, next_id + in + let leaves, _ = loop ~next_id:0 map comparator t in + leaves ;; let instantiate_cells (type k) t comparator (map : (k * _) Opaque_map.t Value.t) = let empty = Map.empty (module Opaque_map.Key) in visible_leaves map comparator t - |> Computation.fold_right ~init:(Value.return empty) ~f:(fun a acc -> + |> List.fold_right ~init:(Bonsai.const empty) ~f:(fun (leaf_comp, column_id) acc -> + let%sub a = leaf_comp in + let%sub acc = acc in Bonsai.Incr.compute (Value.both a acc) ~f:(fun a_and_acc -> let%pattern_bind.Ui_incr a, acc = a_and_acc in Ui_incr.Map.merge a acc ~f:(fun ~key:_ change -> match change with - | `Left (i, l) -> Some (i, [ l ]) + | `Left (i, l) -> Some (i, [ column_id, l ]) | `Right (i, r) -> Some (i, r) - | `Both ((i, l), (_, r)) -> Some (i, l :: r)))) + | `Both ((i, l), (_, r)) -> Some (i, (column_id, l) :: r)))) ;; end @@ -95,11 +138,15 @@ module Dynamic_cells = struct let group ~label children = T.Group { group_header = label; children } let expand ~label child = group ~label [ child ] - let lift : type key data. (key, data) T.t list -> (key, data) Column_intf.t = + let lift + : type key data. + (key, data) T.t list -> (key, data, Indexed_column_id.t) Column_intf.t + = let module X = struct type t = (key, data) T.t type nonrec key = key type nonrec data = data + type column_id = Indexed_column_id.t let headers = T.headers let instantiate_cells = T.instantiate_cells @@ -107,7 +154,7 @@ module Dynamic_cells = struct in fun columns -> let value = T.Org_group columns in - Column_intf.T { value; vtable = (module X) } + Column_intf.T { value; vtable = (module X); column_id = (module Int) } ;; module Sortable = Sortable @@ -116,7 +163,7 @@ end module Dynamic_experimental = struct module T = struct type ('key, 'data, 'column_id, 'column_id_cmp) t = - { col_id : ('column_id, 'column_id_cmp) Bonsai.comparator + { column_id : ('column_id, 'column_id_cmp) Bonsai.comparator ; columns : 'column_id list Value.t ; render_header : 'column_id Value.t -> Vdom.Node.t Computation.t ; render_cell : @@ -125,19 +172,20 @@ module Dynamic_experimental = struct let headers : type key data column_id column_id_cmp. - (key, data, column_id, column_id_cmp) t -> Header_tree.t Computation.t + (key, data, column_id, column_id_cmp) t -> column_id Header_tree.t Computation.t = - fun { col_id; columns; render_header; render_cell = _ } -> - let module Col_id = (val col_id) in + fun { column_id; columns; render_header; render_cell = _ } -> + let module Col_id = (val column_id) in let%sub rendered = Bonsai.assoc_list (module Col_id) columns ~get_key:Fn.id - ~f:(fun _ col -> - let%sub header = render_header col in - let%arr header = header in - Header_tree.leaf ~header ~visible:true ~initial_width:(`Px 50)) + ~f:(fun _ column_id -> + let%sub header = render_header column_id in + let%arr header = header + and column_id = column_id in + Header_tree.leaf ~header ~visible:true ~initial_width:(`Px 50) ~column_id) in match%sub rendered with | `Duplicate_key _ -> @@ -154,23 +202,27 @@ module Dynamic_experimental = struct (key, data, column_id, column_id_cmp) t -> (key, _) Bonsai.comparator -> (key * data) Opaque_map.t Value.t - -> (key * Vdom.Node.t list) Opaque_map.t Computation.t + -> (key * (column_id * Vdom.Node.t) list) Opaque_map.t Computation.t = - fun { col_id; columns; render_header = _; render_cell } key_cmp rows -> - let module Col_id = (val col_id) in + fun { column_id; columns; render_header = _; render_cell } key_cmp rows -> + let module Col_id = (val column_id) in Bonsai.Expert.assoc_on (module Opaque_map.Key) key_cmp rows ~get_model_key:(fun _ (k, _) -> k) - ~f:(fun _key_key data -> + ~f:(fun _key data -> let%sub key, data = return data in let%sub rendered = Bonsai.assoc_list (module Col_id) columns ~get_key:Fn.id - ~f:(fun _ col -> render_cell col key data) + ~f:(fun _ col -> + let%sub cell = render_cell col key data in + let%arr col = col + and cell = cell in + col, cell) in match%sub rendered with | `Duplicate_key _ -> @@ -193,19 +245,20 @@ module Dynamic_experimental = struct -> render_header:(column Value.t -> Vdom.Node.t Computation.t) -> render_cell: (column Value.t -> key Value.t -> data Value.t -> Vdom.Node.t Computation.t) - -> (key, data) Column_intf.t + -> (key, data, column) Column_intf.t = let module X = struct type t = (key, data, column, column_cmp) T.t type nonrec key = key type nonrec data = data + type column_id = column let headers = T.headers let instantiate_cells = T.instantiate_cells end in - fun col_id ~columns ~render_header ~render_cell -> - let module Col_id = (val col_id) in + fun column_id ~columns ~render_header ~render_cell -> + let module Col_id = (val column_id) in let columns = let%map columns = columns in (* deduplicate *) @@ -217,8 +270,8 @@ module Dynamic_experimental = struct seen := Set.add !seen column; true)) in - let value = { T.col_id; columns; render_header; render_cell } in - Column_intf.T { value; vtable = (module X) } + let value = { T.column_id; columns; render_header; render_cell } in + Column_intf.T { value; vtable = (module X); column_id } ;; module Sortable = Sortable @@ -239,23 +292,41 @@ module Dynamic_columns = struct } | Org_group of ('key, 'data) t list - let rec translate = function - | Leaf { leaf_header = header; initial_width; visible; cell = _ } -> - Header_tree.leaf ~header ~visible ~initial_width - | Group { children; group_header = header } -> - let children = List.map children ~f:translate in - Header_tree.group ~header children - | Org_group children -> Header_tree.org_group (List.map children ~f:translate) + let translate t = + let rec map_children ~next_id children = + List.fold_map children ~init:next_id ~f:(fun next_id child -> + let tree, next_id = loop ~next_id child in + next_id, tree) + and loop ~next_id = function + | Leaf { leaf_header = header; initial_width; visible; cell = _ } -> + ( Header_tree.leaf + ~header + ~visible + ~initial_width + ~column_id:(Indexed_column_id.of_int next_id) + , next_id + 1 ) + | Group { children; group_header = header } -> + let next_id, tree = map_children ~next_id children in + Header_tree.group ~header tree, next_id + | Org_group children -> + let next_id, tree = map_children ~next_id children in + Header_tree.org_group tree, next_id + in + let tree, _ = loop ~next_id:0 t in + tree ;; let headers t = Bonsai.pure translate t - let rec visible_leaves structure ~key ~data = + let rec visible_leaves idx structure ~key ~data = match structure with | Leaf { cell; visible; _ } -> - if visible then [ cell ~key ~data ] else [ Vdom.Node.none ] + if visible + then [ Indexed_column_id.of_int idx, cell ~key ~data ] + else [ Indexed_column_id.of_int idx, Vdom.Node.none ] | Org_group children | Group { children; group_header = _ } -> - List.concat_map children ~f:(visible_leaves ~key ~data) + List.concat_mapi children ~f:(fun i child -> + visible_leaves (idx + i) child ~key ~data) ;; let instantiate_cells t _comparator map = @@ -265,7 +336,7 @@ module Dynamic_columns = struct Incr_map.mapi' which closes over visible_leaves as an incremental, but even in that scenario, if the set of visible_leaves changes, we're recomputing the whole world anyway, so it doesn't buy us anything vs this bind. *) - let%bind.Ui_incr visible_leaves = Ui_incr.map t ~f:visible_leaves in + let%bind.Ui_incr visible_leaves = Ui_incr.map t ~f:(visible_leaves 0) in Ui_incr.Map.map map ~f:(fun (key, data) -> key, visible_leaves ~key ~data)) ;; end @@ -279,11 +350,15 @@ module Dynamic_columns = struct let group ~label children = T.Group { group_header = label; children } let expand ~label child = group ~label [ child ] - let lift : type key data. (key, data) T.t list Value.t -> (key, data) Column_intf.t = + let lift + : type key data. + (key, data) T.t list Value.t -> (key, data, Indexed_column_id.t) Column_intf.t + = let module X = struct type t = (key, data) T.t Value.t type nonrec key = key type nonrec data = data + type column_id = Indexed_column_id.t let headers = T.headers let instantiate_cells = T.instantiate_cells @@ -294,7 +369,7 @@ module Dynamic_columns = struct let%map columns = columns in T.Org_group columns in - Column_intf.T { value; vtable = (module X) } + Column_intf.T { value; vtable = (module X); column_id = (module Int) } ;; module Sortable = Sortable @@ -408,7 +483,7 @@ module Dynamic_cells_with_sorter = struct let lift : type key data. - (key, data) T.t list -> (key, data, Indexed_col_id.t) Column_intf.with_sorter + (key, data) T.t list -> (key, data, Indexed_column_id.t) Column_intf.with_sorter = let module X = struct type t = (key, data) T.t @@ -424,7 +499,7 @@ module Dynamic_cells_with_sorter = struct let value = T.Group { children = columns; build = (fun c -> Dynamic_cells.T.Org_group c) } in - Column_intf.Y { value; vtable = (module X); col_id = (module Int) } + Column_intf.Y { value; vtable = (module X); column_id = (module Int) } ;; module Sortable = Sortable @@ -503,7 +578,7 @@ module Dynamic_columns_with_sorter = struct let lift : type key data. (key, data) T.t list Value.t - -> (key, data, Indexed_col_id.t) Column_intf.with_sorter + -> (key, data, Indexed_column_id.t) Column_intf.with_sorter = let module X = struct type t = (key, data) T.t Value.t @@ -520,7 +595,7 @@ module Dynamic_columns_with_sorter = struct let%map columns = columns in T.Group { children = columns; build = (fun c -> Dynamic_columns.T.Org_group c) } in - Column_intf.Y { value; vtable = (module X); col_id = (module Int) } + Column_intf.Y { value; vtable = (module X); column_id = (module Int) } ;; module Sortable = Sortable @@ -529,7 +604,7 @@ end module Dynamic_experimental_with_sorter = struct module T = struct type ('key, 'data, 'column_id, 'column_id_cmp) t = - { col_id : ('column_id, 'column_id_cmp) Bonsai.comparator + { column_id : ('column_id, 'column_id_cmp) Bonsai.comparator ; columns : ('column_id list * ('column_id, 'column_id_cmp) Set.t) Value.t ; render_header : 'column_id Value.t -> (Sort_state.t -> Vdom.Node.t) Computation.t ; render_cell : @@ -542,11 +617,12 @@ module Dynamic_experimental_with_sorter = struct : type key data column_id column_id_cmp. (key, data, column_id, column_id_cmp) t -> column_id Sortable.t Value.t - -> ((column_id, (key, data) Sort_kind.t, column_id_cmp) Map.t * Header_tree.t) + -> ((column_id, (key, data) Sort_kind.t, column_id_cmp) Map.t + * column_id Header_tree.t) Computation.t = - fun { col_id; columns; render_header; sorts; render_cell = _ } sortable_header -> - let module Col_id = (val col_id) in + fun { column_id; columns; render_header; sorts; render_cell = _ } sortable_header -> + let module Col_id = (val column_id) in let%sub columns, columns_as_a_set = return columns in let%sub sorts = match sorts with @@ -579,7 +655,7 @@ module Dynamic_experimental_with_sorter = struct sortable_header render_header in - Header_tree.leaf ~header ~visible:true ~initial_width:(`Px 50)) + Header_tree.leaf ~column_id:col ~header ~visible:true ~initial_width:(`Px 50)) in let%sub headers = match%sub headers with @@ -600,10 +676,10 @@ module Dynamic_experimental_with_sorter = struct (key, data, column_id, column_id_cmp) t -> (key, _) Bonsai.comparator -> (key * data) Opaque_map.t Value.t - -> (key * Vdom.Node.t list) Opaque_map.t Computation.t + -> (key * (column_id * Vdom.Node.t) list) Opaque_map.t Computation.t = - fun { col_id; columns; render_cell; render_header = _; sorts = _ } key_cmp rows -> - let module Col_id = (val col_id) in + fun { column_id; columns; render_cell; render_header = _; sorts = _ } key_cmp rows -> + let module Col_id = (val column_id) in let%sub columns, _ = return columns in Bonsai.Expert.assoc_on (module Opaque_map.Key) @@ -617,7 +693,11 @@ module Dynamic_experimental_with_sorter = struct (module Col_id) columns ~get_key:Fn.id - ~f:(fun _ col -> render_cell col key data) + ~f:(fun _ col -> + let%sub cell = render_cell col key data in + let%arr col = col + and cell = cell in + col, cell) in match%sub rendered with | `Duplicate_key _ -> @@ -651,8 +731,8 @@ module Dynamic_experimental_with_sorter = struct let instantiate_cells = T.instantiate_cells end in - fun ?sorts col_id ~columns ~render_header ~render_cell -> - let module Col_id = (val col_id) in + fun ?sorts column_id ~columns ~render_header ~render_cell -> + let module Col_id = (val column_id) in let columns = let%map columns = columns in (* deduplicate *) @@ -667,8 +747,8 @@ module Dynamic_experimental_with_sorter = struct in as_list, !seen in - let value = { T.col_id; columns; render_header; render_cell; sorts } in - Column_intf.Y { value; vtable = (module X); col_id = (module Col_id) } + let value = { T.column_id; columns; render_header; render_cell; sorts } in + Column_intf.Y { value; vtable = (module X); column_id = (module Col_id) } ;; module Sortable = Sortable diff --git a/web_ui/partial_render_table/src/column.mli b/web_ui/partial_render_table/src/column.mli index 2a22516e..1d1189ab 100644 --- a/web_ui/partial_render_table/src/column.mli +++ b/web_ui/partial_render_table/src/column.mli @@ -2,8 +2,8 @@ open! Core open! Bonsai_web module Sort_state := Bonsai_web_ui_partial_render_table_protocol.Sort_state -module Indexed_col_id : sig - type t [@@deriving equal] +module Indexed_column_id : sig + type t [@@deriving equal, sexp] val to_int : t -> int val of_int : int -> t @@ -31,7 +31,7 @@ module Dynamic_cells : sig val group : label:Vdom.Node.t Value.t -> ('key, 'data) t list -> ('key, 'data) t val expand : label:Vdom.Node.t Value.t -> ('key, 'data) t -> ('key, 'data) t - val lift : ('key, 'data) t list -> ('key, 'data) Column_intf.t + val lift : ('key, 'data) t list -> ('key, 'data, Indexed_column_id.t) Column_intf.t module Sortable = Sortable end @@ -49,19 +49,25 @@ module Dynamic_columns : sig val group : label:Vdom.Node.t -> ('key, 'data) t list -> ('key, 'data) t val expand : label:Vdom.Node.t -> ('key, 'data) t -> ('key, 'data) t - val lift : ('key, 'data) t list Value.t -> ('key, 'data) Column_intf.t + + val lift + : ('key, 'data) t list Value.t + -> ('key, 'data, Indexed_column_id.t) Column_intf.t module Sortable = Sortable end module Dynamic_experimental : sig val build - : ('column, _) Bonsai.comparator - -> columns:'column list Value.t - -> render_header:('column Value.t -> Vdom.Node.t Computation.t) + : ('column_id, _) Bonsai.comparator + -> columns:'column_id list Value.t + -> render_header:('column_id Value.t -> Vdom.Node.t Computation.t) -> render_cell: - ('column Value.t -> 'key Value.t -> 'data Value.t -> Vdom.Node.t Computation.t) - -> ('key, 'data) Column_intf.t + ('column_id Value.t + -> 'key Value.t + -> 'data Value.t + -> Vdom.Node.t Computation.t) + -> ('key, 'data, 'column_id) Column_intf.t module Sortable = Sortable end @@ -84,7 +90,7 @@ module Dynamic_cells_with_sorter : sig val lift : ('key, 'data) t list - -> ('key, 'data, Indexed_col_id.t) Column_intf.with_sorter + -> ('key, 'data, Indexed_column_id.t) Column_intf.with_sorter module Sortable = Sortable end @@ -107,20 +113,23 @@ module Dynamic_columns_with_sorter : sig val lift : ('key, 'data) t list Value.t - -> ('key, 'data, Indexed_col_id.t) Column_intf.with_sorter + -> ('key, 'data, Indexed_column_id.t) Column_intf.with_sorter module Sortable = Sortable end module Dynamic_experimental_with_sorter : sig val build - : ?sorts:('column Value.t -> ('key, 'data) Sort_kind.t option Computation.t) - -> ('column, _) Bonsai.comparator - -> columns:'column list Value.t - -> render_header:('column Value.t -> (Sort_state.t -> Vdom.Node.t) Computation.t) + : ?sorts:('column_id Value.t -> ('key, 'data) Sort_kind.t option Computation.t) + -> ('column_id, _) Bonsai.comparator + -> columns:'column_id list Value.t + -> render_header:('column_id Value.t -> (Sort_state.t -> Vdom.Node.t) Computation.t) -> render_cell: - ('column Value.t -> 'key Value.t -> 'data Value.t -> Vdom.Node.t Computation.t) - -> ('key, 'data, 'column) Column_intf.with_sorter + ('column_id Value.t + -> 'key Value.t + -> 'data Value.t + -> Vdom.Node.t Computation.t) + -> ('key, 'data, 'column_id) Column_intf.with_sorter module Sortable = Sortable end diff --git a/web_ui/partial_render_table/src/column_intf.ml b/web_ui/partial_render_table/src/column_intf.ml index 1378188c..55c2ffab 100644 --- a/web_ui/partial_render_table/src/column_intf.ml +++ b/web_ui/partial_render_table/src/column_intf.ml @@ -6,14 +6,15 @@ module type S = sig type t type key type data + type column_id - val headers : t -> Header_tree.t Computation.t + val headers : t -> column_id Header_tree.t Computation.t val instantiate_cells : t -> (key, 'cmp) Bonsai.comparator -> (key * data) Opaque_map.t Value.t - -> (key * Vdom.Node.t list) Opaque_map.t Computation.t + -> (key * (column_id * Vdom.Node.t) list) Opaque_map.t Computation.t end module type S_with_sorter = sig @@ -26,22 +27,29 @@ module type S_with_sorter = sig val headers_and_sorters : t -> column_id Sortable.t Value.t - -> ((column_id, (key, data) Sort_kind.t, column_id_cmp) Map.t * Header_tree.t) + -> ((column_id, (key, data) Sort_kind.t, column_id_cmp) Map.t + * column_id Header_tree.t) Computation.t val instantiate_cells : t -> (key, 'cmp) Bonsai.comparator -> (key * data) Opaque_map.t Value.t - -> (key * Vdom.Node.t list) Opaque_map.t Computation.t + -> (key * (column_id * Vdom.Node.t) list) Opaque_map.t Computation.t end -type ('key, 'data) t = +type ('key, 'data, 'column_id) t = | T : { value : 'a - ; vtable : (module S with type t = 'a and type key = 'key and type data = 'data) + ; vtable : + (module S + with type t = 'a + and type key = 'key + and type data = 'data + and type column_id = 'column_id) + ; column_id : ('column_id, 'column_id_cmp) Bonsai.comparator } - -> ('key, 'data) t + -> ('key, 'data, 'column_id) t type ('key, 'data, 'column_id) with_sorter = | Y : @@ -53,6 +61,6 @@ type ('key, 'data, 'column_id) with_sorter = and type data = 'data and type column_id = 'column_id and type column_id_cmp = 'column_id_cmp) - ; col_id : ('column_id, 'column_id_cmp) Bonsai.comparator + ; column_id : ('column_id, 'column_id_cmp) Bonsai.comparator } -> ('key, 'data, 'column_id) with_sorter diff --git a/web_ui/partial_render_table/src/dune b/web_ui/partial_render_table/src/dune index 7882e9a7..e078b3f1 100644 --- a/web_ui/partial_render_table/src/dune +++ b/web_ui/partial_render_table/src/dune @@ -1,8 +1,9 @@ -(library (name bonsai_web_ui_partial_render_table) +(library + (name bonsai_web_ui_partial_render_table) (public_name bonsai.web_ui_partial_render_table) (libraries bonsai_web_ui_scroll_utilities vdom_node_with_map_children - bonsai_web bonsai_extra core incr_map.collate - bonsai_web_ui_element_size_hooks - bonsai_web_ui_partial_render_table_protocol) + bonsai_web bonsai_extra core incr_map.collate + bonsai_web_ui_element_size_hooks + bonsai_web_ui_partial_render_table_protocol) (preprocess - (pps ppx_css js_of_ocaml-ppx ppx_jane ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + (pps ppx_css js_of_ocaml-ppx ppx_jane ppx_pattern_bind ppx_bonsai))) diff --git a/web_ui/partial_render_table/src/focus.ml b/web_ui/partial_render_table/src/focus.ml index 391fe182..549e58f5 100644 --- a/web_ui/partial_render_table/src/focus.ml +++ b/web_ui/partial_render_table/src/focus.ml @@ -3,16 +3,18 @@ open! Bonsai_web open! Bonsai.Let_syntax module Collated = Incr_map_collate.Collated -module By_row = struct +module By_cell = struct module Action = struct - type 'key t = + type ('key, 'column_id) t = | Unfocus | Up | Down + | Left + | Right | Page_up | Page_down - | Select of 'key - | Select_index of int + | Select of ('key * 'column_id) + | Select_index of (int * 'column_id) | Switch_from_index_to_key of { key : 'key ; index : int @@ -20,69 +22,105 @@ module By_row = struct [@@deriving sexp_of] end - type ('k, 'presence) t = + type ('k, 'column_id, 'presence) t = { focused : 'presence ; unfocus : unit Effect.t ; focus_up : unit Effect.t ; focus_down : unit Effect.t + ; focus_left : unit Effect.t + ; focus_right : unit Effect.t ; page_up : unit Effect.t ; page_down : unit Effect.t - ; focus : 'k -> unit Effect.t - ; focus_index : int -> unit Effect.t + ; focus : 'k -> 'column_id -> unit Effect.t + ; focus_index : int -> 'column_id -> unit Effect.t } [@@deriving fields ~getters] - type 'k optional = ('k, 'k option) t + type ('k, 'column_id) optional = ('k, 'column_id, ('k * 'column_id) option) t - (* The effects computed from [inject] are constant, and only computed once. - [presence], however, changes extremely frequently, since it is the focused row. - Constructing this value in stages means that downstream consumers that only look at - e.g. "focus_up", won't have cutoff issues caused by [inject Up] being called every - time that the model changes. *) module Without_presence : sig - type 'k unfinalized + (* The effects computed from [inject] are constant, and only computed once. + [presence], however, changes extremely frequently, since it is the focused row. + Constructing this value in stages means that downstream consumers that only look at + e.g. "focus_up", won't have cutoff issues caused by [inject Up] being called every + time that the model changes. *) + type ('k, 'column_id) unfinalized - val create : ('k Action.t -> unit Effect.t) -> 'k unfinalized - val finalize : 'k unfinalized -> 'presence -> ('k, 'presence) t + val create + : (('k, 'column_id) Action.t -> unit Effect.t) + -> ('k, 'column_id) unfinalized + + val finalize + : ('k, 'column_id) unfinalized + -> 'presence + -> ('k, 'column_id, 'presence) t end = struct - type 'k unfinalized = ('k, Nothing.t option) t + type ('k, 'column_id) unfinalized = ('k, 'column_id, Nothing.t option) t let create inject = { focused = None ; unfocus = inject Action.Unfocus ; focus_up = inject Up ; focus_down = inject Down + ; focus_left = inject Left + ; focus_right = inject Right ; page_up = inject Page_up ; page_down = inject Page_down - ; focus = (fun k -> inject (Select k)) - ; focus_index = (fun k -> inject (Select_index k)) + ; focus = (fun k c -> inject (Select (k, c))) + ; focus_index = (fun k c -> inject (Select_index (k, c))) } ;; let finalize without_focus focused = { without_focus with focused } end +end + +module By_row = struct + type ('k, 'presence) t = ('k, unit, 'presence) By_cell.t + type 'k optional = ('k, 'k option) t + + let focused = By_cell.focused + let unfocus = By_cell.unfocus + let focus_up = By_cell.focus_up + let focus_down = By_cell.focus_down + let page_up = By_cell.page_up + let page_down = By_cell.page_down + let focus t k = By_cell.focus t k () + let focus_index t i = By_cell.focus_index t i () module Expert = struct - let keyless t = { t with focused = None; focus = (fun _ -> Effect.Ignore) } + let keyless (t : ('k, 'presence) t) = + { t with focused = None; focus = (fun _ _ -> Effect.Ignore) } + ;; end end module Kind = struct - type ('a, 'presence, 'k) t = - | None : (unit, unit, 'k) t + type ('a, 'presence, 'k, 'column_id) t = + | None : (unit, unit, 'k, 'column_id) t | By_row : { on_change : ('k option -> unit Effect.t) Value.t ; compute_presence : 'k option Value.t -> 'presence Computation.t } - -> (('k, 'presence) By_row.t, 'presence, 'k) t + -> (('k, 'presence) By_row.t, 'presence, 'k, 'column_id) t + | By_cell : + { on_change : (('k * 'column_id) option -> unit Effect.t) Value.t + ; compute_presence : ('k * 'column_id) option Value.t -> 'presence Computation.t + } + -> (('k, 'column_id, 'presence) By_cell.t, 'presence, 'k, 'column_id) t end -type ('kind, 'key) t = +type ('key, 'column_id, 'kind) focused = + | Nothing_focused : ('key, 'column_id, _) focused + | Cell_focused : ('key * 'column_id) -> ('key, 'column_id, _ By_cell.t) focused + | Row_focused : 'key -> ('key, 'column_id, _ By_row.t) focused + +type ('kind, 'key, 'column_id) t = { focus : 'kind - ; visually_focused : 'key option + ; visually_focused : ('key, 'column_id, 'kind) focused } -module Row_machine = struct +module Cell_machine = struct module Triple = struct (** This type is pretty integral to the row selection state-machine. A value of this type is stored as the "currently selected row" and also @@ -101,6 +139,8 @@ module Row_machine = struct [@@deriving sexp, equal] end + module Action = By_cell.Action + let find_by collated ~f = with_return_option (fun { return } -> let i = ref (Collated.num_before_range collated) in @@ -121,82 +161,125 @@ module Row_machine = struct Int.equal index needle)) ;; + module Currently_selected_cell = struct + type ('k, 'column_id) t = + { row : 'k Currently_selected_row.t + ; column : 'column_id + } + [@@deriving sexp_of, equal] + end + let component - (type key data cmp presence) + (type key column_id data cmp column_id_cmp presence) (key : (key, cmp) Bonsai.comparator) - ~(compute_presence : key option Value.t -> presence Computation.t) - ~(on_change : (key option -> unit Effect.t) Value.t) + (column_id : (column_id, column_id_cmp) Bonsai.comparator) + ~(compute_presence : (key * column_id) option Value.t -> presence Computation.t) + ~(on_change : ((key * column_id) option -> unit Effect.t) Value.t) ~(collated : (key, data) Incr_map_collate.Collated.t Value.t) + ~(columns : column_id list Value.t) ~(range : (int * int) Value.t) ~(scroll_to_index : (int -> unit Effect.t) Value.t) - : ((key, presence) By_row.t, key) t Computation.t + ~(scroll_to_column : (column_id -> unit Effect.t) Value.t) + : ((key, column_id, presence) By_cell.t, key, column_id) t Computation.t = let module Key = struct include (val key) - let equal a b = comparator.compare a b = 0 + let equal = Comparable.equal comparator.compare + end + in + let module Column_id = struct + include (val column_id) + + let equal = Comparable.equal comparator.compare end in let module Action = struct - include By_row.Action + include Action - type t = Key.t By_row.Action.t [@@deriving sexp_of] + type t = (Key.t, Column_id.t) Action.t [@@deriving sexp_of] end in let module Model = struct - (** [current] is the currently selected row. - [shadow] is the previously selected row. + (** [current] is the currently selected cell. + [shadow] is the previously selected cell. - Shadow is useful for computing "next row down" if the user previously + Shadow is useful for computing "next cell down" if the user previously unfocused, or if the element that was previously selected has been removed. *) type t = - | No_focused_row - | Shadow of Key.t Currently_selected_row.t - | Visible of Key.t Currently_selected_row.t + | No_focused_cell + | Shadow of (Key.t, Column_id.t) Currently_selected_cell.t + | Visible of (Key.t, Column_id.t) Currently_selected_cell.t [@@deriving sexp_of, equal] - let empty = No_focused_row + let empty = No_focused_cell end in let module Input = struct type t = { collated : (key, data) Collated.t + ; columns : column_id list ; range : int * int - ; on_change : key option -> unit Ui_effect.t + ; on_change : (key * column_id) option -> unit Ui_effect.t ; scroll_to_index : int -> unit Effect.t + ; scroll_to_column : column_id -> unit Effect.t } end in let%sub input = let%arr collated = collated + and columns = columns and range = range and on_change = on_change - and scroll_to_index = scroll_to_index in - { Input.collated; range; on_change; scroll_to_index } + and scroll_to_index = scroll_to_index + and scroll_to_column = scroll_to_column in + { Input.collated; columns; range; on_change; scroll_to_index; scroll_to_column } in let apply_action context input (model : Model.t) action = match input with | Bonsai.Computation_status.Active - { Input.collated; range = range_start, range_end; on_change; scroll_to_index } - -> + { Input.columns = [] + ; collated = _ + ; range = _ + ; on_change = _ + ; scroll_to_index = _ + ; scroll_to_column = _ + } -> + (* There are no columns, therefore no cells, so there is nothing to focus. *) + Model.No_focused_cell + | Inactive -> + (* We want to preserve focus state even if the table is inactive *) + model + | Active + { collated + ; columns = first_column :: _ as columns + ; range = range_start, range_end + ; on_change + ; scroll_to_index + ; scroll_to_column + } -> let scroll_to_index index = Bonsai.Apply_action_context.schedule_event context (scroll_to_index index) in - let update_focused_index ~f = - let original_index = + let scroll_to_column column = + Bonsai.Apply_action_context.schedule_event context (scroll_to_column column) + in + let update_focus ~f = + let original_index_and_column = match model with - | No_focused_row -> None - | Shadow current | Visible current -> - (match current with - | At_index index -> Some index + | No_focused_cell -> None + | Shadow { row; column } | Visible { row; column } -> + (match row with + | At_index index -> Some (index, column) | At_key { key; index = old_index } -> (match find_by_key collated ~key ~key_equal:Key.equal with - | Some { Triple.index; key = _ } -> Some index - | None -> Some old_index)) + | Some { Triple.index; key = _ } -> Some (index, column) + | None -> Some (old_index, column))) in - let new_index = f original_index in + let new_index, new_column = f original_index_and_column in scroll_to_index new_index; + scroll_to_column new_column; let new_index = Int.max 0 @@ -207,10 +290,12 @@ module Row_machine = struct + Collated.length collated - 1)) in - Some - (match find_by_index collated ~index:new_index with - | Some triple -> Currently_selected_row.At_key triple - | None -> At_index new_index) + let row = + match find_by_index collated ~index:new_index with + | Some triple -> Currently_selected_row.At_key triple + | None -> At_index new_index + in + { Currently_selected_cell.row; column = new_column } in let new_focus = match (action : Action.t) with @@ -220,78 +305,111 @@ module Row_machine = struct ignore the request to switch from index to key, since it is out of date. *) (match model with - | No_focused_row -> None - | Visible (At_index model_index) | Shadow (At_index model_index) -> + | No_focused_cell -> None + | Visible { row = At_index model_index; column } + | Shadow { row = At_index model_index; column } -> if model_index = index - then Some (Currently_selected_row.At_key { key; index }) - else Some (At_index model_index) - | Visible (At_key _ as current) | Shadow (At_key _ as current) -> - Some current) - | Select key -> + then Some { Currently_selected_cell.row = At_key { key; index }; column } + else Some { row = At_index model_index; column } + | Visible ({ row = At_key _; column = _ } as current) + | Shadow ({ row = At_key _; column = _ } as current) -> Some current) + | Select (key, column) -> (match find_by_key ~key ~key_equal:Key.equal collated with | Some ({ index; key = _ } as triple) -> scroll_to_index index; - Some (Currently_selected_row.At_key triple) + Some { row = At_key triple; column } | None -> None) | Unfocus -> None - | Select_index new_index -> - update_focused_index ~f:(fun _original_index -> new_index) + | Select_index (new_index, new_column) -> + Some (update_focus ~f:(fun _original_index -> new_index, new_column)) | Down -> - update_focused_index ~f:(function - | Some original_index -> original_index + 1 - | None -> range_start) + Some + (update_focus ~f:(function + | Some (original_index, column) -> original_index + 1, column + | None -> range_start, first_column)) | Up -> - update_focused_index ~f:(function - | Some original_index -> original_index - 1 - | None -> range_end) + Some + (update_focus ~f:(function + | Some (original_index, column) -> original_index - 1, column + | None -> range_end, first_column)) + | Left -> + Some + (update_focus ~f:(function + | Some (original_index, original_column) -> + let column_index = + List.findi columns ~f:(fun _ column -> + Column_id.equal column original_column) + in + (match column_index with + | Some (i, _) -> + (* List.nth_exn will throw if and only if the length of the list is 0, + which the pattern match above guards against already.*) + original_index, List.nth_exn columns (Int.max (i - 1) 0) + | None -> original_index, first_column) + | None -> range_start, first_column)) + | Right -> + Some + (update_focus ~f:(function + | Some (original_index, original_column) -> + let column_index = + List.findi columns ~f:(fun _ column -> + Column_id.equal column original_column) + in + (match column_index with + | Some (i, _) -> + (* List.nth_exn will throw if and only if the length of the list is 0, + which the pattern match above guards against already.*) + ( original_index + , List.nth_exn columns (Int.min (i + 1) (List.length columns - 1)) ) + | None -> original_index, first_column) + | None -> range_start, first_column)) | Page_down -> - update_focused_index ~f:(function - | Some original_index -> - if original_index < range_end - then range_end - else original_index + (range_end - range_start) - | None -> range_end) + Some + (update_focus ~f:(function + | Some (original_index, original_column) -> + let new_index = + if original_index < range_end + then range_end + else original_index + (range_end - range_start) + in + new_index, original_column + | None -> range_end, first_column)) | Page_up -> - update_focused_index ~f:(function - | Some original_index -> - if original_index > range_start - then range_start - else original_index - (range_end - range_start) - | None -> range_start) + Some + (update_focus ~f:(function + | Some (original_index, original_column) -> + let new_index = + if original_index > range_start + then range_start + else original_index - (range_end - range_start) + in + new_index, original_column + | None -> range_start, first_column)) in let new_model = match action with | Unfocus -> (match model with - | No_focused_row -> Model.No_focused_row + | No_focused_cell -> Model.No_focused_cell | Visible triple | Shadow triple -> Shadow triple) | _ -> (match new_focus with | Some triple -> Visible triple - | None -> No_focused_row) + | None -> No_focused_cell) in let prev_key = match model with - | No_focused_row | Shadow _ | Visible (At_index _) -> None - | Visible (At_key { key; _ }) -> Some key + | No_focused_cell | Shadow _ | Visible { row = At_index _; column = _ } -> None + | Visible { row = At_key { key; _ }; column } -> Some (key, column) in let next_key = match new_model with - | No_focused_row | Shadow _ | Visible (At_index _) -> None - | Visible (At_key { key; _ }) -> Some key + | No_focused_cell | Shadow _ | Visible { row = At_index _; column = _ } -> None + | Visible { row = At_key { key; _ }; column } -> Some (key, column) in - if not ([%equal: Key.t option] prev_key next_key) + if not ([%equal: (Key.t * Column_id.t) option] prev_key next_key) then Bonsai.Apply_action_context.schedule_event context (on_change next_key); new_model - | Inactive -> - eprint_s - [%message - [%here] - "An action sent to a [state_machine1] has been dropped because its input \ - was not present. This happens when the [state_machine1] is inactive when \ - it receives a message." - (action : Action.t)]; - model in let%sub current, inject = Bonsai.state_machine1 @@ -303,21 +421,30 @@ module Row_machine = struct input in let%sub current = return (Value.cutoff ~equal:[%equal: Model.t] current) in + let%sub everything_injectable = + (* By depending on only [inject] (which is a constant), we can build the vast majority + of this record, leaving only the "focused" field left unset, which we quickly fix. + Doing it this way will mean that downstream consumers that only look at e.g. the "focus_up" + field, won't have cutoff issues caused by [inject Up] being called every time that + the model changes. *) + let%arr inject = inject in + By_cell.Without_presence.create inject + in let%sub visually_focused = let%arr current = current and collated = collated in match current with - | Visible (At_key { key; _ }) -> Some key - | Visible (At_index index) -> + | Visible { row = At_key { key; _ }; column } -> Some (key, column) + | Visible { row = At_index index; column } -> (match find_by_index collated ~index with - | Some { key; _ } -> Some key + | Some { key; _ } -> Some (key, column) | None -> None) - | No_focused_row | Shadow _ -> None + | No_focused_cell | Shadow _ -> None in let%sub () = Bonsai.Edge.on_change - ~sexp_of_model:[%sexp_of: Model.t * Key.t option] - ~equal:[%equal: Model.t * Key.t option] + ~sexp_of_model:[%sexp_of: Model.t * (Key.t * Column_id.t) option] + ~equal:[%equal: Model.t * (Key.t * Column_id.t) option] (Value.both current visually_focused) ~callback: (let%map inject = inject in @@ -326,63 +453,143 @@ module Row_machine = struct for which there is an existing row, we can request that the state machine switch over to being focused on the key at that index. *) match current with - | Model.Visible (At_index index) -> + | Model.Visible { row = At_index index; column = _ } -> (match visually_focused with - | Some key -> inject (Switch_from_index_to_key { key; index }) + | Some (key, _) -> inject (Switch_from_index_to_key { key; index }) | None -> Effect.Ignore) - | Visible (At_key _) | No_focused_row | Shadow _ -> Effect.Ignore) - in - let%sub without_focus = - let%arr inject = inject in - By_row.Without_presence.create inject + | Visible { row = At_key _; column = _ } | No_focused_cell | Shadow _ -> + Effect.Ignore) in let%sub presence = compute_presence visually_focused in + let%sub visually_focused = + match%arr visually_focused with + | None -> Nothing_focused + | Some (key, column_id) -> Cell_focused (key, column_id) + in let%arr presence = presence and visually_focused = visually_focused - and without_focus = without_focus in - let focus = By_row.Without_presence.finalize without_focus presence in + and everything_injectable = everything_injectable in + let focus = By_cell.Without_presence.finalize everything_injectable presence in + { focus; visually_focused } + ;; +end + +module Row_machine = struct + let component + (type key data cmp presence) + (key : (key, cmp) Bonsai.comparator) + ~(compute_presence : key option Value.t -> presence Computation.t) + ~(on_change : (key option -> unit Effect.t) Value.t) + ~(collated : (key, data) Incr_map_collate.Collated.t Value.t) + ~(range : (int * int) Value.t) + ~(scroll_to_index : (int -> unit Effect.t) Value.t) + : ((key, presence) By_row.t, key, _) t Computation.t + = + let compute_presence focus = + let%sub focus = + let%arr focus = focus in + Option.map focus ~f:(fun (key, ()) -> key) + in + compute_presence focus + in + let%sub on_change = + let%arr on_change = on_change in + fun focus -> + match focus with + | None -> on_change None + | Some (key, ()) -> on_change (Some key) + in + let%sub { focus; visually_focused } = + Cell_machine.component + key + (module Unit) + ~on_change + ~compute_presence + ~collated + ~columns:(Value.return [ () ]) + ~range + ~scroll_to_index + ~scroll_to_column:(Value.return (fun _ -> Effect.Ignore)) + in + let%sub visually_focused = + let%arr visually_focused = visually_focused in + match visually_focused with + | Nothing_focused -> Nothing_focused + | Cell_focused (key, ()) | Row_focused key -> Row_focused key + in + let%arr focus = focus + and visually_focused = visually_focused in { focus; visually_focused } ;; end let component - : type kind presence key. - (kind, presence, key) Kind.t + : type kind presence key column_id column_id_cmp. + (kind, presence, key, column_id) Kind.t -> (key, _) Bonsai.comparator + -> (column_id, column_id_cmp) Bonsai.comparator -> collated:(key, _) Collated.t Value.t + -> leaves:column_id Header_tree.leaf list Value.t -> range:_ -> scroll_to_index:_ - -> (kind, key) t Computation.t + -> scroll_to_column:(column_id -> unit Effect.t) Value.t + -> (kind, key, column_id) t Computation.t = fun kind -> match kind with | None -> - fun _ ~collated:_ ~range:_ ~scroll_to_index:_ -> - Bonsai.const { focus = (); visually_focused = None } + fun _ _ ~collated:_ ~leaves:_ ~range:_ ~scroll_to_index:_ ~scroll_to_column:_ -> + Bonsai.const { focus = (); visually_focused = Nothing_focused } | By_row { on_change; compute_presence } -> - Row_machine.component ~on_change ~compute_presence + fun key _ ~collated ~leaves:_ ~range ~scroll_to_index ~scroll_to_column:_ -> + Row_machine.component + key + ~on_change + ~compute_presence + ~collated + ~range + ~scroll_to_index + | By_cell { on_change; compute_presence } -> + fun key column ~collated ~leaves ~range ~scroll_to_index ~scroll_to_column -> + let%sub columns = + let%arr leaves = leaves in + List.map leaves ~f:(fun leaf -> leaf.column_id) + in + Cell_machine.component + key + column + ~on_change + ~compute_presence + ~collated + ~columns + ~range + ~scroll_to_index + ~scroll_to_column ;; -let get_focused (type r presence k) - : (r, presence, k) Kind.t -> r Value.t -> presence Value.t - = - fun kind value -> - match kind with - | None -> Value.return () - | By_row _ -> - let%map { focused; _ } = value in - focused -;; - -let get_on_row_click - (type r presence k) - (kind : (r, presence, k) Kind.t) +let get_on_cell_click + (type r presence k column_id) + (kind : (r, presence, k, column_id) Kind.t) (value : r Value.t) - : (k -> unit Effect.t) Value.t + : (k -> column_id -> unit Effect.t) Value.t = + (* The incrementality of this code is important: we need to have a cutoff between when + we extract the focus function and when we create the wrapping function. This is + because the focus function should be a constant, but the entire [control] is not. *) match kind with - | None -> Value.return (fun _ -> Effect.Ignore) + | None -> Value.return (fun _ _ -> Effect.Ignore) | By_row _ -> - let%map control = value in - By_row.focus control + let focus = + let%map control = value in + By_row.focus control + in + let%map focus = focus in + fun key _ -> focus key + | By_cell _ -> + let focus = + let%map control = value in + By_cell.focus control + in + let%map focus = focus in + fun key column -> focus key column ;; diff --git a/web_ui/partial_render_table/src/focus.mli b/web_ui/partial_render_table/src/focus.mli index 18858933..e4bb5cb0 100644 --- a/web_ui/partial_render_table/src/focus.mli +++ b/web_ui/partial_render_table/src/focus.mli @@ -2,6 +2,28 @@ open! Core open! Bonsai_web module Collated := Incr_map_collate.Collated +module By_cell : sig + type ('k, 'col_id, 'presence) t + + val focused : ('k, 'col_id, 'presence) t -> 'presence + val focus_up : ('k, 'col_id, 'presence) t -> unit Effect.t + val focus_down : ('k, 'col_id, 'presence) t -> unit Effect.t + val focus_left : ('k, 'col_id, 'presence) t -> unit Effect.t + val focus_right : ('k, 'col_id, 'presence) t -> unit Effect.t + val page_up : ('k, 'col_id, 'presence) t -> unit Effect.t + val page_down : ('k, 'col_id, 'presence) t -> unit Effect.t + val unfocus : ('k, 'col_id, 'presence) t -> unit Effect.t + + (** [focus k] sets the focus to the `col_id cell in the row keyed by k. *) + val focus : ('k, 'col_id, 'presence) t -> 'k -> 'col_id -> unit Effect.t + + (** [focus_index n] sets the focus to the `col_id cell in the nth row from the top of the + entire table. The first row is 0, the second is 1, and so on. *) + val focus_index : ('k, 'col_id, 'presence) t -> int -> 'col_id -> unit Effect.t + + type ('k, 'col_id) optional = ('k, 'col_id, ('k * 'col_id) option) t +end + module By_row : sig type ('k, 'presence) t @@ -30,31 +52,42 @@ module By_row : sig end module Kind : sig - type ('a, 'presence, 'k) t = - | None : (unit, unit, 'k) t + type ('a, 'presence, 'k, 'col_id) t = + | None : (unit, unit, 'k, 'col_id) t | By_row : { on_change : ('k option -> unit Effect.t) Value.t ; compute_presence : 'k option Value.t -> 'presence Computation.t } - -> (('k, 'presence) By_row.t, 'presence, 'k) t + -> (('k, 'presence) By_row.t, 'presence, 'k, 'col_id) t + | By_cell : + { on_change : (('k * 'col_id) option -> unit Effect.t) Value.t + ; compute_presence : ('k * 'col_id) option Value.t -> 'presence Computation.t + } + -> (('k, 'col_id, 'presence) By_cell.t, 'presence, 'k, 'col_id) t end -type ('kind, 'key) t = +type ('key, 'col_id, 'kind) focused = + | Nothing_focused : ('key, 'col_id, _) focused + | Cell_focused : ('key * 'col_id) -> ('key, 'col_id, _ By_cell.t) focused + | Row_focused : 'key -> ('key, 'col_id, _ By_row.t) focused + +type ('kind, 'key, 'col_id) t = { focus : 'kind - ; visually_focused : 'key option + ; visually_focused : ('key, 'col_id, 'kind) focused } val component - : ('kind, 'presence, 'key) Kind.t + : ('kind, 'presence, 'key, 'col_id) Kind.t -> ('key, 'cmp) Bonsai.comparator + -> ('col_id, _) Bonsai.comparator -> collated:('key, 'data) Collated.t Value.t + -> leaves:'col_id Header_tree.leaf list Value.t -> range:(int * int) Value.t -> scroll_to_index:(int -> unit Effect.t) Value.t - -> ('kind, 'key) t Computation.t - -val get_focused : ('r, 'presence, _) Kind.t -> 'r Value.t -> 'presence Value.t + -> scroll_to_column:('col_id -> unit Effect.t) Value.t + -> ('kind, 'key, 'col_id) t Computation.t -val get_on_row_click - : ('r, _, 'key) Kind.t +val get_on_cell_click + : ('r, _, 'key, 'column) Kind.t -> 'r Value.t - -> ('key -> unit Effect.t) Value.t + -> ('key -> 'column -> unit Effect.t) Value.t diff --git a/web_ui/partial_render_table/src/header_tree.ml b/web_ui/partial_render_table/src/header_tree.ml index 38b01300..ef2a6f33 100644 --- a/web_ui/partial_render_table/src/header_tree.ml +++ b/web_ui/partial_render_table/src/header_tree.ml @@ -1,20 +1,21 @@ open! Core open! Bonsai_web -type t = - | Leaf of leaf - | Group of group - | Organizational_group of t list - | Spacer of t +type 'column_id t = + | Leaf of 'column_id leaf + | Group of 'column_id group + | Organizational_group of 'column_id t list + | Spacer of 'column_id t -and leaf = +and 'column_id leaf = { leaf_header : (Vdom.Node.t[@sexp.opaque]) ; initial_width : Css_gen.Length.t ; visible : bool + ; column_id : 'column_id } -and group = - { children : t list +and 'column_id group = + { children : 'column_id t list ; group_header : (Vdom.Node.t[@sexp.opaque]) } [@@deriving sexp] @@ -61,8 +62,8 @@ let column_names t = List.rev !results ;; -let leaf ~header:leaf_header ~initial_width ~visible = - Leaf { leaf_header; initial_width; visible } +let leaf ~header:leaf_header ~initial_width ~visible ~column_id = + Leaf { leaf_header; initial_width; visible; column_id } ;; let spacer t = Spacer t diff --git a/web_ui/partial_render_table/src/header_tree.mli b/web_ui/partial_render_table/src/header_tree.mli index f0a8049b..4a60ac1f 100644 --- a/web_ui/partial_render_table/src/header_tree.mli +++ b/web_ui/partial_render_table/src/header_tree.mli @@ -1,32 +1,39 @@ open! Core open! Bonsai_web -type t = private - | Leaf of leaf - | Group of group - | Organizational_group of t list - | Spacer of t +type 'column_id t = private + | Leaf of 'column_id leaf + | Group of 'column_id group + | Organizational_group of 'column_id t list + | Spacer of 'column_id t -and leaf = private +and 'column_id leaf = private { leaf_header : Vdom.Node.t ; initial_width : Css_gen.Length.t ; visible : bool + ; column_id : 'column_id } -and group = private - { children : t list +and 'column_id group = private + { children : 'column_id t list ; group_header : Vdom.Node.t } [@@deriving sexp] -val leaf : header:Vdom.Node.t -> initial_width:Css_gen.Length.t -> visible:bool -> t -val group : header:Vdom.Node.t -> t list -> t -val org_group : t list -> t -val colspan : t -> int -val height : t -> int -val leaves : t -> leaf list +val leaf + : header:Vdom.Node.t + -> initial_width:Css_gen.Length.t + -> visible:bool + -> column_id:'column_id + -> 'column_id t + +val group : header:Vdom.Node.t -> 'column_id t list -> 'column_id t +val org_group : 'column_id t list -> 'column_id t +val colspan : _ t -> int +val height : _ t -> int +val leaves : 'column_id t -> 'column_id leaf list (** For each leaf, [column_names] returns a list like [group_header; group_header; ...; leaf_header], where the group labels are that leaf's ancestors, ordered left to right from most to least distant. Used for rendering column groups in tests. *) -val column_names : t -> Vdom.Node.t list list +val column_names : _ t -> Vdom.Node.t list list diff --git a/web_ui/partial_render_table/src/table_body.ml b/web_ui/partial_render_table/src/table_body.ml index 3effe6f0..81196aa9 100644 --- a/web_ui/partial_render_table/src/table_body.ml +++ b/web_ui/partial_render_table/src/table_body.ml @@ -6,14 +6,19 @@ open! Incr_map_collate module For_testing = struct type cell = + { cell_focused : bool + ; view : Vdom.Node.t + } + + type row = { id : Opaque_map.Key.t - ; focused : bool - ; view : Vdom.Node.t list + ; row_focused : bool + ; cells : cell list } type t = { column_names : Vdom.Node.t list list - ; cells : cell list + ; rows : row list ; rows_before : int ; rows_after : int ; num_filtered : int @@ -22,41 +27,50 @@ module For_testing = struct end let rows - (type key cmp) + (type key cmp column_id column_id_cmp kind) ~themed_attrs - ~(comparator : (key, cmp) Bonsai.comparator) + ~(key_comparator : (key, cmp) Bonsai.comparator) + ~(column_id_comparator : (column_id, column_id_cmp) Bonsai.comparator) ~row_height - ~(leaves : Header_tree.leaf list Value.t) - ~column_widths - ~(visually_focused : key option Value.t) - ~on_row_click - (cells : (key * Vdom.Node.t list) Opaque_map.Key.Map.t Value.t) + ~(leaves : column_id Header_tree.leaf list Value.t) + ~(column_widths : (column_id, Column_size.t, column_id_cmp) Map.t Value.t) + ~(visually_focused : (key, column_id, kind) Focus.focused Value.t) + ~(on_cell_click : (key -> column_id -> unit Effect.t) Value.t) + (cells : (key * (column_id * Vdom.Node.t) list) Opaque_map.t Value.t) = + let module Key_cmp = (val key_comparator) in + let module Col_cmp = (val column_id_comparator) in let%sub col_widths = - let%arr col_widths = column_widths - and leaves = leaves in - List.mapi leaves ~f:(fun i _ -> - match Map.find col_widths i with - | Some (Column_size.Visible { width_px = w }) -> `Visible w - | Some (Hidden { prev_width_px = Some w }) -> `Hidden w - | None | Some (Hidden { prev_width_px = None }) -> `Hidden 0.0) + Bonsai.assoc column_id_comparator column_widths ~f:(fun _ column_width -> + match%arr column_width with + | Visible { width_px = w } -> `Visible w + | Hidden { prev_width_px = Some w } -> `Hidden w + | Hidden { prev_width_px = None } -> `Hidden 0.0) in + (* It's tempting to use [Bonsai.Map.unordered_fold] over the [col_widths], but some + columns in [col_widths] may not actually be present in the table. *) let%sub row_width = - let%arr col_widths = col_widths in - List.fold col_widths ~init:0.0 ~f:(fun acc -> function - | `Visible w -> acc +. w - | `Hidden _ -> acc) - in - let%sub cols_visible = - let%arr leaves = leaves in - List.map leaves ~f:(fun leaf -> leaf.visible) + let%arr col_widths = col_widths + and leaves = leaves in + List.sum + (module Float) + leaves + ~f:(fun leaf -> + match Map.find col_widths leaf.column_id with + | Some (`Visible w) -> w + | None | Some (`Hidden _) -> 0.0) in let%sub col_styles = - let%arr (`Px row_height) = row_height - and cols_visible = cols_visible + let%arr themed_attrs = themed_attrs + and (`Px row_height) = row_height and col_widths = col_widths - and themed_attrs = themed_attrs in - Table_view.Cell.Col_styles.create ~themed_attrs ~row_height ~col_widths ~cols_visible + and leaves = leaves in + Table_view.Cell.Col_styles.create + column_id_comparator + ~themed_attrs + ~row_height + ~col_widths + ~leaves in let%sub row_styles = let%arr (`Px row_height) = row_height @@ -67,44 +81,66 @@ let rows (module Opaque_map.Key) cells ~f:(fun _ key_and_cells -> - let%sub is_focused = + let%sub key, cells = return key_and_cells in + let%sub is_row_focused = let%arr visually_focused = visually_focused and key, _ = key_and_cells in - let module Cmp = (val comparator) in match visually_focused with - | None -> false - | Some k -> Cmp.comparator.compare k key = 0 + | Nothing_focused | Cell_focused _ -> false + | Row_focused k -> Comparable.equal Key_cmp.comparator.compare k key + in + let%sub focused_column_in_row = + let%arr visually_focused = visually_focused + and key = key in + match visually_focused with + | Nothing_focused | Row_focused _ -> None + | Cell_focused (k, c) -> + Option.some_if (Comparable.equal Key_cmp.comparator.compare k key) c in let%sub cells = - let%arr _, cell_contents = key_and_cells - and col_styles = col_styles in - List.mapi cell_contents ~f:(fun i content -> - let col_styles = col_styles i in - Table_view.Cell.view ~col_styles content) + let%sub is_focused = + match%arr focused_column_in_row with + | None -> fun _ -> false + | Some focused_column -> + fun column_id -> + Comparable.equal Col_cmp.comparator.compare focused_column column_id + in + let%arr col_styles = col_styles + and on_cell_click = on_cell_click + and is_focused = is_focused + and cells = cells + and themed_attrs = themed_attrs + and key = key in + let col_styles column_id = (Staged.unstage col_styles) column_id in + List.map cells ~f:(fun (column_id, cell) -> + Table_view.Cell.view + themed_attrs + ~is_focused:(is_focused column_id) + ~col_styles:(col_styles column_id) + ~on_cell_click:(on_cell_click key column_id) + cell) in let%arr themed_attrs = themed_attrs - and key, _ = key_and_cells and cells = cells - and is_focused = is_focused - and row_styles = row_styles - and on_row_click = on_row_click in - let on_row_click = on_row_click key in - Table_view.Row.view themed_attrs ~styles:row_styles ~is_focused ~on_row_click cells) + and is_row_focused = is_row_focused + and row_styles = row_styles in + Table_view.Row.view themed_attrs ~styles:row_styles ~is_focused:is_row_focused cells) ;; let component - (type key data cmp) + (type key data cmp col col_cmp kind) ~themed_attrs - ~(comparator : (key, cmp) Bonsai.comparator) + ~(key_comparator : (key, cmp) Bonsai.comparator) + ~(column_id_comparator : (col, col_cmp) Bonsai.comparator) ~row_height - ~(leaves : Header_tree.leaf list Value.t) - ~(headers : Header_tree.t Value.t) + ~(headers : col Header_tree.t Value.t) + ~(leaves : col Header_tree.leaf list Value.t) ~(assoc : (key * data) Opaque_map.t Value.t - -> (key * Vdom.Node.t list) Opaque_map.t Computation.t) + -> (key * (col * Vdom.Node.t) list) Opaque_map.t Computation.t) ~column_widths - ~(visually_focused : key option Value.t) - ~on_row_click + ~(visually_focused : (key, col, kind) Focus.focused Value.t) + ~on_cell_click (collated : (key, data) Collated.t Value.t) (input : (key * data) Opaque_map.t Value.t) : (Table_view.Body.t * For_testing.t Lazy.t) Computation.t @@ -120,12 +156,13 @@ let component let%sub rows = rows ~themed_attrs - ~comparator + ~key_comparator + ~column_id_comparator ~row_height ~leaves ~column_widths ~visually_focused - ~on_row_click + ~on_cell_click cells in let%sub view = @@ -142,15 +179,27 @@ let component lazy (let column_names = Header_tree.column_names headers in { For_testing.column_names - ; cells = + ; rows = List.map (Map.to_alist cells) ~f:(fun (id, (key, view)) -> - let focused = - let module Cmp = (val comparator) in + let module Key_cmp = (val key_comparator) in + let module Col_cmp = (val column_id_comparator) in + let row_focused = match visually_focused with - | None -> false - | Some k -> Cmp.comparator.compare k key = 0 + | Nothing_focused | Cell_focused _ -> false + | Row_focused k -> Comparable.equal Key_cmp.comparator.compare k key + in + let cells = + List.map view ~f:(fun (column, view) -> + let cell_focused = + match visually_focused with + | Nothing_focused | Row_focused _ -> false + | Cell_focused (k, c) -> + Comparable.equal Key_cmp.comparator.compare key k + && Comparable.equal Col_cmp.comparator.compare c column + in + { For_testing.view; cell_focused }) in - { For_testing.id; focused; view }) + { For_testing.id; row_focused; cells }) ; rows_before = Collated.num_before_range collated ; rows_after = Collated.num_after_range collated ; num_filtered = Collated.num_filtered_rows collated diff --git a/web_ui/partial_render_table/src/table_body.mli b/web_ui/partial_render_table/src/table_body.mli index d72da7fa..7b885783 100644 --- a/web_ui/partial_render_table/src/table_body.mli +++ b/web_ui/partial_render_table/src/table_body.mli @@ -6,14 +6,19 @@ open! Incr_map_collate module For_testing : sig type cell = + { cell_focused : bool + ; view : Vdom.Node.t + } + + type row = { id : Opaque_map.Key.t - ; focused : bool - ; view : Vdom.Node.t list + ; row_focused : bool + ; cells : cell list } type t = { column_names : Vdom.Node.t list list (** See [Header_tree.column_names]. *) - ; cells : cell list + ; rows : row list ; rows_before : int ; rows_after : int ; num_filtered : int @@ -23,16 +28,17 @@ end val component : themed_attrs:Table_view.Themed.t Value.t - -> comparator:('key, 'cmp) Bonsai.comparator + -> key_comparator:('key, 'cmp) Bonsai.comparator + -> column_id_comparator:('column_id, 'column_id_cmp) Bonsai.comparator -> row_height:[< `Px of int ] Value.t - -> leaves:Header_tree.leaf list Value.t - -> headers:Header_tree.t Value.t + -> headers:'column_id Header_tree.t Value.t + -> leaves:'column_id Header_tree.leaf list Value.t -> assoc: (('key * 'data) Opaque_map.t Value.t - -> ('key * Vdom.Node.t list) Opaque_map.t Computation.t) - -> column_widths:Column_size.t Int.Map.t Value.t - -> visually_focused:'key option Value.t - -> on_row_click:('key -> unit Effect.t) Value.t + -> ('key * ('column_id * Vdom.Node.t) list) Opaque_map.t Computation.t) + -> column_widths:('column_id, Column_size.t, 'column_id_cmp) Map.t Value.t + -> visually_focused:('key, 'column_id, 'kind) Focus.focused Value.t + -> on_cell_click:('key -> 'column_id -> unit Effect.t) Value.t -> ('key, 'data) Collated.t Value.t -> ('key * 'data) Opaque_map.t Value.t -> (Table_view.Body.t * For_testing.t Lazy.t) Computation.t diff --git a/web_ui/partial_render_table/src/table_header.ml b/web_ui/partial_render_table/src/table_header.ml index 12915b1e..88ab691b 100644 --- a/web_ui/partial_render_table/src/table_header.ml +++ b/web_ui/partial_render_table/src/table_header.ml @@ -5,25 +5,21 @@ open! Incr_map_collate open! Bonsai.Let_syntax module Acc = struct - type t = - { level_map : Table_view.Header.Header_cell.t list Int.Map.t - ; leaf_index : int - } + type t = { level_map : Table_view.Header.Header_cell.t list Int.Map.t } - let empty = { level_map = Int.Map.empty; leaf_index = 0 } + let empty = { level_map = Int.Map.empty } - let visit_leaf { level_map; leaf_index } ~level ~node = - let data = node leaf_index in - let level_map = Map.add_multi level_map ~key:level ~data in - { leaf_index = leaf_index + 1; level_map } + let visit_leaf { level_map } ~level ~node = + let level_map = Map.add_multi level_map ~key:level ~data:node in + { level_map } ;; - let visit_non_leaf { level_map; leaf_index } ~level ~node = + let visit_non_leaf { level_map } ~level ~node = let level_map = Map.add_multi level_map ~key:level ~data:node in - { leaf_index; level_map } + { level_map } ;; - let finalize ~themed_attrs { level_map; leaf_index = _ } = + let finalize ~themed_attrs { level_map } = level_map |> Map.data |> List.map ~f:(fun seq -> @@ -39,10 +35,10 @@ let rec render_header header ~themed_attrs ~level ~acc ~column_widths ~set_colum render_header ~themed_attrs ~level ~column_widths ~set_column_width in match header with - | Header_tree.Leaf { visible; leaf_header; initial_width } -> - let node index = + | Header_tree.Leaf { visible; leaf_header; initial_width; column_id } -> + let node = let column_width = - match Map.find column_widths index with + match Map.find column_widths column_id with | Some (Column_size.Visible { width_px = width }) | Some (Hidden { prev_width_px = Some width }) -> `Px_float width | None | Some (Hidden { prev_width_px = None }) -> initial_width @@ -50,7 +46,7 @@ let rec render_header header ~themed_attrs ~level ~acc ~column_widths ~set_colum Table_view.Header.Header_cell.leaf_view themed_attrs ~column_width - ~set_column_width:(set_column_width ~index) + ~set_column_width:(set_column_width ~column_id) ~visible ~label:leaf_header () @@ -86,10 +82,12 @@ let render_header ~themed_attrs headers ~column_widths ~set_column_width = ;; let component + (type column_id column_id_cmp) ~themed_attrs - (headers : Header_tree.t Value.t) - ~column_widths - ~set_column_width + (headers : column_id Header_tree.t Value.t) + ~(column_widths : (column_id, Column_size.t, column_id_cmp) Map.t Value.t) + ~(set_column_width : + (column_id:column_id -> [< `Px_float of float ] -> unit Effect.t) Value.t) ~set_header_client_rect = let%arr set_column_width = set_column_width diff --git a/web_ui/partial_render_table/src/table_header.mli b/web_ui/partial_render_table/src/table_header.mli index 11ea0ef6..7ae7ce05 100644 --- a/web_ui/partial_render_table/src/table_header.mli +++ b/web_ui/partial_render_table/src/table_header.mli @@ -6,9 +6,10 @@ open! Incr_map_collate val component : themed_attrs:Table_view.Themed.t Value.t - -> Header_tree.t Value.t - -> column_widths:Column_size.t Int.Map.t Value.t - -> set_column_width:(index:int -> [ `Px_float of float ] -> unit Vdom.Effect.t) Value.t + -> 'column_id Header_tree.t Value.t + -> column_widths:('column_id, Column_size.t, 'column_id_cmp) Map.t Value.t + -> set_column_width: + (column_id:'column_id -> [ `Px_float of float ] -> unit Vdom.Effect.t) Value.t -> set_header_client_rect: (Bonsai_web_ui_element_size_hooks.Visibility_tracker.Bbox.t -> unit Vdom.Effect.t) Value.t diff --git a/web_ui/partial_render_table/src/table_view.ml b/web_ui/partial_render_table/src/table_view.ml index 558997ae..0cdab3ed 100644 --- a/web_ui/partial_render_table/src/table_view.ml +++ b/web_ui/partial_render_table/src/table_view.ml @@ -15,6 +15,7 @@ module Themed = struct ; header_row : Vdom.Attr.t ; header : Vdom.Attr.t ; cell : Vdom.Attr.t + ; cell_focused : Vdom.Attr.t ; row : Vdom.Attr.t ; row_focused : Vdom.Attr.t ; body : Vdom.Attr.t @@ -37,6 +38,7 @@ module Themed = struct ; header_row = Vdom.Attr.empty ; header = Vdom.Attr.class_ "prt-table-header" ; cell = Vdom.Attr.class_ "prt-table-cell" + ; cell_focused = Vdom.Attr.class_ "prt-table-cell-selected" ; row = Vdom.Attr.class_ "prt-table-row" ; row_focused = Vdom.Attr.class_ "prt-table-row-selected" ; body = Vdom.Attr.empty @@ -48,6 +50,7 @@ module Themed = struct ; header_row = styling.header_row ; header = styling.header ; cell = styling.cell + ; cell_focused = styling.cell_focused ; row = styling.row ; row_focused = styling.row_focused ; body = styling.body @@ -258,37 +261,73 @@ module Cell = struct The reason that Css_gen is so slow is because apparently "sprintf" is _really_ slow. *) - let create ~(themed_attrs : Themed.t) ~row_height ~col_widths ~cols_visible = - let styles_arr = - List.map2_exn col_widths cols_visible ~f:(fun width is_visible -> - (* We use the previous width even when hidden, so that the rendering engine has - less work to do if re-adding a column. Columns that are not currently visible - are hidden via `display: None`. *) - let width = - match width with - | `Visible w | `Hidden w -> w + let create + (type column_id cmp) + (module Col_cmp : Bonsai.Comparator + with type t = column_id + and type comparator_witness = cmp) + ~(themed_attrs : Themed.t) + ~row_height + ~(col_widths : (column_id, [< `Hidden of float | `Visible of float ], cmp) Map.t) + ~(leaves : column_id Header_tree.leaf list) + = + let height_styles = + let h = int_to_px_string row_height in + Css_gen.( + create ~field:"height" ~value:h + @> create ~field:"min-height" ~value:h + @> create ~field:"max-height" ~value:h) + in + let styles_by_column = + List.map + leaves + ~f: + (fun + { visible = is_visible; column_id; leaf_header = _; initial_width = _ } -> + let width_styles = + (* We use the previous width even when hidden, so that the rendering engine has + less work to do if re-adding a column. Columns that are not currently visible + are hidden via `display: None`. *) + let width = + match Map.find col_widths column_id with + | None -> 0.0 + | Some (`Hidden width) | Some (`Visible width) -> width + in + let w = float_to_px_string width in + Css_gen.( + create ~field:"width" ~value:w + @> create ~field:"min-width" ~value:w + @> create ~field:"max-width" ~value:w) + in + let visible_styles = + match is_visible with + | false -> Css_gen.display `None + | true -> Css_gen.empty in - let h = int_to_px_string row_height in - let w = float_to_px_string width in - let open Css_gen in - (create ~field:"height" ~value:h - @> create ~field:"min-height" ~value:h - @> create ~field:"max-height" ~value:h - @> create ~field:"width" ~value:w - @> create ~field:"min-width" ~value:w - @> create ~field:"max-width" ~value:w - @> if is_visible then Css_gen.empty else display `None) - |> fun x -> [ themed_attrs.cell; Vdom.Attr.style x ]) - |> Array.of_list + ( column_id + , [ Vdom.Attr.style Css_gen.(height_styles @> width_styles @> visible_styles) + ; themed_attrs.cell + ] )) + |> Map.of_alist_exn (module Col_cmp) in - fun i -> Array.get styles_arr i + Staged.stage (fun column -> Map.find_exn styles_by_column column) ;; end type t = Vdom.Node.t - let view ~col_styles content = - set_or_wrap content ~attrs:(col_styles @ [ Functional_style.cell ]) + let view (themed_attrs : Themed.t) ~is_focused ~col_styles ~on_cell_click content = + let focused_attr = + if is_focused then themed_attrs.cell_focused else Vdom.Attr.empty + in + set_or_wrap + content + ~attrs: + (col_styles + @ [ Vdom.Attr.on_click (fun _ -> on_cell_click) + ; focused_attr + ; Functional_style.cell + ]) ;; end @@ -308,17 +347,18 @@ module Row = struct type t = Vdom.Node.t - let view (themed_attrs : Themed.t) ~styles ~is_focused ~on_row_click cells = + let view (themed_attrs : Themed.t) ~styles ~is_focused cells = let focused_attr = if is_focused then themed_attrs.row_focused else Vdom.Attr.empty in - Vdom.Node.div - ~attrs: - [ themed_attrs.row - ; Vdom.Attr.style styles - ; focused_attr - ; Vdom.Attr.on_click (fun _ -> on_row_click) - ; Functional_style.row - ] - cells + Vdom.Node.lazy_ + (lazy + (Vdom.Node.div + ~attrs: + [ themed_attrs.row + ; Vdom.Attr.style styles + ; focused_attr + ; Functional_style.row + ] + cells)) ;; end diff --git a/web_ui/partial_render_table/src/table_view.mli b/web_ui/partial_render_table/src/table_view.mli index 80d80231..b851ee0e 100644 --- a/web_ui/partial_render_table/src/table_view.mli +++ b/web_ui/partial_render_table/src/table_view.mli @@ -66,17 +66,25 @@ module Cell : sig type t val create - : themed_attrs:Themed.t + : (module Bonsai.Comparator + with type t = 'column_id + and type comparator_witness = 'cmp) + -> themed_attrs:Themed.t -> row_height:int - -> col_widths:[< `Hidden of float | `Visible of float ] list - -> cols_visible:bool list - -> int - -> t + -> col_widths:('column_id, [< `Hidden of float | `Visible of float ], 'cmp) Map.t + -> leaves:'column_id Header_tree.leaf list + -> ('column_id -> t) Staged.t end type t - val view : col_styles:Col_styles.t -> Vdom.Node.t -> t + val view + : Themed.t + -> is_focused:bool + -> col_styles:Col_styles.t + -> on_cell_click:unit Effect.t + -> Vdom.Node.t + -> t end module Row : sig @@ -88,13 +96,7 @@ module Row : sig type t - val view - : Themed.t - -> styles:Styles.t - -> is_focused:bool - -> on_row_click:unit Ui_effect.t - -> Cell.t list - -> t + val view : Themed.t -> styles:Styles.t -> is_focused:bool -> Cell.t list -> t end module Body : sig diff --git a/web_ui/partial_render_table/test/ansi_table_tests.ml b/web_ui/partial_render_table/test/ansi_table_tests.ml index e543dd33..077b21ce 100644 --- a/web_ui/partial_render_table/test/ansi_table_tests.ml +++ b/web_ui/partial_render_table/test/ansi_table_tests.ml @@ -10,8 +10,7 @@ let table_to_string ~include_stats ?(include_num_column = true) ?(selected_header = ">") - ?num_filtered_rows - (res : _ Table.Focus_by_row.t option) + ?(additional_summary = "") (for_testing : Table.For_testing.t) () = @@ -35,9 +34,11 @@ let table_to_string ~string_with_attr:(fun _attr str -> str) in let contents = - let focused = - Column.create selected_header (fun { Table.For_testing.Table_body.focused; _ } -> - if focused then "*" else "") + let row_focused = + Column.create + selected_header + (fun { Table.For_testing.Table_body.row_focused; _ } -> + if row_focused then "*" else "") in let num_column = Column.create "#" (fun { Table.For_testing.Table_body.id; _ } -> @@ -50,21 +51,24 @@ let table_to_string (List.map headers ~f:(fun header -> Node_h.unsafe_convert_exn header |> Node_h.inner_text)) in - Column.create header (fun { Table.For_testing.Table_body.view; _ } -> - List.nth_exn view i |> Node_h.unsafe_convert_exn |> Node_h.inner_text) + Column.create header (fun { Table.For_testing.Table_body.cells; _ } -> + List.nth_exn cells i + |> fun { Table.For_testing.Table_body.view; cell_focused; _ } -> + let text = view |> Node_h.unsafe_convert_exn |> Node_h.inner_text in + if cell_focused then [%string "> %{text} <"] else text) in let columns = match include_num_column with | false -> - focused :: (for_testing.body.column_names |> List.mapi ~f:ascii_column_of_leaf) + row_focused :: (for_testing.body.column_names |> List.mapi ~f:ascii_column_of_leaf) | true -> - focused + row_focused :: num_column :: (for_testing.body.column_names |> List.mapi ~f:ascii_column_of_leaf) in Ascii_table_kernel.draw columns - for_testing.body.cells + for_testing.body.rows ~limit_width_to:3000 ~prefer_split_on_spaces:false |> Option.value_exn @@ -73,23 +77,14 @@ let table_to_string ~string_with_attr:(fun _attr str -> str) in let result = if include_stats then stats ^ contents else contents in - match res with - | None -> result - | Some res -> - ([%message - "" - ~focused:(Table.Focus_by_row.focused res : int option) - ~num_filtered_rows:(num_filtered_rows : int option)] - |> Sexp.to_string_hum - |> fun s -> s ^ "\n") - ^ result + additional_summary ^ result ;; module Test = struct include Shared.Test let create_with_var - (type a) + (type a column_id) ?(stabilize_height = true) ?(visible_range = 0, 100) ?(map = Bonsai.Var.create small_map) @@ -105,6 +100,7 @@ module Test = struct ; get_testing ; get_inject ; get_num_filtered_rows + ; summarize_focus } = component (Bonsai.Var.value map) (Bonsai.Var.value filter_var) @@ -117,23 +113,21 @@ module Test = struct let out a = Lazy.force (get_testing a) let view a = + let num_filtered_rows = get_num_filtered_rows a in table_to_string - (Some (get_focus a)) + ~additional_summary:(summarize_focus ?num_filtered_rows (get_focus a)) (out a) - ?num_filtered_rows:(get_num_filtered_rows a) ~include_stats:stats () ;; - type incoming = Action.t + type incoming = column_id Action.t let incoming = get_inject end) component in - let t = - { handle; get_vdom; get_focus; input_var = map; filter_var; get_num_filtered_rows } - in + let t = { handle; get_vdom; input_var = map; filter_var; get_num_filtered_rows } in if should_set_bounds then set_bounds t ~low:min_vis ~high:max_vis; (* Because the component uses edge-triggering to propagate rank-range, we need to run the view-computers twice. *) @@ -185,6 +179,31 @@ let%expect_test "basic table" = └───┴─────┴─────┴───────┴──────────┴─────┘ |}] ;; +let%expect_test "basic table with cell focus" = + let test = + Test.create ~stats:true (Test.Component.default_cell_focus ~theming:`Themed ()) + in + Handle.show test.handle; + [%expect + {| +((focused ()) (num_filtered_rows (3))) +┌────────────────┬───────┐ +│ metric │ value │ +├────────────────┼───────┤ +│ rows-before │ 0 │ +│ rows-after │ 0 │ +│ num-filtered │ 3 │ +│ num-unfiltered │ 3 │ +└────────────────┴───────┘ +┌───┬─────┬─────┬───────┬──────────┬─────┐ +│ > │ # │ key │ a │ b │ d │ +├───┼─────┼─────┼───────┼──────────┼─────┤ +│ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ +│ │ 100 │ 1 │ there │ 2.000000 │ 2 │ +│ │ 200 │ 4 │ world │ 2.000000 │ --- │ +└───┴─────┴─────┴───────┴──────────┴─────┘ |}] +;; + let%expect_test "basic table with default sort" = let test = Test.create @@ -374,6 +393,113 @@ let%expect_test "REGRESSION: basic table with overriden column sort but no defau () ;; +let%expect_test "BUG: In basic tables with dynamic columns, the sorted column can change \ + if the order of columns changes" + = + let module Record = struct + module T = struct + type t = + { a : int + ; b : int + } + [@@deriving compare, equal, sexp] + end + + include T + include Comparator.Make (T) + end + in + let map = + [ 0; 1; 2 ] + |> List.map ~f:(fun i -> i, { Record.a = i; b = (i + 1) % 3 }) + |> Int.Map.of_alist_exn + |> Value.return + in + let a_before_b = Bonsai.Var.create false in + let columns = + let int_column name get_data = + Table.Basic.Columns.Dynamic_columns.column + ~header:(fun _ -> Vdom.Node.text name) + ~sort:(fun (_, a) (_, b) -> Int.ascending (get_data a) (get_data b)) + ~cell:(fun ~key:_ ~data -> Vdom.Node.text (Int.to_string (get_data data))) + () + in + let column_a = int_column "a" (fun (data : Record.t) -> data.a) in + let column_b = int_column "b" (fun (data : Record.t) -> data.b) in + let ordered = + let%map a_before_b = Bonsai.Var.value a_before_b in + if a_before_b then [ column_a; column_b ] else [ column_b; column_a ] + in + Table.Basic.Columns.Dynamic_columns.lift ordered + in + let component = + Table.Basic.component + ~theming:`Themed + ~focus:None + ~row_height:(Value.return (`Px 20)) + ~columns + (module Int) + map + in + let module Indexed_column_id = Table.Basic.Columns.Indexed_column_id in + let handle = + Handle.create + (module struct + type t = (unit, Indexed_column_id.t) Table.Basic.Result.t + type incoming = unit + + let view { Table.Basic.Result.for_testing; _ } = + table_to_string (Lazy.force for_testing) ~include_stats:false () + ;; + + let incoming { Table.Basic.Result.sortable_state; _ } () = + Table.Basic.Columns.Dynamic_columns.Sortable.inject + sortable_state + (* Sort ascending on the first column *) + (Set_sort (Indexed_column_id.of_int 0)) + ;; + end) + component + in + Handle.recompute_view_until_stable handle; + Handle.show handle; + [%expect + {| + ┌───┬─────┬───┬───┐ + │ > │ # │ b │ a │ + ├───┼─────┼───┼───┤ + │ │ 0 │ 1 │ 0 │ + │ │ 100 │ 2 │ 1 │ + │ │ 200 │ 0 │ 2 │ + └───┴─────┴───┴───┘ |}]; + Handle.do_actions handle [ () ]; + Handle.recompute_view_until_stable handle; + Handle.show handle; + [%expect + {| + ┌───┬─────┬───┬───┐ + │ > │ # │ b │ a │ + ├───┼─────┼───┼───┤ + │ │ 0 │ 0 │ 2 │ + │ │ 100 │ 1 │ 0 │ + │ │ 200 │ 2 │ 1 │ + └───┴─────┴───┴───┘ |}]; + Bonsai.Var.set a_before_b true; + Handle.recompute_view_until_stable handle; + Handle.show handle; + (* Notice that the order of the columns switched, but so has the sort order: column a + is now sorted ascending, and column b is no longer. This is a bug. *) + [%expect + {| + ┌───┬─────┬───┬───┐ + │ > │ # │ a │ b │ + ├───┼─────┼───┼───┤ + │ │ 0 │ 0 │ 1 │ + │ │ 100 │ 1 │ 2 │ + │ │ 200 │ 2 │ 0 │ + └───┴─────┴───┴───┘ |}] +;; + let%expect_test "big table" = let test = Test.create @@ -520,7 +646,7 @@ let%expect_test "table with col groups" = └───┴─────┴─────┴────────┴──────────┴─────────┴─────────┴─────────┘ |}] ;; -let%expect_test "focus down" = +let%expect_test "focus down in row-focus table" = let test = Test.create ~stats:false (Test.Component.default ~theming:`Themed ()) in Handle.show test.handle; [%expect @@ -563,7 +689,54 @@ let%expect_test "focus down" = └───┴─────┴─────┴───────┴──────────┴─────┘ |}] ;; -let%expect_test "focus up" = +let%expect_test "focus down in cell-focus table" = + let test = + Test.create ~stats:false (Test.Component.default_cell_focus ~theming:`Themed ()) + in + Handle.show test.handle; + [%expect + {| + ((focused ()) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────┼──────────┼─────┤ + │ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_down ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 0 at 0.0px + scrolling column with id 0 into view, if necessary + (focus_changed_to ((0 0))) + ((focused ((0 0))) (num_filtered_rows (3))) + ┌───┬─────┬───────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼───────┼───────┼──────────┼─────┤ + │ │ 0 │ > 0 < │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴───────┴───────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_down ]; + Handle.show test.handle; + [%expect + {| + skipping scroll because target already in view + scrolling column with id 0 into view, if necessary + (focus_changed_to ((1 0))) + ((focused ((1 0))) (num_filtered_rows (3))) + ┌───┬─────┬───────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼───────┼───────┼──────────┼─────┤ + │ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ + │ │ 100 │ > 1 < │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴───────┴───────┴──────────┴─────┘ |}] +;; + +let%expect_test "focus up in row-focus table" = let test = Test.create ~stats:false (Test.Component.default ~theming:`Themed ()) in Handle.show test.handle; [%expect @@ -606,6 +779,53 @@ let%expect_test "focus up" = └───┴─────┴─────┴───────┴──────────┴─────┘ |}] ;; +let%expect_test "focus up in cell-focus table" = + let test = + Test.create ~stats:false (Test.Component.default_cell_focus ~theming:`Themed ()) + in + Handle.show test.handle; + [%expect + {| + ((focused ()) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────┼──────────┼─────┤ + │ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_up ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 101 at 102.0px + scrolling column with id 0 into view, if necessary + (focus_changed_to ((4 0))) + ((focused ((4 0))) (num_filtered_rows (3))) + ┌───┬─────┬───────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼───────┼───────┼──────────┼─────┤ + │ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ > 4 < │ world │ 2.000000 │ --- │ + └───┴─────┴───────┴───────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_up ]; + Handle.show test.handle; + [%expect + {| + skipping scroll because target already in view + scrolling column with id 0 into view, if necessary + (focus_changed_to ((1 0))) + ((focused ((1 0))) (num_filtered_rows (3))) + ┌───┬─────┬───────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼───────┼───────┼──────────┼─────┤ + │ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ + │ │ 100 │ > 1 < │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴───────┴───────┴──────────┴─────┘ |}] +;; + let%expect_test "unfocus" = let test = Test.create ~stats:false (Test.Component.default ~theming:`Themed ()) in Handle.do_actions test.handle [ Focus_up ]; @@ -786,6 +1006,133 @@ let%expect_test "focus shadow (up)" = └───┴─────┴─────┴───────┴──────────┴─────┘ |}] ;; +let%expect_test "focus shadow (right)" = + let test = + Test.create ~stats:false (Test.Component.default_cell_focus ~theming:`Themed ()) + in + Handle.do_actions test.handle [ Focus_right ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 0 at 0.0px + scrolling column with id 0 into view, if necessary + (focus_changed_to ((0 0))) + ((focused ((0 0))) (num_filtered_rows (3))) + ┌───┬─────┬───────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼───────┼───────┼──────────┼─────┤ + │ │ 0 │ > 0 < │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴───────┴───────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_right ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 0 at 0.0px + scrolling column with id 1 into view, if necessary + (focus_changed_to ((0 1))) + ((focused ((0 1))) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────────┼──────────┼─────┤ + │ │ 0 │ 0 │ > hello < │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Unfocus ]; + Handle.show test.handle; + [%expect + {| + (focus_changed_to ()) + ((focused ()) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────┼──────────┼─────┤ + │ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_right ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 0 at 0.0px + scrolling column with id 2 into view, if necessary + (focus_changed_to ((0 2))) + ((focused ((0 2))) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────┬──────────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────┼──────────────┼─────┤ + │ │ 0 │ 0 │ hello │ > 1.000000 < │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────┴──────────────┴─────┘ |}] +;; + +let%expect_test "focus shadow (left)" = + let test = + Test.create ~stats:false (Test.Component.default_cell_focus ~theming:`Themed ()) + in + Handle.do_actions test.handle [ Focus_cell (0, 2) ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 0 at 0.0px + (focus_changed_to ((0 2))) + ((focused ((0 2))) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────┬──────────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────┼──────────────┼─────┤ + │ │ 0 │ 0 │ hello │ > 1.000000 < │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────┴──────────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_left ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 0 at 0.0px + scrolling column with id 1 into view, if necessary + (focus_changed_to ((0 1))) + ((focused ((0 1))) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────────┼──────────┼─────┤ + │ │ 0 │ 0 │ > hello < │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Unfocus ]; + Handle.show test.handle; + [%expect + {| + (focus_changed_to ()) + ((focused ()) (num_filtered_rows (3))) + ┌───┬─────┬─────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼─────┼───────┼──────────┼─────┤ + │ │ 0 │ 0 │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴─────┴───────┴──────────┴─────┘ |}]; + Handle.do_actions test.handle [ Focus_left ]; + Handle.show test.handle; + [%expect + {| + scrolling to index 0 at 0.0px + scrolling column with id 0 into view, if necessary + (focus_changed_to ((0 0))) + ((focused ((0 0))) (num_filtered_rows (3))) + ┌───┬─────┬───────┬───────┬──────────┬─────┐ + │ > │ # │ key │ a │ b │ d │ + ├───┼─────┼───────┼───────┼──────────┼─────┤ + │ │ 0 │ > 0 < │ hello │ 1.000000 │ 1 │ + │ │ 100 │ 1 │ there │ 2.000000 │ 2 │ + │ │ 200 │ 4 │ world │ 2.000000 │ --- │ + └───┴─────┴───────┴───────┴──────────┴─────┘ |}] +;; + let%expect_test "remove focused causes unfocus (down)" = let test = Test.create ~stats:false (Test.Component.default ~theming:`Themed ()) in Handle.do_actions test.handle [ Focus_down; Focus_down ]; @@ -2130,11 +2477,26 @@ let%expect_test "Pseudo-BUG: setting rank_range does not change the which rows t let handle = Handle.create (module struct - type t = int Table_expert.Focus.By_row.optional Table_expert.Result.t + type t = + ( int Table_expert.Focus.By_row.optional + , Indexed_column_id.t ) + Table_expert.Result.t + type incoming = Action.t let view { Table_expert.Result.for_testing; focus; _ } = - table_to_string (Some focus) (Lazy.force for_testing) ~include_stats:false () + let for_testing = Lazy.force for_testing in + let focused_row = Table_expert.Focus.By_row.focused focus in + let focus_summary = + [%message "" ~focused:(focused_row : int option)] + |> Sexp.to_string_hum + |> fun s -> [%string "%{s}\n"] + in + table_to_string + ~additional_summary:focus_summary + for_testing + ~include_stats:false + () ;; let incoming { Table_expert.Result.focus; _ } Action.Focus_down = @@ -2146,7 +2508,7 @@ let%expect_test "Pseudo-BUG: setting rank_range does not change the which rows t Handle.show handle; [%expect {| - ((focused ()) (num_filtered_rows ())) + (focused ()) ┌───┬─────┬────┬────┐ │ > │ # │ a │ b │ ├───┼─────┼────┼────┤ @@ -2162,7 +2524,7 @@ let%expect_test "Pseudo-BUG: setting rank_range does not change the which rows t {| scrolling to index 0 at 0.0px (focus_changed_to (1)) - ((focused (1)) (num_filtered_rows ())) + (focused (1)) ┌───┬─────┬────┬────┐ │ > │ # │ a │ b │ ├───┼─────┼────┼────┤ @@ -2175,7 +2537,7 @@ let%expect_test "Pseudo-BUG: setting rank_range does not change the which rows t Handle.show handle; [%expect {| - ((focused (1)) (num_filtered_rows ())) + (focused (1)) ┌───┬─────┬────┬────┐ │ > │ # │ a │ b │ ├───┼─────┼────┼────┤ @@ -2191,7 +2553,7 @@ let%expect_test "Pseudo-BUG: setting rank_range does not change the which rows t {| scrolling to index 1 at 40.0px (focus_changed_to ()) - ((focused ()) (num_filtered_rows ())) + (focused ()) ┌───┬─────┬────┬────┐ │ > │ # │ a │ b │ ├───┼─────┼────┼────┤ @@ -2211,7 +2573,7 @@ let%expect_test "Pseudo-BUG: setting rank_range does not change the which rows t (focus_changed_to (4)) scrolling to index 4 at 100.0px (focus_changed_to (5)) - ((focused (5)) (num_filtered_rows ())) + (focused (5)) ┌───┬─────┬────┬────┐ │ > │ # │ a │ b │ ├───┼─────┼────┼────┤ @@ -2763,14 +3125,16 @@ let%test_module "dynamic columns with visibility" = let%expect_test "REGRESSION: starting a column as invisible shouldn't crash" = let component, _set_visibility = setup ~visibility_starts_out_as:false in let (_ : _ Handle.t) = Handle.create (Result_spec.vdom Fn.id) component in - () + (); + [%expect {| |}] ;; let%expect_test "REGRESSION: toggling a column to be invisible shouldn't crash" = let component, set_visibility = setup ~visibility_starts_out_as:true in let handle = Handle.create (Result_spec.vdom Fn.id) component in set_visibility false; - Handle.recompute_view handle + Handle.recompute_view handle; + [%expect {| |}] ;; end) ;; diff --git a/web_ui/partial_render_table/test/ansi_table_tests.mli b/web_ui/partial_render_table/test/ansi_table_tests.mli index 85c17ba9..80684864 100644 --- a/web_ui/partial_render_table/test/ansi_table_tests.mli +++ b/web_ui/partial_render_table/test/ansi_table_tests.mli @@ -6,8 +6,7 @@ val table_to_string : include_stats:bool -> ?include_num_column:bool -> ?selected_header:string - -> ?num_filtered_rows:int - -> ('a, int option) Table.Focus_by_row.t option + -> ?additional_summary:string -> Table.For_testing.t -> unit -> string diff --git a/web_ui/partial_render_table/test/different_column_types_produce_same_vdom_tests.ml b/web_ui/partial_render_table/test/different_column_types_produce_same_vdom_tests.ml index 15844435..1ee4ce85 100644 --- a/web_ui/partial_render_table/test/different_column_types_produce_same_vdom_tests.ml +++ b/web_ui/partial_render_table/test/different_column_types_produce_same_vdom_tests.ml @@ -37,7 +37,7 @@ module Vdom_tests (Columns : Shared_with_bench.S) = struct let handle = Handle.create (module struct - type t = unit Prt.Result.t + type t = (unit, Columns.column_id) Prt.Result.t let view { Prt.Result.view; _ } = Virtual_dom_test_helpers.Node_helpers.unsafe_convert_exn view @@ -52,7 +52,7 @@ module Vdom_tests (Columns : Shared_with_bench.S) = struct [%expect {|
+ custom-css-vars=((--row-odd-fg_hash_replaced_in_test black)(--row-odd-bg_hash_replaced_in_test white)(--row-focused-fg_hash_replaced_in_test black)(--row-focused-border_hash_replaced_in_test #0a90bf)(--row-focused-bg_hash_replaced_in_test #e0f7ff)(--row-even-fg_hash_replaced_in_test black)(--row-even-bg_hash_replaced_in_test #e6e6e6)(--header-header-border_hash_replaced_in_test grey)(--header-fg_hash_replaced_in_test white)(--header-body-border_hash_replaced_in_test grey)(--header-bg_hash_replaced_in_test black)(--fg_hash_replaced_in_test black)(--cell-focused-fg_hash_replaced_in_test black)(--cell-focused-bg_hash_replaced_in_test #e0f7ff)(--body-body-border_hash_replaced_in_test grey)(--bg_hash_replaced_in_test white))> > @@ -110,7 +110,6 @@ module Vdom_tests (Columns : Shared_with_bench.S) = struct
JANE0
0.
0.
0
0.
0.
0
JANE1
1.
1.
1
1.
1.
1
JANE2
2.
2.
2
2.
2.
2
JANE3
3.
3.
3
3.
3.
3
JANE4
4.
4.
4
4.
4.
Vdom.Node.t ; get_num_filtered_rows : 'a -> int option - ; get_focus : 'a -> int Table.Focus.By_row.optional ; input_var : outer Int.Map.t Bonsai.Var.t ; filter_var : (key:int -> data:outer -> bool) Bonsai.Var.t } @@ -232,18 +239,24 @@ module Test = struct Effect.print_s [%message (focus_changed_to : int option)]) ;; + let focus_changed' = + Value.return (fun focus_changed_to -> + Effect.print_s [%message (focus_changed_to : (int * Indexed_column_id.t) option)]) + ;; + module Component = struct - type 'a t = + type ('a, 'focus, 'column_id) t = { component : 'a Computation.t ; get_vdom : 'a -> Vdom.Node.t - ; get_inject : 'a -> Action.t -> unit Ui_effect.t + ; get_inject : 'a -> 'column_id Action.t -> unit Ui_effect.t ; get_testing : 'a -> Bonsai_web_ui_partial_render_table.For_testing.t Lazy.t - ; get_focus : 'a -> int Table.Focus.By_row.optional + ; get_focus : 'a -> 'focus + ; summarize_focus : ?num_filtered_rows:int -> 'focus -> string ; get_num_filtered_rows : 'a -> int option } - let get_inject' t f = - let focus = f t in + let get_inject' t ~get_focus ~get_set_column_width = + let focus = get_focus t in let module Focus_control = Table.Focus.By_row in function | Action.Unfocus -> Focus_control.unfocus focus @@ -251,12 +264,72 @@ module Test = struct | Focus_up -> Focus_control.focus_up focus | Page_up -> Focus_control.page_up focus | Page_down -> Focus_control.page_down focus - | Focus k -> (Focus_control.focus focus) k + | Focus_row k -> (Focus_control.focus focus) k | Focus_index index -> (Focus_control.focus_index focus) index + | Focus_cell _ | Focus_left | Focus_right -> Effect.print_s [%message "Unsupported"] + | Set_column_width { column_id; width } -> + (get_set_column_width t) ~column_id (`Px_float width) + ;; + + let get_inject t = + get_inject' + t + ~get_focus:Table.Result.focus + ~get_set_column_width:Table.Result.set_column_width + ;; + + let get_inject_expert t = + get_inject' + t + ~get_focus:Table_expert.Result.focus + ~get_set_column_width:Table_expert.Result.set_column_width + ;; + + let get_inject_cell_focus' t ~get_focus ~get_set_column_width = + let focus = get_focus t in + let module Focus_control = Table.Focus.By_cell in + function + | Action.Unfocus -> Focus_control.unfocus focus + | Focus_down -> Focus_control.focus_down focus + | Focus_up -> Focus_control.focus_up focus + | Page_up -> Focus_control.page_up focus + | Page_down -> Focus_control.page_down focus + | Focus_cell (k, c) -> Focus_control.focus focus k (Indexed_column_id.of_int c) + | Focus_left -> Focus_control.focus_left focus + | Focus_right -> Focus_control.focus_right focus + | Focus_index _ | Focus_row _ -> Effect.print_s [%message "Unsupported"] + | Set_column_width { column_id; width } -> + (get_set_column_width t) ~column_id (`Px_float width) ;; - let get_inject t = get_inject' t Table.Result.focus - let get_inject_expert t = get_inject' t Table_expert.Result.focus + let get_inject_cell_focus t = + get_inject_cell_focus' + t + ~get_focus:Table.Result.focus + ~get_set_column_width:Table.Result.set_column_width + ;; + + let summarize_focus ?num_filtered_rows (focus : int Table.Focus.By_row.optional) = + [%message + "" + ~focused:(Table.Focus.By_row.focused focus : int option) + ~num_filtered_rows:(num_filtered_rows : int option)] + |> Sexp.to_string_hum + |> fun s -> s ^ "\n" + ;; + + let summarize_focus' + ?num_filtered_rows + (focus : (int, Indexed_column_id.t) Table.Focus.By_cell.optional) + = + [%message + "" + ~focused: + (Table.Focus.By_cell.focused focus : (int * Indexed_column_id.t) option) + ~num_filtered_rows:(num_filtered_rows : int option)] + |> Sexp.to_string_hum + |> fun s -> s ^ "\n" + ;; let default ~theming @@ -288,6 +361,41 @@ module Test = struct ; get_testing = Table.Result.for_testing ; get_focus = Table.Result.focus ; get_num_filtered_rows = (fun a -> Some (Table.Result.num_filtered_rows a)) + ; summarize_focus + } + ;; + + let default_cell_focus + ~theming + ?(preload_rows = 0) + ?(is_column_b_visible = Value.return true) + ?override_sort + ?default_sort + ?(use_legacy_header = false) + ?(row_height = Value.return (`Px 1)) + () + input + filter + = + let module Column = Table.Columns.Dynamic_cells in + { component = + Table.component + (module Int) + ~theming + ~focus:(By_cell { on_change = focus_changed' }) + ~filter + ?override_sort + ?default_sort + ~row_height + ~preload_rows + ~columns:(columns ~use_legacy_header ~is_column_b_visible () |> Column.lift) + input + ; get_vdom = Table.Result.view + ; get_inject = get_inject_cell_focus + ; get_testing = Table.Result.for_testing + ; get_focus = Table.Result.focus + ; get_num_filtered_rows = (fun a -> Some (Table.Result.num_filtered_rows a)) + ; summarize_focus = summarize_focus' } ;; @@ -320,6 +428,7 @@ module Test = struct ; get_focus = Table.Result.focus ; get_inject ; get_num_filtered_rows = (fun a -> Some (Table.Result.num_filtered_rows a)) + ; summarize_focus } ;; @@ -362,6 +471,7 @@ module Test = struct ; get_focus = Table_expert.Result.focus ; get_inject = get_inject_expert ; get_num_filtered_rows = (fun _ -> None) + ; summarize_focus } ;; end diff --git a/web_ui/partial_render_table/test/shared_with_bench.ml b/web_ui/partial_render_table/test/shared_with_bench.ml index 49bc1fde..d30438ce 100644 --- a/web_ui/partial_render_table/test/shared_with_bench.ml +++ b/web_ui/partial_render_table/test/shared_with_bench.ml @@ -35,7 +35,10 @@ module Row = struct end module type S = sig - val all : (int, Row.t) Expert.Columns.t + type column_id + + val first_column : column_id + val all : (int, Row.t, column_id) Expert.Columns.t end module Dynamic_cells : S = struct @@ -47,6 +50,10 @@ module Dynamic_cells : S = struct module Column = Expert.Columns.Dynamic_cells + type column_id = Indexed_column_id.t + + let first_column = Indexed_column_id.of_int 0 + let column_helper (type a) (module M : S with type t = a) @@ -89,6 +96,10 @@ module Dynamic_columns : S = struct module Column = Expert.Columns.Dynamic_columns + type column_id = Indexed_column_id.t + + let first_column = Indexed_column_id.of_int 0 + let column_helper (type a) (module M : S with type t = a) @@ -124,6 +135,10 @@ module Dynamic_experimental : S = struct include Comparator.Make (Row.Typed_field.Packed) end + type column_id = Col_id.t + + let first_column = Row.Typed_field.Packed.all |> List.hd_exn + let render_header col = let%arr { Row.Typed_field.Packed.f = T field } = col in Vdom.Node.text (Row.Typed_field.name field) @@ -148,7 +163,7 @@ module Dynamic_experimental : S = struct | Asize -> int value ;; - let all = + let (all : (int, Row.t, column_id) Expert.Columns.t) = Column.build (module Col_id) ~render_header diff --git a/web_ui/partial_render_table/test/shared_with_bench.mli b/web_ui/partial_render_table/test/shared_with_bench.mli index 58694fb9..4926c1b5 100644 --- a/web_ui/partial_render_table/test/shared_with_bench.mli +++ b/web_ui/partial_render_table/test/shared_with_bench.mli @@ -1,6 +1,7 @@ open! Core open! Bonsai_web open! Bonsai.Let_syntax +module Table := Bonsai_web_ui_partial_render_table module Row : sig type t = @@ -20,7 +21,10 @@ module Row : sig end module type S = sig - val all : (int, Row.t) Bonsai_web_ui_partial_render_table.Expert.Columns.t + type column_id + + val first_column : column_id + val all : (int, Row.t, column_id) Table.Expert.Columns.t end module Dynamic_cells : S diff --git a/web_ui/partial_render_table/test/vdom_based_tests.ml b/web_ui/partial_render_table/test/vdom_based_tests.ml index 92b36ee6..7f23fcc1 100644 --- a/web_ui/partial_render_table/test/vdom_based_tests.ml +++ b/web_ui/partial_render_table/test/vdom_based_tests.ml @@ -8,13 +8,13 @@ module Test = struct include Shared.Test let create - (type a) + (type a column_id) ?(visible_range = 0, 100) ?(map = small_map) ?(should_print_styles = false) ?(should_set_bounds = true) component - : a t + : (a, column_id) t = let min_vis, max_vis = visible_range in let input_var = Bonsai.Var.create map in @@ -22,9 +22,10 @@ module Test = struct let { Component.component ; get_vdom ; get_testing = _ - ; get_focus + ; get_focus = _ ; get_inject ; get_num_filtered_rows + ; summarize_focus = _ } = component (Bonsai.Var.value input_var) (Bonsai.Var.value filter_var) @@ -45,15 +46,13 @@ module Test = struct should_print_styles || not (String.is_prefix ~prefix:"style." key)) ;; - type incoming = Action.t + type incoming = column_id Action.t let incoming = get_inject end) component in - let t = - { handle; get_vdom; get_focus; input_var; filter_var; get_num_filtered_rows } - in + let t = { handle; get_vdom; input_var; filter_var; get_num_filtered_rows } in if should_set_bounds then set_bounds t ~low:min_vis ~high:max_vis; t ;; @@ -80,7 +79,7 @@ let print_assocs component = in let structure = component - |> Bonsai.Private.reveal_computation + |> Bonsai.Private.top_level_handle |> Bonsai.Private.pre_process |> sexp_of_computation in @@ -99,10 +98,10 @@ let%expect_test "simplified_assocs" = (Bonsai.Value.return (fun ~key:_ ~data:_ -> true)) in print_assocs component; - (* there's only one assoc because all the columns are inside of an assoc + (* there's only one stateful assoc because all the columns are inside of an assoc per-row instead of it being the other way around as you might have expected. *) - [%expect {| ((assoc_count 1) (assoc_simple_count 3) (assoc_on_count 1)) |}] + [%expect {| ((assoc_count 1) (assoc_simple_count 4) (assoc_on_count 1)) |}] ;; let%expect_test "simplified_assocs on the dynamic columns" = @@ -115,7 +114,7 @@ let%expect_test "simplified_assocs on the dynamic columns" = in print_assocs component; (* No assocs here because it just uses the Incr_map function directly *) - [%expect {| ((assoc_count 1) (assoc_simple_count 0) (assoc_on_count 0)) |}] + [%expect {| ((assoc_count 1) (assoc_simple_count 1) (assoc_on_count 0)) |}] ;; let%expect_test "column visibility" = @@ -133,146 +132,147 @@ let%expect_test "column visibility" = Handle.show_diff ~location_style:Separator test.handle; [%expect {| -=== DIFF HUNK === - class="header_cell header_label leaf_header" - size_tracker= - style={ - width: 50px; - }> -
-
- a + === DIFF HUNK === + class="header_cell header_label leaf_header" + size_tracker= + style={ + width: 50px; + }> +
+
+ a +
+
+ +
+ - - - + + + +
+ style={ + width: 50px; + +| display: none; + }> +
+
+ b +
+
+ 		+ === DIFF HUNK === + width: 0.00000000px; + min-width: 0.00000000px; + max-width: 0.00000000px; + }> + + hello + +
1.000000
+ +| display: none; + +| }> +
1
- - 		- style={ - width: 50px; -+| display: none; - }> -
-
- b + === DIFF HUNK === + width: 0.00000000px; + min-width: 0.00000000px; + max-width: 0.00000000px; + }> + + there +
+
2.000000
+ +| display: none; + +| }>
+
2
+ +
+ + world +
+
2.000000
+ +| display: none; + +| }> +
---
- 		-=== DIFF HUNK === - max-height: 1px; - width: 0.00000000px; - min-width: 0.00000000px; - max-width: 0.00000000px; - }> - - hello - -
1.000000
-+| display: none; -+| }> -
1
- -
- - there -
-
2.000000
-+| display: none; -+| }> -
2
- -
- - world -
-
2.000000
-+| display: none; -+| }> -
---
- - - |}] + |}] ;; let%expect_test "stabilization of view range" = @@ -286,103 +286,103 @@ let%expect_test "stabilization of view range" = Handle.show test.handle; [%expect {| -
- > - - - - - - - - -
> -
-
- key -
-
- 		> +
+ > + + + + + + + + +
> +
+
+ key +
+
+ 		> +
+
+ a +
+
+ 		> +
+
+ b +
+
+ 		> +
+
+ d +
+
+
+
> +
-
- a -
-
-
> -
-
- b +
+
0
+
+ + hello +
+
1.000000
+
1
-
-
> -
-
- d +
+
1
+
+ + there +
+
2.000000
+
2
-
-
> -
-
-
-
0
-
- - hello -
-
1.000000
-
1
-
-
-
1
-
- - there -
-
2.000000
-
2
-
-
-
|}]; + |}]; (* Change the visibility to show the rest of the nodes *) Handle.show_diff ~location_style:Separator test.handle; - [%expect {||}]; + [%expect {| |}]; Handle.recompute_view_until_stable test.handle; Handle.show_diff ~location_style:Separator test.handle; - [%expect {||}]; + [%expect {| |}]; Test.set_bounds test ~low:0 ~high:100; Handle.recompute_view_until_stable test.handle; Handle.show_diff ~location_style:Separator test.handle; [%expect {| === DIFF HUNK === -
+
hello
-
1.000000
-
1
+
1.000000
+
1
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
- +|
- +|
4
- +|
+ +|
+ +|
4
+ +|
+| +| world +|
- +|
2.000000
- +|
---
+ +|
2.000000
+ +|
---
+|
@@ -391,194 +391,206 @@ let%expect_test "stabilization of view range" = ;; let%expect_test "resize-column" = - let test = - Test.create ~should_print_styles:true (Test.Component.default ~theming:`Themed ()) + let resize_via_size_changed_hook (test : _ Test.t) ~idx ~width = + Test.resize_column test ~idx ~width in - Handle.recompute_view_until_stable test.handle; - Handle.store_view test.handle; - Test.resize_column test ~idx:0 ~width:10.0; - Handle.recompute_view_until_stable test.handle; - Handle.show_diff ~location_style:Separator test.handle; - [%expect - {| -=== DIFF HUNK === -
- > - - - - - - -
- style={ --| width: 50px; -+| width: 10.00px; - }> -
-
+ let test = + Test.create ~should_print_styles:true (Test.Component.default ~theming:`Themed ()) + in + Handle.recompute_view_until_stable test.handle; + Handle.store_view test.handle; + resize test ~idx:0 ~width:10.0; + Handle.recompute_view_until_stable test.handle; + Handle.show_diff ~location_style:Separator test.handle; + [%expect + {| + === DIFF HUNK === +
+ > + + + + + + +
+ style={ + -| width: 50px; + +| width: 10.00px; + }> +
+
+ key +
+
+ 		+ === DIFF HUNK === + + +
+
+ style={ + height: 3px; + }> +
+
+
- key +
0
+
+ + hello +
+
1.000000
+
1
-
-
-=== DIFF HUNK === - -
-
- style={ - height: 3px; - }> -
-
-
-
0
-
- - hello -
-
1.000000
-
1
-
-
-
1
-
- - there -
-
2.000000
-
2
-
-
-
4
-
- - world -
-
+
1
+
+ + there +
+
2.000000
+
2
+
+
+
4
+
+ + world +
+
- > - - - - - - - - -
> -
-
- key -
-
- 		> +
+ > + + + + + + + + +
> +
+
+ key +
+
+ 		> +
+
+ a +
+
+ 		> +
+
+ b +
+
+ 		> +
+
+ d +
+
+
+
> +
-
- a -
-
-
> -
-
- b +
+
51
+
+ + hi +
+
25.000000
+
100
-
-
> -
-
- d +
+
52
+
+ + hi +
+
26.000000
+
100
-
-
> -
-
-
-
51
-
- - hi -
-
25.000000
-
100
-
-
-
52
-
- - hi -
-
26.000000
-
100
-
-
-
|}]; +
|}]; (* extending the range upwards should only add to the end *) Test.set_bounds test ~low:55 ~high:60; Handle.recompute_view_until_stable test.handle; Handle.show_diff ~location_style:Separator test.handle; [%expect {| -=== DIFF HUNK === -
-
> -
-
- d + === DIFF HUNK === +
+
> +
+
+ d +
+
+
+
> +
+
+
+ -|
51
+ +|
55
+
+ + hi +
+ -|
25.000000
+ +|
27.000000
+
100
+
+
+ -|
52
+ +|
56
+
+ + hi +
+ -|
26.000000
+ +|
28.000000
+ +|
100
+ +|
+ +|
+ +|
57
+ +|
+ +| + +| hi + +|
+ +|
28.000000
+ +|
100
+ +|
+ +|
+ +|
58
+ +|
+ +| + +| hi + +|
+ +|
29.000000
+ +|
100
+ +|
+ +|
+ +|
59
+ +|
+ +| + +| hi + +|
+ +|
29.000000
+ +|
100
+ +|
+ +|
+ +|
60
+ +|
+ +| + +| hi + +|
+ +|
30.000000
+ +|
100
+ +|
+ +|
+ +|
61
+ +|
+ +| + +| hi + +|
+ +|
30.000000
+ +|
100
+ +|
+ +|
+ +|
62
+ +|
+ +| + +| hi + +|
+ +|
31.000000
+
100
- - - - -
> -
-
-
--|
51
-+|
55
-
- - hi -
--|
25.000000
-+|
27.000000
-
100
-
-
--|
52
-+|
56
-
- - hi -
--|
26.000000
-+|
28.000000
-+|
100
-+|
-+|
-+|
57
-+|
-+| -+| hi -+|
-+|
28.000000
-+|
100
-+|
-+|
-+|
58
-+|
-+| -+| hi -+|
-+|
29.000000
-+|
100
-+|
-+|
-+|
59
-+|
-+| -+| hi -+|
-+|
29.000000
-+|
100
-+|
-+|
-+|
60
-+|
-+| -+| hi -+|
-+|
30.000000
-+|
100
-+|
-+|
-+|
61
-+|
-+| -+| hi -+|
-+|
30.000000
-+|
100
-+|
-+|
-+|
62
-+|
-+| -+| hi -+|
-+|
31.000000
-
100
-
-
-
|}] +
|}] ;; let%expect_test "typing into a column, leaving that column, and then coming back. " = @@ -790,24 +802,24 @@ let%expect_test "typing into a column, leaving that column, and then coming back
>
-
-
51
-
+
+
51
+
-| hi +| hi hello world
-
25.000000
-
100
+
25.000000
+
100
-
-
52
-
+
+
52
+
hi
-
26.000000
-
100
+
26.000000
+
100
@@ -823,7 +835,7 @@ let%expect_test "typing into a column, leaving that column, and then coming back [%expect {|
+ custom-css-vars=((--row-odd-fg black)(--row-odd-bg white)(--row-focused-fg black)(--row-focused-border #0a90bf)(--row-focused-bg #e0f7ff)(--row-even-fg black)(--row-even-bg #e6e6e6)(--header-header-border grey)(--header-fg white)(--header-body-border grey)(--header-bg black)(--fg black)(--cell-focused-fg black)(--cell-focused-bg #e0f7ff)(--body-body-border grey)(--bg white))> > @@ -861,23 +873,23 @@ let%expect_test "typing into a column, leaving that column, and then coming back
>
-
-
51
-
+
+
51
+
hi hello world
-
25.000000
-
100
+
25.000000
+
100
-
-
52
-
+
+
52
+
hi
-
26.000000
-
100
+
26.000000
+
100
@@ -910,7 +922,7 @@ let%expect_test "table body is not recomputed more often than necessary" = (* Re-setting the bounds to the same value should not cause a re-fire *) Test.set_bounds test ~low:0 ~high:300; Handle.recompute_view test.handle; - [%expect {||}] + [%expect {| |}] ;; let%expect_test "table body is not recomputed more often than necessary" = @@ -959,6 +971,7 @@ let%expect_test "table body is not recomputed more often than necessary" = ; get_inject = Shared.Test.Component.get_inject_expert ; get_focus = Table_expert.Result.focus ; get_num_filtered_rows = (fun _ -> None) + ; summarize_focus = (fun ?num_filtered_rows:_ _ -> "") }) in Test.print_message_on_result_recomputation test; @@ -971,12 +984,12 @@ let%expect_test "table body is not recomputed more often than necessary" = Changed |}]; (* Sanity check: re-stabilizing after doing no actions does not cause recomputation *) Handle.recompute_view test.handle; - [%expect {||}]; + [%expect {| |}]; (* Changing the bounds should not cause a re-fire because we are doing our own collation and don't rely on result.bounds. *) Test.set_bounds test ~low:100 ~high:300; Handle.recompute_view test.handle; - [%expect {||}] + [%expect {| |}] ;; let%expect_test "test is browser" = @@ -993,66 +1006,66 @@ let%expect_test "sorting legacy renderer" = Handle.show test.handle; [%expect {| -
-
> - - - - - - - - -
> -
- ◇ key -
- 		> -
a
- 		> -
- ◇ b -
- 		> -
- ◇ d -
-
-
> -
-
-
-
0
-
- - hello -
-
1.000000
-
1
-
-
-
1
-
- - there -
-
2.000000
-
2
-
-
-
4
-
- - world +
+ > + + + + + + + + +
> +
+ ◇ key +
+ 		> +
a
+ 		> +
+ ◇ b +
+ 		> +
+ ◇ d +
+
+
> +
+
+
+
0
+
+ + hello +
+
1.000000
+
1
+
+
+
1
+
+ + there +
+
2.000000
+
2
+
+
+
4
+
+ + world +
+
2.000000
+
---
+
-
2.000000
-
---
-
-
-
|}]; +
|}]; (* this one is the key, clicking on it does nothing (it's already sorted by the key) *) Handle.click_on test.handle ~selector:"td:nth-child(1) > div" ~get_vdom:test.get_vdom; Handle.show_diff ~location_style:Separator test.handle; @@ -1060,7 +1073,7 @@ let%expect_test "sorting legacy renderer" = {| === DIFF HUNK ===
+ custom-css-vars=((--row-odd-fg black)(--row-odd-bg white)(--row-focused-fg black)(--row-focused-border #0a90bf)(--row-focused-bg #e0f7ff)(--row-even-fg black)(--row-even-bg #e6e6e6)(--header-header-border grey)(--header-fg white)(--header-body-border grey)(--header-bg black)(--fg black)(--cell-focused-fg black)(--cell-focused-bg #e0f7ff)(--body-body-border grey)(--bg white))> > @@ -1090,85 +1103,85 @@ let%expect_test "sorting legacy renderer" = Handle.show_diff ~location_style:Separator test.handle; [%expect {| -=== DIFF HUNK === -
-
> - - - - - - - - -
> -
--| ⬘ key -+| ◇ key -
- 		> -
a
- 		> -
--| ◇ b -+| ⬙ b -
- 		> -
- ◇ d -
-
-
> -
-
--|
--|
0
--|
--| --| hello --|
--|
1.000000
--|
1
--|
-
-
1
-
- - there -
-
2.000000
-
2
-
-
-
4
-
- - world + === DIFF HUNK === +
+ > + + + + + + + + +
> +
+ -| ⬘ key + +| ◇ key +
+ 		> +
a
+ 		> +
+ -| ◇ b + +| ⬙ b +
+ 		> +
+ ◇ d +
+
+
> +
+
+ -|
+ -|
0
+ -|
+ -| + -| hello + -|
+ -|
1.000000
+ -|
1
+ -|
+
+
1
+
+ + there +
+
2.000000
+
2
+
+
+
4
+
+ + world +
+
2.000000
+
---
+
+ +|
+ +|
0
+ +|
+ +| + +| hello + +|
+ +|
1.000000
+ +|
1
+ +|
-
2.000000
-
---
-+|
-+|
0
-+|
-+| -+| hello -+|
-+|
1.000000
-+|
1
-+|
-
-
-
|}]; +
|}]; Handle.click_on test.handle ~selector:"td:nth-child(3) > div" ~get_vdom:test.get_vdom; Handle.show_diff ~location_style:Separator test.handle; [%expect {| === DIFF HUNK ===
+ custom-css-vars=((--row-odd-fg black)(--row-odd-bg white)(--row-focused-fg black)(--row-focused-border #0a90bf)(--row-focused-bg #e0f7ff)(--row-even-fg black)(--row-even-bg #e6e6e6)(--header-header-border grey)(--header-fg white)(--header-body-border grey)(--header-bg black)(--fg black)(--cell-focused-fg black)(--cell-focused-bg #e0f7ff)(--body-body-border grey)(--bg white))> > @@ -1197,41 +1210,41 @@ let%expect_test "sorting legacy renderer" =
>
- +|
- +|
0
- +|
+ +|
+ +|
0
+ +|
+| +| hello +|
- +|
1.000000
- +|
1
+ +|
1.000000
+ +|
1
+|
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
- -|
- -|
0
- -|
+ -|
+ -|
0
+ -|
-| -| hello -|
- -|
1.000000
- -|
1
+ -|
1.000000
+ -|
1
-|
@@ -1269,15 +1282,14 @@ let%expect_test "sorting legacy renderer" =
>
-
-
0
-
+
+
0
+
hello
-
1.000000
-
1
- |}]; +
1.000000
+
1
|}]; (* but in reverse, notice that [None]s stay on the bottom *) Handle.click_on test.handle ~selector:"td:nth-child(4) > div" ~get_vdom:test.get_vdom; Handle.show_diff test.handle; @@ -1309,41 +1321,41 @@ let%expect_test "sorting legacy renderer" =
>
- +|
- +|
1
- +|
+ +|
+ +|
1
+ +|
+| +| there +|
- +|
2.000000
- +|
2
+ +|
2.000000
+ +|
2
+|
-
-
0
-
+
+
0
+
hello
-
1.000000
-
1
+
1.000000
+
1
- -|
- -|
1
- -|
+ -|
+ -|
1
+ -|
-| -| there -|
- -|
2.000000
- -|
2
+ -|
2.000000
+ -|
2
-|
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
@@ -1357,76 +1369,76 @@ let%expect_test "sorting default renderer" = Handle.show test.handle; [%expect {| -
-
> - - - - - - - - -
> -
-
- key -
-
- 		> +
+ > + + + + + + + + +
> +
+
+ key +
+
+ 		> +
+
+ a +
+
+ 		> +
+
+ b +
+
+ 		> +
+
+ d +
+
+
+
> +
-
- a +
+
0
+
+ + hello +
+
1.000000
+
1
-
-
> -
-
- b +
+
1
+
+ + there +
+
2.000000
+
2
-
-
> -
-
- d +
+
4
+
+ + world +
+
2.000000
+
---
-
-
> -
-
-
-
0
-
- - hello -
-
1.000000
-
1
-
-
-
1
-
- - there -
-
2.000000
-
2
-
-
-
4
-
- - world -
-
2.000000
-
---
-
-
-
|}]; +
|}]; (* this one is the key, clicking on it does nothing (it's already sorted by the key) *) Handle.click_on test.handle ~selector:"td:nth-child(1) > div" ~get_vdom:test.get_vdom; Handle.show_diff ~location_style:Separator test.handle; @@ -1434,7 +1446,7 @@ let%expect_test "sorting default renderer" = {| === DIFF HUNK ===
+ custom-css-vars=((--row-odd-fg black)(--row-odd-bg white)(--row-focused-fg black)(--row-focused-border #0a90bf)(--row-focused-bg #e0f7ff)(--row-even-fg black)(--row-even-bg #e6e6e6)(--header-header-border grey)(--header-fg white)(--header-body-border grey)(--header-bg black)(--fg black)(--cell-focused-fg black)(--cell-focused-bg #e0f7ff)(--body-body-border grey)(--bg white))> > @@ -1465,88 +1477,88 @@ let%expect_test "sorting default renderer" = Handle.show_diff ~location_style:Separator test.handle; [%expect {| -=== DIFF HUNK === -
-
> - - - - - - - - -
> -
-
- key --| ▲ -
-
- 		> + === DIFF HUNK === +
+ > + + + + + + + + +
> +
+
+ key + -| ▲ +
+
+ 		> +
+
+ a +
+
+ 		> +
+
+ b + +| ▼ +
+
+ 		> +
+
+ d +
+
+
+
> +
-
- a -
-
-
> -
-
- b -+| ▼ + -|
+ -|
0
+ -|
+ -| + -| hello + -|
+ -|
1.000000
+ -|
1
+ -|
+
+
1
+
+ + there +
+
2.000000
+
2
-
-
> -
-
- d +
+
4
+
+ + world +
+
2.000000
+
---
+ +|
+ +|
0
+ +|
+ +| + +| hello + +|
+ +|
1.000000
+ +|
1
+ +|
-
-
> -
-
--|
--|
0
--|
--| --| hello --|
--|
1.000000
--|
1
--|
-
-
1
-
- - there -
-
2.000000
-
2
-
-
-
4
-
- - world -
-
2.000000
-
---
-+|
-+|
0
-+|
-+| -+| hello -+|
-+|
1.000000
-+|
1
-+|
-
-
-
|}]; +
|}]; (* Click on second column, creating a multi-sort *) Handle.click_on ~shift_key_down:true @@ -1558,7 +1570,7 @@ let%expect_test "sorting default renderer" = {| === DIFF HUNK ===
+ custom-css-vars=((--row-odd-fg black)(--row-odd-bg white)(--row-focused-fg black)(--row-focused-border #0a90bf)(--row-focused-bg #e0f7ff)(--row-even-fg black)(--row-even-bg #e6e6e6)(--header-header-border grey)(--header-fg white)(--header-body-border grey)(--header-bg black)(--fg black)(--cell-focused-fg black)(--cell-focused-bg #e0f7ff)(--body-body-border grey)(--bg white))> > @@ -1606,7 +1618,7 @@ let%expect_test "sorting default renderer" = {| === DIFF HUNK ===
+ custom-css-vars=((--row-odd-fg black)(--row-odd-bg white)(--row-focused-fg black)(--row-focused-border #0a90bf)(--row-focused-bg #e0f7ff)(--row-even-fg black)(--row-even-bg #e6e6e6)(--header-header-border grey)(--header-fg white)(--header-body-border grey)(--header-bg black)(--fg black)(--cell-focused-fg black)(--cell-focused-bg #e0f7ff)(--body-body-border grey)(--bg white))>
> @@ -1646,41 +1658,41 @@ let%expect_test "sorting default renderer" =
>
- +|
- +|
0
- +|
+ +|
+ +|
0
+ +|
+| +| hello +|
- +|
1.000000
- +|
1
+ +|
1.000000
+ +|
1
+|
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
- -|
- -|
0
- -|
+ -|
+ -|
0
+ -|
-| -| hello -|
- -|
1.000000
- -|
1
+ -|
1.000000
+ -|
1
-|
diff --git a/web_ui/partial_render_table/test/vdom_based_tests_legacy_unthemed.ml b/web_ui/partial_render_table/test/vdom_based_tests_legacy_unthemed.ml index ef06c9fa..785785f3 100644 --- a/web_ui/partial_render_table/test/vdom_based_tests_legacy_unthemed.ml +++ b/web_ui/partial_render_table/test/vdom_based_tests_legacy_unthemed.ml @@ -8,13 +8,13 @@ module Test = struct include Shared.Test let create - (type a) + (type a column_id) ?(visible_range = 0, 100) ?(map = small_map) ?(should_print_styles = false) ?(should_set_bounds = true) component - : a t + : (a, column_id) t = let min_vis, max_vis = visible_range in let input_var = Bonsai.Var.create map in @@ -22,9 +22,10 @@ module Test = struct let { Component.component ; get_vdom ; get_testing = _ - ; get_focus + ; get_focus = _ ; get_inject ; get_num_filtered_rows + ; summarize_focus = _ } = component (Bonsai.Var.value input_var) (Bonsai.Var.value filter_var) @@ -45,15 +46,13 @@ module Test = struct should_print_styles || not (String.is_prefix ~prefix:"style." key)) ;; - type incoming = Action.t + type incoming = column_id Action.t let incoming = get_inject end) component in - let t = - { handle; get_vdom; get_focus; input_var; filter_var; get_num_filtered_rows } - in + let t = { handle; get_vdom; input_var; filter_var; get_num_filtered_rows } in if should_set_bounds then set_bounds t ~low:min_vis ~high:max_vis; t ;; @@ -117,7 +116,6 @@ let%expect_test "column visibility" = class="header_cell header_label leaf_header" size_tracker= === DIFF HUNK === - max-height: 1px; width: 0.00000000px; min-width: 0.00000000px; max-width: 0.00000000px; @@ -126,6 +124,7 @@ let%expect_test "column visibility" = hello
1
2
>
-
-
0
-
+
+
0
+
hello
-
1.000000
-
1
+
1.000000
+
1
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
@@ -307,30 +307,30 @@ let%expect_test "stabilization of view range" = [%expect {| === DIFF HUNK === -
+
hello
-
1.000000
-
1
+
1.000000
+
1
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
- +|
- +|
4
- +|
+ +|
+ +|
4
+ +|
+| +| world +|
- +|
2.000000
- +|
---
+ +|
2.000000
+ +|
---
+|
@@ -379,6 +379,7 @@ let%expect_test "resize-column" = class="header_cell header_label leaf_header" size_tracker= === DIFF HUNK === +
@@ -392,7 +393,6 @@ let%expect_test "resize-column" =
0
1.000000
1
1
2.000000
2
4
>
-
-
51
-
+
+
51
+
hi
-
25.000000
-
100
+
25.000000
+
100
-
-
52
-
+
+
52
+
hi
-
26.000000
-
100
+
26.000000
+
100
@@ -625,81 +628,81 @@ let%expect_test "big table" =
>
-
--|
51
-+|
55
-
+
+-|
51
++|
55
+
hi
--|
25.000000
-+|
27.000000
-
100
+-|
25.000000
++|
27.000000
+
100
-
--|
52
-+|
56
-
+
+-|
52
++|
56
+
hi
--|
26.000000
-+|
28.000000
-+|
100
+-|
26.000000
++|
28.000000
++|
100
+|
-+|
-+|
57
-+|
++|
++|
57
++|
+| +| hi +|
-+|
28.000000
-+|
100
++|
28.000000
++|
100
+|
-+|
-+|
58
-+|
++|
++|
58
++|
+| +| hi +|
-+|
29.000000
-+|
100
++|
29.000000
++|
100
+|
-+|
-+|
59
-+|
++|
++|
59
++|
+| +| hi +|
-+|
29.000000
-+|
100
++|
29.000000
++|
100
+|
-+|
-+|
60
-+|
++|
++|
60
++|
+| +| hi +|
-+|
30.000000
-+|
100
++|
30.000000
++|
100
+|
-+|
-+|
61
-+|
++|
++|
61
++|
+| +| hi +|
-+|
30.000000
-+|
100
++|
30.000000
++|
100
+|
-+|
-+|
62
-+|
++|
++|
62
++|
+| +| hi +|
-+|
31.000000
-
100
++|
31.000000
+
100
@@ -738,24 +741,24 @@ let%expect_test "typing into a column, leaving that column, and then coming back
>
-
-
51
-
+
+
51
+
-| hi +| hi hello world
-
25.000000
-
100
+
25.000000
+
100
-
-
52
-
+
+
52
+
hi
-
26.000000
-
100
+
26.000000
+
100
@@ -808,23 +811,23 @@ let%expect_test "typing into a column, leaving that column, and then coming back
>
-
-
51
-
+
+
51
+
hi hello world
-
25.000000
-
100
+
25.000000
+
100
-
-
52
-
+
+
52
+
hi
-
26.000000
-
100
+
26.000000
+
100
@@ -906,6 +909,7 @@ let%expect_test "table body is not recomputed more often than necessary" = ; get_inject = Shared.Test.Component.get_inject_expert ; get_focus = Table_expert.Result.focus ; get_num_filtered_rows = (fun _ -> None) + ; summarize_focus = (fun ?num_filtered_rows:_ _ -> "") }) in Test.print_message_on_result_recomputation test; @@ -969,32 +973,32 @@ let%expect_test "sorting legacy renderer" =
>
-
-
0
-
+
+
0
+
hello
-
1.000000
-
1
+
1.000000
+
1
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
@@ -1067,41 +1071,41 @@ let%expect_test "sorting legacy renderer" =
>
--|
--|
0
--|
+-|
+-|
0
+-|
-| -| hello -|
--|
1.000000
--|
1
+-|
1.000000
+-|
1
-|
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
-+|
-+|
0
-+|
++|
++|
0
++|
+| +| hello +|
-+|
1.000000
-+|
1
++|
1.000000
++|
1
+|
@@ -1141,41 +1145,41 @@ let%expect_test "sorting legacy renderer" =
>
- +|
- +|
0
- +|
+ +|
+ +|
0
+ +|
+| +| hello +|
- +|
1.000000
- +|
1
+ +|
1.000000
+ +|
1
+|
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
- -|
- -|
0
- -|
+ -|
+ -|
0
+ -|
-| -| hello -|
- -|
1.000000
- -|
1
+ -|
1.000000
+ -|
1
-|
@@ -1213,14 +1217,14 @@ let%expect_test "sorting legacy renderer" =
>
-
-
0
-
+
+
0
+
hello
-
1.000000
-
1
+
1.000000
+
1
|}]; (* but in reverse, notice that [None]s stay on the bottom *) Handle.click_on test.handle ~selector:"td:nth-child(4) > div" ~get_vdom:test.get_vdom; @@ -1253,41 +1257,41 @@ let%expect_test "sorting legacy renderer" =
>
- +|
- +|
1
- +|
+ +|
+ +|
1
+ +|
+| +| there +|
- +|
2.000000
- +|
2
+ +|
2.000000
+ +|
2
+|
-
-
0
-
+
+
0
+
hello
-
1.000000
-
1
+
1.000000
+
1
- -|
- -|
1
- -|
+ -|
+ -|
1
+ -|
-| -| there -|
- -|
2.000000
- -|
2
+ -|
2.000000
+ -|
2
-|
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
@@ -1339,32 +1343,32 @@ let%expect_test "sorting default renderer" =
>
-
-
0
-
+
+
0
+
hello
-
1.000000
-
1
+
1.000000
+
1
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
@@ -1448,41 +1452,41 @@ let%expect_test "sorting default renderer" =
>
--|
--|
0
--|
+-|
+-|
0
+-|
-| -| hello -|
--|
1.000000
--|
1
+-|
1.000000
+-|
1
-|
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
-+|
-+|
0
-+|
++|
++|
0
++|
+| +| hello +|
-+|
1.000000
-+|
1
++|
1.000000
++|
1
+|
@@ -1585,41 +1589,41 @@ let%expect_test "sorting default renderer" =
>
- +|
- +|
0
- +|
+ +|
+ +|
0
+ +|
+| +| hello +|
- +|
1.000000
- +|
1
+ +|
1.000000
+ +|
1
+|
-
-
1
-
+
+
1
+
there
-
2.000000
-
2
+
2.000000
+
2
-
-
4
-
+
+
4
+
world
-
2.000000
-
---
+
2.000000
+
---
- -|
- -|
0
- -|
+ -|
+ -|
0
+ -|
-| -| hello -|
- -|
1.000000
- -|
1
+ -|
1.000000
+ -|
1
-|
diff --git a/web_ui/popover/src/dune b/web_ui/popover/src/dune index 415ea5cc..31886b50 100644 --- a/web_ui/popover/src/dune +++ b/web_ui/popover/src/dune @@ -1,7 +1,12 @@ -(library (name bonsai_web_ui_popover) (public_name bonsai.web_ui_popover) - (preprocess (pps js_of_ocaml-ppx ppx_jane ppx_bonsai ppx_css)) +(library + (name bonsai_web_ui_popover) + (public_name bonsai.web_ui_popover) + (preprocess + (pps js_of_ocaml-ppx ppx_jane ppx_bonsai ppx_css)) (libraries bonsai bonsai_web core ppx_css.inline_css)) -(rule (targets style.ml style.mli style__generated.ml style__generated.mli) +(rule + (targets style.ml style.mli style__generated.ml style__generated.mli) (deps style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) \ No newline at end of file + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) diff --git a/web_ui/popover/test/dune b/web_ui/popover/test/dune index 0a5b8984..79df00b3 100644 --- a/web_ui/popover/test/dune +++ b/web_ui/popover/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_popover_test) +(library + (name bonsai_web_ui_popover_test) (libraries bonsai_web_ui_popover bonsai_web bonsai_web_test - virtual_dom.vdom_test_helpers core) - (preprocess (pps ppx_jane ppx_bonsai js_of_ocaml-ppx))) \ No newline at end of file + virtual_dom.vdom_test_helpers core) + (preprocess + (pps ppx_jane ppx_bonsai js_of_ocaml-ppx))) diff --git a/web_ui/query_box/src/dune b/web_ui/query_box/src/dune index aff44c7f..b5252afa 100644 --- a/web_ui/query_box/src/dune +++ b/web_ui/query_box/src/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_query_box) (public_name bonsai.web_ui_query_box) +(library + (name bonsai_web_ui_query_box) + (public_name bonsai.web_ui_query_box) (libraries bonsai_web core fuzzy_match.match fuzzy_match.search) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_pattern_bind ppx_bonsai))) diff --git a/web_ui/query_box/test/dune b/web_ui/query_box/test/dune index 60b1799b..f55d3d09 100644 --- a/web_ui/query_box/test/dune +++ b/web_ui/query_box/test/dune @@ -1,4 +1,6 @@ -(library (name test_bonsai_web_ui_query_box) +(library + (name test_bonsai_web_ui_query_box) (libraries bonsai_web_ui_query_box bonsai_web_test fuzzy_match.match - fuzzy_match.search) - (preprocess (pps ppx_bonsai ppx_jane ppx_quick_test))) \ No newline at end of file + fuzzy_match.search) + (preprocess + (pps ppx_bonsai ppx_jane ppx_quick_test))) diff --git a/web_ui/reorderable_list/src/dune b/web_ui/reorderable_list/src/dune index 8fc7bc00..348385db 100644 --- a/web_ui/reorderable_list/src/dune +++ b/web_ui/reorderable_list/src/dune @@ -1,5 +1,7 @@ -(library (name bonsai_web_ui_reorderable_list) +(library + (name bonsai_web_ui_reorderable_list) (public_name bonsai.web_ui_reorderable_list) (libraries core core_kernel.reversed_list bonsai_web - bonsai_web_ui_drag_and_drop bonsai_web_ui_element_size_hooks) - (preprocess (pps js_of_ocaml-ppx ppx_jane ppx_pattern_bind ppx_bonsai))) \ No newline at end of file + bonsai_web_ui_drag_and_drop bonsai_web_ui_element_size_hooks) + (preprocess + (pps js_of_ocaml-ppx ppx_jane ppx_pattern_bind ppx_bonsai))) diff --git a/web_ui/reorderable_list/test/dune b/web_ui/reorderable_list/test/dune index 9ad39170..48cfd7b2 100644 --- a/web_ui/reorderable_list/test/dune +++ b/web_ui/reorderable_list/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_reorderable_list_test) +(library + (name bonsai_web_ui_reorderable_list_test) (libraries bonsai_web_ui_reorderable_list bonsai_web_test core) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/scroll_utilities/dune b/web_ui/scroll_utilities/dune index e0585fdf..96567a4b 100644 --- a/web_ui/scroll_utilities/dune +++ b/web_ui/scroll_utilities/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_scroll_utilities) +(library + (name bonsai_web_ui_scroll_utilities) (public_name bonsai.web_ui_scroll_utilities) (libraries bonsai bonsai_web js_of_ocaml core) - (preprocess (pps ppx_jane js_of_ocaml-ppx))) \ No newline at end of file + (preprocess + (pps ppx_jane js_of_ocaml-ppx))) diff --git a/web_ui/search_bar/src/dune b/web_ui/search_bar/src/dune index 8bb1da70..1db195d4 100644 --- a/web_ui/search_bar/src/dune +++ b/web_ui/search_bar/src/dune @@ -1,2 +1,5 @@ -(library (name bonsai_web_ui_search_bar) (libraries bonsai_web core) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_pattern_bind ppx_bonsai))) \ No newline at end of file +(library + (name bonsai_web_ui_search_bar) + (libraries bonsai_web core) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_pattern_bind ppx_bonsai))) diff --git a/web_ui/search_bar/test/dune b/web_ui/search_bar/test/dune index 788749ea..8c64e541 100644 --- a/web_ui/search_bar/test/dune +++ b/web_ui/search_bar/test/dune @@ -1,3 +1,5 @@ -(library (name test_bonsai_web_ui_search_bar) +(library + (name test_bonsai_web_ui_search_bar) (libraries bonsai_web_ui_search_bar bonsai_web_test) - (preprocess (pps ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_jane))) diff --git a/web_ui/tabs/src/dune b/web_ui/tabs/src/dune index a4bf3f73..4db89db4 100644 --- a/web_ui/tabs/src/dune +++ b/web_ui/tabs/src/dune @@ -1,2 +1,5 @@ -(library (name bonsai_web_ui_tabs) (libraries bonsai_web core) - (preprocess (pps ppx_jane ppx_pattern_bind ppx_bonsai))) \ No newline at end of file +(library + (name bonsai_web_ui_tabs) + (libraries bonsai_web core) + (preprocess + (pps ppx_jane ppx_pattern_bind ppx_bonsai))) diff --git a/web_ui/tabs/test/dune b/web_ui/tabs/test/dune index 5e2f881a..ca1b2e82 100644 --- a/web_ui/tabs/test/dune +++ b/web_ui/tabs/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_tabs_test) +(library + (name bonsai_web_ui_tabs_test) (libraries bonsai_web_ui_tabs patdiff.expect_test_patdiff bonsai_web_test - core) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + core) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/tailwind_colors/dune b/web_ui/tailwind_colors/dune index 6eb6a888..aac0a704 100644 --- a/web_ui/tailwind_colors/dune +++ b/web_ui/tailwind_colors/dune @@ -1,2 +1,6 @@ -(library (name tailwind_colors) (public_name bonsai.tailwind_colors) - (libraries bin_prot core_kernel.enum) (preprocess (pps ppx_jane))) \ No newline at end of file +(library + (name tailwind_colors) + (public_name bonsai.tailwind_colors) + (libraries bin_prot core_kernel.enum) + (preprocess + (pps ppx_jane))) diff --git a/web_ui/toggle/src/dune b/web_ui/toggle/src/dune index 200282c9..d5789758 100644 --- a/web_ui/toggle/src/dune +++ b/web_ui/toggle/src/dune @@ -1,2 +1,6 @@ -(library (name bonsai_web_ui_toggle) (public_name bonsai.web_ui_toggle) - (libraries core virtual_dom) (preprocess (pps ppx_css))) \ No newline at end of file +(library + (name bonsai_web_ui_toggle) + (public_name bonsai.web_ui_toggle) + (libraries core virtual_dom) + (preprocess + (pps ppx_css))) diff --git a/web_ui/tree_layout/dune b/web_ui/tree_layout/dune index 5ab384ae..12fc5f86 100644 --- a/web_ui/tree_layout/dune +++ b/web_ui/tree_layout/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_tree_layout) - (public_name bonsai.web_ui_tree_layout) (libraries bonsai_web core) - (preprocess (pps ppx_jane ppx_css ppx_pattern_bind))) \ No newline at end of file +(library + (name bonsai_web_ui_tree_layout) + (public_name bonsai.web_ui_tree_layout) + (libraries bonsai_web core) + (preprocess + (pps ppx_jane ppx_css ppx_pattern_bind))) diff --git a/web_ui/typeahead/src/dune b/web_ui/typeahead/src/dune index 384c9495..e6be26d8 100644 --- a/web_ui/typeahead/src/dune +++ b/web_ui/typeahead/src/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_typeahead) (public_name bonsai.web_ui_typeahead) +(library + (name bonsai_web_ui_typeahead) + (public_name bonsai.web_ui_typeahead) (libraries core bonsai_web bonsai_web_ui_common_components) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/typeahead/test/dune b/web_ui/typeahead/test/dune index 4170d332..655069f7 100644 --- a/web_ui/typeahead/test/dune +++ b/web_ui/typeahead/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_ui_components_typeahead_test) +(library + (name bonsai_ui_components_typeahead_test) (libraries bonsai_web_ui_typeahead bonsai_web bonsai_web_test core - patdiff.expect_test_patdiff) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + patdiff.expect_test_patdiff) + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/url_var/src/dune b/web_ui/url_var/src/dune index 6434b6d3..376b22c7 100644 --- a/web_ui/url_var/src/dune +++ b/web_ui/url_var/src/dune @@ -1,5 +1,8 @@ -(library (name bonsai_web_ui_url_var) (public_name bonsai.web_ui_url_var) +(library + (name bonsai_web_ui_url_var) + (public_name bonsai.web_ui_url_var) (libraries uri bonsai bonsai_web core virtual_dom.html5_history re - uri_parsing ppx_typed_fields.typed_fields_lib - ppx_typed_fields.typed_variants_lib) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_typed_fields))) \ No newline at end of file + uri_parsing ppx_typed_fields.typed_fields_lib + ppx_typed_fields.typed_variants_lib) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_typed_fields))) diff --git a/web_ui/url_var/test/dune b/web_ui/url_var/test/dune index da53825d..e290ff71 100644 --- a/web_ui/url_var/test/dune +++ b/web_ui/url_var/test/dune @@ -1,4 +1,6 @@ -(library (name bonsai_web_ui_url_var_test) +(library + (name bonsai_web_ui_url_var_test) (libraries bonsai_web_ui_url_var bonsai_web uri_parsing_test core - base_quickcheck expect_test_helpers_core) - (preprocess (pps ppx_jane ppx_typed_fields))) \ No newline at end of file + base_quickcheck expect_test_helpers_core) + (preprocess + (pps ppx_jane ppx_typed_fields))) diff --git a/web_ui/vdom_node_with_map_children/dune b/web_ui/vdom_node_with_map_children/dune index fb94e614..bd84d15d 100644 --- a/web_ui/vdom_node_with_map_children/dune +++ b/web_ui/vdom_node_with_map_children/dune @@ -1,4 +1,6 @@ -(library (name vdom_node_with_map_children) +(library + (name vdom_node_with_map_children) (public_name bonsai.vdom_node_with_map_children) (libraries bonsai_web core js_of_ocaml jsoo_weak_collections) - (preprocess (pps js_of_ocaml-ppx ppx_jane))) \ No newline at end of file + (preprocess + (pps js_of_ocaml-ppx ppx_jane))) diff --git a/web_ui/view/form/dune b/web_ui/view/form/dune index 55158d68..8bf09b5b 100644 --- a/web_ui/view/form/dune +++ b/web_ui/view/form/dune @@ -1,2 +1,6 @@ -(library (name bonsai_web_ui_form_view) (public_name bonsai.web_ui_form_view) - (libraries core virtual_dom) (preprocess (pps ppx_jane ppx_css))) \ No newline at end of file +(library + (name bonsai_web_ui_form_view) + (public_name bonsai.web_ui_form_view) + (libraries core virtual_dom) + (preprocess + (pps ppx_jane ppx_css))) diff --git a/web_ui/view/src/bonsai_web_ui_view.ml b/web_ui/view/src/bonsai_web_ui_view.ml index 984e55a5..165f5f3d 100644 --- a/web_ui/view/src/bonsai_web_ui_view.ml +++ b/web_ui/view/src/bonsai_web_ui_view.ml @@ -373,14 +373,14 @@ module Theme = struct let%sub app_vdom = set_for_computation theme app in let%arr app_vdom = app_vdom and theme = theme in - with_attr [ App.top_attr theme ] app_vdom + with_attr [ force (App.top_attr theme) ] app_vdom ;; let set_for_app' theme app = let%sub result_and_vdom = set_for_computation theme app in let%arr result, app_vdom = result_and_vdom and theme = theme in - result, with_attr [ App.top_attr theme ] app_vdom + result, with_attr [ force (App.top_attr theme) ] app_vdom ;; let override_constants_for_computation ~f inside = diff --git a/web_ui/view/src/bonsai_web_ui_view.mli b/web_ui/view/src/bonsai_web_ui_view.mli index 0e1bf043..748b1f96 100644 --- a/web_ui/view/src/bonsai_web_ui_view.mli +++ b/web_ui/view/src/bonsai_web_ui_view.mli @@ -565,7 +565,7 @@ module For_components : sig end module App : sig - val top_attr : Theme.t -> Vdom.Attr.t + val top_attr : Theme.t -> Vdom.Attr.t Lazy.t end module Expert : sig diff --git a/web_ui/view/src/constants.ml b/web_ui/view/src/constants.ml index e7cd2a03..34a54c9d 100644 --- a/web_ui/view/src/constants.ml +++ b/web_ui/view/src/constants.ml @@ -53,6 +53,7 @@ module Table = struct { body_row_even : Fg_bg.t ; body_row_odd : Fg_bg.t ; body_row_focused : Fg_bg.t + ; body_cell_focused : Fg_bg.t ; header_row : Fg_bg.t ; header_header_border : Color.t ; header_body_border : Color.t diff --git a/web_ui/view/src/dune b/web_ui/view/src/dune index 78d836f9..e9c54e7e 100644 --- a/web_ui/view/src/dune +++ b/web_ui/view/src/dune @@ -1,11 +1,15 @@ -(library (name bonsai_web_ui_view) (public_name bonsai.web_ui_view) +(library + (name bonsai_web_ui_view) + (public_name bonsai.web_ui_view) (libraries bonsai bonsai_web_ui_form_view bonsai_web_ui_toggle core - virtual_dom.input_widgets virtual_dom) - (preprocess (pps ppx_jane ppx_bonsai ppx_css)) + virtual_dom.input_widgets virtual_dom) + (preprocess + (pps ppx_jane ppx_bonsai ppx_css)) (flags :standard -alert -private_bonsai_view_library)) (rule (targets card_style.ml card_style.mli card_style__generated.ml - card_style__generated.mli) + card_style__generated.mli) (deps card_style.css) - (action (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) \ No newline at end of file + (action + (bash "%{bin:css_inliner} %{deps} \"((rewrite ()))\""))) diff --git a/web_ui/view/src/expert.ml b/web_ui/view/src/expert.ml index c83cf2fc..40a6ab7f 100644 --- a/web_ui/view/src/expert.ml +++ b/web_ui/view/src/expert.ml @@ -22,22 +22,23 @@ let override_theme ((module M) : Theme.t) ~(f : t -> t) : Theme.t = end) ;; -module Style = -[%css -stylesheet - {| +let app_attr = + lazy + (Inline_css.Private.Dynamic.attr + {| @layer bonsai_web_ui_view.app { - :root:has(.app) { + :root { font-family: sans-serif; } - :root:has(.app) *, - :root:has(.app) *::before, - :root:has(.app) *::after { + :root *, + :root *::before, + :root *::after { box-sizing: border-box; } } -|}] +|}) +;; let default_theme = make_theme @@ -45,7 +46,7 @@ let default_theme = class c = object (self : #Underlying_intf.C.t) method theme_name = "default theme" - method app_attr = Style.app + method app_attr = app_attr method constants = let primary = @@ -79,6 +80,8 @@ let default_theme = ; body_row_odd = primary ; body_row_focused = { foreground = primary.foreground; background = info.background } + ; body_cell_focused = + { foreground = primary.foreground; background = info.background } ; header_row = header ; header_header_border = extreme_primary_border ; header_body_border = extreme_primary_border diff --git a/web_ui/view/src/for_prt.ml b/web_ui/view/src/for_prt.ml index f0efe881..0b74262e 100644 --- a/web_ui/view/src/for_prt.ml +++ b/web_ui/view/src/for_prt.ml @@ -6,6 +6,7 @@ type t = ; header_row : Vdom.Attr.t ; header : Vdom.Attr.t ; cell : Vdom.Attr.t + ; cell_focused : Vdom.Attr.t ; row : Vdom.Attr.t ; row_focused : Vdom.Attr.t ; body : Vdom.Attr.t @@ -65,6 +66,11 @@ stylesheet color: var(--row-focused-fg); } +.body_cell.body_cell_focused { + background: var(--cell-focused-bg); + color: var(--cell-focused-fg); +} + /* Borders. Probably due to a browser bug, if we use full borders AND contain:paint (subset of strict) in PRT, we'll get weird, glitchy double borders. Instead, cells/rows (except for the last cell/row) only paint their top/left borders. @@ -122,6 +128,10 @@ let table_attr (constants : Constants.t) = ~row_even_fg:(Css_gen.Color.to_string_css constants.table.body_row_even.foreground) ~row_odd_bg:(Css_gen.Color.to_string_css constants.table.body_row_odd.background) ~row_odd_fg:(Css_gen.Color.to_string_css constants.table.body_row_odd.foreground) + ~cell_focused_bg: + (Css_gen.Color.to_string_css constants.table.body_cell_focused.background) + ~cell_focused_fg: + (Css_gen.Color.to_string_css constants.table.body_cell_focused.foreground) ~row_focused_bg: (Css_gen.Color.to_string_css constants.table.body_row_focused.background) ~row_focused_fg: @@ -142,6 +152,7 @@ let default constants = ; header_row = Default_table_styling.header_row ; header = Default_table_styling.header ; cell = Default_table_styling.body_cell + ; cell_focused = Default_table_styling.body_cell_focused ; row = Default_table_styling.body_row ; row_focused = Default_table_styling.body_row_focused ; body = Default_table_styling.body diff --git a/web_ui/view/src/for_prt.mli b/web_ui/view/src/for_prt.mli index 1f616989..5b898df1 100644 --- a/web_ui/view/src/for_prt.mli +++ b/web_ui/view/src/for_prt.mli @@ -6,6 +6,7 @@ type t = ; header_row : Vdom.Attr.t ; header : Vdom.Attr.t ; cell : Vdom.Attr.t + ; cell_focused : Vdom.Attr.t ; row : Vdom.Attr.t ; row_focused : Vdom.Attr.t ; body : Vdom.Attr.t diff --git a/web_ui/view/src/underlying_intf.ml b/web_ui/view/src/underlying_intf.ml index a294dc94..c0c07716 100644 --- a/web_ui/view/src/underlying_intf.ml +++ b/web_ui/view/src/underlying_intf.ml @@ -53,7 +53,7 @@ module C = struct -> tooltip:Vdom.Node.t -> Vdom.Node.t - method app_attr : Vdom.Attr.t + method app_attr : Vdom.Attr.t Lazy.t method codemirror_theme : For_codemirror.Theme.t option method prt_styling : For_prt.t diff --git a/web_ui/view/test/bonsai_web_ui_view_test.ml b/web_ui/view/test/bonsai_web_ui_view_test.ml index 7f8075fb..131241ea 100644 --- a/web_ui/view/test/bonsai_web_ui_view_test.ml +++ b/web_ui/view/test/bonsai_web_ui_view_test.ml @@ -1088,14 +1088,14 @@ let%expect_test "devbar" = ;; let%expect_test "app" = - let basic theme = Vdom.Node.div ~attrs:[ View.App.top_attr theme ] [] in + let basic theme = Vdom.Node.div ~attrs:[ force (View.App.top_attr theme) ] [] in themed_component [ "basic", basic ]; [%expect {| # default theme ## basic ```html -
+
``` # kado v1 diff --git a/web_ui/view/test/dune b/web_ui/view/test/dune index 4abce020..6ad2f9fc 100644 --- a/web_ui/view/test/dune +++ b/web_ui/view/test/dune @@ -1,3 +1,5 @@ -(library (name bonsai_web_ui_view_test) +(library + (name bonsai_web_ui_view_test) (libraries bonsai_web bonsai_web_test kado core expect_test_helpers_core) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/visibility/dune b/web_ui/visibility/dune index d74c91c3..5c67b7c8 100644 --- a/web_ui/visibility/dune +++ b/web_ui/visibility/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_visibility) - (public_name bonsai.web_ui_visibility) (libraries core bonsai_web) - (preprocess (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css))) \ No newline at end of file +(library + (name bonsai_web_ui_visibility) + (public_name bonsai.web_ui_visibility) + (libraries core bonsai_web) + (preprocess + (pps ppx_jane js_of_ocaml-ppx ppx_bonsai ppx_css))) diff --git a/web_ui/widget/src/dune b/web_ui/widget/src/dune index c2c9749d..ef4d3748 100644 --- a/web_ui/widget/src/dune +++ b/web_ui/widget/src/dune @@ -1,3 +1,6 @@ -(library (name bonsai_web_ui_widget) (public_name bonsai.web_ui_widget) +(library + (name bonsai_web_ui_widget) + (public_name bonsai.web_ui_widget) (libraries bonsai_web core js_of_ocaml) - (preprocess (pps ppx_jane ppx_bonsai))) \ No newline at end of file + (preprocess + (pps ppx_jane ppx_bonsai))) diff --git a/web_ui/widget/test/dune b/web_ui/widget/test/dune index 08846db4..93199aad 100644 --- a/web_ui/widget/test/dune +++ b/web_ui/widget/test/dune @@ -1,3 +1,5 @@ -(library (name mutable_state_tracker_test) +(library + (name mutable_state_tracker_test) (libraries core bonsai_web_ui_widget bonsai_test) - (preprocess (pps ppx_bonsai ppx_jane))) \ No newline at end of file + (preprocess + (pps ppx_bonsai ppx_jane)))