Compare commits
31 Commits
Author | SHA1 | Date |
---|---|---|
Frédéric Bour | 77351d2e2c | |
Frédéric Bour | ca68a42d35 | |
Frédéric Bour | 3b093a572a | |
Frédéric Bour | 3fcf7c0696 | |
Frédéric Bour | 4f6c9ea387 | |
Frédéric Bour | 5ab38ed701 | |
Frédéric Bour | ef73c77ea8 | |
Frédéric Bour | a703fcb6f7 | |
Frédéric Bour | 5441e4a388 | |
Frédéric Bour | 1b8801af45 | |
Frédéric Bour | c229f9cff2 | |
Frédéric Bour | e38469ddad | |
Frédéric Bour | adebdfa2c3 | |
Frédéric Bour | 5702aa5287 | |
Score_Under | 7b2b63c65b | |
Frédéric Bour | e1587add76 | |
Frédéric Bour | 3bfeca4d37 | |
Frédéric Bour | 33dbd25b04 | |
Frédéric Bour | b3b6b0a46d | |
Frédéric Bour | 1c0c26975b | |
Frédéric Bour | e361cadacc | |
Frédéric Bour | 406a2c7eb8 | |
Frédéric Bour | 55a5297a3b | |
Frédéric Bour | 46e1fe7386 | |
Frédéric Bour | e91cb0bcaa | |
Frédéric Bour | ff76941eda | |
Frédéric Bour | c4a2d18ce4 | |
Frédéric Bour | 4d72cb6984 | |
Frédéric Bour | 6d74d2c00d | |
Frédéric Bour | 022cd7a92e | |
Frédéric Bour | 0fe8b311dd |
|
@ -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
|
@ -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
|
||||
|
|
|
@ -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"
|
18
dune-project
|
@ -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))))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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))
|
|
@ -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);
|
||||
()
|
|
@ -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>
|
Before Width: | Height: | Size: 576 B After Width: | Height: | Size: 576 B |
Before Width: | Height: | Size: 714 B After Width: | Height: | Size: 714 B |
Before Width: | Height: | Size: 718 B After Width: | Height: | Size: 718 B |
Before Width: | Height: | Size: 650 B After Width: | Height: | Size: 650 B |
Before Width: | Height: | Size: 698 B After Width: | Height: | Size: 698 B |
Before Width: | Height: | Size: 764 B After Width: | Height: | Size: 764 B |
Before Width: | Height: | Size: 620 B After Width: | Height: | Size: 620 B |
Before Width: | Height: | Size: 802 B After Width: | Height: | Size: 802 B |
Before Width: | Height: | Size: 1.1 KiB After Width: | Height: | Size: 1.1 KiB |
Before Width: | Height: | Size: 403 B After Width: | Height: | Size: 403 B |
Before Width: | Height: | Size: 735 B After Width: | Height: | Size: 735 B |
Before Width: | Height: | Size: 434 B After Width: | Height: | Size: 434 B |
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
|
@ -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
|
||||
|
|
|
@ -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 -> ()
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -0,0 +1,4 @@
|
|||
(library
|
||||
(name brr_lwd)
|
||||
(public_name brr-lwd)
|
||||
(libraries brr lwd))
|
|
@ -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
|
|
@ -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} *)
|
135
lib/lwd/lwd.ml
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. *)
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
5
lwd.opam
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|