Compare commits

...

31 Commits

Author SHA1 Message Date
Frédéric Bour 77351d2e2c Test Lwd_seq.sort_uniq in focustest 2022-04-03 19:38:46 +09:00
Frédéric Bour ca68a42d35 Implement Lwd_seq.sort_uniq (POC) 2022-04-03 19:38:31 +09:00
Frédéric Bour 3b093a572a Revert "REMOVE ME: Disable inline tests"
This reverts commit 5ab38ed701.
2022-02-26 19:50:39 +09:00
Frédéric Bour 3fcf7c0696 Add strict dependency on self-version in sub-packages 2022-02-26 19:50:20 +09:00
Frédéric Bour 4f6c9ea387 Depend on notty >= 0.2 2022-02-25 09:45:53 +09:00
Frédéric Bour 5ab38ed701 REMOVE ME: Disable inline tests 2022-02-23 10:26:36 +09:00
Frédéric Bour ef73c77ea8 Stricter dependencies 2022-02-22 18:42:07 +09:00
Frédéric Bour a703fcb6f7 Upgrade build to dune 2.7
Please the gods of linting.
2022-02-21 11:17:41 +09:00
Frédéric Bour 5441e4a388 Remove Lwd_infix dependency from exemples 2022-02-21 11:10:55 +09:00
Frédéric Bour 1b8801af45 Update CHANGES
... and remove a spurious dune-project file that made its way to the
repo.
2022-02-20 21:01:16 +09:00
Frédéric Bour c229f9cff2 Fix cbor_explorer 2022-02-20 20:48:06 +09:00
Frédéric Bour e38469ddad Add a brr test 2022-02-20 20:47:47 +09:00
Frédéric Bour adebdfa2c3 Add fixpoint operator 2022-02-13 17:36:40 +09:00
Frédéric Bour 5702aa5287 Specialize min/max/clamp on integers and floats 2021-10-18 13:49:56 +09:00
Score_Under 7b2b63c65b Prevent splits from being moved out of bounds (becoming irrecoverable if released) 2021-10-18 06:19:05 +02:00
Frédéric Bour e1587add76 Fix conditions for triggering permanent sensors 2021-10-15 22:38:21 +09:00
Frédéric Bour 3bfeca4d37 Fix tyxml, update constraints 2021-09-01 11:34:57 +09:00
Frédéric Bour 33dbd25b04 Elwd.attach_attribs: catch removed attributes 2021-04-22 08:59:00 +02:00
Frédéric Bour b3b6b0a46d backport tyxml patch to brr 2021-04-06 21:19:41 +02:00
Frédéric Bour 1c0c26975b focus preserving patches for tyxml 2021-04-06 20:17:03 +02:00
Frédéric Bour e361cadacc Port performance fix to tyxml 2021-04-06 14:01:30 +02:00
Frédéric Bour 406a2c7eb8 Tweak performance 2021-04-06 12:00:55 +02:00
Frédéric Bour 55a5297a3b Add brr-lwd library 2021-04-06 10:01:38 +02:00
Frédéric Bour 46e1fe7386 brr-lwd 2021-04-06 09:58:36 +02:00
Frédéric Bour e91cb0bcaa fix inline test following 0138f22826/.github/workflows/main.yml 2021-04-02 15:05:42 +02:00
Frédéric Bour ff76941eda caching in actions?! 2021-04-02 14:57:04 +02:00
Frédéric Bour c4a2d18ce4 tweak github workflow 2021-04-02 14:44:59 +02:00
Frédéric Bour 4d72cb6984 Update workflow 2021-04-02 13:55:43 +02:00
Frédéric Bour 6d74d2c00d Proper implementation of scrollbox 2021-04-02 13:38:24 +02:00
Frédéric Bour 022cd7a92e Working scrollbox :)) 2021-04-02 13:19:33 +02:00
Frédéric Bour 0fe8b311dd WIP: scrollbox 2021-03-15 11:56:39 +01:00
52 changed files with 1822 additions and 222 deletions

View File

@ -3,27 +3,40 @@ on: [push, pull_request]
jobs:
run:
name: Build
runs-on: ${{ matrix.operating-system }}
strategy:
fail-fast: false
matrix:
operating-system: [ubuntu-latest]
# operating-system: [macos-latest, ubuntu-latest, windows-latest]
ocaml-version: [ '4.03.0', '4.04.2', '4.05.0', '4.06.1', '4.07.1', '4.08.1', '4.09.1', '4.10.1', '4.11.1' ]
os:
- macos-latest
- ubuntu-latest
#- windows-latest
ocaml-version:
- 4.11.1
- 4.10.1
- 4.09.1
- 4.08.1
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v2
- name: Cache
uses: actions/cache@v2
with:
# A directory to store and save the cache
path: ~/.opam
# An explicit key for restoring and saving the cache
key: ${{ matrix.os }}-${{ matrix.ocaml-version }}-${{ hashFiles('*.opam') }}-build
- name: Set up OCaml ${{ matrix.ocaml-version }}
uses: avsm/setup-ocaml@v1
with:
ocaml-version: ${{ matrix.ocaml-version }}
- run: opam pin -n .
- run: opam depext -yt lwd nottui nottui-lwt
- run: opam install -t . --deps-only
- run: opam exec -- dune build
- run: opam exec -- dune runtest
- name: Checkout code
uses: actions/checkout@v2
- name: Cache
uses: actions/cache@v2
with:
# A directory to store and save the cache
path: ~/.opam
# An explicit key for restoring and saving the cache
key: ${{ matrix.os }}-${{ matrix.ocaml-version }}-${{ hashFiles('*.opam') }}-build
- name: Use OCaml ${{ matrix.ocaml-version }}
uses: avsm/setup-ocaml@v1
with:
ocaml-version: ${{ matrix.ocaml-version }}
- run: opam pin -n .
# more recent dune breaks the inline tests… because of warn-error 😱
- run: opam pin dune 2.7.1 -y -n
- run: opam depext -yt lwd nottui nottui-lwt
- run: opam install -t . --deps-only
- run: opam install -y containers cbor js_of_ocaml js_of_ocaml-lwt
- run: opam exec -- dune build
- run: opam exec -- dune runtest

14
CHANGES
View File

@ -1,3 +1,17 @@
v0.2 - Alpha 0.2
======
Sun Feb 20 20:49:47 JST 2022
- Lwd.fix operator helps working with graphs that cannot be evaluated in a
single pass
- brr-lwd library integrates Lwd with Brr library, for writing javascript
applications
Bug fixes:
- fixed invalidation in Lwd
- restored some internal invariants in Lwd_seq
- fixed behavior of Notty sensors
v0.1 - Alpha 0.1
======
Wed Sep 23 14:51:17 CEST 2020

31
brr-lwd.opam Normal file
View File

@ -0,0 +1,31 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Make reactive webpages in Js_of_ocaml using Brr and Lwd"
maintainer: ["fred@tarides.com"]
authors: ["Frédéric Bour"]
license: "MIT"
homepage: "https://github.com/let-def/lwd"
doc: "https://let-def.github.io/lwd/doc"
bug-reports: "https://github.com/let-def/lwd/issues"
depends: [
"dune" {>= "2.7"}
"lwd" {= version}
"brr"
"js_of_ocaml"
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/let-def/lwd.git"

View File

@ -1,4 +1,4 @@
(lang dune 2.0)
(lang dune 2.7)
(generate_opam_files true)
(name lwd)
@ -11,7 +11,7 @@
(name lwd)
(synopsis "Lightweight reactive documents")
(documentation "https://let-def.github.io/lwd/doc")
(depends (dune (>= 2.0)) seq (ocaml (>= "4.03"))
(depends dune seq (ocaml (>= "4.03"))
(qtest :with-test)
(qcheck :with-test)))
@ -19,22 +19,28 @@
(name nottui)
(synopsis "UI toolkit for the terminal built on top of Notty and Lwd")
(documentation "https://let-def.github.io/lwd/doc")
(depends (dune (>= 2.0)) lwd notty))
(depends (lwd (= :version)) (notty (>= 0.2))))
(package
(name tyxml-lwd)
(synopsis "Make reactive webpages in Js_of_ocaml using Tyxml and Lwd")
(documentation "https://let-def.github.io/lwd/doc")
(depends dune lwd tyxml js_of_ocaml js_of_ocaml-ppx))
(depends (lwd (= :version)) (tyxml (>= 4.5.0)) js_of_ocaml js_of_ocaml-ppx))
(package
(name brr-lwd)
(synopsis "Make reactive webpages in Js_of_ocaml using Brr and Lwd")
(documentation "https://let-def.github.io/lwd/doc")
(depends (lwd (= :version)) brr js_of_ocaml))
(package
(name nottui-pretty)
(synopsis "A pretty-printer based on PPrint rendering UIs")
(documentation "https://let-def.github.io/lwd/doc")
(depends (dune (>= 2.0)) notty nottui))
(depends (nottui (= :version)) (notty (>= 0.2))))
(package
(name nottui-lwt)
(synopsis "Run Nottui UIs in Lwt")
(documentation "https://let-def.github.io/lwd/doc")
(depends (dune (>= 2.0)) notty lwt nottui))
(depends lwt (nottui (= :version)) (notty (>= 0.2))))

View File

@ -48,6 +48,8 @@ let ui_of_cbor (c:C.t) =
Lwd_table.set row kv)
l;
Lwd.join @@ Lwd_table.reduce (Lwd_utils.lift_monoid Ui.Ui.pack_y) tbl)
| `Tag (tag, payload) ->
Lwd.map ~f:(Ui.Ui.join_y (W.printf "tag(%d)" tag)) (traverse payload)
and mk_k_v x y =
let tr_x = traverse x in
let summary = match y with

View File

@ -0,0 +1,8 @@
ROOT=$(realpath $(PWD)/../..)
all:
dune build index.html main.js
@echo "open $(ROOT)/_build/default/examples/focustest-brr/index.html"
clean:
dune clean

View File

@ -0,0 +1,14 @@
(executables
(names main)
(libraries js_of_ocaml brr lwd brr-lwd)
(modes byte))
(rule
(targets main.js)
(action
(run %{bin:js_of_ocaml} --noruntime %{lib:js_of_ocaml-compiler:runtime.js}
--source-map %{dep:main.bc} -o %{targets} --pretty)))
(alias
(name default)
(deps main.js index.html))

View File

@ -0,0 +1,67 @@
open Brr
open Brr_lwd
let ui =
let values = Lwd_table.make () in
let items = Lwd.var Lwd_seq.empty in
let shuffle () =
let all = Lwd_seq.to_array (Lwd.peek items) in
for i = Array.length all - 1 downto 1 do
let i' = Random.int (i + 1) in
let x = all.(i) in
let x' = all.(i') in
all.(i') <- x;
all.(i) <- x';
done;
Lwd.set items (Lwd_seq.of_array all)
in
let edit _ =
let row = Lwd_table.append values in
Lwd.map (Elwd.input ()) ~f:(fun el ->
Ev.listen Ev.input
(fun _ ->
let txt = Jstr.to_string (El.prop El.Prop.value el) in
Console.log ["shuffle"; txt];
Lwd_table.set row txt;
shuffle ()
)
(El.as_target el);
el
)
in
Lwd.set items (Lwd_seq.of_array (Array.init 10 edit));
let values =
Lwd_table.map_reduce
(fun _row txt -> Lwd_seq.element (txt ^ "\n"))
(Lwd_seq.monoid)
values
|> Lwd_seq.sort_uniq String.compare
in
Elwd.div [
`P (El.txt' "In this test, typing in one of the input field should \
shuffle them. The test succeeds if focus and selections are \
preserved after shuffling.");
`P (El.br ());
`S (Lwd_seq.lift (Lwd.get items));
`S (Lwd_seq.map El.txt' values);
]
let () =
let ui = Lwd.observe ui in
let on_invalidate _ =
Console.(log [str "on invalidate"]);
let _ : int =
G.request_animation_frame @@ fun _ ->
let _ui = Lwd.quick_sample ui in
(*El.set_children (Document.body G.document) [ui]*)
()
in
()
in
let on_load _ =
Console.(log [str "onload"]);
El.append_children (Document.body G.document) [Lwd.quick_sample ui];
Lwd.set_on_invalidate ui on_invalidate
in
Ev.listen Ev.dom_content_loaded on_load (Window.as_target G.window);
()

View File

@ -0,0 +1,13 @@
<?xml version="1.0" encoding="utf-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>Minesweeper</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<script type="text/javascript" src="main.js"></script>
</head>
<body>
<div id="main"></div>
</body>
</html>

View File

Before

Width:  |  Height:  |  Size: 576 B

After

Width:  |  Height:  |  Size: 576 B

View File

Before

Width:  |  Height:  |  Size: 714 B

After

Width:  |  Height:  |  Size: 714 B

View File

Before

Width:  |  Height:  |  Size: 718 B

After

Width:  |  Height:  |  Size: 718 B

View File

Before

Width:  |  Height:  |  Size: 650 B

After

Width:  |  Height:  |  Size: 650 B

View File

Before

Width:  |  Height:  |  Size: 698 B

After

Width:  |  Height:  |  Size: 698 B

View File

Before

Width:  |  Height:  |  Size: 764 B

After

Width:  |  Height:  |  Size: 764 B

View File

Before

Width:  |  Height:  |  Size: 620 B

After

Width:  |  Height:  |  Size: 620 B

View File

Before

Width:  |  Height:  |  Size: 802 B

After

Width:  |  Height:  |  Size: 802 B

View File

Before

Width:  |  Height:  |  Size: 1.1 KiB

After

Width:  |  Height:  |  Size: 1.1 KiB

View File

Before

Width:  |  Height:  |  Size: 403 B

After

Width:  |  Height:  |  Size: 403 B

View File

Before

Width:  |  Height:  |  Size: 735 B

After

Width:  |  Height:  |  Size: 735 B

View File

Before

Width:  |  Height:  |  Size: 434 B

After

Width:  |  Height:  |  Size: 434 B

View File

Before

Width:  |  Height:  |  Size: 11 KiB

After

Width:  |  Height:  |  Size: 11 KiB

View File

@ -73,11 +73,27 @@ let celsius_edit =
~on_submit:ignore
let root =
Lwd_utils.pack Ui.pack_y [
Lwd.pure (Nottui_widgets.string "Celsius:");
celsius_edit;
Lwd.pure (Nottui_widgets.string "Farenheight:");
farenheit_edit;
]
Lwd_utils.pack Ui.pack_y [
Lwd.pure (Nottui_widgets.string "Celsius:");
celsius_edit;
Lwd.pure (Nottui_widgets.string "Farenheight:");
farenheit_edit;
]
let root =
Lwd_utils.pack Ui.pack_y [
root; root; root; root; root; root;
root; root; root; root; root; root;
root; root; root; root; root; root;
]
let root =
Lwd_utils.pack Ui.pack_x [
root; root; root; root; root; root;
root; root; root; root; root; root;
root; root; root; root; root; root;
]
let root = Nottui_widgets.scrollbox root
let () = Ui_loop.run ~tick_period:0.2 root

View File

@ -1,5 +1,4 @@
open Nottui
open Lwd_infix
open Nottui_widgets
(* App-specific widgets *)
@ -97,36 +96,36 @@ let wm =
(*let () = Statmemprof_emacs.start 1E-4 30 5*)
let () =
top
$= Lwd_utils.pack Ui.pack_x
[
main_menu_item wm "File" (fun () ->
Lwd_utils.pack Ui.pack_y
[
Lwd.return @@ sub_entry "New" ignore;
Lwd.return @@ sub_entry "Open" ignore;
sub_menu_item wm "Recent" (fun () ->
Lwd_utils.pack Ui.pack_y
[
Lwd.return @@ sub_entry "A" ignore;
Lwd.return @@ sub_entry "B" ignore;
Lwd.return @@ sub_entry "CD" ignore;
]);
Lwd.return @@ sub_entry "Quit" (fun () -> raise Exit);
]);
main_menu_item wm "View" (fun _ ->
bot $= Lwd.return (string "<View>");
Lwd.return Ui.empty);
main_menu_item wm "Edit" (fun _ ->
bot $= Lwd.return (string "<Edit>");
Lwd.return Ui.empty);
];
bot
$= Lwd_utils.pack Ui.pack_y
[
simple_edit "Hello world";
v_pane (strict_table ()) (Lwd.return @@ string "B");
h_pane (Lwd.return (string "A")) (Lwd.return (string "B"));
];
Lwd.set top @@
Lwd_utils.pack Ui.pack_x
[
main_menu_item wm "File" (fun () ->
Lwd_utils.pack Ui.pack_y
[
Lwd.return @@ sub_entry "New" ignore;
Lwd.return @@ sub_entry "Open" ignore;
sub_menu_item wm "Recent" (fun () ->
Lwd_utils.pack Ui.pack_y
[
Lwd.return @@ sub_entry "A" ignore;
Lwd.return @@ sub_entry "B" ignore;
Lwd.return @@ sub_entry "CD" ignore;
]);
Lwd.return @@ sub_entry "Quit" (fun () -> raise Exit);
]);
main_menu_item wm "View" (fun _ ->
Lwd.set bot (Lwd.return (string "<View>"));
Lwd.return Ui.empty);
main_menu_item wm "Edit" (fun _ ->
Lwd.set bot (Lwd.return (string "<Edit>"));
Lwd.return Ui.empty);
];
Lwd.set bot @@
Lwd_utils.pack Ui.pack_y
[
simple_edit "Hello world";
v_pane (strict_table ()) (Lwd.return @@ string "B");
h_pane (Lwd.return (string "A")) (Lwd.return (string "B"));
];
try Ui_loop.run ~tick_period:0.2 (window_manager_view wm)
with Exit -> ()

View File

@ -1,6 +1,5 @@
open Nottui
open Nottui_widgets
open Lwd_infix
let is_double_click =
let k = ref 0 in
@ -50,7 +49,7 @@ let rec dir ?(initial_path = []) ?after_width:(wref = ref 0) path =
if constrain then Lwd.map ~f:(Ui.resize ~w:12) t
else Lwd.map ~f:(remember_width ~wref) t
in
column $= Lwd_utils.pack Ui.pack_x [ t; Lwd.join (Lwd.get after) ]
Lwd.set column (Lwd_utils.pack Ui.pack_x [ t; Lwd.join (Lwd.get after) ])
in
set_constrain false;
let after_width = ref 0 in
@ -61,7 +60,7 @@ let rec dir ?(initial_path = []) ?after_width:(wref = ref 0) path =
with exn ->
Lwd.return (string ~attr:Notty.(A.bg A.red) (Printexc.to_string exn))
in
after $= Lwd.map ~f:(Ui.join_x (string " ")) t
Lwd.set after (Lwd.map ~f:(Ui.join_x (string " ")) t)
in
let highlighted_cell = ref None in
let rec render_directory ?(highlight = false) cell name =

4
lib/brr-lwd/dune Normal file
View File

@ -0,0 +1,4 @@
(library
(name brr_lwd)
(public_name brr-lwd)
(libraries brr lwd))

337
lib/brr-lwd/elwd.ml Normal file
View File

@ -0,0 +1,337 @@
open Brr
open El
type t = El.t
type 'a col = [
| `P of 'a
(** Pure element *)
| `R of 'a Lwd.t
(** Reactive element *)
| `S of 'a Lwd_seq.t Lwd.t
(** Reactive sequence of elements *)
] list
(** Describing collections of elements *)
let is_pure_element = function
| `P _ -> true
| `R x -> Option.is_some (Lwd.is_pure x)
| `S x -> Option.is_some (Lwd.is_pure x)
let extract_pure_element x = Option.get (Lwd.is_pure x)
let extract_pure_elements xs =
List.flatten (
List.map (function
| `P x -> [x]
| `R x -> [extract_pure_element x]
| `S x -> Lwd_seq.to_list (extract_pure_element x)
) xs
)
let consume_attribs : _ col -> _ = function
| [] -> [], []
| attribs ->
let pure, impure = List.partition is_pure_element attribs in
extract_pure_elements pure, impure
(** Reactive sequence of elements *)
let consume_children = function
| [] -> [], None
| [`P x] -> [x], None
| [`S x] -> [], Some x
| [`R x] -> [], Some (Lwd.map ~f:Lwd_seq.element x)
| col ->
if List.for_all is_pure_element col
then
List.flatten (
List.map (function
| `P x -> [x]
| `R x -> [extract_pure_element x]
| `S x -> Lwd_seq.to_list (extract_pure_element x)
)
col
), None
else [], Some (
Lwd_utils.map_reduce (function
| `P x -> Lwd.pure (Lwd_seq.element x)
| `R x -> Lwd.map ~f:Lwd_seq.element x
| `S x -> x
) Lwd_seq.lwd_monoid
col
)
type child_tree =
| Leaf of El.t
| Inner of { mutable bound: Jv.t;
left: child_tree; right: child_tree; }
let child_node node = Leaf node
let child_join left right = Inner { bound = Jv.null; left; right }
let jv_parentNode = Jstr.v "parentNode"
let jv_nextSibling = Jstr.v "nextSibling"
let jv_append = Jstr.v "append"
let jv_before = Jstr.v "before"
let jv_remove = Jstr.v "remove"
let jv_contains = Jstr.v "contains"
let jv_toRemove =
Jstr.v "lwd-to-remove" (* HACK Could be turned into a Javascript symbol *)
let contains_focus node =
match Brr.Document.active_el (Brr.El.document node) with
| None -> false
| Some el ->
Jv.to_bool (Jv.call' (El.to_jv node) jv_contains [|El.to_jv el|])
let update_children
(self : El.t)
(children : El.t Lwd_seq.t Lwd.t) : El.t Lwd.t =
let reducer =
ref (Lwd_seq.Reducer.make ~map:child_node ~reduce:child_join)
in
Lwd.map children ~f:begin fun children ->
let dropped, reducer' =
Lwd_seq.Reducer.update_and_get_dropped !reducer children in
reducer := reducer';
let schedule_for_removal child () = match child with
| Leaf node -> Jv.set' (El.to_jv node) jv_toRemove Jv.true';
| Inner _ -> ()
in
Lwd_seq.Reducer.fold_dropped `Map schedule_for_removal dropped ();
let preserve_focus = contains_focus self in
begin match Lwd_seq.Reducer.reduce reducer' with
| None -> ()
| Some tree ->
let rec update acc = function
| Leaf node ->
let node' = El.to_jv node in
Jv.delete' node' jv_toRemove;
(*Brr.Console.log ["Updating "; node];*)
if Jv.get' node' jv_parentNode != El.to_jv self then (
if Jv.is_null acc
then ignore (Jv.call' (El.to_jv self) jv_append [|node'|])
else ignore (Jv.call' acc jv_before [|node'|])
) else if (
(* Check if there is not any work to do *)
Jv.get' node' jv_nextSibling != acc &&
(* Check if we are in the focus case and try to "bubble sort" to
preserve focus *)
not (
preserve_focus && contains_focus node &&
let rec shift_siblings () =
let sibling = Jv.get' node' jv_nextSibling in
if sibling == acc then true
else if Jv.is_null sibling then false
else (
ignore (Jv.call' node' jv_before [|sibling|]);
shift_siblings ()
)
in
shift_siblings ()
)
) then (
if Jv.is_null acc
then ignore (Jv.call' (El.to_jv self) jv_append [|node'|])
else ignore (Jv.call' acc jv_before [|node'|])
);
node'
| Inner t ->
if Jv.is_null t.bound then (
let acc = update acc t.right in
let acc = update acc t.left in
t.bound <- acc;
acc
) else
t.bound
in
ignore (update Jv.null tree)
end;
let remove_child child () = match child with
| Leaf node ->
let node = El.to_jv node in
if Jv.is_some (Jv.get' node jv_toRemove) then (
(*Brr.Console.log ["Removing "; node];*)
Jv.delete' node jv_toRemove;
ignore (Jv.call' node jv_remove [||])
)
| Inner _ -> ()
in
Lwd_seq.Reducer.fold_dropped `Map remove_child dropped ();
self
end
let pure_unit = Lwd.pure ()
let attach_attribs el attribs =
let set_at at =
let k, v = At.to_pair at in
El.set_at k (Some v) el
in
Lwd_utils.map_reduce (function
| `P at -> set_at at; pure_unit
| `R at -> Lwd.map ~f:set_at at
| `S ats ->
let set_at' at =
let k, v = At.to_pair at in
El.set_at k (Some v) el;
Some k
in
let reducer =
ref (Lwd_seq.Reducer.make ~map:set_at' ~reduce:(fun _ _ -> None))
in
let update ats =
let dropped, reducer' =
Lwd_seq.Reducer.update_and_get_dropped !reducer ats
in
reducer := reducer';
Lwd_seq.Reducer.fold_dropped `Map (fun at () ->
match at with
| Some k -> El.set_at k None el
| None -> assert false
) dropped ();
ignore (Lwd_seq.Reducer.reduce reducer': _ option option)
in
Lwd.map ~f:update ats
) (pure_unit, fun _ _ -> pure_unit)
attribs
let v ?d ?(at=[]) tag children =
let at, impure_at = consume_attribs at in
let children, impure_children = consume_children children in
let el = El.v ?d ~at tag children in
match impure_at, impure_children with
| [], None -> Lwd.pure el
| [], Some children ->
update_children el children
| at, None ->
Lwd.map ~f:(fun () -> el) (attach_attribs el at)
| at, Some children ->
Lwd.map2 ~f:(fun () el -> el)
(attach_attribs el at)
(update_children el children)
(** {1:els Element constructors} *)
type cons = ?d:El.document -> ?at:At.t col -> t col -> t Lwd.t
(** The type for element constructors. This is simply {!v} with a
pre-applied element name. *)
type void_cons = ?d:El.document -> ?at:At.t col -> unit -> t Lwd.t
(** The type for void element constructors. This is simply {!v}
with a pre-applied element name and without children. *)
let cons name ?d ?at cs = v ?d ?at name cs
let void_cons name ?d ?at () = v ?d ?at name []
let a = cons Name.a
let abbr = cons Name.abbr
let address = cons Name.address
let area = void_cons Name.area
let article = cons Name.article
let aside = cons Name.aside
let audio = cons Name.audio
let b = cons Name.b
let base = void_cons Name.base
let bdi = cons Name.bdi
let bdo = cons Name.bdo
let blockquote = cons Name.blockquote
let body = cons Name.body
let br = void_cons Name.br
let button = cons Name.button
let canvas = cons Name.canvas
let caption = cons Name.caption
let cite = cons Name.cite
let code = cons Name.code
let col = void_cons Name.col
let colgroup = cons Name.colgroup
let command = cons Name.command
let datalist = cons Name.datalist
let dd = cons Name.dd
let del = cons Name.del
let details = cons Name.details
let dfn = cons Name.dfn
let div = cons Name.div
let dl = cons Name.dl
let dt = cons Name.dt
let em = cons Name.em
let embed = void_cons Name.embed
let fieldset = cons Name.fieldset
let figcaption = cons Name.figcaption
let figure = cons Name.figure
let footer = cons Name.footer
let form = cons Name.form
let h1 = cons Name.h1
let h2 = cons Name.h2
let h3 = cons Name.h3
let h4 = cons Name.h4
let h5 = cons Name.h5
let h6 = cons Name.h6
let head = cons Name.head
let header = cons Name.header
let hgroup = cons Name.hgroup
let hr = void_cons Name.hr
let html = cons Name.html
let i = cons Name.i
let iframe = cons Name.iframe
let img = void_cons Name.img
let input = void_cons Name.input
let ins = cons Name.ins
let kbd = cons Name.kbd
let keygen = cons Name.keygen
let label = cons Name.label
let legend = cons Name.legend
let li = cons Name.li
let link = void_cons Name.link
let map = cons Name.map
let mark = cons Name.mark
let menu = cons Name.menu
let meta = void_cons Name.meta
let meter = cons Name.meter
let nav = cons Name.nav
let noscript = cons Name.noscript
let object' = cons Name.object'
let ol = cons Name.ol
let optgroup = cons Name.optgroup
let option = cons Name.option
let output = cons Name.output
let p = cons Name.p
let param = void_cons Name.param
let pre = cons Name.pre
let progress = cons Name.progress
let q = cons Name.q
let rp = cons Name.rp
let rt = cons Name.rt
let ruby = cons Name.ruby
let s = cons Name.s
let samp = cons Name.samp
let script = cons Name.script
let section = cons Name.section
let select = cons Name.select
let small = cons Name.small
let source = void_cons Name.source
let span = cons Name.span
let strong = cons Name.strong
let style = cons Name.style
let sub = cons Name.sub
let summary = cons Name.summary
let sup = cons Name.sup
let table = cons Name.table
let tbody = cons Name.tbody
let td = cons Name.td
let textarea = cons Name.textarea
let tfoot = cons Name.tfoot
let th = cons Name.th
let thead = cons Name.thead
let time = cons Name.time
let title = cons Name.title
let tr = cons Name.tr
let track = void_cons Name.track
let u = cons Name.u
let ul = cons Name.ul
let var = cons Name.var
let video = cons Name.video
let wbr = void_cons Name.wbr

429
lib/brr-lwd/elwd.mli Normal file
View File

@ -0,0 +1,429 @@
open Brr
open El
type t = El.t
type 'a col = [
| `P of 'a
(** Pure element *)
| `R of 'a Lwd.t
(** Reactive element *)
| `S of 'a Lwd_seq.t Lwd.t
(** Reactive sequence of elements *)
] list
(** Describing collections of elements *)
val v : ?d:document -> ?at:At.t col -> tag_name -> t col -> t Lwd.t
(** [v ?d ?at name cs] is an element [name] with attribute [at]
(defaults to [[]]) and children [cs]. If [at] specifies an
attribute more thanonce, the last one takes over with the
exception of {!At.class'} whose occurences accumulate to define
the final value. [d] is the document on which the element is
defined it defaults {!Brr.G.document}. *)
(** {1:els Element constructors} *)
type cons = ?d:document -> ?at:At.t col -> t col -> t Lwd.t
(** The type for element constructors. This is simply {!v} with a
pre-applied element name. *)
type void_cons = ?d:document -> ?at:At.t col -> unit -> t Lwd.t
(** The type for void element constructors. This is simply {!v}
with a pre-applied element name and without children. *)
val a : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/a}a} *)
val abbr : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/abbr}abbr} *)
val address : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/address}
address} *)
val area : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/area}
area} *)
val article : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/article}
article} *)
val aside : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/aside}
aside} *)
val audio : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/audio}
audio} *)
val b : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/b}b} *)
val base : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/base}
base} *)
val bdi : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/bdi}
bdi} *)
val bdo : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/bdo}
bdo} *)
val blockquote : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/blockquote}
blockquote} *)
val body : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/body}
body} *)
val br : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/br}br} *)
val button : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/button}
button} *)
val canvas : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/canvas}
canvas} *)
val caption : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/caption}
caption} *)
val cite : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/cite}
cite} *)
val code : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/code}
code} *)
val col : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/col}
col} *)
val colgroup : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/colgroup}
colgroup} *)
val command : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/command}
command} *)
val datalist : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/datalist}
datalist} *)
val dd : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dd}dd} *)
val del : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/del}
del} *)
val details : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/details}
details} *)
val dfn : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dfn}
dfn} *)
val div : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/div}
div} *)
val dl : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dl}dl} *)
val dt : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dt}dt} *)
val em : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/em}em} *)
val embed : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/embed}
embed} *)
val fieldset : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/fieldset}
fieldset} *)
val figcaption : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/figcaption}
figcaption} *)
val figure : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/figure}
figure} *)
val footer : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/footer}
footer} *)
val form : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/form}
form} *)
val h1 : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h1}h1} *)
val h2 : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h2}h2} *)
val h3 : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h3}h3} *)
val h4 : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h4}h4} *)
val h5 : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h5}h5} *)
val h6 : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h6}h6} *)
val head : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/head}
head} *)
val header : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/header}
header} *)
val hgroup : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/hgroup}
hgroup} *)
val hr : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/hr}hr} *)
val html : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/html}
html} *)
val i : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/i}i} *)
val iframe : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/iframe}
iframe} *)
val img : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/img}
img} *)
val input : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input}
input} *)
val ins : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ins}
ins} *)
val kbd : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/kbd}
kbd} *)
val keygen : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/keygen}
keygen} *)
val label : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/label}
label} *)
val legend : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/legend}
legend} *)
val li : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/li}li} *)
val link : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/link}link} *)
val map : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/map}map} *)
val mark : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/mark}mark} *)
val menu : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/menu}menu} *)
val meta : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/meta}meta} *)
val meter : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/meter}
meter} *)
val nav : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/nav}nav} *)
val noscript : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/noscript}
noscript} *)
val object' : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/object}
object} *)
val ol : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ol}ol} *)
val optgroup : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/optgroup}
optgroup} *)
val option : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/option}
option} *)
val output : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/output}
output} *)
val p : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/p}p} *)
val param : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/param}
param} *)
val pre : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/pre}
pre} *)
val progress : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/progress}
progress} *)
val q : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/q}q} *)
val rp : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/rp}rp} *)
val rt : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/rt}rt} *)
val ruby : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ruby}ruby} *)
val s : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/s}s} *)
val samp : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/samp}
samp} *)
val script : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/script}
script} *)
val section : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/section}
section} *)
val select : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/select}
select} *)
val small : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/small}
small} *)
val source : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/source}
source} *)
val span : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/span}
span} *)
val strong : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/strong}
strong} *)
val style : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/style}
style} *)
val sub : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/sub}
sub} *)
val summary : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/summary}
summary} *)
val sup : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/sup}
sup} *)
val table : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/table}
table} *)
val tbody : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tbody}
tbody} *)
val td : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/td}td} *)
val textarea : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/textarea}
textarea} *)
val tfoot : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tfoot}
tfoot} *)
val th : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/th}th} *)
val thead : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/thead}
thead} *)
val time : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time}
time} *)
val title : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/title}
title} *)
val tr : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tr}tr} *)
val track : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/track}
track} *)
val u : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/u}u} *)
val ul : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ul}ul} *)
val var : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/var}
var} *)
val video : cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/video}
video} *)
val wbr : void_cons
(** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/wbr}
wbr} *)

View File

@ -37,6 +37,7 @@ and _ desc =
| Var : { mutable binding : 'a } -> 'a desc
| Prim : { acquire : 'a t -> 'a;
release : 'a t -> 'a -> unit } -> 'a desc
| Fix : { doc : 'a t_; wrt : _ t_ } -> 'a desc
(* a set of (active) parents for a ['a t], used during invalidation *)
and trace =
@ -199,46 +200,97 @@ let get_idx obj = function
| Root t' -> get_idx_rec obj t'.trace_idx
| Operator t' -> get_idx_rec obj t'.trace_idx
type status =
| Neutral
| Safe
| Unsafe
type sensitivity =
| Strong
| Fragile
(* Propagating invalidation recursively.
Each document is invalidated at most once,
and only if it has [t.value = Some _]. *)
let rec invalidate_node : type a . a t_ -> unit = function
| Pure _ -> assert false
| Root ({ value; _ } as t) ->
let rec invalidate_node : type a . status ref -> sensitivity -> a t_ -> unit =
fun status sensitivity node ->
match node, sensitivity with
| Pure _, _ -> assert false
| Root ({value; _} as t), _ ->
t.value <- Eval_none;
begin match value with
| Eval_none | Eval_progress -> ()
| Eval_none -> ()
| Eval_progress ->
status := Unsafe
| Eval_some x ->
begin match sensitivity with
| Strong -> ()
| Fragile -> status := Unsafe
end;
t.on_invalidate x (* user callback that {i observes} this root. *)
end
| Operator { value = Eval_none; _ } -> ()
| Operator t ->
| Operator {value = Eval_none; _}, Fragile ->
begin match !status with
| Unsafe | Safe -> ()
| _ -> status := Safe
end
| Operator {value = Eval_none; _}, _ -> ()
| Operator {desc = Fix {wrt = Operator {value = Eval_none; _}; _}; _}, Fragile ->
begin match !status with
| Safe | Unsafe -> ()
| Neutral -> status := Safe
end
| Operator {desc = Fix {wrt = Operator {value = Eval_some _; _}; _}; _}, Fragile ->
()
| Operator t, _ ->
let sensitivity =
match t.value with Eval_progress -> Fragile | _ -> sensitivity
in
t.value <- Eval_none;
invalidate_trace t.trace; (* invalidate parents recursively *)
(* invalidate parents recursively *)
invalidate_trace status sensitivity t.trace
(* invalidate recursively documents in the given trace *)
and invalidate_trace = function
and invalidate_trace status sensitivity = function
| T0 -> ()
| T1 x -> invalidate_node x
| T1 x -> invalidate_node status sensitivity x
| T2 (x, y) ->
invalidate_node x;
invalidate_node y
invalidate_node status sensitivity x;
invalidate_node status sensitivity y
| T3 (x, y, z) ->
invalidate_node x;
invalidate_node y;
invalidate_node z
invalidate_node status sensitivity x;
invalidate_node status sensitivity y;
invalidate_node status sensitivity z
| T4 (x, y, z, w) ->
invalidate_node x;
invalidate_node y;
invalidate_node z;
invalidate_node w
invalidate_node status sensitivity x;
invalidate_node status sensitivity y;
invalidate_node status sensitivity z;
invalidate_node status sensitivity w
| Tn t ->
let active = t.active in
t.active <- 0;
for i = 0 to active - 1 do
invalidate_node t.entries.(i)
invalidate_node status sensitivity t.entries.(i)
done
let default_unsafe_mutation_logger () =
let callstack = Printexc.get_callstack 20 in
Printf.fprintf stderr
"Lwd: unsafe mutation (variable invalidated during evaluation) at\n%a"
Printexc.print_raw_backtrace callstack
let unsafe_mutation_logger = ref default_unsafe_mutation_logger
let do_invalidate sensitivity node =
let status = ref Neutral in
invalidate_node status sensitivity node;
let unsafe =
match !status with
| Neutral | Safe -> false
| Unsafe -> true
in
if unsafe then !unsafe_mutation_logger ()
(* Variables *)
type 'a var = 'a t_
let var x = operator (Var {binding = x})
@ -248,7 +300,7 @@ let set (vx:_ var) x : unit =
match vx with
| Operator ({desc = Var v; _}) ->
(* set the variable, and invalidate all observers *)
invalidate_node vx;
do_invalidate Strong vx;
v.binding <- x
| _ -> assert false
@ -263,17 +315,24 @@ let prim ~acquire ~release =
let get_prim x = x
let invalidate x = match prj x with
| Operator ({ desc = Prim p; _ } as t) ->
let value = t.value in
t.value <- Eval_none;
| Operator {desc = Prim p; value; _} as t ->
(* the value is invalidated, be sure to invalidate all parents as well *)
invalidate_trace t.trace;
begin match value with
| Eval_none | Eval_progress -> ()
| Eval_some v -> p.release x v
| Eval_none -> ()
| Eval_progress -> do_invalidate Fragile t;
| Eval_some v ->
do_invalidate Strong t;
p.release x v
end
| _ -> assert false
(* Fix point *)
let fix doc ~wrt = match prj wrt with
| Root _ -> assert false
| Pure _ -> doc
| Operator _ as wrt -> inj (operator (Fix {doc = prj doc; wrt}))
type release_list =
| Release_done
| Release_more :
@ -371,6 +430,8 @@ let rec sub_release
sub_release failures self child'
end
| Var _ -> failures
| Fix {doc; wrt} ->
sub_release (sub_release failures self wrt) self doc
| Prim t ->
begin match value with
| Eval_none | Eval_progress -> failures
@ -438,6 +499,9 @@ let rec sub_acquire : type a b . a t_ -> b t_ -> unit = fun origin ->
| App (x, y) ->
sub_acquire self x;
sub_acquire self y
| Fix {doc; wrt} ->
sub_acquire self doc;
sub_acquire self wrt
| Join { child; intermediate } ->
sub_acquire self child;
begin match intermediate with
@ -469,6 +533,15 @@ let activate_tracing self origin = function
)
| _ -> ()
let sub_is_damaged = function
| Root _ -> assert false
| Pure _ -> false
| Operator {value; _} ->
match value with
| Eval_none -> true
| Eval_some _ -> false
| Eval_progress -> assert false
(* [sub_sample origin self] computes a value for [self].
[sub_sample] raise if any user-provided computation raises.
@ -492,6 +565,16 @@ let sub_sample queue =
| Map2 (x, y, f) -> f (aux self x) (aux self y)
| Pair (x, y) -> (aux self x, aux self y)
| App (f, x) -> (aux self f) (aux self x)
| Fix {doc; wrt} ->
let _ = aux self wrt in
let result = aux self doc in
if sub_is_damaged wrt then
aux origin self
else (
if sub_is_damaged doc then
do_invalidate Fragile self;
result
)
| Join x ->
let intermediate =
(* We haven't touched any state yet,

View File

@ -85,6 +85,18 @@ val prim : acquire:('a prim -> 'a) -> release:('a prim -> 'a -> unit) -> 'a prim
val get_prim : 'a prim -> 'a t
val invalidate : 'a prim -> unit
(** Some document might change variables during their evaluation.
These are called "unstable" documents.
Evaluating these might need many passes to eventually converge to a value.
The `fix` operator tries to stabilize a sub-document by repeating
evaluation until a stable condition is reached.
*)
val fix : 'a t -> wrt:_ t -> 'a t
val default_unsafe_mutation_logger : unit -> unit
val unsafe_mutation_logger : (unit -> unit) ref
(** Releasing unused graphs *)
type release_failure = exn * Printexc.raw_backtrace

View File

@ -10,17 +10,23 @@ let empty = Nil
let element v = Leaf { mark = 0; v }
let mask_bits = 2
let old_mask = 1
let new_mask = 2
let both_mask = 3
let maxi a b : int = if b > a then b else a
let rank = function
| Nil | Leaf _ -> 0
| Join t -> t.mark lsr mask_bits
| Nil -> 0
| Leaf t ->
if t.mark <> 0 then
invalid_arg "Lwd_seq.rank: node is marked";
0
| Join t ->
if t.mark land mask_bits <> 0 then
invalid_arg "Lwd_seq.rank: node is marked";
t.mark lsr mask_bits
let concat a b = match a, b with
| Nil, x | x, Nil -> x
| l, r -> Join { mark = (max (rank l) (rank r) + 1) lsl mask_bits; l; r }
| l, r -> Join { mark = (maxi (rank l) (rank r) + 1) lsl mask_bits; l; r }
type ('a, 'b) view =
| Empty
@ -59,7 +65,7 @@ end = struct
| Nil | Leaf _ -> assert false
| Join tr ->
let trr = node_left tr.r r in
if check (1 + max (rank t.l) (rank tr.l)) (rank trr)
if check (1 + maxi (rank t.l) (rank tr.l)) (rank trr)
then concat (concat t.l tr.l) trr
else concat t.l (concat tr.l trr)
@ -75,7 +81,7 @@ end = struct
| Nil | Leaf _ -> assert false
| Join tl ->
let tll = node_right l tl.l in
if check (1 + max (rank tl.r) (rank t.r)) (rank tll)
if check (1 + maxi (rank tl.r) (rank t.r)) (rank tll)
then concat tll (concat tl.r t.r)
else concat (concat tll tl.r) t.r
@ -91,18 +97,65 @@ end = struct
let view = view
end
module Reducer = struct
type (+'a, 'b) xform =
| XEmpty
| XLeaf of { a: 'a t; mutable b: 'b option; }
| XJoin of { a: 'a t; mutable b: 'b option;
l: ('a, 'b) xform; r: ('a, 'b) xform; }
module Marking : sig
type mark = (*private*) int
val is_shared : mark -> bool
val is_not_shared : mark -> bool
val is_none : mark -> bool
val is_both : mark -> bool
val is_old : mark -> bool
val is_new : mark -> bool
(*val has_old : mark -> bool*)
(*val has_new : mark -> bool*)
val set_both : mark -> mark
val unmark : mark -> mark
val get_index : mark -> int
val with_index_new : int -> mark
type stats
val marked : stats -> int
val shared : stats -> int
val blocked : stats -> int
type traversal
val old_stats : traversal -> stats
val new_stats : traversal -> stats
val unsafe_traverse : old_root:_ seq -> new_root:_ seq -> traversal
val restore : _ seq -> unit
end = struct
type mark = int
let mask_none = 0
let mask_old = 1
let mask_new = 2
let mask_both = 3
let is_shared m = m = -1
let is_not_shared m = m <> -1
let is_none m = m land mask_both = mask_none
let is_both m = m land mask_both = mask_both
let is_old m = m land mask_both = mask_old
let is_new m = m land mask_both = mask_new
(*let has_old m = m land mask_old <> 0*)
(*let has_new m = m land mask_new <> 0*)
let set_both m = m lor mask_both
let get_index m = m lsr mask_bits
let with_index_new index = (index lsl mask_bits) lor mask_new
let unmark m = m land lnot mask_both
type stats = {
mutable marked: int;
mutable shared: int;
mutable blocked: int;
}
let marked s = s.marked
let shared s = s.shared
let blocked s = s.blocked
let mk_stats () = { marked = 0; shared = 0; blocked = 0 }
let new_marked stats = stats.marked <- stats.marked + 1
@ -113,19 +166,19 @@ module Reducer = struct
| Nil -> ()
| Leaf t' ->
let mark = t'.mark in
if mark land both_mask <> both_mask && mark land both_mask <> 0
if mark land mask_both <> mask_both && mark land mask_both <> 0
then (
if mark land mask = 0 then new_marked stats else assert false;
new_blocked stats;
t'.mark <- mark lor both_mask
t'.mark <- mark lor mask_both
)
| Join t' ->
let mark = t'.mark in
if mark land both_mask <> both_mask && mark land both_mask <> 0
if mark land mask_both <> mask_both && mark land mask_both <> 0
then (
if mark land mask = 0 then new_marked stats else assert false;
new_blocked stats;
t'.mark <- mark lor both_mask;
t'.mark <- mark lor mask_both;
block stats mask t'.l;
block stats mask t'.r;
)
@ -137,7 +190,7 @@ module Reducer = struct
if mark land mask = 0 then (
(* Not yet seen *)
new_marked stats;
if mark land both_mask <> 0 then (
if mark land mask_both <> 0 then (
(* Newly shared, clear mask *)
t'.mark <- -1;
new_blocked stats;
@ -145,7 +198,7 @@ module Reducer = struct
) else
t'.mark <- mark lor mask;
);
if mark <> -1 && mark land both_mask = both_mask then (
if mark <> -1 && mark land mask_both = mask_both then (
t'.mark <- -1;
new_shared stats
)
@ -154,7 +207,7 @@ module Reducer = struct
if mark land mask = 0 then (
(* Not yet seen *)
new_marked stats;
if mark land both_mask <> 0 then (
if mark land mask_both <> 0 then (
(* Newly shared, clear mask *)
t'.mark <- -1;
new_blocked stats;
@ -167,7 +220,7 @@ module Reducer = struct
Queue.push t q
)
);
if mark <> -1 && mark land both_mask = both_mask then (
if mark <> -1 && mark land mask_both = mask_both then (
t'.mark <- -1;
new_shared stats
)
@ -175,7 +228,7 @@ module Reducer = struct
let dequeue stats q mask =
match Queue.pop q with
| Join t ->
if t.mark land both_mask = mask then (
if t.mark land mask_both = mask then (
enqueue stats q mask t.l;
enqueue stats q mask t.r;
)
@ -188,15 +241,64 @@ module Reducer = struct
let rec traverse sold snew qold qnew =
if Queue.is_empty qold then
traverse1 snew qnew new_mask
traverse1 snew qnew mask_new
else if Queue.is_empty qnew then
traverse1 sold qold old_mask
traverse1 sold qold mask_old
else (
dequeue sold qold old_mask;
dequeue snew qnew new_mask;
dequeue sold qold mask_old;
dequeue snew qnew mask_new;
traverse sold snew qold qnew
)
type traversal = {
old_stats: stats;
new_stats: stats;
}
let old_stats tr = tr.old_stats
let new_stats tr = tr.new_stats
let unsafe_traverse ~old_root ~new_root =
let old_stats = mk_stats () in
let new_stats = mk_stats () in
let old_queue = Queue.create () in
let new_queue = Queue.create () in
enqueue old_stats old_queue mask_old old_root;
enqueue new_stats new_queue mask_new new_root;
traverse old_stats new_stats old_queue new_queue;
{old_stats; new_stats}
let restore = function
| Nil -> ()
| Leaf t -> t.mark <- 0
| Join t ->
t.mark <- (maxi (rank t.l) (rank t.r) + 1) lsl mask_bits
end
(* Marks go through many states.
A mark is usually split in two parts:
- the mask, made of the two least significant bits
- the index is an unsigned integer formed of all the remaining bits
The exception is the distinguished mask with value -1 (all bits set to 1)
that denote a "locked" node.
When the mask is 0, the index denotes the rank of the node: the depth of
the tree rooted at this node.
When the mask is non-zero, the index meaning is left to the traversal
algorithm.
Restoring the mark sets the mask to 0 and the indext to the rank,
but is only possible when the children of the node are themselves restored.
*)
module Reducer = struct
type (+'a, 'b) xform =
| XEmpty
| XLeaf of { a: 'a t; mutable b: 'b option; }
| XJoin of { a: 'a t; mutable b: 'b option;
l: ('a, 'b) xform; r: ('a, 'b) xform; }
type ('a, 'b) unmark_state = {
dropped : 'b option array;
mutable dropped_leaf : int;
@ -217,12 +319,12 @@ module Reducer = struct
| XJoin {a = Nil | Leaf _; _} -> assert false
| XLeaf {a = Leaf t'; _} ->
let mark = t'.mark in
if mark <> -1 && mark land both_mask = both_mask then
t'.mark <- mark land lnot both_mask;
if Marking.is_not_shared mark && Marking.is_both mark then
t'.mark <- Marking.unmark mark;
| XJoin {a = Join t'; l; r; _} ->
let mark = t'.mark in
if mark <> -1 && mark land both_mask = both_mask then (
t'.mark <- mark land lnot both_mask;
if Marking.is_not_shared mark && Marking.is_both mark then (
t'.mark <- Marking.unmark mark;
unblock l;
unblock r
)
@ -233,49 +335,49 @@ module Reducer = struct
| XJoin {a = Nil | Leaf _; _} -> assert false
| XLeaf {a = Leaf t' as a; b} as t ->
let mark = t'.mark in
if mark land both_mask = old_mask then (
if Marking.is_old mark then (
let dropped_leaf = st.dropped_leaf in
if dropped_leaf > -1 then (
st.dropped.(dropped_leaf) <- b;
st.dropped_leaf <- dropped_leaf + 1;
assert (st.dropped_leaf <= st.dropped_join);
);
t'.mark <- mark land lnot both_mask
) else if mark = -1 then (
t'.mark <- Marking.unmark mark
) else if Marking.is_shared mark then (
let index = next_shared_index st in
st.shared.(index) <- a;
st.shared_x.(index) <- [t];
t'.mark <- (index lsl mask_bits) lor new_mask;
) else if mark land both_mask = new_mask then (
let index = mark lsr mask_bits in
t'.mark <- Marking.with_index_new index;
) else if Marking.is_new mark then (
let index = Marking.get_index mark in
st.shared_x.(index) <- t :: st.shared_x.(index);
) else if mark land both_mask = both_mask then (
) else if Marking.is_both mark then (
assert false
(*t'.mark <- mark land lnot both_mask*)
)
| XJoin {a = Join t' as a; l; r; b} as t ->
let mark = t'.mark in
if mark land both_mask = old_mask then (
if Marking.is_shared mark then (
let index = next_shared_index st in
st.shared.(index) <- a;
st.shared_x.(index) <- [t];
t'.mark <- Marking.with_index_new index;
unblock l;
unblock r;
) else if Marking.is_old mark then (
if st.dropped_join > -1 then (
let dropped_join = st.dropped_join - 1 in
st.dropped.(dropped_join) <- b;
st.dropped_join <- dropped_join;
assert (st.dropped_leaf <= st.dropped_join);
);
t'.mark <- mark land lnot both_mask;
t'.mark <- Marking.unmark mark;
unmark_old st l;
unmark_old st r;
) else if mark = -1 then (
let index = next_shared_index st in
st.shared.(index) <- a;
st.shared_x.(index) <- [t];
t'.mark <- (index lsl mask_bits) lor new_mask;
unblock l;
unblock r;
) else if mark land both_mask = new_mask then (
) else if Marking.is_new mark then (
let index = mark lsr mask_bits in
st.shared_x.(index) <- t :: st.shared_x.(index);
) else if mark land both_mask = both_mask then (
) else if Marking.is_both mark then (
assert false
)
@ -283,8 +385,8 @@ module Reducer = struct
for i = 0 to st.shared_index - 1 do
begin match st.shared.(i) with
| Nil -> ()
| Leaf t -> t.mark <- t.mark lor both_mask
| Join t -> t.mark <- t.mark lor both_mask
| Leaf t -> t.mark <- Marking.set_both t.mark
| Join t -> t.mark <- Marking.set_both t.mark
end;
match st.shared_x.(i) with
| [] -> assert false
@ -296,7 +398,7 @@ module Reducer = struct
| Nil -> XEmpty
| Leaf t' as t ->
let mark = t'.mark in
if mark <> -1 && mark land both_mask = both_mask then (
if Marking.is_not_shared mark && Marking.is_both mark then (
let index = mark lsr mask_bits in
match st.shared_x.(index) with
| [] -> XLeaf {a = t; b = None}
@ -314,7 +416,7 @@ module Reducer = struct
let l = unmark_new st t'.l in
let r = unmark_new st t'.r in
XJoin {a = t; b = None; l; r}
) else if mark land both_mask = both_mask then (
) else if Marking.is_both mark then (
let index = mark lsr mask_bits in
match st.shared_x.(index) with
| [] -> assert false
@ -323,7 +425,7 @@ module Reducer = struct
if xs == [] then t'.mark <- 0;
x
) else (
t'.mark <- t'.mark land lnot both_mask;
t'.mark <- Marking.unmark t'.mark;
let l = unmark_new st t'.l in
let r = unmark_new st t'.r in
XJoin {a = t; b = None; l; r}
@ -343,23 +445,28 @@ module Reducer = struct
| XEmpty, Nil -> no_dropped, XEmpty
| (XLeaf {a; _} | XJoin {a; _}), _ when a == tnew -> no_dropped, xold
| _ ->
(* Cost: 16 words *)
let qold = Queue.create () and sold = mk_stats () in
let qnew = Queue.create () and snew = mk_stats () in
begin match xold with
| XEmpty -> ()
| (XLeaf {a; _} | XJoin {a; _}) ->
enqueue sold qold old_mask a
end;
enqueue snew qnew new_mask tnew;
traverse sold snew qold qnew;
let nb_dropped = sold.marked - (sold.blocked + snew.blocked) in
let traversal =
Marking.unsafe_traverse
~old_root:(match xold with
| XEmpty -> empty
| (XLeaf {a; _} | XJoin {a; _}) -> a
)
~new_root:tnew
in
let sold = Marking.old_stats traversal in
let snew = Marking.new_stats traversal in
let nb_dropped =
Marking.marked sold - (Marking.blocked sold + Marking.blocked snew)
in
let nb_shared =
Marking.shared sold + Marking.shared snew
in
let st = {
dropped = if get_dropped then Array.make nb_dropped None else [||];
dropped_leaf = if get_dropped then 0 else - 1;
dropped_join = if get_dropped then nb_dropped else - 1;
shared = Array.make (sold.shared + snew.shared) Nil;
shared_x = Array.make (sold.shared + snew.shared) [];
shared = Array.make nb_shared Nil;
shared_x = Array.make nb_shared [];
shared_index = 0;
} in
(*Printf.eprintf "sold.shared:%d sold.marked:%d sold.blocked:%d\n%!"
@ -371,14 +478,8 @@ module Reducer = struct
prepare_shared st;
let result = unmark_new st tnew in
(*Printf.eprintf "new_computed:%d%!\n" !new_computed;*)
let restore_rank = function
| Nil -> assert false
| Leaf t -> t.mark <- 0
| Join t ->
t.mark <- (max (rank t.l) (rank t.r) + 1) lsl mask_bits
in
for i = st.shared_index - 1 downto 0 do
restore_rank st.shared.(i)
Marking.restore st.shared.(i)
done;
if get_dropped then (
let xleaf = ref [] in
@ -397,9 +498,10 @@ module Reducer = struct
) else
no_dropped, result
type ('a, 'b) map_reduce = ('a -> 'b) * ('b -> 'b -> 'b)
let map (f, _) x = f x
let reduce (_, f) x y = f x y
type ('a, 'b) map_reduce = {
map: 'a -> 'b;
reduce: 'b -> 'b -> 'b;
}
let eval map_reduce = function
| XEmpty -> None
@ -408,12 +510,12 @@ module Reducer = struct
| XEmpty | XLeaf {a = Nil | Join _; _} -> assert false
| XLeaf {b = Some b; _} | XJoin {b = Some b; _} -> b
| XLeaf ({a = Leaf t';_ } as t) ->
let result = map map_reduce t'.v in
let result = map_reduce.map t'.v in
t.b <- Some result;
result
| XJoin t ->
let l = aux t.l and r = aux t.r in
let result = reduce map_reduce l r in
let result = map_reduce.reduce l r in
t.b <- Some result;
result
in
@ -421,7 +523,7 @@ module Reducer = struct
type ('a, 'b) reducer = ('a, 'b) map_reduce * ('a, 'b) xform
let make ~map ~reduce = ((map, reduce), XEmpty)
let make ~map ~reduce = ({map; reduce}, XEmpty)
let reduce (map_reduce, tree : _ reducer) =
eval map_reduce tree
@ -564,3 +666,229 @@ let seq_bind (seq : 'a seq Lwd.t) (f : 'a -> 'b seq) : 'b seq Lwd.t =
let lift (seq : 'a Lwd.t seq Lwd.t) : 'a seq Lwd.t =
bind seq (Lwd.map ~f:element)
module BalancedTree : sig
type 'a t =
| Leaf
| Node of {
rank: int;
l: 'a t;
x: int * 'a seq;
r: 'a t;
mutable seq: 'a seq;
}
val leaf : 'a t
(*val node : 'a t -> int * 'a seq -> 'a t -> 'a t*)
val insert : cmp:('a -> 'a -> int) -> int -> 'a seq -> 'a t -> 'a t
(*val union : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t*)
end = struct
type 'a t =
| Leaf
| Node of {
rank: int;
l: 'a t;
x: int * 'a seq;
r: 'a t;
mutable seq: 'a seq;
}
let leaf = Leaf
let rank = function
| Leaf -> 0
| Node t -> t.rank
let check l r = abs (l - r) <= 1
let node l x r =
Node {l; x; r; seq = empty; rank = maxi (rank l) (rank r) + 1}
let rec node_left l x r =
let ml = rank l in
let mr = rank r in
if check ml mr then node l x r else match l with
| Leaf -> assert false
| Node t ->
if check (rank t.l) ml
then node t.l t.x (node_left t.r x r)
else match t.r with
| Leaf -> assert false
| Node tr ->
let trr = node_left tr.r x r in
if check (1 + maxi (rank t.l) (rank tr.l)) (rank trr)
then node (node t.l t.x tr.l) tr.x trr
else node t.l t.x (node tr.l tr.x trr)
let rec node_right l x r =
let ml = rank l in
let mr = rank r in
if check mr ml then node l x r else match r with
| Leaf -> assert false
| Node t ->
if check (rank t.r) mr
then node (node_right l x t.l) t.x t.r
else match t.l with
| Leaf -> assert false
| Node tl ->
let tll = node_right l x tl.l in
if check (1 + maxi (rank tl.r) (rank t.r)) (rank tll)
then node tll tl.x (node tl.r t.x t.r)
else node (node tll tl.x tl.r) t.x t.r
let node l x r =
let ml = rank l in
let mr = rank r in
if check ml mr
then node l x r
else if ml <= mr
then node_right l x r
else node_left l x r
let rec join l r = match l, r with
| Leaf, t | t, Leaf -> t
| Node tl, Node tr ->
if tl.rank <= tr.rank then
node (join l tr.l) tr.x tr.r
else
node tl.l tl.x (join tl.r r)
let get_element = function
| Nil | Join _ -> assert false
| Leaf {v;_} -> v
(*let rec split ~cmp k = function
| Leaf -> Leaf, 0, Leaf
| Node t ->
let c = cmp k (get_element (snd (t.x))) in
if c < 0 then
let l', v', r' = split ~cmp k t.l in
l', v', join r' t.r
else if c > 0 then
let l', v', r' = split ~cmp k t.r in
join t.l l', v', r'
else
(t.l, fst t.x, t.r)
let rec union ~cmp t1 t2 =
match t1, t2 with
| Leaf, t | t, Leaf -> t
| Node t1, t2 ->
let m1, k1 = t1.x in
let l2, m2, r2 = split ~cmp (get_element k1) t2 in
let l' = union ~cmp t1.l l2 in
let r' = union ~cmp t1.r r2 in
let m = m1 + m2 in
if m = 0 then
join l' r'
else (
assert (m > 0);
node l' (m, k1) r';
)
*)
let insert ~cmp m1 s t =
assert (m1 <> 0);
let rec aux = function
| Leaf -> node Leaf (m1, s) Leaf
| Node t ->
let m2, x = t.x in
let c = cmp (get_element s) (get_element x) in
if c = 0 then
let m = m1 + m2 in
if m = 0 then
join t.l t.r
else
node t.l (m, x) t.r
else if c < 0 then
let l' = aux t.l in
node l' t.x t.r
else
let r' = aux t.r in
node t.l t.x r'
in
aux t
end
let rec seq_of_tree = function
| BalancedTree.Leaf -> empty
| BalancedTree.Node t ->
match t.seq with
| Nil ->
let sl = seq_of_tree t.l in
let sr = seq_of_tree t.r in
assert (fst t.x > 0);
let seq = concat sl (concat (snd t.x) sr) in
t.seq <- seq;
seq
| seq -> seq
let sort_uniq cmp seq =
let previous_seq = ref empty in
let previous_tree = ref BalancedTree.leaf in
let f new_seq =
let old_seq = !previous_seq in
let old_tree = !previous_tree in
let _ = Marking.unsafe_traverse ~old_root:old_seq ~new_root:new_seq in
let rec unblock = function
| Nil -> ()
| Leaf t -> t.mark <- Marking.unmark t.mark
| Join t as seq ->
let mark = t.mark in
unblock t.l;
unblock t.r;
if Marking.is_shared mark then (
Marking.restore seq;
) else if Marking.is_both mark then (
t.mark <- Marking.unmark mark;
) else
assert (Marking.is_none mark)
in
let rec unmark_new tree = function
| Nil -> tree
| Leaf t as seq ->
let mark = t.mark in
t.mark <- 0;
if Marking.is_new mark then
BalancedTree.insert ~cmp (+1) seq tree
else (
assert (Marking.is_both mark || Marking.is_none mark);
tree
)
| Join t as seq ->
let mark = t.mark in
if Marking.is_new mark then (
t.mark <- Marking.unmark mark;
unmark_new (unmark_new tree t.l) t.r
) else (
unblock seq;
tree
)
in
let rec unmark_old tree = function
| Nil -> tree
| Leaf t as seq ->
let mark = t.mark in
t.mark <- 0;
if Marking.is_old mark then
BalancedTree.insert ~cmp (-1) seq tree
else (
assert (Marking.is_both mark || Marking.is_none mark);
tree
)
| Join t as seq ->
let mark = t.mark in
if Marking.is_old mark then (
t.mark <- Marking.unmark mark;
unmark_old (unmark_old tree t.l) t.r
) else (
unblock seq;
tree
)
in
let new_tree = unmark_old (unmark_new old_tree new_seq) old_seq in
previous_seq := new_seq;
previous_tree := new_tree;
seq_of_tree new_tree
in
Lwd.map seq ~f

View File

@ -155,6 +155,8 @@ val monoid : 'a t Lwd_utils.monoid
val lwd_monoid : 'a t Lwd.t Lwd_utils.monoid
(** Monoid instance for reactive sequences *)
val sort_uniq : ('a -> 'a -> int) -> 'a seq Lwd.t -> 'a seq Lwd.t
(** {2 Low-level interface for observing changes} *)
module Reducer : sig
@ -199,4 +201,3 @@ module Reducer : sig
val fold_dropped :
[<`All|`Map|`Reduce] -> ('a -> 'b -> 'b) -> 'a dropped -> 'b -> 'b
end

View File

@ -44,3 +44,33 @@ let rec map_l (f:'a -> 'b Lwd.t) (l:'a list) : 'b list Lwd.t =
let flatten_l (l:'a Lwd.t list) : 'a list Lwd.t =
map_l (fun x->x) l
(** {1 Miscellaneous functions}
I don't know where to put these, but they are useful, especially for
UI-related computations.
*)
let mini a b : int = if b < a then b else a
let maxi a b : int = if b > a then b else a
let clampi x ~min ~max : int =
if x < min then
min
else if x > max then
max
else
x
let minf a b : float = if b < a then b else a
let maxf a b : float = if b > a then b else a
let clampf x ~min ~max : float =
if x < min then
min
else if x > max then
max
else
x

View File

@ -36,3 +36,27 @@ val map_l : ('a -> 'b Lwd.t) -> 'a list -> 'b list Lwd.t
val flatten_l : 'a Lwd.t list -> 'a list Lwd.t
(** Commute [Lwd] and [list] *)
(** {1 Miscellaneous functions}
I don't know where to put these, but they are useful, especially for
UI-related computations.
*)
val mini : int -> int -> int
(** Minimum of two integers *)
val maxi : int -> int -> int
(** Maximum of two integers *)
val clampi : int -> min:int -> max:int -> int
(** Clamp an integer between two bounds. *)
val minf : float -> float -> float
(** Minimum of two floats *)
val maxf : float -> float -> float
(** Maximum of two floats *)
val clampf : float -> min:float -> max:float -> float
(** Clamp a float between two bounds. *)

View File

@ -267,8 +267,8 @@ let rec pretty_flat = function
this ugly 100-lines long implementation.
*)
let maxi i j : int = if i < j then j else i
let mini i j : int = if i < j then i else j
let mini, maxi = Lwd_utils.(mini, maxi)
let (+++) i j = let result = i + j in if result < 0 then max_int else result
let nonflat_line ui =

View File

@ -1,7 +1,5 @@
open Notty
let maxi x y : int = if x > y then x else y
let mini x y : int = if x < y then x else y
open Lwd_utils
module Focus :
sig
@ -441,9 +439,9 @@ struct
if has_transient_sensor ui.flags || (
has_permanent_sensor ui.flags &&
match ui.sensor_cache with
| None -> false
| None -> true
| Some (ox', oy', sw', sh') ->
ox = ox' && oy = oy' && sw = sw' && sh = sh'
not (ox = ox' && oy = oy' && sw = sw' && sh = sh')
)
then (
ui.flags <- ui.flags land lnot flag_transient_sensor;

View File

@ -3,6 +3,7 @@ open Notty
open Nottui
let empty_lwd = Lwd.return Ui.empty
let (mini, maxi, clampi) = Lwd_utils.(mini, maxi, clampi)
let string ?(attr=A.empty) str =
let control_character_index str i =
@ -154,7 +155,7 @@ let vscroll_area ~state ~change t =
let total = ref (-1) in
let scroll state delta =
let position = state.position + delta in
let position = max 0 (min state.bound position) in
let position = clampi position ~min:0 ~max:state.bound in
if position <> state.position then
change `Action {state with position};
`Handled
@ -190,7 +191,7 @@ let vscroll_area ~state ~change t =
in
if tchange || vchange then
change `Content {state with visible = !visible; total = !total;
bound = max 0 (!total - !visible); }
bound = maxi 0 (!total - !visible); }
)
|> Ui.mouse_area (scroll_handler state)
|> Ui.keyboard_area (focus_handler state)
@ -200,8 +201,8 @@ let scroll_area ?(offset=0,0) t =
let offset = Lwd.var offset in
let scroll d_x d_y =
let s_x, s_y = Lwd.peek offset in
let s_x = max 0 (s_x + d_x) in
let s_y = max 0 (s_y + d_y) in
let s_x = maxi 0 (s_x + d_x) in
let s_y = maxi 0 (s_y + d_y) in
Lwd.set offset (s_x, s_y);
`Handled
in
@ -308,7 +309,8 @@ let h_pane left right =
| Split _ -> ui
| Re_split {at; _} ->
Ui.transient_sensor (fun ~x ~y:_ ~w ~h:_ () ->
Lwd.set state_var (Split {pos = (at - x); max = w})
let newpos = clampi (at - x) ~min:0 ~max:w in
Lwd.set state_var (Split {pos = newpos; max = w})
) ui
in
ui
@ -347,7 +349,8 @@ let v_pane top bot =
| Split _ -> ui
| Re_split {at; _} ->
Ui.transient_sensor (fun ~x:_ ~y ~w:_ ~h () ->
Lwd.set state_var (Split {pos = (at - y); max = h})
let newpos = clampi (at - y) ~min:0 ~max:h in
Lwd.set state_var (Split {pos = newpos; max = h})
) ui
in
ui
@ -361,7 +364,7 @@ let sub' str p l =
let edit_field ?(focus=Focus.make()) state ~on_change ~on_submit =
let update focus_h focus (text, pos) =
let pos = min (max 0 pos) (String.length text) in
let pos = clampi pos ~min:0 ~max:(String.length text) in
let content =
Ui.atom @@ I.hcat @@
if Focus.has_focus focus then (
@ -403,12 +406,12 @@ let edit_field ?(focus=Focus.make()) state ~on_change ~on_submit =
) else text
) else text
in
let pos = max 0 (pos - 1) in
let pos = maxi 0 (pos - 1) in
on_change (text, pos);
`Handled
| `Enter, _ -> on_submit (text, pos); `Handled
| `Arrow `Left, [] ->
let pos = min (String.length text) pos in
let pos = mini (String.length text) pos in
if pos > 0 then (
on_change (text, pos - 1);
`Handled
@ -586,21 +589,21 @@ let grid
Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows
end >>= fun (rows:Ui.t list list) ->
(* determine width of each column and height of each row *)
let n_cols = List.fold_left (fun n r -> max n (List.length r)) 0 rows in
let n_cols = List.fold_left (fun n r -> maxi n (List.length r)) 0 rows in
let col_widths = Array.make n_cols 1 in
List.iter
(fun row ->
List.iteri
(fun col_j cell ->
let w = (Ui.layout_spec cell).Ui.w in
col_widths.(col_j) <- max col_widths.(col_j) w)
col_widths.(col_j) <- maxi col_widths.(col_j) w)
row)
rows;
begin match max_w with
| None -> ()
| Some max_w ->
(* limit width *)
Array.iteri (fun i x -> col_widths.(i) <- min x max_w) col_widths
Array.iteri (fun i x -> col_widths.(i) <- mini x max_w) col_widths
end;
(* now render, with some padding *)
let pack_pad_x =
@ -614,11 +617,11 @@ let grid
List.map
(fun row ->
let row_h =
List.fold_left (fun n c -> max n (Ui.layout_spec c).Ui.h) 0 row
List.fold_left (fun n c -> maxi n (Ui.layout_spec c).Ui.h) 0 row
in
let row_h = match max_h with
| None -> row_h
| Some max_h -> min row_h max_h
| Some max_h -> mini row_h max_h
in
let row =
List.mapi
@ -698,3 +701,125 @@ let toggle, toggle' =
in
toggle, toggle'
type scrollbox_state = { w: int; h: int; x: int; y: int; }
let adjust_offset visible total off =
let off = if off + visible > total then total - visible else off in
let off = if off < 0 then 0 else off in
off
let decr_if x cond = if cond then x - 1 else x
let scrollbar_bg = Notty.A.gray 4
let scrollbar_fg = Notty.A.gray 7
let scrollbar_click_step = 3 (* Clicking scrolls one third of the screen *)
let scrollbar_wheel_step = 8 (* Wheel event scrolls 1/8th of the screen *)
let hscrollbar visible total offset ~set =
let prefix = offset * visible / total in
let suffix = (total - offset - visible) * visible / total in
let handle = visible - prefix - suffix in
let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' size 1) in
let mouse_handler ~x ~y:_ = function
| `Left ->
if x < prefix then
(set (offset - maxi 1 (visible / scrollbar_click_step)); `Handled)
else if x > prefix + handle then
(set (offset + maxi 1 (visible / scrollbar_click_step)); `Handled)
else `Grab (
(fun ~x:x' ~y:_ -> set (offset + (x' - x) * total / visible)),
(fun ~x:_ ~y:_ -> ())
)
| `Scroll dir ->
let dir = match dir with `Down -> +1 | `Up -> -1 in
set (offset + dir * (maxi 1 (visible / scrollbar_wheel_step)));
`Handled
| _ -> `Unhandled
in
let (++) = Ui.join_x in
Ui.mouse_area mouse_handler (
render prefix scrollbar_bg ++
render handle scrollbar_fg ++
render suffix scrollbar_bg
)
let vscrollbar visible total offset ~set =
let prefix = offset * visible / total in
let suffix = (total - offset - visible) * visible / total in
let handle = visible - prefix - suffix in
let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' 1 size) in
let mouse_handler ~x:_ ~y = function
| `Left ->
if y < prefix then
(set (offset - maxi 1 (visible / scrollbar_click_step)); `Handled)
else if y > prefix + handle then
(set (offset + maxi 1 (visible / scrollbar_click_step)); `Handled)
else `Grab (
(fun ~x:_ ~y:y' -> set (offset + (y' - y) * total / visible)),
(fun ~x:_ ~y:_ -> ())
)
| `Scroll dir ->
let dir = match dir with `Down -> +1 | `Up -> -1 in
set (offset + dir * (maxi 1 (visible / scrollbar_wheel_step)));
`Handled
| _ -> `Unhandled
in
let (++) = Ui.join_y in
Ui.mouse_area mouse_handler (
render prefix scrollbar_bg ++
render handle scrollbar_fg ++
render suffix scrollbar_bg
)
let scrollbox t =
(* Keep track of scroll state *)
let state_var = Lwd.var {w = 0; h = 0; x = 0; y = 0} in
(* Keep track of size available for display *)
let update_size ~w ~h =
let state = Lwd.peek state_var in
if state.w <> w || state.h <> h then Lwd.set state_var {state with w; h}
in
let measure_size body =
Ui.size_sensor update_size (Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:1 body)
in
(* Given body and state, composite scroll bars *)
let compose_bars body state =
let (bw, bh) = Ui.layout_width body, Ui.layout_height body in
(* Logic to determine which scroll bar should be visible *)
let hvisible = state.w < bw and vvisible = state.h < bh in
let hvisible = hvisible || (vvisible && state.w = bw) in
let vvisible = vvisible || (hvisible && state.h = bh) in
(* Compute size and offsets based on visibility *)
let state_w = decr_if state.w vvisible in
let state_h = decr_if state.h hvisible in
let state_x = adjust_offset state_w bw state.x in
let state_y = adjust_offset state_h bh state.y in
(* Composite visible scroll bars *)
let crop b =
Ui.resize ~sw:1 ~sh:1 ~w:0 ~h:0
(Ui.shift_area state_x state_y b)
in
let set_vscroll y =
let state = Lwd.peek state_var in
if state.y <> y then Lwd.set state_var {state with y}
in
let set_hscroll x =
let state = Lwd.peek state_var in
if state.x <> x then Lwd.set state_var {state with x}
in
let (<->) = Ui.join_y and (<|>) = Ui.join_x in
match hvisible, vvisible with
| false , false -> body
| false , true ->
crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll
| true , false ->
crop body <-> hscrollbar state_w bw state_x ~set:set_hscroll
| true , true ->
(crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll)
<->
(hscrollbar state_w bw state_x ~set:set_hscroll <|> Ui.space 1 1)
in
(* Render final box *)
Lwd.map2 t (Lwd.get state_var)
~f:(fun ui size -> measure_size (compose_bars ui size))

View File

@ -41,6 +41,8 @@ val vscroll_area :
val scroll_area :
?offset:int * int -> ui Lwd.t -> ui Lwd.t
val scrollbox: ui Lwd.t -> ui Lwd.t
(* FIXME Explain panes *)
val v_pane : ui Lwd.t -> ui Lwd.t -> ui Lwd.t
val h_pane : ui Lwd.t -> ui Lwd.t -> ui Lwd.t

View File

@ -35,6 +35,13 @@ let child_node node = Leaf node
let child_join left right = Inner { bound = Js.null; left; right }
let js_lwd_to_remove =
Js.string "lwd-to-remove" (* HACK Could be turned into a Javascript symbol *)
let contains_focus node =
Js.to_bool (Js.Unsafe.meth_call (node : raw_node) "contains"
[|Js.Unsafe.inject Dom_html.document##.activeElement|])
let update_children (self : raw_node) (children : raw_node live) : unit Lwd.t =
let reducer =
ref (Lwd_seq.Reducer.make ~map:child_node ~reduce:child_join)
@ -43,18 +50,40 @@ let update_children (self : raw_node) (children : raw_node live) : unit Lwd.t =
let dropped, reducer' =
Lwd_seq.Reducer.update_and_get_dropped !reducer children in
reducer := reducer';
let remove_child child () = match child with
| Leaf node -> ignore (self##removeChild node)
let schedule_for_removal child () = match child with
| Leaf node -> Js.Unsafe.set node js_lwd_to_remove Js._true
| Inner _ -> ()
in
Lwd_seq.Reducer.fold_dropped `Map remove_child dropped ();
Lwd_seq.Reducer.fold_dropped `Map schedule_for_removal dropped ();
let preserve_focus = contains_focus self in
begin match Lwd_seq.Reducer.reduce reducer' with
| None -> ()
| Some tree ->
let rec update acc = function
| Leaf x ->
if x##.nextSibling != acc || x##.parentNode != Js.some self then
ignore (self##insertBefore x acc);
Js.Unsafe.delete x js_lwd_to_remove;
if x##.parentNode != Js.some self then
ignore (self##insertBefore x acc)
else if x##.nextSibling != acc then begin
(* Parent is correct but sibling is not: swap nodes, but be
cautious with focus *)
if preserve_focus && contains_focus x then (
let rec shift_siblings () =
let sibling = x##.nextSibling in
if sibling == acc then
true
else match Js.Opt.to_option sibling with
| None -> false
| Some sibling ->
ignore (self##insertBefore sibling (Js.some x));
shift_siblings ()
in
if not (shift_siblings ()) then
ignore (self##insertBefore x acc)
)
else
ignore (self##insertBefore x acc)
end;
Js.some x
| Inner t ->
if Js.Opt.test t.bound then t.bound else (
@ -65,7 +94,14 @@ let update_children (self : raw_node) (children : raw_node live) : unit Lwd.t =
)
in
ignore (update Js.null tree)
end
end;
let remove_child child () = match child with
| Leaf node ->
if Js.Opt.test (Js.Unsafe.get node js_lwd_to_remove) then
ignore (self##removeChild node)
| Inner _ -> ()
in
Lwd_seq.Reducer.fold_dropped `Map remove_child dropped ();
end
let update_children_list self children =
@ -1174,8 +1210,7 @@ module Html : sig
val a_min : float Lwd.t -> [>`Min] attrib
val a_input_min : number_or_datetime Lwd.t -> [>`Input_Min] attrib
val a_inputmode :
[<`Email|`Full_width_latin|`Kana|`Katakana|`Latin
|`Latin_name|`Latin_prose|`Numeric|`Tel|`Url|`Verbatim] Lwd.t ->
[<`Decimal|`Email|`None|`Numeric|`Search|`Tel|`Text|`Url] Lwd.t ->
[>`Inputmode] attrib
val a_novalidate : unit -> [>`Novalidate] attrib
val a_open : unit -> [>`Open] attrib

View File

@ -531,8 +531,7 @@ module Html : sig
val a_min : float Lwd.t -> [>`Min] attrib
val a_input_min : number_or_datetime Lwd.t -> [>`Input_Min] attrib
val a_inputmode :
[<`Email|`Full_width_latin|`Kana|`Katakana|`Latin
|`Latin_name|`Latin_prose|`Numeric|`Tel|`Url|`Verbatim] Lwd.t ->
[<`Decimal|`Email|`None|`Numeric|`Search|`Tel|`Text|`Url] Lwd.t ->
[>`Inputmode] attrib
val a_novalidate : unit -> [>`Novalidate] attrib
val a_open : unit -> [>`Open] attrib

View File

@ -8,14 +8,15 @@ homepage: "https://github.com/let-def/lwd"
doc: "https://let-def.github.io/lwd/doc"
bug-reports: "https://github.com/let-def/lwd/issues"
depends: [
"dune" {>= "2.0"}
"dune" {>= "2.7"}
"seq"
"ocaml" {>= "4.03"}
"qtest" {with-test}
"qcheck" {with-test}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {pinned}
["dune" "subst"] {dev}
[
"dune"
"build"

View File

@ -8,13 +8,14 @@ homepage: "https://github.com/let-def/lwd"
doc: "https://let-def.github.io/lwd/doc"
bug-reports: "https://github.com/let-def/lwd/issues"
depends: [
"dune" {>= "2.0"}
"notty"
"dune" {>= "2.7"}
"lwt"
"nottui"
"nottui" {= version}
"notty" {>= "0.2"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {pinned}
["dune" "subst"] {dev}
[
"dune"
"build"

View File

@ -8,12 +8,13 @@ homepage: "https://github.com/let-def/lwd"
doc: "https://let-def.github.io/lwd/doc"
bug-reports: "https://github.com/let-def/lwd/issues"
depends: [
"dune" {>= "2.0"}
"notty"
"nottui"
"dune" {>= "2.7"}
"nottui" {= version}
"notty" {>= "0.2"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {pinned}
["dune" "subst"] {dev}
[
"dune"
"build"

View File

@ -8,12 +8,13 @@ homepage: "https://github.com/let-def/lwd"
doc: "https://let-def.github.io/lwd/doc"
bug-reports: "https://github.com/let-def/lwd/issues"
depends: [
"dune" {>= "2.0"}
"lwd"
"notty"
"dune" {>= "2.7"}
"lwd" {= version}
"notty" {>= "0.2"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {pinned}
["dune" "subst"] {dev}
[
"dune"
"build"

View File

@ -7,9 +7,16 @@ license: "MIT"
homepage: "https://github.com/let-def/lwd"
doc: "https://let-def.github.io/lwd/doc"
bug-reports: "https://github.com/let-def/lwd/issues"
depends: ["dune" "lwd" "tyxml" "js_of_ocaml" "js_of_ocaml-ppx"]
depends: [
"dune" {>= "2.7"}
"lwd" {= version}
"tyxml" {>= "4.5.0"}
"js_of_ocaml"
"js_of_ocaml-ppx"
"odoc" {with-doc}
]
build: [
["dune" "subst"] {pinned}
["dune" "subst"] {dev}
[
"dune"
"build"