terminal user interface to jujutsu. Focused on speed and clarity
add lwd fork and use mutex version
+8007
-874
+19
.vscode/launch.json
+19
.vscode/launch.json
···
1
+
{
2
+
// Use IntelliSense to learn about possible attributes.
3
+
// Hover to view descriptions of existing attributes.
4
+
// For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387
5
+
"version": "0.2.0",
6
+
"configurations": [
7
+
{
8
+
"name": "test_program",
9
+
"type": "ocaml.earlybird",
10
+
"request": "launch",
11
+
"stopOnEntry": true,
12
+
"console": "integratedTerminal",
13
+
"program": "${workspaceFolder}/_build/default/jj_tui/bin/main.bc",
14
+
"onlyDebugGlob": "<${workspaceFolder}/**/*>",
15
+
"yieldSteps": 1024,
16
+
"cwd": "${workspaceFolder}"
17
+
}
18
+
]
19
+
}
+1
dune-project
+1
dune-project
err
err
This is a binary file and will not be displayed.
+98
-18
flake.nix
+98
-18
flake.nix
···
72
72
};
73
73
picos = ocamlPackages.buildDunePackage {
74
74
pname = "picos";
75
-
version = "0.5.0";
75
+
version = "0.6.0";
76
76
duneVersion = "3";
77
77
src = picos_src;
78
78
buildInputs = with ocamlPackages; [
79
79
backoff
80
80
thread-local-storage
81
81
];
82
-
82
+
propagatedBuildInputs = with ocamlPackages; [
83
+
backoff
84
+
thread-local-storage
85
+
];
83
86
strictDeps = true;
84
87
};
85
88
picos_std = ocamlPackages.buildDunePackage {
86
89
pname = "picos_std";
87
-
version = "0.5.0";
90
+
version = "0.6.0";
88
91
duneVersion = "3";
89
92
src = picos_src;
90
93
buildInputs = with ocamlPackages; [
···
94
97
thread-local-storage
95
98
multicore-magic
96
99
];
97
-
100
+
propagatedBuildInputs = with ocamlPackages; [
101
+
backoff
102
+
thread-local-storage
103
+
multicore-magic
104
+
picos_aux
105
+
];
98
106
strictDeps = true;
99
107
};
100
108
picos_aux = ocamlPackages.buildDunePackage {
101
109
pname = "picos_aux";
102
-
version = "0.5.0";
110
+
version = "0.6.0";
103
111
duneVersion = "3";
104
112
src = picos_src;
105
113
buildInputs = with ocamlPackages; [
···
111
119
};
112
120
picos_mux = ocamlPackages.buildDunePackage {
113
121
pname = "picos_mux";
114
-
version = "0.5.0";
122
+
version = "0.6.0";
115
123
duneVersion = "3";
116
124
src = picos_src;
117
125
buildInputs = with ocamlPackages; [
···
123
131
thread-local-storage
124
132
psq
125
133
];
126
-
134
+
propagatedBuildInputs = with ocamlPackages; [
135
+
psq
136
+
];
127
137
strictDeps = true;
128
138
};
129
139
picos_io = ocamlPackages.buildDunePackage {
130
140
pname = "picos_io";
131
-
version = "0.5.0";
141
+
version = "0.6.0";
132
142
duneVersion = "3";
133
143
src = picos_src;
134
144
buildInputs = with ocamlPackages; [
···
143
153
psq
144
154
thread-local-storage
145
155
];
156
+
propagatedBuildInputs = with ocamlPackages; [
157
+
psq
158
+
mtime
159
+
];
160
+
146
161
strictDeps = true;
147
162
};
148
163
picos_mux_with_io = ocamlPackages.buildDunePackage {
149
164
pname = "picos_mux";
150
-
version = "0.5.0";
165
+
version = "0.6.0";
151
166
duneVersion = "3";
152
167
src = picos_src;
153
168
buildInputs =
···
162
177
multicore-magic
163
178
thread-local-storage
164
179
];
180
+
propagatedBuildInputs = with ocamlPackages; [
181
+
backoff
182
+
multicore-magic
183
+
thread-local-storage
184
+
];
165
185
166
186
strictDeps = true;
167
187
};
···
181
201
];
182
202
strictDeps = true;
183
203
};
184
-
185
204
lwd = ocamlPackages.buildDunePackage {
186
205
pname = "lwd";
187
206
version = "0.1.0";
188
207
duneVersion = "3";
189
-
src = pkgs.fetchFromGitHub {
208
+
209
+
src = ./forks/lwd/.;
190
210
191
-
owner = "faldor20";
192
-
repo = "lwd";
193
-
rev = "c19bc2fd55c2de977cdd283458ce06402b08febe";
194
-
sha256 = "sha256-8QwDzRgffA4wnE9vWLpLfy9MdQ5Yc8wBF5jgRamGMfA=";
195
-
};
211
+
# pkgs.fetchFromGitHub {
196
212
197
-
buildInputs = with ocamlPackages; [ seq ];
213
+
# owner = "faldor20";
214
+
# repo = "lwd";
215
+
# rev = "c19bc2fd55c2de977cdd283458ce06402b08febe";
216
+
# sha256 = "sha256-8QwDzRgffA4wnE9vWLpLfy9MdQ5Yc8wBF5jgRamGMfA=";
217
+
# };
218
+
219
+
buildInputs = with ocamlPackages; [ seq logs ];
220
+
propagatedBuildInputs = with ocamlPackages; [ logs ];
221
+
222
+
strictDeps = false;
223
+
};
224
+
lwd_picos = ocamlPackages.buildDunePackage {
225
+
pname = "lwd_picos";
226
+
version = "0.1.0";
227
+
duneVersion = "3";
228
+
229
+
src = ./forks/lwd/.;
230
+
231
+
buildInputs = with ocamlPackages; [ seq lwd picos picos_std backoff multicore-magic thread-local-storage ];
232
+
propagatedBuildInputs = with ocamlPackages; [
233
+
234
+
lwd
235
+
];
198
236
199
237
strictDeps = true;
200
238
};
···
233
271
234
272
strictDeps = true;
235
273
};
274
+
nottui_picos=
275
+
let
276
+
pname = "nottui_picos";
277
+
in
278
+
ocamlPackages.buildDunePackage {
279
+
pname = "nottui_picos";
280
+
version = "dev";
281
+
duneVersion = "3";
282
+
src = ./forks/nottui/.;
283
+
buildInputs = with ocamlPackages; [
284
+
logs
285
+
signal
286
+
# lwd
287
+
lwd_picos
288
+
nottui
289
+
picos
290
+
picos_io
291
+
picos_std
292
+
notty-mine
293
+
seq
294
+
];
295
+
buildPhase = ''
296
+
runHook preBuild
297
+
rm -rf ./tutorial
298
+
dune build -p ${pname} ''${enableParallelBuilding:+-j $NIX_BUILD_CORES}
299
+
runHook postBuild
300
+
'';
301
+
checkPhase = ''
302
+
runHook preCheck
303
+
dune runtest -p ${pname}''${enableParallelBuilding:+-j $NIX_BUILD_CORES}
304
+
runHook postCheck
305
+
'';
306
+
installPhase = ''
307
+
runHook preInstall
308
+
dune install --prefix $out --libdir $OCAMLFIND_DESTDIR ${pname}
309
+
runHook postInstall
310
+
'';
311
+
312
+
strictDeps = true;
313
+
};
236
314
237
315
jj_tui_build_pkgs =
238
316
···
241
319
++ picos_aux.buildInputs
242
320
++ [
243
321
lwd
322
+
lwd_picos
244
323
notty-mine
245
324
nottui
325
+
nottui_picos
246
326
picos
247
327
picos_std
248
328
picos_io
···
344
424
inputsFrom = [ self'.packages.default ];
345
425
packages = builtins.attrValues {
346
426
inherit (pkgs) gcc pkg-config;
347
-
inherit (ocamlPackages) ocaml-lsp ocamlformat-rpc-lib;
427
+
inherit (ocamlPackages) ocaml-lsp ocamlformat-rpc-lib earlybird;
348
428
};
349
429
};
350
430
};
+1
forks/lwd/.envrc
+1
forks/lwd/.envrc
···
1
+
use flake
+39
forks/lwd/.github/workflows/main.yml
+39
forks/lwd/.github/workflows/main.yml
···
1
+
name: Main workflow
2
+
3
+
on:
4
+
pull_request:
5
+
push:
6
+
schedule:
7
+
# Prime the caches every Monday
8
+
- cron: 0 1 * * MON
9
+
10
+
jobs:
11
+
build:
12
+
strategy:
13
+
fail-fast: false
14
+
matrix:
15
+
os:
16
+
- macos-latest
17
+
- ubuntu-latest
18
+
# - windows-latest
19
+
ocaml-compiler:
20
+
- 5.0.0
21
+
- 4.14.x
22
+
- 4.08.x
23
+
24
+
runs-on: ${{ matrix.os }}
25
+
26
+
steps:
27
+
- name: Checkout code
28
+
uses: actions/checkout@v3
29
+
30
+
- name: Use OCaml ${{ matrix.ocaml-compiler }}
31
+
uses: ocaml/setup-ocaml@v2
32
+
with:
33
+
ocaml-compiler: ${{ matrix.ocaml-compiler }}
34
+
35
+
- run: opam install . --deps-only --with-test
36
+
37
+
- run: opam exec -- dune build
38
+
39
+
- run: opam exec -- dune runtest
+30
forks/lwd/.gitignore
+30
forks/lwd/.gitignore
···
1
+
*.annot
2
+
*.cmo
3
+
*.cma
4
+
*.cmi
5
+
*.a
6
+
*.o
7
+
*.cmx
8
+
*.cmxs
9
+
*.cmxa
10
+
11
+
# ocamlbuild working directory
12
+
_build/
13
+
14
+
# ocamlbuild targets
15
+
*.byte
16
+
*.native
17
+
18
+
# oasis generated files
19
+
setup.data
20
+
setup.log
21
+
22
+
# Merlin configuring file for Vim and Emacs
23
+
.merlin
24
+
25
+
# Dune generated files
26
+
*.install
27
+
28
+
# Local OPAM switch
29
+
_opam/
30
+
.direnv
+1
forks/lwd/.ocamlformat
+1
forks/lwd/.ocamlformat
···
1
+
profile = janestreet
+19
forks/lwd/.vscode/launch.json
+19
forks/lwd/.vscode/launch.json
···
1
+
{
2
+
// Use IntelliSense to learn about possible attributes.
3
+
// Hover to view descriptions of existing attributes.
4
+
// For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387
5
+
"version": "0.2.0",
6
+
"configurations": [
7
+
{
8
+
"name": "test_program",
9
+
"type": "ocaml.earlybird",
10
+
"request": "launch",
11
+
"stopOnEntry": true,
12
+
"console": "integratedTerminal",
13
+
"program": "${workspaceFolder}/_build/default/examples/interact/test_program.bc",
14
+
"onlyDebugGlob": "<${workspaceFolder}/**/*>",
15
+
"yieldSteps": 1024,
16
+
"cwd": "${workspaceFolder}"
17
+
}
18
+
]
19
+
}
+7
forks/lwd/.vscode/settings.json
+7
forks/lwd/.vscode/settings.json
+45
forks/lwd/CHANGES
+45
forks/lwd/CHANGES
···
1
+
v0.4 - Alpha 0.4 UNRELEASED
2
+
======
3
+
4
+
- Add Lwd.update (by @OlivierNicole and @Julow) and Lwd.may_update functions
5
+
- Lwd.set: change binding before invalidation, otherwise the old value could be re-observed (reported by @voodoos)
6
+
- brr-lwd: support declarative events and set of css classes
7
+
- Nottui: fix treatment of some terminal events that were delayed because of improper buffer flushing, reported by @darrenldl
8
+
9
+
v0.3 - Alpha 0.3
10
+
======
11
+
Mon Sep 5 10:57:53 JST 2022
12
+
13
+
- Add [Lwd_seq.sort_uniq] function
14
+
- Make [Lwd_seq.t] injective
15
+
- Fix a bug breaking invariants in Lwd_table.remove
16
+
- Documentation update contributed by @shubhamkumar13
17
+
- Option to disable the default Quit behavior of Nottui contributed by @OhadRau
18
+
19
+
v0.2 - Alpha 0.2
20
+
======
21
+
Sun Feb 20 20:49:47 JST 2022
22
+
23
+
- Lwd.fix operator helps working with graphs that cannot be evaluated in a
24
+
single pass
25
+
- brr-lwd library integrates Lwd with Brr library, for writing javascript
26
+
applications
27
+
28
+
Bug fixes:
29
+
- fixed invalidation in Lwd
30
+
- restored some internal invariants in Lwd_seq
31
+
- fixed behavior of Notty sensors
32
+
33
+
v0.1 - Alpha 0.1
34
+
======
35
+
Wed Sep 23 14:51:17 CEST 2020
36
+
37
+
Preview release, the API is not yet stabilized.
38
+
Most features are there, except support for overlays (menu, dialog windows,
39
+
popup, ...) in Nottui.
40
+
41
+
Libraries included in this release:
42
+
- Lwd, the definition of reactive documents
43
+
- Nottui, reactive terminal interfaces using Notty & Lwd
44
+
- Nottui-lwt, an asynchronous mainloop for Nottui
45
+
- Tyxml-lwd, strongly-typed reactive webpages in Jsoo using Tyxml & Lwd
+21
forks/lwd/LICENSE
+21
forks/lwd/LICENSE
···
1
+
MIT License
2
+
3
+
Copyright (c) 2019 Frédéric Bour
4
+
5
+
Permission is hereby granted, free of charge, to any person obtaining a copy
6
+
of this software and associated documentation files (the "Software"), to deal
7
+
in the Software without restriction, including without limitation the rights
8
+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9
+
copies of the Software, and to permit persons to whom the Software is
10
+
furnished to do so, subject to the following conditions:
11
+
12
+
The above copyright notice and this permission notice shall be included in all
13
+
copies or substantial portions of the Software.
14
+
15
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16
+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17
+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18
+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19
+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20
+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21
+
SOFTWARE.
+29
forks/lwd/Makefile
+29
forks/lwd/Makefile
···
1
+
all:
2
+
dune build
3
+
4
+
clean:
5
+
dune clean
6
+
7
+
TESTS=minimal misc reranger stress pretty \
8
+
cbor/cbor_of_fs cbor/cbor_explorer
9
+
RUN_TESTS_BC=$(patsubst %, run-%, $(TESTS))
10
+
RUN_TESTS_EXE=$(patsubst %, run-%.exe, $(TESTS))
11
+
12
+
$(TESTS):
13
+
dune build examples/$@.bc
14
+
15
+
examples:
16
+
dune build $(patsubst %,examples/%.bc,$(TESTS))
17
+
18
+
$(RUN_TESTS_BC):
19
+
dune exec examples/$(patsubst run-%,%,$@.bc)
20
+
21
+
$(RUN_TESTS_EXE):
22
+
dune exec examples/$(patsubst run-%,%,$@)
23
+
24
+
run-cbor-explorer.exe:
25
+
rm curdir.cbor || true
26
+
dune exec examples/cbor/cbor_of_fs.exe -- -o curdir.cbor ./
27
+
dune exec examples/cbor/cbor_explorer.exe -- curdir.cbor
28
+
29
+
.PHONY: all clean examples $(RUN_TESTS_BC) $(RUN_TESTS_EXE)
+222
forks/lwd/README.md
+222
forks/lwd/README.md
···
1
+
# Lwd: a "lightweight document" library
2
+
3
+
`Lwd` is a library that lets you build values that changes over time. It is a simple form of incremental computation, in the like of [Incremental](https://github.com/janestreet/incremental) and [React](https://github.com/dbuenzli/react).
4
+
5
+
It is only about interactivity. A bunch of companion libraries make it usable in different settings:
6
+
7
+
- [Nottui](lib/nottui) renders user interface in the terminal
8
+
- [Nottui-lwt](lib/nottui-lwt) add support for concurrent/asynchronous UI to Nottui
9
+
- [Nottui-pretty](lib/nottui-pretty) is an interactive pretty-printer (based on [Pprint](https://github.com/fpottier/pprint))
10
+
- [Tyxml-lwd](lib/tyxml-lwd) is a Js_of_ocaml library for making interactive applications, using Lwd for updating the DOM and [Tyxml](https://github.com/ocsigen/tyxml) for writing typesafe HTML Document.
11
+
12
+
```shell
13
+
$ opam pin add tyxml https://github.com/ocsigen/tyxml.git#wraps
14
+
```
15
+
16
+
[TOC]
17
+
18
+
## Documents?
19
+
20
+
`Lwd` shines when constructing a single value, which we call a document, by aggregating many sub-documents. These sub-documents might be updated independently and we want to keep a consistent view on the aggregated document: when we observe it, it should be the aggregate of the sub-documents in their current version.
21
+
22
+
We will illustrate that with some examples. First we need to define the syntax for the final document:
23
+
24
+
```ocaml
25
+
type hypertext =
26
+
| Text of string
27
+
| Link of (unit -> unit) * hypertext
28
+
| List of hypertext list
29
+
```
30
+
31
+
A value of type `hypertext` will be interpreted by a backend. The interpretation is roughly as follows:
32
+
33
+
- `Text str` simply displays the string `str` to the user (for instance on a terminal)
34
+
- `Link (callback, hypertext')` displays the document `hypertext'`.
35
+
If the backend determines that the user is interacting with the content in this sub-document, `callback` is called.
36
+
- `List (doc1 :: doc2 :: ...)` displays `doc1` followed by `doc2` followed by `...`.
37
+
38
+
To keep the example simple, we didn't say anything about styling nor how interactions are determined. For instance, the backend could display plain text in a default color, switch to another color for text below a `Link _` constructor, and keep track of _focus_ by cycling between links when `<TAB>` is pressed and choosing a different color for the focused link.
39
+
40
+
A navigation menu could look like:
41
+
42
+
```ocaml
43
+
let newline = Text "\n" in
44
+
List [
45
+
Text "Welcome to my cafe"; newline;
46
+
Link (display_drink, Text "See drink options"); newline;
47
+
Link (display_food, Text "See food options"); newline;
48
+
]
49
+
```
50
+
51
+
We don't yet know how to implement the `display_drink` and `display_food` function but we have enough infrastructure to receive user intent. To complete the task, we will look at the idea of implementing a function that "changes its mind": it returned a value but, because of some circumstances, decide that another value should have been returned.
52
+
53
+
### Counting clicks
54
+
55
+
Let's imagine we want to make a button that counts the number of times it has been clicked: at first it displays 0, when triggered the 0 switch to 1, etc.
56
+
57
+
```ocaml
58
+
let counter = ref 0
59
+
let on_click () = counter := !counter + 1
60
+
61
+
let button clicks =
62
+
Link (on_click, Text ("Clicked " ^ string_of_int clicks ^ " times"))
63
+
64
+
let document = button !counter
65
+
```
66
+
67
+
We now have a counter that is incremented when the button is clicked. However the content of the button is not updated.
68
+
69
+
This is where `Lwd` comes into play: the `Lwd.var` type behaves almost like a reference but also tracks data dependencies. Let's update the example:
70
+
71
+
```ocaml
72
+
let counter = Lwd.var 0
73
+
let on_click () = Lwd.set counter (Lwd.peek counter + 1)
74
+
75
+
let button clicks =
76
+
Link (on_click, Text ("Clicked " ^ string_of_int clicks ^ " times"))
77
+
78
+
let document = Lwd.map ~f:button (Lwd.get counter)
79
+
```
80
+
81
+
We make use of the following `Lwd` functions:
82
+
83
+
```ocaml
84
+
(* Variable manipulation function *)
85
+
val Lwd.var : 'a -> 'a Lwd.var
86
+
val Lwd.set : 'a Lwd.var -> 'a -> unit
87
+
val Lwd.peek : 'a Lwd.var -> 'a
88
+
```
89
+
90
+
`var`, `set` and `peek` behave like `ref`, `:=` and `!`. They allocate a mutable cell, change its value and read the value at current time.
91
+
92
+
```ocaml
93
+
val Lwd.get : 'a Lwd.var -> 'a Lwd.t
94
+
```
95
+
96
+
`Lwd.get` reads a mutable cell, but while `Lwd.peek` returns the value immediately, `Lwd.get` lets you access the value wrapped in the `Lwd.t` type.
97
+
98
+
`Lwd` lets you build graph of computations with mutable inputs. The inputs or sources of the graph are made of `Lwd.var` while the inner nodes are built using combinators.
99
+
100
+
Here `Lwd.map : ~f:('a -> 'b) -> 'a Lwd.t -> 'b Lwd.t` apply a transformation to a varying value. That value might depend on arbitrary inputs, and if one of these input changes, the transformation will be recomputed too.
101
+
102
+
When the `Link` is triggered, the counter is incremented. Because `document` depends on the value of the counter it is invalidated.
103
+
104
+
### Building computation graph
105
+
106
+
`Lwd.t` implements a few abstractions that should be familiar to seasoned functional programmers:
107
+
108
+
- it is a _functor_. With `Lwd.map : ~f:('a -> 'b) -> 'a Lwd.t -> 'b Lwd.t` you can transform values and chain the transformations
109
+
- it is an _applicative functor_. With `Lwd.map2 : ~f:('a -> 'b -> 'c) -> 'a Lwd.t -> 'b Lwd.t > 'c Lwd.t` you can connect two different chains (making the computation tree shaped, actually with sharing it will form a DAG)
110
+
- and, although this should in general be avoided, a _monad_. With `Lwd.join : 'a Lwd.t Lwd.t -> 'a Lwd.t` you can have a first pipeline that computes another pipeline and inject the inner one.
111
+
112
+
### Consuming computation graph
113
+
114
+
So far we described how to build values of type `a Lwd.t` but we don't have a way to get access to those `a` outside of the _Lwd_ graph.
115
+
116
+
That's what `Lwd.root`s are for:
117
+
118
+
```ocaml
119
+
type 'a Lwd.root
120
+
val Lwd.observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root
121
+
val Lwd.set_on_invalidate : 'a root -> ('a -> unit) -> unit
122
+
123
+
val Lwd.sample : 'a root -> 'a
124
+
val Lwd.is_damaged : 'a root -> bool
125
+
val Lwd.release : 'a root -> unit
126
+
```
127
+
128
+
When you are interested in accessing the content of an `a Lwd.t` value, you create a root by `observe`-ing it.
129
+
130
+
`Lwd.sample` lets you access the value at the current time.
131
+
132
+
After calling `Lwd.sample`, the `on_invalidate` callback might be invoked if the value is invalidated: some input changed, the value you sampled is out of date.
133
+
134
+
When you are done with the `root` and are no longer interested in observing the value, you should call `release`. This call to `release` is very important: the `root` maintain the whole graph alive, so forgetting to `release` leads to memory leaks. After releasing, the on_invalidate callback will not be invoked.
135
+
136
+
A root can be in three possible states:
137
+
138
+
- released
139
+
- damaged
140
+
- sampled
141
+
142
+
When created, the root is in the `released` state: it does not maintain the graph alive.
143
+
144
+
Calling `sample` switches the root from the `released` to the `sampled` state.
145
+
146
+
```mermaid
147
+
graph TD;
148
+
R[Released]
149
+
S[Sampled]
150
+
D[Damaged]
151
+
s{"call to sample"}
152
+
i{"graph input change,<br/>call <tt>on_invalidate</tt>"}
153
+
r{"call to release"}
154
+
R-->s
155
+
s-->S
156
+
D-->s
157
+
S-->i
158
+
i-->D
159
+
S-->r
160
+
D-->r
161
+
r-->R
162
+
```
163
+
164
+
## Relation to HTML, DOM, and reactive UI libraries
165
+
166
+
**Syntax, data description and HTML.** To introduce our first example, we had to build a syntax using the simple `hypertext` algebraic data type. This type serves as an interface between the application and the interactive system: values of this type are produced by the front-end, like our example codes, and consumed by a back-end.
167
+
168
+
In the case of a web browser, the surface syntax is `HTML` which is much richer and more expressive than `hypertext` but ultimately is just data: a static description of some pieces of information.
169
+
170
+
**Adding programming languages.** Because static description are too limited for modern websites, Web browsers support the Javascript programming language. Pieces of javascript code can be put in the middle of the HTML syntax.
171
+
172
+
Similarly the `unit -> unit` parameter of the `Link` constructor allows to inject arbitrary OCaml code in the middle of an `hypertext` document.
173
+
174
+
**Making things interactive.** Being able to execute arbitrary piece of codes is not enough to make a document interactive: to make things dynamic the code needs to change the contents of the document in return.
175
+
176
+
Ultimately, interaction comes from this mutual dependency between document and code:
177
+
178
+
- the document contains codes that are executed in certain circumstances (determined by the meaning of elements of the document).
179
+
- when executed, a code can change the document, producing new elements associated to new codes.
180
+
- this updated document can then execute new pieces of code, that may update the document, and so on...
181
+
182
+
**The DOM.** Web browser's solution to allowing document update is the Document Object Model abstraction. The idea is to derive mutable data structures from the syntactic specification: each syntactic construction has a corresponding "DOM class" that can store the same information in mutable fields. Applied to our hypertext example:
183
+
184
+
```ocaml
185
+
type hypertext_dom =
186
+
| Text of { mutable text: string }
187
+
| Link of { mutable callback: (unit -> unit)
188
+
; mutable child: hypertext_dom }
189
+
| List of { mutable children: hypertext_dom list }
190
+
```
191
+
192
+
While this might be a natural derivation in imperative languages, it proved difficult and error-prone to manipulate. Thousands of Javascript libraries were proposed to ease DOM manipulation.
193
+
194
+
Some successful ones drew inspiration from functional programming, in the sense that they discouraged side-effects, producing new documents rather than modifying existing ones.
195
+
196
+
_Lwd_ rethinks this scaffolding: rather than starting from a static description, deriving mutable data structures to bring dynamism, and then restricting the mutations to make it manageable, we propose to keep the syntax as it is, lift the document in an `Lwd.t` computation graph and use variables nodes to express parts that can changes.
197
+
198
+
**Reactive UI.** It is difficult to make a fair comparison with these libraries as the term is loosely defined and there many competing approaches. Furthermore Lwd can be presented as an alternative to the DOM so it is effective at a lower-level than what common reactive libraries target.
199
+
200
+
That being said, we will try to address the following questions:
201
+
202
+
- can reactive libraries, to a reasonable extent, be reimplemented on top of _Lwd_ rather than _DOM_?
203
+
- can _Lwd_ be conveniently used without such layer?
204
+
205
+
The first question can be answered positively with a naive encoding: put `Lwd.var` everywhere, essentially keeping enough "degrees of freedom" to change things as needed later. No static structure is enforced this way.
206
+
207
+
To answer the second question, it is interesting to observe that there is no concept of "diffing" here. _Lwd_ does not try to see if things have changed in order to update them. Rather, if an input change, the whole branch that depends on it is recomputed.
208
+
209
+
So it is not VDOM/Diffing that could make Lwd convenient. Instead, it is the fact that most of the time, dependencies are made explicit.
210
+
Let's consider a component that changes its color when it is focused. With `Lwd` (and `Nottui`), this could be expressed as:
211
+
212
+
```ocaml
213
+
let focus = Focus.make () in
214
+
let color status =
215
+
if Focus.has_focus status then blue else black
216
+
in
217
+
button ~focus ~color:(Lwd.map ~f:color (Focus.status focus)))
218
+
```
219
+
220
+
The color of the button is defined declaratively: it cannot be changed elsewhere, no other part of the code can mutate it. It is this explicit declaration of dependencies that make it possible to reason about the code, to enforce invariants and to encapsulate behaviors.
221
+
222
+
`Lwd.var` is the escape hatch one can use to recover imperative code. But rather than being the default, it has to be opted in and can be exposed to a limited scope only.
+19
forks/lwd/TODO.md
+19
forks/lwd/TODO.md
···
1
+
- Document implementation
2
+
- Switch to labelled interface
3
+
- Make "window manager" a core Nottui concept:
4
+
- applications start by creating a window manager
5
+
- main loop runs a window manager and not a ui Lwd.t
6
+
- main loop quit when there is no window scheduled
7
+
- Benchmark "compact" trace representation:
8
+
It should consume a bit less memory (that should be observable in misc
9
+
example with a million edit fields) and should not affect runtime
10
+
performance... However it seems to do so (in misc and stress),
11
+
especially in bytecode, maybe because of the additional recursive functions.
12
+
- Add a standard mainloop / update scheduler to Tyxml-lwd:
13
+
- it should take into account different roots
14
+
(multiple sub-trees of the DOM that are maintained by lwd)
15
+
- it should support "unstable" documents (those that need more than one
16
+
update cycle):
17
+
- provide different levels of logging for profiling unstable parts?
18
+
- maybe split update cycles in different chunks, so that we can still
19
+
produce a frame within time budget when a fixpoint cannot be reached
+38
forks/lwd/dune-project
+38
forks/lwd/dune-project
···
1
+
(lang dune 3.5)
2
+
3
+
(generate_opam_files true)
4
+
5
+
(formatting
6
+
(enabled_for dune))
7
+
8
+
(name lwd)
9
+
10
+
(source
11
+
(github let-def/lwd))
12
+
13
+
(license MIT)
14
+
15
+
(authors "Frédéric Bour")
16
+
17
+
(maintainers "fred@tarides.com")
18
+
19
+
(package
20
+
(name lwd)
21
+
(synopsis "Lightweight reactive documents")
22
+
(documentation "https://let-def.github.io/lwd/doc")
23
+
(depends
24
+
dune
25
+
seq
26
+
(ocaml
27
+
(>= "5.2"))
28
+
(qtest :with-test)
29
+
(qcheck :with-test)))
30
+
31
+
(package
32
+
(name lwd_picos)
33
+
(synopsis "Lightweight reactive documents with Picos backend")
34
+
(allow_empty)
35
+
(depends
36
+
lwd
37
+
(picos (>= "0.6.0"))
38
+
(picos_std (>= "0.6.0"))))
+78
forks/lwd/flake.lock
+78
forks/lwd/flake.lock
···
1
+
{
2
+
"nodes": {
3
+
"flake-parts": {
4
+
"inputs": {
5
+
"nixpkgs-lib": "nixpkgs-lib"
6
+
},
7
+
"locked": {
8
+
"lastModified": 1749398372,
9
+
"narHash": "sha256-tYBdgS56eXYaWVW3fsnPQ/nFlgWi/Z2Ymhyu21zVM98=",
10
+
"owner": "hercules-ci",
11
+
"repo": "flake-parts",
12
+
"rev": "9305fe4e5c2a6fcf5ba6a3ff155720fbe4076569",
13
+
"type": "github"
14
+
},
15
+
"original": {
16
+
"id": "flake-parts",
17
+
"type": "indirect"
18
+
}
19
+
},
20
+
"nixpkgs": {
21
+
"inputs": {
22
+
"nixpkgs": "nixpkgs_2"
23
+
},
24
+
"locked": {
25
+
"lastModified": 1749954629,
26
+
"narHash": "sha256-cNOD88uVzBZRhOTil9HkSR2j0dFhZrjQWGevOAOWiUU=",
27
+
"owner": "nix-ocaml",
28
+
"repo": "nix-overlays",
29
+
"rev": "b7b23a9b51d4c083ea06878eae41c1aef775764d",
30
+
"type": "github"
31
+
},
32
+
"original": {
33
+
"owner": "nix-ocaml",
34
+
"repo": "nix-overlays",
35
+
"type": "github"
36
+
}
37
+
},
38
+
"nixpkgs-lib": {
39
+
"locked": {
40
+
"lastModified": 1748740939,
41
+
"narHash": "sha256-rQaysilft1aVMwF14xIdGS3sj1yHlI6oKQNBRTF40cc=",
42
+
"owner": "nix-community",
43
+
"repo": "nixpkgs.lib",
44
+
"rev": "656a64127e9d791a334452c6b6606d17539476e2",
45
+
"type": "github"
46
+
},
47
+
"original": {
48
+
"owner": "nix-community",
49
+
"repo": "nixpkgs.lib",
50
+
"type": "github"
51
+
}
52
+
},
53
+
"nixpkgs_2": {
54
+
"locked": {
55
+
"lastModified": 1749411262,
56
+
"narHash": "sha256-gRBkeW9l5lb/90lv1waQFNT+18OhITs11HENarh6vNo=",
57
+
"owner": "NixOS",
58
+
"repo": "nixpkgs",
59
+
"rev": "0fc422d6c394191338c9d6a05786c63fc52a0f29",
60
+
"type": "github"
61
+
},
62
+
"original": {
63
+
"owner": "NixOS",
64
+
"repo": "nixpkgs",
65
+
"rev": "0fc422d6c394191338c9d6a05786c63fc52a0f29",
66
+
"type": "github"
67
+
}
68
+
},
69
+
"root": {
70
+
"inputs": {
71
+
"flake-parts": "flake-parts",
72
+
"nixpkgs": "nixpkgs"
73
+
}
74
+
}
75
+
},
76
+
"root": "root",
77
+
"version": 7
78
+
}
+126
forks/lwd/flake.nix
+126
forks/lwd/flake.nix
···
1
+
# {
2
+
# inputs = {
3
+
# nixpkgs.url = "github:nix-ocaml/nix-overlays";
4
+
# flakelight.url = "github:nix-community/flakelight";
5
+
# };
6
+
7
+
# outputs =
8
+
# { flakelight, ... }@inputs:
9
+
# flakelight ./. {
10
+
# inherit inputs;
11
+
12
+
13
+
# # default devshell
14
+
# devShell= pkgs:
15
+
# let
16
+
# ocamlPackages = pkgs.ocaml-ng.ocamlPackages_5_3;
17
+
# in
18
+
# {
19
+
# packages = with pkgs; [
20
+
# # ocaml53.dune_3
21
+
# # ocaml53.utop
22
+
# ocamlPackages.ocaml-lsp
23
+
# # ocaml53.odoc
24
+
# # ocaml53.ocamlformat-rpc-lib
25
+
# ];
26
+
# inputsFrom = [
27
+
# # pkgs.lwd
28
+
# ];
29
+
# };
30
+
31
+
# # # Define the main package
32
+
# # package=
33
+
34
+
# # {
35
+
# # # ocamlPackages,
36
+
# # # lib,
37
+
# # defaultMeta,
38
+
# # pkgs,
39
+
# # }:
40
+
# # pkgs.ocamlPackages.buildDunePackage {
41
+
# # pname = "lwd";
42
+
# # version = "0.1.0";
43
+
# # src = ./.;
44
+
45
+
# # # nativeBuildInputs = with pkgs; with ocamlPackages; [
46
+
# # # dune
47
+
# # # utop
48
+
# # # ocaml
49
+
# # # ocamlformat
50
+
# # # re
51
+
# # # iter
52
+
# # # base
53
+
# # # angstrom
54
+
# # # ppx_let
55
+
# # # notty
56
+
# # # ppx_inline_test
57
+
# # # ppx_assert
58
+
# # # seq
59
+
# # # picos
60
+
# # # picos_std
61
+
# # # ];
62
+
# # meta = defaultMeta // {
63
+
# # description = "Lightweight reactive documents";
64
+
# # };
65
+
66
+
# # };
67
+
# };
68
+
# }
69
+
70
+
{
71
+
description = "Example JavaScript development environment for Zero to Nix";
72
+
73
+
# Flake inputs
74
+
inputs = {
75
+
nixpkgs.url = "github:nix-ocaml/nix-overlays";
76
+
};
77
+
# Flake outputs
78
+
outputs = { self, nixpkgs, flake-parts, ... }@inputs:
79
+
80
+
flake-parts.lib.mkFlake { inherit inputs; } {
81
+
systems =
82
+
[ "x86_64-linux" "aarch64-linux" "aarch64-darwin" "x86_64-darwin" ];
83
+
perSystem = { config, self', inputs', pkgs, system, ... }:
84
+
let
85
+
# OCaml packages available on nixpkgs
86
+
ocamlPackages = pkgs.ocaml-ng.ocamlPackages_5_2;
87
+
inherit (pkgs) mkShell lib;
88
+
in {
89
+
_module.args.pkgs = import inputs.nixpkgs {
90
+
inherit system;
91
+
config.allowUnfree = true;
92
+
};
93
+
94
+
devShells = {
95
+
default = mkShell.override { stdenv = pkgs.gccStdenv; } {
96
+
buildInputs = with ocamlPackages; [
97
+
dune
98
+
utop
99
+
ocaml
100
+
ocamlformat
101
+
re
102
+
iter
103
+
base
104
+
angstrom
105
+
ppx_let
106
+
notty
107
+
ppx_inline_test
108
+
ppx_assert
109
+
seq
110
+
picos
111
+
picos_std
112
+
];
113
+
inputsFrom = [
114
+
# self'.packages.default
115
+
# ocamlPackages.bonsai
116
+
];
117
+
packages = builtins.attrValues {
118
+
inherit (pkgs) gcc pkg-config;
119
+
inherit (ocamlPackages) ocaml-lsp ocamlformat-rpc-lib;
120
+
};
121
+
};
122
+
};
123
+
124
+
};
125
+
};
126
+
}
+67
forks/lwd/lib/lwd/custom_mutex.ml
+67
forks/lwd/lib/lwd/custom_mutex.ml
···
1
+
module type MUTEX = sig
2
+
(** Locks for mutual exclusion with support for multiple concurrency backends.
3
+
4
+
This module provides a unified interface for mutexes that can work with
5
+
different concurrency backends (OCaml standard library, Picos, etc.).
6
+
It extends the standard OCaml mutex interface with additional functionality
7
+
for acquiring multiple mutexes atomically.
8
+
*)
9
+
10
+
type t
11
+
(** The type of mutexes. *)
12
+
13
+
val create : unit -> t
14
+
(** Return a new mutex. *)
15
+
16
+
val lock : t -> unit
17
+
(** Lock the given mutex. Only one thread can have the mutex locked
18
+
at any time. A thread that attempts to lock a mutex already locked
19
+
by another thread will suspend until the other thread unlocks
20
+
the mutex.
21
+
22
+
@raise Sys_error if the mutex is already locked by the thread calling
23
+
{!lock}.
24
+
25
+
@before 4.12 {!Sys_error} was not raised for recursive locking
26
+
(platform-dependent behaviour) *)
27
+
28
+
val try_lock : t -> bool
29
+
(** Same as {!lock}, but does not suspend the calling thread if
30
+
the mutex is already locked: just return [false] immediately
31
+
in that case. If the mutex is unlocked, lock it and
32
+
return [true]. *)
33
+
34
+
val unlock : t -> unit
35
+
(** Unlock the given mutex. Other threads suspended trying to lock
36
+
the mutex will restart. The mutex must have been previously locked
37
+
by the thread that calls {!unlock}.
38
+
@raise Sys_error if the mutex is unlocked or was locked by another thread.
39
+
40
+
@before 4.12 {!Sys_error} was not raised when unlocking an unlocked mutex
41
+
or when unlocking a mutex from a different thread. *)
42
+
43
+
val protect : t -> (unit -> 'a) -> 'a
44
+
(** [protect mutex f] runs [f()] in a critical section where [mutex]
45
+
is locked (using {!lock}); it then takes care of releasing [mutex],
46
+
whether [f()] returned a value or raised an exception.
47
+
48
+
The unlocking operation is guaranteed to always takes place,
49
+
even in the event an asynchronous exception (e.g. {!Sys.Break}) is raised
50
+
in some signal handler.
51
+
52
+
@since 5.1 *)
53
+
54
+
val lock_all : t list -> bool
55
+
(** [lock_all mutexes] attempts to acquire all mutexes in the list atomically.
56
+
It uses {!try_lock} for each mutex in the order provided. If any mutex
57
+
cannot be acquired, it releases all previously acquired mutexes and
58
+
returns [false]. If all mutexes are successfully acquired, it returns [true].
59
+
60
+
This function is useful for avoiding deadlocks when multiple mutexes
61
+
need to be acquired simultaneously.
62
+
63
+
@return [true] if all mutexes were successfully acquired, [false] otherwise.
64
+
65
+
Note: The caller is responsible for unlocking all mutexes that were
66
+
successfully acquired when this function returns [true]. *)
67
+
end
+21
forks/lwd/lib/lwd/dune
+21
forks/lwd/lib/lwd/dune
···
1
+
(library
2
+
(name lwd)
3
+
(public_name lwd)
4
+
(modules lwd lwd_seq lwd_table lwd_infix lwd_utils mutex_stdlib lwd_impl mutex_backend )
5
+
(libraries seq)
6
+
(inline_tests
7
+
(backend qtest.lib)
8
+
(executable
9
+
(flags
10
+
(-w -33))))
11
+
(wrapped false)
12
+
(preprocess
13
+
(per_module
14
+
((action
15
+
(run %{dep:pp.exe} %{input-file}))
16
+
lwd_infix
17
+
lwd_seq))))
18
+
19
+
(executable
20
+
(name pp)
21
+
(modules pp))
+2
forks/lwd/lib/lwd/lwd.ml
+2
forks/lwd/lib/lwd/lwd.ml
+162
forks/lwd/lib/lwd/lwd.mli
+162
forks/lwd/lib/lwd/lwd.mli
···
1
+
type +'a t
2
+
(** A dynamic document of type ['a]. Documents can be produced in several
3
+
different ways:
4
+
5
+
- operators, such as {!map}, {!bind}, {!app}, {!pair}, etc.
6
+
combine several documents into one. The result is (lazily)
7
+
updated whenever the sub-documents are.
8
+
9
+
- variables {!var}, a mutable reference.
10
+
- primitive documents {!prim}, providing custom leaves to trees of
11
+
documents.
12
+
*)
13
+
14
+
val return : 'a -> 'a t
15
+
(** The content document with the given value inside *)
16
+
17
+
val pure : 'a -> 'a t
18
+
(** Alias to {!return} *)
19
+
20
+
val map : 'a t -> f:('a -> 'b) -> 'b t
21
+
(** [map d ~f] is the document that has value [f x] whenever [d] has value [x] *)
22
+
23
+
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
24
+
(** [map2 d1 d2 ~f] is the document that has value [f x1 x2] whenever
25
+
[d1] has value [x1] and [d2] has value [x2] *)
26
+
27
+
val join : 'a t t -> 'a t
28
+
(** Monadic operator [join d] is the document pointed to by document [d].
29
+
This is powerful but potentially costly in case of recomputation.
30
+
*)
31
+
32
+
val bind : 'a t -> f:('a -> 'b t) -> 'b t
33
+
(** Monadic bind, a mix of {!join} and {!map} *)
34
+
35
+
val app : ('a -> 'b) t -> 'a t -> 'b t
36
+
(** Applicative: [app df dx] is the document that has value [f x]
37
+
whenever [df] has value [f] and [dx] has value [x] *)
38
+
39
+
val pair : 'a t -> 'b t -> ('a * 'b) t
40
+
(** [pair a b] is [map2 (fun x y->x,y) a b] *)
41
+
42
+
val is_pure : 'a t -> 'a option
43
+
(** [is_pure x] will return [Some v] if [x] was built with [pure v] or
44
+
[return v].
45
+
46
+
Normal code should not rely on the "reactive-ness" of a value, but this is
47
+
often useful for optimising reactive data structures.
48
+
*)
49
+
50
+
type 'a var
51
+
(** The workhorse of Lwd: a mutable variable that also tracks dependencies.
52
+
Every time {!set} is called, all documents that depend on this variable
53
+
via {!map}, {!bind}, etc. will be at least partially invalidated
54
+
and will be recomputed incrementally on demand. *)
55
+
56
+
val var : 'a -> 'a var
57
+
(** Create a new variable with the given initial value *)
58
+
59
+
val get : 'a var -> 'a t
60
+
(** A document that reflects the current content of a variable *)
61
+
62
+
val set : 'a var -> 'a -> unit
63
+
(** Change the variable's content, invalidating all documents depending
64
+
on it. *)
65
+
66
+
val peek_stable : 'a var -> 'a
67
+
(** Same as `peek` but if it is called during recomputation of the document, it will always return the value as it was at the start of the recomputation. This can be important for ui consistency. *)
68
+
69
+
val peek : 'a var -> 'a
70
+
(** Observe the current value of the variable, without any dependency
71
+
tracking. *)
72
+
73
+
val update : ('a -> 'a) -> 'a var -> unit
74
+
(** Modify a variable based on its currently observed value. *)
75
+
76
+
val may_update : ('a -> 'a option) -> 'a var -> unit
77
+
(** Conditionnally modify a variable based on its currently observed value. *)
78
+
79
+
type +'a prim
80
+
(** A primitive document. It can correspond, for example, to
81
+
a primitive UI element.
82
+
83
+
A primitive is a resource with [acquire] and [release] functions
84
+
to manage its lifecycle. *)
85
+
86
+
val prim : acquire:('a prim -> 'a) -> release:('a prim -> 'a -> unit) -> 'a prim
87
+
(** create a new primitive document.
88
+
@param acquire is called when the document becomes observed (indirectly)
89
+
via at least one {!root}. The resulting primitive is passed as an argument
90
+
to support certain recursive use cases.
91
+
@param release is called when the document is no longer observed.
92
+
Internal resources can be freed. *)
93
+
94
+
val get_prim : 'a prim -> 'a t
95
+
val invalidate : 'a prim -> unit
96
+
97
+
(** Some document might change variables during their evaluation.
98
+
These are called "unstable" documents.
99
+
100
+
Evaluating these might need many passes to eventually converge to a value.
101
+
The `fix` operator tries to stabilize a sub-document by repeating
102
+
evaluation until a stable condition is reached.
103
+
*)
104
+
val fix : 'a t -> wrt:_ t -> 'a t
105
+
106
+
val default_unsafe_mutation_logger : unit -> unit
107
+
val unsafe_mutation_logger : (unit -> unit) ref
108
+
109
+
(** Releasing unused graphs *)
110
+
type release_failure = exn * Printexc.raw_backtrace
111
+
112
+
exception Release_failure of exn option * release_failure list
113
+
114
+
type release_queue
115
+
val make_release_queue : unit -> release_queue
116
+
val flush_release_queue : release_queue -> release_failure list
117
+
118
+
type +'a root
119
+
(** A root of computation, whose value(s) over time we're interested in. *)
120
+
121
+
val observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root
122
+
(** [observe x] creates a root that contains document [x].
123
+
@param on_invalidate is called whenever the root is invalidated
124
+
because the content of [x] has changed. This can be useful to
125
+
perform side-effects such as re-rendering some UI. *)
126
+
127
+
val set_on_invalidate : 'a root -> ('a -> unit) -> unit
128
+
(** Change the callback for the root.
129
+
See [observe] for more details. *)
130
+
131
+
val sample : release_queue -> 'a root -> 'a
132
+
(** Force the computation of the value for this root.
133
+
The value is cached, so this is idempotent, until the next invalidation. *)
134
+
135
+
val is_damaged : 'a root -> bool
136
+
(** [is_damaged root] is true if the root doesn't have a valid value in
137
+
cache. This can be the case if the value was never computed, or
138
+
if it was computed and then invalidated. *)
139
+
140
+
val release : release_queue -> 'a root -> unit
141
+
(** Forget about this root and release sub-values no longer reachable from
142
+
any root. *)
143
+
144
+
val quick_sample : 'a root -> 'a
145
+
146
+
val quick_release : 'a root -> unit
147
+
148
+
module Infix : sig
149
+
150
+
(** Lwd map operaor*)
151
+
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
152
+
153
+
(** Lwd bind operaor*)
154
+
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
155
+
156
+
(** Lwd application operator *)
157
+
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
158
+
159
+
end
160
+
161
+
(* For debug purposes *)
162
+
val dump_trace : 'a t -> unit
+824
forks/lwd/lib/lwd/lwd_impl.ml
+824
forks/lwd/lib/lwd/lwd_impl.ml
···
1
+
module Make (Mutex : Mutex_backend.MUTEX) = struct
2
+
3
+
(** Create-only version of [Obj.t] *)
4
+
module Any : sig
5
+
type t
6
+
val any : 'a -> t
7
+
end = struct
8
+
type t = Obj.t
9
+
let any = Obj.repr
10
+
end
11
+
12
+
type 'a eval =
13
+
| Eval_none
14
+
| Eval_progress
15
+
| Eval_some of 'a
16
+
| Eval_invalid_next
17
+
18
+
type 'a t_ =
19
+
| Pure of 'a
20
+
| Operator : {
21
+
mutex : Mutex.t;
22
+
mutable value : 'a eval; (* cached value *)
23
+
mutable trace : trace; (* list of parents this can invalidate *)
24
+
mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
25
+
desc: 'a desc;
26
+
} -> 'a t_
27
+
| Root : {
28
+
mutex : Mutex.t;
29
+
mutable value : 'a eval; (* cached value *)
30
+
mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
31
+
mutable on_invalidate : 'a -> unit;
32
+
mutable acquired : bool;
33
+
child : 'a t_;
34
+
} -> 'a t_
35
+
36
+
and _ desc =
37
+
| Map : 'a t_ * ('a -> 'b) -> 'b desc
38
+
| Map2 : 'a t_ * 'b t_ * ('a -> 'b -> 'c) -> 'c desc
39
+
| Pair : 'a t_ * 'b t_ -> ('a * 'b) desc
40
+
| App : ('a -> 'b) t_ * 'a t_ -> 'b desc
41
+
| Join : { child : 'a t_ t_; mutable intermediate : 'a t_ option } -> 'a desc
42
+
| Var : { mutable binding : 'a; mutable nextVal: 'a option } -> 'a desc
43
+
| Prim : { acquire : 'a t -> 'a;
44
+
release : 'a t -> 'a -> unit } -> 'a desc
45
+
| Fix : { doc : 'a t_; wrt : _ t_ } -> 'a desc
46
+
47
+
(* a set of (active) parents for a ['a t], used during invalidation *)
48
+
and trace =
49
+
| T0
50
+
| T1 : _ t_ -> trace
51
+
| T2 : _ t_ * _ t_ -> trace
52
+
| T3 : _ t_ * _ t_ * _ t_ -> trace
53
+
| T4 : _ t_ * _ t_ * _ t_ * _ t_ -> trace
54
+
| Tn : { mutable active : int; mutable count : int;
55
+
mutable entries : Any.t t_ array } -> trace
56
+
57
+
(* a set of direct children for a composite document *)
58
+
and trace_idx =
59
+
| I0
60
+
| I1 : { mutable idx : int ;
61
+
obj : 'a t_;
62
+
mutable next : trace_idx } -> trace_idx
63
+
64
+
(* The type system cannot see that t is covariant in its parameter.
65
+
Use the Force to convince it. *)
66
+
and +'a t
67
+
external inj : 'a t_ -> 'a t = "%identity"
68
+
external prj : 'a t -> 'a t_ = "%identity"
69
+
external prj2 : 'a t t -> 'a t_ t_ = "%identity"
70
+
71
+
(* Basic combinators *)
72
+
let return x = inj (Pure x)
73
+
let pure x = inj (Pure x)
74
+
75
+
let is_pure x = match prj x with
76
+
| Pure x -> Some x
77
+
| _ -> None
78
+
79
+
let dummy = Pure (Any.any ())
80
+
81
+
let operator desc =
82
+
Operator { value = Eval_none; trace = T0; desc; trace_idx = I0 ;mutex= Mutex.create () }
83
+
84
+
let map x ~f = inj (
85
+
match prj x with
86
+
| Pure vx -> Pure (f vx)
87
+
| x -> operator (Map (x, f))
88
+
)
89
+
90
+
let map2 x y ~f = inj (
91
+
match prj x, prj y with
92
+
| Pure vx, Pure vy -> Pure (f vx vy)
93
+
| x, y -> operator (Map2 (x, y, f))
94
+
)
95
+
96
+
97
+
let pair x y = inj (
98
+
match prj x, prj y with
99
+
| Pure vx, Pure vy -> Pure (vx, vy)
100
+
| x, y -> operator (Pair (x, y))
101
+
)
102
+
103
+
let app f x = inj (
104
+
match prj f, prj x with
105
+
| Pure vf, Pure vx -> Pure (vf vx)
106
+
| f, x -> operator (App (f, x))
107
+
)
108
+
109
+
let join child = inj (
110
+
match prj2 child with
111
+
| Pure v -> v
112
+
| child -> operator (Join { child; intermediate = None })
113
+
)
114
+
115
+
let bind x ~f = join (map ~f x)
116
+
117
+
(* Management of trace indices *)
118
+
119
+
let addr oc obj =
120
+
Printf.fprintf oc "0x%08x" (Obj.magic obj : int)
121
+
122
+
external t_equal : _ t_ -> _ t_ -> bool = "%eq"
123
+
external obj_t : 'a t_ -> Any.t t_ = "%identity"
124
+
125
+
let rec dump_trace : type a. a t_ -> unit =
126
+
fun obj -> match obj with
127
+
| Pure _ -> Printf.eprintf "%a: Pure _\n%!" addr obj
128
+
| Operator t ->
129
+
Printf.eprintf "%a: Operator _ -> %a\n%!" addr obj dump_trace_aux t.trace;
130
+
begin match t.trace with
131
+
| T0 -> ()
132
+
| T1 a -> dump_trace a
133
+
| T2 (a,b) -> dump_trace a; dump_trace b
134
+
| T3 (a,b,c) -> dump_trace a; dump_trace b; dump_trace c
135
+
| T4 (a,b,c,d) -> dump_trace a; dump_trace b; dump_trace c; dump_trace d
136
+
| Tn t -> Array.iter dump_trace t.entries
137
+
end
138
+
| Root _ -> Printf.eprintf "%a: Root _\n%!" addr obj
139
+
140
+
and dump_trace_aux oc = function
141
+
| T0 -> Printf.fprintf oc "T0"
142
+
| T1 a -> Printf.fprintf oc "T1 %a" addr a
143
+
| T2 (a,b) ->
144
+
Printf.fprintf oc "T2 (%a, %a)" addr a addr b
145
+
| T3 (a,b,c) ->
146
+
Printf.fprintf oc "T3 (%a, %a, %a)" addr a addr b addr c
147
+
| T4 (a,b,c,d) ->
148
+
Printf.fprintf oc "T4 (%a, %a, %a, %a)" addr a addr b addr c addr d
149
+
| Tn t ->
150
+
Printf.fprintf oc "Tn {active = %d; count = %d; entries = "
151
+
t.active t.count;
152
+
Array.iter (Printf.fprintf oc "(%a)" addr) t.entries;
153
+
Printf.fprintf oc "}"
154
+
155
+
let dump_trace x = dump_trace (obj_t (prj x))
156
+
157
+
let add_idx obj idx = function
158
+
| Pure _ -> assert false
159
+
| Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
160
+
| Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
161
+
162
+
let rec rem_idx_rec obj = function
163
+
| I0 -> assert false
164
+
| I1 t as self ->
165
+
if t_equal t.obj obj
166
+
then (t.idx, t.next)
167
+
else (
168
+
let idx, result = rem_idx_rec obj t.next in
169
+
t.next <- result;
170
+
(idx, self)
171
+
)
172
+
173
+
(* remove [obj] from the lwd's trace. *)
174
+
let rem_idx obj = function
175
+
| Pure _ -> assert false
176
+
| Root t' ->
177
+
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
178
+
t'.trace_idx <- trace_idx; idx
179
+
| Operator t' ->
180
+
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
181
+
t'.trace_idx <- trace_idx; idx
182
+
183
+
(* move [obj] from old index to new index. *)
184
+
let rec mov_idx_rec obj oldidx newidx = function
185
+
| I0 -> assert false
186
+
| I1 t ->
187
+
if t.idx = oldidx && t_equal t.obj obj
188
+
then t.idx <- newidx
189
+
else mov_idx_rec obj oldidx newidx t.next
190
+
191
+
let mov_idx obj oldidx newidx = function
192
+
| Pure _ -> assert false
193
+
| Root t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
194
+
| Operator t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
195
+
196
+
let rec get_idx_rec obj = function
197
+
| I0 -> assert false
198
+
| I1 t ->
199
+
if t_equal t.obj obj
200
+
then t.idx
201
+
else get_idx_rec obj t.next
202
+
203
+
(* find index of [obj] in the given lwd *)
204
+
let get_idx obj = function
205
+
| Pure _ -> assert false
206
+
| Root t' -> get_idx_rec obj t'.trace_idx
207
+
| Operator t' -> get_idx_rec obj t'.trace_idx
208
+
209
+
type status =
210
+
| Neutral
211
+
| Safe
212
+
| Unsafe of (unit->unit) list ref
213
+
214
+
(*
215
+
Sensitivity is used to indicate to when reading a root node, that one of the child operater nodes was being evaluated.
216
+
I think this is needed because the child cound have multiple roots and we need to indicate that to all of them
217
+
*)
218
+
type sensitivity =
219
+
| Strong
220
+
| Fragile
221
+
222
+
(* Propagating invalidation recursively.
223
+
Each document is invalidated at most once,
224
+
and only if it has [t.value = Some _]. *)
225
+
let rec invalidate_node : type a . status ref -> sensitivity -> a t_ -> unit =
226
+
(*sensitivity indicates that a parent is being evaluated*)
227
+
fun status sensitivity node ->
228
+
match node, sensitivity with
229
+
| Pure _, _ -> assert false
230
+
| Root ({value; on_invalidate; _} as t), _ ->
231
+
(match value with
232
+
| Eval_none | Eval_invalid_next -> ()
233
+
| Eval_progress ->
234
+
t.value <- Eval_invalid_next
235
+
| Eval_some x ->
236
+
t.value <- Eval_none;
237
+
on_invalidate x
238
+
)
239
+
| Operator { value = Eval_none | Eval_invalid_next; _ }, _ -> ()
240
+
| Operator { desc = Fix { wrt = Operator { value = Eval_none | Eval_invalid_next; _ }; _ }; _ }, Fragile ->
241
+
(match !status with
242
+
| Safe | Unsafe _ -> ()
243
+
| Neutral -> status := Safe)
244
+
| Operator { desc = Fix { wrt = Operator { value = Eval_some _; _ }; _ }; _ }, Fragile
245
+
-> ()
246
+
| Operator t, _ ->
247
+
let sensitivity =
248
+
match t.value with Eval_progress -> Fragile | _ -> sensitivity
249
+
in
250
+
t.value <- Eval_none;
251
+
(* invalidate parents recursively *)
252
+
invalidate_trace status sensitivity t.trace
253
+
254
+
(* invalidate recursively documents in the given trace *)
255
+
and invalidate_trace status sensitivity = function
256
+
| T0 -> ()
257
+
| T1 x -> invalidate_node status sensitivity x
258
+
| T2 (x, y) ->
259
+
invalidate_node status sensitivity x;
260
+
invalidate_node status sensitivity y
261
+
| T3 (x, y, z) ->
262
+
invalidate_node status sensitivity x;
263
+
invalidate_node status sensitivity y;
264
+
invalidate_node status sensitivity z
265
+
| T4 (x, y, z, w) ->
266
+
invalidate_node status sensitivity x;
267
+
invalidate_node status sensitivity y;
268
+
invalidate_node status sensitivity z;
269
+
invalidate_node status sensitivity w
270
+
| Tn t ->
271
+
let active = t.active in
272
+
t.active <- 0;
273
+
for i = 0 to active - 1 do
274
+
invalidate_node status sensitivity t.entries.(i)
275
+
done
276
+
277
+
let default_unsafe_mutation_logger () =
278
+
let callstack = Printexc.get_callstack 20 in
279
+
Printf.fprintf stderr
280
+
"Lwd: unsafe mutation (variable invalidated during evaluation) at\n%a"
281
+
Printexc.print_raw_backtrace callstack
282
+
283
+
let unsafe_mutation_logger = ref default_unsafe_mutation_logger
284
+
285
+
286
+
(**
287
+
288
+
289
+
@param ~was_delayed: set to true if the function call was put on hold untill the current root had finished being evaluated
290
+
*)
291
+
let do_invalidate sensitivity (node : 'a t_) =
292
+
let status = ref Neutral in
293
+
invalidate_node status sensitivity node;
294
+
(* Variables *)
295
+
type 'a var = 'a t_
296
+
let var x = operator (Var {binding = x;nextVal=None})
297
+
let get x = inj x
298
+
299
+
let set (vx:'a var) x : unit =
300
+
match vx with
301
+
| (Operator ({desc = Var v; _} )as node) ->
302
+
v.binding <- x;
303
+
v.nextVal <- None;
304
+
(let rec climb (parents: Any.t t_ list) =
305
+
let new_parents : Any.t t_ list = List.fold_left (fun acc p ->
306
+
match p with
307
+
| Pure _ -> acc
308
+
| Root r ->
309
+
if Mutex.try_lock r.mutex then (
310
+
(match r.value with
311
+
| Eval_some v ->
312
+
r.value <- Eval_none;
313
+
r.on_invalidate v
314
+
| Eval_none | Eval_invalid_next -> ()
315
+
| Eval_progress -> r.value <- Eval_invalid_next
316
+
);
317
+
Mutex.unlock r.mutex;
318
+
acc
319
+
) else (
320
+
Mutex.protect r.mutex (fun () ->
321
+
if r.value = Eval_progress then r.value <- Eval_invalid_next
322
+
);
323
+
acc
324
+
)
325
+
| Operator o ->
326
+
if Mutex.try_lock o.mutex then (
327
+
let continue =
328
+
match o.value with
329
+
| Eval_some _ -> o.value <- Eval_none; true
330
+
| Eval_none | Eval_invalid_next -> false
331
+
| Eval_progress -> o.value <- Eval_invalid_next; false
332
+
in
333
+
Mutex.unlock o.mutex;
334
+
if continue then (
335
+
match o.trace with
336
+
| T0 -> acc
337
+
| T1 p1 -> obj_t p1 :: acc
338
+
| T2 (p1, p2) -> obj_t p1 :: obj_t p2 :: acc
339
+
| T3 (p1, p2, p3) -> obj_t p1 :: obj_t p2 :: obj_t p3 :: acc
340
+
| T4 (p1, p2, p3, p4) -> obj_t p1 :: obj_t p2 :: obj_t p3 :: obj_t p4 :: acc
341
+
| Tn t -> Array.to_list t.entries |> List.rev_append acc
342
+
) else acc
343
+
) else (
344
+
Mutex.protect o.mutex (fun () ->
345
+
if o.value = Eval_progress then o.value <- Eval_invalid_next
346
+
);
347
+
acc
348
+
)
349
+
) [] parents in
350
+
if new_parents <> [] then climb new_parents
351
+
in
352
+
match node with
353
+
| Operator o ->
354
+
let initial_parents : Any.t t_ list =
355
+
match o.trace with
356
+
| T0 -> []
357
+
| T1 p1 -> [obj_t p1]
358
+
| T2 (p1, p2) -> [obj_t p1; obj_t p2]
359
+
| T3 (p1, p2, p3) -> [obj_t p1; obj_t p2; obj_t p3]
360
+
| T4 (p1, p2, p3, p4) -> [obj_t p1; obj_t p2; obj_t p3; obj_t p4]
361
+
| Tn t -> Array.to_list t.entries
362
+
in
363
+
climb initial_parents
364
+
| _ -> ()
365
+
)
366
+
| _ -> assert false
367
+
368
+
let peek_stable = function
369
+
| Operator ({desc = Var v; _}) -> v.binding
370
+
| _ -> assert false
371
+
372
+
let peek = function
373
+
| Operator ({desc = Var v; _}) -> v.nextVal |>Option.value ~default: v.binding
374
+
| _ -> assert false
375
+
376
+
let update f v = set v (f (peek v))
377
+
378
+
let may_update f v =
379
+
match f (peek v) with
380
+
| None -> ()
381
+
| Some x -> set v x
382
+
383
+
(* Primitives *)
384
+
type 'a prim = 'a t
385
+
let prim ~acquire ~release =
386
+
inj (operator (Prim { acquire; release }))
387
+
let get_prim x = x
388
+
389
+
let invalidate x = match prj x with
390
+
| Operator {desc = Prim p; value; _} as t ->
391
+
(* the value is invalidated, be sure to invalidate all parents as well *)
392
+
begin match value with
393
+
| Eval_none | Eval_invalid_next -> ()
394
+
| Eval_progress -> do_invalidate Fragile t;
395
+
| Eval_some v ->
396
+
do_invalidate Strong t;
397
+
p.release x v
398
+
end
399
+
| _ -> assert false
400
+
401
+
(* Fix point *)
402
+
403
+
let fix doc ~wrt = match prj wrt with
404
+
| Root _ -> assert false
405
+
| Pure _ -> doc
406
+
| Operator _ as wrt -> inj (operator (Fix {doc = prj doc; wrt}))
407
+
408
+
type release_list =
409
+
| Release_done
410
+
| Release_more :
411
+
{ origin : 'a t_; element : 'b t_; next : release_list } -> release_list
412
+
413
+
type release_queue = release_list ref
414
+
let make_release_queue () = ref Release_done
415
+
416
+
type release_failure = exn * Printexc.raw_backtrace
417
+
418
+
(* [sub_release [] origin self] is called when [origin] is released,
419
+
where [origin] is reachable from [self]'s trace.
420
+
We're going to remove [origin] from that trace as [origin] is now dead.
421
+
422
+
[sub_release] cannot raise.
423
+
If a primitive raises, the exception is caught and a warning is emitted. *)
424
+
let rec sub_release
425
+
: type a b . release_failure list -> a t_ -> b t_ -> release_failure list
426
+
= fun failures origin -> function
427
+
| Root _ -> assert false
428
+
| Pure _ -> failures
429
+
| Operator t as self ->
430
+
(* compute [t.trace \ {origin}] *)
431
+
let trace = match t.trace with
432
+
| T0 -> assert false
433
+
| T1 x -> assert (t_equal x origin); T0
434
+
| T2 (x, y) ->
435
+
if t_equal x origin then T1 y
436
+
else if t_equal y origin then T1 x
437
+
else assert false
438
+
| T3 (x, y, z) ->
439
+
if t_equal x origin then T2 (y, z)
440
+
else if t_equal y origin then T2 (x, z)
441
+
else if t_equal z origin then T2 (x, y)
442
+
else assert false
443
+
| T4 (x, y, z, w) ->
444
+
if t_equal x origin then T3 (y, z, w)
445
+
else if t_equal y origin then T3 (x, z, w)
446
+
else if t_equal z origin then T3 (x, y, w)
447
+
else if t_equal w origin then T3 (x, y, z)
448
+
else assert false
449
+
| Tn tn as trace ->
450
+
let revidx = rem_idx self origin in
451
+
assert (t_equal tn.entries.(revidx) origin);
452
+
let count = tn.count - 1 in
453
+
tn.count <- count;
454
+
if revidx < count then (
455
+
let obj = tn.entries.(count) in
456
+
tn.entries.(revidx) <- obj;
457
+
tn.entries.(count) <- dummy;
458
+
mov_idx self count revidx obj
459
+
) else
460
+
tn.entries.(revidx) <- dummy;
461
+
if tn.active > count then tn.active <- count;
462
+
if count = 4 then (
463
+
(* downgrade to [T4] to save space *)
464
+
let a = tn.entries.(0) and b = tn.entries.(1) in
465
+
let c = tn.entries.(2) and d = tn.entries.(3) in
466
+
ignore (rem_idx self a : int);
467
+
ignore (rem_idx self b : int);
468
+
ignore (rem_idx self c : int);
469
+
ignore (rem_idx self d : int);
470
+
T4 (a, b, c, d)
471
+
) else (
472
+
let len = Array.length tn.entries in
473
+
if count <= len lsr 2 then
474
+
Tn { active = tn.active; count = tn.count;
475
+
entries = Array.sub tn.entries 0 (len lsr 1) }
476
+
else
477
+
trace
478
+
)
479
+
in
480
+
t.trace <- trace;
481
+
match trace with
482
+
| T0 ->
483
+
(* [self] is not active anymore, since it's not reachable
484
+
from any root. We can release its cached value and
485
+
recursively release its subtree. *)
486
+
let value = t.value in
487
+
t.value <- Eval_progress;
488
+
begin match t.desc with
489
+
| Map (x, _) -> sub_release failures self x
490
+
| Map2 (x, y, _) ->
491
+
sub_release (sub_release failures self x) self y
492
+
| Pair (x, y) ->
493
+
sub_release (sub_release failures self x) self y
494
+
| App (x, y) ->
495
+
sub_release (sub_release failures self x) self y
496
+
| Join ({ child; intermediate } as t) ->
497
+
let failures = sub_release failures self child in
498
+
begin match intermediate with
499
+
| None -> failures
500
+
| Some child' ->
501
+
t.intermediate <- None;
502
+
sub_release failures self child'
503
+
end
504
+
| Var _ -> failures
505
+
| Fix {doc; wrt} ->
506
+
sub_release (sub_release failures self wrt) self doc
507
+
| Prim t ->
508
+
begin match value with
509
+
| Eval_none | Eval_invalid_next | Eval_progress -> failures
510
+
| Eval_some x ->
511
+
begin match t.release (inj self) x with
512
+
| () -> failures
513
+
| exception exn ->
514
+
let bt = Printexc.get_raw_backtrace () in
515
+
(exn, bt) :: failures
516
+
end
517
+
end
518
+
end
519
+
| _ -> failures
520
+
521
+
(* [sub_acquire] cannot raise *)
522
+
let rec sub_acquire : type a b . a t_ -> b t_ -> unit = fun origin ->
523
+
function
524
+
| Root _ -> assert false
525
+
| Pure _ -> ()
526
+
| Operator t as self ->
527
+
(*lock the mutex, because we are making changes within this node *)
528
+
Mutex.protect t.mutex @@ fun _->
529
+
(* [acquire] is true if this is the first time this operator
530
+
is used, in which case we need to acquire its children *)
531
+
let acquire = match t.trace with T0 -> true | _ -> false in
532
+
let trace = match t.trace with
533
+
| T0 -> T1 origin
534
+
| T1 x -> T2 (origin, x)
535
+
| T2 (x, y) -> T3 (origin, x, y)
536
+
| T3 (x, y, z) -> T4 (origin, x, y, z)
537
+
| T4 (x, y, z, w) ->
538
+
let obj_origin = obj_t origin in
539
+
let entries =
540
+
[| obj_t x; obj_t y; obj_t z; obj_t w; obj_origin; dummy; dummy; dummy |]
541
+
in
542
+
for i = 0 to 4 do add_idx self i entries.(i) done;
543
+
Tn { active = 5; count = 5; entries }
544
+
| Tn tn as trace ->
545
+
let index = tn.count in
546
+
let entries, trace =
547
+
(* possibly resize array [entries] *)
548
+
if index < Array.length tn.entries then (
549
+
tn.count <- tn.count + 1;
550
+
(tn.entries, trace)
551
+
) else (
552
+
let entries = Array.make (index * 2) dummy in
553
+
Array.blit tn.entries 0 entries 0 index;
554
+
(entries, Tn { active = tn.active; count = index + 1; entries })
555
+
)
556
+
in
557
+
let obj_origin = obj_t origin in
558
+
entries.(index) <- obj_origin;
559
+
add_idx self index obj_origin;
560
+
trace
561
+
in
562
+
t.trace <- trace;
563
+
if acquire then (
564
+
(* acquire immediate children, and so on recursively *)
565
+
match t.desc with
566
+
| Map (x, _) -> sub_acquire self x
567
+
| Map2 (x, y, _) ->
568
+
sub_acquire self x;
569
+
sub_acquire self y
570
+
| Pair (x, y) ->
571
+
sub_acquire self x;
572
+
sub_acquire self y
573
+
| App (x, y) ->
574
+
sub_acquire self x;
575
+
sub_acquire self y
576
+
| Fix {doc; wrt} ->
577
+
sub_acquire self doc;
578
+
sub_acquire self wrt
579
+
| Join { child; intermediate } ->
580
+
sub_acquire self child;
581
+
begin match intermediate with
582
+
| None -> ()
583
+
| Some _ ->
584
+
assert false (* this can't initialized already, first-time acquire *)
585
+
end
586
+
| Var _ -> ()
587
+
| Prim _ -> ()
588
+
)
589
+
590
+
(* make sure that [origin] is in [self.trace], passed as last arg. *)
591
+
let activate_tracing self origin = function
592
+
| Tn tn ->
593
+
let idx = get_idx self origin in (* index of [self] in [origin.trace_idx] *)
594
+
let active = tn.active in
595
+
(* [idx < active] means [self] is already traced by [origin].
596
+
We only have to add [self] to the entries if [idx >= active]. *)
597
+
if idx >= active then (
598
+
tn.active <- active + 1;
599
+
);
600
+
if idx > active then (
601
+
(* swap with last entry in [tn.entries] *)
602
+
let old = tn.entries.(active) in
603
+
tn.entries.(idx) <- old;
604
+
tn.entries.(active) <- obj_t origin;
605
+
mov_idx self active idx old;
606
+
mov_idx self idx active origin
607
+
)
608
+
| _ -> ()
609
+
610
+
let sub_is_damaged = function
611
+
| Root _ -> assert false
612
+
| Pure _ -> false
613
+
| Operator {value; _} ->
614
+
match value with
615
+
| Eval_none | Eval_invalid_next -> true
616
+
| Eval_some _ -> false
617
+
| Eval_progress -> assert false
618
+
619
+
(* [sub_sample origin self] computes a value for [self].
620
+
621
+
[sub_sample] raise if any user-provided computation raises.
622
+
Graph will be left in a coherent state but exception will be propagated
623
+
to the observer. *)
624
+
let sub_sample queue =
625
+
let rec aux : type a b . a t_ -> b t_ -> b = fun origin ->
626
+
function
627
+
| Root _ -> assert false
628
+
| Pure x -> x
629
+
| Operator t as self ->
630
+
(* lock the mutex, examine cached value *)
631
+
Mutex.lock t.mutex;
632
+
match t.value with
633
+
| Eval_some value ->
634
+
Mutex.unlock t.mutex;
635
+
activate_tracing self origin t.trace;
636
+
value
637
+
| Eval_none ->
638
+
t.value <- Eval_progress;
639
+
Mutex.unlock t.mutex;
640
+
641
+
(* compute value without holding the lock *)
642
+
let result : b =
643
+
match t.desc with
644
+
| Map (x, f) -> f (aux self x)
645
+
| Map2 (x, y, f) -> f (aux self x) (aux self y)
646
+
| Pair (x, y) -> (aux self x, aux self y)
647
+
| App (f, x) -> (aux self f) (aux self x)
648
+
| Fix { doc; wrt } ->
649
+
let _ = aux self wrt in
650
+
let result = aux self doc in
651
+
if sub_is_damaged wrt then aux origin self
652
+
else (
653
+
if sub_is_damaged doc then do_invalidate Fragile self;
654
+
result)
655
+
| Join x ->
656
+
let intermediate =
657
+
(* We haven't touched any state yet,
658
+
it is safe for [aux] to raise *)
659
+
aux self x.child
660
+
in
661
+
begin
662
+
match x.intermediate with
663
+
| None ->
664
+
x.intermediate <- Some intermediate;
665
+
sub_acquire self intermediate
666
+
| Some x' when x' != intermediate ->
667
+
queue :=
668
+
Release_more
669
+
{ origin = self; element = x'; next = !queue };
670
+
x.intermediate <- Some intermediate;
671
+
sub_acquire self intermediate
672
+
| Some _ -> ()
673
+
end;
674
+
aux self intermediate
675
+
| Var x -> x.binding
676
+
| Prim t -> t.acquire (inj self)
677
+
in
678
+
679
+
(* lock again and finalize *)
680
+
Mutex.lock t.mutex;
681
+
begin
682
+
match t.value with
683
+
| Eval_progress -> t.value <- Eval_some result
684
+
| Eval_invalid_next -> t.value <- Eval_none
685
+
| Eval_none | Eval_some _ -> ()
686
+
end;
687
+
Mutex.unlock t.mutex;
688
+
689
+
(* Re-evaluate if the node was invalidated during computation *)
690
+
if t.value == Eval_none then aux origin self
691
+
else (
692
+
(* [self] just became active, so it may invalidate [origin] in case its
693
+
value changes because of [t.desc], like if it's a variable and gets
694
+
mutated, or if it's a primitive that gets invalidated.
695
+
We need to put [origin] into [self.trace] in case it isn't there yet. *)
696
+
activate_tracing self origin t.trace;
697
+
result)
698
+
| Eval_progress | Eval_invalid_next ->
699
+
Mutex.unlock t.mutex;
700
+
(* spin and retry *)
701
+
let rec spin () =
702
+
match t.value with
703
+
| Eval_progress | Eval_invalid_next ->
704
+
Domain.cpu_relax ();
705
+
spin ()
706
+
| Eval_none | Eval_some _ -> ()
707
+
in
708
+
spin ();
709
+
aux origin self
710
+
in
711
+
aux
712
+
713
+
type 'a root = 'a t
714
+
715
+
let observe ?(on_invalidate = ignore) child : _ root =
716
+
let root =
717
+
Root
718
+
{ child = prj child
719
+
; value = Eval_none
720
+
; on_invalidate
721
+
; trace_idx = I0
722
+
; acquired = false
723
+
; mutex= Mutex.create()
724
+
}
725
+
in
726
+
inj root
727
+
728
+
exception Release_failure of exn option * release_failure list
729
+
730
+
let raw_flush_release_queue queue =
731
+
let rec aux failures = function
732
+
| Release_done -> failures
733
+
| Release_more t ->
734
+
let failures = sub_release failures t.origin t.element in
735
+
aux failures t.next
736
+
in
737
+
aux [] queue
738
+
739
+
let flush_release_queue queue =
740
+
let queue' = !queue in
741
+
queue := Release_done;
742
+
raw_flush_release_queue queue'
743
+
744
+
let sample queue x = match prj x with
745
+
| Pure _ | Operator _ -> assert false
746
+
| Root t as self ->
747
+
(*lock the root mutex while sampling*)
748
+
Mutex.protect t.mutex @@ fun _->
749
+
match t.value with
750
+
| Eval_some value -> value
751
+
| _ ->
752
+
(
753
+
(* no cached value, compute it now *)
754
+
if not t.acquired then (
755
+
t.acquired <- true;
756
+
sub_acquire self t.child;
757
+
);
758
+
t.value <- Eval_progress;
759
+
let value = sub_sample queue self t.child in
760
+
begin match t.value with
761
+
| Eval_progress -> t.value <- Eval_some value; (* cache value *)
762
+
| Eval_none | Eval_some _ | Eval_invalid_next -> ()
763
+
end;
764
+
value
765
+
)
766
+
767
+
let is_damaged x =
768
+
match prj x with
769
+
| Pure _ | Operator _ -> assert false
770
+
| Root {value;_}->
771
+
(* NOTE: I don't think i need a mutex here*)
772
+
(match value with
773
+
| Eval_some _ -> false
774
+
| Eval_none | Eval_progress | Eval_invalid_next -> true
775
+
)
776
+
777
+
let release queue x = match prj x with
778
+
| Pure _ | Operator _ -> assert false
779
+
| Root t as self ->
780
+
Mutex.protect t.mutex @@ fun _->
781
+
if t.acquired then (
782
+
(* release subtree, remove cached value *)
783
+
t.value <- Eval_none;
784
+
t.acquired <- false;
785
+
queue := Release_more { origin = self; element = t.child; next = !queue }
786
+
)
787
+
788
+
let set_on_invalidate x f =
789
+
match prj x with
790
+
| Pure _ | Operator _ -> assert false
791
+
| Root t ->
792
+
t.on_invalidate <- f
793
+
794
+
let flush_or_fail main_exn queue =
795
+
match flush_release_queue queue with
796
+
| [] -> ()
797
+
| failures -> raise (Release_failure (main_exn, failures))
798
+
799
+
let quick_sample root =
800
+
let queue = ref Release_done in
801
+
match sample queue root with
802
+
| result -> flush_or_fail None queue; result
803
+
| exception exn -> flush_or_fail (Some exn) queue; raise exn
804
+
805
+
let quick_release root =
806
+
let queue = ref Release_done in
807
+
release queue root;
808
+
flush_or_fail None queue
809
+
810
+
module Infix = struct
811
+
let (>>=) x f = bind x ~f
812
+
let (>|=) x f = map x ~f
813
+
let (<*>) = app
814
+
end
815
+
816
+
(*$R
817
+
let x = var 0 in
818
+
let y = map ~f:succ (get x) in
819
+
let o_y = Lwd.observe y in
820
+
assert_equal 1 (quick_sample o_y);
821
+
set x 10;
822
+
assert_equal 11 (quick_sample o_y);
823
+
*)
824
+
end
+12
forks/lwd/lib/lwd/lwd_infix.ml
+12
forks/lwd/lib/lwd/lwd_infix.ml
···
1
+
(*BEGIN LETOP*)
2
+
let (let$) : 'a Lwd.t -> ('a -> 'b) -> 'b Lwd.t = Lwd.Infix.(>|=)
3
+
let (and$) : 'a Lwd.t -> 'b Lwd.t -> ('a * 'b) Lwd.t = Lwd.pair
4
+
let (let$*) : 'a Lwd.t -> ('a -> 'b Lwd.t) -> 'b Lwd.t = Lwd.Infix.(>>=)
5
+
(*END*)
6
+
7
+
let ($=) : 'a Lwd.var -> 'a -> unit = Lwd.set
8
+
let ($<-) : 'a Lwd_table.row -> 'a -> unit = Lwd_table.set
9
+
10
+
let ( |>$ ) v f = Lwd.map ~f v
11
+
let ( >> ) f g x = g (f x)
12
+
+23
forks/lwd/lib/lwd/lwd_infix.mli
+23
forks/lwd/lib/lwd/lwd_infix.mli
···
1
+
(*BEGIN LETOP*)
2
+
val (let$) : 'a Lwd.t -> ('a -> 'b) -> 'b Lwd.t
3
+
(** Alias to {!Lwd.map'} suitable for let-op bindings *)
4
+
5
+
val (let$*) : 'a Lwd.t -> ('a -> 'b Lwd.t) -> 'b Lwd.t
6
+
(** Alias to {!Lwd.bind} suitable for let-op bindings *)
7
+
8
+
val (and$) : 'a Lwd.t -> 'b Lwd.t -> ('a * 'b) Lwd.t
9
+
(** Alias to {!Lwd.pair} suitable for let-op bindings *)
10
+
(*END*)
11
+
12
+
val ($=) : 'a Lwd.var -> 'a -> unit
13
+
(** Infix alias to {!Lwd.set} *)
14
+
15
+
val ($<-) : 'a Lwd_table.row -> 'a -> unit
16
+
(** Infix alias to {!Lwd_table.set} *)
17
+
18
+
val ( |>$ ):'a Lwd.t -> ('a -> 'b) -> 'b Lwd.t
19
+
(** Used to pipe with Lwd.map *)
20
+
21
+
val ( >> ):('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
22
+
(** Function composition operator *)
23
+
+908
forks/lwd/lib/lwd/lwd_seq.ml
+908
forks/lwd/lib/lwd/lwd_seq.ml
···
1
+
(*BEGIN INJECTIVITY*)
2
+
type !+'a t =
3
+
(*ELSE*)
4
+
type +'a t =
5
+
(*END*)
6
+
| Nil
7
+
| Leaf of { mutable mark: int; v: 'a; }
8
+
| Join of { mutable mark: int; l: 'a t; r: 'a t; }
9
+
10
+
type 'a seq = 'a t
11
+
12
+
let empty = Nil
13
+
14
+
let element v = Leaf { mark = 0; v }
15
+
16
+
let mask_bits = 2
17
+
18
+
let maxi a b : int = if b > a then b else a
19
+
20
+
let rank = function
21
+
| Nil -> 0
22
+
| Leaf t ->
23
+
if t.mark <> 0 then
24
+
invalid_arg "Lwd_seq.rank: node is marked";
25
+
0
26
+
| Join t ->
27
+
if t.mark land mask_bits <> 0 then
28
+
invalid_arg "Lwd_seq.rank: node is marked";
29
+
t.mark lsr mask_bits
30
+
31
+
let concat a b = match a, b with
32
+
| Nil, x | x, Nil -> x
33
+
| l, r -> Join { mark = (maxi (rank l) (rank r) + 1) lsl mask_bits; l; r }
34
+
35
+
type ('a, 'b) view =
36
+
| Empty
37
+
| Element of 'a
38
+
| Concat of 'b * 'b
39
+
40
+
let view = function
41
+
| Nil -> Empty
42
+
| Leaf t -> Element t.v
43
+
| Join t -> Concat (t.l, t.r)
44
+
45
+
module Balanced : sig
46
+
type 'a t = private 'a seq
47
+
val empty : 'a t
48
+
val element : 'a -> 'a t
49
+
val concat : 'a t -> 'a t -> 'a t
50
+
51
+
val view : 'a t -> ('a, 'a t) view
52
+
end = struct
53
+
type 'a t = 'a seq
54
+
55
+
let empty = empty
56
+
let element = element
57
+
58
+
let check l r = abs (l - r) <= 1
59
+
60
+
let rec node_left l r =
61
+
let ml = rank l in
62
+
let mr = rank r in
63
+
if check ml mr then concat l r else match l with
64
+
| Nil | Leaf _ -> assert false
65
+
| Join t ->
66
+
if check (rank t.l) ml
67
+
then concat t.l (node_left t.r r)
68
+
else match t.r with
69
+
| Nil | Leaf _ -> assert false
70
+
| Join tr ->
71
+
let trr = node_left tr.r r in
72
+
if check (1 + maxi (rank t.l) (rank tr.l)) (rank trr)
73
+
then concat (concat t.l tr.l) trr
74
+
else concat t.l (concat tr.l trr)
75
+
76
+
let rec node_right l r =
77
+
let ml = rank l in
78
+
let mr = rank r in
79
+
if check mr ml then concat l r else match r with
80
+
| Nil | Leaf _ -> assert false
81
+
| Join t ->
82
+
if check (rank t.r) mr
83
+
then concat (node_right l t.l) t.r
84
+
else match t.l with
85
+
| Nil | Leaf _ -> assert false
86
+
| Join tl ->
87
+
let tll = node_right l tl.l in
88
+
if check (1 + maxi (rank tl.r) (rank t.r)) (rank tll)
89
+
then concat tll (concat tl.r t.r)
90
+
else concat (concat tll tl.r) t.r
91
+
92
+
let concat l r =
93
+
let ml = rank l in
94
+
let mr = rank r in
95
+
if check ml mr
96
+
then concat l r
97
+
else if ml <= mr
98
+
then node_right l r
99
+
else node_left l r
100
+
101
+
let view = view
102
+
end
103
+
104
+
module Marking : sig
105
+
type mark = (*private*) int
106
+
val is_shared : mark -> bool
107
+
val is_not_shared : mark -> bool
108
+
val is_none : mark -> bool
109
+
val is_both : mark -> bool
110
+
val is_old : mark -> bool
111
+
val is_new : mark -> bool
112
+
(*val has_old : mark -> bool*)
113
+
(*val has_new : mark -> bool*)
114
+
val set_both : mark -> mark
115
+
val unmark : mark -> mark
116
+
val get_index : mark -> int
117
+
val with_index_new : int -> mark
118
+
119
+
type stats
120
+
val marked : stats -> int
121
+
val shared : stats -> int
122
+
val blocked : stats -> int
123
+
124
+
type traversal
125
+
val old_stats : traversal -> stats
126
+
val new_stats : traversal -> stats
127
+
128
+
val unsafe_traverse : old_root:_ seq -> new_root:_ seq -> traversal
129
+
130
+
val restore : _ seq -> unit
131
+
end = struct
132
+
type mark = int
133
+
134
+
let mask_none = 0
135
+
let mask_old = 1
136
+
let mask_new = 2
137
+
let mask_both = 3
138
+
139
+
let is_shared m = m = -1
140
+
let is_not_shared m = m <> -1
141
+
let is_none m = m land mask_both = mask_none
142
+
let is_both m = m land mask_both = mask_both
143
+
let is_old m = m land mask_both = mask_old
144
+
let is_new m = m land mask_both = mask_new
145
+
(*let has_old m = m land mask_old <> 0*)
146
+
(*let has_new m = m land mask_new <> 0*)
147
+
let set_both m = m lor mask_both
148
+
149
+
let get_index m = m lsr mask_bits
150
+
let with_index_new index = (index lsl mask_bits) lor mask_new
151
+
152
+
let unmark m = m land lnot mask_both
153
+
154
+
type stats = {
155
+
mutable marked: int;
156
+
mutable shared: int;
157
+
mutable blocked: int;
158
+
}
159
+
let marked s = s.marked
160
+
let shared s = s.shared
161
+
let blocked s = s.blocked
162
+
163
+
let mk_stats () = { marked = 0; shared = 0; blocked = 0 }
164
+
165
+
let new_marked stats = stats.marked <- stats.marked + 1
166
+
let new_shared stats = stats.shared <- stats.shared + 1
167
+
let new_blocked stats = stats.blocked <- stats.blocked + 1
168
+
169
+
let rec block stats mask = function
170
+
| Nil -> ()
171
+
| Leaf t' ->
172
+
let mark = t'.mark in
173
+
if mark land mask_both <> mask_both && mark land mask_both <> 0
174
+
then (
175
+
if mark land mask = 0 then new_marked stats else assert false;
176
+
new_blocked stats;
177
+
t'.mark <- mark lor mask_both
178
+
)
179
+
| Join t' ->
180
+
let mark = t'.mark in
181
+
if mark land mask_both <> mask_both && mark land mask_both <> 0
182
+
then (
183
+
if mark land mask = 0 then new_marked stats else assert false;
184
+
new_blocked stats;
185
+
t'.mark <- mark lor mask_both;
186
+
block stats mask t'.l;
187
+
block stats mask t'.r;
188
+
)
189
+
190
+
let enqueue stats q mask = function
191
+
| Nil -> ()
192
+
| Leaf t' ->
193
+
let mark = t'.mark in
194
+
if mark land mask = 0 then (
195
+
(* Not yet seen *)
196
+
new_marked stats;
197
+
if mark land mask_both <> 0 then (
198
+
(* Newly shared, clear mask *)
199
+
t'.mark <- -1;
200
+
new_blocked stats;
201
+
new_shared stats;
202
+
) else
203
+
t'.mark <- mark lor mask;
204
+
);
205
+
if mark <> -1 && mark land mask_both = mask_both then (
206
+
t'.mark <- -1;
207
+
new_shared stats
208
+
)
209
+
| Join t' as t ->
210
+
let mark = t'.mark in
211
+
if mark land mask = 0 then (
212
+
(* Not yet seen *)
213
+
new_marked stats;
214
+
if mark land mask_both <> 0 then (
215
+
(* Newly shared, clear mask *)
216
+
t'.mark <- -1;
217
+
new_blocked stats;
218
+
new_shared stats;
219
+
block stats mask t'.l;
220
+
block stats mask t'.r;
221
+
) else (
222
+
(* First mark *)
223
+
t'.mark <- mark lor mask;
224
+
Queue.push t q
225
+
)
226
+
);
227
+
if mark <> -1 && mark land mask_both = mask_both then (
228
+
t'.mark <- -1;
229
+
new_shared stats
230
+
)
231
+
232
+
let dequeue stats q mask =
233
+
match Queue.pop q with
234
+
| Join t ->
235
+
if t.mark land mask_both = mask then (
236
+
enqueue stats q mask t.l;
237
+
enqueue stats q mask t.r;
238
+
)
239
+
| _ -> assert false
240
+
241
+
let traverse1 stats q mask =
242
+
while not (Queue.is_empty q) do
243
+
dequeue stats q mask
244
+
done
245
+
246
+
let rec traverse sold snew qold qnew =
247
+
if Queue.is_empty qold then
248
+
traverse1 snew qnew mask_new
249
+
else if Queue.is_empty qnew then
250
+
traverse1 sold qold mask_old
251
+
else (
252
+
dequeue sold qold mask_old;
253
+
dequeue snew qnew mask_new;
254
+
traverse sold snew qold qnew
255
+
)
256
+
257
+
type traversal = {
258
+
old_stats: stats;
259
+
new_stats: stats;
260
+
}
261
+
262
+
let old_stats tr = tr.old_stats
263
+
let new_stats tr = tr.new_stats
264
+
265
+
let unsafe_traverse ~old_root ~new_root =
266
+
let old_stats = mk_stats () in
267
+
let new_stats = mk_stats () in
268
+
let old_queue = Queue.create () in
269
+
let new_queue = Queue.create () in
270
+
enqueue old_stats old_queue mask_old old_root;
271
+
enqueue new_stats new_queue mask_new new_root;
272
+
traverse old_stats new_stats old_queue new_queue;
273
+
{old_stats; new_stats}
274
+
275
+
let restore = function
276
+
| Nil -> ()
277
+
| Leaf t -> t.mark <- 0
278
+
| Join t ->
279
+
t.mark <- (maxi (rank t.l) (rank t.r) + 1) lsl mask_bits
280
+
end
281
+
282
+
(* Marks go through many states.
283
+
284
+
A mark is usually split in two parts:
285
+
- the mask, made of the two least significant bits
286
+
- the index is an unsigned integer formed of all the remaining bits
287
+
288
+
The exception is the distinguished mask with value -1 (all bits set to 1)
289
+
that denote a "locked" node.
290
+
291
+
When the mask is 0, the index denotes the rank of the node: the depth of
292
+
the tree rooted at this node.
293
+
When the mask is non-zero, the index meaning is left to the traversal
294
+
algorithm.
295
+
Restoring the mark sets the mask to 0 and the indext to the rank,
296
+
but is only possible when the children of the node are themselves restored.
297
+
*)
298
+
299
+
module Reducer = struct
300
+
type (+'a, 'b) xform =
301
+
| XEmpty
302
+
| XLeaf of { a: 'a t; mutable b: 'b option; }
303
+
| XJoin of { a: 'a t; mutable b: 'b option;
304
+
l: ('a, 'b) xform; r: ('a, 'b) xform; }
305
+
306
+
type ('a, 'b) unmark_state = {
307
+
dropped : 'b option array;
308
+
mutable dropped_leaf : int;
309
+
mutable dropped_join : int;
310
+
shared : 'a seq array;
311
+
shared_x : ('a, 'b) xform list array;
312
+
mutable shared_index: int;
313
+
}
314
+
315
+
let next_shared_index st =
316
+
let result = st.shared_index in
317
+
st.shared_index <- result + 1;
318
+
result
319
+
320
+
let rec unblock = function
321
+
| XEmpty -> ()
322
+
| XLeaf {a = Nil | Join _; _} -> assert false
323
+
| XJoin {a = Nil | Leaf _; _} -> assert false
324
+
| XLeaf {a = Leaf t'; _} ->
325
+
let mark = t'.mark in
326
+
if Marking.is_not_shared mark && Marking.is_both mark then
327
+
t'.mark <- Marking.unmark mark;
328
+
| XJoin {a = Join t'; l; r; _} ->
329
+
let mark = t'.mark in
330
+
if Marking.is_not_shared mark && Marking.is_both mark then (
331
+
t'.mark <- Marking.unmark mark;
332
+
unblock l;
333
+
unblock r
334
+
)
335
+
336
+
let rec unmark_old st = function
337
+
| XEmpty -> ()
338
+
| XLeaf {a = Nil | Join _; _} -> assert false
339
+
| XJoin {a = Nil | Leaf _; _} -> assert false
340
+
| XLeaf {a = Leaf t' as a; b} as t ->
341
+
let mark = t'.mark in
342
+
if Marking.is_old mark then (
343
+
let dropped_leaf = st.dropped_leaf in
344
+
if dropped_leaf > -1 then (
345
+
st.dropped.(dropped_leaf) <- b;
346
+
st.dropped_leaf <- dropped_leaf + 1;
347
+
assert (st.dropped_leaf <= st.dropped_join);
348
+
);
349
+
t'.mark <- Marking.unmark mark
350
+
) else if Marking.is_shared mark then (
351
+
let index = next_shared_index st in
352
+
st.shared.(index) <- a;
353
+
st.shared_x.(index) <- [t];
354
+
t'.mark <- Marking.with_index_new index;
355
+
) else if Marking.is_new mark then (
356
+
let index = Marking.get_index mark in
357
+
st.shared_x.(index) <- t :: st.shared_x.(index);
358
+
) else if Marking.is_both mark then (
359
+
assert false
360
+
(*t'.mark <- mark land lnot both_mask*)
361
+
)
362
+
| XJoin {a = Join t' as a; l; r; b} as t ->
363
+
let mark = t'.mark in
364
+
if Marking.is_shared mark then (
365
+
let index = next_shared_index st in
366
+
st.shared.(index) <- a;
367
+
st.shared_x.(index) <- [t];
368
+
t'.mark <- Marking.with_index_new index;
369
+
unblock l;
370
+
unblock r;
371
+
) else if Marking.is_old mark then (
372
+
if st.dropped_join > -1 then (
373
+
let dropped_join = st.dropped_join - 1 in
374
+
st.dropped.(dropped_join) <- b;
375
+
st.dropped_join <- dropped_join;
376
+
assert (st.dropped_leaf <= st.dropped_join);
377
+
);
378
+
t'.mark <- Marking.unmark mark;
379
+
unmark_old st l;
380
+
unmark_old st r;
381
+
) else if Marking.is_new mark then (
382
+
let index = mark lsr mask_bits in
383
+
st.shared_x.(index) <- t :: st.shared_x.(index);
384
+
) else if Marking.is_both mark then (
385
+
assert false
386
+
)
387
+
388
+
let prepare_shared st =
389
+
for i = 0 to st.shared_index - 1 do
390
+
begin match st.shared.(i) with
391
+
| Nil -> ()
392
+
| Leaf t -> t.mark <- Marking.set_both t.mark
393
+
| Join t -> t.mark <- Marking.set_both t.mark
394
+
end;
395
+
match st.shared_x.(i) with
396
+
| [] -> assert false
397
+
| [_] -> ()
398
+
| xs -> st.shared_x.(i) <- List.rev xs
399
+
done
400
+
401
+
let rec unmark_new st = function
402
+
| Nil -> XEmpty
403
+
| Leaf t' as t ->
404
+
let mark = t'.mark in
405
+
if Marking.is_not_shared mark && Marking.is_both mark then (
406
+
let index = mark lsr mask_bits in
407
+
match st.shared_x.(index) with
408
+
| [] -> XLeaf {a = t; b = None}
409
+
| x :: xs -> st.shared_x.(index) <- xs; x
410
+
) else (
411
+
t'.mark <- 0;
412
+
XLeaf {a = t; b = None}
413
+
)
414
+
| Join t' as t ->
415
+
let mark = t'.mark in
416
+
if mark = -1 then (
417
+
let index = next_shared_index st in
418
+
t'.mark <- 0;
419
+
st.shared.(index) <- t;
420
+
let l = unmark_new st t'.l in
421
+
let r = unmark_new st t'.r in
422
+
XJoin {a = t; b = None; l; r}
423
+
) else if Marking.is_both mark then (
424
+
let index = mark lsr mask_bits in
425
+
match st.shared_x.(index) with
426
+
| [] -> assert false
427
+
| x :: xs ->
428
+
st.shared_x.(index) <- xs;
429
+
if xs == [] then t'.mark <- 0;
430
+
x
431
+
) else (
432
+
t'.mark <- Marking.unmark t'.mark;
433
+
let l = unmark_new st t'.l in
434
+
let r = unmark_new st t'.r in
435
+
XJoin {a = t; b = None; l; r}
436
+
)
437
+
438
+
type 'b dropped = {
439
+
leaves: int;
440
+
table: 'b option array;
441
+
extra_leaf: 'b list;
442
+
extra_join: 'b list;
443
+
}
444
+
445
+
let no_dropped =
446
+
{ leaves = 0; table = [||]; extra_leaf = []; extra_join = [] }
447
+
448
+
let diff get_dropped xold tnew = match xold, tnew with
449
+
| XEmpty, Nil -> no_dropped, XEmpty
450
+
| (XLeaf {a; _} | XJoin {a; _}), _ when a == tnew -> no_dropped, xold
451
+
| _ ->
452
+
let traversal =
453
+
Marking.unsafe_traverse
454
+
~old_root:(match xold with
455
+
| XEmpty -> empty
456
+
| (XLeaf {a; _} | XJoin {a; _}) -> a
457
+
)
458
+
~new_root:tnew
459
+
in
460
+
let sold = Marking.old_stats traversal in
461
+
let snew = Marking.new_stats traversal in
462
+
let nb_dropped =
463
+
Marking.marked sold - (Marking.blocked sold + Marking.blocked snew)
464
+
in
465
+
let nb_shared =
466
+
Marking.shared sold + Marking.shared snew
467
+
in
468
+
let st = {
469
+
dropped = if get_dropped then Array.make nb_dropped None else [||];
470
+
dropped_leaf = if get_dropped then 0 else - 1;
471
+
dropped_join = if get_dropped then nb_dropped else - 1;
472
+
shared = Array.make nb_shared Nil;
473
+
shared_x = Array.make nb_shared [];
474
+
shared_index = 0;
475
+
} in
476
+
(*Printf.eprintf "sold.shared:%d sold.marked:%d sold.blocked:%d\n%!"
477
+
sold.shared sold.marked sold.blocked;
478
+
Printf.eprintf "snew.shared:%d snew.marked:%d snew.blocked:%d\n%!"
479
+
snew.shared snew.marked snew.blocked;*)
480
+
unmark_old st xold;
481
+
assert (st.dropped_leaf = st.dropped_join);
482
+
prepare_shared st;
483
+
let result = unmark_new st tnew in
484
+
(*Printf.eprintf "new_computed:%d%!\n" !new_computed;*)
485
+
for i = st.shared_index - 1 downto 0 do
486
+
Marking.restore st.shared.(i)
487
+
done;
488
+
if get_dropped then (
489
+
let xleaf = ref [] in
490
+
let xjoin = ref [] in
491
+
for i = 0 to st.shared_index - 1 do
492
+
List.iter (function
493
+
| XLeaf { b = Some b; _} -> xleaf := b :: !xleaf
494
+
| XJoin { b = Some b; _} -> xjoin := b :: !xjoin
495
+
| _ -> ()
496
+
) st.shared_x.(i)
497
+
done;
498
+
({ leaves = st.dropped_leaf;
499
+
table = st.dropped;
500
+
extra_leaf = !xleaf;
501
+
extra_join = !xjoin }, result)
502
+
) else
503
+
no_dropped, result
504
+
505
+
type ('a, 'b) map_reduce = {
506
+
map: 'a -> 'b;
507
+
reduce: 'b -> 'b -> 'b;
508
+
}
509
+
510
+
let eval map_reduce = function
511
+
| XEmpty -> None
512
+
| other ->
513
+
let rec aux = function
514
+
| XEmpty | XLeaf {a = Nil | Join _; _} -> assert false
515
+
| XLeaf {b = Some b; _} | XJoin {b = Some b; _} -> b
516
+
| XLeaf ({a = Leaf t';_ } as t) ->
517
+
let result = map_reduce.map t'.v in
518
+
t.b <- Some result;
519
+
result
520
+
| XJoin t ->
521
+
let l = aux t.l and r = aux t.r in
522
+
let result = map_reduce.reduce l r in
523
+
t.b <- Some result;
524
+
result
525
+
in
526
+
Some (aux other)
527
+
528
+
type ('a, 'b) reducer = ('a, 'b) map_reduce * ('a, 'b) xform
529
+
530
+
let make ~map ~reduce = ({map; reduce}, XEmpty)
531
+
532
+
let reduce (map_reduce, tree : _ reducer) =
533
+
eval map_reduce tree
534
+
535
+
let update (map_reduce, old_tree : _ reducer) new_tree : _ reducer =
536
+
let _, tree = diff false old_tree new_tree in
537
+
(map_reduce, tree)
538
+
539
+
let update_and_get_dropped (map_reduce, old_tree : _ reducer) new_tree
540
+
: _ dropped * _ reducer =
541
+
let dropped, tree = diff true old_tree new_tree in
542
+
(dropped, (map_reduce, tree))
543
+
544
+
let fold_dropped kind f dropped acc =
545
+
let acc = ref acc in
546
+
let start, bound = match kind with
547
+
| `All -> 0, Array.length dropped.table
548
+
| `Map -> 0, dropped.leaves
549
+
| `Reduce -> dropped.leaves, Array.length dropped.table
550
+
in
551
+
for i = start to bound - 1 do
552
+
match dropped.table.(i) with
553
+
| None -> ()
554
+
| Some x -> acc := f x !acc
555
+
done;
556
+
begin match kind with
557
+
| `All | `Map ->
558
+
List.iter (fun x -> acc := f x !acc) dropped.extra_leaf
559
+
| `Reduce -> ()
560
+
end;
561
+
begin match kind with
562
+
| `All | `Reduce ->
563
+
List.iter (fun x -> acc := f x !acc) dropped.extra_join
564
+
| `Map -> ()
565
+
end;
566
+
!acc
567
+
end
568
+
569
+
(* Lwd interface *)
570
+
571
+
let rec pure_map_reduce map reduce = function
572
+
| Nil -> assert false
573
+
| Leaf t -> map t.v
574
+
| Join t ->
575
+
reduce
576
+
(pure_map_reduce map reduce t.l)
577
+
(pure_map_reduce map reduce t.r)
578
+
579
+
let fold ~map ~reduce seq =
580
+
match Lwd.is_pure seq with
581
+
| Some Nil -> Lwd.pure None
582
+
| Some other -> Lwd.pure (Some (pure_map_reduce map reduce other))
583
+
| None ->
584
+
let reducer = ref (Reducer.make ~map ~reduce) in
585
+
Lwd.map seq ~f:begin fun seq ->
586
+
let reducer' = Reducer.update !reducer seq in
587
+
reducer := reducer';
588
+
Reducer.reduce reducer'
589
+
end
590
+
591
+
let fold_monoid map (zero, reduce) seq =
592
+
match Lwd.is_pure seq with
593
+
| Some Nil -> Lwd.pure zero
594
+
| Some other -> Lwd.pure (pure_map_reduce map reduce other)
595
+
| None ->
596
+
let reducer = ref (Reducer.make ~map ~reduce) in
597
+
Lwd.map seq ~f:begin fun seq ->
598
+
let reducer' = Reducer.update !reducer seq in
599
+
reducer := reducer';
600
+
match Reducer.reduce reducer' with
601
+
| None -> zero
602
+
| Some x -> x
603
+
end
604
+
605
+
let monoid = (empty, concat)
606
+
607
+
let transform_list ls f =
608
+
Lwd_utils.map_reduce f monoid ls
609
+
610
+
let of_list ls = transform_list ls element
611
+
612
+
let rec of_sub_array f arr i j =
613
+
if j < i then empty
614
+
else if j = i then f arr.(i)
615
+
else
616
+
let k = i + (j - i) / 2 in
617
+
concat (of_sub_array f arr i k) (of_sub_array f arr (k + 1) j)
618
+
619
+
let transform_array arr f = of_sub_array f arr 0 (Array.length arr - 1)
620
+
621
+
let of_array arr = transform_array arr element
622
+
623
+
let to_list x =
624
+
let rec fold x acc = match x with
625
+
| Nil -> acc
626
+
| Leaf t -> t.v :: acc
627
+
| Join t -> fold t.l (fold t.r acc)
628
+
in
629
+
fold x []
630
+
631
+
let to_array x =
632
+
let rec count = function
633
+
| Nil -> 0
634
+
| Leaf _ -> 1
635
+
| Join t -> count t.l + count t.r
636
+
in
637
+
match count x with
638
+
| 0 -> [||]
639
+
| n ->
640
+
let rec first = function
641
+
| Nil -> assert false
642
+
| Leaf t -> t.v
643
+
| Join t -> first t.l
644
+
in
645
+
let first = first x in
646
+
let arr = Array.make n first in
647
+
let rec fold i = function
648
+
| Nil -> i
649
+
| Leaf t -> arr.(i) <- t.v; i + 1
650
+
| Join t ->
651
+
let i = fold i t.l in
652
+
let i = fold i t.r in
653
+
i
654
+
in
655
+
let _ : int = fold 0 x in
656
+
arr
657
+
658
+
let lwd_empty : 'a t Lwd.t = Lwd.pure Nil
659
+
let lwd_monoid : 'a. 'a t Lwd.t Lwd_utils.monoid =
660
+
(lwd_empty, fun x y -> Lwd.map2 ~f:concat x y)
661
+
662
+
let map f seq =
663
+
fold_monoid (fun x -> element (f x)) monoid seq
664
+
665
+
let filter f seq =
666
+
fold_monoid (fun x -> if f x then element x else empty) monoid seq
667
+
668
+
let filter_map f seq =
669
+
let select x = match f x with
670
+
| Some y -> element y
671
+
| None -> empty
672
+
in
673
+
fold_monoid select monoid seq
674
+
675
+
let bind (seq : 'a seq Lwd.t) (f : 'a -> 'b seq Lwd.t) : 'b seq Lwd.t =
676
+
Lwd.join (fold_monoid f lwd_monoid seq)
677
+
678
+
let seq_bind (seq : 'a seq Lwd.t) (f : 'a -> 'b seq) : 'b seq Lwd.t =
679
+
fold_monoid f monoid seq
680
+
681
+
let lift (seq : 'a Lwd.t seq Lwd.t) : 'a seq Lwd.t =
682
+
bind seq (Lwd.map ~f:element)
683
+
684
+
module BalancedTree : sig
685
+
type 'a t =
686
+
| Leaf
687
+
| Node of {
688
+
rank: int;
689
+
l: 'a t;
690
+
x: int * 'a seq;
691
+
r: 'a t;
692
+
mutable seq: 'a seq;
693
+
}
694
+
val leaf : 'a t
695
+
(*val node : 'a t -> int * 'a seq -> 'a t -> 'a t*)
696
+
697
+
val insert : cmp:('a -> 'a -> int) -> int -> 'a seq -> 'a t -> 'a t
698
+
(*val union : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t*)
699
+
end = struct
700
+
type 'a t =
701
+
| Leaf
702
+
| Node of {
703
+
rank: int;
704
+
l: 'a t;
705
+
x: int * 'a seq;
706
+
r: 'a t;
707
+
mutable seq: 'a seq;
708
+
}
709
+
710
+
let leaf = Leaf
711
+
712
+
let rank = function
713
+
| Leaf -> 0
714
+
| Node t -> t.rank
715
+
716
+
let check l r = abs (l - r) <= 1
717
+
718
+
let node l x r =
719
+
Node {l; x; r; seq = empty; rank = maxi (rank l) (rank r) + 1}
720
+
721
+
let rec node_left l x r =
722
+
let ml = rank l in
723
+
let mr = rank r in
724
+
if check ml mr then node l x r else match l with
725
+
| Leaf -> assert false
726
+
| Node t ->
727
+
if check (rank t.l) ml
728
+
then node t.l t.x (node_left t.r x r)
729
+
else match t.r with
730
+
| Leaf -> assert false
731
+
| Node tr ->
732
+
let trr = node_left tr.r x r in
733
+
if check (1 + maxi (rank t.l) (rank tr.l)) (rank trr)
734
+
then node (node t.l t.x tr.l) tr.x trr
735
+
else node t.l t.x (node tr.l tr.x trr)
736
+
737
+
let rec node_right l x r =
738
+
let ml = rank l in
739
+
let mr = rank r in
740
+
if check mr ml then node l x r else match r with
741
+
| Leaf -> assert false
742
+
| Node t ->
743
+
if check (rank t.r) mr
744
+
then node (node_right l x t.l) t.x t.r
745
+
else match t.l with
746
+
| Leaf -> assert false
747
+
| Node tl ->
748
+
let tll = node_right l x tl.l in
749
+
if check (1 + maxi (rank tl.r) (rank t.r)) (rank tll)
750
+
then node tll tl.x (node tl.r t.x t.r)
751
+
else node (node tll tl.x tl.r) t.x t.r
752
+
753
+
let node l x r =
754
+
let ml = rank l in
755
+
let mr = rank r in
756
+
if check ml mr
757
+
then node l x r
758
+
else if ml <= mr
759
+
then node_right l x r
760
+
else node_left l x r
761
+
762
+
let rec join l r = match l, r with
763
+
| Leaf, t | t, Leaf -> t
764
+
| Node tl, Node tr ->
765
+
if tl.rank <= tr.rank then
766
+
node (join l tr.l) tr.x tr.r
767
+
else
768
+
node tl.l tl.x (join tl.r r)
769
+
770
+
let get_element = function
771
+
| Nil | Join _ -> assert false
772
+
| Leaf {v;_} -> v
773
+
774
+
(*let rec split ~cmp k = function
775
+
| Leaf -> Leaf, 0, Leaf
776
+
| Node t ->
777
+
let c = cmp k (get_element (snd (t.x))) in
778
+
if c < 0 then
779
+
let l', v', r' = split ~cmp k t.l in
780
+
l', v', join r' t.r
781
+
else if c > 0 then
782
+
let l', v', r' = split ~cmp k t.r in
783
+
join t.l l', v', r'
784
+
else
785
+
(t.l, fst t.x, t.r)
786
+
787
+
let rec union ~cmp t1 t2 =
788
+
match t1, t2 with
789
+
| Leaf, t | t, Leaf -> t
790
+
| Node t1, t2 ->
791
+
let m1, k1 = t1.x in
792
+
let l2, m2, r2 = split ~cmp (get_element k1) t2 in
793
+
let l' = union ~cmp t1.l l2 in
794
+
let r' = union ~cmp t1.r r2 in
795
+
let m = m1 + m2 in
796
+
if m = 0 then
797
+
join l' r'
798
+
else (
799
+
assert (m > 0);
800
+
node l' (m, k1) r';
801
+
)
802
+
*)
803
+
804
+
let insert ~cmp m1 s t =
805
+
assert (m1 <> 0);
806
+
let rec aux = function
807
+
| Leaf -> node Leaf (m1, s) Leaf
808
+
| Node t ->
809
+
let m2, x = t.x in
810
+
let c = cmp (get_element s) (get_element x) in
811
+
if c = 0 then
812
+
let m = m1 + m2 in
813
+
if m = 0 then
814
+
join t.l t.r
815
+
else
816
+
node t.l (m, x) t.r
817
+
else if c < 0 then
818
+
let l' = aux t.l in
819
+
node l' t.x t.r
820
+
else
821
+
let r' = aux t.r in
822
+
node t.l t.x r'
823
+
in
824
+
aux t
825
+
end
826
+
827
+
let rec seq_of_tree = function
828
+
| BalancedTree.Leaf -> empty
829
+
| BalancedTree.Node t ->
830
+
match t.seq with
831
+
| Nil ->
832
+
let sl = seq_of_tree t.l in
833
+
let sr = seq_of_tree t.r in
834
+
assert (fst t.x > 0);
835
+
let seq = concat sl (concat (snd t.x) sr) in
836
+
t.seq <- seq;
837
+
seq
838
+
| seq -> seq
839
+
840
+
let sort_uniq cmp seq =
841
+
let previous_seq = ref empty in
842
+
let previous_tree = ref BalancedTree.leaf in
843
+
let f new_seq =
844
+
let old_seq = !previous_seq in
845
+
let old_tree = !previous_tree in
846
+
let _ = Marking.unsafe_traverse ~old_root:old_seq ~new_root:new_seq in
847
+
let rec unblock = function
848
+
| Nil -> ()
849
+
| Leaf t -> t.mark <- Marking.unmark t.mark
850
+
| Join t as seq ->
851
+
let mark = t.mark in
852
+
unblock t.l;
853
+
unblock t.r;
854
+
if Marking.is_shared mark then (
855
+
Marking.restore seq;
856
+
) else if Marking.is_both mark then (
857
+
t.mark <- Marking.unmark mark;
858
+
) else
859
+
assert (Marking.is_none mark)
860
+
in
861
+
let rec unmark_new tree = function
862
+
| Nil -> tree
863
+
| Leaf t as seq ->
864
+
let mark = t.mark in
865
+
t.mark <- 0;
866
+
if Marking.is_new mark then
867
+
BalancedTree.insert ~cmp (+1) seq tree
868
+
else (
869
+
assert (Marking.is_both mark || Marking.is_none mark);
870
+
tree
871
+
)
872
+
| Join t as seq ->
873
+
let mark = t.mark in
874
+
if Marking.is_new mark then (
875
+
t.mark <- Marking.unmark mark;
876
+
unmark_new (unmark_new tree t.l) t.r
877
+
) else (
878
+
unblock seq;
879
+
tree
880
+
)
881
+
in
882
+
let rec unmark_old tree = function
883
+
| Nil -> tree
884
+
| Leaf t as seq ->
885
+
let mark = t.mark in
886
+
t.mark <- 0;
887
+
if Marking.is_old mark then
888
+
BalancedTree.insert ~cmp (-1) seq tree
889
+
else (
890
+
assert (Marking.is_both mark || Marking.is_none mark);
891
+
tree
892
+
)
893
+
| Join t as seq ->
894
+
let mark = t.mark in
895
+
if Marking.is_old mark then (
896
+
t.mark <- Marking.unmark mark;
897
+
unmark_old (unmark_old tree t.l) t.r
898
+
) else (
899
+
unblock seq;
900
+
tree
901
+
)
902
+
in
903
+
let new_tree = unmark_old (unmark_new old_tree new_seq) old_seq in
904
+
previous_seq := new_seq;
905
+
previous_tree := new_tree;
906
+
seq_of_tree new_tree
907
+
in
908
+
Lwd.map seq ~f
+209
forks/lwd/lib/lwd/lwd_seq.mli
+209
forks/lwd/lib/lwd/lwd_seq.mli
···
1
+
(** {1 Sequence manipulation}
2
+
3
+
[Lwd_seq] is an ordered collection with a pure interface.
4
+
Changes to collections are easy to track.
5
+
6
+
A collection can be transformed with the usual map, filter and fold
7
+
combinators. If the collection is updated, shared elements (in the sense of
8
+
physical sharing), the result of the previous transformation will be reused
9
+
for these elements.
10
+
11
+
The book-keeping overhead is O(n) in the number of changes, so O(1) per
12
+
element.
13
+
*)
14
+
15
+
(*BEGIN INJECTIVITY*)
16
+
type !+'a t
17
+
type !+'a seq = 'a t
18
+
(*ELSE*)
19
+
type +'a t
20
+
type +'a seq = 'a t
21
+
(*END*)
22
+
23
+
(** The type of sequences *)
24
+
25
+
(** {2 Primitive constructors} *)
26
+
27
+
val empty : 'a seq
28
+
(** A sequence with no element. *)
29
+
30
+
val element : 'a -> 'a seq
31
+
(** A singleton sequence. The physical identity of the element is considered
32
+
when reusing previous computations.
33
+
34
+
If you do:
35
+
36
+
{[let x1 = element x
37
+
let x2 = element x]}
38
+
39
+
Then [x1] and [x2] are seen as different elements and no sharing will be
40
+
done during transformation.
41
+
*)
42
+
43
+
val concat : 'a seq -> 'a seq -> 'a seq
44
+
(** Concatenate two sequences into a bigger one.
45
+
As for [element], the physical identity of a sequence is considered for
46
+
reuse.
47
+
*)
48
+
49
+
(** {2 Looking at sequence contents} *)
50
+
51
+
type ('a, 'b) view =
52
+
| Empty
53
+
| Element of 'a
54
+
| Concat of 'b * 'b
55
+
56
+
val view : 'a seq -> ('a, 'a seq) view
57
+
(** View how a sequence is defined *)
58
+
59
+
(** {2 Conversion between sequences, lists and arrays} *)
60
+
61
+
val transform_list : 'a list -> ('a -> 'b seq) -> 'b seq
62
+
(** Produce a sequence by transforming each element of a list and concatenating
63
+
all results. *)
64
+
65
+
val transform_array : 'a array -> ('a -> 'b seq) -> 'b seq
66
+
(** Produce a sequence by transforming each element of an array and
67
+
concatenating all results. *)
68
+
69
+
val of_list : 'a list -> 'a seq
70
+
(** Produce a sequence from a list *)
71
+
72
+
val of_array : 'a array -> 'a seq
73
+
(** Produce a sequence from an array *)
74
+
75
+
val to_list : 'a seq -> 'a list
76
+
(** Produce a list from a sequence *)
77
+
78
+
val to_array : 'a seq -> 'a array
79
+
(** Produce an array from a sequence *)
80
+
81
+
(** {2 Balanced variant of sequences} *)
82
+
83
+
module Balanced : sig
84
+
85
+
(** A variant of the sequence type that guarantees that the depth of a
86
+
transformation, measured as the number of nested [concat] nodes, grows in
87
+
O(log n) where n is the number of elements in the sequnce.
88
+
89
+
This is useful to prevent stack overflows and to avoid degenerate cases
90
+
where a single element changes, but it is at the end of a linear sequence
91
+
of [concat] nodes, thus making the total work O(n).
92
+
For instance, in:
93
+
94
+
{[concat e1 (concat e2 (concat e3 (... (concat e_n))...))]}
95
+
96
+
If [e_n] changes, the whole spine has to be recomputed.
97
+
98
+
Using [Balanced.concat], the representation will be re-balanced
99
+
internally. Then [Balanced.view] should be used to access the balanced
100
+
sequence.
101
+
102
+
When working with balanced sequences in a transformation pipeline, it is
103
+
only useful to balance the first sequence of the pipeline. Derived
104
+
sequence will have a depth bounded by the depth of the first one.
105
+
*)
106
+
107
+
type 'a t = private 'a seq
108
+
(** Type of balanced sequences *)
109
+
110
+
val empty : 'a t
111
+
val element : 'a -> 'a t
112
+
val concat : 'a t -> 'a t -> 'a t
113
+
114
+
val view : 'a t -> ('a, 'a t) view
115
+
end
116
+
117
+
(** {2 Transforming sequences} *)
118
+
119
+
(**
120
+
All sequences live in [Lwd] monad: if a sequence changes slightly, parts
121
+
that have not changed will not be re-transformed.
122
+
*)
123
+
124
+
val fold :
125
+
map:('a -> 'b) -> reduce:('b -> 'b -> 'b) -> 'a seq Lwd.t -> 'b option Lwd.t
126
+
(** [fold ~map ~reduce] transforms a sequence.
127
+
If the sequence is non-empty, the [map] function is applied to element
128
+
nodes and the [reduce] function is used to combine transformed concatenated
129
+
nodes.
130
+
If the sequence is empty, None is returned.
131
+
*)
132
+
133
+
val fold_monoid :
134
+
('a -> 'b) -> 'b Lwd_utils.monoid -> 'a seq Lwd.t -> 'b Lwd.t
135
+
(** Like [fold], but reduction and default value are defined by a [monoid] *)
136
+
137
+
val map :
138
+
('a -> 'b) -> 'a seq Lwd.t -> 'b seq Lwd.t
139
+
(** [map f] transforms a sequence by applying [f] to each element. *)
140
+
141
+
val filter :
142
+
('a -> bool) -> 'a seq Lwd.t -> 'a seq Lwd.t
143
+
(** [filter p] transforms a sequence by keeping elements that satisfies [p]. *)
144
+
145
+
val filter_map :
146
+
('a -> 'b option) -> 'a seq Lwd.t -> 'b seq Lwd.t
147
+
(** Filter and map elements at the same time *)
148
+
149
+
val lift : 'a Lwd.t seq Lwd.t -> 'a seq Lwd.t
150
+
(** Remove a layer of [Lwd] inside a sequence. *)
151
+
152
+
val bind : 'a seq Lwd.t -> ('a -> 'b seq Lwd.t) -> 'b seq Lwd.t
153
+
(** Sequence forms a monad too... *)
154
+
155
+
val seq_bind : 'a seq Lwd.t -> ('a -> 'b seq) -> 'b seq Lwd.t
156
+
(** Sequence forms a monad too... *)
157
+
158
+
val monoid : 'a t Lwd_utils.monoid
159
+
(** Monoid instance for sequences *)
160
+
161
+
val lwd_monoid : 'a t Lwd.t Lwd_utils.monoid
162
+
(** Monoid instance for reactive sequences *)
163
+
164
+
val sort_uniq : ('a -> 'a -> int) -> 'a seq Lwd.t -> 'a seq Lwd.t
165
+
166
+
(** {2 Low-level interface for observing changes} *)
167
+
168
+
module Reducer : sig
169
+
(* The interface allows to implement incremental sequence transformation
170
+
outside of the [Lwd] monad.
171
+
Actually, the Lwd functions above are implemented on top of this
172
+
interface.
173
+
*)
174
+
175
+
(* A [('a, 'b) reducer] value stores the state necessary to incrementally
176
+
transform an ['a seq] to ['b].
177
+
In essence, the Lwd functions just hide a reducer value.
178
+
*)
179
+
type ('a, 'b) reducer
180
+
181
+
(* A new reducer that transforms sequences with the given [map] and [reduce]
182
+
functions. The reducer starts from the [empty] sequence. *)
183
+
val make : map:('a -> 'b) -> reduce:('b -> 'b -> 'b) -> ('a, 'b) reducer
184
+
185
+
(* Updates the [reducer] to transform another sequence.
186
+
Intermediate nodes are reused when possible.
187
+
Only the "reuse plan" is computed by [update], actual transformation is
188
+
done by the [reduce] function.
189
+
*)
190
+
val update : ('a, 'b) reducer -> 'a seq -> ('a, 'b) reducer
191
+
192
+
(* Returns the reduced ['b] value if the sequence is non-empty or [None] if
193
+
the sequence is empty.
194
+
Because transformation is done lazily, [reduce] is the only function
195
+
that can call [map] and [reduce].
196
+
*)
197
+
val reduce : ('a, 'b) reducer -> 'b option
198
+
199
+
(* Sometimes it is important to track the elements that disappeared from a
200
+
sequence. The ['b dropped] type represent all the intermediate result that
201
+
were referenced by a reducer and are no longer after an update.
202
+
*)
203
+
type 'b dropped
204
+
val update_and_get_dropped :
205
+
('a, 'b) reducer -> 'a seq -> 'b dropped * ('a, 'b) reducer
206
+
207
+
val fold_dropped :
208
+
[<`All|`Map|`Reduce] -> ('a -> 'b -> 'b) -> 'a dropped -> 'b -> 'b
209
+
end
+579
forks/lwd/lib/lwd/lwd_table.ml
+579
forks/lwd/lib/lwd/lwd_table.ml
···
1
+
type 'a binding =
2
+
| Bound of { value : 'a ; mutable valid : bool }
3
+
| Unbound
4
+
5
+
type 'a tree =
6
+
| Leaf
7
+
| Node of {
8
+
mutable version : int;
9
+
mutable left : 'a tree;
10
+
mutable binding : 'a binding;
11
+
mutable right : 'a tree;
12
+
mutable parent : 'a tree;
13
+
mutable size : int;
14
+
}
15
+
| Root of {
16
+
mutable version : int;
17
+
mutable child : 'a tree;
18
+
mutable generation : unit ref;
19
+
mutable on_invalidate : Obj.t Lwd.prim list;
20
+
}
21
+
22
+
type 'a t = 'a tree
23
+
type 'a row = 'a tree
24
+
25
+
let not_origin = ref () (* not {!origin} *)
26
+
let origin = ref () (* not {!not_origin} *)
27
+
28
+
let make () =
29
+
Root { child = Leaf; generation = origin; version = 0; on_invalidate = [] }
30
+
31
+
let set_parent ~parent = function
32
+
| Root _ -> assert false
33
+
| Node n -> n.parent <- parent
34
+
| Leaf -> ()
35
+
36
+
let reparent ~parent ~oldchild ~newchild =
37
+
match parent with
38
+
| Root r ->
39
+
assert (r.child == oldchild);
40
+
r.child <- newchild
41
+
| Node n when n.left == oldchild ->
42
+
n.left <- newchild
43
+
| Node n when n.right == oldchild ->
44
+
n.right <- newchild
45
+
| Leaf | Node _ -> assert false
46
+
47
+
let make_node set ~left ~right ~parent =
48
+
let binding = match set with
49
+
| None -> Unbound
50
+
| Some value -> Bound { value ; valid = true }
51
+
in
52
+
let node = Node { left; right; parent; version = 0; size = 0; binding } in
53
+
set_parent left ~parent:node;
54
+
set_parent right ~parent:node;
55
+
node
56
+
57
+
let rec raw_invalidate = function
58
+
| Node { size = 0; _ } -> ()
59
+
| Node t ->
60
+
t.size <- 0;
61
+
raw_invalidate t.parent
62
+
| Root r ->
63
+
List.iter Lwd.invalidate r.on_invalidate
64
+
| Leaf -> assert false
65
+
66
+
let prepend ?set = function
67
+
| Root r as parent ->
68
+
raw_invalidate parent;
69
+
let node = make_node set ~left:Leaf ~right:r.child ~parent in
70
+
r.child <- node;
71
+
node
72
+
| Leaf | Node _ -> assert false
73
+
74
+
let prepend' x set = ignore (prepend x ~set)
75
+
76
+
let append ?set = function
77
+
| Root r as parent ->
78
+
raw_invalidate parent;
79
+
let node = make_node set ~left:r.child ~right:Leaf ~parent in
80
+
r.child <- node;
81
+
node
82
+
| Leaf | Node _ -> assert false
83
+
84
+
let append' x set = ignore (append x ~set)
85
+
86
+
let before ?set = function
87
+
| Node { parent = Leaf ; _ } | Leaf -> Leaf
88
+
| Node n as parent ->
89
+
raw_invalidate parent;
90
+
let node = make_node set ~left:n.left ~right:Leaf ~parent in
91
+
n.left <- node;
92
+
node
93
+
| Root _ -> assert false
94
+
95
+
let after ?set = function
96
+
| Node { parent = Leaf ; _ } | Leaf -> Leaf
97
+
| Node n as parent ->
98
+
raw_invalidate parent;
99
+
let node = make_node set ~left:Leaf ~right:n.right ~parent in
100
+
n.right <- node;
101
+
node
102
+
| Root _ -> assert false
103
+
104
+
let get = function
105
+
| Node { binding = Bound { value ; _ } ; _ } -> Some value
106
+
| Leaf | Root _ | Node { binding = Unbound ; _ } -> None
107
+
108
+
let invalidate_binding = function
109
+
| Unbound -> ()
110
+
| Bound b -> b.valid <- false
111
+
112
+
let set_binding x = function
113
+
| Root _ -> assert false
114
+
| Leaf | Node { parent = Leaf; _ } -> ()
115
+
| Node n as t ->
116
+
raw_invalidate t;
117
+
invalidate_binding n.binding;
118
+
n.binding <- x
119
+
120
+
let set t value = set_binding (Bound { value; valid = true }) t
121
+
let unset t = set_binding Unbound t
122
+
123
+
let is_bound = function
124
+
| Leaf | Node { parent = Leaf; _ } -> false
125
+
| Root _ | Node _ -> true
126
+
127
+
let rec join left = function
128
+
| Root _ | Leaf -> assert false
129
+
| Node ({ left = Leaf; _ } as n) as self ->
130
+
n.left <- left;
131
+
set_parent left ~parent:self;
132
+
self
133
+
| Node node ->
134
+
join left node.left
135
+
136
+
let remove = function
137
+
| Root _ | Leaf | Node {parent = Leaf; _} -> ()
138
+
| Node ({left; right; parent; _} as n) as t ->
139
+
invalidate_binding n.binding;
140
+
n.left <- Leaf;
141
+
n.right <- Leaf;
142
+
n.parent <- Leaf;
143
+
n.binding <- Unbound;
144
+
n.version <- max_int;
145
+
let join, invalid = match left, right with
146
+
| Leaf, other | other, Leaf -> (other, parent)
147
+
| _ -> (right, join left right)
148
+
in
149
+
reparent ~parent ~oldchild:t ~newchild:join;
150
+
set_parent join ~parent;
151
+
raw_invalidate invalid
152
+
153
+
let rec clear = function
154
+
| Leaf -> ()
155
+
| Node ({left; right; _} as n) ->
156
+
invalidate_binding n.binding;
157
+
n.left <- Leaf;
158
+
n.right <- Leaf;
159
+
n.parent <- Leaf;
160
+
n.binding <- Unbound;
161
+
n.version <- max_int;
162
+
clear left;
163
+
clear right
164
+
| Root r as root ->
165
+
let child = r.child in
166
+
r.child <- Leaf;
167
+
clear child;
168
+
raw_invalidate root
169
+
170
+
(* Tree balancing *)
171
+
172
+
let size = function
173
+
| Node node ->
174
+
assert (node.size <> 0);
175
+
node.size
176
+
| Leaf -> 0
177
+
| Root _ -> assert false
178
+
179
+
(** [smaller_ell smin smax] iff
180
+
- [smin] is less than [smax]
181
+
- [smin] and [smax] differs by less than two magnitude orders, i.e
182
+
msbs(smin) >= msbs(smax) - 1
183
+
where msbs is the index of the most significant bit set *)
184
+
let smaller_ell smin smax = (smin < smax) && ((smin land smax) lsl 1 < smax)
185
+
186
+
(** [disbalanced smin smax] check if two sub-trees of size [smin] and [smax],
187
+
are disbalanczed. That is, msbs(smin) < msbs(smax) - 1 *)
188
+
let disbalanced smin smax = smaller_ell smin (smax lsr 1)
189
+
190
+
let reparent ~parent ~oldchild ~newchild =
191
+
match parent with
192
+
| Root r ->
193
+
assert (r.child == oldchild);
194
+
r.child <- newchild;
195
+
| Node n when n.left == oldchild ->
196
+
n.left <- newchild
197
+
| Node n when n.right == oldchild ->
198
+
n.right <- newchild
199
+
| Leaf | Node _ -> assert false
200
+
201
+
let rec rot_left version = function
202
+
| Node ({ right = (Node rn) as r; _} as sn) as s ->
203
+
let parent = sn.parent in
204
+
let rl = match rn.left with
205
+
| Root _ -> assert false
206
+
| Leaf -> Leaf
207
+
| (Node rln) as rl ->
208
+
rln.parent <- s;
209
+
rl
210
+
in
211
+
rn.left <- s;
212
+
sn.right <- rl;
213
+
sn.parent <- r;
214
+
rn.parent <- parent;
215
+
reparent ~parent ~oldchild:s ~newchild:r;
216
+
ignore (balance version s);
217
+
balance version r
218
+
| _ -> assert false
219
+
220
+
and rot_right version = function
221
+
| Node ({ left = (Node ln) as l; _} as sn) as s ->
222
+
let parent = sn.parent in
223
+
let lr = match ln.right with
224
+
| Root _ -> assert false
225
+
| Leaf -> Leaf
226
+
| (Node lrn) as lr ->
227
+
lrn.parent <- s;
228
+
lr
229
+
in
230
+
ln.right <- s;
231
+
sn.left <- lr;
232
+
sn.parent <- l;
233
+
ln.parent <- parent;
234
+
reparent ~parent ~oldchild:s ~newchild:l;
235
+
ignore (balance version s);
236
+
balance version l
237
+
| _ -> assert false
238
+
239
+
and inc_left version = function
240
+
| Root _ | Leaf -> assert false
241
+
| Node {right; _} as self ->
242
+
begin match right with
243
+
| Node rn when smaller_ell (size rn.right) (size rn.left) ->
244
+
ignore (rot_right version right)
245
+
| _ -> ()
246
+
end;
247
+
rot_left version self
248
+
249
+
and inc_right version = function
250
+
| Root _ | Leaf -> assert false
251
+
| Node {left; _} as self ->
252
+
begin match left with
253
+
| Node ln when smaller_ell (size ln.left) (size ln.right) ->
254
+
ignore (rot_left version left)
255
+
| _ -> ()
256
+
end;
257
+
rot_right version self
258
+
259
+
and balance version = function
260
+
| Root _ | Leaf -> assert false
261
+
| Node node as self ->
262
+
let sl = size node.left and sr = size node.right in
263
+
if sl < sr then (
264
+
if disbalanced sl sr
265
+
then inc_left version self
266
+
else (node.version <- version; node.size <- 1 + sl + sr; self)
267
+
) else (
268
+
if disbalanced sr sl
269
+
then inc_right version self
270
+
else (node.version <- version; node.size <- 1 + sl + sr; self)
271
+
)
272
+
273
+
let rec compute_sub_size version = function
274
+
| Root _ -> ()
275
+
| Leaf -> ()
276
+
| Node node as self ->
277
+
if node.size = 0 then
278
+
match node.left with
279
+
| Node {size = 0; _} ->
280
+
compute_sub_size version node.left
281
+
| _ ->
282
+
match node.right with
283
+
| Node {size = 0; _} ->
284
+
compute_sub_size version node.right
285
+
| _ ->
286
+
let parent = node.parent in
287
+
ignore (balance version self);
288
+
compute_sub_size version parent
289
+
290
+
let rec reset_version version = function
291
+
| Leaf -> ()
292
+
| Node n ->
293
+
n.version <- version;
294
+
reset_version version n.left;
295
+
reset_version version n.right
296
+
| Root _ -> assert false
297
+
298
+
let rebalance = function
299
+
| Root r ->
300
+
begin match r.child with
301
+
| Node { size = 0; _ } ->
302
+
let version = succ r.version in
303
+
let version =
304
+
if version = max_int then (
305
+
r.generation <- ref ();
306
+
reset_version 0 r.child;
307
+
0
308
+
)
309
+
else version
310
+
in
311
+
r.version <- version;
312
+
compute_sub_size version r.child;
313
+
version
314
+
| Node _ | Leaf -> r.version
315
+
| Root _ -> assert false
316
+
end
317
+
| _ -> assert false
318
+
319
+
let plus (zero, plus) x y =
320
+
if x == zero then y
321
+
else if y == zero then x
322
+
else plus x y
323
+
324
+
type ('a, 'b) reduction_tree =
325
+
| Red_leaf
326
+
| Red_node of {
327
+
cell: 'a row;
328
+
binding: 'a binding;
329
+
reduction: 'b;
330
+
aggregate: 'b;
331
+
left : ('a, 'b) reduction_tree;
332
+
right : ('a, 'b) reduction_tree;
333
+
}
334
+
335
+
type ('a, 'b) reduction = {
336
+
mutable version: int;
337
+
source: 'a tree;
338
+
mutable result : ('a, 'b) reduction_tree;
339
+
mutable generation: unit ref;
340
+
mapper: 'a row -> 'a -> 'b;
341
+
monoid: 'b Lwd_utils.monoid;
342
+
}
343
+
344
+
345
+
let extract_bindings tree =
346
+
let rec aux acc = function
347
+
| Red_leaf -> acc
348
+
| Red_node rnode ->
349
+
let acc = aux acc rnode.right in
350
+
let acc = match rnode.binding with
351
+
| Unbound -> acc
352
+
| Bound { valid = false; _ } -> acc
353
+
| _ -> (rnode.binding, rnode.reduction) :: acc
354
+
in
355
+
aux acc rnode.left
356
+
in
357
+
aux [] tree
358
+
359
+
let full_rebuild red tree =
360
+
let bindings = ref (extract_bindings red.result) in
361
+
let rec aux = function
362
+
| Node node as cell ->
363
+
let left = aux node.left in
364
+
let reduction =
365
+
match node.binding, !bindings with
366
+
| Unbound, _ -> fst red.monoid
367
+
| binding, ((binding', reduction) :: bindings')
368
+
when binding == binding' ->
369
+
bindings := bindings';
370
+
reduction
371
+
| Bound b, _ -> assert b.valid; red.mapper cell b.value
372
+
in
373
+
let right = aux node.right in
374
+
let aggregate = match left with
375
+
| Red_leaf -> reduction
376
+
| Red_node r -> plus red.monoid r.aggregate reduction
377
+
in
378
+
let aggregate = match right with
379
+
| Red_leaf -> aggregate
380
+
| Red_node r -> plus red.monoid aggregate r.aggregate
381
+
in
382
+
Red_node {
383
+
cell;
384
+
binding = node.binding;
385
+
reduction;
386
+
aggregate;
387
+
left;
388
+
right;
389
+
}
390
+
| Leaf -> Red_leaf
391
+
| Root _ -> assert false
392
+
in
393
+
let result = aux tree in
394
+
assert (!bindings = []);
395
+
result
396
+
397
+
let extract_fringe version tree =
398
+
let rec aux acc = function
399
+
| Red_leaf -> acc
400
+
| Red_node rnode as tree ->
401
+
match rnode.cell with
402
+
| Node node when node.version <= version -> tree :: acc
403
+
| _ ->
404
+
let acc = aux acc rnode.right in
405
+
let acc = match rnode.binding with
406
+
| Unbound -> acc
407
+
| Bound { valid = false; _ } -> acc
408
+
| _ -> tree :: acc
409
+
in
410
+
aux acc rnode.left
411
+
in
412
+
aux [] tree
413
+
414
+
let incremental_rebuild red version tree =
415
+
let fringe = ref (extract_fringe version red.result) in
416
+
let rec aux = function
417
+
| Node node as cell when node.version <= version ->
418
+
begin match !fringe with
419
+
| (Red_node rnode as reduction) :: fringe' ->
420
+
assert (rnode.cell == cell);
421
+
fringe := fringe';
422
+
reduction
423
+
| _ -> assert false
424
+
end
425
+
| Node node as cell ->
426
+
let left = aux node.left in
427
+
let reduction =
428
+
match node.binding, !fringe with
429
+
| Unbound, _ -> fst red.monoid
430
+
| binding, (Red_node rnode :: fringe')
431
+
when binding == rnode.binding ->
432
+
fringe := fringe';
433
+
rnode.reduction
434
+
| Bound b, _ ->
435
+
assert b.valid; red.mapper cell b.value
436
+
in
437
+
let right = aux node.right in
438
+
let aggregate = match left with
439
+
| Red_leaf -> reduction
440
+
| Red_node r -> plus red.monoid r.aggregate reduction
441
+
in
442
+
let aggregate = match right with
443
+
| Red_leaf -> aggregate
444
+
| Red_node r -> plus red.monoid aggregate r.aggregate
445
+
in
446
+
Red_node {
447
+
cell;
448
+
binding = node.binding;
449
+
reduction;
450
+
aggregate;
451
+
left;
452
+
right;
453
+
}
454
+
| Root _ | Leaf -> Red_leaf
455
+
in
456
+
let result = aux tree in
457
+
assert (!fringe = []);
458
+
result
459
+
460
+
let eval red =
461
+
match red.source with
462
+
| Leaf | Node _ -> assert false
463
+
| Root root ->
464
+
let version = rebalance red.source in
465
+
if true then (
466
+
if red.generation != root.generation then (
467
+
red.generation <- root.generation;
468
+
red.result <- full_rebuild red root.child;
469
+
) else (
470
+
red.result <- incremental_rebuild red red.version root.child
471
+
);
472
+
) else (
473
+
red.result <- full_rebuild red root.child;
474
+
);
475
+
red.version <- version;
476
+
match red.result with
477
+
| Red_leaf -> fst red.monoid
478
+
| Red_node r -> r.aggregate
479
+
480
+
let opaque : 'a Lwd.prim -> Obj.t Lwd.prim = Obj.magic
481
+
482
+
let map_reduce mapper monoid source =
483
+
let reduction = {
484
+
source; mapper; monoid;
485
+
result = Red_leaf;
486
+
generation = not_origin;
487
+
version = 0;
488
+
} in
489
+
let prim = Lwd.prim
490
+
~acquire:(fun self ->
491
+
match reduction.source with
492
+
| Leaf | Node _ -> assert false
493
+
| Root root ->
494
+
root.on_invalidate <- opaque self :: root.on_invalidate;
495
+
reduction
496
+
)
497
+
~release:(fun self reduction ->
498
+
match reduction.source with
499
+
| Leaf | Node _ -> assert false
500
+
| Root root ->
501
+
root.on_invalidate <-
502
+
List.filter ((!=) (opaque self)) root.on_invalidate
503
+
)
504
+
in
505
+
Lwd.map ~f:eval (Lwd.get_prim prim)
506
+
507
+
let reduce monoid source = map_reduce (fun _ x -> x) monoid source
508
+
509
+
let rec iter f = function
510
+
| Leaf -> ()
511
+
| Node t ->
512
+
iter f t.left;
513
+
begin match t.binding with
514
+
| Bound x -> f x.value
515
+
| Unbound -> ()
516
+
end;
517
+
iter f t.right
518
+
| Root t ->
519
+
iter f t.child
520
+
521
+
let rec left_most : 'a row -> 'a row option = function
522
+
| Root _ -> assert false
523
+
| Leaf -> None
524
+
| Node n as self ->
525
+
match left_most n.left with
526
+
| Some _ as x -> x
527
+
| None -> Some self
528
+
529
+
let rec right_most : 'a row -> 'a row option = function
530
+
| Root _ -> assert false
531
+
| Leaf -> None
532
+
| Node n as self ->
533
+
match right_most n.right with
534
+
| Some _ as x -> x
535
+
| None -> Some self
536
+
537
+
let first : 'a t -> 'a row option = function
538
+
| Leaf | Node _ -> assert false
539
+
| Root root -> left_most root.child
540
+
541
+
let last : 'a t -> 'a row option = function
542
+
| Leaf | Node _ -> assert false
543
+
| Root root -> right_most root.child
544
+
545
+
let next : 'a row -> 'a row option = function
546
+
| Root _ -> assert false
547
+
| Leaf -> None
548
+
| Node n as self ->
549
+
match left_most n.right with
550
+
| Some _ as x -> x
551
+
| None ->
552
+
let rec walk_root self = function
553
+
| Leaf -> assert false
554
+
| Root _ -> None
555
+
| Node n' as parent ->
556
+
if n'.left == self then Some parent else (
557
+
assert (n'.right == self);
558
+
walk_root parent n'.parent
559
+
)
560
+
in
561
+
walk_root self n.parent
562
+
563
+
let prev : 'a row -> 'a row option = function
564
+
| Root _ -> assert false
565
+
| Leaf -> None
566
+
| Node n as self ->
567
+
match right_most n.left with
568
+
| Some _ as x -> x
569
+
| None ->
570
+
let rec walk_root self = function
571
+
| Leaf -> assert false
572
+
| Root _ -> None
573
+
| Node n' as parent ->
574
+
if n'.right == self then Some parent else (
575
+
assert (n'.left == self);
576
+
walk_root parent n'.parent
577
+
)
578
+
in
579
+
walk_root self n.parent
+102
forks/lwd/lib/lwd/lwd_table.mli
+102
forks/lwd/lib/lwd/lwd_table.mli
···
1
+
(** {1 Table manipulation}
2
+
3
+
[Lwd_table] is an ordered collection with an impure interface.
4
+
It is designed to be efficient in an interactive setting.
5
+
6
+
The interface mimics the one of a doubly-linked lists: from a node, called
7
+
row, you can iterate backward and forward, insert and delete other nodes,
8
+
and change the value it is bound to.
9
+
10
+
The sequence of nodes can be observed by map/reduce operations, that will
11
+
be recomputed efficiently when sequence changes.
12
+
*)
13
+
14
+
type 'a t
15
+
type 'a row
16
+
(** The type of tables *)
17
+
18
+
val make : unit -> 'a t
19
+
(** Create a new table *)
20
+
21
+
(** {2 Inserting rows} *)
22
+
23
+
val prepend : ?set:'a -> 'a t -> 'a row
24
+
(** Insert and return a new row at the start of a table.
25
+
It can be optionnally initialized to the value of [set]. *)
26
+
27
+
val append : ?set:'a -> 'a t -> 'a row
28
+
(** Insert and return a new row at the end of a table.
29
+
It can be optionnally initialized to the value of [set]. *)
30
+
31
+
val prepend' : 'a t -> 'a -> unit
32
+
(* Insert a new initialized row at start of a table *)
33
+
34
+
val append' : 'a t -> 'a -> unit
35
+
(* Insert a new initialized row at end of a table *)
36
+
37
+
val before : ?set:'a -> 'a row -> 'a row
38
+
(** Insert and return a new row just before an existing row.
39
+
It can be optionnally initialized to the value of [set].
40
+
41
+
If the input row is unbound ([is_bound] returns false), the returned row is
42
+
too.
43
+
*)
44
+
45
+
val after : ?set:'a -> 'a row -> 'a row
46
+
(** Insert and return a new row just after an existing row.
47
+
It can be optionnally initialized to the value of [set].
48
+
49
+
If the input row is unbound ([is_bound] returns false), the returned row is
50
+
too.
51
+
*)
52
+
53
+
(** {2 Iterating over rows} *)
54
+
55
+
val first : 'a t -> 'a row option
56
+
(** Returns the first row of a table, or [None] if the table is empty *)
57
+
58
+
val last : 'a t -> 'a row option
59
+
(** Returns the last row of a table, or [None] if the table is empty *)
60
+
61
+
val next : 'a row -> 'a row option
62
+
(** Returns the row next to another one, or [None] if the input row is unbound
63
+
or is the last row *)
64
+
65
+
val prev : 'a row -> 'a row option
66
+
(** Returns the row just before another one, or [None] if the input row is
67
+
unbound or is the first row *)
68
+
69
+
(** {2 Accessing and changing row contents} *)
70
+
71
+
val get : 'a row -> 'a option
72
+
(** Get the value associated with a row, if any, or [None] if the row is
73
+
unbound *)
74
+
75
+
val set : 'a row -> 'a -> unit
76
+
(** Set the value associated with a row, or do nothing if the row is unbound *)
77
+
78
+
val unset : 'a row -> unit
79
+
(** Unset the value associated with a row *)
80
+
81
+
(** {2 Removing rows} *)
82
+
83
+
val is_bound : 'a row -> bool
84
+
(** Returns [true] iff the row is bound in a table (it has not beem [remove]d
85
+
yet, the table has not been [clear]ed) *)
86
+
87
+
val remove : 'a row -> unit
88
+
(** [remove] a row from its table, [is_bound] will be [true] after that *)
89
+
90
+
val clear : 'a t -> unit
91
+
(** Remove all rows from a table *)
92
+
93
+
(** {2 Observing table contents} *)
94
+
95
+
val reduce : 'a Lwd_utils.monoid -> 'a t -> 'a Lwd.t
96
+
(** Observe the content of a table by reducing it with a monoid *)
97
+
98
+
val map_reduce : ('a row -> 'a -> 'b) -> 'b Lwd_utils.monoid -> 'a t -> 'b Lwd.t
99
+
(** Observe the content of a table by mapping and reducing it *)
100
+
101
+
val iter : ('a -> unit) -> 'a t -> unit
102
+
(** Immediate, non reactive, iteration over elements of a table *)
+474
forks/lwd/lib/lwd/lwd_trace_debug.ml
+474
forks/lwd/lib/lwd/lwd_trace_debug.ml
···
1
+
type 'a t =
2
+
| Pure of 'a
3
+
| Impure : {
4
+
mutable value : 'a option;
5
+
mutable trace : trace;
6
+
mutable trace_idx : trace_idx;
7
+
desc: 'a desc;
8
+
} -> 'a t
9
+
| Root : {
10
+
mutable on_invalidate : 'a -> unit;
11
+
mutable value : 'a option;
12
+
child : 'a t;
13
+
mutable trace_idx : trace_idx;
14
+
} -> 'a t
15
+
16
+
and _ desc =
17
+
| Map : 'a t * ('a -> 'b) -> 'b desc
18
+
| Map2 : 'a t * 'b t * ('a -> 'b -> 'c) -> 'c desc
19
+
| Pair : 'a t * 'b t -> ('a * 'b) desc
20
+
| App : ('a -> 'b) t * 'a t -> 'b desc
21
+
| Bind : { child : 'a t; map : 'a -> 'b t;
22
+
mutable intermediate : 'b t option } -> 'b desc
23
+
| Var : { mutable binding : 'a } -> 'a desc
24
+
| Prim : { acquire : unit -> 'a;
25
+
release : 'a -> unit;
26
+
mutable acquired : 'a option } -> 'a desc
27
+
28
+
and trace =
29
+
| T0
30
+
(*| T1 : _ t -> trace
31
+
| T2 : _ t * _ t -> trace
32
+
| T3 : _ t * _ t * _ t -> trace
33
+
| T4 : _ t * _ t * _ t * _ t -> trace*)
34
+
| Tn : { mutable active : int; mutable count : int;
35
+
mutable entries : Obj.t t array } -> trace
36
+
37
+
and trace_idx =
38
+
| I0
39
+
| I1 : { mutable idx : int ;
40
+
obj : 'a t;
41
+
mutable next : trace_idx } -> trace_idx
42
+
43
+
(* Basic combinators *)
44
+
let return x = Pure x
45
+
let pure x = Pure x
46
+
47
+
let dummy = Pure (Obj.repr ())
48
+
49
+
let impure desc =
50
+
Impure { value = None; trace = T0; desc; trace_idx = I0 }
51
+
52
+
let map f x = impure (Map (x, f))
53
+
let map2 f x y = impure (Map2 (x, y, f))
54
+
let map' x f = impure (Map (x, f))
55
+
let map2' x y f = impure (Map2 (x, y, f))
56
+
let pair x y = impure (Pair (x, y))
57
+
let app f x = impure (App (f, x))
58
+
let bind child map = impure (Bind { child; map; intermediate = None })
59
+
let id x = x
60
+
let join child = impure (Bind { child; map = id; intermediate = None })
61
+
62
+
(* Management of trace indexes *)
63
+
64
+
external t_equal : _ t -> _ t -> bool = "%eq"
65
+
external obj_t : 'a t -> Obj.t t = "%identity"
66
+
67
+
let debug_trace_idx (type a) (self : a t) idx =
68
+
let rec gather = function
69
+
| I0 -> []
70
+
| I1 {obj = obj1; next = I1 {obj = obj2; _}; _}
71
+
when t_equal obj1 obj2 && (
72
+
let self = match self with
73
+
| Pure _ | Root _ -> assert false
74
+
| Impure t ->
75
+
match t.desc with
76
+
| Map (t1, _) ->
77
+
Printf.sprintf "Map (%x, _)" (Obj.magic t1)
78
+
| Map2 (t1, t2, _) ->
79
+
Printf.sprintf "Map2 (%x, %x, _)" (Obj.magic t1) (Obj.magic t2)
80
+
| Pair (t1, t2) ->
81
+
Printf.sprintf "Pair (%x, %x)" (Obj.magic t1) (Obj.magic t2)
82
+
| App (t1, t2) ->
83
+
Printf.sprintf "App (%x, %x)" (Obj.magic t1) (Obj.magic t2)
84
+
| Bind {child; intermediate = None; _} ->
85
+
Printf.sprintf "Bind (%x)" (Obj.magic child)
86
+
| Bind {child; intermediate = Some i; _} ->
87
+
Printf.sprintf "Bind (%x, %x)" (Obj.magic child) (Obj.magic i)
88
+
| Var _ -> "Var _"
89
+
| Prim _ -> "Prim _"
90
+
in
91
+
Printf.eprintf "%x: %s\n" (Obj.magic obj1) self;
92
+
false
93
+
) -> assert false
94
+
| I1 t ->
95
+
begin match t.obj with
96
+
| Impure {trace = Tn {active; count; entries}; _} ->
97
+
if not (t.idx < count) then (
98
+
prerr_endline
99
+
(Printexc.raw_backtrace_to_string (Printexc.get_callstack 10));
100
+
assert false
101
+
);
102
+
assert (entries.(t.idx) == obj_t self);
103
+
if t.idx > active then (
104
+
match self with
105
+
| Root { value = None; _ } | Impure { value = None; _} -> ()
106
+
| _ -> assert false
107
+
)
108
+
| Impure {trace = T0; _} -> () (* invariant temporary broken, can't do much *)
109
+
| _ ->
110
+
prerr_endline
111
+
(Printexc.raw_backtrace_to_string (Printexc.get_callstack 10));
112
+
assert false
113
+
end;
114
+
Printf.sprintf "%x@%d" (Obj.magic t.obj) t.idx :: gather t.next
115
+
in
116
+
Printf.eprintf "idx : [%s]\n" (String.concat "; " (gather idx));
117
+
idx
118
+
119
+
let debug_trace = function
120
+
| T0 -> Printf.eprintf "empty trace"
121
+
| Tn tn ->
122
+
Printf.eprintf "trace: {active = %d; count = %d; capacity = %d}\n"
123
+
tn.active tn.count (Array.length tn.entries)
124
+
125
+
let add_idx obj idx = function
126
+
| Pure _ -> assert false
127
+
| Root t' as self->
128
+
t'.trace_idx <- debug_trace_idx self (I1 { idx; obj; next = t'.trace_idx })
129
+
| Impure t' as self->
130
+
t'.trace_idx <- debug_trace_idx self (I1 { idx; obj; next = t'.trace_idx })
131
+
132
+
let rec rem_idx obj = function
133
+
| I0 -> assert false
134
+
| I1 t as self ->
135
+
if t_equal t.obj obj
136
+
then (t.idx, t.next)
137
+
else
138
+
let idx, result = rem_idx obj t.next in
139
+
t.next <- result;
140
+
(idx, self)
141
+
142
+
let rem_idx obj = function
143
+
| Pure _ -> assert false
144
+
| Root t' as self ->
145
+
let idx, trace_idx = rem_idx obj t'.trace_idx in
146
+
t'.trace_idx <- debug_trace_idx self trace_idx; idx
147
+
| Impure t' as self ->
148
+
let idx, trace_idx = rem_idx obj t'.trace_idx in
149
+
t'.trace_idx <- debug_trace_idx self trace_idx; idx
150
+
151
+
let rec mov_idx obj oldidx newidx = function
152
+
| I0 -> assert false
153
+
| I1 t ->
154
+
if t.idx = oldidx && t_equal t.obj obj
155
+
then t.idx <- newidx
156
+
else mov_idx obj oldidx newidx t.next
157
+
158
+
let mov_idx obj oldidx newidx = function
159
+
| Pure _ -> assert false
160
+
| Root t' -> mov_idx obj oldidx newidx t'.trace_idx
161
+
| Impure t' -> mov_idx obj oldidx newidx t'.trace_idx
162
+
163
+
let rec get_idx obj = function
164
+
| I0 -> assert false
165
+
| I1 t ->
166
+
if t_equal t.obj obj
167
+
then t.idx
168
+
else get_idx obj t.next
169
+
170
+
let get_idx obj = function
171
+
| Pure _ -> assert false
172
+
| Root t' as self -> get_idx obj (debug_trace_idx self t'.trace_idx)
173
+
| Impure t' as self -> get_idx obj (debug_trace_idx self t'.trace_idx)
174
+
175
+
(* Propagating invalidation *)
176
+
let rec invalidate_node : type a . a t -> unit = function
177
+
| Pure _ -> assert false
178
+
| Root { value = None; _ } -> ()
179
+
| Root ({ value = Some x; _ } as t) ->
180
+
t.value <- None;
181
+
t.on_invalidate x
182
+
| Impure t ->
183
+
begin match t.value with
184
+
| None -> ()
185
+
| Some _ ->
186
+
t.value <- None;
187
+
debug_trace t.trace;
188
+
invalidate_trace t.trace
189
+
end
190
+
191
+
and invalidate_trace = function
192
+
| T0 -> ()
193
+
(*| T1 x -> invalidate_node x
194
+
| T2 (x, y) ->
195
+
invalidate_node x;
196
+
invalidate_node y
197
+
| T3 (x, y, z) ->
198
+
invalidate_node x;
199
+
invalidate_node y;
200
+
invalidate_node z
201
+
| T4 (x, y, z, w) ->
202
+
invalidate_node x;
203
+
invalidate_node y;
204
+
invalidate_node z;
205
+
invalidate_node w*)
206
+
| Tn t ->
207
+
let active = t.active in
208
+
t.active <- 0;
209
+
for i = 0 to active - 1 do
210
+
invalidate_node t.entries.(i)
211
+
done
212
+
213
+
(* Variables *)
214
+
type 'a var = 'a t
215
+
let var x = impure (Var {binding = x})
216
+
let get x = x
217
+
218
+
let set vx x =
219
+
match vx with
220
+
| Impure ({desc = Var v; _}) ->
221
+
invalidate_node vx;
222
+
v.binding <- x
223
+
| _ -> assert false
224
+
225
+
let peek = function
226
+
| Impure ({desc = Var v; _}) -> v.binding
227
+
| _ -> assert false
228
+
229
+
(* Primitives *)
230
+
type 'a prim = 'a t
231
+
let prim ~acquire ~release =
232
+
impure (Prim { acquire; release; acquired = None })
233
+
let get_prim x = x
234
+
let invalidate = invalidate_node
235
+
236
+
let rec sub_release : type a b . a t -> b t -> unit = fun origin ->
237
+
function
238
+
| Root _ -> assert false
239
+
| Pure _ -> ()
240
+
| Impure t as self ->
241
+
let trace = match t.trace with
242
+
| T0 -> assert false
243
+
(*| T1 x -> assert (t_equal x origin); T0
244
+
| T2 (x, y) ->
245
+
if t_equal x origin then T1 y
246
+
else if t_equal y origin then T1 x
247
+
else assert false
248
+
| T3 (x, y, z) ->
249
+
if t_equal x origin then T2 (y, z)
250
+
else if t_equal y origin then T2 (x, z)
251
+
else if t_equal z origin then T2 (x, y)
252
+
else assert false
253
+
| T4 (x, y, z, w) ->
254
+
if t_equal x origin then T3 (y, z, w)
255
+
else if t_equal y origin then T3 (x, z, w)
256
+
else if t_equal z origin then T3 (x, y, w)
257
+
else assert false*)
258
+
| Tn tn as trace ->
259
+
let revidx = rem_idx self origin in
260
+
assert (t_equal tn.entries.(revidx) origin);
261
+
let count = tn.count - 1 in
262
+
tn.count <- count;
263
+
if revidx < count then (
264
+
let obj = tn.entries.(count) in
265
+
tn.entries.(revidx) <- obj;
266
+
mov_idx self count revidx obj
267
+
);
268
+
tn.entries.(count) <- dummy;
269
+
if tn.active > count then tn.active <- count;
270
+
(*if count = 4 then (
271
+
let a = tn.entries.(0) and b = tn.entries.(1) in
272
+
let c = tn.entries.(2) and d = tn.entries.(3) in
273
+
ignore (rem_idx self a : int);
274
+
ignore (rem_idx self b : int);
275
+
ignore (rem_idx self c : int);
276
+
ignore (rem_idx self d : int);
277
+
T4 (a, b, c, d)*)
278
+
if count = 0 then (
279
+
T0
280
+
) else
281
+
let len = Array.length tn.entries in
282
+
if count <= len lsr 2 then
283
+
Tn { active = tn.active; count = tn.count;
284
+
entries = Array.sub tn.entries 0 (len lsr 1) }
285
+
else
286
+
trace
287
+
in
288
+
t.trace <- trace;
289
+
match trace with
290
+
| T0 ->
291
+
t.value <- None;
292
+
begin match t.desc with
293
+
| Map (x, _) -> sub_release self x
294
+
| Map2 (x, y, _) ->
295
+
sub_release self x;
296
+
sub_release self y
297
+
| Pair (x, y) ->
298
+
sub_release self x;
299
+
sub_release self y
300
+
| App (x, y) ->
301
+
sub_release self x;
302
+
sub_release self y
303
+
| Bind ({ child; intermediate; map = _ } as t) ->
304
+
sub_release self child;
305
+
begin match intermediate with
306
+
| None -> ()
307
+
| Some child' ->
308
+
t.intermediate <- None;
309
+
sub_release self child'
310
+
end
311
+
| Var _ -> ()
312
+
| Prim t ->
313
+
let x = match t.acquired with None -> assert false | Some x -> x in
314
+
t.acquired <- None;
315
+
t.release x
316
+
end
317
+
| _ -> ()
318
+
319
+
let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
320
+
function
321
+
| Root _ -> assert false
322
+
| Pure _ -> ()
323
+
| Impure t as self ->
324
+
let acquire = match t.trace with T0 -> true | _ -> false in
325
+
let trace = match t.trace with
326
+
(*| T0 -> T1 origin
327
+
| T1 x -> T2 (origin, x)
328
+
| T2 (x, y) -> T3 (origin, x, y)
329
+
| T3 (x, y, z) -> T4 (origin, x, y, z)
330
+
| T4 (x, y, z, w) ->
331
+
let obj = obj_t origin in
332
+
let entries =
333
+
[| obj_t x; obj_t y; obj_t z; obj_t w; obj; dummy; dummy; dummy |]
334
+
in
335
+
for i = 0 to 4 do add_idx self i entries.(i) done;
336
+
Tn { active = 5; count = 5; entries }*)
337
+
| T0 ->
338
+
let obj = obj_t origin in
339
+
let entries = [| obj; dummy; dummy; dummy |] in
340
+
add_idx self 0 obj;
341
+
Tn { active = 1; count = 1; entries }
342
+
| Tn tn as trace ->
343
+
let index = tn.count in
344
+
let entries, trace =
345
+
if index < Array.length tn.entries then (
346
+
tn.count <- tn.count + 1;
347
+
(tn.entries, trace)
348
+
) else (
349
+
let entries = Array.make (index * 2) dummy in
350
+
Array.blit tn.entries 0 entries 0 index;
351
+
(entries, Tn { active = tn.active; count = index + 1; entries })
352
+
)
353
+
in
354
+
let obj = obj_t origin in
355
+
entries.(index) <- obj;
356
+
add_idx self index obj;
357
+
trace
358
+
in
359
+
t.trace <- trace;
360
+
if acquire then
361
+
match t.desc with
362
+
| Map (x, _) -> sub_acquire self x
363
+
| Map2 (x, y, _) ->
364
+
sub_acquire self x;
365
+
sub_acquire self y
366
+
| Pair (x, y) ->
367
+
sub_acquire self x;
368
+
sub_acquire self y
369
+
| App (x, y) ->
370
+
sub_acquire self x;
371
+
sub_acquire self y
372
+
| Bind { child; intermediate; map = _ } ->
373
+
sub_acquire self child;
374
+
begin match intermediate with
375
+
| None -> ()
376
+
| Some _ -> assert false
377
+
end
378
+
| Var _ -> ()
379
+
| Prim t ->
380
+
begin match t.acquired with
381
+
| None -> t.acquired <- Some (t.acquire ())
382
+
| Some _ -> ()
383
+
end
384
+
385
+
let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
386
+
function
387
+
| Root _ -> assert false
388
+
| Pure x -> x
389
+
| Impure t as self ->
390
+
begin match t.trace with
391
+
| Tn tn ->
392
+
let idx = get_idx self origin in
393
+
let active = tn.active in
394
+
if idx >= active then
395
+
tn.active <- active + 1;
396
+
if idx > active then (
397
+
let old = tn.entries.(active) in
398
+
tn.entries.(idx) <- old;
399
+
tn.entries.(active) <- obj_t origin;
400
+
mov_idx self active idx old;
401
+
mov_idx self idx active origin
402
+
)
403
+
| _ -> ()
404
+
end;
405
+
match t.value with
406
+
| Some value -> value
407
+
| None ->
408
+
let value : b = match t.desc with
409
+
| Map (x, f) -> f (sub_sample self x)
410
+
| Map2 (x, y, f) -> f (sub_sample self x) (sub_sample self y)
411
+
| Pair (x, y) -> (sub_sample self x, sub_sample self y)
412
+
| App (f, x) -> (sub_sample self f) (sub_sample self x)
413
+
| Bind x ->
414
+
let old_intermediate = x.intermediate in
415
+
let intermediate = x.map (sub_sample self x.child) in
416
+
x.intermediate <- Some intermediate;
417
+
sub_acquire self intermediate;
418
+
let result = sub_sample self intermediate in
419
+
begin match old_intermediate with
420
+
| Some x' -> sub_release self x'
421
+
| None -> ()
422
+
end;
423
+
result
424
+
| Var x -> x.binding
425
+
| Prim t ->
426
+
begin match t.acquired with
427
+
| Some x -> x
428
+
| None -> assert false
429
+
end
430
+
in
431
+
t.value <- Some value;
432
+
value
433
+
434
+
type 'a root = 'a t
435
+
436
+
let observe ?(on_invalidate=ignore) child =
437
+
let root = Root { child; value = None; on_invalidate; trace_idx = I0 } in
438
+
sub_acquire root child;
439
+
root
440
+
441
+
let sample = function
442
+
| Pure _ | Impure _ -> assert false
443
+
| Root t as self ->
444
+
match t.value with
445
+
| Some value -> value
446
+
| None ->
447
+
let value = sub_sample self t.child in
448
+
t.value <- Some value;
449
+
value
450
+
451
+
let is_damaged = function
452
+
| Pure _ | Impure _ -> assert false
453
+
| Root { value = None ; _ } -> true
454
+
| Root { value = Some _ ; _ } -> false
455
+
456
+
let release = function
457
+
| Pure _ | Impure _ -> assert false
458
+
| Root t as self ->
459
+
begin match t.value with
460
+
| None -> ()
461
+
| Some _ -> t.value <- None;
462
+
end;
463
+
sub_release self t.child
464
+
465
+
let set_on_invalidate x f =
466
+
match x with
467
+
| Pure _ | Impure _ -> assert false
468
+
| Root t -> t.on_invalidate <- f
469
+
470
+
module Infix = struct
471
+
let (let$) = bind
472
+
let (and$) = pair
473
+
let ($=) = set
474
+
end
+76
forks/lwd/lib/lwd/lwd_utils.ml
+76
forks/lwd/lib/lwd/lwd_utils.ml
···
1
+
2
+
type 'a monoid = 'a * ('a -> 'a -> 'a)
3
+
4
+
let lift_monoid (zero, plus) =
5
+
(Lwd.return zero, Lwd.map2 ~f:plus)
6
+
7
+
let map_reduce inj (zero, plus) items =
8
+
let rec cons_monoid c xs v =
9
+
match xs with
10
+
| (c', v') :: xs when c = c' ->
11
+
cons_monoid (c + 1) xs (plus v' v)
12
+
| xs -> (c, v) :: xs
13
+
in
14
+
let cons_monoid xs v = cons_monoid 0 xs (inj v) in
15
+
match List.fold_left cons_monoid [] items with
16
+
| [] -> zero
17
+
| (_,x) :: xs ->
18
+
List.fold_left (fun acc (_, v) -> plus v acc) x xs
19
+
20
+
let reduce monoid items = map_reduce (fun x -> x) monoid items
21
+
22
+
let rec cons_lwd_monoid plus c xs v =
23
+
match xs with
24
+
| (c', v') :: xs when c = c' ->
25
+
cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v)
26
+
| xs -> (c, v) :: xs
27
+
28
+
let pack (zero, plus) items =
29
+
match List.fold_left (cons_lwd_monoid plus 0) [] items with
30
+
| [] -> Lwd.return zero
31
+
| (_,x) :: xs ->
32
+
List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs
33
+
34
+
let pack_seq (zero, plus) items =
35
+
match Seq.fold_left (cons_lwd_monoid plus 0) [] items with
36
+
| [] -> Lwd.return zero
37
+
| (_,x) :: xs ->
38
+
List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs
39
+
40
+
let rec map_l (f:'a -> 'b Lwd.t) (l:'a list) : 'b list Lwd.t =
41
+
match l with
42
+
| [] -> Lwd.return []
43
+
| x :: tl -> Lwd.map2 ~f:List.cons (f x) (map_l f tl)
44
+
45
+
let flatten_l (l:'a Lwd.t list) : 'a list Lwd.t =
46
+
map_l (fun x->x) l
47
+
48
+
(** {1 Miscellaneous functions}
49
+
50
+
I don't know where to put these, but they are useful, especially for
51
+
UI-related computations.
52
+
*)
53
+
54
+
let mini a b : int = if b < a then b else a
55
+
56
+
let maxi a b : int = if b > a then b else a
57
+
58
+
let clampi x ~min ~max : int =
59
+
if x < min then
60
+
min
61
+
else if x > max then
62
+
max
63
+
else
64
+
x
65
+
66
+
let minf a b : float = if b < a then b else a
67
+
68
+
let maxf a b : float = if b > a then b else a
69
+
70
+
let clampf x ~min ~max : float =
71
+
if x < min then
72
+
min
73
+
else if x > max then
74
+
max
75
+
else
76
+
x
+62
forks/lwd/lib/lwd/lwd_utils.mli
+62
forks/lwd/lib/lwd/lwd_utils.mli
···
1
+
type 'a monoid = 'a * ('a -> 'a -> 'a)
2
+
(** A monoid, defined by a default element and an associative operation *)
3
+
4
+
val lift_monoid : 'a monoid -> 'a Lwd.t monoid
5
+
(** Use a monoid inside [Lwd] *)
6
+
7
+
(** {1 List reduction functions}
8
+
9
+
All reductions are balanced, relying on operator associativity.
10
+
11
+
[fold_left] would compute a chain like:
12
+
[fold f [a; b; c; d] = f a (f b (f c d)]
13
+
14
+
[reduce] uses tree-shaped computations like:
15
+
[reduce f [a; b; c; d] = f (f a b) (f c d)]
16
+
17
+
The depth of the computation grows in O(log n) where n is the length of the
18
+
input sequence.
19
+
*)
20
+
21
+
val pack : 'a monoid -> 'a Lwd.t list -> 'a Lwd.t
22
+
(** Reduce a list of elements in [Lwd] monad *)
23
+
24
+
val pack_seq : 'a monoid -> 'a Lwd.t Seq.t -> 'a Lwd.t
25
+
(** Reduce an (OCaml) [Seq.t] with a monoid *)
26
+
27
+
val reduce : 'a monoid -> 'a list -> 'a
28
+
(** Reduce a list with a monoid **)
29
+
30
+
val map_reduce : ('a -> 'b) -> 'b monoid -> 'a list -> 'b
31
+
(** Map and reduce a list with a monoid **)
32
+
33
+
(** {1 Other Lwd list functions} *)
34
+
35
+
val map_l : ('a -> 'b Lwd.t) -> 'a list -> 'b list Lwd.t
36
+
37
+
val flatten_l : 'a Lwd.t list -> 'a list Lwd.t
38
+
(** Commute [Lwd] and [list] *)
39
+
40
+
(** {1 Miscellaneous functions}
41
+
42
+
I don't know where to put these, but they are useful, especially for
43
+
UI-related computations.
44
+
*)
45
+
46
+
val mini : int -> int -> int
47
+
(** Minimum of two integers *)
48
+
49
+
val maxi : int -> int -> int
50
+
(** Maximum of two integers *)
51
+
52
+
val clampi : int -> min:int -> max:int -> int
53
+
(** Clamp an integer between two bounds. *)
54
+
55
+
val minf : float -> float -> float
56
+
(** Minimum of two floats *)
57
+
58
+
val maxf : float -> float -> float
59
+
(** Maximum of two floats *)
60
+
61
+
val clampf : float -> min:float -> max:float -> float
62
+
(** Clamp a float between two bounds. *)
+39
forks/lwd/lib/lwd/mutex_backend.ml
+39
forks/lwd/lib/lwd/mutex_backend.ml
···
1
+
(** Backend selection for mutex implementations. *)
2
+
3
+
module type MUTEX = sig
4
+
include module type of Mutex
5
+
val lock_all : t list -> bool
6
+
end
7
+
8
+
module Stdlib : MUTEX = struct
9
+
include Mutex
10
+
11
+
let lock_all mutexes =
12
+
let rec try_lock_all acc = function
13
+
| [] ->
14
+
(* All mutexes acquired successfully *)
15
+
true
16
+
| mutex :: rest ->
17
+
if try_lock mutex then
18
+
try_lock_all (mutex :: acc) rest
19
+
else begin
20
+
(* Failed to acquire current mutex, release all previously acquired ones *)
21
+
List.iter unlock acc;
22
+
false
23
+
end
24
+
in
25
+
try_lock_all [] mutexes
26
+
end
27
+
28
+
(* Picos implementation - only available if picos is linked *)
29
+
module Picos : MUTEX = struct
30
+
(* This is a placeholder implementation that will be replaced
31
+
when picos is available. For now, it falls back to stdlib. *)
32
+
include Stdlib
33
+
end
34
+
35
+
(* Default backend - can be changed at compile time *)
36
+
module Default = Stdlib
37
+
38
+
(* Functor to create a mutex module from any backend *)
39
+
module Make (Backend : MUTEX) = Backend
+19
forks/lwd/lib/lwd/mutex_stdlib.ml
+19
forks/lwd/lib/lwd/mutex_stdlib.ml
···
1
+
(** OCaml standard library implementation of the mutex interface. *)
2
+
3
+
include Mutex
4
+
5
+
let lock_all mutexes =
6
+
let rec try_lock_all acc = function
7
+
| [] ->
8
+
(* All mutexes acquired successfully *)
9
+
true
10
+
| mutex :: rest ->
11
+
if try_lock mutex then
12
+
try_lock_all (mutex :: acc) rest
13
+
else begin
14
+
(* Failed to acquire current mutex, release all previously acquired ones *)
15
+
List.iter unlock acc;
16
+
false
17
+
end
18
+
in
19
+
try_lock_all [] mutexes
+36
forks/lwd/lib/lwd/pp.ml
+36
forks/lwd/lib/lwd/pp.ml
···
1
+
let version =
2
+
Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> (major, minor))
3
+
4
+
let ic =
5
+
if Array.length Sys.argv = 1 then (
6
+
Printf.eprintf
7
+
"Usage: %s <input-file>\n\
8
+
Expecting a filename as argument.\n"
9
+
Sys.argv.(0);
10
+
exit 1
11
+
) else if not (Sys.file_exists Sys.argv.(1)) then (
12
+
Printf.eprintf
13
+
"Usage: %s <input-file>\n\
14
+
Cannot find file %S.\n"
15
+
Sys.argv.(0)
16
+
Sys.argv.(1);
17
+
exit 1
18
+
) else
19
+
open_in_bin Sys.argv.(1)
20
+
21
+
let () =
22
+
let enable_output = ref true in
23
+
let change_output v =
24
+
print_newline ();
25
+
enable_output := v
26
+
in
27
+
try
28
+
while true do
29
+
match input_line ic with
30
+
| "(*BEGIN LETOP*)" -> change_output (version >= (4, 08))
31
+
| "(*BEGIN INJECTIVITY*)" -> change_output (version >= (4, 12))
32
+
| "(*ELSE*)" -> change_output (not !enable_output)
33
+
| "(*END*)" -> change_output true
34
+
| line -> if !enable_output then print_endline line
35
+
done
36
+
with End_of_file -> ()
+18
forks/lwd/lib/lwd/select_version.ml
+18
forks/lwd/lib/lwd/select_version.ml
···
1
+
let () =
2
+
let version =
3
+
Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> (major, minor))
4
+
in
5
+
let basename =
6
+
if version < (4, 08) then "lwd_infix_compat" else "lwd_infix_letop"
7
+
in
8
+
let file =
9
+
match Sys.argv.(1) with
10
+
| "intf" -> basename ^ ".mli"
11
+
| "impl" -> basename ^ ".ml"
12
+
| _ -> assert false
13
+
in
14
+
let ic = open_in_bin file in
15
+
let length = in_channel_length ic in
16
+
let content = really_input_string ic length in
17
+
close_in ic;
18
+
print_string content
+30
forks/lwd/lib/lwd_picos/dune
+30
forks/lwd/lib/lwd_picos/dune
···
1
+
; (library
2
+
; (name lwd)
3
+
; (public_name lwd)
4
+
; (modules lwd lwd_seq lwd_table lwd_infix lwd_utils mutex_config)
5
+
; (modules_without_implementation mutex)
6
+
; (libraries seq)
7
+
; (inline_tests
8
+
; (backend qtest.lib)
9
+
; (executable
10
+
; (flags
11
+
; (-w -33))))
12
+
; (wrapped false)
13
+
; (preprocess
14
+
; (per_module
15
+
; ((action
16
+
; (run %{dep:pp.exe} %{input-file}))
17
+
; lwd_infix
18
+
; lwd_seq))))
19
+
20
+
;; Optional Picos backend - only compiled if picos is available
21
+
(library
22
+
(name lwd_picos)
23
+
(modules lwd mutex_picos)
24
+
(libraries picos picos_stdlwd)
25
+
(optional)
26
+
(wrapped false))
27
+
28
+
; (executable
29
+
; (name pp)
30
+
; (modules pp))
+1
forks/lwd/lib/lwd_picos/lwd.ml
+1
forks/lwd/lib/lwd_picos/lwd.ml
···
1
+
include Lwd_impl.Make(Mutex_picos.Default)
+1
forks/lwd/lib/lwd_picos/lwd.mli
+1
forks/lwd/lib/lwd_picos/lwd.mli
···
1
+
include module type of Lwd.Lwd
+92
forks/lwd/lib/lwd_picos/mutex_picos.ml
+92
forks/lwd/lib/lwd_picos/mutex_picos.ml
···
1
+
2
+
(** Picos implementation of the mutex interface. *)
3
+
4
+
(* Note: This implementation requires the picos library to be available.
5
+
You may need to add picos as a dependency in your dune-project file. *)
6
+
7
+
(* We'll use Picos's synchronization primitives to implement mutexes.
8
+
Since Picos doesn't have a direct mutex equivalent, we'll implement
9
+
one using Picos's basic synchronization primitives. *)
10
+
11
+
type t = {
12
+
mutable locked : bool;
13
+
mutable owner : Picos.Fiber.t option;
14
+
waiters : Picos.Trigger.t list ref;
15
+
}
16
+
17
+
let create () = {
18
+
locked = false;
19
+
owner = None;
20
+
waiters = ref [];
21
+
}
22
+
23
+
let lock mutex =
24
+
let rec try_acquire () =
25
+
if not mutex.locked then begin
26
+
mutex.locked <- true;
27
+
mutex.owner <- Some (Picos.Fiber.current ());
28
+
end else begin
29
+
(* Create a trigger to wait for the mutex to be released *)
30
+
let trigger = Picos.Trigger.create () in
31
+
mutex.waiters := trigger :: !(mutex.waiters);
32
+
match Picos.await trigger with
33
+
| None -> (* Cancelled *) raise (Sys_error "Mutex lock cancelled")
34
+
| Some (exn, _) -> raise exn
35
+
end
36
+
in
37
+
try_acquire ()
38
+
39
+
let try_lock mutex =
40
+
if not mutex.locked then begin
41
+
mutex.locked <- true;
42
+
mutex.owner <- Some (Picos.Fiber.current ());
43
+
true
44
+
end else
45
+
false
46
+
47
+
let unlock mutex =
48
+
if not mutex.locked then
49
+
raise (Sys_error "Mutex is not locked")
50
+
else
51
+
let current_fiber = Picos.Fiber.current () in
52
+
match mutex.owner with
53
+
| None -> raise (Sys_error "Mutex has no owner")
54
+
| Some owner ->
55
+
if not (Picos.Fiber.equal current_fiber owner) then
56
+
raise (Sys_error "Mutex was locked by another fiber")
57
+
else begin
58
+
mutex.locked <- false;
59
+
mutex.owner <- None;
60
+
(* Wake up one waiter if any *)
61
+
match !(mutex.waiters) with
62
+
| [] -> ()
63
+
| trigger :: rest ->
64
+
mutex.waiters := rest;
65
+
Picos.Trigger.signal trigger ()
66
+
end
67
+
68
+
let protect mutex f =
69
+
lock mutex;
70
+
try
71
+
let result = f () in
72
+
unlock mutex;
73
+
result
74
+
with exn ->
75
+
unlock mutex;
76
+
raise exn
77
+
78
+
let lock_all mutexes =
79
+
let rec try_lock_all acc = function
80
+
| [] ->
81
+
(* All mutexes acquired successfully *)
82
+
true
83
+
| mutex :: rest ->
84
+
if try_lock mutex then
85
+
try_lock_all (mutex :: acc) rest
86
+
else begin
87
+
(* Failed to acquire current mutex, release all previously acquired ones *)
88
+
List.iter unlock acc;
89
+
false
90
+
end
91
+
in
92
+
try_lock_all [] mutexes
+1
forks/lwd/lib/lwd_picos/mutex_picos.mli
+1
forks/lwd/lib/lwd_picos/mutex_picos.mli
···
1
+
include Lwd.Mute
+32
forks/lwd/lwd.opam
+32
forks/lwd/lwd.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Lightweight reactive documents"
4
+
maintainer: ["fred@tarides.com"]
5
+
authors: ["Frédéric Bour"]
6
+
license: "MIT"
7
+
homepage: "https://github.com/let-def/lwd"
8
+
doc: "https://let-def.github.io/lwd/doc"
9
+
bug-reports: "https://github.com/let-def/lwd/issues"
10
+
depends: [
11
+
"dune" {>= "3.5"}
12
+
"seq"
13
+
"ocaml" {>= "5.2"}
14
+
"qtest" {with-test}
15
+
"qcheck" {with-test}
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
32
+
dev-repo: "git+https://github.com/let-def/lwd.git"
+30
forks/lwd/lwd_picos.opam
+30
forks/lwd/lwd_picos.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Lightweight reactive documents with Picos backend"
4
+
maintainer: ["fred@tarides.com"]
5
+
authors: ["Frédéric Bour"]
6
+
license: "MIT"
7
+
homepage: "https://github.com/let-def/lwd"
8
+
bug-reports: "https://github.com/let-def/lwd/issues"
9
+
depends: [
10
+
"dune" {>= "3.5"}
11
+
"lwd"
12
+
"picos" {>= "0.6.0"}
13
+
"picos_std" {>= "0.6.0"}
14
+
"odoc" {with-doc}
15
+
]
16
+
build: [
17
+
["dune" "subst"] {dev}
18
+
[
19
+
"dune"
20
+
"build"
21
+
"-p"
22
+
name
23
+
"-j"
24
+
jobs
25
+
"@install"
26
+
"@runtest" {with-test}
27
+
"@doc" {with-doc}
28
+
]
29
+
]
30
+
dev-repo: "git+https://github.com/let-def/lwd.git"
+75
forks/lwd/making multithreaded.md
+75
forks/lwd/making multithreaded.md
···
1
+
Plans to make it multithreaded
2
+
3
+
4
+
My initial approach was to schedule the chagnes to the lwd varaiables untill a root has finished evaluating. However, this doesn't work if you have two roots that can be evaulated in paralell.
5
+
6
+
I could:
7
+
1. Pervent roots from being evaluated in paralell
8
+
2. Could i just prevent any nodes being evaluated in paralell.
9
+
Imagine two roots share a node and are being evaluated in paralell
10
+
```mermaid
11
+
A1[root]--> B1[shared]
12
+
A1-->B2
13
+
A2-->B1
14
+
A2-->B3
15
+
B1--> C1[lwd var]
16
+
```
17
+
If, while setting the lwd.var we can either lock the node, or lock the root that is holding the node we can safely update $
18
+
19
+
if we just locked the node, currently the root could be evaluating a parent node while we lock it... but does that matter?
20
+
no.. not really.... if the root holds all locked nodes locked untill the evaluation is finished we are actually safe to set a varaible and it'll still ensure consitency
21
+
22
+
23
+
So, by that logic:
24
+
A root should lock and hold locked all nodes it touches while evaluating, this ensures that it will experience consitency.
25
+
Infact, we don't need to hold all nodes locked, we could just lock all leaf nodes that still have a path to the parent node,
26
+
but we could unlock any node that has been fully calculated that isn't a leaf, sometimes a leaf could connect to two different mid nodes so we can't neciserily unlock them
27
+
28
+
if we can lock a node while setting an lwd var we are safe to do set it, otherwise we have to wait until it's finished evaluating.
29
+
in a concurrent enviroment this is okay, because we can just wait for the unlock in the background.
30
+
In a non concurrent environment, I think we could locate the root node that locked it, and then add the setting operation to a "post eval" list.
31
+
We would have to decide if it should set and then eval while holding the lock and further delay another root evaluation, or let the other root evaluate, or set it, let the root evaluate and then revaluate ourself.
32
+
33
+
34
+
If two graphs are evaluating at the same time and one encounters a locked node from another, the second should move on if possible and then just wait
35
+
36
+
37
+
Could i just used the cached value if a node is locked. no, because it could be recomputing
38
+
39
+
## How to handle invalidation during re-evaluation:
40
+
I guess I could actually just cancel and reschedule rendering, but that could block rendering forever if rendering takes a long time. and a new event comes in
41
+
42
+
Or I could walk upwards towards each root, locking as i go. however, if there is an evaluation occuring, they will not be able to keep evaluating.
43
+
44
+
I could introduce a rule that says, if a node is locked because of invalidation, the node should use the cached value.
45
+
We can be very sure the node will eventually get recomputed, but the invalidation would have to be in it's own process and constantly trying to work its way up the node graph.
46
+
47
+
48
+
I don't like the idea of
49
+
50
+
In a concurrent environment i could just drop the recomputation into it's own process and move on, in a single threaded environment the simplest way would be to schedule the update and locking on the root node that currently holds the lock.
51
+
52
+
53
+
54
+
55
+
- what if we split up invalidation into two parts? currently invalid and next invalid we just set next invalid on all the items without doing any locking. Then when the currently invalidating root node is done, it sets currently invalid to true as it unlocks the node.
56
+
57
+
58
+
59
+
## So full explanation:
60
+
61
+
- to recompute: a root node should walk down the tree of invalidated nodes locking as it goes, then unlock them once done.
62
+
- to update a variable a leaf node should lock itself, apply an update and then walk up the tree, marking locking each node and marking it invalid
63
+
- if a root node that is currently traversing down the nodes
64
+
65
+
66
+
67
+
68
+
69
+
## invalidate next:
70
+
- evaluation starts at the root node, locking as it goes.
71
+
- when updating a variable walk up the tree of nodes. When we encounter a locked node (one that is currently being evaluated) we mark it as invalidate-next.
72
+
- if we encounter a node that is currently marked invalidated we can just stop
73
+
- if we encounter an unlocked node that is marked computed, we mark it invalid
74
+
- when a node is finished evaluating it checks to see if it is marked (invalidate next) if it is, we re check the children to find the invalid children and evalute it again.
75
+
- this process may need to have some smart locking of this invalidate next status so that the checking and updating of the status doesn't encounter a scenario where we check the node status and then mark it invalidate next and then concurrently the node is marked evaluted by another thread
+2
forks/nottui/dune-project
+2
forks/nottui/dune-project
+81
-41
forks/nottui/examples/minimal.ml
+81
-41
forks/nottui/examples/minimal.ml
···
2
2
3
3
(* Put the UI here *)
4
4
5
-
6
5
(*let node title ~f =
7
6
let vopened = Lwd.var false in
8
7
let label =
···
31
30
32
31
let root = count_to_10 ()*)
33
32
34
-
let f_to_c x = (x -. 32.0) *. 5.0/.9.0
35
-
let c_to_f x = x *. 9.0/.5.0 +. 32.0
36
-
33
+
let f_to_c x = (x -. 32.0) *. 5.0 /. 9.0
34
+
let c_to_f x = (x *. 9.0 /. 5.0) +. 32.0
37
35
let degrees = Lwd.var 0.0
38
-
39
36
let farenheit = Lwd.var (nan, ("", 0))
40
37
41
38
let farenheit_text =
42
-
Lwd.map2 (Lwd.get degrees) (Lwd.get farenheit)
43
-
~f:(fun d (d', f) ->
44
-
if d = d' then f else (string_of_float (c_to_f d), 0))
39
+
Lwd.map2 (Lwd.get degrees) (Lwd.get farenheit) ~f:(fun d (d', f) ->
40
+
if d = d' then f else string_of_float (c_to_f d), 0)
41
+
;;
45
42
46
43
let farenheit_edit =
47
44
W.edit_field
48
45
farenheit_text
49
-
~on_change:(fun (text, _ as state) ->
50
-
let d = match float_of_string_opt text with
51
-
| None -> Lwd.peek degrees
52
-
| Some d -> let d = f_to_c d in Lwd.set degrees d; d
53
-
in
54
-
Lwd.set farenheit (d, state)
55
-
)
46
+
~on_change:(fun ((text, _) as state) ->
47
+
let d =
48
+
match float_of_string_opt text with
49
+
| None -> Lwd.peek degrees
50
+
| Some d ->
51
+
let d = f_to_c d in
52
+
Lwd.set degrees d;
53
+
d
54
+
in
55
+
Lwd.set farenheit (d, state))
56
56
~on_submit:ignore
57
+
;;
57
58
58
59
let celsius = Lwd.var (nan, ("", 0))
59
60
60
61
let celsius_text =
61
-
Lwd.map2 (Lwd.get degrees) (Lwd.get celsius)
62
-
~f:(fun d (d', f) -> if d = d' then f else (string_of_float d, 0))
62
+
Lwd.map2 (Lwd.get degrees) (Lwd.get celsius) ~f:(fun d (d', f) ->
63
+
if d = d' then f else string_of_float d, 0)
64
+
;;
63
65
64
66
let celsius_edit =
65
67
W.edit_field
66
68
celsius_text
67
-
~on_change:(fun (text, _ as state) ->
68
-
let d = match float_of_string_opt text with
69
-
| None -> Lwd.peek degrees
70
-
| Some d -> Lwd.set degrees d; d
71
-
in
72
-
Lwd.set celsius (d, state)
73
-
)
69
+
~on_change:(fun ((text, _) as state) ->
70
+
let d =
71
+
match float_of_string_opt text with
72
+
| None -> Lwd.peek degrees
73
+
| Some d ->
74
+
Lwd.set degrees d;
75
+
d
76
+
in
77
+
Lwd.set celsius (d, state))
74
78
~on_submit:ignore
79
+
;;
75
80
76
81
let root =
77
-
Lwd_utils.pack Ui.pack_y [
78
-
Lwd.pure (W.string "Celsius:");
79
-
celsius_edit;
80
-
Lwd.pure (W.string "Farenheight:");
81
-
farenheit_edit;
82
-
]
82
+
Lwd_utils.pack
83
+
Ui.pack_y
84
+
[ Lwd.pure (W.string "Celsius:")
85
+
; celsius_edit
86
+
; Lwd.pure (W.string "Farenheight:")
87
+
; farenheit_edit
88
+
]
89
+
;;
83
90
84
91
let root =
85
-
Lwd_utils.pack Ui.pack_y [
86
-
root; root; root; root; root; root;
87
-
root; root; root; root; root; root;
88
-
root; root; root; root; root; root;
89
-
]
92
+
Lwd_utils.pack
93
+
Ui.pack_y
94
+
[ root
95
+
; root
96
+
; root
97
+
; root
98
+
; root
99
+
; root
100
+
; root
101
+
; root
102
+
; root
103
+
; root
104
+
; root
105
+
; root
106
+
; root
107
+
; root
108
+
; root
109
+
; root
110
+
; root
111
+
; root
112
+
]
113
+
;;
90
114
91
115
let root =
92
-
Lwd_utils.pack Ui.pack_x [
93
-
root; root; root; root; root; root;
94
-
root; root; root; root; root; root;
95
-
root; root; root; root; root; root;
96
-
]
116
+
Lwd_utils.pack
117
+
Ui.pack_x
118
+
[ root
119
+
; root
120
+
; root
121
+
; root
122
+
; root
123
+
; root
124
+
; root
125
+
; root
126
+
; root
127
+
; root
128
+
; root
129
+
; root
130
+
; root
131
+
; root
132
+
; root
133
+
; root
134
+
; root
135
+
; root
136
+
]
137
+
;;
97
138
98
139
let root = W.Old.scrollbox root
99
-
100
140
let () = Ui_loop.run ~tick_period:0.2 root
+40
-48
forks/nottui/examples/misc.ml
+40
-48
forks/nottui/examples/misc.ml
···
1
1
open Nottui
2
2
3
-
4
3
(* App-specific widgets *)
5
4
6
5
let simple_edit x =
7
6
let var = Lwd.var (x, 0) in
8
7
W.edit_field (Lwd.get var) ~on_change:(Lwd.set var) ~on_submit:ignore
8
+
;;
9
9
10
10
let strict_table () =
11
11
let columns = Lwd_table.make () in
···
13
13
let rows = Lwd_table.make () in
14
14
Lwd_table.append' rows (W.printf "Column %d" colidx |> Lwd.pure);
15
15
for rowidx = 0 to 99 do
16
-
Lwd_table.append' rows
17
-
(simple_edit (Printf.sprintf "Test-%03d-%03d" colidx rowidx))
16
+
Lwd_table.append' rows (simple_edit (Printf.sprintf "Test-%03d-%03d" colidx rowidx))
18
17
done;
19
-
Lwd_table.append' columns
20
-
( rows
21
-
|> Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_y)
22
-
|> Lwd.join );
18
+
Lwd_table.append'
19
+
columns
20
+
(rows |> Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_y) |> Lwd.join);
23
21
Lwd_table.append' columns (Lwd.return (W.string " "))
24
22
done;
25
-
W.Scroll.area
26
-
@@ Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_x) columns)
23
+
W.Scroll.area @@ Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_x) columns)
24
+
;;
27
25
28
26
(*let lazy_table t =
29
27
let t = scroll_area t in
···
81
79
else lazy_table body;
82
80
in
83
81
view_menu ()
84
-
*)
82
+
*)
85
83
86
84
(* Entry point *)
87
85
88
86
let top = Lwd.var (Lwd.return Ui.empty)
89
-
90
87
let bot = Lwd.var (Lwd.return Ui.empty)
91
-
92
-
let wm =
93
-
W.Old.window_manager @@
94
-
W.vbox [ Lwd.join (Lwd.get top); Lwd.join (Lwd.get bot) ]
88
+
let wm = W.Old.window_manager @@ W.vbox [ Lwd.join (Lwd.get top); Lwd.join (Lwd.get bot) ]
95
89
96
90
(*let () = Statmemprof_emacs.start 1E-4 30 5*)
97
91
98
92
let () =
99
93
let open W.Old in
100
-
Lwd.set top @@
101
-
Lwd_utils.pack Ui.pack_x
102
-
[
103
-
main_menu_item wm "File" (fun () ->
104
-
W.vbox
105
-
[
106
-
Lwd.return @@ sub_entry "New" ignore;
107
-
Lwd.return @@ sub_entry "Open" ignore;
108
-
sub_menu_item wm "Recent" (fun () ->
109
-
W.vbox
110
-
[
111
-
Lwd.return @@ sub_entry "A" ignore;
112
-
Lwd.return @@ sub_entry "B" ignore;
113
-
Lwd.return @@ sub_entry "CD" ignore;
114
-
]);
115
-
Lwd.return @@ sub_entry "Quit" (fun () -> raise Exit);
116
-
]);
117
-
main_menu_item wm "View" (fun _ ->
118
-
Lwd.set bot (Lwd.return (W.string "<View>"));
119
-
Lwd.return Ui.empty);
120
-
main_menu_item wm "Edit" (fun _ ->
121
-
Lwd.set bot (Lwd.return (W.string "<Edit>"));
122
-
Lwd.return Ui.empty);
123
-
];
124
-
Lwd.set bot @@
125
-
W.vbox
126
-
[
127
-
simple_edit "Hello world";
128
-
W.v_pane (strict_table ()) (Lwd.return @@ W.string "B");
129
-
W.h_pane (Lwd.return (W.string "A")) (Lwd.return (W.string "B"));
130
-
];
131
-
try Ui_loop.run ~tick_period:0.2 (window_manager_view wm)
132
-
with Exit -> ()
94
+
Lwd.set top
95
+
@@ Lwd_utils.pack
96
+
Ui.pack_x
97
+
[ main_menu_item wm "File" (fun () ->
98
+
W.vbox
99
+
[ Lwd.return @@ sub_entry "New" ignore
100
+
; Lwd.return @@ sub_entry "Open" ignore
101
+
; sub_menu_item wm "Recent" (fun () ->
102
+
W.vbox
103
+
[ Lwd.return @@ sub_entry "A" ignore
104
+
; Lwd.return @@ sub_entry "B" ignore
105
+
; Lwd.return @@ sub_entry "CD" ignore
106
+
])
107
+
; Lwd.return @@ sub_entry "Quit" (fun () -> raise Exit)
108
+
])
109
+
; main_menu_item wm "View" (fun _ ->
110
+
Lwd.set bot (Lwd.return (W.string "<View>"));
111
+
Lwd.return Ui.empty)
112
+
; main_menu_item wm "Edit" (fun _ ->
113
+
Lwd.set bot (Lwd.return (W.string "<Edit>"));
114
+
Lwd.return Ui.empty)
115
+
];
116
+
Lwd.set bot
117
+
@@ W.vbox
118
+
[ simple_edit "Hello world"
119
+
; W.v_pane (strict_table ()) (Lwd.return @@ W.string "B")
120
+
; W.h_pane (Lwd.return (W.string "A")) (Lwd.return (W.string "B"))
121
+
];
122
+
try Ui_loop.run ~tick_period:0.2 (window_manager_view wm) with
123
+
| Exit -> ()
124
+
;;
+51
-46
forks/nottui/examples/pretty.ml
+51
-46
forks/nottui/examples/pretty.ml
···
2
2
module P = Nottui_pretty
3
3
4
4
let string ?attr text = P.ui (W.string ?attr text)
5
-
6
-
let (^^) = P.(^^)
7
-
let (^/^) a b = P.(a ^^ break 1 ^^ b)
8
-
5
+
let ( ^^ ) = P.( ^^ )
6
+
let ( ^/^ ) a b = P.(a ^^ break 1 ^^ b)
9
7
let base = Lwd.var W.empty_lwd
10
-
11
8
let wm = W.Old.window_manager (Lwd.join (Lwd.get base))
12
-
13
9
let spring = P.ui (Ui.resize ~sw:1 Ui.empty)
14
10
15
11
let selector text f choices =
16
12
W.Old.main_menu_item wm text (fun () ->
17
-
Lwd.pure @@ Ui.vcat (
18
-
List.map
19
-
(fun choice ->
20
-
W.Old.sub_entry choice (fun () -> f choice))
21
-
choices
22
-
)
23
-
)
13
+
Lwd.pure
14
+
@@ Ui.vcat
15
+
(List.map (fun choice -> W.Old.sub_entry choice (fun () -> f choice)) choices))
16
+
;;
24
17
25
18
let fruit =
26
-
let fruits = ["Apple"; "Orange"; "Strawberry"] in
19
+
let fruits = [ "Apple"; "Orange"; "Strawberry" ] in
27
20
let choice = Lwd.var (List.hd fruits) in
28
-
Lwd.join (
29
-
Lwd.map (Lwd.get choice)
30
-
~f:(fun current -> selector current (Lwd.set choice) fruits)
31
-
)
21
+
Lwd.join
22
+
(Lwd.map (Lwd.get choice) ~f:(fun current -> selector current (Lwd.set choice) fruits))
23
+
;;
32
24
33
25
let doc = Lwd_table.make ()
34
26
35
27
let () =
36
28
for _ = 0 to 99 do
37
-
List.iter (fun doc' -> Lwd_table.append' doc (Lwd.pure doc'))
38
-
[
39
-
P.group (string "This" ^/^ string "is" ^/^ string "pretty.");
40
-
P.hardline; P.ui (Ui.space 0 1); P.hardline;
41
-
P.group (P.group (string "This" ^/^ string "is") ^/^ string "pretty.");
42
-
P.hardline; P.ui (Ui.space 0 1); P.hardline;
43
-
P.group (string "This" ^/^ P.group (string "is" ^/^ string "pretty."));
44
-
P.hardline; P.ui (Ui.space 0 1); P.hardline;
45
-
P.group (spring ^^ string "This" ^^ spring ^/^
46
-
P.group (string "is" ^^ spring ^/^ string "pretty.") ^^ spring);
47
-
P.hardline; P.ui (Ui.space 0 1); P.hardline;
29
+
List.iter
30
+
(fun doc' -> Lwd_table.append' doc (Lwd.pure doc'))
31
+
[ P.group (string "This" ^/^ string "is" ^/^ string "pretty.")
32
+
; P.hardline
33
+
; P.ui (Ui.space 0 1)
34
+
; P.hardline
35
+
; P.group (P.group (string "This" ^/^ string "is") ^/^ string "pretty.")
36
+
; P.hardline
37
+
; P.ui (Ui.space 0 1)
38
+
; P.hardline
39
+
; P.group (string "This" ^/^ P.group (string "is" ^/^ string "pretty."))
40
+
; P.hardline
41
+
; P.ui (Ui.space 0 1)
42
+
; P.hardline
43
+
; P.group
44
+
(spring
45
+
^^ string "This"
46
+
^^ spring
47
+
^/^ P.group (string "is" ^^ spring ^/^ string "pretty.")
48
+
^^ spring)
49
+
; P.hardline
50
+
; P.ui (Ui.space 0 1)
51
+
; P.hardline
48
52
];
49
-
Lwd_table.append' doc
53
+
Lwd_table.append'
54
+
doc
50
55
(Lwd.map fruit ~f:(fun fruit ->
51
-
P.group (spring ^^ string "I" ^^ spring ^/^
52
-
P.group (string "like" ^^ spring ^/^
53
-
P.ui fruit ^^ spring ^/^
54
-
string "more.") ^^ spring);
55
-
))
56
+
P.group
57
+
(spring
58
+
^^ string "I"
59
+
^^ spring
60
+
^/^ P.group
61
+
(string "like" ^^ spring ^/^ P.ui fruit ^^ spring ^/^ string "more.")
62
+
^^ spring)))
56
63
done
64
+
;;
57
65
58
66
let varying_width f =
59
67
let width = Lwd.var 0 in
60
-
Lwd.map (f (Lwd.get width)) ~f:(fun ui ->
68
+
Lwd.map
69
+
(f (Lwd.get width))
70
+
~f:(fun ui ->
61
71
Ui.size_sensor
62
72
(fun ~w ~h:_ -> if Lwd.peek width <> w then Lwd.set width w)
63
-
(Ui.resize ~sw:1 ~sh:1 ~w:0 ui)
64
-
)
65
-
66
-
let doc =
67
-
Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid (P.empty, P.(^^))) doc)
73
+
(Ui.resize ~sw:1 ~sh:1 ~w:0 ui))
74
+
;;
68
75
76
+
let doc = Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid (P.empty, P.( ^^ ))) doc)
69
77
let contents width = Lwd.map2 ~f:P.pretty width doc
70
78
71
79
let () =
72
-
Lwd.set base (
73
-
W.h_pane
74
-
(W.Scroll.area (varying_width contents))
75
-
(Lwd.pure Ui.empty)
76
-
);
80
+
Lwd.set base (W.h_pane (W.Scroll.area (varying_width contents)) (Lwd.pure Ui.empty));
77
81
Ui_loop.run (W.Old.window_manager_view wm)
82
+
;;
+57
-55
forks/nottui/examples/reranger.ml
+57
-55
forks/nottui/examples/reranger.ml
···
1
1
open Nottui
2
2
open! Lwd_infix
3
3
4
-
5
4
let is_double_click =
6
5
let k = ref 0 in
7
6
let last = ref (0, 0.0) in
···
14
13
let k, t = !last in
15
14
k = k' && t +. 0.4 >= time
16
15
in
17
-
last := (k', time);
16
+
last := k', time;
18
17
result
18
+
;;
19
19
20
20
let remember_width ~wref ui =
21
21
wref := max (Ui.layout_spec ui).Ui.w !wref;
22
-
Ui.resize ~w:!wref ui
22
+
Ui.resize ~w:!wref ui
23
+
;;
23
24
24
25
let rec dir ?(initial_path = []) ?after_width:(wref = ref 0) path =
25
26
let column = Lwd.var (Lwd.return Ui.empty) in
···
28
29
let directories = Lwd_table.make () in
29
30
let files = Lwd_table.make () in
30
31
let body =
31
-
32
-
(W.vbox
33
-
[
34
-
Lwd_table.reduce Ui.pack_y directories;
35
-
Lwd_table.reduce Ui.pack_y files;
36
-
])
37
-
|>W.Scroll.v_area
32
+
W.vbox [ Lwd_table.reduce Ui.pack_y directories; Lwd_table.reduce Ui.pack_y files ]
33
+
|> W.Scroll.v_area
38
34
in
39
35
let rec set_constrain constrain =
40
36
let header =
41
37
Ui.mouse_area
42
38
(fun ~x:_ ~y:_ -> function
43
-
| `Left ->
44
-
set_constrain false;
45
-
Lwd.set after (Lwd.return Ui.empty);
46
-
`Handled | _ -> `Unhandled)
39
+
| `Left ->
40
+
set_constrain false;
41
+
Lwd.set after (Lwd.return Ui.empty);
42
+
`Handled
43
+
| _ -> `Unhandled)
47
44
header
48
45
in
49
46
let t = W.vbox [ Lwd.return header; body ] in
50
47
let t =
51
-
if constrain then Lwd.map ~f:(Ui.resize ~w:12 ) t
48
+
if constrain
49
+
then Lwd.map ~f:(Ui.resize ~w:12) t
52
50
else Lwd.map ~f:(remember_width ~wref) t
53
51
in
54
52
Lwd.set column (Lwd_utils.pack Ui.pack_x [ t; Lwd.join (Lwd.get after) ])
···
58
56
let goto ?initial_path name =
59
57
set_constrain true;
60
58
let t =
61
-
try dir ?initial_path ~after_width (Filename.concat path name)
62
-
with exn ->
63
-
Lwd.return (W.string ~attr:Notty.(A.bg A.red) (Printexc.to_string exn))
59
+
try dir ?initial_path ~after_width (Filename.concat path name) with
60
+
| exn -> Lwd.return (W.string ~attr:Notty.(A.bg A.red) (Printexc.to_string exn))
64
61
in
65
62
Lwd.set after (Lwd.map ~f:(Ui.join_x (W.string " ")) t)
66
63
in
67
64
let highlighted_cell = ref None in
68
65
let rec render_directory ?(highlight = false) cell name =
69
-
if highlight then (
70
-
( match !highlighted_cell with
71
-
| None -> ()
72
-
| Some (cell, name) -> render_directory cell name );
73
-
highlighted_cell := Some (cell, name) );
66
+
if highlight
67
+
then (
68
+
(match !highlighted_cell with
69
+
| None -> ()
70
+
| Some (cell, name) -> render_directory cell name);
71
+
highlighted_cell := Some (cell, name));
74
72
Lwd_table.set cell
75
73
@@ Ui.mouse_area
76
74
(fun ~x:_ ~y:_ -> function
77
-
| `Left ->
78
-
render_directory ~highlight:true cell name;
79
-
goto name;
80
-
`Handled | _ -> `Unhandled)
81
-
(W.string
82
-
~attr:Notty.(A.bg (if highlight then A.lightblue else A.blue))
83
-
name)
75
+
| `Left ->
76
+
render_directory ~highlight:true cell name;
77
+
goto name;
78
+
`Handled
79
+
| _ -> `Unhandled)
80
+
(W.string ~attr:Notty.(A.bg (if highlight then A.lightblue else A.blue)) name)
84
81
in
85
82
let add_directory name =
86
-
if name <> "" && name.[0] <> '.' then
83
+
if name <> "" && name.[0] <> '.'
84
+
then (
87
85
let highlight =
88
-
match initial_path with x :: _ when x = name -> true | _ -> false
86
+
match initial_path with
87
+
| x :: _ when x = name -> true
88
+
| _ -> false
89
89
in
90
-
render_directory ~highlight (Lwd_table.append directories) name
90
+
render_directory ~highlight (Lwd_table.append directories) name)
91
91
in
92
92
let add_file name =
93
93
let is_double_click = is_double_click () in
94
94
Lwd_table.set (Lwd_table.append files)
95
95
@@ Ui.mouse_area
96
96
(fun ~x:_ ~y:_ -> function
97
-
| `Left ->
98
-
if is_double_click () then
99
-
ignore
100
-
( Sys.command
101
-
( "xdg-open "
102
-
^ Filename.quote (Filename.concat path name) )
103
-
: int );
104
-
`Handled | _ -> `Unhandled)
97
+
| `Left ->
98
+
if is_double_click ()
99
+
then
100
+
ignore
101
+
(Sys.command ("xdg-open " ^ Filename.quote (Filename.concat path name))
102
+
: int);
103
+
`Handled
104
+
| _ -> `Unhandled)
105
105
(W.string name)
106
106
in
107
107
let entries = Sys.readdir path in
108
108
Array.sort String.compare entries;
109
109
Array.iter
110
110
(fun name ->
111
-
let path = Filename.concat path name in
112
-
try if Sys.is_directory path then add_directory name else add_file name
113
-
with exn ->
114
-
let text =
115
-
match exn with Sys_error _ -> name | exn -> Printexc.to_string exn
116
-
in
117
-
Lwd_table.append' files (W.string ~attr:Notty.(A.bg A.red) text))
111
+
let path = Filename.concat path name in
112
+
try if Sys.is_directory path then add_directory name else add_file name with
113
+
| exn ->
114
+
let text =
115
+
match exn with
116
+
| Sys_error _ -> name
117
+
| exn -> Printexc.to_string exn
118
+
in
119
+
Lwd_table.append' files (W.string ~attr:Notty.(A.bg A.red) text))
118
120
entries;
119
-
(match initial_path with [] -> () | x :: xs -> goto ~initial_path:xs x);
121
+
(match initial_path with
122
+
| [] -> ()
123
+
| x :: xs -> goto ~initial_path:xs x);
120
124
Lwd.join (Lwd.get column)
125
+
;;
121
126
122
127
let gravity_pad = Gravity.make ~h:`Negative ~v:`Negative
123
-
124
128
let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative
125
129
126
130
let () =
···
133
137
in
134
138
let body = Lwd.var (Lwd.pure Ui.empty) in
135
139
let wm = W.Old.window_manager (Lwd.join (Lwd.get body)) in
136
-
let ui = W.vbox [
137
-
W.Old.main_menu_item wm "Quit" (fun () -> exit 0);
138
-
dir ~initial_path "/"
139
-
]
140
+
let ui =
141
+
W.vbox [ W.Old.main_menu_item wm "Quit" (fun () -> exit 0); dir ~initial_path "/" ]
140
142
in
141
143
Lwd.set body (Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui);
142
144
Ui_loop.run (W.Old.window_manager_view wm)
143
-
145
+
;;
+13
-9
forks/nottui/examples/stress.ml
+13
-9
forks/nottui/examples/stress.ml
···
1
1
open Nottui
2
2
3
-
4
3
(* App-specific widgets *)
5
4
6
5
let strict_table () =
7
6
let columns = Lwd_table.make () in
8
7
let cells =
9
8
Array.init 100 (fun _ ->
10
-
let rows = Lwd_table.make () in
11
-
Lwd_table.append' columns rows;
12
-
Array.init 100 (fun _ -> Lwd_table.append rows ~set:0))
9
+
let rows = Lwd_table.make () in
10
+
Lwd_table.append' columns rows;
11
+
Array.init 100 (fun _ -> Lwd_table.append rows ~set:0))
13
12
in
14
13
let render_cell _ v = W.string (string_of_int v) in
15
14
let render_column _ rows = Lwd_table.map_reduce render_cell Ui.pack_y rows in
16
15
let table =
17
-
Lwd_table.map_reduce render_column
18
-
(Lwd_utils.lift_monoid Ui.pack_x)
19
-
columns
16
+
Lwd_table.map_reduce render_column (Lwd_utils.lift_monoid Ui.pack_x) columns
20
17
in
21
-
(cells, Lwd.join table |> W.Scroll.area)
18
+
cells, Lwd.join table |> W.Scroll.area
19
+
;;
22
20
23
21
(* Entry point *)
24
22
25
23
(*let () = Statmemprof_emacs.start 1E-4 30 5*)
26
24
27
25
let walk cell =
28
-
let v = match Lwd_table.get cell with None -> 0 | Some x -> x in
26
+
let v =
27
+
match Lwd_table.get cell with
28
+
| None -> 0
29
+
| Some x -> x
30
+
in
29
31
Lwd_table.set cell (v + Random.int 20 - 10)
32
+
;;
30
33
31
34
let () =
32
35
let cells, table = strict_table () in
···
39
42
done;
40
43
Lwd.quick_release root;
41
44
Notty_unix.Term.release term
45
+
;;
+30
-24
forks/nottui/lib/nottui-lwt/nottui_lwt.ml
+30
-24
forks/nottui/lib/nottui-lwt/nottui_lwt.ml
···
2
2
open Nottui
3
3
open Notty_lwt
4
4
5
-
type event = [
6
-
| `Key of Unescape.key
5
+
type event =
6
+
[ `Key of Unescape.key
7
7
| `Mouse of Unescape.mouse
8
8
| `Paste of Unescape.paste
9
9
| `Resize of int * int
10
-
]
10
+
]
11
11
12
12
let copy_until quit ~f input =
13
13
let quit = Lwt.map (fun () -> None) quit in
14
14
let stream, push = Lwt_stream.create () in
15
15
let rec aux () =
16
-
Lwt.bind (Lwt.choose [quit; Lwt_stream.peek input]) @@ fun result ->
16
+
Lwt.bind (Lwt.choose [ quit; Lwt_stream.peek input ]) @@ fun result ->
17
17
match result with
18
18
| None ->
19
19
push None;
···
24
24
in
25
25
Lwt.async aux;
26
26
stream
27
+
;;
27
28
28
29
let render ?quit ~size events doc =
29
30
let renderer = Renderer.make () in
30
31
let refresh_stream, push_refresh = Lwt_stream.create () in
31
32
let root =
32
-
Lwd.observe ~on_invalidate:(fun _ ->
33
-
if not (Lwt_stream.is_closed refresh_stream) then
34
-
push_refresh (Some ())
35
-
) doc
33
+
Lwd.observe
34
+
~on_invalidate:(fun _ ->
35
+
if not (Lwt_stream.is_closed refresh_stream) then push_refresh (Some ()))
36
+
doc
36
37
in
37
-
let quit, do_quit = match quit with
38
+
let quit, do_quit =
39
+
match quit with
38
40
| Some quit -> quit, None
39
-
| None -> let t, u = Lwt.wait () in t, Some u
41
+
| None ->
42
+
let t, u = Lwt.wait () in
43
+
t, Some u
40
44
in
41
-
let events = copy_until quit events ~f:(fun e ->
42
-
(e : [`Resize of _ | Unescape.event] :> [`Resize of _ | Ui.event]))
45
+
let events =
46
+
copy_until quit events ~f:(fun e ->
47
+
(e : [ `Resize of _ | Unescape.event ] :> [ `Resize of _ | Ui.event ]))
43
48
in
44
49
let size = ref size in
45
50
let result, push = Lwt_stream.create () in
···
51
56
in
52
57
refresh ();
53
58
let process_event = function
54
-
| `Key (`ASCII 'q', [`Meta]) as event ->
55
-
begin match do_quit with
56
-
| Some u -> Lwt.wakeup u ()
57
-
| None -> ignore (Renderer.dispatch_event renderer event)
58
-
end
59
-
| #Ui.event as event ->
60
-
ignore (Renderer.dispatch_event renderer event)
59
+
| `Key (`ASCII 'q', [ `Meta ]) as event ->
60
+
(match do_quit with
61
+
| Some u -> Lwt.wakeup u ()
62
+
| None -> ignore (Renderer.dispatch_event renderer event))
63
+
| #Ui.event as event -> ignore (Renderer.dispatch_event renderer event)
61
64
| `Resize size' ->
62
65
size := size';
63
66
refresh ()
64
67
in
65
68
Lwt.async (fun () ->
66
-
Lwt.finalize
67
-
(fun () -> Lwt_stream.iter process_event events)
68
-
(fun () -> push None; Lwt.return_unit)
69
-
);
69
+
Lwt.finalize
70
+
(fun () -> Lwt_stream.iter process_event events)
71
+
(fun () ->
72
+
push None;
73
+
Lwt.return_unit));
70
74
Lwt.async (fun () -> Lwt_stream.iter refresh refresh_stream);
71
75
result
76
+
;;
72
77
73
78
let run ?quit doc =
74
79
let term = Term.create () in
75
80
let images = render ?quit ~size:(Term.size term) (Term.events term) doc in
76
81
Lwt.finalize
77
82
(fun () -> Lwt_stream.iter_s (Term.image term) images)
78
-
(fun () -> (Term.release term))
83
+
(fun () -> Term.release term)
84
+
;;
+11
-6
forks/nottui/lib/nottui-lwt/nottui_lwt.mli
+11
-6
forks/nottui/lib/nottui-lwt/nottui_lwt.mli
···
7
7
synchronize threads.
8
8
*)
9
9
10
-
type event = [
11
-
| `Key of Unescape.key
10
+
(** FIXME: Refactor to use [Nottui.Ui.event]? *)
11
+
type event =
12
+
[ `Key of Unescape.key
12
13
| `Mouse of Unescape.mouse
13
14
| `Paste of Unescape.paste
14
15
| `Resize of int * int
15
-
]
16
-
(** FIXME: Refactor to use [Nottui.Ui.event]? *)
16
+
]
17
17
18
-
val render : ?quit:unit Lwt.t -> size:int * int -> event Lwt_stream.t -> ui Lwd.t -> image Lwt_stream.t
19
18
(** Turn a stream of events into a stream of images. *)
19
+
val render
20
+
: ?quit:unit Lwt.t
21
+
-> size:int * int
22
+
-> event Lwt_stream.t
23
+
-> ui Lwd.t
24
+
-> image Lwt_stream.t
20
25
21
-
val run : (*?term:Term.t ->*) ?quit:unit Lwt.t -> ui Lwd.t -> unit Lwt.t
22
26
(** Run mainloop in [Lwt], until the [quit] promise is fulfilled.
23
27
24
28
The ui is a normal [Lwd.t] value, but events are free to spawn asynchronous
25
29
[Lwt] threads.
26
30
*)
31
+
val run : ?quit:(*?term:Term.t ->*) unit Lwt.t -> ui Lwd.t -> unit Lwt.t
+207
-162
forks/nottui/lib/nottui-pretty/nottui_pretty.ml
+207
-162
forks/nottui/lib/nottui-pretty/nottui_pretty.ml
···
17
17
18
18
(* A type of integers with infinity. *)
19
19
20
-
type requirement =
21
-
int (* with infinity *)
20
+
type requirement = int (* with infinity *)
22
21
23
22
(* Infinity is encoded as [max_int]. *)
24
23
25
-
let infinity : requirement =
26
-
max_int
24
+
let infinity : requirement = max_int
27
25
28
26
(* Addition of integers with infinity. *)
29
27
30
-
let (++) (x : requirement) (y : requirement) : requirement =
31
-
if x = infinity || y = infinity
32
-
then infinity
33
-
else x + y
28
+
let ( ++ ) (x : requirement) (y : requirement) : requirement =
29
+
if x = infinity || y = infinity then infinity else x + y
30
+
;;
34
31
35
32
(* --------------------------------------------------------------------------
36
33
UI cache
···
66
63
FUTURE WORK: since flat layout never changes, it might be worth caching
67
64
separately flat and non-flat results. Flat cache would actually be a lazy
68
65
computation.
69
-
*)
66
+
*)
70
67
71
68
(* We use a few OCaml tricks to implement caching without introducing too
72
69
much indirections.
···
90
87
It can only occur when someone put a `Hardline` in a flat document.
91
88
They lied: the document should have been flat, but it is not.
92
89
Nevertheless, I chose to accept this case. *)
93
-
Flat_span : { prefix: ui; body: ui; suffix: ui } -> flat ui_cache
90
+
Flat_span :
91
+
{ prefix : ui
92
+
; body : ui
93
+
; suffix : ui
94
+
}
95
+
-> flat ui_cache
94
96
| (* A line in a non-flat context *)
95
-
Nonflat_line : { min_rem: int; max_rem: int; ui: ui; } -> nonflat ui_cache
97
+
Nonflat_line :
98
+
{ min_rem : int
99
+
; max_rem : int
100
+
; ui : ui
101
+
}
102
+
-> nonflat ui_cache
96
103
| (* A span in a non-flat context *)
97
-
Nonflat_span : {
98
-
min_rem: int; max_rem: int; prefix: ui;
99
-
min_wid: int; max_wid: int; body: ui; suffix: ui;
100
-
} -> nonflat ui_cache
104
+
Nonflat_span :
105
+
{ min_rem : int
106
+
; max_rem : int
107
+
; prefix : ui
108
+
; min_wid : int
109
+
; max_wid : int
110
+
; body : ui
111
+
; suffix : ui
112
+
}
113
+
-> nonflat ui_cache
101
114
102
115
(* The type of an actual cache slot (stored in document nodes).
103
116
It hides the category of the node. *)
···
110
123
type t =
111
124
| Blank of int
112
125
| Ui of Nottui.ui
113
-
| If_flat of { then_: t; else_: t }
126
+
| If_flat of
127
+
{ then_ : t
128
+
; else_ : t
129
+
}
114
130
| Hardline
115
-
| Cat of { req: requirement; lhs: t; rhs: t; mutable cache : ui_cache_slot }
116
-
| Nest of { req: requirement; indent: int; doc: t }
117
-
| Group of { req: requirement; doc: t; mutable cache : ui_cache_slot }
131
+
| Cat of
132
+
{ req : requirement
133
+
; lhs : t
134
+
; rhs : t
135
+
; mutable cache : ui_cache_slot
136
+
}
137
+
| Nest of
138
+
{ req : requirement
139
+
; indent : int
140
+
; doc : t
141
+
}
142
+
| Group of
143
+
{ req : requirement
144
+
; doc : t
145
+
; mutable cache : ui_cache_slot
146
+
}
118
147
119
148
(* Only [Cat] and [Group] nodes are cached.
120
149
This is because [Cat] is the only place where two sub-documents are
···
125
154
should normally only have a fixed nesting ([Nest (Nest (Nest ...))] cannot
126
155
happen). I suspect that caching is not beneficial, if detrimental, to these
127
156
cases.
128
-
*)
157
+
*)
129
158
130
159
(* -------------------------------------------------------------------------- *)
131
160
···
136
165
| Ui ui -> Nottui.Ui.layout_width ui
137
166
| If_flat t -> requirement t.then_
138
167
| Hardline -> infinity
139
-
| Cat {req; _} | Nest {req; _} | Group {req; _} -> req
168
+
| Cat { req; _ } | Nest { req; _ } | Group { req; _ } -> req
169
+
;;
140
170
141
171
(* -------------------------------------------------------------------------- *)
142
172
143
173
(* Document constructors. *)
144
174
145
175
let empty = Blank 0
146
-
147
176
let ui ui = Ui ui
148
-
149
177
let hardline = Hardline
150
178
151
179
let blank = function
152
180
| 0 -> Blank 0
153
181
| 1 -> Blank 1
154
182
| n -> Blank n
155
-
156
-
let if_flat (If_flat {then_; _} | then_) else_ =
157
-
If_flat { then_; else_ }
183
+
;;
158
184
159
-
let internal_break i =
160
-
if_flat (blank i) hardline
185
+
let if_flat (If_flat { then_; _ } | then_) else_ = If_flat { then_; else_ }
186
+
let internal_break i = if_flat (blank i) hardline
161
187
162
188
let break =
163
189
let break0 = internal_break 0 in
···
166
192
| 0 -> break0
167
193
| 1 -> break1
168
194
| i -> internal_break i
195
+
;;
169
196
170
-
let (^^) x y =
197
+
let ( ^^ ) x y =
171
198
match x, y with
172
-
| (Blank 0, t) | (t, Blank 0) -> t
199
+
| Blank 0, t | t, Blank 0 -> t
173
200
| Blank i, Blank j -> Blank (i + j)
174
201
| lhs, rhs ->
175
-
Cat {req = requirement lhs ++ requirement rhs; lhs; rhs;
176
-
cache = Cache Uncached}
202
+
Cat { req = requirement lhs ++ requirement rhs; lhs; rhs; cache = Cache Uncached }
203
+
;;
177
204
178
205
let nest indent doc =
179
206
assert (indent >= 0);
180
207
match doc with
181
-
| Nest t -> Nest {req = t.req; indent = indent + t.indent; doc = t.doc}
182
-
| doc -> Nest {req = requirement doc; indent; doc}
208
+
| Nest t -> Nest { req = t.req; indent = indent + t.indent; doc = t.doc }
209
+
| doc -> Nest { req = requirement doc; indent; doc }
210
+
;;
183
211
184
212
let group = function
185
213
| Group _ as doc -> doc
186
214
| doc ->
187
215
let req = requirement doc in
188
-
if req = infinity then doc else Group {req; doc; cache = Cache Uncached}
216
+
if req = infinity then doc else Group { req; doc; cache = Cache Uncached }
217
+
;;
189
218
190
219
(* -------------------------------------------------------------------------- *)
191
220
···
194
223
(* Some intermediate UI *)
195
224
196
225
let blank_ui n = Ui.space n 0
197
-
198
-
let flat_hardline =
199
-
Flat_span { prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty; }
226
+
let flat_hardline = Flat_span { prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty }
200
227
201
228
let mk_body body1 suffix prefix body2 =
202
229
Ui.join_y body1 (Ui.join_y (Ui.join_x suffix prefix) body2)
230
+
;;
203
231
204
232
let mk_pad indent body suffix =
205
233
let pad = Ui.space indent 0 in
206
-
(Ui.join_x pad body, Ui.join_x pad suffix)
234
+
Ui.join_x pad body, Ui.join_x pad suffix
235
+
;;
207
236
208
237
(* Flat renderer *)
209
238
210
-
let flat_cache (Cache slot) = match slot with
239
+
let flat_cache (Cache slot) =
240
+
match slot with
211
241
| Flat_line _ as ui -> Some ui
212
242
| Flat_span _ as ui -> Some ui
213
243
| _ -> None
244
+
;;
214
245
215
246
let rec pretty_flat = function
216
247
| Ui ui -> Flat_line ui
···
218
249
| Hardline -> flat_hardline
219
250
| If_flat t -> pretty_flat t.then_
220
251
| Cat t ->
221
-
begin match flat_cache t.cache with
222
-
| Some ui -> ui
223
-
| None ->
224
-
let result =
225
-
let lhs = pretty_flat t.lhs and rhs = pretty_flat t.rhs in
226
-
match lhs, rhs with
227
-
| Flat_line l, Flat_line r ->
228
-
Flat_line (Ui.join_x l r)
229
-
| Flat_line l, Flat_span r ->
230
-
Flat_span {r with prefix = Ui.join_x l r.prefix}
231
-
| Flat_span l, Flat_line r ->
232
-
Flat_span {l with suffix = Ui.join_x l.suffix r}
233
-
| Flat_span l, Flat_span r ->
234
-
Flat_span {prefix = l.prefix;
235
-
body = mk_body l.body l.suffix r.prefix r.body;
236
-
suffix = r.suffix}
237
-
in
238
-
t.cache <- Cache result;
239
-
result
240
-
end
252
+
(match flat_cache t.cache with
253
+
| Some ui -> ui
254
+
| None ->
255
+
let result =
256
+
let lhs = pretty_flat t.lhs
257
+
and rhs = pretty_flat t.rhs in
258
+
match lhs, rhs with
259
+
| Flat_line l, Flat_line r -> Flat_line (Ui.join_x l r)
260
+
| Flat_line l, Flat_span r -> Flat_span { r with prefix = Ui.join_x l r.prefix }
261
+
| Flat_span l, Flat_line r -> Flat_span { l with suffix = Ui.join_x l.suffix r }
262
+
| Flat_span l, Flat_span r ->
263
+
Flat_span
264
+
{ prefix = l.prefix
265
+
; body = mk_body l.body l.suffix r.prefix r.body
266
+
; suffix = r.suffix
267
+
}
268
+
in
269
+
t.cache <- Cache result;
270
+
result)
241
271
| Nest t ->
242
-
begin match pretty_flat t.doc with
243
-
| Flat_line _ as ui -> ui
244
-
| Flat_span s ->
245
-
let body, suffix = mk_pad t.indent s.body s.suffix in
246
-
Flat_span {s with body; suffix}
247
-
end
272
+
(match pretty_flat t.doc with
273
+
| Flat_line _ as ui -> ui
274
+
| Flat_span s ->
275
+
let body, suffix = mk_pad t.indent s.body s.suffix in
276
+
Flat_span { s with body; suffix })
248
277
| Group t ->
249
-
begin match flat_cache t.cache with
250
-
| Some ui -> ui
251
-
| None ->
252
-
let result = pretty_flat t.doc in
253
-
t.cache <- Cache result;
254
-
result
255
-
end
278
+
(match flat_cache t.cache with
279
+
| Some ui -> ui
280
+
| None ->
281
+
let result = pretty_flat t.doc in
282
+
t.cache <- Cache result;
283
+
result)
284
+
;;
256
285
257
286
(* Nonflat renderer.
258
287
···
269
298
270
299
let mini, maxi = Lwd_utils.(mini, maxi)
271
300
272
-
let (+++) i j = let result = i + j in if result < 0 then max_int else result
301
+
let ( +++ ) i j =
302
+
let result = i + j in
303
+
if result < 0 then max_int else result
304
+
;;
273
305
274
-
let nonflat_line ui =
275
-
Nonflat_line {min_rem = min_int; max_rem = max_int; ui}
306
+
let nonflat_line ui = Nonflat_line { min_rem = min_int; max_rem = max_int; ui }
276
307
277
-
let nonflat_cache (Cache slot) rem wid = match slot with
308
+
let nonflat_cache (Cache slot) rem wid =
309
+
match slot with
278
310
| Nonflat_line t' as t when t'.min_rem <= rem && rem < t'.max_rem -> Some t
279
311
| Nonflat_span t' as t
280
-
when t'.min_rem <= rem && rem < t'.max_rem &&
281
-
t'.min_wid <= wid && wid < t'.max_wid -> Some t
312
+
when t'.min_rem <= rem && rem < t'.max_rem && t'.min_wid <= wid && wid < t'.max_wid ->
313
+
Some t
282
314
| _ -> None
315
+
;;
283
316
284
-
let span_hardline = Nonflat_span {
285
-
min_rem = min_int; max_rem = max_int;
286
-
min_wid = min_int; max_wid = max_int;
287
-
prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty;
288
-
}
317
+
let span_hardline =
318
+
Nonflat_span
319
+
{ min_rem = min_int
320
+
; max_rem = max_int
321
+
; min_wid = min_int
322
+
; max_wid = max_int
323
+
; prefix = Ui.empty
324
+
; body = Ui.empty
325
+
; suffix = Ui.empty
326
+
}
327
+
;;
289
328
290
-
let rec pretty (rem: int) (wid : int) = function
329
+
let rec pretty (rem : int) (wid : int) = function
291
330
| Ui ui -> nonflat_line ui
292
331
| Blank n -> nonflat_line (blank_ui n)
293
332
| Hardline -> span_hardline
294
333
| If_flat t -> pretty rem wid t.else_
295
334
| Cat t ->
296
-
begin match nonflat_cache t.cache rem wid with
297
-
| Some ui -> ui
298
-
| None ->
299
-
let lhs = pretty rem wid t.lhs in
300
-
let result = match lhs with
301
-
| Nonflat_line l ->
302
-
let lw = Ui.layout_width l.ui in
303
-
begin match pretty (rem - lw) wid t.rhs with
304
-
| Nonflat_line r ->
305
-
Nonflat_line {
306
-
min_rem = maxi l.min_rem (r.min_rem + lw);
307
-
max_rem = mini l.max_rem (r.max_rem +++ lw);
308
-
ui = Ui.join_x l.ui r.ui;
309
-
}
310
-
| Nonflat_span r ->
311
-
Nonflat_span {
312
-
r with
313
-
min_rem = maxi l.min_rem (r.min_rem + lw);
314
-
max_rem = mini l.max_rem (r.max_rem +++ lw);
315
-
prefix = Ui.join_x l.ui r.prefix;
316
-
}
317
-
end
318
-
| Nonflat_span l ->
319
-
let lw = Ui.layout_width l.suffix in
320
-
begin match pretty (wid - lw) wid t.rhs with
321
-
| Nonflat_line r ->
322
-
Nonflat_span {
323
-
l with
324
-
min_wid = maxi l.min_wid (r.min_rem + lw);
325
-
max_wid = mini l.max_wid (r.max_rem +++ lw);
326
-
suffix = Ui.join_x l.suffix r.ui;
335
+
(match nonflat_cache t.cache rem wid with
336
+
| Some ui -> ui
337
+
| None ->
338
+
let lhs = pretty rem wid t.lhs in
339
+
let result =
340
+
match lhs with
341
+
| Nonflat_line l ->
342
+
let lw = Ui.layout_width l.ui in
343
+
(match pretty (rem - lw) wid t.rhs with
344
+
| Nonflat_line r ->
345
+
Nonflat_line
346
+
{ min_rem = maxi l.min_rem (r.min_rem + lw)
347
+
; max_rem = mini l.max_rem (r.max_rem +++ lw)
348
+
; ui = Ui.join_x l.ui r.ui
327
349
}
328
-
| Nonflat_span r ->
329
-
Nonflat_span {
330
-
prefix = l.prefix; min_rem = l.min_rem; max_rem = l.max_rem;
331
-
min_wid = maxi (maxi l.min_wid (r.min_rem + lw)) r.min_wid;
332
-
max_wid = mini (mini l.max_wid (r.max_rem +++ lw)) r.max_wid;
333
-
body = mk_body l.body l.suffix r.prefix r.body;
334
-
suffix = r.suffix;
350
+
| Nonflat_span r ->
351
+
Nonflat_span
352
+
{ r with
353
+
min_rem = maxi l.min_rem (r.min_rem + lw)
354
+
; max_rem = mini l.max_rem (r.max_rem +++ lw)
355
+
; prefix = Ui.join_x l.ui r.prefix
356
+
})
357
+
| Nonflat_span l ->
358
+
let lw = Ui.layout_width l.suffix in
359
+
(match pretty (wid - lw) wid t.rhs with
360
+
| Nonflat_line r ->
361
+
Nonflat_span
362
+
{ l with
363
+
min_wid = maxi l.min_wid (r.min_rem + lw)
364
+
; max_wid = mini l.max_wid (r.max_rem +++ lw)
365
+
; suffix = Ui.join_x l.suffix r.ui
335
366
}
336
-
end
337
-
in
338
-
t.cache <- Cache result;
339
-
result
340
-
end
367
+
| Nonflat_span r ->
368
+
Nonflat_span
369
+
{ prefix = l.prefix
370
+
; min_rem = l.min_rem
371
+
; max_rem = l.max_rem
372
+
; min_wid = maxi (maxi l.min_wid (r.min_rem + lw)) r.min_wid
373
+
; max_wid = mini (mini l.max_wid (r.max_rem +++ lw)) r.max_wid
374
+
; body = mk_body l.body l.suffix r.prefix r.body
375
+
; suffix = r.suffix
376
+
})
377
+
in
378
+
t.cache <- Cache result;
379
+
result)
341
380
| Nest t ->
342
-
begin match pretty rem (wid - t.indent) t.doc with
343
-
| Nonflat_line _ as ui -> ui
344
-
| Nonflat_span s ->
345
-
let body, suffix = mk_pad t.indent s.body s.suffix in
346
-
Nonflat_span {
347
-
min_rem = s.min_rem; max_rem = s.max_rem;
348
-
min_wid = s.min_wid + t.indent;
349
-
max_wid = s.max_wid +++ t.indent;
350
-
prefix = s.prefix; body; suffix;
351
-
}
352
-
end
381
+
(match pretty rem (wid - t.indent) t.doc with
382
+
| Nonflat_line _ as ui -> ui
383
+
| Nonflat_span s ->
384
+
let body, suffix = mk_pad t.indent s.body s.suffix in
385
+
Nonflat_span
386
+
{ min_rem = s.min_rem
387
+
; max_rem = s.max_rem
388
+
; min_wid = s.min_wid + t.indent
389
+
; max_wid = s.max_wid +++ t.indent
390
+
; prefix = s.prefix
391
+
; body
392
+
; suffix
393
+
})
353
394
| Group t as self ->
354
-
begin if t.req <= rem then
355
-
match pretty_flat self with
356
-
| Flat_line ui ->
357
-
Nonflat_line { min_rem = t.req; max_rem = max_int; ui }
358
-
| Flat_span ui ->
359
-
Nonflat_span {
360
-
min_rem = t.req; max_rem = max_int;
361
-
min_wid = min_int; max_wid = max_int;
362
-
prefix = ui.prefix;
363
-
body = ui.body;
364
-
suffix = ui.suffix;
365
-
}
366
-
else match nonflat_cache t.cache rem wid with
367
-
| Some ui -> ui
368
-
| None ->
369
-
let result = match pretty rem wid t.doc with
370
-
| Nonflat_line ui -> Nonflat_line {ui with max_rem = t.req}
371
-
| Nonflat_span ui ->
372
-
Nonflat_span {ui with max_rem = mini t.req ui.max_rem}
373
-
in
374
-
t.cache <- Cache result;
375
-
result
376
-
end
395
+
if t.req <= rem
396
+
then (
397
+
match pretty_flat self with
398
+
| Flat_line ui -> Nonflat_line { min_rem = t.req; max_rem = max_int; ui }
399
+
| Flat_span ui ->
400
+
Nonflat_span
401
+
{ min_rem = t.req
402
+
; max_rem = max_int
403
+
; min_wid = min_int
404
+
; max_wid = max_int
405
+
; prefix = ui.prefix
406
+
; body = ui.body
407
+
; suffix = ui.suffix
408
+
})
409
+
else (
410
+
match nonflat_cache t.cache rem wid with
411
+
| Some ui -> ui
412
+
| None ->
413
+
let result =
414
+
match pretty rem wid t.doc with
415
+
| Nonflat_line ui -> Nonflat_line { ui with max_rem = t.req }
416
+
| Nonflat_span ui -> Nonflat_span { ui with max_rem = mini t.req ui.max_rem }
417
+
in
418
+
t.cache <- Cache result;
419
+
result)
420
+
;;
377
421
378
422
(* -------------------------------------------------------------------------- *)
379
423
···
383
427
match pretty width width doc with
384
428
| Nonflat_line t -> t.ui
385
429
| Nonflat_span t -> Ui.join_y t.prefix (Ui.join_y t.body t.suffix)
430
+
;;
+1
-1
forks/nottui/lib/nottui/nottui.ml
+1
-1
forks/nottui/lib/nottui/nottui.ml
+36
-20
forks/nottui/lib/nottui/nottui_main.ml
+36
-20
forks/nottui/lib/nottui/nottui_main.ml
···
14
14
(** request the focus and add to the focus stack *)
15
15
val request_reversable : handle -> unit
16
16
17
-
(** Release the focus (if the handle has it) and restore the last focus on the stack *)
17
+
(** Release the focus (if the handle has it) and restore the last focus on the
18
+
stack *)
18
19
val release_reversable : handle -> unit
19
20
20
21
type status =
···
61
62
let clock = ref 0
62
63
let currently_focused : var ref = ref (make () |> fst)
63
64
let focus_stack : var list ref = ref []
64
-
let focus_stack_to_str ()=
65
-
(!focus_stack|>List.map Lwd.peek|>List.map (string_of_int)|>String.concat ","|>Printf.sprintf "[%s]")
65
+
66
+
let focus_stack_to_str () =
67
+
!focus_stack
68
+
|> List.map Lwd.peek
69
+
|> List.map string_of_int
70
+
|> String.concat ","
71
+
|> Printf.sprintf "[%s]"
72
+
;;
66
73
67
-
let focusLock= Mutex.create()
74
+
let focusLock = Mutex.create ()
68
75
69
76
let request_var (v : var) =
70
77
incr clock;
···
72
79
currently_focused := v
73
80
;;
74
81
75
-
let request ((v, _) : handle) =
76
-
Mutex.protect focusLock @@ fun _->
77
-
request_var v
82
+
let request ((v, _) : handle) = Mutex.protect focusLock @@ fun _ -> request_var v
78
83
79
84
let release ((v, _) : handle) =
80
-
Mutex.protect focusLock @@ fun _->
85
+
Mutex.protect focusLock @@ fun _ ->
81
86
incr clock;
82
87
Lwd.set v 0
83
88
;;
84
89
85
90
let var_equal a b = Lwd.peek a = Lwd.peek b
86
-
87
91
88
92
let request_reversable ((v, _) : handle) =
89
-
Mutex.protect focusLock @@ fun _->
93
+
Mutex.protect focusLock @@ fun _ ->
90
94
Log.debug (fun m -> m "Maybe requesting reversable focus %d" (Lwd.peek v));
91
95
if not @@ var_equal !currently_focused v
92
96
then (
93
97
focus_stack := !currently_focused :: !focus_stack;
94
98
request_var v;
95
-
Log.debug (fun m -> m "Requested reversable focus %d. stack:%s" (Lwd.peek v) (focus_stack_to_str ())))
99
+
Log.debug (fun m ->
100
+
m "Requested reversable focus %d. stack:%s" (Lwd.peek v) (focus_stack_to_str ())))
96
101
;;
97
102
98
103
let release_reversable ((v, _) : handle) =
99
104
(* Mutex.protect focusLock @@ fun _-> *)
100
105
Log.debug (fun m ->
101
-
m "Maybe release or remove %d from reversable focus stack. stack: %s" (Lwd.peek v) (focus_stack_to_str ()));
106
+
m
107
+
"Maybe release or remove %d from reversable focus stack. stack: %s"
108
+
(Lwd.peek v)
109
+
(focus_stack_to_str ()));
102
110
(* we should only release if we actually have the focus*)
103
111
if var_equal !currently_focused v
104
112
then (
···
323
331
324
332
let pp_main_key ppf = function
325
333
| #Unescape.special as special -> pp_special_key ppf special
326
-
| `Uchar u ->
327
-
if Uchar.is_char u then
328
-
Format.fprintf ppf "'%c'" (Uchar.to_char u)
329
-
else
330
-
Format.fprintf ppf "U+%04X" (Uchar.to_int u)
334
+
| `Uchar u ->
335
+
if Uchar.is_char u
336
+
then Format.fprintf ppf "'%c'" (Uchar.to_char u)
337
+
else Format.fprintf ppf "U+%04X" (Uchar.to_int u)
331
338
| `ASCII c -> Format.fprintf ppf "'%c'" c
332
339
| #semantic_key as sem -> pp_semantic_key ppf sem
333
340
;;
···
702
709
else a, b
703
710
;;
704
711
712
+
(** Allows the element to stretch if possible up to it's max and then returns
713
+
the position change + dimension. *)
705
714
let pack ~max ~fixed ~stretch total g1 g2 =
706
715
(*flex is the space we should expand into if we stretch*)
707
716
let flex = total - fixed in
···
714
723
in
715
724
let gravity = if flex >= 0 then g1 else g2 in
716
725
match gravity with
726
+
(*if the gravity is negative then ofcourse it won't move even if it expands so we return 0 position change *)
717
727
| `Negative -> 0, fixed
718
728
| `Neutral -> flex / 2, fixed
719
729
| `Positive -> flex, fixed)
···
748
758
update_sensors ox oy sw sh mw mh t;
749
759
sensor ()
750
760
| Resize (t, g, _) ->
761
+
(* think this is the real width and the real height plus the change in x and y position to account for that changed size*)
751
762
let open Gravity in
752
763
let dx, rw = pack ~max:t.mw ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
753
764
let dy, rh = pack ~max:t.mh ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
···
1136
1147
?process_event:bool
1137
1148
-> ?timeout:float
1138
1149
-> renderer:Renderer.t
1139
-
-> cache: image option ref
1150
+
-> cache:image option ref
1140
1151
-> Term.t
1141
1152
-> ui Lwd.root
1142
1153
-> unit
···
1166
1177
let size = Term.size term in
1167
1178
let image =
1168
1179
if (not (Lwd.is_damaged root)) && !cache |> Option.is_some
1169
-
then !cache |> Option.get
1180
+
then
1181
+
let a= !cache |> Option.get in
1182
+
Log.debug (fun m -> m "not damaged and cache is some returning cached image");
1183
+
a
1170
1184
else (
1171
1185
let rec stabilize () =
1186
+
Log.debug (fun m -> m "damaged stabilizing");
1172
1187
let tree = Lwd.quick_sample root in
1173
1188
Renderer.update renderer size tree;
1174
1189
let image = Renderer.image renderer in
···
1235
1250
let root = Lwd.observe ~on_invalidate t in
1236
1251
let cache = ref None in
1237
1252
let rec loop () =
1253
+
Log.debug (fun m -> m "loop");
1238
1254
let quit = Lwd.quick_sample quit in
1239
1255
if not quit
1240
1256
then (
1241
-
step ~process_event:true ?timeout:tick_period ~renderer ~cache term root ;
1257
+
step ~process_event:true ?timeout:tick_period ~renderer ~cache term root;
1242
1258
tick ();
1243
1259
loop ())
1244
1260
in
+7
-4
forks/nottui/lib/nottui/nottui_main.mli
+7
-4
forks/nottui/lib/nottui/nottui_main.mli
···
377
377
: ?process_event:bool
378
378
-> ?timeout:float
379
379
-> renderer:Renderer.t
380
-
-> cache: image option ref
380
+
-> cache:image option ref
381
381
-> Term.t
382
382
-> ui Lwd.root
383
383
-> unit
···
416
416
?process_event:bool
417
417
-> ?timeout:float
418
418
-> renderer:Renderer.t
419
-
-> cache: image option ref
419
+
-> cache:image option ref
420
420
-> Term.t
421
421
-> ui Lwd.root
422
422
-> unit
423
423
424
-
val await_read_unix : Unix.file_descr -> float -> [ `NotReady | `Ready | `LwdStateUpdate]
424
+
val await_read_unix
425
+
: Unix.file_descr
426
+
-> float
427
+
-> [ `NotReady | `Ready | `LwdStateUpdate ]
425
428
426
429
(** Run one step of the main loop.
427
430
···
435
438
-> ?process_event:bool
436
439
-> ?timeout:float
437
440
-> renderer:Renderer.t
438
-
-> cache: image option ref
441
+
-> cache:image option ref
439
442
-> Term.t
440
443
-> ui Lwd.root
441
444
-> unit
+33
-33
forks/nottui/lib/nottui/widgets/border_box.ml
+33
-33
forks/nottui/lib/nottui/widgets/border_box.ml
···
45
45
46
46
(** Internal function for rendering a border box with known dimensions and padding.*)
47
47
let border_box_intern
48
-
?(border_attr = A.empty)
49
-
?(label_top = I.empty)
50
-
?(label_bottom = I.empty)
51
-
~w
52
-
~h
53
-
~pad
54
-
~pad_w
55
-
~pad_h
56
-
input
48
+
?(border_attr = A.empty)
49
+
?(label_top = I.empty)
50
+
?(label_bottom = I.empty)
51
+
~w
52
+
~h
53
+
~pad
54
+
~pad_w
55
+
~pad_h
56
+
input
57
57
=
58
58
(*can't go below 1 internal width or things get weird*)
59
59
let h = if pad_h < 1 then Int.max h 1 else h in
···
87
87
open Internal
88
88
89
89
let with_border_attr
90
-
?(pad = neutral_grav)
91
-
?(pad_w = 2)
92
-
?(pad_h = 1)
93
-
?label_top
94
-
?label_bottom
95
-
get_border
96
-
input
90
+
?(pad = neutral_grav)
91
+
?(pad_w = 2)
92
+
?(pad_h = 1)
93
+
?label_top
94
+
?label_bottom
95
+
get_border
96
+
input
97
97
=
98
98
let size = Lwd.var (0, 0) in
99
99
let layout_width = Lwd.var 0 in
···
129
129
;;
130
130
131
131
let focusable
132
-
?pad
133
-
?pad_w
134
-
?pad_h
135
-
?label_top
136
-
?label_bottom
137
-
?(border_attr = A.empty)
138
-
?(focus_attr = A.fg A.blue)
139
-
?(focus = Focus.make ())
140
-
?(on_key = fun _ -> `Unhandled)
141
-
input
132
+
?pad
133
+
?pad_w
134
+
?pad_h
135
+
?label_top
136
+
?label_bottom
137
+
?(border_attr = A.empty)
138
+
?(focus_attr = A.fg A.blue)
139
+
?(focus = Focus.make ())
140
+
?(on_key = fun _ -> `Unhandled)
141
+
input
142
142
=
143
143
let input =
144
144
input
···
168
168
;;
169
169
170
170
let static
171
-
?(pad = neutral_grav)
172
-
?(pad_w = 2)
173
-
?(pad_h = 1)
174
-
?label_top
175
-
?label_bottom
176
-
?(border_attr = A.empty)
177
-
ui
171
+
?(pad = neutral_grav)
172
+
?(pad_w = 2)
173
+
?(pad_h = 1)
174
+
?label_top
175
+
?label_bottom
176
+
?(border_attr = A.empty)
177
+
ui
178
178
=
179
179
let Ui.{ w; h; _ } = Ui.layout_spec ui in
180
180
Internal.border_box_intern
+5
-6
forks/nottui/lib/nottui/widgets/lists.ml
+5
-6
forks/nottui/lib/nottui/widgets/lists.ml
···
9
9
;;
10
10
11
11
let vlist_with
12
-
?(bullet = "- ")
13
-
?(filter = Lwd.return (fun _ -> true))
14
-
(f : 'a -> Ui.t Lwd.t)
15
-
(l : 'a list Lwd.t)
12
+
?(bullet = "- ")
13
+
?(filter = Lwd.return (fun _ -> true))
14
+
(f : 'a -> Ui.t Lwd.t)
15
+
(l : 'a list Lwd.t)
16
16
: Ui.t Lwd.t
17
17
=
18
18
let open Lwd.Infix in
···
29
29
in
30
30
let l = l |>$ List.map (fun x -> x, Lwd.map ~f:(Ui.join_x (string bullet)) @@ f x) in
31
31
let l_filter : _ list Lwd.t =
32
-
filter
33
-
>>= fun filter ->
32
+
filter >>= fun filter ->
34
33
l >|= filter_map_ [] (fun (x, ui) -> if filter x then Some ui else None)
35
34
in
36
35
l_filter >>= vbox
+59
-67
forks/nottui/lib/nottui/widgets/nottui_widgets.ml
+59
-67
forks/nottui/lib/nottui/widgets/nottui_widgets.ml
···
1
1
open Lwd.Infix
2
-
3
2
open Notty
4
3
open Nottui_main
5
4
include Shared
···
30
29
let splitter =
31
30
Ui.mouse_area
32
31
(fun ~x:_ ~y:_ -> function
33
-
| `Left ->
34
-
`Grab
35
-
( (fun ~x ~y:_ ->
36
-
match Lwd.peek state_var with
37
-
| Split { pos; max } ->
38
-
Lwd.set state_var (Re_split { pos; max; at = x })
39
-
| Re_split { pos; max; at } ->
40
-
if at <> x then Lwd.set state_var (Re_split { pos; max; at = x }))
41
-
, fun ~x:_ ~y:_ -> () )
42
-
| _ -> `Unhandled)
32
+
| `Left ->
33
+
`Grab
34
+
( (fun ~x ~y:_ ->
35
+
match Lwd.peek state_var with
36
+
| Split { pos; max } ->
37
+
Lwd.set state_var (Re_split { pos; max; at = x })
38
+
| Re_split { pos; max; at } ->
39
+
if at <> x then Lwd.set state_var (Re_split { pos; max; at = x }))
40
+
, fun ~x:_ ~y:_ -> () )
41
+
| _ -> `Unhandled)
43
42
splitter
44
43
in
45
44
let ui = Ui.join_x l (Ui.join_x splitter r) in
···
50
49
| Re_split { at; _ } ->
51
50
Ui.transient_sensor
52
51
(fun ~x ~y:_ ~w ~h:_ () ->
53
-
let newpos = clampi (at - x) ~min:0 ~max:w in
54
-
Lwd.set state_var (Split { pos = newpos; max = w }))
52
+
let newpos = clampi (at - x) ~min:0 ~max:w in
53
+
Lwd.set state_var (Split { pos = newpos; max = w }))
55
54
ui
56
55
in
57
56
ui
···
71
70
let splitter =
72
71
Ui.mouse_area
73
72
(fun ~x:_ ~y:_ -> function
74
-
| `Left ->
75
-
`Grab
76
-
( (fun ~x:_ ~y ->
77
-
match Lwd.peek state_var with
78
-
| Split { pos; max } ->
79
-
Lwd.set state_var (Re_split { pos; max; at = y })
80
-
| Re_split { pos; max; at } ->
81
-
if at <> y then Lwd.set state_var (Re_split { pos; max; at = y }))
82
-
, fun ~x:_ ~y:_ -> () )
83
-
| _ -> `Unhandled)
73
+
| `Left ->
74
+
`Grab
75
+
( (fun ~x:_ ~y ->
76
+
match Lwd.peek state_var with
77
+
| Split { pos; max } ->
78
+
Lwd.set state_var (Re_split { pos; max; at = y })
79
+
| Re_split { pos; max; at } ->
80
+
if at <> y then Lwd.set state_var (Re_split { pos; max; at = y }))
81
+
, fun ~x:_ ~y:_ -> () )
82
+
| _ -> `Unhandled)
84
83
splitter
85
84
in
86
85
let ui = Ui.join_y top (Ui.join_y splitter bot) in
···
91
90
| Re_split { at; _ } ->
92
91
Ui.transient_sensor
93
92
(fun ~x:_ ~y ~w:_ ~h () ->
94
-
let newpos = clampi (at - y) ~min:0 ~max:h in
95
-
Lwd.set state_var (Split { pos = newpos; max = h }))
93
+
let newpos = clampi (at - y) ~min:0 ~max:h in
94
+
Lwd.set state_var (Split { pos = newpos; max = h }))
96
95
ui
97
96
in
98
97
ui
···
111
110
@@
112
111
if Focus.has_focus focus
113
112
then (
114
-
let attr = attr_clickable in
113
+
let attr = A.(st italic) in
115
114
let len = String.length text in
116
115
(if pos >= len
117
116
then [ I.string attr text ]
···
119
118
@
120
119
if pos < String.length text
121
120
then
122
-
[ I.string A.(bg lightred) (sub' text pos 1)
121
+
[ I.string A.(bg lightblue ++ fg black ++ attr ++ st bold) (sub' text pos 1)
123
122
; I.string attr (sub' text (pos + 1) (len - pos - 1))
124
123
]
125
-
else [ I.string A.(bg lightred) " " ])
124
+
else [ I.string A.(bg lightblue ++ fg black) " " ])
126
125
else [ I.string A.(st underline) (if text = "" then " " else text) ]
127
126
in
128
127
let handler = function
···
190
189
Lwd.map2 state node ~f:(fun state content -> Ui.mouse_area (mouse_grab state) content)
191
190
;;
192
191
193
-
194
-
195
192
(** Prints the summary, but calls [f()] to compute a sub-widget
196
193
when clicked on. Useful for displaying deep trees. Mouse only *)
197
194
let unfoldable ?(folded_by_default = true) summary (f : unit -> Ui.t Lwd.t) : Ui.t Lwd.t =
198
195
let open Lwd.Infix in
199
196
let opened = Lwd.var (not folded_by_default) in
200
197
let fold_content =
201
-
Lwd.get opened
202
-
>>= function
198
+
Lwd.get opened >>= function
203
199
| true ->
204
200
(* call [f] and pad a bit *)
205
201
f () |> Lwd.map ~f:(Ui.join_x (string " "))
···
207
203
in
208
204
(* pad summary with a "> " when it's opened *)
209
205
let summary =
210
-
Lwd.get opened
211
-
>>= fun op ->
212
-
summary
213
-
>|= fun s ->
206
+
Lwd.get opened >>= fun op ->
207
+
summary >|= fun s ->
214
208
Ui.hcat [ string ~attr:attr_clickable (if op then "v" else ">"); string " "; s ]
215
209
in
216
210
let cursor ~x:_ ~y:_ = function
···
237
231
else Ui.join_x summary fold)
238
232
;;
239
233
240
-
241
-
242
234
(** A grid layout, with alignment in all rows/columns.
243
235
@param max_h maximum height of a cell
244
236
@param max_w maximum width of a cell
···
253
245
TODO: horizontal rule below headers
254
246
TODO: headers *)
255
247
let grid
256
-
?max_h
257
-
?max_w
258
-
?pad
259
-
?crop
260
-
?bg
261
-
?(h_space = 0)
262
-
?(v_space = 0)
263
-
?(headers : Ui.t Lwd.t list option)
264
-
(rows : Ui.t Lwd.t list list)
248
+
?max_h
249
+
?max_w
250
+
?pad
251
+
?crop
252
+
?bg
253
+
?(h_space = 0)
254
+
?(v_space = 0)
255
+
?(headers : Ui.t Lwd.t list option)
256
+
(rows : Ui.t Lwd.t list list)
265
257
: Ui.t Lwd.t
266
258
=
267
259
let rows =
···
270
262
| Some r -> r :: rows
271
263
in
272
264
(* build a [ui list list Lwd.t] *)
273
-
Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows
274
-
>>= fun (rows : Ui.t list list) ->
265
+
Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows >>= fun (rows : Ui.t list list) ->
275
266
(* determine width of each column and height of each row *)
276
267
let n_cols = List.fold_left (fun n r -> maxi n (List.length r)) 0 rows in
277
268
let col_widths = Array.make n_cols 1 in
278
269
List.iter
279
270
(fun row ->
280
-
List.iteri
281
-
(fun col_j cell ->
282
-
let w = (Ui.layout_spec cell).Ui.w in
283
-
col_widths.(col_j) <- maxi col_widths.(col_j) w)
284
-
row)
271
+
List.iteri
272
+
(fun col_j cell ->
273
+
let w = (Ui.layout_spec cell).Ui.w in
274
+
col_widths.(col_j) <- maxi col_widths.(col_j) w)
275
+
row)
285
276
rows;
286
277
(match max_w with
287
278
| None -> ()
···
301
292
let rows =
302
293
List.map
303
294
(fun row ->
304
-
let row_h = List.fold_left (fun n c -> maxi n (Ui.layout_spec c).Ui.h) 0 row in
305
-
let row_h =
306
-
match max_h with
307
-
| None -> row_h
308
-
| Some max_h -> mini row_h max_h
309
-
in
310
-
let row =
311
-
List.mapi (fun i c -> Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c) row
312
-
in
313
-
Lwd_utils.reduce pack_pad_x row)
295
+
let row_h = List.fold_left (fun n c -> maxi n (Ui.layout_spec c).Ui.h) 0 row in
296
+
let row_h =
297
+
match max_h with
298
+
| None -> row_h
299
+
| Some max_h -> mini row_h max_h
300
+
in
301
+
let row =
302
+
List.mapi
303
+
(fun i c -> Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c)
304
+
row
305
+
in
306
+
Lwd_utils.reduce pack_pad_x row)
314
307
rows
315
308
in
316
309
(* TODO: mouse and keyboard handling *)
···
322
315
let button_of ui f =
323
316
Ui.mouse_area
324
317
(fun ~x:_ ~y:_ _ ->
325
-
f ();
326
-
`Handled)
318
+
f ();
319
+
`Handled)
327
320
ui
328
321
;;
329
322
330
323
(** A clickable button that calls [f] when clicked, labelled with a string. *)
331
324
let button ?(attr = attr_clickable) s f = button_of (string ~attr s) f
332
-
333
325
334
326
let toggle, toggle' =
335
327
let toggle_ st (lbl : string Lwd.t) (f : bool -> unit) : Ui.t Lwd.t =
+20
-20
forks/nottui/lib/nottui/widgets/nottui_widgets.mli
+20
-20
forks/nottui/lib/nottui/widgets/nottui_widgets.mli
···
1
1
open Notty
2
2
open Nottui_main
3
3
include module type of Shared
4
-
val empty_lwd : ui Lwd.t
5
4
5
+
val empty_lwd : ui Lwd.t
6
6
7
7
(** Vertical pane that can be dragged to be bigger or smaller *)
8
8
val v_pane : ui Lwd.t -> ui Lwd.t -> ui Lwd.t
9
9
10
10
(** horizontal pane that can be dragged to be bigger or smaller *)
11
-
val h_pane : ?splitter_color:(Notty.A.color)-> ui Lwd.t -> ui Lwd.t -> ui Lwd.t
12
-
11
+
val h_pane : ?splitter_color:Notty.A.color -> ui Lwd.t -> ui Lwd.t -> ui Lwd.t
13
12
14
13
(** An editable text field.
15
14
Supports navigating with arrow keys *)
16
-
val edit_field :
17
-
?focus:Focus.handle ->
18
-
(string * int) Lwd.t ->
19
-
on_change:(string * int -> unit) ->
20
-
on_submit:(string * int -> unit) -> ui Lwd.t
21
-
15
+
val edit_field
16
+
: ?focus:Focus.handle
17
+
-> (string * int) Lwd.t
18
+
-> on_change:(string * int -> unit)
19
+
-> on_submit:(string * int -> unit)
20
+
-> ui Lwd.t
22
21
23
22
(** Shows the summary when folded, calls [f()] to compute a sub-widget when clicked on. Useful for displaying deep trees. Mouse only *)
24
-
val unfoldable :
25
-
?folded_by_default:bool ->
26
-
ui Lwd.t -> (unit -> ui Lwd.t) -> ui Lwd.t
27
-
23
+
val unfoldable : ?folded_by_default:bool -> ui Lwd.t -> (unit -> ui Lwd.t) -> ui Lwd.t
28
24
29
-
val grid :
30
-
?max_h:int -> ?max_w:int ->
31
-
?pad:gravity -> ?crop:gravity -> ?bg:attr ->
32
-
?h_space:int -> ?v_space:int ->
33
-
?headers:ui Lwd.t list ->
34
-
ui Lwd.t list list -> ui Lwd.t
25
+
val grid
26
+
: ?max_h:int
27
+
-> ?max_w:int
28
+
-> ?pad:gravity
29
+
-> ?crop:gravity
30
+
-> ?bg:attr
31
+
-> ?h_space:int
32
+
-> ?v_space:int
33
+
-> ?headers:ui Lwd.t list
34
+
-> ui Lwd.t list list
35
+
-> ui Lwd.t
35
36
36
37
(** A clickable button that calls [f] when clicked, labelled with a string. *)
37
38
val button : ?attr:attr -> string -> (unit -> unit) -> ui
38
-
39
39
40
40
(** A toggle button that invokes the callback when toggled*)
41
41
val toggle : ?init:bool -> string Lwd.t -> (bool -> unit) -> ui Lwd.t
+10
-12
forks/nottui/lib/nottui/widgets/old.ml
+10
-12
forks/nottui/lib/nottui/widgets/old.ml
···
55
55
let catchall =
56
56
Ui.mouse_area
57
57
(fun ~x:_ ~y:_ -> function
58
-
| `Left ->
59
-
Lwd_table.remove row;
60
-
`Handled
61
-
| _ -> `Handled)
58
+
| `Left ->
59
+
Lwd_table.remove row;
60
+
`Handled
61
+
| _ -> `Handled)
62
62
(Ui.resize ~sw:1 ~sh:1 ~mw:1000 ~mh:1000 Ui.empty)
63
63
in
64
64
Ui.join_z catchall @@ Ui.join_y v_pad @@ Ui.join_x h_pad @@ Ui.join_z bg body)
···
305
305
| [] -> Lwd.return Ui.empty
306
306
| _ ->
307
307
let cur = Lwd.var 0 in
308
-
Lwd.get cur
309
-
>>= fun idx_sel ->
308
+
Lwd.get cur >>= fun idx_sel ->
310
309
let _, f = List.nth tabs idx_sel in
311
310
let tab_bar =
312
311
tabs
···
315
314
let tab_annot = printf ~attr "[%s]" s in
316
315
Ui.mouse_area
317
316
(fun ~x:_ ~y:_ l ->
318
-
if l = `Left
319
-
then (
320
-
Lwd.set cur i;
321
-
`Handled)
322
-
else `Unhandled)
317
+
if l = `Left
318
+
then (
319
+
Lwd.set cur i;
320
+
`Handled)
321
+
else `Unhandled)
323
322
tab_annot)
324
323
|> Ui.hcat
325
324
in
326
325
f () >|= Ui.join_y tab_bar
327
326
;;
328
-
+8
-15
forks/nottui/lib/nottui/widgets/overlays.ml
+8
-15
forks/nottui/lib/nottui/widgets/overlays.ml
···
25
25
let set_bg ~attr ui =
26
26
let size = Lwd.var (0, 0) in
27
27
W.zbox
28
-
[ (size
29
-
|> Lwd.get
30
-
|>$ fun (w, h) -> I.char attr ' ' w h |> Ui.atom |> Ui.resize ~w:0 ~h:0)
28
+
[ ( size |> Lwd.get |>$ fun (w, h) ->
29
+
I.char attr ' ' w h |> Ui.atom |> Ui.resize ~w:0 ~h:0 )
31
30
; ui |>$ Ui.size_sensor (fun ~w ~h -> if (w, h) <> Lwd.peek size then size $= (w, h))
32
31
]
33
32
;;
···
50
49
let$* show_prompt_val = show_prompt in
51
50
let prompt_ui =
52
51
show_prompt_val
53
-
|> Option.map
54
-
@@ fun (label, label_bottom, on_exit, prompt_content) ->
52
+
|> Option.map @@ fun (label, label_bottom, on_exit, prompt_content) ->
55
53
(*we need focus because the base ui is rendering first and so *)
56
54
Focus.request_reversable focus;
57
55
let$* label_bottom = label_bottom in
···
96
94
let prompt_args =
97
95
let$ show_prompt_val = Lwd.get show_prompt_var in
98
96
show_prompt_val
99
-
|> Option.map
100
-
@@ fun { label; pre_fill; on_exit } ->
97
+
|> Option.map @@ fun { label; pre_fill; on_exit } ->
101
98
let on_exit result =
102
99
Focus.release_reversable focus;
103
100
show_prompt_var $= None;
···
147
144
let prompt_args =
148
145
let$ show_prompt_val = Lwd.get show_prompt_var in
149
146
show_prompt_val
150
-
|> Option.map
151
-
@@ fun { label; items; on_exit } ->
147
+
|> Option.map @@ fun { label; items; on_exit } ->
152
148
let on_exit result =
153
149
Focus.release_reversable focus;
154
150
show_prompt_var $= None;
···
195
191
let prompt_args =
196
192
let$ show_prompt_val = Lwd.get show_prompt_var in
197
193
show_prompt_val
198
-
|> Option.map
199
-
@@ fun { label; items; filter_predicate; on_exit } ->
194
+
|> Option.map @@ fun { label; items; filter_predicate; on_exit } ->
200
195
let on_exit result =
201
196
Focus.release_reversable focus;
202
197
show_prompt_var $= None;
···
230
225
let$ prompt_field = content in
231
226
prompt_field |> Ui.resize ~w:5 ~sw:1
232
227
in
233
-
ui
234
-
|> BB.focusable ~focus ~label_top:label ?on_key
235
-
|> clear_bg
228
+
ui |> BB.focusable ~focus ~label_top:label ?on_key |> clear_bg
236
229
(*This is a little confusing, but by wrapping the content in 2 nested keyboard areas we make it the user cannot escape the popup.
237
230
becasue focus moves between keyboard areas within a current keyboard area by adding 2 we make escape impossible *)
238
231
(* |> Lwd.map ~f:(fun ui -> *)
239
-
(* ui |> Ui.keyboard_area (fun x -> `Unhandled)) *)
232
+
(* ui |> Ui.keyboard_area (fun x -> `Unhandled)) *)
240
233
| None ->
241
234
Focus.release_reversable focus;
242
235
Ui.empty |> Lwd.pure
+45
-44
forks/nottui/lib/nottui/widgets/overlays.mli
+45
-44
forks/nottui/lib/nottui/widgets/overlays.mli
···
10
10
(**Clears anything behind the given area*)
11
11
val clear_bg : Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t
12
12
13
-
14
-
15
-
(** Config for a text_prompt*)
16
-
type text_prompt_data = {
17
-
label : string;
18
-
pre_fill : string;
19
-
on_exit : [ `Closed | `Finished of string ] -> unit;
20
-
}
13
+
(** Config for a text_prompt*)
14
+
type text_prompt_data =
15
+
{ label : string
16
+
; pre_fill : string
17
+
; on_exit : [ `Closed | `Finished of string ] -> unit
18
+
}
21
19
22
20
(** Text box prompt that takes user input then calls [on_exit] with the result.
23
21
24
22
This will display ontop of any ui it is passed when show_prompt_var is [Some].*)
25
23
26
-
val text_prompt :
27
-
?pad_h:int ->
28
-
?pad_w:int ->
29
-
?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t) ->
30
-
?focus:Nottui_main.Focus.handle ->
31
-
?char_count:bool ->
32
-
show_prompt_var:text_prompt_data option Lwd.var ->
33
-
Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t
24
+
val text_prompt
25
+
: ?pad_h:int
26
+
-> ?pad_w:int
27
+
-> ?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t)
28
+
-> ?focus:Nottui_main.Focus.handle
29
+
-> ?char_count:bool
30
+
-> show_prompt_var:text_prompt_data option Lwd.var
31
+
-> Nottui_main.ui Lwd.t
32
+
-> Nottui_main.ui Lwd.t
34
33
35
34
(** Config for a selection_list_prompt*)
36
-
type 'a selection_list_prompt_data = {
37
-
label : string;
38
-
items : 'a Selection_list.multi_selectable_item list Lwd.t;
39
-
on_exit : [ `Closed | `Finished of 'a ] -> unit;
40
-
}
35
+
type 'a selection_list_prompt_data =
36
+
{ label : string
37
+
; items : 'a Selection_list.multi_selectable_item list Lwd.t
38
+
; on_exit : [ `Closed | `Finished of 'a ] -> unit
39
+
}
41
40
42
41
(** Selection_list prompt.
43
42
44
43
This will display ontop of any ui it is passed when show_prompt_var is [Some].
45
44
@param modify_body Function that takes the completed body of the prompt, incase you want to resize it or otherwise change it
46
45
*)
47
-
val selection_list_prompt :
48
-
?pad_w:int ->
49
-
?pad_h:int ->
50
-
?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t) ->
51
-
?focus:Nottui_main.Focus.handle ->
52
-
show_prompt_var:'a selection_list_prompt_data option Lwd.var ->
53
-
Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t
54
-
46
+
val selection_list_prompt
47
+
: ?pad_w:int
48
+
-> ?pad_h:int
49
+
-> ?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t)
50
+
-> ?focus:Nottui_main.Focus.handle
51
+
-> show_prompt_var:'a selection_list_prompt_data option Lwd.var
52
+
-> Nottui_main.ui Lwd.t
53
+
-> Nottui_main.ui Lwd.t
55
54
56
55
type 'a filterable_selection_list_prompt_data =
57
56
{ label : string
58
57
; items : 'a Selection_list.multi_selectable_item list Lwd.t
59
-
;filter_predicate:(string-> 'a-> bool)
58
+
; filter_predicate : string -> 'a -> bool
60
59
; on_exit : [ `Closed | `Finished of 'a ] -> unit
61
60
}
61
+
62
62
(** Selection_list prompt that is filterable.
63
63
64
64
This will display ontop of any ui it is passed when show_prompt_var is [Some].
65
65
@param modify_body Function that takes the completed body of the prompt, incase you want to resize it or otherwise change it
66
66
*)
67
-
val selection_list_prompt_filterable :
68
-
?pad_w:int ->
69
-
?pad_h:int ->
70
-
?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t) ->
71
-
?focus:Nottui_main.Focus.handle ->
72
-
show_prompt_var:'a filterable_selection_list_prompt_data option Lwd.var ->
73
-
Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t
74
-
67
+
val selection_list_prompt_filterable
68
+
: ?pad_w:int
69
+
-> ?pad_h:int
70
+
-> ?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t)
71
+
-> ?focus:Nottui_main.Focus.handle
72
+
-> show_prompt_var:'a filterable_selection_list_prompt_data option Lwd.var
73
+
-> Nottui_main.ui Lwd.t
74
+
-> Nottui_main.ui Lwd.t
75
75
76
-
(**This is a simple popup that can show ontop of other ui elements *)
77
-
val popup :
78
-
?focus:Nottui_main.Focus.handle ->
79
-
?on_key:(Nottui_main.Ui.key->Nottui_main.Ui.may_handle)->
80
-
show_popup_var:(Nottui_main.ui Lwd.t * string) option Lwd.var ->
81
-
Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t
76
+
(**This is a simple popup that can show ontop of other ui elements *)
77
+
val popup
78
+
: ?focus:Nottui_main.Focus.handle
79
+
-> ?on_key:(Nottui_main.Ui.key -> Nottui_main.Ui.may_handle)
80
+
-> show_popup_var:(Nottui_main.ui Lwd.t * string) option Lwd.var
81
+
-> Nottui_main.ui Lwd.t
82
+
-> Nottui_main.ui Lwd.t
+5
-1
forks/nottui/lib/nottui/widgets/scroll.mli
+5
-1
forks/nottui/lib/nottui/widgets/scroll.mli
···
2
2
val v_area : ?reset_on_content_change:bool -> Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t
3
3
4
4
(** A scroll area that allows keyboard scrolling in both x and y directions*)
5
-
val area : ?reset_on_content_change:bool -> ?focus:Nottui_main.Focus.status -> Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t
5
+
val area
6
+
: ?reset_on_content_change:bool
7
+
-> ?focus:Nottui_main.Focus.status
8
+
-> Nottui_main.ui Lwd.t
9
+
-> Nottui_main.ui Lwd.t
6
10
7
11
(** A scroll area that allows keyboard scrolling in both x and y directions and has no limits.
8
12
This might be useful if you have some very dynamic content and the usual scroll area doesn't know how big things are*)
+69
-72
forks/nottui/lib/nottui/widgets/selection_list.ml
+69
-72
forks/nottui/lib/nottui/widgets/selection_list.ml
···
16
16
| Filler of Ui.t Lwd.t
17
17
18
18
module MyMap = Map.Make (Int)
19
-
let singe_space= Shared.string " ";;
19
+
20
+
let singe_space = Shared.string " "
20
21
21
22
(** Get a map of all the selectable items*)
22
23
let get_selectable_items_map (items : 'a maybe_multi_selectable array Lwd.t) =
···
26
27
items
27
28
|> Array.fold_left
28
29
(fun map item ->
29
-
match item with
30
-
| Selectable item -> MyMap.add item.id (item.id, item) map
31
-
| Filler _ -> map)
30
+
match item with
31
+
| Selectable item -> MyMap.add item.id (item.id, item) map
32
+
| Filler _ -> map)
32
33
MyMap.empty
33
34
in
34
35
selectable_items
···
46
47
items
47
48
|> Array.fold_left
48
49
(fun (i, selectable_count) item ->
49
-
match item with
50
-
| Selectable item ->
51
-
(*copy any seletable items to the new array*)
52
-
Array.set selectable_items selectable_count (i, item);
53
-
i + 1, selectable_count + 1
54
-
| Filler _ -> i + 1, selectable_count)
50
+
match item with
51
+
| Selectable item ->
52
+
(*copy any seletable items to the new array*)
53
+
Array.set selectable_items selectable_count (i, item);
54
+
i + 1, selectable_count + 1
55
+
| Filler _ -> i + 1, selectable_count)
55
56
(0, 0)
56
57
in
57
58
Array.sub selectable_items 0 final_len
···
60
61
;;
61
62
62
63
let multi_selection_list_exclusions
63
-
?(focus = Focus.make ())
64
-
?reset_selections
65
-
?(on_selection_change = fun ~hovered ~selected -> ())
66
-
~custom_handler
67
-
(items : 'a maybe_multi_selectable array Lwd.t)
64
+
?(focus = Focus.make ())
65
+
?reset_selections
66
+
?(on_selection_change = fun ~hovered ~selected -> ())
67
+
~custom_handler
68
+
(items : 'a maybe_multi_selectable array Lwd.t)
68
69
=
69
70
(*
70
71
The rough overview is:
···
111
112
selectable_items
112
113
|> Array.fold_left
113
114
(fun (count, acc) (idx, item) ->
114
-
let nCount = count + 1 in
115
-
match acc with
116
-
| `Found _ -> nCount, acc
117
-
| `Same_idx _ ->
118
-
if item.id = hovered_id
119
-
then nCount, `Found (item.id, idx, count)
120
-
else nCount, acc
121
-
| `Searching _ ->
122
-
if item.id = hovered_id
123
-
then nCount, `Found (item.id, idx, count)
124
-
else if count == hovered_selection_idx
125
-
then nCount, `Same_idx (item.id, idx, count)
126
-
else nCount, `Searching (item.id, idx, count))
115
+
let nCount = count + 1 in
116
+
match acc with
117
+
| `Found _ -> nCount, acc
118
+
| `Same_idx _ ->
119
+
if item.id = hovered_id
120
+
then nCount, `Found (item.id, idx, count)
121
+
else nCount, acc
122
+
| `Searching _ ->
123
+
if item.id = hovered_id
124
+
then nCount, `Found (item.id, idx, count)
125
+
else if count == hovered_selection_idx
126
+
then nCount, `Same_idx (item.id, idx, count)
127
+
else nCount, `Searching (item.id, idx, count))
127
128
(0, `Searching (0, 0, 0))
128
129
|> snd
129
130
|> function
···
144
145
and$ _ = Lwd.get hover_changed
145
146
and$ selected_items = Lwd.get selected_items_var in
146
147
(* FIXME: can i just get rid of all the other parts of the hovered var now that we store the id?*)
147
-
let hovered_id, _, _= !hovered_var in
148
+
let hovered_id, _, _ = !hovered_var in
148
149
(*==== Rendering The list ====*)
149
150
(* Ui.vcat can be a little weird when the *)
150
151
if items |> Array.length = 0
···
154
155
|> Array.mapi (fun i x ->
155
156
match x with
156
157
(*Becasue selectable has a space used for the selection pointer, filler also needs a space*)
157
-
| Filler ui -> ui|>$(fun x-> Ui.hcat[ singe_space ; x])
158
+
| Filler ui -> ui |>$ fun x -> Ui.hcat [ singe_space; x ]
158
159
| Selectable x ->
159
160
let hovered = hovered_id == x.id in
160
161
let selected = selected_items |> MyMap.mem x.id in
···
251
252
;;
252
253
253
254
let selection_list_exclusions
254
-
?(focus = Focus.make ())
255
-
?(on_selection_change = fun _ -> ())
256
-
~custom_handler
257
-
(items : 'a maybe_multi_selectable array Lwd.t)
255
+
?(focus = Focus.make ())
256
+
?(on_selection_change = fun _ -> ())
257
+
~custom_handler
258
+
(items : 'a maybe_multi_selectable array Lwd.t)
258
259
=
259
260
(*
260
261
The rough overview is:
···
300
301
|> Array.mapi (fun i x ->
301
302
match x with
302
303
(*Becasue selectable has a space used for the selection pointer, filler also needs a space*)
303
-
| Filler ui -> ui|>$(fun x-> Ui.hcat[ singe_space ; x])
304
+
| Filler ui -> ui |>$ fun x -> Ui.hcat [ singe_space; x ]
304
305
| Selectable x ->
305
306
if hovered == i
306
307
then
···
393
394
;;
394
395
395
396
let multi_selection_list_custom
396
-
?(focus = Focus.make ())
397
-
?reset_selections
398
-
?(on_selection_change = fun ~hovered ~selected -> ())
399
-
~custom_handler
400
-
(items : 'a multi_selectable_item list Lwd.t)
397
+
?(focus = Focus.make ())
398
+
?reset_selections
399
+
?(on_selection_change = fun ~hovered ~selected -> ())
400
+
~custom_handler
401
+
(items : 'a multi_selectable_item list Lwd.t)
401
402
=
402
403
multi_selection_list_exclusions
403
404
~focus
404
405
?reset_selections
405
406
~on_selection_change
406
407
~custom_handler
407
-
(items
408
-
|>$ fun items ->
409
-
let selectable_items = Array.make (List.length items) (Obj.magic ()) in
410
-
items |> List.iteri (fun i x -> Array.set selectable_items i (Selectable x));
411
-
selectable_items)
408
+
( items |>$ fun items ->
409
+
let selectable_items = Array.make (List.length items) (Obj.magic ()) in
410
+
items |> List.iteri (fun i x -> Array.set selectable_items i (Selectable x));
411
+
selectable_items )
412
412
;;
413
413
414
414
let selection_list_custom
415
-
?(focus = Focus.make ())
416
-
?(on_selection_change = fun _ -> ())
417
-
~custom_handler
418
-
(items : 'a multi_selectable_item list Lwd.t)
415
+
?(focus = Focus.make ())
416
+
?(on_selection_change = fun _ -> ())
417
+
~custom_handler
418
+
(items : 'a multi_selectable_item list Lwd.t)
419
419
=
420
420
selection_list_exclusions
421
421
~focus
422
422
~on_selection_change
423
423
~custom_handler
424
-
(items
425
-
|>$ fun items ->
426
-
let selectable_items = Array.make (List.length items) (Obj.magic ()) in
427
-
items |> List.iteri (fun i x -> Array.set selectable_items i (Selectable x));
428
-
selectable_items)
424
+
( items |>$ fun items ->
425
+
let selectable_items = Array.make (List.length items) (Obj.magic ()) in
426
+
items |> List.iteri (fun i x -> Array.set selectable_items i (Selectable x));
427
+
selectable_items )
429
428
;;
430
429
431
430
let filterable_selection_list_custom
432
-
?(focus = Focus.make ())
433
-
~(filter_predicate : string -> 'a -> bool)
434
-
~custom_handler
435
-
~filter_text_var
436
-
(items : 'a multi_selectable_item list Lwd.t)
431
+
?(focus = Focus.make ())
432
+
~(filter_predicate : string -> 'a -> bool)
433
+
~custom_handler
434
+
~filter_text_var
435
+
(items : 'a multi_selectable_item list Lwd.t)
437
436
=
438
437
(*filter the list whenever the input changes*)
439
438
let items =
···
454
453
;;
455
454
456
455
let filterable_selection_list
457
-
?(pad_w = 1)
458
-
?(pad_h = 0)
459
-
?(focus = Focus.make ())
460
-
~filter_predicate
461
-
?(on_esc = fun _ -> ())
462
-
~on_confirm
463
-
list_items
456
+
?(pad_w = 1)
457
+
?(pad_h = 0)
458
+
?(focus = Focus.make ())
459
+
~filter_predicate
460
+
?(on_esc = fun _ -> ())
461
+
~on_confirm
462
+
list_items
464
463
=
465
464
let filter_text_var = Lwd.var "" in
466
465
let filter_text_ui =
···
490
489
let max_width = Lwd.var 5 in
491
490
vbox
492
491
[ filter_text_ui |> Border_box.box ~pad_w ~pad_h
493
-
; (list_ui
494
-
|> Border_box.box ~pad_w ~pad_h
495
-
|>$ fun x ->
496
-
let mw = (x |> Ui.layout_spec).mw in
497
-
if mw > Lwd.peek max_width then max_width $= mw;
498
-
x)
492
+
; ( list_ui |> Border_box.box ~pad_w ~pad_h |>$ fun x ->
493
+
let mw = (x |> Ui.layout_spec).mw in
494
+
if mw > Lwd.peek max_width then max_width $= mw;
495
+
x )
499
496
]
500
497
|> Lwd.map2 (Lwd.get max_width) ~f:(fun mw ui -> ui |> Ui.resize ~mw)
501
498
;;
+1
-1
forks/nottui/lib/nottui/widgets/selection_list.mli
+1
-1
forks/nottui/lib/nottui/widgets/selection_list.mli
···
4
4
(**Selectable list item with a ui and some data *)
5
5
type 'a multi_selectable_item =
6
6
{ data : 'a
7
-
(**info attached to each ui elment in the list, used for filtering and on_select callback *)
7
+
(**info attached to each ui elment in the list, used for filtering and on_select callback *)
8
8
; id : int
9
9
; ui : selected:bool -> hovered:bool -> Ui.t Lwd.t
10
10
}
+2
-4
forks/nottui/lib/nottui/widgets/wip.ml
+2
-4
forks/nottui/lib/nottui/widgets/wip.ml
···
67
67
Focus.request x;
68
68
focused := focused_idx - 1);
69
69
`Handled
70
-
| _ ->
71
-
`Unhandled
70
+
| _ -> `Unhandled
72
71
else fun _ -> `Unhandled))
73
72
|> Border_box.with_border_attr
74
73
(let$ focus = focus |> Focus.status |>$ Focus.has_focus in
···
120
119
Focus.request x;
121
120
focused := focused_idx - 1);
122
121
`Handled
123
-
| _ ->
124
-
`Unhandled
122
+
| _ -> `Unhandled
125
123
else fun _ -> `Unhandled))
126
124
|> Border_box.with_border_attr
127
125
(let$ focus = focus |> Focus.status |>$ Focus.has_focus in
+1
forks/nottui/lib/nottui_picos/dune
+1
forks/nottui/lib/nottui_picos/dune
+16
-2
forks/nottui/lib/nottui_picos/nottui_picos.ml
+16
-2
forks/nottui/lib/nottui_picos/nottui_picos.ml
···
8
8
open Notty
9
9
open Notty_unix
10
10
11
+
module Log = (val Logs.src_log (Logs.Src.create "nottui_picos") : Logs.LOG)
12
+
11
13
(*Super simple method for tracking invalidations that occur outside of a computation using picos.
12
14
We already track and apply invaldations that happen within a ui recompute
13
15
*)
···
17
19
let start_tracking tracker = tracker := Computation.create ()
18
20
let create () : t = Computation.create () |> ref
19
21
let invalidated_evt tracker = Event.from_computation !tracker
22
+
(* TODO: add a slight delay to the invalidation so that if many invalidations come in concurrently it batches them. Something like 5ms *)
20
23
let invalidate (tracker : t) = Computation.finish !tracker
21
24
end
22
25
···
34
37
; It.invalidated_evt invalidation_tracker
35
38
|> Event.map (fun _ -> `LwdStateUpdate)
36
39
]
37
-
in
40
+
in
38
41
ret
39
42
in
40
43
select ()
···
53
56
let size = Term.size term in
54
57
let image =
55
58
if (not (Lwd.is_damaged root)) && !cache |> Option.is_some
56
-
then !cache |> Option.get
59
+
then
60
+
let a= !cache |> Option.get in
61
+
(* Log.debug (fun m -> m "not damaged and cache is some returning cached image"); *)
62
+
a
57
63
else (
58
64
let rec stabilize () =
65
+
(* Log.debug (fun m -> m "stabilize"); *)
66
+
let start_time = Unix.gettimeofday () in
59
67
let tree = Lwd.quick_sample root in
68
+
let end_time = Unix.gettimeofday () in
69
+
let duration = end_time -. start_time in
70
+
Printf.eprintf "%f" duration;
60
71
Renderer.update renderer size tree;
61
72
It.start_tracking invalidation_tracker;
62
73
let image = Renderer.image renderer in
74
+
63
75
(* If we are already damaged then we should re-calculate*)
64
76
if Lwd.is_damaged root then stabilize () else image
65
77
in
66
78
stabilize ())
67
79
in
68
80
cache := Some image;
81
+
(* Log.debug (fun m -> m "redrawing terminal with image: hash: %d" (Hashtbl.hash image)); *)
69
82
Term.image term image;
70
83
(* Now we wait for another event or the timeout*)
71
84
if process_event
···
103
116
a := !a + 1;
104
117
let cache = ref None in
105
118
Ui_loop.Internal.run_with_term
119
+
(* tracks root invalidation so we can recompute on invalidation*)
106
120
~on_invalidate:(fun _ -> It.invalidate invalidation_tracker)
107
121
~step:
108
122
(step
+1
forks/nottui/nottui.opam
+1
forks/nottui/nottui.opam
+32
forks/nottui/nottui_picos.opam
+32
forks/nottui/nottui_picos.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Run Nottui UIs using picos"
4
+
maintainer: ["fred@tarides.com" "eli.jambu@gmail.com"]
5
+
authors: ["Frédéric Bour" "Eli Dowling"]
6
+
license: "MIT"
7
+
homepage: "https://github.com/flador20/nottui"
8
+
doc: "https://let-def.github.io/lwd/doc"
9
+
bug-reports: "https://github.com/flador20/nottui/issues"
10
+
depends: [
11
+
"dune" {>= "3.5"}
12
+
"picos" {>= "0.6.0"}
13
+
"lwd_picos" {= version}
14
+
"nottui" {= version}
15
+
"notty" {>= "0.2"}
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
32
+
dev-repo: "git+https://github.com/flador20/nottui.git"
+2
-3
forks/nottui/tutorial/src/hackernews/bin/comments.ml
+2
-3
forks/nottui/tutorial/src/hackernews/bin/comments.ml
···
15
15
let make_comment_ui ?(focus = Focus.make ()) (comment : comment Lwd.t) =
16
16
make_comment_ui_attr
17
17
~attr:
18
-
(focus
19
-
|> Focus.status
20
-
|>$ fun focus -> if Focus.has_focus focus then A.(fg blue) else A.empty)
18
+
( focus |> Focus.status |>$ fun focus ->
19
+
if Focus.has_focus focus then A.(fg blue) else A.empty )
21
20
comment
22
21
;;
23
22
+6
-5
forks/nottui/tutorial/src/hackernews/bin/hackernews_1.ml
+6
-5
forks/nottui/tutorial/src/hackernews/bin/hackernews_1.ml
···
3
3
open Hackernews_api
4
4
5
5
(*
6
-
$#S1
6
+
$#S1
7
7
open Nottui
8
8
open Notty
9
9
open Hackernews_api
···
18
18
$#E1
19
19
*)
20
20
21
-
22
21
(* We can make a heper function to render a post *)
23
22
(*$#S2*)
24
23
let post_ui ({ title; url; score; comments; _ } : Hackernews_api.post) : ui Lwd.t =
25
-
(*$#S3*)
24
+
(*$#S3*)
26
25
let website = List.nth (String.split_on_char '/' url) 2 in
27
-
(*$#E3*)
26
+
(*$#E3*)
28
27
Ui.vcat
29
28
[ Ui.hcat
30
29
[ W.string ~attr:A.(st bold) title; W.printf ~attr:A.(st italic) "(%s)" website ]
31
-
; Ui.hcat
30
+
; Ui.hcat
32
31
[ W.printf ~attr:A.(st italic) "%d points" score
33
32
; W.printf ~attr:A.(st italic) "%d comments" comments
34
33
]
···
36
35
|> Lwd.pure
37
36
|> W.Box.focusable
38
37
;;
38
+
39
39
(*$#E2*)
40
40
41
41
(*Generate some posts and render them using our post_renderer*)
···
44
44
let posts = Hackernews_api.fake_posts () in
45
45
posts |> List.map post_ui |> W.vbox
46
46
;;
47
+
47
48
(*$#E4*)
48
49
49
50
(*Start the nottui process with our built up ui*)
+7
-8
forks/nottui/tutorial/src/hackernews/bin/hackernews_2.ml
+7
-8
forks/nottui/tutorial/src/hackernews/bin/hackernews_2.ml
···
84
84
let shortcuts = Ui.vcat [ Ui.hcat [ W.string "[S]orting" ] ]
85
85
86
86
let main_ui =
87
-
(*$#S15*)
87
+
(*$#S15*)
88
88
let sorted_by_ui =
89
89
let$ sorting = Lwd.get sorting_mode_var in
90
90
(match sorting with
···
92
92
| `Comments -> "Comments")
93
93
|> W.fmt "Sorted by %s"
94
94
in
95
-
(*$#E15*)
96
-
(*$#S14*)
95
+
(*$#E15*)
96
+
(*$#S14*)
97
97
let posts =
98
98
let$* sort_mode = Lwd.get sorting_mode_var in
99
99
let sort_func = get_sort_func sort_mode in
···
103
103
|> W.vbox
104
104
|> W.Scroll.v_area
105
105
in
106
-
(*$#E14*)
107
-
(*$#S12*)
106
+
(*$#E14*)
107
+
(*$#S12*)
108
108
W.vbox
109
-
[
110
-
sorted_by_ui|>W.Box.box ~pad_w:1 ~pad_h:0;
111
-
posts |> W.Box.box ~pad_w:1 ~pad_h:0
109
+
[ sorted_by_ui |> W.Box.box ~pad_w:1 ~pad_h:0
110
+
; posts |> W.Box.box ~pad_w:1 ~pad_h:0
112
111
; shortcuts |> Ui.resize ~sw:1 ~mw:10000 |> Lwd.pure |> W.Box.box ~pad_w:1 ~pad_h:0
113
112
]
114
113
|> sorting_prompt
+19
-18
forks/nottui/tutorial/src/hackernews/bin/hackernews_3.ml
+19
-18
forks/nottui/tutorial/src/hackernews/bin/hackernews_3.ml
···
6
6
let selected_post_var : post option Lwd.var = Lwd.var None
7
7
8
8
let post_ui
9
-
?(focus = Focus.make ())
10
-
({ title; url; score; comments; _ } as post : Hackernews_api.post)
9
+
?(focus = Focus.make ())
10
+
({ title; url; score; comments; _ } as post : Hackernews_api.post)
11
11
=
12
12
let website = List.nth (String.split_on_char '/' url) 2 in
13
13
let update_focused =
14
14
let$ focus = Focus.status focus in
15
15
Lwd.may_update
16
16
(fun x ->
17
-
if focus |> Focus.has_focus
17
+
if
18
+
focus |> Focus.has_focus
18
19
&& x
19
20
|> Option.map (fun (x : post) -> x.id <> post.id)
20
21
|> Option.value ~default:true
21
-
then Some (Some post)
22
-
else None)
22
+
then Some (Some post)
23
+
else None)
23
24
selected_post_var
24
25
in
25
26
()
···
27
28
|> Lwd.fix ~wrt:update_focused
28
29
(*We map on update_focused becasue we want it in our LWD tree so it updates with the rest of the ui, but we want it at the bottom becasue we don't want aything to re-render becasue of it changing*)
29
30
|>$ (fun () ->
30
-
Ui.vcat
31
-
[ Ui.hcat
32
-
[ W.string ~attr:A.(st bold) title
33
-
; W.string " "
34
-
; W.printf ~attr:A.(st italic ++ fg lightblack) "(%s)" website
35
-
]
36
-
; Ui.hcat
37
-
[ W.printf ~attr:A.(st italic) "%d points" score
38
-
; W.string " "
39
-
; W.printf ~attr:A.(st italic) "%d comments" comments
40
-
]
41
-
]
42
-
|> Ui.resize ~sw:1 ~mw:10000)
31
+
Ui.vcat
32
+
[ Ui.hcat
33
+
[ W.string ~attr:A.(st bold) title
34
+
; W.string " "
35
+
; W.printf ~attr:A.(st italic ++ fg lightblack) "(%s)" website
36
+
]
37
+
; Ui.hcat
38
+
[ W.printf ~attr:A.(st italic) "%d points" score
39
+
; W.string " "
40
+
; W.printf ~attr:A.(st italic) "%d comments" comments
41
+
]
42
+
]
43
+
|> Ui.resize ~sw:1 ~mw:10000)
43
44
|> W.Box.focusable ~focus
44
45
;;
45
46
+98
-75
forks/nottui/tutorial/src/hackernews/bin/hackernews_api.ml
+98
-75
forks/nottui/tutorial/src/hackernews/bin/hackernews_api.ml
···
1
-
type post = {
2
-
id : int;
3
-
title : string;
4
-
url : string;
5
-
score : int;
6
-
comments : int;
7
-
kids: int list;
8
-
}
1
+
type post =
2
+
{ id : int
3
+
; title : string
4
+
; url : string
5
+
; score : int
6
+
; comments : int
7
+
; kids : int list
8
+
}
9
9
10
10
(** generates a list of child ids, skewed twards low numbers *)
11
-
let generate_kids_list()=
12
-
13
-
List.init (Float.pow ((Random.float 10.0)/. 3.0) 6.0|>Int.of_float) (fun _ -> Random.int 10000000 + 2000000)
11
+
let generate_kids_list () =
12
+
List.init
13
+
(Float.pow (Random.float 10.0 /. 3.0) 6.0 |> Int.of_float)
14
+
(fun _ -> Random.int 10000000 + 2000000)
15
+
;;
14
16
15
17
(** returns a list of posts from hackernews*)
16
18
let fake_posts () =
17
-
let titles = [
18
-
"OCaml 5.0 Released: What’s New?";
19
-
"Why Functional Programming Matters";
20
-
"Building Scalable Systems with OCaml";
21
-
"Understanding Type Systems";
22
-
"Introduction to Category Theory";
23
-
"The Future of Multi-Core OCaml";
24
-
"How to Contribute to Open Source Projects";
25
-
"OCaml vs Haskell: A Comparison";
26
-
"Getting Started with MirageOS";
27
-
"Real-World Applications of OCaml"
28
-
] in
29
-
let urls = [
30
-
"https://ocaml.com/ocaml-5-released";
31
-
"https://functional.com/functional-programming-matters";
32
-
"https://scaleable.com/building-scalable-systems";
33
-
"https://understanding.com/understanding-type-systems";
34
-
"https://theory.com/introduction-to-category-theory";
35
-
"https://multicore.com/future-of-multicore-ocaml";
36
-
"https://contrib.com/contributing-to-open-source";
37
-
"https://haskell.com/ocaml-vs-haskell";
38
-
"https://migrations.com/getting-started-mirageos";
39
-
"https://realworldocaml.com/real-world-applications-ocaml"
40
-
] in
19
+
let titles =
20
+
[ "OCaml 5.0 Released: What’s New?"
21
+
; "Why Functional Programming Matters"
22
+
; "Building Scalable Systems with OCaml"
23
+
; "Understanding Type Systems"
24
+
; "Introduction to Category Theory"
25
+
; "The Future of Multi-Core OCaml"
26
+
; "How to Contribute to Open Source Projects"
27
+
; "OCaml vs Haskell: A Comparison"
28
+
; "Getting Started with MirageOS"
29
+
; "Real-World Applications of OCaml"
30
+
]
31
+
in
32
+
let urls =
33
+
[ "https://ocaml.com/ocaml-5-released"
34
+
; "https://functional.com/functional-programming-matters"
35
+
; "https://scaleable.com/building-scalable-systems"
36
+
; "https://understanding.com/understanding-type-systems"
37
+
; "https://theory.com/introduction-to-category-theory"
38
+
; "https://multicore.com/future-of-multicore-ocaml"
39
+
; "https://contrib.com/contributing-to-open-source"
40
+
; "https://haskell.com/ocaml-vs-haskell"
41
+
; "https://migrations.com/getting-started-mirageos"
42
+
; "https://realworldocaml.com/real-world-applications-ocaml"
43
+
]
44
+
in
41
45
let rec make_posts ids titles urls scores comments acc =
42
-
match (ids, titles, urls, scores, comments) with
43
-
| ([], [], [], [], []) -> List.rev acc
44
-
| (id::ids_tail, title::titles_tail, url::urls_tail, score::scores_tail, comment::comments_tail) ->
45
-
let post = {id; title; url; score; comments = comment; kids=generate_kids_list()} in
46
-
make_posts ids_tail titles_tail urls_tail scores_tail comments_tail (post :: acc)
46
+
match ids, titles, urls, scores, comments with
47
+
| [], [], [], [], [] -> List.rev acc
48
+
| ( id :: ids_tail
49
+
, title :: titles_tail
50
+
, url :: urls_tail
51
+
, score :: scores_tail
52
+
, comment :: comments_tail ) ->
53
+
let post =
54
+
{ id; title; url; score; comments = comment; kids = generate_kids_list () }
55
+
in
56
+
make_posts ids_tail titles_tail urls_tail scores_tail comments_tail (post :: acc)
47
57
| _ -> acc
48
58
in
49
-
let ids = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10] in
50
-
let scores = [120; 85; 99; 75; 110; 95; 130; 90; 70; 80] in
51
-
let comments = [15; 25; 30; 20; 35; 40; 50; 45; 10; 5] in
59
+
let ids = [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ] in
60
+
let scores = [ 120; 85; 99; 75; 110; 95; 130; 90; 70; 80 ] in
61
+
let comments = [ 15; 25; 30; 20; 35; 40; 50; 45; 10; 5 ] in
52
62
make_posts ids titles urls scores comments []
63
+
;;
53
64
54
-
type comment = {
55
-
by : string;
56
-
id : int;
57
-
kids : int list;
58
-
parent : int;
59
-
text : string;
60
-
time : int;
61
-
comment_type : string;
62
-
}
65
+
type comment =
66
+
{ by : string
67
+
; id : int
68
+
; kids : int list
69
+
; parent : int
70
+
; text : string
71
+
; time : int
72
+
; comment_type : string
73
+
}
63
74
64
75
let generate_fake_comment parent_id comment_id =
65
-
let authors = ["ocaml_fan"; "functional_guru"; "type_safety_advocate"; "pattern_matcher"; "monad_master"] in
66
-
let texts = [
67
-
"Great article! I've been using OCaml for years and it never ceases to amaze me.";
68
-
"I disagree with some points, but overall a good read.";
69
-
"Has anyone tried implementing this in a production environment?";
70
-
"This reminds me of a similar approach we took in our project. It worked wonders!";
71
-
"I'd love to see a follow-up article exploring this topic further.";
72
-
"The author makes some interesting points, but I think they're overlooking some key issues.";
73
-
"This is a game-changer for functional programming. Can't wait to try it out!";
74
-
"I'm skeptical about the performance claims. Has anyone done benchmarks?";
75
-
"As always, it depends on the specific use case. YMMV.";
76
-
"I've been waiting for something like this for a long time. Thanks for sharing!"
77
-
] in
78
-
{
79
-
by = List.nth authors (Random.int (List.length authors));
80
-
id = comment_id;
81
-
kids = generate_kids_list();
82
-
parent = parent_id;
83
-
text = List.nth texts (Random.int (List.length texts));
84
-
time = int_of_float (Unix.time ()) - Random.int 86400; (* Random time within last 24 hours *)
85
-
comment_type = "comment";
76
+
let authors =
77
+
[ "ocaml_fan"
78
+
; "functional_guru"
79
+
; "type_safety_advocate"
80
+
; "pattern_matcher"
81
+
; "monad_master"
82
+
]
83
+
in
84
+
let texts =
85
+
[ "Great article! I've been using OCaml for years and it never ceases to amaze me."
86
+
; "I disagree with some points, but overall a good read."
87
+
; "Has anyone tried implementing this in a production environment?"
88
+
; "This reminds me of a similar approach we took in our project. It worked wonders!"
89
+
; "I'd love to see a follow-up article exploring this topic further."
90
+
; "The author makes some interesting points, but I think they're overlooking some \
91
+
key issues."
92
+
; "This is a game-changer for functional programming. Can't wait to try it out!"
93
+
; "I'm skeptical about the performance claims. Has anyone done benchmarks?"
94
+
; "As always, it depends on the specific use case. YMMV."
95
+
; "I've been waiting for something like this for a long time. Thanks for sharing!"
96
+
]
97
+
in
98
+
{ by = List.nth authors (Random.int (List.length authors))
99
+
; id = comment_id
100
+
; kids = generate_kids_list ()
101
+
; parent = parent_id
102
+
; text = List.nth texts (Random.int (List.length texts))
103
+
; time = int_of_float (Unix.time ()) - Random.int 86400
104
+
; (* Random time within last 24 hours *)
105
+
comment_type = "comment"
86
106
}
107
+
;;
87
108
88
109
(*generates a comment with some number of children mostly those comments will have no children, but some will*)
89
-
let generate_fake_comments count parent_id =
90
-
List.init count (fun _ -> generate_fake_comment parent_id (Random.int 10000000 + 2000000))
110
+
let generate_fake_comments count parent_id =
111
+
List.init count (fun _ ->
112
+
generate_fake_comment parent_id (Random.int 10000000 + 2000000))
113
+
;;
+4
-5
forks/nottui/tutorial/src/tangle.ml
+4
-5
forks/nottui/tutorial/src/tangle.ml
···
48
48
49
49
(* Parser for $#<number> fold <name> *)
50
50
let parse_fold =
51
-
string "$#" *> parse_number
52
-
<* string " fold "
53
-
>>= fun n -> take_while1 Char.(fun c -> c <> '\n') >>| fun name -> Fold (n, name)
51
+
string "$#" *> parse_number <* string " fold " >>= fun n ->
52
+
take_while1 Char.(fun c -> c <> '\n') >>| fun name -> Fold (n, name)
54
53
;;
55
54
56
55
(* Combine all parsers *)
···
169
168
files
170
169
|> List.filter_map ~f:(fun f ->
171
170
let path = Stdlib.Filename.concat input_path f in
172
-
if (not (Stdlib.Filename.check_suffix f ".md"))
173
-
&& not (Stdlib.Sys.is_directory path)
171
+
if
172
+
(not (Stdlib.Filename.check_suffix f ".md")) && not (Stdlib.Sys.is_directory path)
174
173
then Some path
175
174
else None)
176
175
in
+13
jj_tui.install
+13
jj_tui.install
···
1
+
lib: [
2
+
"_build/install/default/lib/jj_tui/META"
3
+
"_build/install/default/lib/jj_tui/dune-package"
4
+
"_build/install/default/lib/jj_tui/opam"
5
+
]
6
+
bin: [
7
+
"_build/install/default/bin/jj_tui"
8
+
"_build/install/default/bin/widget_test"
9
+
]
10
+
doc: [
11
+
"_build/install/default/doc/jj_tui/LICENSE"
12
+
"_build/install/default/doc/jj_tui/README.md"
13
+
]
+1
jj_tui.opam
+1
jj_tui.opam
+2
-1
jj_tui/bin/dune
+2
-1
jj_tui/bin/dune
+1
-1
jj_tui/widget-test/dune
+1
-1
jj_tui/widget-test/dune
+21
-15
jj_tui/widget-test/main.ml
+21
-15
jj_tui/widget-test/main.ml
···
10
10
11
11
let pString s = W.string s |> Lwd.pure
12
12
13
+
let test_input=
14
+
let inp_var =("hi there",5)|>Lwd.var in
15
+
let inp_text= inp_var|>Lwd.get in
16
+
17
+
W.edit_field inp_text ~on_change:(fun x->Lwd.set inp_var x) ~on_submit:(fun x->())
13
18
let w_0 =
14
19
W.hbox
15
20
[
16
-
pString " |"
17
-
; (let og =
18
-
Ui.vcat
19
-
[
20
-
W.string "123456789000000000000000000000000000000000000000000000000000end"
21
-
; W.string "123456789000000000000000000000000000000000000000000000000000end"
22
-
]
23
-
in
24
-
og
25
-
|> Lwd.pure
26
-
|> W.Scroll.area
27
-
|> W.Box.box
28
-
|>$ Ui.resize ~sh:1 ~mh:1000
29
-
|> W.size_logger)
30
-
; pString "| "
21
+
(* pString " |" *)
22
+
(* ; (let og = *)
23
+
(* Ui.vcat *)
24
+
(* [ *)
25
+
(* W.string "123456789000000000000000000000000000000000000000000000000000end" *)
26
+
(* ; W.string "123456789000000000000000000000000000000000000000000000000000end" *)
27
+
(* ] *)
28
+
(* in *)
29
+
(* og *)
30
+
(* |> Lwd.pure *)
31
+
(* |> W.Scroll.area *)
32
+
(* |> W.Box.box *)
33
+
(* |>$ Ui.resize ~sh:1 ~mh:1000 *)
34
+
(* |> W.size_logger) *)
35
+
(* ; pString "| " *)
36
+
test_input
31
37
]
32
38
;;
33
39
+2282
test
+2282
test
···
1
+
setting value
2
+
finished setting value
3
+
setting value
4
+
finished setting value
5
+
setting value
6
+
finished setting value
7
+
setting value
8
+
finished setting value
9
+
setting value
10
+
finished setting value
11
+
setting value
12
+
finished setting value
13
+
setting value
14
+
finished setting value
15
+
setting value
16
+
finished setting value
17
+
setting value
18
+
finished setting value
19
+
setting value
20
+
finished setting value
21
+
setting value
22
+
finished setting value
23
+
setting value
24
+
finished setting value
25
+
setting value
26
+
finished setting value
27
+
setting value
28
+
finished setting value
29
+
setting value
30
+
finished setting value
31
+
setting value
32
+
finished setting value
33
+
setting value
34
+
finished setting value
35
+
setting value
36
+
finished setting value
37
+
setting value
38
+
finished setting value
39
+
setting value
40
+
finished setting value
41
+
setting value
42
+
finished setting value
43
+
setting value
44
+
finished setting value
45
+
setting value
46
+
finished setting value
47
+
setting value
48
+
finished setting value
49
+
setting value
50
+
finished setting value
51
+
setting value
52
+
finished setting value
53
+
setting value
54
+
finished setting value
55
+
setting value
56
+
finished setting value
57
+
setting value
58
+
finished setting value
59
+
setting value
60
+
finished setting value
61
+
setting value
62
+
setting value
63
+
finished setting value
64
+
finished setting value
65
+
setting value
66
+
finished setting value
67
+
setting value
68
+
finished setting value
69
+
setting value
70
+
finished setting value
71
+
setting value
72
+
finished setting value
73
+
setting value
74
+
finished setting value
75
+
setting value
76
+
finished setting value
77
+
setting value
78
+
finished setting value
79
+
setting value
80
+
finished setting value
81
+
setting value
82
+
finished setting value
83
+
setting value
84
+
finished setting value
85
+
setting value
86
+
finished setting value
87
+
setting value
88
+
finished setting value
89
+
setting value
90
+
finished setting value
91
+
setting value
92
+
finished setting value
93
+
setting value
94
+
finished setting value
95
+
setting value
96
+
finished setting value
97
+
setting value
98
+
finished setting value
99
+
setting value
100
+
finished setting value
101
+
setting value
102
+
finished setting value
103
+
setting value
104
+
finished setting value
105
+
setting value
106
+
finished setting value
107
+
setting value
108
+
finished setting value
109
+
setting value
110
+
finished setting value
111
+
setting value
112
+
finished setting value
113
+
setting value
114
+
finished setting value
115
+
setting value
116
+
finished setting value
117
+
setting value
118
+
finished setting value
119
+
setting value
120
+
finished setting value
121
+
setting value
122
+
finished setting value
123
+
setting value
124
+
finished setting value
125
+
setting value
126
+
finished setting value
127
+
setting value
128
+
finished setting value
129
+
setting value
130
+
finished setting value
131
+
setting value
132
+
finished setting value
133
+
setting value
134
+
finished setting value
135
+
setting value
136
+
finished setting value
137
+
setting value
138
+
finished setting value
139
+
setting value
140
+
finished setting value
141
+
setting value
142
+
finished setting value
143
+
setting value
144
+
finished setting value
145
+
setting value
146
+
finished setting value
147
+
setting value
148
+
finished setting value
149
+
setting value
150
+
finished setting value
151
+
setting value
152
+
finished setting value
153
+
setting value
154
+
finished setting value
155
+
setting value
156
+
finished setting value
157
+
setting value
158
+
finished setting value
159
+
setting value
160
+
finished setting value
161
+
setting value
162
+
finished setting value
163
+
setting value
164
+
finished setting value
165
+
setting value
166
+
finished setting value
167
+
setting value
168
+
finished setting value
169
+
setting value
170
+
finished setting value
171
+
setting value
172
+
finished setting value
173
+
setting value
174
+
finished setting value
175
+
setting value
176
+
finished setting value
177
+
setting value
178
+
finished setting value
179
+
setting value
180
+
finished setting value
181
+
setting value
182
+
finished setting value
183
+
setting value
184
+
finished setting value
185
+
setting value
186
+
finished setting value
187
+
setting value
188
+
finished setting value
189
+
setting value
190
+
finished setting value
191
+
setting value
192
+
finished setting value
193
+
setting value
194
+
finished setting value
195
+
setting value
196
+
finished setting value
197
+
setting value
198
+
finished setting value
199
+
setting value
200
+
finished setting value
201
+
setting value
202
+
finished setting value
203
+
setting value
204
+
finished setting value
205
+
setting value
206
+
finished setting value
207
+
setting value
208
+
finished setting value
209
+
setting value
210
+
finished setting value
211
+
setting value
212
+
finished setting value
213
+
setting value
214
+
finished setting value
215
+
setting value
216
+
finished setting value
217
+
setting value
218
+
finished setting value
219
+
setting value
220
+
finished setting value
221
+
setting value
222
+
finished setting value
223
+
setting value
224
+
finished setting value
225
+
setting value
226
+
finished setting value
227
+
setting value
228
+
finished setting value
229
+
setting value
230
+
finished setting value
231
+
setting value
232
+
finished setting value
233
+
setting value
234
+
finished setting value
235
+
setting value
236
+
finished setting value
237
+
setting value
238
+
finished setting value
239
+
setting value
240
+
finished setting value
241
+
setting value
242
+
finished setting value
243
+
setting value
244
+
finished setting value
245
+
setting value
246
+
finished setting value
247
+
setting value
248
+
finished setting value
249
+
setting value
250
+
finished setting value
251
+
setting value
252
+
finished setting value
253
+
setting value
254
+
finished setting value
255
+
setting value
256
+
finished setting value
257
+
setting value
258
+
finished setting value
259
+
setting value
260
+
finished setting value
261
+
setting value
262
+
finished setting value
263
+
setting value
264
+
setting value
265
+
finished setting value
266
+
finished setting value
267
+
setting value
268
+
finished setting value
269
+
setting value
270
+
finished setting value
271
+
setting value
272
+
finished setting value
273
+
setting value
274
+
finished setting value
275
+
setting value
276
+
finished setting value
277
+
setting value
278
+
finished setting value
279
+
setting value
280
+
finished setting value
281
+
setting value
282
+
finished setting value
283
+
setting value
284
+
finished setting value
285
+
setting value
286
+
finished setting value
287
+
setting value
288
+
finished setting value
289
+
setting value
290
+
finished setting value
291
+
setting value
292
+
finished setting value
293
+
setting value
294
+
finished setting value
295
+
setting value
296
+
finished setting value
297
+
setting value
298
+
finished setting value
299
+
setting value
300
+
finished setting value
301
+
setting value
302
+
finished setting value
303
+
setting value
304
+
finished setting value
305
+
setting value
306
+
finished setting value
307
+
setting value
308
+
finished setting value
309
+
setting value
310
+
finished setting value
311
+
setting value
312
+
finished setting value
313
+
setting value
314
+
finished setting value
315
+
setting value
316
+
finished setting value
317
+
setting value
318
+
finished setting value
319
+
setting value
320
+
finished setting value
321
+
setting value
322
+
finished setting value
323
+
setting value
324
+
finished setting value
325
+
setting value
326
+
finished setting value
327
+
setting value
328
+
finished setting value
329
+
setting value
330
+
finished setting value
331
+
setting value
332
+
finished setting value
333
+
setting value
334
+
finished setting value
335
+
setting value
336
+
finished setting value
337
+
setting value
338
+
finished setting value
339
+
setting value
340
+
finished setting value
341
+
setting value
342
+
finished setting value
343
+
setting value
344
+
finished setting value
345
+
setting value
346
+
finished setting value
347
+
setting value
348
+
finished setting value
349
+
setting value
350
+
finished setting value
351
+
setting value
352
+
finished setting value
353
+
setting value
354
+
finished setting value
355
+
setting value
356
+
finished setting value
357
+
setting value
358
+
finished setting value
359
+
setting value
360
+
finished setting value
361
+
setting value
362
+
finished setting value
363
+
setting value
364
+
finished setting value
365
+
setting value
366
+
finished setting value
367
+
setting value
368
+
finished setting value
369
+
setting value
370
+
finished setting value
371
+
setting value
372
+
finished setting value
373
+
setting value
374
+
finished setting value
375
+
setting value
376
+
finished setting value
377
+
setting value
378
+
finished setting value
379
+
setting value
380
+
finished setting value
381
+
setting value
382
+
finished setting value
383
+
setting value
384
+
finished setting value
385
+
setting value
386
+
finished setting value
387
+
setting value
388
+
finished setting value
389
+
setting value
390
+
finished setting value
391
+
setting value
392
+
finished setting value
393
+
setting value
394
+
finished setting value
395
+
setting value
396
+
finished setting value
397
+
setting value
398
+
finished setting value
399
+
setting value
400
+
finished setting value
401
+
setting value
402
+
finished setting value
403
+
setting value
404
+
finished setting value
405
+
setting value
406
+
finished setting value
407
+
setting value
408
+
finished setting value
409
+
setting value
410
+
finished setting value
411
+
setting value
412
+
finished setting value
413
+
setting value
414
+
finished setting value
415
+
setting value
416
+
finished setting value
417
+
setting value
418
+
finished setting value
419
+
setting value
420
+
finished setting value
421
+
setting value
422
+
finished setting value
423
+
setting value
424
+
finished setting value
425
+
setting value
426
+
finished setting value
427
+
setting value
428
+
finished setting value
429
+
setting value
430
+
finished setting value
431
+
setting value
432
+
finished setting value
433
+
setting value
434
+
finished setting value
435
+
setting value
436
+
finished setting value
437
+
setting value
438
+
finished setting value
439
+
setting value
440
+
finished setting value
441
+
setting value
442
+
finished setting value
443
+
setting value
444
+
finished setting value
445
+
setting value
446
+
finished setting value
447
+
setting value
448
+
finished setting value
449
+
setting value
450
+
finished setting value
451
+
setting value
452
+
finished setting value
453
+
setting value
454
+
finished setting value
455
+
setting value
456
+
finished setting value
457
+
setting value
458
+
finished setting value
459
+
setting value
460
+
finished setting value
461
+
setting value
462
+
finished setting value
463
+
setting value
464
+
finished setting value
465
+
setting value
466
+
finished setting value
467
+
setting value
468
+
finished setting value
469
+
setting value
470
+
finished setting value
471
+
setting value
472
+
finished setting value
473
+
setting value
474
+
finished setting value
475
+
setting value
476
+
finished setting value
477
+
setting value
478
+
finished setting value
479
+
setting value
480
+
finished setting value
481
+
setting value
482
+
finished setting value
483
+
setting value
484
+
finished setting value
485
+
setting value
486
+
finished setting value
487
+
setting value
488
+
finished setting value
489
+
setting value
490
+
finished setting value
491
+
setting value
492
+
finished setting value
493
+
setting value
494
+
finished setting value
495
+
setting value
496
+
finished setting value
497
+
setting value
498
+
finished setting value
499
+
setting value
500
+
finished setting value
501
+
setting value
502
+
finished setting value
503
+
setting value
504
+
finished setting value
505
+
setting value
506
+
finished setting value
507
+
setting value
508
+
finished setting value
509
+
setting value
510
+
finished setting value
511
+
setting value
512
+
finished setting value
513
+
setting value
514
+
finished setting value
515
+
setting value
516
+
finished setting value
517
+
setting value
518
+
finished setting value
519
+
setting value
520
+
finished setting value
521
+
setting value
522
+
finished setting value
523
+
setting value
524
+
finished setting value
525
+
setting value
526
+
finished setting value
527
+
setting value
528
+
finished setting value
529
+
setting value
530
+
finished setting value
531
+
setting value
532
+
finished setting value
533
+
setting value
534
+
finished setting value
535
+
setting value
536
+
finished setting value
537
+
setting value
538
+
finished setting value
539
+
setting value
540
+
finished setting value
541
+
setting value
542
+
finished setting value
543
+
setting value
544
+
finished setting value
545
+
setting value
546
+
finished setting value
547
+
setting value
548
+
finished setting value
549
+
setting value
550
+
finished setting value
551
+
setting value
552
+
finished setting value
553
+
setting value
554
+
finished setting value
555
+
setting value
556
+
finished setting value
557
+
setting value
558
+
finished setting value
559
+
setting value
560
+
finished setting value
561
+
setting value
562
+
finished setting value
563
+
setting value
564
+
finished setting value
565
+
setting value
566
+
finished setting value
567
+
setting value
568
+
finished setting value
569
+
setting value
570
+
finished setting value
571
+
setting value
572
+
finished setting value
573
+
setting value
574
+
finished setting value
575
+
setting value
576
+
finished setting value
577
+
setting value
578
+
finished setting value
579
+
setting value
580
+
finished setting value
581
+
setting value
582
+
finished setting value
583
+
setting value
584
+
finished setting value
585
+
setting value
586
+
finished setting value
587
+
setting value
588
+
finished setting value
589
+
setting value
590
+
finished setting value
591
+
setting value
592
+
finished setting value
593
+
setting value
594
+
finished setting value
595
+
setting value
596
+
finished setting value
597
+
setting value
598
+
finished setting value
599
+
setting value
600
+
finished setting value
601
+
setting value
602
+
finished setting value
603
+
setting value
604
+
finished setting value
605
+
setting value
606
+
finished setting value
607
+
setting value
608
+
finished setting value
609
+
setting value
610
+
finished setting value
611
+
setting value
612
+
finished setting value
613
+
setting value
614
+
finished setting value
615
+
setting value
616
+
setting value
617
+
finished setting value
618
+
setting value
619
+
finished setting value
620
+
finished setting value
621
+
setting value
622
+
finished setting value
623
+
setting value
624
+
finished setting value
625
+
setting value
626
+
finished setting value
627
+
setting value
628
+
finished setting value
629
+
setting value
630
+
finished setting value
631
+
setting value
632
+
finished setting value
633
+
setting value
634
+
finished setting value
635
+
setting value
636
+
finished setting value
637
+
setting value
638
+
finished setting value
639
+
setting value
640
+
finished setting value
641
+
setting value
642
+
finished setting value
643
+
setting value
644
+
finished setting value
645
+
setting value
646
+
finished setting value
647
+
setting value
648
+
finished setting value
649
+
setting value
650
+
finished setting value
651
+
setting value
652
+
finished setting value
653
+
setting value
654
+
finished setting value
655
+
setting value
656
+
finished setting value
657
+
setting value
658
+
finished setting value
659
+
setting value
660
+
finished setting value
661
+
setting value
662
+
finished setting value
663
+
setting value
664
+
finished setting value
665
+
setting value
666
+
finished setting value
667
+
setting value
668
+
finished setting value
669
+
setting value
670
+
finished setting value
671
+
setting value
672
+
finished setting value
673
+
setting value
674
+
finished setting value
675
+
setting value
676
+
finished setting value
677
+
setting value
678
+
finished setting value
679
+
setting value
680
+
finished setting value
681
+
setting value
682
+
finished setting value
683
+
setting value
684
+
finished setting value
685
+
setting value
686
+
finished setting value
687
+
setting value
688
+
finished setting value
689
+
setting value
690
+
finished setting value
691
+
setting value
692
+
finished setting value
693
+
setting value
694
+
finished setting value
695
+
setting value
696
+
finished setting value
697
+
setting value
698
+
finished setting value
699
+
setting value
700
+
finished setting value
701
+
setting value
702
+
finished setting value
703
+
setting value
704
+
finished setting value
705
+
setting value
706
+
finished setting value
707
+
setting value
708
+
finished setting value
709
+
setting value
710
+
finished setting value
711
+
setting value
712
+
finished setting value
713
+
setting value
714
+
finished setting value
715
+
setting value
716
+
finished setting value
717
+
setting value
718
+
finished setting value
719
+
setting value
720
+
finished setting value
721
+
setting value
722
+
finished setting value
723
+
setting value
724
+
finished setting value
725
+
setting value
726
+
finished setting value
727
+
setting value
728
+
finished setting value
729
+
setting value
730
+
finished setting value
731
+
setting value
732
+
finished setting value
733
+
setting value
734
+
finished setting value
735
+
setting value
736
+
finished setting value
737
+
setting value
738
+
finished setting value
739
+
setting value
740
+
finished setting value
741
+
setting value
742
+
finished setting value
743
+
setting value
744
+
finished setting value
745
+
setting value
746
+
finished setting value
747
+
setting value
748
+
finished setting value
749
+
setting value
750
+
finished setting value
751
+
setting value
752
+
finished setting value
753
+
setting value
754
+
finished setting value
755
+
setting value
756
+
finished setting value
757
+
setting value
758
+
finished setting value
759
+
setting value
760
+
finished setting value
761
+
setting value
762
+
finished setting value
763
+
setting value
764
+
finished setting value
765
+
setting value
766
+
finished setting value
767
+
setting value
768
+
finished setting value
769
+
setting value
770
+
finished setting value
771
+
setting value
772
+
finished setting value
773
+
setting value
774
+
finished setting value
775
+
setting value
776
+
finished setting value
777
+
setting value
778
+
finished setting value
779
+
setting value
780
+
finished setting value
781
+
setting value
782
+
finished setting value
783
+
setting value
784
+
finished setting value
785
+
setting value
786
+
finished setting value
787
+
setting value
788
+
finished setting value
789
+
setting value
790
+
finished setting value
791
+
setting value
792
+
finished setting value
793
+
setting value
794
+
finished setting value
795
+
setting value
796
+
finished setting value
797
+
setting value
798
+
finished setting value
799
+
setting value
800
+
finished setting value
801
+
setting value
802
+
finished setting value
803
+
setting value
804
+
finished setting value
805
+
setting value
806
+
finished setting value
807
+
setting value
808
+
finished setting value
809
+
setting value
810
+
finished setting value
811
+
setting value
812
+
setting value
813
+
finished setting value
814
+
finished setting value
815
+
setting value
816
+
finished setting value
817
+
setting value
818
+
finished setting value
819
+
setting value
820
+
finished setting value
821
+
setting value
822
+
finished setting value
823
+
setting value
824
+
finished setting value
825
+
setting value
826
+
finished setting value
827
+
setting value
828
+
finished setting value
829
+
setting value
830
+
finished setting value
831
+
setting value
832
+
finished setting value
833
+
setting value
834
+
finished setting value
835
+
setting value
836
+
finished setting value
837
+
setting value
838
+
finished setting value
839
+
setting value
840
+
finished setting value
841
+
setting value
842
+
finished setting value
843
+
setting value
844
+
finished setting value
845
+
setting value
846
+
finished setting value
847
+
setting value
848
+
finished setting value
849
+
setting value
850
+
finished setting value
851
+
setting value
852
+
finished setting value
853
+
setting value
854
+
finished setting value
855
+
setting value
856
+
finished setting value
857
+
setting value
858
+
finished setting value
859
+
setting value
860
+
finished setting value
861
+
setting value
862
+
finished setting value
863
+
setting value
864
+
finished setting value
865
+
setting value
866
+
finished setting value
867
+
setting value
868
+
finished setting value
869
+
setting value
870
+
finished setting value
871
+
setting value
872
+
finished setting value
873
+
setting value
874
+
finished setting value
875
+
setting value
876
+
finished setting value
877
+
setting value
878
+
finished setting value
879
+
setting value
880
+
finished setting value
881
+
setting value
882
+
finished setting value
883
+
setting value
884
+
finished setting value
885
+
setting value
886
+
finished setting value
887
+
setting value
888
+
finished setting value
889
+
setting value
890
+
finished setting value
891
+
setting value
892
+
finished setting value
893
+
setting value
894
+
finished setting value
895
+
setting value
896
+
finished setting value
897
+
setting value
898
+
finished setting value
899
+
setting value
900
+
finished setting value
901
+
setting value
902
+
finished setting value
903
+
setting value
904
+
finished setting value
905
+
setting value
906
+
finished setting value
907
+
setting value
908
+
finished setting value
909
+
setting value
910
+
finished setting value
911
+
setting value
912
+
finished setting value
913
+
setting value
914
+
finished setting value
915
+
setting value
916
+
finished setting value
917
+
setting value
918
+
finished setting value
919
+
setting value
920
+
finished setting value
921
+
setting value
922
+
finished setting value
923
+
setting value
924
+
finished setting value
925
+
setting value
926
+
finished setting value
927
+
setting value
928
+
finished setting value
929
+
setting value
930
+
finished setting value
931
+
setting value
932
+
finished setting value
933
+
setting value
934
+
finished setting value
935
+
setting value
936
+
finished setting value
937
+
setting value
938
+
finished setting value
939
+
setting value
940
+
finished setting value
941
+
setting value
942
+
finished setting value
943
+
setting value
944
+
finished setting value
945
+
setting value
946
+
finished setting value
947
+
setting value
948
+
finished setting value
949
+
setting value
950
+
finished setting value
951
+
setting value
952
+
finished setting value
953
+
setting value
954
+
finished setting value
955
+
setting value
956
+
finished setting value
957
+
setting value
958
+
finished setting value
959
+
setting value
960
+
finished setting value
961
+
setting value
962
+
finished setting value
963
+
setting value
964
+
finished setting value
965
+
setting value
966
+
finished setting value
967
+
setting value
968
+
finished setting value
969
+
setting value
970
+
finished setting value
971
+
setting value
972
+
finished setting value
973
+
setting value
974
+
finished setting value
975
+
setting value
976
+
finished setting value
977
+
setting value
978
+
finished setting value
979
+
setting value
980
+
finished setting value
981
+
setting value
982
+
finished setting value
983
+
setting value
984
+
finished setting value
985
+
setting value
986
+
finished setting value
987
+
setting value
988
+
finished setting value
989
+
setting value
990
+
finished setting value
991
+
setting value
992
+
finished setting value
993
+
setting value
994
+
finished setting value
995
+
setting value
996
+
finished setting value
997
+
setting value
998
+
finished setting value
999
+
setting value
1000
+
finished setting value
1001
+
setting value
1002
+
finished setting value
1003
+
setting value
1004
+
finished setting value
1005
+
setting value
1006
+
finished setting value
1007
+
setting value
1008
+
finished setting value
1009
+
setting value
1010
+
finished setting value
1011
+
setting value
1012
+
finished setting value
1013
+
setting value
1014
+
finished setting value
1015
+
setting value
1016
+
finished setting value
1017
+
setting value
1018
+
finished setting value
1019
+
setting value
1020
+
finished setting value
1021
+
setting value
1022
+
finished setting value
1023
+
setting value
1024
+
finished setting value
1025
+
setting value
1026
+
finished setting value
1027
+
setting value
1028
+
finished setting value
1029
+
setting value
1030
+
finished setting value
1031
+
setting value
1032
+
setting value
1033
+
finished setting value
1034
+
finished setting value
1035
+
setting value
1036
+
finished setting value
1037
+
setting value
1038
+
finished setting value
1039
+
setting value
1040
+
finished setting value
1041
+
setting value
1042
+
finished setting value
1043
+
setting value
1044
+
finished setting value
1045
+
setting value
1046
+
finished setting value
1047
+
setting value
1048
+
finished setting value
1049
+
setting value
1050
+
finished setting value
1051
+
setting value
1052
+
finished setting value
1053
+
setting value
1054
+
finished setting value
1055
+
setting value
1056
+
finished setting value
1057
+
setting value
1058
+
finished setting value
1059
+
setting value
1060
+
finished setting value
1061
+
setting value
1062
+
finished setting value
1063
+
setting value
1064
+
finished setting value
1065
+
setting value
1066
+
finished setting value
1067
+
setting value
1068
+
finished setting value
1069
+
setting value
1070
+
finished setting value
1071
+
setting value
1072
+
finished setting value
1073
+
setting value
1074
+
finished setting value
1075
+
setting value
1076
+
finished setting value
1077
+
setting value
1078
+
finished setting value
1079
+
setting value
1080
+
finished setting value
1081
+
setting value
1082
+
finished setting value
1083
+
setting value
1084
+
finished setting value
1085
+
setting value
1086
+
finished setting value
1087
+
setting value
1088
+
finished setting value
1089
+
setting value
1090
+
finished setting value
1091
+
setting value
1092
+
finished setting value
1093
+
setting value
1094
+
finished setting value
1095
+
setting value
1096
+
finished setting value
1097
+
setting value
1098
+
finished setting value
1099
+
setting value
1100
+
finished setting value
1101
+
setting value
1102
+
setting value
1103
+
finished setting value
1104
+
finished setting value
1105
+
setting value
1106
+
finished setting value
1107
+
setting value
1108
+
finished setting value
1109
+
setting value
1110
+
finished setting value
1111
+
setting value
1112
+
finished setting value
1113
+
setting value
1114
+
finished setting value
1115
+
setting value
1116
+
finished setting value
1117
+
setting value
1118
+
finished setting value
1119
+
setting value
1120
+
finished setting value
1121
+
setting value
1122
+
finished setting value
1123
+
setting value
1124
+
finished setting value
1125
+
setting value
1126
+
finished setting value
1127
+
setting value
1128
+
finished setting value
1129
+
setting value
1130
+
finished setting value
1131
+
setting value
1132
+
finished setting value
1133
+
setting value
1134
+
finished setting value
1135
+
setting value
1136
+
finished setting value
1137
+
setting value
1138
+
finished setting value
1139
+
setting value
1140
+
finished setting value
1141
+
setting value
1142
+
finished setting value
1143
+
setting value
1144
+
finished setting value
1145
+
setting value
1146
+
finished setting value
1147
+
setting value
1148
+
finished setting value
1149
+
setting value
1150
+
finished setting value
1151
+
setting value
1152
+
finished setting value
1153
+
setting value
1154
+
finished setting value
1155
+
setting value
1156
+
finished setting value
1157
+
setting value
1158
+
finished setting value
1159
+
setting value
1160
+
finished setting value
1161
+
setting value
1162
+
finished setting value
1163
+
setting value
1164
+
finished setting value
1165
+
setting value
1166
+
finished setting value
1167
+
setting value
1168
+
finished setting value
1169
+
setting value
1170
+
finished setting value
1171
+
setting value
1172
+
finished setting value
1173
+
setting value
1174
+
finished setting value
1175
+
setting value
1176
+
finished setting value
1177
+
setting value
1178
+
finished setting value
1179
+
setting value
1180
+
finished setting value
1181
+
setting value
1182
+
finished setting value
1183
+
setting value
1184
+
finished setting value
1185
+
setting value
1186
+
finished setting value
1187
+
setting value
1188
+
finished setting value
1189
+
setting value
1190
+
finished setting value
1191
+
setting value
1192
+
finished setting value
1193
+
setting value
1194
+
finished setting value
1195
+
setting value
1196
+
finished setting value
1197
+
setting value
1198
+
finished setting value
1199
+
setting value
1200
+
finished setting value
1201
+
setting value
1202
+
finished setting value
1203
+
setting value
1204
+
finished setting value
1205
+
setting value
1206
+
finished setting value
1207
+
setting value
1208
+
finished setting value
1209
+
setting value
1210
+
finished setting value
1211
+
setting value
1212
+
finished setting value
1213
+
setting value
1214
+
finished setting value
1215
+
setting value
1216
+
finished setting value
1217
+
setting value
1218
+
finished setting value
1219
+
setting value
1220
+
setting value
1221
+
finished setting value
1222
+
finished setting value
1223
+
setting value
1224
+
finished setting value
1225
+
setting value
1226
+
finished setting value
1227
+
setting value
1228
+
finished setting value
1229
+
setting value
1230
+
finished setting value
1231
+
setting value
1232
+
finished setting value
1233
+
setting value
1234
+
finished setting value
1235
+
setting value
1236
+
finished setting value
1237
+
setting value
1238
+
finished setting value
1239
+
setting value
1240
+
finished setting value
1241
+
setting value
1242
+
finished setting value
1243
+
setting value
1244
+
finished setting value
1245
+
setting value
1246
+
finished setting value
1247
+
setting value
1248
+
finished setting value
1249
+
setting value
1250
+
finished setting value
1251
+
setting value
1252
+
finished setting value
1253
+
setting value
1254
+
finished setting value
1255
+
setting value
1256
+
finished setting value
1257
+
setting value
1258
+
finished setting value
1259
+
setting value
1260
+
finished setting value
1261
+
setting value
1262
+
finished setting value
1263
+
setting value
1264
+
finished setting value
1265
+
setting value
1266
+
finished setting value
1267
+
setting value
1268
+
finished setting value
1269
+
setting value
1270
+
finished setting value
1271
+
setting value
1272
+
finished setting value
1273
+
setting value
1274
+
finished setting value
1275
+
setting value
1276
+
finished setting value
1277
+
setting value
1278
+
finished setting value
1279
+
setting value
1280
+
finished setting value
1281
+
setting value
1282
+
finished setting value
1283
+
setting value
1284
+
finished setting value
1285
+
setting value
1286
+
finished setting value
1287
+
setting value
1288
+
finished setting value
1289
+
setting value
1290
+
finished setting value
1291
+
setting value
1292
+
finished setting value
1293
+
setting value
1294
+
finished setting value
1295
+
setting value
1296
+
finished setting value
1297
+
setting value
1298
+
finished setting value
1299
+
setting value
1300
+
finished setting value
1301
+
setting value
1302
+
finished setting value
1303
+
setting value
1304
+
finished setting value
1305
+
setting value
1306
+
finished setting value
1307
+
setting value
1308
+
finished setting value
1309
+
setting value
1310
+
finished setting value
1311
+
setting value
1312
+
finished setting value
1313
+
setting value
1314
+
finished setting value
1315
+
setting value
1316
+
finished setting value
1317
+
setting value
1318
+
finished setting value
1319
+
setting value
1320
+
finished setting value
1321
+
setting value
1322
+
finished setting value
1323
+
setting value
1324
+
finished setting value
1325
+
setting value
1326
+
finished setting value
1327
+
setting value
1328
+
finished setting value
1329
+
setting value
1330
+
finished setting value
1331
+
setting value
1332
+
finished setting value
1333
+
setting value
1334
+
finished setting value
1335
+
setting value
1336
+
finished setting value
1337
+
setting value
1338
+
finished setting value
1339
+
setting value
1340
+
finished setting value
1341
+
setting value
1342
+
finished setting value
1343
+
setting value
1344
+
finished setting value
1345
+
setting value
1346
+
finished setting value
1347
+
setting value
1348
+
finished setting value
1349
+
setting value
1350
+
finished setting value
1351
+
setting value
1352
+
finished setting value
1353
+
setting value
1354
+
finished setting value
1355
+
setting value
1356
+
finished setting value
1357
+
setting value
1358
+
finished setting value
1359
+
setting value
1360
+
finished setting value
1361
+
setting value
1362
+
finished setting value
1363
+
setting value
1364
+
finished setting value
1365
+
setting value
1366
+
finished setting value
1367
+
setting value
1368
+
finished setting value
1369
+
setting value
1370
+
finished setting value
1371
+
setting value
1372
+
finished setting value
1373
+
setting value
1374
+
finished setting value
1375
+
setting value
1376
+
finished setting value
1377
+
setting value
1378
+
finished setting value
1379
+
setting value
1380
+
finished setting value
1381
+
setting value
1382
+
finished setting value
1383
+
setting value
1384
+
finished setting value
1385
+
setting value
1386
+
finished setting value
1387
+
setting value
1388
+
finished setting value
1389
+
setting value
1390
+
finished setting value
1391
+
setting value
1392
+
finished setting value
1393
+
setting value
1394
+
finished setting value
1395
+
setting value
1396
+
finished setting value
1397
+
setting value
1398
+
finished setting value
1399
+
setting value
1400
+
finished setting value
1401
+
setting value
1402
+
finished setting value
1403
+
setting value
1404
+
finished setting value
1405
+
setting value
1406
+
finished setting value
1407
+
setting value
1408
+
finished setting value
1409
+
setting value
1410
+
finished setting value
1411
+
setting value
1412
+
finished setting value
1413
+
setting value
1414
+
finished setting value
1415
+
setting value
1416
+
finished setting value
1417
+
setting value
1418
+
finished setting value
1419
+
setting value
1420
+
finished setting value
1421
+
setting value
1422
+
finished setting value
1423
+
setting value
1424
+
finished setting value
1425
+
setting value
1426
+
finished setting value
1427
+
setting value
1428
+
finished setting value
1429
+
setting value
1430
+
finished setting value
1431
+
setting value
1432
+
finished setting value
1433
+
setting value
1434
+
finished setting value
1435
+
setting value
1436
+
finished setting value
1437
+
setting value
1438
+
finished setting value
1439
+
setting value
1440
+
finished setting value
1441
+
setting value
1442
+
finished setting value
1443
+
setting value
1444
+
finished setting value
1445
+
setting value
1446
+
finished setting value
1447
+
setting value
1448
+
finished setting value
1449
+
setting value
1450
+
finished setting value
1451
+
setting value
1452
+
finished setting value
1453
+
setting value
1454
+
finished setting value
1455
+
setting value
1456
+
finished setting value
1457
+
setting value
1458
+
finished setting value
1459
+
setting value
1460
+
finished setting value
1461
+
setting value
1462
+
finished setting value
1463
+
setting value
1464
+
finished setting value
1465
+
setting value
1466
+
finished setting value
1467
+
setting value
1468
+
finished setting value
1469
+
setting value
1470
+
finished setting value
1471
+
setting value
1472
+
finished setting value
1473
+
setting value
1474
+
finished setting value
1475
+
setting value
1476
+
finished setting value
1477
+
setting value
1478
+
finished setting value
1479
+
setting value
1480
+
finished setting value
1481
+
setting value
1482
+
finished setting value
1483
+
setting value
1484
+
finished setting value
1485
+
setting value
1486
+
finished setting value
1487
+
setting value
1488
+
finished setting value
1489
+
setting value
1490
+
finished setting value
1491
+
setting value
1492
+
finished setting value
1493
+
setting value
1494
+
finished setting value
1495
+
setting value
1496
+
finished setting value
1497
+
setting value
1498
+
finished setting value
1499
+
setting value
1500
+
finished setting value
1501
+
setting value
1502
+
finished setting value
1503
+
setting value
1504
+
finished setting value
1505
+
setting value
1506
+
finished setting value
1507
+
setting value
1508
+
finished setting value
1509
+
setting value
1510
+
finished setting value
1511
+
setting value
1512
+
finished setting value
1513
+
setting value
1514
+
finished setting value
1515
+
setting value
1516
+
finished setting value
1517
+
setting value
1518
+
finished setting value
1519
+
setting value
1520
+
finished setting value
1521
+
setting value
1522
+
finished setting value
1523
+
setting value
1524
+
finished setting value
1525
+
setting value
1526
+
finished setting value
1527
+
setting value
1528
+
finished setting value
1529
+
setting value
1530
+
finished setting value
1531
+
setting value
1532
+
finished setting value
1533
+
setting value
1534
+
finished setting value
1535
+
setting value
1536
+
finished setting value
1537
+
setting value
1538
+
finished setting value
1539
+
setting value
1540
+
finished setting value
1541
+
setting value
1542
+
finished setting value
1543
+
setting value
1544
+
finished setting value
1545
+
setting value
1546
+
finished setting value
1547
+
setting value
1548
+
finished setting value
1549
+
setting value
1550
+
finished setting value
1551
+
setting value
1552
+
finished setting value
1553
+
setting value
1554
+
finished setting value
1555
+
setting value
1556
+
finished setting value
1557
+
setting value
1558
+
finished setting value
1559
+
setting value
1560
+
finished setting value
1561
+
setting value
1562
+
finished setting value
1563
+
setting value
1564
+
finished setting value
1565
+
setting value
1566
+
finished setting value
1567
+
setting value
1568
+
finished setting value
1569
+
setting value
1570
+
finished setting value
1571
+
setting value
1572
+
finished setting value
1573
+
setting value
1574
+
finished setting value
1575
+
setting value
1576
+
finished setting value
1577
+
setting value
1578
+
finished setting value
1579
+
setting value
1580
+
finished setting value
1581
+
setting value
1582
+
finished setting value
1583
+
setting value
1584
+
finished setting value
1585
+
setting value
1586
+
finished setting value
1587
+
setting value
1588
+
finished setting value
1589
+
setting value
1590
+
finished setting value
1591
+
setting value
1592
+
finished setting value
1593
+
setting value
1594
+
finished setting value
1595
+
setting value
1596
+
finished setting value
1597
+
setting value
1598
+
finished setting value
1599
+
setting value
1600
+
finished setting value
1601
+
setting value
1602
+
finished setting value
1603
+
setting value
1604
+
finished setting value
1605
+
setting value
1606
+
finished setting value
1607
+
setting value
1608
+
finished setting value
1609
+
setting value
1610
+
finished setting value
1611
+
setting value
1612
+
finished setting value
1613
+
setting value
1614
+
finished setting value
1615
+
setting value
1616
+
finished setting value
1617
+
setting value
1618
+
finished setting value
1619
+
setting value
1620
+
finished setting value
1621
+
setting value
1622
+
finished setting value
1623
+
setting value
1624
+
finished setting value
1625
+
setting value
1626
+
finished setting value
1627
+
setting value
1628
+
finished setting value
1629
+
setting value
1630
+
finished setting value
1631
+
setting value
1632
+
finished setting value
1633
+
setting value
1634
+
finished setting value
1635
+
setting value
1636
+
finished setting value
1637
+
setting value
1638
+
finished setting value
1639
+
setting value
1640
+
finished setting value
1641
+
setting value
1642
+
finished setting value
1643
+
setting value
1644
+
finished setting value
1645
+
setting value
1646
+
finished setting value
1647
+
setting value
1648
+
finished setting value
1649
+
setting value
1650
+
finished setting value
1651
+
setting value
1652
+
finished setting value
1653
+
setting value
1654
+
finished setting value
1655
+
setting value
1656
+
finished setting value
1657
+
setting value
1658
+
finished setting value
1659
+
setting value
1660
+
finished setting value
1661
+
setting value
1662
+
finished setting value
1663
+
setting value
1664
+
finished setting value
1665
+
setting value
1666
+
finished setting value
1667
+
setting value
1668
+
finished setting value
1669
+
setting value
1670
+
finished setting value
1671
+
setting value
1672
+
finished setting value
1673
+
setting value
1674
+
finished setting value
1675
+
setting value
1676
+
finished setting value
1677
+
setting value
1678
+
finished setting value
1679
+
setting value
1680
+
finished setting value
1681
+
setting value
1682
+
finished setting value
1683
+
setting value
1684
+
finished setting value
1685
+
setting value
1686
+
finished setting value
1687
+
setting value
1688
+
finished setting value
1689
+
setting value
1690
+
finished setting value
1691
+
setting value
1692
+
finished setting value
1693
+
setting value
1694
+
finished setting value
1695
+
setting value
1696
+
finished setting value
1697
+
setting value
1698
+
finished setting value
1699
+
setting value
1700
+
finished setting value
1701
+
setting value
1702
+
finished setting value
1703
+
setting value
1704
+
finished setting value
1705
+
setting value
1706
+
finished setting value
1707
+
setting value
1708
+
finished setting value
1709
+
setting value
1710
+
finished setting value
1711
+
setting value
1712
+
finished setting value
1713
+
setting value
1714
+
finished setting value
1715
+
setting value
1716
+
finished setting value
1717
+
setting value
1718
+
finished setting value
1719
+
setting value
1720
+
finished setting value
1721
+
setting value
1722
+
finished setting value
1723
+
setting value
1724
+
finished setting value
1725
+
setting value
1726
+
finished setting value
1727
+
setting value
1728
+
finished setting value
1729
+
setting value
1730
+
finished setting value
1731
+
setting value
1732
+
finished setting value
1733
+
setting value
1734
+
finished setting value
1735
+
setting value
1736
+
finished setting value
1737
+
setting value
1738
+
finished setting value
1739
+
setting value
1740
+
finished setting value
1741
+
setting value
1742
+
finished setting value
1743
+
setting value
1744
+
finished setting value
1745
+
setting value
1746
+
finished setting value
1747
+
setting value
1748
+
finished setting value
1749
+
setting value
1750
+
finished setting value
1751
+
setting value
1752
+
finished setting value
1753
+
setting value
1754
+
finished setting value
1755
+
setting value
1756
+
finished setting value
1757
+
setting value
1758
+
finished setting value
1759
+
setting value
1760
+
finished setting value
1761
+
setting value
1762
+
finished setting value
1763
+
setting value
1764
+
finished setting value
1765
+
setting value
1766
+
finished setting value
1767
+
setting value
1768
+
finished setting value
1769
+
setting value
1770
+
finished setting value
1771
+
setting value
1772
+
finished setting value
1773
+
setting value
1774
+
finished setting value
1775
+
setting value
1776
+
finished setting value
1777
+
setting value
1778
+
finished setting value
1779
+
setting value
1780
+
finished setting value
1781
+
setting value
1782
+
finished setting value
1783
+
setting value
1784
+
finished setting value
1785
+
setting value
1786
+
finished setting value
1787
+
setting value
1788
+
finished setting value
1789
+
setting value
1790
+
finished setting value
1791
+
setting value
1792
+
finished setting value
1793
+
setting value
1794
+
finished setting value
1795
+
setting value
1796
+
finished setting value
1797
+
setting value
1798
+
finished setting value
1799
+
setting value
1800
+
finished setting value
1801
+
setting value
1802
+
finished setting value
1803
+
setting value
1804
+
finished setting value
1805
+
setting value
1806
+
finished setting value
1807
+
setting value
1808
+
finished setting value
1809
+
setting value
1810
+
finished setting value
1811
+
setting value
1812
+
finished setting value
1813
+
setting value
1814
+
finished setting value
1815
+
setting value
1816
+
finished setting value
1817
+
setting value
1818
+
finished setting value
1819
+
setting value
1820
+
finished setting value
1821
+
setting value
1822
+
finished setting value
1823
+
setting value
1824
+
finished setting value
1825
+
setting value
1826
+
finished setting value
1827
+
setting value
1828
+
finished setting value
1829
+
setting value
1830
+
finished setting value
1831
+
setting value
1832
+
finished setting value
1833
+
setting value
1834
+
finished setting value
1835
+
setting value
1836
+
finished setting value
1837
+
setting value
1838
+
finished setting value
1839
+
setting value
1840
+
finished setting value
1841
+
setting value
1842
+
finished setting value
1843
+
setting value
1844
+
finished setting value
1845
+
setting value
1846
+
finished setting value
1847
+
setting value
1848
+
finished setting value
1849
+
setting value
1850
+
finished setting value
1851
+
setting value
1852
+
finished setting value
1853
+
setting value
1854
+
finished setting value
1855
+
setting value
1856
+
finished setting value
1857
+
setting value
1858
+
finished setting value
1859
+
setting value
1860
+
finished setting value
1861
+
setting value
1862
+
finished setting value
1863
+
setting value
1864
+
finished setting value
1865
+
setting value
1866
+
finished setting value
1867
+
setting value
1868
+
finished setting value
1869
+
setting value
1870
+
finished setting value
1871
+
setting value
1872
+
finished setting value
1873
+
setting value
1874
+
finished setting value
1875
+
setting value
1876
+
finished setting value
1877
+
setting value
1878
+
finished setting value
1879
+
setting value
1880
+
finished setting value
1881
+
setting value
1882
+
finished setting value
1883
+
setting value
1884
+
finished setting value
1885
+
setting value
1886
+
finished setting value
1887
+
setting value
1888
+
finished setting value
1889
+
setting value
1890
+
finished setting value
1891
+
setting value
1892
+
finished setting value
1893
+
setting value
1894
+
finished setting value
1895
+
setting value
1896
+
finished setting value
1897
+
setting value
1898
+
finished setting value
1899
+
setting value
1900
+
finished setting value
1901
+
setting value
1902
+
finished setting value
1903
+
setting value
1904
+
finished setting value
1905
+
setting value
1906
+
finished setting value
1907
+
setting value
1908
+
finished setting value
1909
+
setting value
1910
+
finished setting value
1911
+
setting value
1912
+
finished setting value
1913
+
setting value
1914
+
finished setting value
1915
+
setting value
1916
+
finished setting value
1917
+
setting value
1918
+
finished setting value
1919
+
setting value
1920
+
finished setting value
1921
+
setting value
1922
+
finished setting value
1923
+
setting value
1924
+
finished setting value
1925
+
setting value
1926
+
finished setting value
1927
+
setting value
1928
+
finished setting value
1929
+
setting value
1930
+
finished setting value
1931
+
setting value
1932
+
finished setting value
1933
+
setting value
1934
+
finished setting value
1935
+
setting value
1936
+
finished setting value
1937
+
setting value
1938
+
finished setting value
1939
+
setting value
1940
+
finished setting value
1941
+
setting value
1942
+
finished setting value
1943
+
setting value
1944
+
finished setting value
1945
+
setting value
1946
+
finished setting value
1947
+
setting value
1948
+
finished setting value
1949
+
setting value
1950
+
finished setting value
1951
+
setting value
1952
+
finished setting value
1953
+
setting value
1954
+
finished setting value
1955
+
setting value
1956
+
finished setting value
1957
+
setting value
1958
+
finished setting value
1959
+
setting value
1960
+
finished setting value
1961
+
setting value
1962
+
finished setting value
1963
+
setting value
1964
+
finished setting value
1965
+
setting value
1966
+
finished setting value
1967
+
setting value
1968
+
finished setting value
1969
+
setting value
1970
+
finished setting value
1971
+
setting value
1972
+
finished setting value
1973
+
setting value
1974
+
finished setting value
1975
+
setting value
1976
+
finished setting value
1977
+
setting value
1978
+
finished setting value
1979
+
setting value
1980
+
finished setting value
1981
+
setting value
1982
+
finished setting value
1983
+
setting value
1984
+
finished setting value
1985
+
setting value
1986
+
finished setting value
1987
+
setting value
1988
+
finished setting value
1989
+
setting value
1990
+
finished setting value
1991
+
setting value
1992
+
finished setting value
1993
+
setting value
1994
+
finished setting value
1995
+
setting value
1996
+
finished setting value
1997
+
setting value
1998
+
finished setting value
1999
+
setting value
2000
+
finished setting value
2001
+
setting value
2002
+
finished setting value
2003
+
setting value
2004
+
finished setting value
2005
+
setting value
2006
+
finished setting value
2007
+
setting value
2008
+
finished setting value
2009
+
setting value
2010
+
finished setting value
2011
+
setting value
2012
+
finished setting value
2013
+
setting value
2014
+
finished setting value
2015
+
setting value
2016
+
finished setting value
2017
+
setting value
2018
+
finished setting value
2019
+
setting value
2020
+
finished setting value
2021
+
setting value
2022
+
finished setting value
2023
+
setting value
2024
+
finished setting value
2025
+
setting value
2026
+
finished setting value
2027
+
setting value
2028
+
finished setting value
2029
+
setting value
2030
+
finished setting value
2031
+
setting value
2032
+
finished setting value
2033
+
setting value
2034
+
finished setting value
2035
+
setting value
2036
+
finished setting value
2037
+
setting value
2038
+
finished setting value
2039
+
setting value
2040
+
finished setting value
2041
+
setting value
2042
+
finished setting value
2043
+
setting value
2044
+
finished setting value
2045
+
setting value
2046
+
finished setting value
2047
+
setting value
2048
+
finished setting value
2049
+
setting value
2050
+
finished setting value
2051
+
setting value
2052
+
finished setting value
2053
+
setting value
2054
+
finished setting value
2055
+
setting value
2056
+
finished setting value
2057
+
setting value
2058
+
finished setting value
2059
+
setting value
2060
+
finished setting value
2061
+
setting value
2062
+
finished setting value
2063
+
setting value
2064
+
finished setting value
2065
+
setting value
2066
+
finished setting value
2067
+
setting value
2068
+
finished setting value
2069
+
setting value
2070
+
finished setting value
2071
+
setting value
2072
+
finished setting value
2073
+
setting value
2074
+
finished setting value
2075
+
setting value
2076
+
finished setting value
2077
+
setting value
2078
+
finished setting value
2079
+
setting value
2080
+
finished setting value
2081
+
setting value
2082
+
finished setting value
2083
+
setting value
2084
+
finished setting value
2085
+
setting value
2086
+
finished setting value
2087
+
setting value
2088
+
finished setting value
2089
+
setting value
2090
+
finished setting value
2091
+
setting value
2092
+
finished setting value
2093
+
setting value
2094
+
finished setting value
2095
+
setting value
2096
+
finished setting value
2097
+
setting value
2098
+
finished setting value
2099
+
setting value
2100
+
finished setting value
2101
+
setting value
2102
+
finished setting value
2103
+
setting value
2104
+
finished setting value
2105
+
setting value
2106
+
finished setting value
2107
+
setting value
2108
+
finished setting value
2109
+
setting value
2110
+
finished setting value
2111
+
setting value
2112
+
finished setting value
2113
+
setting value
2114
+
finished setting value
2115
+
setting value
2116
+
finished setting value
2117
+
setting value
2118
+
finished setting value
2119
+
setting value
2120
+
finished setting value
2121
+
setting value
2122
+
finished setting value
2123
+
setting value
2124
+
finished setting value
2125
+
setting value
2126
+
finished setting value
2127
+
setting value
2128
+
finished setting value
2129
+
setting value
2130
+
finished setting value
2131
+
setting value
2132
+
finished setting value
2133
+
setting value
2134
+
finished setting value
2135
+
setting value
2136
+
finished setting value
2137
+
setting value
2138
+
finished setting value
2139
+
setting value
2140
+
finished setting value
2141
+
setting value
2142
+
finished setting value
2143
+
setting value
2144
+
finished setting value
2145
+
setting value
2146
+
finished setting value
2147
+
setting value
2148
+
finished setting value
2149
+
setting value
2150
+
finished setting value
2151
+
setting value
2152
+
finished setting value
2153
+
setting value
2154
+
finished setting value
2155
+
setting value
2156
+
finished setting value
2157
+
setting value
2158
+
finished setting value
2159
+
setting value
2160
+
finished setting value
2161
+
setting value
2162
+
finished setting value
2163
+
setting value
2164
+
finished setting value
2165
+
setting value
2166
+
finished setting value
2167
+
setting value
2168
+
finished setting value
2169
+
setting value
2170
+
finished setting value
2171
+
setting value
2172
+
finished setting value
2173
+
setting value
2174
+
finished setting value
2175
+
setting value
2176
+
finished setting value
2177
+
setting value
2178
+
finished setting value
2179
+
setting value
2180
+
finished setting value
2181
+
setting value
2182
+
finished setting value
2183
+
setting value
2184
+
finished setting value
2185
+
setting value
2186
+
finished setting value
2187
+
setting value
2188
+
finished setting value
2189
+
setting value
2190
+
finished setting value
2191
+
setting value
2192
+
finished setting value
2193
+
setting value
2194
+
finished setting value
2195
+
setting value
2196
+
finished setting value
2197
+
setting value
2198
+
finished setting value
2199
+
setting value
2200
+
finished setting value
2201
+
setting value
2202
+
finished setting value
2203
+
setting value
2204
+
finished setting value
2205
+
setting value
2206
+
finished setting value
2207
+
setting value
2208
+
finished setting value
2209
+
setting value
2210
+
finished setting value
2211
+
setting value
2212
+
finished setting value
2213
+
setting value
2214
+
finished setting value
2215
+
setting value
2216
+
finished setting value
2217
+
setting value
2218
+
finished setting value
2219
+
setting value
2220
+
finished setting value
2221
+
setting value
2222
+
finished setting value
2223
+
setting value
2224
+
setting value
2225
+
finished setting value
2226
+
finished setting value
2227
+
setting value
2228
+
finished setting value
2229
+
setting value
2230
+
finished setting value
2231
+
setting value
2232
+
finished setting value
2233
+
setting value
2234
+
finished setting value
2235
+
setting value
2236
+
finished setting value
2237
+
setting value
2238
+
finished setting value
2239
+
setting value
2240
+
finished setting value
2241
+
setting value
2242
+
finished setting value
2243
+
setting value
2244
+
finished setting value
2245
+
setting value
2246
+
finished setting value
2247
+
setting value
2248
+
finished setting value
2249
+
setting value
2250
+
finished setting value
2251
+
setting value
2252
+
finished setting value
2253
+
setting value
2254
+
finished setting value
2255
+
setting value
2256
+
finished setting value
2257
+
setting value
2258
+
finished setting value
2259
+
setting value
2260
+
finished setting value
2261
+
setting value
2262
+
finished setting value
2263
+
setting value
2264
+
finished setting value
2265
+
setting value
2266
+
finished setting value
2267
+
setting value
2268
+
finished setting value
2269
+
setting value
2270
+
finished setting value
2271
+
setting value
2272
+
finished setting value
2273
+
setting value
2274
+
finished setting value
2275
+
setting value
2276
+
finished setting value
2277
+
setting value
2278
+
finished setting value
2279
+
setting value
2280
+
finished setting value
2281
+
setting value
2282
+
finished setting value