jon.recoil.org
this repo has no description
Merge commit 'd1fa0143b5bb6a58f310f15d162a944a2c1e76c6' as 'js_top_worker'
+54
js_top_worker/.devcontainer/devcontainer.json
+54
js_top_worker/.devcontainer/devcontainer.json
···
1
+
{
2
+
"name": "Claude Code OCaml Sandbox",
3
+
"image": "ghcr.io/jonludlam/claude-ocaml-devcontainer:main",
4
+
"runArgs": [
5
+
"--cap-add=NET_ADMIN",
6
+
"--cap-add=NET_RAW",
7
+
"--init",
8
+
"--ipc=host",
9
+
"--cap-add=SYS_ADMIN"
10
+
],
11
+
"customizations": {
12
+
"vscode": {
13
+
"extensions": [
14
+
"anthropic.claude-code",
15
+
"dbaeumer.vscode-eslint",
16
+
"esbenp.prettier-vscode",
17
+
"eamodio.gitlens",
18
+
"ocamllabs.ocaml-platform"
19
+
],
20
+
"settings": {
21
+
"editor.formatOnSave": true,
22
+
"editor.defaultFormatter": "esbenp.prettier-vscode",
23
+
"editor.codeActionsOnSave": {
24
+
"source.fixAll.eslint": "explicit"
25
+
},
26
+
"terminal.integrated.defaultProfile.linux": "zsh",
27
+
"terminal.integrated.profiles.linux": {
28
+
"bash": {
29
+
"path": "bash",
30
+
"icon": "terminal-bash"
31
+
},
32
+
"zsh": {
33
+
"path": "zsh"
34
+
}
35
+
}
36
+
}
37
+
}
38
+
},
39
+
"remoteUser": "node",
40
+
"mounts": [
41
+
"source=claude-code-bashhistory-${devcontainerId},target=/commandhistory,type=volume",
42
+
"source=${localEnv:HOME}/.claude,target=/home/node/.claude,type=bind",
43
+
"source=${localEnv:HOME}/.ssh,target=/home/node/.ssh,type=bind,readonly",
44
+
"source=${localEnv:HOME}/.gitconfig,target=/home/node/.gitconfig,type=bind,readonly"
45
+
],
46
+
"containerEnv": {
47
+
"NODE_OPTIONS": "--max-old-space-size=4096",
48
+
"CLAUDE_CONFIG_DIR": "/home/node/.claude",
49
+
"POWERLEVEL9K_DISABLE_GITSTATUS": "true"
50
+
},
51
+
"workspaceMount": "source=${localWorkspaceFolder},target=/workspace,type=bind,consistency=delegated",
52
+
"workspaceFolder": "/workspace",
53
+
"waitFor": "postStartCommand"
54
+
}
+41
js_top_worker/.github/workflows/ci.yml
+41
js_top_worker/.github/workflows/ci.yml
···
1
+
name: CI
2
+
3
+
on:
4
+
push:
5
+
branches: [main, master]
6
+
pull_request:
7
+
branches: [main, master]
8
+
9
+
jobs:
10
+
build:
11
+
runs-on: ubuntu-latest
12
+
13
+
strategy:
14
+
fail-fast: false
15
+
matrix:
16
+
ocaml-compiler:
17
+
- "5.2"
18
+
- "5.3"
19
+
20
+
steps:
21
+
- name: Checkout code
22
+
uses: actions/checkout@v4
23
+
24
+
- name: Set up OCaml ${{ matrix.ocaml-compiler }}
25
+
uses: ocaml/setup-ocaml@v3
26
+
with:
27
+
ocaml-compiler: ${{ matrix.ocaml-compiler }}
28
+
29
+
- name: Install Node.js
30
+
uses: actions/setup-node@v4
31
+
with:
32
+
node-version: "20"
33
+
34
+
- name: Install dependencies
35
+
run: opam install . --deps-only --with-test
36
+
37
+
- name: Build
38
+
run: opam exec -- dune build
39
+
40
+
- name: Run tests
41
+
run: opam exec -- dune runtest
+13
js_top_worker/.gitignore
+13
js_top_worker/.gitignore
+1
js_top_worker/.ocamlformat
+1
js_top_worker/.ocamlformat
···
1
+
version=0.27.0
+1
js_top_worker/.ocamlformat-ignore
+1
js_top_worker/.ocamlformat-ignore
···
1
+
lib/worker.cppo.ml
+6
js_top_worker/.vscode/settings.json
+6
js_top_worker/.vscode/settings.json
+67
js_top_worker/CLAUDE.md
+67
js_top_worker/CLAUDE.md
···
1
+
# CLAUDE.md
2
+
3
+
This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository.
4
+
5
+
## Project Overview
6
+
7
+
This is an OCaml toplevel (REPL) designed to run in a web worker. The project consists of multiple OPAM packages that work together to provide an OCaml interactive environment in the browser.
8
+
9
+
## Build Commands
10
+
11
+
```bash
12
+
# Build the entire project
13
+
dune build
14
+
15
+
# Run tests
16
+
dune runtest
17
+
18
+
# Build and watch for changes
19
+
dune build --watch
20
+
21
+
# Run a specific test
22
+
dune test test/cram
23
+
```
24
+
25
+
## Running the Example
26
+
27
+
The worker needs to be served by an HTTP server rather than loaded from the filesystem:
28
+
29
+
```bash
30
+
dune build
31
+
cd _build/default/example
32
+
python3 -m http.server 8000
33
+
# Then open http://localhost:8000/
34
+
```
35
+
36
+
## Architecture
37
+
38
+
The codebase is organized into several interconnected packages:
39
+
40
+
- **js_top_worker**: Core library implementing the OCaml toplevel functionality
41
+
- **js_top_worker-web**: Web-specific worker implementation with browser integration
42
+
- **js_top_worker-client**: Client library for communicating with the worker (Lwt-based)
43
+
- **js_top_worker-client_fut**: Alternative client library using Fut for concurrency
44
+
- **js_top_worker-rpc**: RPC definitions and communication layer
45
+
- **js_top_worker-unix**: Unix implementation for testing outside the browser
46
+
- **js_top_worker-bin**: Command-line tools including `jtw` for package management
47
+
48
+
Key directories:
49
+
- `lib/`: Core toplevel implementation with OCaml compiler integration
50
+
- `idl/`: RPC interface definitions using `ppx_deriving_rpc`
51
+
- `example/`: Example applications demonstrating worker usage
52
+
- `bin/`: Command-line tools, notably `jtw` for OPAM package handling
53
+
54
+
The system uses RPC (via `rpclib`) for communication between the client and worker, with support for both browser WebWorkers and Unix sockets for testing.
55
+
56
+
## Technical Q&A Log
57
+
58
+
When the user asks technical questions about the codebase, tools, or dependencies (especially js_of_ocaml, dune, findlib, etc.), Claude should:
59
+
60
+
1. **Answer the question** with technical accuracy
61
+
2. **Record the Q&A** in `docs/technical-qa.md` with:
62
+
- The question asked
63
+
- The answer provided
64
+
- Verification steps taken (code inspection, testing, documentation lookup)
65
+
- Date of the entry
66
+
67
+
This creates institutional knowledge that persists across sessions.
+13
js_top_worker/README.md
+13
js_top_worker/README.md
···
1
+
# An OCaml toplevel designed to run in a web worker
2
+
3
+
To run the example, the worker needs to be served by an http server rather
4
+
than loaded from the filesystem. Therefore the example may be run in the
5
+
following way:
6
+
7
+
```
8
+
$ dune build
9
+
$ cd _build/default/example
10
+
$ python3 -m http.server 8000
11
+
```
12
+
13
+
and then opening the URL `http://localhost:8000/`
+35
js_top_worker/bin/cmd_outputs.ml
+35
js_top_worker/bin/cmd_outputs.ml
···
1
+
type log_dest =
2
+
[ `Compile
3
+
| `Compile_src
4
+
| `Link
5
+
| `Count_occurrences
6
+
| `Generate
7
+
| `Index
8
+
| `Sherlodoc
9
+
| `Classify ]
10
+
11
+
type log_line = { log_dest : log_dest; prefix : string; run : Run.t }
12
+
13
+
let outputs : log_line list ref = ref []
14
+
15
+
let maybe_log log_dest run =
16
+
match log_dest with
17
+
| Some (log_dest, prefix) ->
18
+
outputs := !outputs @ [ { log_dest; run; prefix } ]
19
+
| None -> ()
20
+
21
+
let submit log_dest desc cmd output_file =
22
+
match Worker_pool.submit desc cmd output_file with
23
+
| Ok x ->
24
+
maybe_log log_dest x;
25
+
String.split_on_char '\n' x.output
26
+
| Error exn -> raise exn
27
+
28
+
let submit_ignore_failures log_dest desc cmd output_file =
29
+
match Worker_pool.submit desc cmd output_file with
30
+
| Ok x ->
31
+
maybe_log log_dest x;
32
+
()
33
+
| Error exn ->
34
+
Logs.err (fun m -> m "Error: %s" (Printexc.to_string exn));
35
+
()
+15
js_top_worker/bin/dune
+15
js_top_worker/bin/dune
+571
js_top_worker/bin/jtw.ml
+571
js_top_worker/bin/jtw.ml
···
1
+
(** Try to relativize a path against findlib_dir. If the result contains
2
+
".." (indicating the path is in a different tree), fall back to extracting
3
+
the path components after "lib" directory. *)
4
+
let relativize_or_fallback ~findlib_dir path =
5
+
(* First try standard relativize *)
6
+
let rel = match Fpath.relativize ~root:findlib_dir path with
7
+
| Some rel -> rel
8
+
| None -> path (* shouldn't happen for absolute paths, but fallback *)
9
+
in
10
+
(* If the result contains "..", use fallback instead *)
11
+
let segs = Fpath.segs rel in
12
+
if List.mem ".." segs then begin
13
+
(* Fallback: use path components after "lib" directory *)
14
+
let path_segs = Fpath.segs path in
15
+
let rec find_after_lib = function
16
+
| [] -> Fpath.v (Fpath.basename path)
17
+
| "lib" :: rest -> Fpath.v (String.concat Fpath.dir_sep rest)
18
+
| _ :: rest -> find_after_lib rest
19
+
in
20
+
find_after_lib path_segs
21
+
end else
22
+
rel
23
+
24
+
let cmi_files dir =
25
+
Bos.OS.Dir.fold_contents ~traverse:`None ~elements:`Files
26
+
(fun path acc ->
27
+
if Fpath.has_ext ".cmi" path then Fpath.filename path :: acc else acc)
28
+
[] dir
29
+
30
+
let gen_cmis ?path_prefix cmis =
31
+
let gen_one (dir, cmis) =
32
+
let all_cmis =
33
+
List.map (fun s -> String.sub s 0 (String.length s - 4)) cmis
34
+
in
35
+
let hidden, non_hidden =
36
+
List.partition (fun x -> Astring.String.is_infix ~affix:"__" x) all_cmis
37
+
in
38
+
let prefixes =
39
+
List.filter_map
40
+
(fun x ->
41
+
match Astring.String.cuts ~sep:"__" x with
42
+
| x :: _ -> Some (x ^ "__")
43
+
| _ -> None)
44
+
hidden
45
+
in
46
+
let prefixes = Util.StringSet.(of_list prefixes |> to_list) in
47
+
let findlib_dir = Ocamlfind.findlib_dir () |> Fpath.v in
48
+
let d = relativize_or_fallback ~findlib_dir dir in
49
+
(* Include path_prefix in dcs_url so it's correct relative to HTTP root *)
50
+
let dcs_url_path = match path_prefix with
51
+
| Some prefix -> Fpath.(v prefix / "lib" // d)
52
+
| None -> Fpath.(v "lib" // d)
53
+
in
54
+
let dcs =
55
+
{
56
+
Js_top_worker_rpc.Toplevel_api_gen.dcs_url = Fpath.to_string dcs_url_path;
57
+
dcs_toplevel_modules = List.map String.capitalize_ascii non_hidden;
58
+
dcs_file_prefixes = prefixes;
59
+
}
60
+
in
61
+
( dir,
62
+
Jsonrpc.to_string
63
+
(Rpcmarshal.marshal
64
+
Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis dcs) )
65
+
in
66
+
List.map gen_one cmis
67
+
68
+
(** Read dependency paths from a file (one path per line) *)
69
+
let read_deps_file path =
70
+
match Bos.OS.File.read_lines (Fpath.v path) with
71
+
| Ok lines -> List.filter (fun s -> String.length s > 0) lines
72
+
| Error (`Msg m) ->
73
+
Format.eprintf "Warning: Failed to read deps file %s: %s\n%!" path m;
74
+
[]
75
+
76
+
let opam verbose output_dir_str switch libraries no_worker path deps_file =
77
+
Opam.switch := switch;
78
+
(* When --path is specified, only compile the specified libraries (no deps) *)
79
+
let libraries_with_deps, libraries_only =
80
+
match Ocamlfind.deps libraries with
81
+
| Ok l ->
82
+
let all = Util.StringSet.of_list ("stdlib" :: l) in
83
+
(* In --path mode, don't auto-add stdlib - only include requested libs *)
84
+
let only = Util.StringSet.of_list libraries in
85
+
(all, only)
86
+
| Error (`Msg m) ->
87
+
Format.eprintf "Failed to find libs: %s\n%!" m;
88
+
failwith ("Bad libs: " ^ m)
89
+
in
90
+
(* In path mode, only compile the specified packages *)
91
+
let libraries = if path <> None then libraries_only else libraries_with_deps in
92
+
(* Read dependency paths from file if specified *)
93
+
let dep_paths = match deps_file with
94
+
| Some f -> read_deps_file f
95
+
| None -> []
96
+
in
97
+
Eio_main.run @@ fun env ->
98
+
Eio.Switch.run @@ fun sw ->
99
+
if verbose then Logs.set_level (Some Logs.Debug) else Logs.set_level None;
100
+
Logs.set_reporter (Logs_fmt.reporter ());
101
+
let () = Worker_pool.start_workers env sw 16 in
102
+
Logs.debug (fun m ->
103
+
m "Libraries: %a"
104
+
(Fmt.list ~sep:Fmt.comma Fmt.string)
105
+
(Util.StringSet.elements libraries));
106
+
(* output_dir is always from -o; --path is a subdirectory within it *)
107
+
let base_output_dir = Fpath.v output_dir_str in
108
+
let output_dir =
109
+
match path with
110
+
| Some p -> Fpath.(base_output_dir // v p)
111
+
| None -> base_output_dir
112
+
in
113
+
let meta_files =
114
+
List.map
115
+
(fun lib -> Ocamlfind.meta_file lib)
116
+
(Util.StringSet.elements libraries)
117
+
|> Util.StringSet.of_list
118
+
in
119
+
let cmi_dirs =
120
+
match Ocamlfind.deps (Util.StringSet.to_list libraries) with
121
+
| Ok libs ->
122
+
let dirs =
123
+
List.filter_map
124
+
(fun lib ->
125
+
match Ocamlfind.get_dir lib with Ok x -> Some x | _ -> None)
126
+
libs
127
+
in
128
+
dirs
129
+
| Error (`Msg m) ->
130
+
Format.eprintf "Failed to find libs: %s\n%!" m;
131
+
[]
132
+
in
133
+
Format.eprintf "cmi_dirs: %a\n%!" (Fmt.list ~sep:Fmt.comma Fpath.pp) cmi_dirs;
134
+
(* In --path mode, only include cmi dirs from specified libraries and their
135
+
subpackages, not external dependencies *)
136
+
let cmi_dirs_to_copy =
137
+
if path <> None then
138
+
let lib_dirs =
139
+
List.filter_map
140
+
(fun lib ->
141
+
match Ocamlfind.get_dir lib with Ok x -> Some x | _ -> None)
142
+
(Util.StringSet.to_list libraries)
143
+
in
144
+
(* Filter cmi_dirs to include directories that are equal to or subdirectories
145
+
of lib_dirs. This includes subpackages like base.base_internalhash_types.
146
+
We check that the relative path doesn't start with ".." *)
147
+
List.filter
148
+
(fun dir ->
149
+
List.exists
150
+
(fun lib_dir ->
151
+
Fpath.equal dir lib_dir ||
152
+
match Fpath.relativize ~root:lib_dir dir with
153
+
| Some rel ->
154
+
let segs = Fpath.segs rel in
155
+
(match segs with
156
+
| ".." :: _ -> false (* Goes outside lib_dir *)
157
+
| _ -> true)
158
+
| None -> false)
159
+
lib_dirs)
160
+
cmi_dirs
161
+
else
162
+
cmi_dirs
163
+
in
164
+
let cmis =
165
+
List.fold_left
166
+
(fun acc dir ->
167
+
match cmi_files dir with
168
+
| Ok files -> (dir, files) :: acc
169
+
| Error _ -> acc)
170
+
[] cmi_dirs_to_copy
171
+
in
172
+
let ( let* ) = Result.bind in
173
+
174
+
let _ =
175
+
let* _ = Bos.OS.Dir.create output_dir in
176
+
let findlib_dir = Ocamlfind.findlib_dir () |> Fpath.v in
177
+
178
+
List.iter
179
+
(fun (dir, files) ->
180
+
let d = relativize_or_fallback ~findlib_dir dir in
181
+
List.iter
182
+
(fun f ->
183
+
let dest_dir = Fpath.(output_dir / "lib" // d) in
184
+
let dest = Fpath.(dest_dir / f) in
185
+
let _ = Bos.OS.Dir.create ~path:true dest_dir in
186
+
match Bos.OS.File.exists dest with
187
+
| Ok true -> ()
188
+
| Ok false -> Util.cp Fpath.(dir / f) dest
189
+
| Error _ -> failwith "file exists failed")
190
+
files)
191
+
cmis;
192
+
193
+
let meta_rels =
194
+
Util.StringSet.fold
195
+
(fun meta_file acc ->
196
+
let meta_file = Fpath.v meta_file in
197
+
let d =
198
+
Fpath.relativize ~root:findlib_dir meta_file
199
+
|> Option.get |> Fpath.parent
200
+
in
201
+
(meta_file, d) :: acc)
202
+
meta_files []
203
+
in
204
+
205
+
List.iter
206
+
(fun (meta_file, d) ->
207
+
let dest = Fpath.(output_dir / "lib" // d) in
208
+
let _ = Bos.OS.Dir.create dest in
209
+
Util.cp meta_file dest)
210
+
meta_rels;
211
+
212
+
(* Generate findlib_index as JSON with metas field *)
213
+
let metas_json =
214
+
List.map
215
+
(fun (meta_file, d) ->
216
+
let file = Fpath.filename meta_file in
217
+
let rel_path = Fpath.(v "lib" // d / file) in
218
+
`String (Fpath.to_string rel_path))
219
+
meta_rels
220
+
in
221
+
(* TODO: dep_paths should also contribute META paths once we have full universe info *)
222
+
let _ = dep_paths in
223
+
let findlib_json = `Assoc [("metas", `List metas_json)] in
224
+
Out_channel.with_open_bin
225
+
Fpath.(output_dir / "findlib_index" |> to_string)
226
+
(fun oc -> Printf.fprintf oc "%s\n" (Yojson.Safe.to_string findlib_json));
227
+
228
+
(* Compile archives for each library AND its subpackages *)
229
+
Util.StringSet.iter
230
+
(fun lib ->
231
+
(* Get subpackages (e.g., base.base_internalhash_types for base) *)
232
+
let sub_libs = Ocamlfind.sub_libraries lib in
233
+
let all_libs = Util.StringSet.add lib sub_libs in
234
+
Util.StringSet.iter
235
+
(fun sub_lib ->
236
+
match Ocamlfind.get_dir sub_lib with
237
+
| Error _ -> ()
238
+
| Ok dir ->
239
+
let archives = Ocamlfind.archives sub_lib in
240
+
let archives = List.map (fun x -> Fpath.(dir / x)) archives in
241
+
let d = relativize_or_fallback ~findlib_dir dir in
242
+
let dest = Fpath.(output_dir / "lib" // d) in
243
+
let (_ : (bool, _) result) = Bos.OS.Dir.create dest in
244
+
let compile_archive archive =
245
+
let output = Fpath.(dest / (Fpath.filename archive ^ ".js")) in
246
+
let js_runtime = Ocamlfind.jsoo_runtime sub_lib in
247
+
let js_files =
248
+
List.map (fun f -> Fpath.(dir / f |> to_string)) js_runtime
249
+
in
250
+
let base_cmd =
251
+
match switch with
252
+
| None -> Bos.Cmd.(v "js_of_ocaml")
253
+
| Some s ->
254
+
Bos.Cmd.(v "opam" % "exec" % "--switch" % s % "--" % "js_of_ocaml")
255
+
in
256
+
let cmd =
257
+
Bos.Cmd.(
258
+
base_cmd % "compile" % "--toplevel" % "--include-runtime"
259
+
% "--effects=disabled")
260
+
in
261
+
let cmd = List.fold_left (fun c f -> Bos.Cmd.(c % f)) cmd js_files in
262
+
let cmd =
263
+
Bos.Cmd.(cmd % Fpath.to_string archive % "-o" % Fpath.to_string output)
264
+
in
265
+
ignore (Util.lines_of_process cmd)
266
+
in
267
+
List.iter compile_archive archives)
268
+
all_libs)
269
+
libraries;
270
+
271
+
(* Format.eprintf "@[<hov 2>dir: %a [%a]@]\n%!" Fpath.pp dir (Fmt.list ~sep:Fmt.sp Fmt.string) files) cmis; *)
272
+
Ok ()
273
+
in
274
+
let init_cmis = gen_cmis ?path_prefix:path cmis in
275
+
List.iter
276
+
(fun (dir, dcs) ->
277
+
let findlib_dir = Ocamlfind.findlib_dir () |> Fpath.v in
278
+
let d = Fpath.relativize ~root:findlib_dir dir in
279
+
match d with
280
+
| None ->
281
+
Format.eprintf "Failed to relativize %a wrt %a\n%!" Fpath.pp dir
282
+
Fpath.pp findlib_dir
283
+
| Some dir ->
284
+
Format.eprintf "Generating %a\n%!" Fpath.pp dir;
285
+
let dir = Fpath.(output_dir / "lib" // dir) in
286
+
let _ = Bos.OS.Dir.create dir in
287
+
let oc = open_out Fpath.(dir / "dynamic_cmis.json" |> to_string) in
288
+
Printf.fprintf oc "%s" dcs;
289
+
close_out oc)
290
+
init_cmis;
291
+
Format.eprintf "Number of cmis: %d\n%!" (List.length init_cmis);
292
+
293
+
let () =
294
+
if no_worker then () else Mk_backend.mk switch output_dir
295
+
in
296
+
297
+
`Ok ()
298
+
299
+
(** Generate a single package's universe directory.
300
+
Returns (pkg_path, meta_path) where meta_path is the full path to META
301
+
relative to the output_dir root. *)
302
+
let generate_package_universe ~switch ~output_dir ~findlib_dir ~pkg ~pkg_deps =
303
+
(* Use package name as directory path *)
304
+
let pkg_path = pkg in
305
+
let pkg_output_dir = Fpath.(output_dir / pkg_path) in
306
+
let _ = Bos.OS.Dir.create ~path:true pkg_output_dir in
307
+
308
+
(* Get the package's directory and copy cmi files *)
309
+
let pkg_dir = match Ocamlfind.get_dir pkg with
310
+
| Ok d -> d
311
+
| Error _ -> failwith ("Cannot find package: " ^ pkg)
312
+
in
313
+
314
+
(* Also include subpackages (directories under pkg_dir) *)
315
+
let all_pkg_dirs =
316
+
let sub_libs = Ocamlfind.sub_libraries pkg in
317
+
Util.StringSet.fold (fun sub acc ->
318
+
match Ocamlfind.get_dir sub with
319
+
| Ok d -> d :: acc
320
+
| Error _ -> acc)
321
+
sub_libs [pkg_dir]
322
+
|> List.sort_uniq Fpath.compare
323
+
in
324
+
325
+
(* Copy cmi files *)
326
+
List.iter (fun dir ->
327
+
match cmi_files dir with
328
+
| Ok files ->
329
+
let d = relativize_or_fallback ~findlib_dir dir in
330
+
List.iter (fun f ->
331
+
let dest_dir = Fpath.(pkg_output_dir / "lib" // d) in
332
+
let dest = Fpath.(dest_dir / f) in
333
+
let _ = Bos.OS.Dir.create ~path:true dest_dir in
334
+
match Bos.OS.File.exists dest with
335
+
| Ok true -> ()
336
+
| Ok false -> Util.cp Fpath.(dir / f) dest
337
+
| Error _ -> ())
338
+
files
339
+
| Error _ -> ())
340
+
all_pkg_dirs;
341
+
342
+
(* Copy META file *)
343
+
let meta_file = Fpath.v (Ocamlfind.meta_file pkg) in
344
+
let meta_rel = relativize_or_fallback ~findlib_dir meta_file |> Fpath.parent in
345
+
let meta_dest = Fpath.(pkg_output_dir / "lib" // meta_rel) in
346
+
let _ = Bos.OS.Dir.create ~path:true meta_dest in
347
+
Util.cp meta_file meta_dest;
348
+
349
+
(* Compile archives for main package and all subpackages *)
350
+
let sub_libs = Ocamlfind.sub_libraries pkg in
351
+
let all_libs = Util.StringSet.add pkg sub_libs in
352
+
Util.StringSet.iter (fun lib ->
353
+
match Ocamlfind.get_dir lib with
354
+
| Error _ -> ()
355
+
| Ok lib_dir ->
356
+
let archives = Ocamlfind.archives lib in
357
+
let archives = List.map (fun x -> Fpath.(lib_dir / x)) archives in
358
+
let d = relativize_or_fallback ~findlib_dir lib_dir in
359
+
let dest = Fpath.(pkg_output_dir / "lib" // d) in
360
+
let _ = Bos.OS.Dir.create ~path:true dest in
361
+
List.iter (fun archive ->
362
+
let output = Fpath.(dest / (Fpath.filename archive ^ ".js")) in
363
+
let js_runtime = Ocamlfind.jsoo_runtime lib in
364
+
let js_files = List.map (fun f -> Fpath.(lib_dir / f |> to_string)) js_runtime in
365
+
let base_cmd = match switch with
366
+
| None -> Bos.Cmd.(v "js_of_ocaml")
367
+
| Some s -> Bos.Cmd.(v "opam" % "exec" % "--switch" % s % "--" % "js_of_ocaml")
368
+
in
369
+
let cmd = Bos.Cmd.(base_cmd % "compile" % "--toplevel" % "--include-runtime" % "--effects=disabled") in
370
+
let cmd = List.fold_left (fun c f -> Bos.Cmd.(c % f)) cmd js_files in
371
+
let cmd = Bos.Cmd.(cmd % Fpath.to_string archive % "-o" % Fpath.to_string output) in
372
+
ignore (Util.lines_of_process cmd))
373
+
archives)
374
+
all_libs;
375
+
376
+
(* Generate dynamic_cmis.json for each directory *)
377
+
List.iter (fun dir ->
378
+
match cmi_files dir with
379
+
| Ok files ->
380
+
let all_cmis = List.map (fun s -> String.sub s 0 (String.length s - 4)) files in
381
+
let hidden, non_hidden = List.partition (fun x -> Astring.String.is_infix ~affix:"__" x) all_cmis in
382
+
let prefixes = List.filter_map (fun x ->
383
+
match Astring.String.cuts ~sep:"__" x with
384
+
| x :: _ -> Some (x ^ "__")
385
+
| _ -> None) hidden in
386
+
let prefixes = Util.StringSet.(of_list prefixes |> to_list) in
387
+
let d = relativize_or_fallback ~findlib_dir dir in
388
+
(* Include pkg_path in dcs_url so it's correct relative to the HTTP root *)
389
+
let dcs = {
390
+
Js_top_worker_rpc.Toplevel_api_gen.dcs_url = Fpath.(v pkg_path / "lib" // d |> to_string);
391
+
dcs_toplevel_modules = List.map String.capitalize_ascii non_hidden;
392
+
dcs_file_prefixes = prefixes;
393
+
} in
394
+
let dcs_json = Jsonrpc.to_string (Rpcmarshal.marshal Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis dcs) in
395
+
let dcs_dir = Fpath.(pkg_output_dir / "lib" // d) in
396
+
let _ = Bos.OS.Dir.create ~path:true dcs_dir in
397
+
let oc = open_out Fpath.(dcs_dir / "dynamic_cmis.json" |> to_string) in
398
+
Printf.fprintf oc "%s" dcs_json;
399
+
close_out oc
400
+
| Error _ -> ())
401
+
all_pkg_dirs;
402
+
403
+
(* Return pkg_path and the META path relative to pkg_path *)
404
+
let local_meta_path = Fpath.(v "lib" // meta_rel / "META" |> to_string) in
405
+
(pkg_path, local_meta_path, pkg_deps)
406
+
407
+
let opam_all verbose output_dir_str switch libraries no_worker all_pkgs =
408
+
Opam.switch := switch;
409
+
410
+
(* Get all packages and their dependencies *)
411
+
let all_packages =
412
+
if all_pkgs then
413
+
(* Build all installed packages *)
414
+
Ocamlfind.all ()
415
+
else if libraries = [] then
416
+
(* No packages specified, just stdlib *)
417
+
["stdlib"]
418
+
else
419
+
match Ocamlfind.deps libraries with
420
+
| Ok l -> "stdlib" :: l
421
+
| Error (`Msg m) -> failwith ("Failed to find libs: " ^ m)
422
+
in
423
+
424
+
(* Remove duplicates and sort *)
425
+
let all_packages = Util.StringSet.(of_list all_packages |> to_list) in
426
+
427
+
Format.eprintf "Generating universes for %d packages\n%!" (List.length all_packages);
428
+
429
+
Eio_main.run @@ fun env ->
430
+
Eio.Switch.run @@ fun sw ->
431
+
if verbose then Logs.set_level (Some Logs.Debug) else Logs.set_level None;
432
+
Logs.set_reporter (Logs_fmt.reporter ());
433
+
let () = Worker_pool.start_workers env sw 16 in
434
+
435
+
let output_dir = Fpath.v output_dir_str in
436
+
let _ = Bos.OS.Dir.create ~path:true output_dir in
437
+
let findlib_dir = Ocamlfind.findlib_dir () |> Fpath.v in
438
+
439
+
(* Build dependency map: package -> list of direct dependency paths *)
440
+
let dep_map = Hashtbl.create 64 in
441
+
List.iter (fun pkg ->
442
+
let deps = match Ocamlfind.deps [pkg] with
443
+
| Ok l -> List.filter (fun d -> d <> pkg) l (* Remove self from deps *)
444
+
| Error _ -> []
445
+
in
446
+
Hashtbl.add dep_map pkg deps)
447
+
all_packages;
448
+
449
+
(* Generate each package and collect results *)
450
+
let pkg_results = List.map (fun pkg ->
451
+
Format.eprintf "Generating %s...\n%!" pkg;
452
+
let pkg_deps = Hashtbl.find dep_map pkg in
453
+
generate_package_universe ~switch ~output_dir ~findlib_dir ~pkg ~pkg_deps)
454
+
all_packages
455
+
in
456
+
457
+
(* Build a map from package name to full META path *)
458
+
let meta_path_map = Hashtbl.create 64 in
459
+
List.iter (fun (pkg_path, local_meta_path, _deps) ->
460
+
let full_meta_path = pkg_path ^ "/" ^ local_meta_path in
461
+
Hashtbl.add meta_path_map pkg_path full_meta_path)
462
+
pkg_results;
463
+
464
+
(* Generate findlib_index for each package with correct META paths *)
465
+
List.iter (fun (pkg_path, local_meta_path, deps) ->
466
+
let this_meta = pkg_path ^ "/" ^ local_meta_path in
467
+
let dep_metas = List.filter_map (fun dep ->
468
+
match Hashtbl.find_opt meta_path_map dep with
469
+
| Some path -> Some path
470
+
| None ->
471
+
Format.eprintf "Warning: no META path found for dep %s\n%!" dep;
472
+
None)
473
+
deps
474
+
in
475
+
let all_metas = this_meta :: dep_metas in
476
+
let findlib_json = `Assoc [("metas", `List (List.map (fun s -> `String s) all_metas))] in
477
+
Out_channel.with_open_bin Fpath.(output_dir / pkg_path / "findlib_index" |> to_string)
478
+
(fun oc -> Printf.fprintf oc "%s\n" (Yojson.Safe.to_string findlib_json)))
479
+
pkg_results;
480
+
481
+
(* Generate root findlib_index with all META paths *)
482
+
let all_metas = List.map (fun (pkg_path, local_meta_path, _) ->
483
+
pkg_path ^ "/" ^ local_meta_path)
484
+
pkg_results
485
+
in
486
+
let root_index = `Assoc [("metas", `List (List.map (fun s -> `String s) all_metas))] in
487
+
Out_channel.with_open_bin Fpath.(output_dir / "findlib_index" |> to_string)
488
+
(fun oc -> Printf.fprintf oc "%s\n" (Yojson.Safe.to_string root_index));
489
+
490
+
Format.eprintf "Generated root findlib_index with %d META files\n%!" (List.length pkg_results);
491
+
492
+
(* Generate worker.js if requested *)
493
+
let () = if no_worker then () else Mk_backend.mk switch output_dir in
494
+
495
+
`Ok ()
496
+
497
+
open Cmdliner
498
+
499
+
let opam_cmd =
500
+
let libraries = Arg.(value & pos_all string [] & info [] ~docv:"LIB") in
501
+
let output_dir =
502
+
let doc =
503
+
"Output directory in which to put all outputs. This should be the root \
504
+
directory of the HTTP server. Ignored when --path is specified."
505
+
in
506
+
Arg.(value & opt string "html" & info [ "o"; "output" ] ~doc)
507
+
in
508
+
let verbose =
509
+
let doc = "Enable verbose logging" in
510
+
Arg.(value & flag & info [ "v"; "verbose" ] ~doc) in
511
+
let no_worker =
512
+
let doc = "Do not create worker.js" in
513
+
Arg.(value & flag & info [ "no-worker" ] ~doc)
514
+
in
515
+
let switch =
516
+
let doc = "Opam switch to use" in
517
+
Arg.(value & opt (some string) None & info [ "switch" ] ~doc)
518
+
in
519
+
let path =
520
+
let doc =
521
+
"Full output path for this package (e.g., universes/abc123/base/v0.17.1/). \
522
+
When specified, only the named packages are compiled (not dependencies)."
523
+
in
524
+
Arg.(value & opt (some string) None & info [ "path" ] ~doc)
525
+
in
526
+
let deps_file =
527
+
let doc =
528
+
"File containing dependency paths, one per line. Each path should be \
529
+
relative to the HTTP root (e.g., universes/xyz789/sexplib0/v0.17.0/)."
530
+
in
531
+
Arg.(value & opt (some string) None & info [ "deps-file" ] ~doc)
532
+
in
533
+
let info = Cmd.info "opam" ~doc:"Generate opam files" in
534
+
Cmd.v info
535
+
Term.(ret (const opam $ verbose $ output_dir $ switch $ libraries $ no_worker $ path $ deps_file))
536
+
537
+
let opam_all_cmd =
538
+
let libraries = Arg.(value & pos_all string [] & info [] ~docv:"LIB") in
539
+
let output_dir =
540
+
let doc =
541
+
"Output directory for all universes. Each package gets its own subdirectory."
542
+
in
543
+
Arg.(value & opt string "html" & info [ "o"; "output" ] ~doc)
544
+
in
545
+
let verbose =
546
+
let doc = "Enable verbose logging" in
547
+
Arg.(value & flag & info [ "v"; "verbose" ] ~doc)
548
+
in
549
+
let no_worker =
550
+
let doc = "Do not create worker.js" in
551
+
Arg.(value & flag & info [ "no-worker" ] ~doc)
552
+
in
553
+
let switch =
554
+
let doc = "Opam switch to use" in
555
+
Arg.(value & opt (some string) None & info [ "switch" ] ~doc)
556
+
in
557
+
let all_pkgs =
558
+
let doc = "Build all installed packages (from ocamlfind list)" in
559
+
Arg.(value & flag & info [ "all" ] ~doc)
560
+
in
561
+
let info = Cmd.info "opam-all" ~doc:"Generate universes for all packages and their dependencies" in
562
+
Cmd.v info
563
+
Term.(ret (const opam_all $ verbose $ output_dir $ switch $ libraries $ no_worker $ all_pkgs))
564
+
565
+
let main_cmd =
566
+
let doc = "An odoc notebook tool" in
567
+
let info = Cmd.info "odoc-notebook" ~version:"%%VERSION%%" ~doc in
568
+
let default = Term.(ret (const (`Help (`Pager, None)))) in
569
+
Cmd.group info ~default [ opam_cmd; opam_all_cmd ]
570
+
571
+
let () = exit (Cmd.eval main_cmd)
+54
js_top_worker/bin/mk_backend.ml
+54
js_top_worker/bin/mk_backend.ml
···
1
+
(* To make a toplevel backend.js *)
2
+
3
+
let mk switch dir =
4
+
let txt = {|let _ = Js_top_worker_web.Worker.run ()|} in
5
+
let file = Fpath.(dir / "worker.ml") in
6
+
Util.write_file file [ txt ];
7
+
let ocamlfind_cmd, js_of_ocaml_cmd =
8
+
match switch with
9
+
| None -> (Bos.Cmd.(v "ocamlfind"), Bos.Cmd.(v "js_of_ocaml"))
10
+
| Some s ->
11
+
( Bos.Cmd.(v "opam" % "exec" % "--switch" % s % "--" % "ocamlfind"),
12
+
Bos.Cmd.(v "opam" % "exec" % "--switch" % s % "--" % "js_of_ocaml") )
13
+
in
14
+
let cmd =
15
+
Bos.Cmd.(
16
+
ocamlfind_cmd % "ocamlc" % "-package" % "js_of_ocaml-ppx.as-lib"
17
+
% "-package" % "js_top_worker-web")
18
+
in
19
+
let cmd = Bos.Cmd.(cmd % "-linkpkg" % "-linkall" % Fpath.to_string file) in
20
+
let cmd =
21
+
Bos.Cmd.(cmd % "-g" % "-o" % Fpath.(dir / "worker.bc" |> to_string))
22
+
in
23
+
let _ = Util.lines_of_process cmd in
24
+
(* No longer query library stubs - they are now linked directly into each library's JS file *)
25
+
let cmd =
26
+
Bos.Cmd.(
27
+
js_of_ocaml_cmd % "--toplevel" % "--no-cmis" % "--linkall" % "--pretty")
28
+
in
29
+
let cmd =
30
+
List.fold_right
31
+
(fun a cmd -> Bos.Cmd.(cmd % a))
32
+
[
33
+
"+dynlink.js";
34
+
"+toplevel.js";
35
+
"+bigstringaf/runtime.js";
36
+
"+js_top_worker/stubs.js";
37
+
]
38
+
cmd
39
+
in
40
+
let cmd =
41
+
Bos.Cmd.(
42
+
cmd
43
+
% Fpath.(dir / "worker.bc" |> to_string)
44
+
% "-o"
45
+
% Fpath.(dir / "worker.js" |> to_string))
46
+
in
47
+
Logs.info (fun m -> m "cmd: %s" (Bos.Cmd.to_string cmd));
48
+
let _ = Util.lines_of_process cmd in
49
+
let to_delete = [ "worker.bc"; "worker.ml"; "worker.cmi"; "worker.cmo" ] in
50
+
let results =
51
+
List.map (fun f -> Bos.OS.File.delete Fpath.(dir / f)) to_delete
52
+
in
53
+
ignore results;
54
+
()
+80
js_top_worker/bin/ocamlfind.ml
+80
js_top_worker/bin/ocamlfind.ml
···
1
+
let init =
2
+
let initialized = ref false in
3
+
fun () ->
4
+
if !initialized then ()
5
+
else
6
+
let prefix = Opam.prefix () in
7
+
let env_camllib = Fpath.(v prefix / "lib" / "ocaml" |> to_string) in
8
+
let config = Fpath.(v prefix / "lib" / "findlib.conf" |> to_string) in
9
+
Findlib.init ~config ~env_camllib ()
10
+
11
+
let all () =
12
+
init ();
13
+
Fl_package_base.list_packages ()
14
+
15
+
let get_dir lib =
16
+
try
17
+
init ();
18
+
Fl_package_base.query lib |> fun x ->
19
+
Logs.debug (fun m -> m "Package %s is in directory %s@." lib x.package_dir);
20
+
Ok Fpath.(v x.package_dir |> to_dir_path)
21
+
with e ->
22
+
Printf.eprintf "Error: %s\n" (Printexc.to_string e);
23
+
Error (`Msg "Error getting directory")
24
+
25
+
let findlib_dir () = Findlib.default_location ()
26
+
27
+
let archives pkg =
28
+
init ();
29
+
let package = Fl_package_base.query pkg in
30
+
let get_1 preds =
31
+
try
32
+
[
33
+
Fl_metascanner.lookup "archive" preds
34
+
package.Fl_package_base.package_defs;
35
+
]
36
+
with _ -> []
37
+
in
38
+
match pkg with
39
+
| "stdlib" -> [ "stdlib.cma" ]
40
+
| _ ->
41
+
get_1 [ "byte" ] @ get_1 [ "byte"; "ppx_driver" ]
42
+
|> List.filter (fun x -> String.length x > 0)
43
+
|> List.sort_uniq String.compare
44
+
45
+
let sub_libraries top =
46
+
init ();
47
+
let packages = Fl_package_base.list_packages () in
48
+
List.fold_left
49
+
(fun acc lib ->
50
+
let package = String.split_on_char '.' lib |> List.hd in
51
+
if package = top then Util.StringSet.add lib acc else acc)
52
+
Util.StringSet.empty packages
53
+
54
+
let deps pkgs =
55
+
init ();
56
+
try
57
+
let packages =
58
+
Fl_package_base.requires_deeply ~preds:[ "ppx_driver"; "byte" ] pkgs
59
+
in
60
+
Ok packages
61
+
with e -> Error (`Msg (Printexc.to_string e))
62
+
63
+
let meta_file pkg =
64
+
init ();
65
+
let package = Fl_package_base.query pkg in
66
+
let meta = package.Fl_package_base.package_meta in
67
+
meta
68
+
69
+
let jsoo_runtime pkg =
70
+
init ();
71
+
let package = Fl_package_base.query pkg in
72
+
try
73
+
let runtime =
74
+
Fl_metascanner.lookup "jsoo_runtime" []
75
+
package.Fl_package_base.package_defs
76
+
in
77
+
(* Runtime may be space-separated list of files *)
78
+
String.split_on_char ' ' runtime
79
+
|> List.filter (fun x -> String.length x > 0)
80
+
with _ -> []
+170
js_top_worker/bin/opam.ml
+170
js_top_worker/bin/opam.ml
···
1
+
open Bos
2
+
3
+
let opam = Cmd.v "opam"
4
+
let switch = ref None
5
+
let prefix = ref None
6
+
7
+
type package = { name : string; version : string }
8
+
9
+
let pp fmt p = Format.fprintf fmt "%s.%s" p.name p.version
10
+
11
+
let rec get_switch () =
12
+
match !switch with
13
+
| None ->
14
+
let cur_switch =
15
+
Util.lines_of_process Cmd.(opam % "switch" % "show") |> List.hd
16
+
in
17
+
switch := Some cur_switch;
18
+
get_switch ()
19
+
| Some s -> s
20
+
21
+
let prefix () =
22
+
match !prefix with
23
+
| Some p -> p
24
+
| None ->
25
+
let p =
26
+
Util.lines_of_process
27
+
Cmd.(opam % "var" % "--switch" % get_switch () % "prefix")
28
+
|> List.hd
29
+
in
30
+
prefix := Some p;
31
+
p
32
+
33
+
let deps_of_opam_result line =
34
+
match Astring.String.fields ~empty:false line with
35
+
| [ name; version ] -> [ { name; version } ]
36
+
| _ -> []
37
+
38
+
let all_opam_packages () =
39
+
Util.lines_of_process
40
+
Cmd.(
41
+
opam % "list" % "--switch" % get_switch () % "--columns=name,version"
42
+
% "--color=never" % "--short")
43
+
|> List.map deps_of_opam_result
44
+
|> List.flatten
45
+
46
+
let pkg_contents { name; _ } =
47
+
let prefix = Fpath.v (prefix ()) in
48
+
let changes_file =
49
+
Format.asprintf "%a/.opam-switch/install/%s.changes" Fpath.pp prefix name
50
+
in
51
+
let file = OpamFilename.raw changes_file in
52
+
let filename =
53
+
OpamFile.make @@ OpamFilename.raw @@ Filename.basename changes_file
54
+
in
55
+
let changed =
56
+
OpamFilename.with_contents
57
+
(fun str ->
58
+
OpamFile.Changes.read_from_string ~filename
59
+
@@
60
+
(* Field [opam-version] is invalid in [*.changes] files, displaying a warning. *)
61
+
if String.starts_with ~prefix:"opam-version" str then
62
+
match OpamStd.String.cut_at str '\n' with
63
+
| Some (_, str) -> str
64
+
| None -> assert false
65
+
else str)
66
+
file
67
+
in
68
+
let added =
69
+
OpamStd.String.Map.fold
70
+
(fun file x acc ->
71
+
match x with
72
+
| OpamDirTrack.Added _ -> (
73
+
try
74
+
if not @@ Sys.is_directory Fpath.(to_string (prefix // v file))
75
+
then file :: acc
76
+
else acc
77
+
with _ ->
78
+
acc
79
+
(* dose (and maybe others) sometimes creates a symlink to something that doesn't exist *)
80
+
)
81
+
| _ -> acc)
82
+
changed []
83
+
in
84
+
List.map Fpath.v added
85
+
86
+
(* let opam_file { name; version } = *)
87
+
(* let prefix = Fpath.v (prefix ()) in *)
88
+
(* let opam_file = *)
89
+
(* Format.asprintf "%a/.opam-switch/packages/%s.%s/opam" Fpath.pp prefix name *)
90
+
(* version *)
91
+
(* in *)
92
+
(* let ic = open_in opam_file in *)
93
+
(* try *)
94
+
(* let lines = Util.lines_of_channel ic in *)
95
+
(* close_in ic; *)
96
+
(* Some lines *)
97
+
(* with _ -> *)
98
+
(* close_in ic; *)
99
+
(* None *)
100
+
101
+
type installed_files = {
102
+
libs : Fpath.set;
103
+
odoc_pages : Fpath.set;
104
+
other_docs : Fpath.set;
105
+
}
106
+
107
+
type package_of_fpath = package Fpath.map
108
+
109
+
(* Here we use an associative list *)
110
+
type fpaths_of_package = (package * installed_files) list
111
+
112
+
let pkg_to_dir_map () =
113
+
let pkgs = all_opam_packages () in
114
+
let prefix = prefix () in
115
+
let pkg_content =
116
+
List.map
117
+
(fun p ->
118
+
let contents = pkg_contents p in
119
+
let libs =
120
+
List.fold_left
121
+
(fun set fpath ->
122
+
match Fpath.segs fpath with
123
+
| "lib" :: "stublibs" :: _ -> set
124
+
| "lib" :: _ :: _ :: _ when Fpath.has_ext ".cmi" fpath ->
125
+
Fpath.Set.add
126
+
Fpath.(v prefix // fpath |> split_base |> fst)
127
+
set
128
+
| _ -> set)
129
+
Fpath.Set.empty contents
130
+
in
131
+
let odoc_pages, other_docs =
132
+
List.fold_left
133
+
(fun (odoc_pages, others) fpath ->
134
+
match Fpath.segs fpath with
135
+
| "doc" :: _pkg :: "odoc-pages" :: _ ->
136
+
Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
137
+
138
+
(Fpath.Set.add Fpath.(v prefix // fpath) odoc_pages, others)
139
+
| "doc" :: _ ->
140
+
Logs.debug (fun m -> m "Found other doc: %a" Fpath.pp fpath);
141
+
(odoc_pages, Fpath.Set.add Fpath.(v prefix // fpath) others)
142
+
| _ -> (odoc_pages, others))
143
+
Fpath.Set.(empty, empty)
144
+
contents
145
+
in
146
+
Logs.debug (fun m ->
147
+
m "Found %d odoc pages, %d other docs"
148
+
(Fpath.Set.cardinal odoc_pages)
149
+
(Fpath.Set.cardinal other_docs));
150
+
(p, { libs; odoc_pages; other_docs }))
151
+
pkgs
152
+
in
153
+
let map =
154
+
List.fold_left
155
+
(fun map (p, { libs; _ }) ->
156
+
Fpath.Set.fold
157
+
(fun dir map ->
158
+
Fpath.Map.update dir
159
+
(function
160
+
| None -> Some p
161
+
| Some x ->
162
+
Logs.debug (fun m ->
163
+
m "Multiple packages (%a,%a) found for dir %a" pp x pp p
164
+
Fpath.pp dir);
165
+
Some p)
166
+
map)
167
+
libs map)
168
+
Fpath.Map.empty pkg_content
169
+
in
170
+
(pkg_content, map)
+116
js_top_worker/bin/run.ml
+116
js_top_worker/bin/run.ml
···
1
+
let instrument = false
2
+
3
+
open Bos
4
+
5
+
let instrument_dir =
6
+
lazy
7
+
(let dir = Fpath.v "landmarks" in
8
+
OS.Dir.delete dir |> Result.get_ok;
9
+
OS.Dir.create dir |> Result.get_ok |> ignore;
10
+
dir)
11
+
12
+
type t = {
13
+
cmd : string list;
14
+
time : float; (** Running time in seconds. *)
15
+
output_file : Fpath.t option;
16
+
output : string;
17
+
errors : string;
18
+
status : [ `Exited of int | `Signaled of int ];
19
+
}
20
+
21
+
(* Environment variables passed to commands. *)
22
+
23
+
(* Record the commands executed, their running time and optionally the path to
24
+
the produced file. *)
25
+
let commands = ref []
26
+
let n = Atomic.make 0
27
+
28
+
(** Return the list of executed commands where the first argument was [cmd]. *)
29
+
let run env cmd output_file =
30
+
let cmd = Bos.Cmd.to_list cmd in
31
+
let myn = Atomic.fetch_and_add n 1 in
32
+
Logs.debug (fun m -> m "%d - Executing: %s" myn (String.concat " " cmd));
33
+
let proc_mgr = Eio.Stdenv.process_mgr env in
34
+
let t_start = Unix.gettimeofday () in
35
+
let env =
36
+
let env = OS.Env.current () |> Result.get_ok in
37
+
env
38
+
in
39
+
let env =
40
+
Astring.String.Map.fold
41
+
(fun k v env -> Astring.String.concat [ k; "="; v ] :: env)
42
+
env []
43
+
|> Array.of_list
44
+
in
45
+
(* Logs.debug (fun m -> m "Running cmd %a" Fmt.(list ~sep:sp string) cmd); *)
46
+
let output, errors, status =
47
+
Eio.Switch.run ~name:"Process.parse_out" @@ fun sw ->
48
+
let r, w = Eio.Process.pipe proc_mgr ~sw in
49
+
let re, we = Eio.Process.pipe proc_mgr ~sw in
50
+
try
51
+
let child =
52
+
Eio.Process.spawn ~sw proc_mgr ~stdout:w ~stderr:we ~env cmd
53
+
in
54
+
Eio.Flow.close w;
55
+
Eio.Flow.close we;
56
+
let output, err =
57
+
Eio.Fiber.pair
58
+
(fun () ->
59
+
Eio.Buf_read.parse_exn Eio.Buf_read.take_all r ~max_size:max_int)
60
+
(fun () ->
61
+
Eio.Buf_read.parse_exn Eio.Buf_read.take_all re ~max_size:max_int)
62
+
in
63
+
Eio.Flow.close r;
64
+
Eio.Flow.close re;
65
+
let status = Eio.Process.await child in
66
+
(output, err, status)
67
+
with Eio.Exn.Io _ as ex ->
68
+
let bt = Printexc.get_raw_backtrace () in
69
+
Eio.Exn.reraise_with_context ex bt "%d - running command: %a" myn
70
+
Eio.Process.pp_args cmd
71
+
in
72
+
(* Logs.debug (fun m ->
73
+
m "Finished running cmd %a" Fmt.(list ~sep:sp string) cmd); *)
74
+
let t_end = Unix.gettimeofday () in
75
+
let time = t_end -. t_start in
76
+
let result = { cmd; time; output_file; output; errors; status } in
77
+
commands := result :: !commands;
78
+
(match result.status with
79
+
| `Exited 0 -> ()
80
+
| _ ->
81
+
let verb, n =
82
+
match result.status with
83
+
| `Exited n -> ("exited", n)
84
+
| `Signaled n -> ("signaled", n)
85
+
in
86
+
Logs.err (fun m ->
87
+
m
88
+
"@[<2>Process %s with %d:@ '@[%a'@]@]@\n\n\
89
+
Stdout:\n\
90
+
%s\n\n\
91
+
Stderr:\n\
92
+
%s"
93
+
verb n
94
+
Fmt.(list ~sep:sp string)
95
+
result.cmd result.output result.errors));
96
+
result
97
+
98
+
(** Print an executed command and its time. *)
99
+
100
+
let filter_commands cmd =
101
+
match
102
+
List.filter
103
+
(fun c -> match c.cmd with _ :: cmd' :: _ -> cmd = cmd' | _ -> false)
104
+
!commands
105
+
with
106
+
| [] -> []
107
+
| _ :: _ as cmds -> cmds
108
+
109
+
let print_cmd c =
110
+
Printf.printf "[%4.2f] $ %s\n" c.time (String.concat " " c.cmd)
111
+
112
+
(** Returns the [k] commands that took the most time for a given subcommand. *)
113
+
let k_longest_commands cmd k =
114
+
filter_commands cmd
115
+
|> List.sort (fun a b -> Float.compare b.time a.time)
116
+
|> List.filteri (fun i _ -> i < k)
+47
js_top_worker/bin/util.ml
+47
js_top_worker/bin/util.ml
···
1
+
open Bos
2
+
module StringSet = Set.Make (String)
3
+
module StringMap = Map.Make (String)
4
+
5
+
let lines_of_channel ic =
6
+
let rec inner acc =
7
+
try
8
+
let l = input_line ic in
9
+
inner (l :: acc)
10
+
with End_of_file -> List.rev acc
11
+
in
12
+
inner []
13
+
14
+
let lines_of_process cmd =
15
+
match OS.Cmd.(run_out ~err:err_null cmd |> to_lines) with
16
+
| Ok x -> x
17
+
| Error (`Msg e) -> failwith ("Error: " ^ e)
18
+
19
+
let mkdir_p d =
20
+
let segs =
21
+
Fpath.segs (Fpath.normalize d) |> List.filter (fun s -> String.length s > 0)
22
+
in
23
+
let _ =
24
+
List.fold_left
25
+
(fun path seg ->
26
+
let d = Fpath.(path // v seg) in
27
+
try
28
+
Unix.mkdir (Fpath.to_string d) 0o755;
29
+
d
30
+
with
31
+
| Unix.Unix_error (Unix.EEXIST, _, _) -> d
32
+
| exn -> raise exn)
33
+
(Fpath.v ".") segs
34
+
in
35
+
()
36
+
37
+
let write_file filename lines =
38
+
let dir = fst (Fpath.split_base filename) in
39
+
mkdir_p dir;
40
+
let oc = open_out (Fpath.to_string filename) in
41
+
List.iter (fun line -> Printf.fprintf oc "%s\n" line) lines;
42
+
close_out oc
43
+
44
+
let cp src dst =
45
+
assert (
46
+
lines_of_process Cmd.(v "cp" % Fpath.to_string src % Fpath.to_string dst)
47
+
= [])
+47
js_top_worker/bin/worker_pool.ml
+47
js_top_worker/bin/worker_pool.ml
···
1
+
(* Worker pool *)
2
+
open Eio
3
+
4
+
type request = {
5
+
description : string;
6
+
request : Bos.Cmd.t;
7
+
output_file : Fpath.t option;
8
+
}
9
+
10
+
type response = (Run.t, exn) result
11
+
type resolver = response Eio.Promise.u
12
+
type t = (request * resolver) Eio.Stream.t
13
+
14
+
let stream : t = Eio.Stream.create 0
15
+
let handle_job env request output_file = Run.run env request output_file
16
+
17
+
exception Worker_failure of Run.t
18
+
19
+
let rec run_worker env id : unit =
20
+
let { request; output_file; description = _ }, reply =
21
+
Eio.Stream.take stream
22
+
in
23
+
(try
24
+
let result = handle_job env request output_file in
25
+
match result.status with
26
+
| `Exited 0 -> Promise.resolve reply (Ok result)
27
+
| _ -> Promise.resolve_error reply (Worker_failure result)
28
+
with e -> Promise.resolve_error reply e);
29
+
run_worker env id
30
+
31
+
let submit description request output_file =
32
+
let reply, resolve_reply = Promise.create () in
33
+
Eio.Stream.add stream ({ description; request; output_file }, resolve_reply);
34
+
Promise.await reply
35
+
36
+
let start_workers env sw n =
37
+
let spawn_worker name =
38
+
Fiber.fork_daemon ~sw (fun () ->
39
+
try
40
+
run_worker env name;
41
+
`Stop_daemon
42
+
with Stdlib.Exit -> `Stop_daemon)
43
+
in
44
+
for i = 0 to n - 1 do
45
+
spawn_worker i
46
+
done;
47
+
()
+203
js_top_worker/client/ocaml-worker.d.ts
+203
js_top_worker/client/ocaml-worker.d.ts
···
1
+
/**
2
+
* OCaml Worker Client TypeScript Declarations
3
+
*/
4
+
5
+
export interface InitConfig {
6
+
/** Findlib packages to require */
7
+
findlib_requires: string[];
8
+
/** URL to dynamic CMIs for stdlib */
9
+
stdlib_dcs?: string;
10
+
/** URL to findlib_index file */
11
+
findlib_index?: string;
12
+
}
13
+
14
+
export interface Position {
15
+
/** Character number */
16
+
pos_cnum: number;
17
+
/** Line number */
18
+
pos_lnum: number;
19
+
/** Beginning of line offset */
20
+
pos_bol: number;
21
+
}
22
+
23
+
export interface Location {
24
+
/** Start position */
25
+
loc_start: Position;
26
+
/** End position */
27
+
loc_end: Position;
28
+
}
29
+
30
+
export interface MimeVal {
31
+
/** MIME type */
32
+
mime_type: string;
33
+
/** Data content */
34
+
data: string;
35
+
}
36
+
37
+
export interface Output {
38
+
/** Cell identifier */
39
+
cell_id: number;
40
+
/** Standard output */
41
+
stdout: string;
42
+
/** Standard error */
43
+
stderr: string;
44
+
/** OCaml pretty-printed output */
45
+
caml_ppf: string;
46
+
/** MIME values */
47
+
mime_vals: MimeVal[];
48
+
}
49
+
50
+
export interface CompletionEntry {
51
+
/** Completion name */
52
+
name: string;
53
+
/** Kind (Value, Module, Type, etc.) */
54
+
kind: string;
55
+
/** Description */
56
+
desc: string;
57
+
/** Additional info */
58
+
info: string;
59
+
/** Whether deprecated */
60
+
deprecated: boolean;
61
+
}
62
+
63
+
export interface Completions {
64
+
/** Cell identifier */
65
+
cell_id: number;
66
+
/** Completions data */
67
+
completions: {
68
+
/** Start position */
69
+
from: number;
70
+
/** End position */
71
+
to: number;
72
+
/** Completion entries */
73
+
entries: CompletionEntry[];
74
+
};
75
+
}
76
+
77
+
export interface Error {
78
+
/** Error kind */
79
+
kind: string;
80
+
/** Error location */
81
+
loc: Location;
82
+
/** Main error message */
83
+
main: string;
84
+
/** Sub-messages */
85
+
sub: string[];
86
+
/** Error source */
87
+
source: string;
88
+
}
89
+
90
+
export interface ErrorList {
91
+
/** Cell identifier */
92
+
cell_id: number;
93
+
/** Errors */
94
+
errors: Error[];
95
+
}
96
+
97
+
export interface TypeInfo {
98
+
/** Type location */
99
+
loc: Location;
100
+
/** Type string */
101
+
type_str: string;
102
+
/** Tail position info */
103
+
tail: string;
104
+
}
105
+
106
+
export interface TypesResult {
107
+
/** Cell identifier */
108
+
cell_id: number;
109
+
/** Type information */
110
+
types: TypeInfo[];
111
+
}
112
+
113
+
export interface EnvResult {
114
+
/** Environment ID */
115
+
env_id: string;
116
+
}
117
+
118
+
export interface OutputAt {
119
+
/** Cell identifier */
120
+
cell_id: number;
121
+
/** Character position after phrase (pos_cnum) */
122
+
loc: number;
123
+
/** OCaml pretty-printed output for this phrase */
124
+
caml_ppf: string;
125
+
/** MIME values for this phrase */
126
+
mime_vals: MimeVal[];
127
+
}
128
+
129
+
export interface OcamlWorkerOptions {
130
+
/** Timeout in milliseconds (default: 30000) */
131
+
timeout?: number;
132
+
/** Callback for incremental output after each phrase */
133
+
onOutputAt?: (output: OutputAt) => void;
134
+
}
135
+
136
+
export class OcamlWorker {
137
+
/**
138
+
* Create a new OCaml worker client.
139
+
* @param workerUrl - URL to the worker script
140
+
* @param options - Options
141
+
*/
142
+
constructor(workerUrl: string, options?: OcamlWorkerOptions);
143
+
144
+
/**
145
+
* Initialize the worker.
146
+
* @param config - Initialization configuration
147
+
*/
148
+
init(config: InitConfig): Promise<void>;
149
+
150
+
/**
151
+
* Wait for the worker to be ready.
152
+
*/
153
+
waitReady(): Promise<void>;
154
+
155
+
/**
156
+
* Evaluate OCaml code.
157
+
* @param code - OCaml code to evaluate
158
+
* @param envId - Environment ID (default: 'default')
159
+
*/
160
+
eval(code: string, envId?: string): Promise<Output>;
161
+
162
+
/**
163
+
* Get completions at a position.
164
+
* @param source - Source code
165
+
* @param position - Cursor position (character offset)
166
+
* @param envId - Environment ID (default: 'default')
167
+
*/
168
+
complete(source: string, position: number, envId?: string): Promise<Completions>;
169
+
170
+
/**
171
+
* Get type information at a position.
172
+
* @param source - Source code
173
+
* @param position - Cursor position (character offset)
174
+
* @param envId - Environment ID (default: 'default')
175
+
*/
176
+
typeAt(source: string, position: number, envId?: string): Promise<TypesResult>;
177
+
178
+
/**
179
+
* Get errors for source code.
180
+
* @param source - Source code
181
+
* @param envId - Environment ID (default: 'default')
182
+
*/
183
+
errors(source: string, envId?: string): Promise<ErrorList>;
184
+
185
+
/**
186
+
* Create a new execution environment.
187
+
* @param envId - Environment ID
188
+
*/
189
+
createEnv(envId: string): Promise<EnvResult>;
190
+
191
+
/**
192
+
* Destroy an execution environment.
193
+
* @param envId - Environment ID
194
+
*/
195
+
destroyEnv(envId: string): Promise<EnvResult>;
196
+
197
+
/**
198
+
* Terminate the worker.
199
+
*/
200
+
terminate(): void;
201
+
}
202
+
203
+
export default OcamlWorker;
+446
js_top_worker/client/ocaml-worker.js
+446
js_top_worker/client/ocaml-worker.js
···
1
+
/**
2
+
* OCaml Worker Client
3
+
*
4
+
* A JavaScript client library for communicating with the OCaml toplevel web worker.
5
+
*
6
+
* @example
7
+
* ```javascript
8
+
* import { OcamlWorker } from './ocaml-worker.js';
9
+
*
10
+
* const worker = new OcamlWorker('worker.js');
11
+
*
12
+
* await worker.init({
13
+
* findlib_requires: [],
14
+
* findlib_index: 'findlib_index'
15
+
* });
16
+
*
17
+
* const result = await worker.eval('let x = 1 + 2;;');
18
+
* console.log(result.caml_ppf); // "val x : int = 3"
19
+
* ```
20
+
*/
21
+
22
+
/**
23
+
* @typedef {Object} InitConfig
24
+
* @property {string[]} findlib_requires - Findlib packages to require
25
+
* @property {string} [stdlib_dcs] - URL to dynamic CMIs for stdlib
26
+
* @property {string} [findlib_index] - URL to findlib_index file
27
+
*/
28
+
29
+
/**
30
+
* @typedef {Object} Position
31
+
* @property {number} pos_cnum - Character number
32
+
* @property {number} pos_lnum - Line number
33
+
* @property {number} pos_bol - Beginning of line offset
34
+
*/
35
+
36
+
/**
37
+
* @typedef {Object} Location
38
+
* @property {Position} loc_start - Start position
39
+
* @property {Position} loc_end - End position
40
+
*/
41
+
42
+
/**
43
+
* @typedef {Object} MimeVal
44
+
* @property {string} mime_type - MIME type
45
+
* @property {string} data - Data content
46
+
*/
47
+
48
+
/**
49
+
* @typedef {Object} Output
50
+
* @property {number} cell_id - Cell identifier
51
+
* @property {string} stdout - Standard output
52
+
* @property {string} stderr - Standard error
53
+
* @property {string} caml_ppf - OCaml pretty-printed output
54
+
* @property {MimeVal[]} mime_vals - MIME values
55
+
*/
56
+
57
+
/**
58
+
* @typedef {Object} CompletionEntry
59
+
* @property {string} name - Completion name
60
+
* @property {string} kind - Kind (Value, Module, Type, etc.)
61
+
* @property {string} desc - Description
62
+
* @property {string} info - Additional info
63
+
* @property {boolean} deprecated - Whether deprecated
64
+
*/
65
+
66
+
/**
67
+
* @typedef {Object} Completions
68
+
* @property {number} cell_id - Cell identifier
69
+
* @property {Object} completions - Completions data
70
+
* @property {number} completions.from - Start position
71
+
* @property {number} completions.to - End position
72
+
* @property {CompletionEntry[]} completions.entries - Completion entries
73
+
*/
74
+
75
+
/**
76
+
* @typedef {Object} Error
77
+
* @property {string} kind - Error kind
78
+
* @property {Location} loc - Error location
79
+
* @property {string} main - Main error message
80
+
* @property {string[]} sub - Sub-messages
81
+
* @property {string} source - Error source
82
+
*/
83
+
84
+
/**
85
+
* @typedef {Object} TypeInfo
86
+
* @property {Location} loc - Type location
87
+
* @property {string} type_str - Type string
88
+
* @property {string} tail - Tail position info
89
+
*/
90
+
91
+
/**
92
+
* @typedef {Object} OutputAt
93
+
* @property {number} cell_id - Cell identifier
94
+
* @property {number} loc - Character position after phrase (pos_cnum)
95
+
* @property {string} caml_ppf - OCaml pretty-printed output for this phrase
96
+
* @property {MimeVal[]} mime_vals - MIME values for this phrase
97
+
*/
98
+
99
+
export class OcamlWorker {
100
+
/**
101
+
* Create the worker blob URL with proper base URL setup.
102
+
* The worker needs __global_rel_url to find its resources.
103
+
* @private
104
+
*/
105
+
static _createWorkerUrl(baseUrl) {
106
+
// Convert relative URL to absolute - importScripts in blob workers needs absolute URLs
107
+
const absoluteBase = new URL(baseUrl, window.location.href).href;
108
+
// Remove the trailing /worker.js to get the base directory
109
+
const baseDir = absoluteBase.replace(/\/worker\.js$/, '');
110
+
const content = `globalThis.__global_rel_url="${baseDir}"\nimportScripts("${absoluteBase}");`;
111
+
return URL.createObjectURL(new Blob([content], { type: "text/javascript" }));
112
+
}
113
+
114
+
/**
115
+
* Create a worker from a findlib_index URL.
116
+
* The findlib_index JSON contains compiler info (version, content_hash) and
117
+
* META file paths. This is the single entry point for discovery.
118
+
* @param {string} indexUrl - URL to findlib_index (e.g., '/jtw-output/u/<hash>/findlib_index')
119
+
* @param {string} baseOutputUrl - Base URL of the jtw-output directory (e.g., '/jtw-output')
120
+
* @param {Object} [options] - Options passed to OcamlWorker constructor
121
+
* @returns {Promise<{worker: OcamlWorker, findlib_index: string, stdlib_dcs: string}>}
122
+
*/
123
+
static async fromIndex(indexUrl, baseOutputUrl, options = {}) {
124
+
const resp = await fetch(indexUrl);
125
+
if (!resp.ok) throw new Error(`Failed to fetch findlib_index: ${resp.status}`);
126
+
const index = await resp.json();
127
+
const compiler = index.compiler;
128
+
if (!compiler) throw new Error('No compiler info in findlib_index');
129
+
const ver = compiler.version;
130
+
const hash = compiler.content_hash;
131
+
const workerUrl = `${baseOutputUrl}/compiler/${ver}/${hash}/worker.js`;
132
+
const worker = new OcamlWorker(workerUrl, options);
133
+
return { worker, findlib_index: indexUrl, stdlib_dcs: 'lib/ocaml/dynamic_cmis.json' };
134
+
}
135
+
136
+
/**
137
+
* Create a new OCaml worker client.
138
+
* @param {string} workerUrl - URL to the worker script (e.g., '_opam/worker.js')
139
+
* @param {Object} [options] - Options
140
+
* @param {number} [options.timeout=30000] - Timeout in milliseconds
141
+
* @param {function(OutputAt): void} [options.onOutputAt] - Callback for incremental output
142
+
*/
143
+
constructor(workerUrl, options = {}) {
144
+
const blobUrl = OcamlWorker._createWorkerUrl(workerUrl);
145
+
this.worker = new Worker(blobUrl);
146
+
this.timeout = options.timeout || 30000;
147
+
this.onOutputAt = options.onOutputAt || null;
148
+
this.cellIdCounter = 0;
149
+
this.pendingRequests = new Map();
150
+
this.readyPromise = null;
151
+
this.readyResolve = null;
152
+
this.isReady = false;
153
+
154
+
this.worker.onmessage = (event) => this._handleMessage(event.data);
155
+
this.worker.onerror = (error) => this._handleError(error);
156
+
}
157
+
158
+
/**
159
+
* Handle incoming messages from the worker.
160
+
* @private
161
+
*/
162
+
_handleMessage(data) {
163
+
const msg = typeof data === 'string' ? JSON.parse(data) : data;
164
+
165
+
switch (msg.type) {
166
+
case 'ready':
167
+
this.isReady = true;
168
+
if (this.readyResolve) {
169
+
this.readyResolve();
170
+
this.readyResolve = null;
171
+
}
172
+
break;
173
+
174
+
case 'init_error':
175
+
if (this.readyResolve) {
176
+
// Convert to rejection
177
+
const reject = this.pendingRequests.get('init')?.reject;
178
+
if (reject) {
179
+
reject(new Error(msg.message));
180
+
this.pendingRequests.delete('init');
181
+
}
182
+
}
183
+
break;
184
+
185
+
case 'output_at':
186
+
// Incremental output - accumulate caml_ppf for final output
187
+
if (!this._accumulatedOutput) {
188
+
this._accumulatedOutput = new Map();
189
+
}
190
+
{
191
+
const cellId = msg.cell_id;
192
+
const prev = this._accumulatedOutput.get(cellId) || '';
193
+
this._accumulatedOutput.set(cellId, prev + (msg.caml_ppf || ''));
194
+
}
195
+
if (this.onOutputAt) {
196
+
this.onOutputAt(msg);
197
+
}
198
+
break;
199
+
200
+
case 'output':
201
+
// Merge accumulated incremental caml_ppf into the final output
202
+
if (this._accumulatedOutput && this._accumulatedOutput.has(msg.cell_id)) {
203
+
const accumulated = this._accumulatedOutput.get(msg.cell_id);
204
+
if (accumulated && (!msg.caml_ppf || msg.caml_ppf === '')) {
205
+
msg.caml_ppf = accumulated;
206
+
}
207
+
this._accumulatedOutput.delete(msg.cell_id);
208
+
}
209
+
this._resolveRequest(msg.cell_id, msg);
210
+
break;
211
+
case 'completions':
212
+
case 'types':
213
+
case 'errors':
214
+
case 'eval_error':
215
+
this._resolveRequest(msg.cell_id, msg);
216
+
break;
217
+
218
+
case 'env_created':
219
+
case 'env_destroyed':
220
+
this._resolveRequest(msg.env_id, msg);
221
+
break;
222
+
223
+
default:
224
+
console.warn('Unknown message type:', msg.type);
225
+
}
226
+
}
227
+
228
+
/**
229
+
* Handle worker errors.
230
+
* @private
231
+
*/
232
+
_handleError(error) {
233
+
console.error('Worker error:', error);
234
+
// Reject all pending requests
235
+
for (const [key, { reject }] of this.pendingRequests) {
236
+
reject(error);
237
+
}
238
+
this.pendingRequests.clear();
239
+
}
240
+
241
+
/**
242
+
* Resolve a pending request.
243
+
* @private
244
+
*/
245
+
_resolveRequest(id, msg) {
246
+
const pending = this.pendingRequests.get(id);
247
+
if (pending) {
248
+
clearTimeout(pending.timeoutId);
249
+
if (msg.type === 'eval_error') {
250
+
pending.reject(new Error(msg.message));
251
+
} else {
252
+
pending.resolve(msg);
253
+
}
254
+
this.pendingRequests.delete(id);
255
+
}
256
+
}
257
+
258
+
/**
259
+
* Send a message to the worker and wait for a response.
260
+
* @private
261
+
*/
262
+
_send(msg, id) {
263
+
return new Promise((resolve, reject) => {
264
+
const timeoutId = setTimeout(() => {
265
+
this.pendingRequests.delete(id);
266
+
reject(new Error('Request timeout'));
267
+
}, this.timeout);
268
+
269
+
this.pendingRequests.set(id, { resolve, reject, timeoutId });
270
+
this.worker.postMessage(JSON.stringify(msg));
271
+
});
272
+
}
273
+
274
+
/**
275
+
* Get the next cell ID.
276
+
* @private
277
+
*/
278
+
_nextCellId() {
279
+
return ++this.cellIdCounter;
280
+
}
281
+
282
+
/**
283
+
* Initialize the worker.
284
+
* @param {InitConfig} config - Initialization configuration
285
+
* @returns {Promise<void>}
286
+
*/
287
+
async init(config) {
288
+
// Set up ready promise
289
+
this.readyPromise = new Promise((resolve, reject) => {
290
+
this.readyResolve = resolve;
291
+
this.pendingRequests.set('init', { resolve, reject, timeoutId: null });
292
+
});
293
+
294
+
// Set timeout for init
295
+
const timeoutId = setTimeout(() => {
296
+
this.pendingRequests.delete('init');
297
+
if (this.readyResolve) {
298
+
this.readyResolve = null;
299
+
}
300
+
throw new Error('Init timeout');
301
+
}, this.timeout);
302
+
303
+
const pending = this.pendingRequests.get('init');
304
+
if (pending) {
305
+
pending.timeoutId = timeoutId;
306
+
}
307
+
308
+
// Send init message
309
+
this.worker.postMessage(JSON.stringify({
310
+
type: 'init',
311
+
findlib_requires: config.findlib_requires || [],
312
+
stdlib_dcs: config.stdlib_dcs || null,
313
+
findlib_index: config.findlib_index || null,
314
+
}));
315
+
316
+
// Wait for ready
317
+
await this.readyPromise;
318
+
clearTimeout(timeoutId);
319
+
this.pendingRequests.delete('init');
320
+
}
321
+
322
+
/**
323
+
* Wait for the worker to be ready.
324
+
* @returns {Promise<void>}
325
+
*/
326
+
async waitReady() {
327
+
if (this.isReady) return;
328
+
if (this.readyPromise) {
329
+
await this.readyPromise;
330
+
}
331
+
}
332
+
333
+
/**
334
+
* Evaluate OCaml code.
335
+
* @param {string} code - OCaml code to evaluate
336
+
* @param {string} [envId='default'] - Environment ID
337
+
* @returns {Promise<Output>}
338
+
*/
339
+
async eval(code, envId = 'default') {
340
+
await this.waitReady();
341
+
const cellId = this._nextCellId();
342
+
return this._send({
343
+
type: 'eval',
344
+
cell_id: cellId,
345
+
env_id: envId,
346
+
code: code,
347
+
}, cellId);
348
+
}
349
+
350
+
/**
351
+
* Get completions at a position.
352
+
* @param {string} source - Source code
353
+
* @param {number} position - Cursor position (character offset)
354
+
* @param {string} [envId='default'] - Environment ID
355
+
* @returns {Promise<Completions>}
356
+
*/
357
+
async complete(source, position, envId = 'default') {
358
+
await this.waitReady();
359
+
const cellId = this._nextCellId();
360
+
return this._send({
361
+
type: 'complete',
362
+
cell_id: cellId,
363
+
env_id: envId,
364
+
source: source,
365
+
position: position,
366
+
}, cellId);
367
+
}
368
+
369
+
/**
370
+
* Get type information at a position.
371
+
* @param {string} source - Source code
372
+
* @param {number} position - Cursor position (character offset)
373
+
* @param {string} [envId='default'] - Environment ID
374
+
* @returns {Promise<{cell_id: number, types: TypeInfo[]}>}
375
+
*/
376
+
async typeAt(source, position, envId = 'default') {
377
+
await this.waitReady();
378
+
const cellId = this._nextCellId();
379
+
return this._send({
380
+
type: 'type_at',
381
+
cell_id: cellId,
382
+
env_id: envId,
383
+
source: source,
384
+
position: position,
385
+
}, cellId);
386
+
}
387
+
388
+
/**
389
+
* Get errors for source code.
390
+
* @param {string} source - Source code
391
+
* @param {string} [envId='default'] - Environment ID
392
+
* @returns {Promise<{cell_id: number, errors: Error[]}>}
393
+
*/
394
+
async errors(source, envId = 'default') {
395
+
await this.waitReady();
396
+
const cellId = this._nextCellId();
397
+
return this._send({
398
+
type: 'errors',
399
+
cell_id: cellId,
400
+
env_id: envId,
401
+
source: source,
402
+
}, cellId);
403
+
}
404
+
405
+
/**
406
+
* Create a new execution environment.
407
+
* @param {string} envId - Environment ID
408
+
* @returns {Promise<{env_id: string}>}
409
+
*/
410
+
async createEnv(envId) {
411
+
await this.waitReady();
412
+
return this._send({
413
+
type: 'create_env',
414
+
env_id: envId,
415
+
}, envId);
416
+
}
417
+
418
+
/**
419
+
* Destroy an execution environment.
420
+
* @param {string} envId - Environment ID
421
+
* @returns {Promise<{env_id: string}>}
422
+
*/
423
+
async destroyEnv(envId) {
424
+
await this.waitReady();
425
+
return this._send({
426
+
type: 'destroy_env',
427
+
env_id: envId,
428
+
}, envId);
429
+
}
430
+
431
+
/**
432
+
* Terminate the worker.
433
+
*/
434
+
terminate() {
435
+
this.worker.terminate();
436
+
// Reject all pending requests
437
+
for (const [key, { reject, timeoutId }] of this.pendingRequests) {
438
+
clearTimeout(timeoutId);
439
+
reject(new Error('Worker terminated'));
440
+
}
441
+
this.pendingRequests.clear();
442
+
}
443
+
}
444
+
445
+
// Also export as default
446
+
export default OcamlWorker;
+339
js_top_worker/docs/architecture.md
+339
js_top_worker/docs/architecture.md
···
1
+
# js_top_worker Architecture
2
+
3
+
This document describes the current architecture of js_top_worker and the planned changes.
4
+
5
+
## Overview
6
+
7
+
js_top_worker is an OCaml toplevel (REPL) designed to run in a Web Worker or remote process. It enables interactive OCaml execution in browsers for:
8
+
9
+
- Jupyter-style notebooks
10
+
- Interactive documentation
11
+
- Educational tools (lecture slides, tutorials)
12
+
- Library documentation with live examples
13
+
14
+
## System Architecture
15
+
16
+
```
17
+
┌─────────────────────────────────────────────────────────────────┐
18
+
│ Browser │
19
+
│ ┌──────────────────┐ ┌──────────────────────────────┐ │
20
+
│ │ Frontend │ │ Web Worker │ │
21
+
│ │ │ │ │ │
22
+
│ │ ┌────────────┐ │ RPC │ ┌────────────────────────┐ │ │
23
+
│ │ │ Client │◄─┼────────►│ │ Server │ │ │
24
+
│ │ │ (Lwt/Fut) │ │ JSON │ │ (worker.ml) │ │ │
25
+
│ │ └────────────┘ │ │ └──────────┬─────────────┘ │ │
26
+
│ │ │ │ │ │ │
27
+
│ │ │ │ ┌──────────▼─────────────┐ │ │
28
+
│ │ │ │ │ Implementation │ │ │
29
+
│ │ │ │ │ (impl.ml) │ │ │
30
+
│ │ │ │ │ - Execute phrases │ │ │
31
+
│ │ │ │ │ - Type checking │ │ │
32
+
│ │ │ │ │ - Code completion │ │ │
33
+
│ │ │ │ └──────────┬─────────────┘ │ │
34
+
│ │ │ │ │ │ │
35
+
│ │ │ │ ┌──────────▼─────────────┐ │ │
36
+
│ │ │ │ │ js_of_ocaml-toplevel │ │ │
37
+
│ │ │ │ │ + Merlin │ │ │
38
+
│ │ │ │ └────────────────────────┘ │ │
39
+
│ └──────────────────┘ └──────────────────────────────┘ │
40
+
└─────────────────────────────────────────────────────────────────┘
41
+
```
42
+
43
+
## Package Structure
44
+
45
+
| Package | Purpose | Key Files |
46
+
|---------|---------|-----------|
47
+
| `js_top_worker` | Core toplevel implementation | `lib/impl.ml`, `lib/ocamltop.ml` |
48
+
| `js_top_worker-web` | Web Worker implementation | `lib/worker.ml`, `lib/findlibish.ml` |
49
+
| `js_top_worker-rpc` | RPC type definitions | `idl/toplevel_api.ml` |
50
+
| `js_top_worker-client` | Lwt-based client | `idl/js_top_worker_client.ml` |
51
+
| `js_top_worker-client_fut` | Fut-based client | `idl/js_top_worker_client_fut.ml` |
52
+
| `js_top_worker-unix` | Unix socket backend (testing) | - |
53
+
| `js_top_worker-bin` | CLI tools (`jtw`) | `bin/jtw.ml` |
54
+
55
+
## Current Communication Layer
56
+
57
+
### RPC Protocol
58
+
59
+
Uses [ocaml-rpc](https://github.com/mirage/ocaml-rpc) with JSON-RPC 2.0:
60
+
61
+
```
62
+
Client Server (Worker)
63
+
│ │
64
+
│ ──── JSON-RPC request ────────► │
65
+
│ {method: "exec", │
66
+
│ params: ["let x = 1"], │
67
+
│ id: 1} │
68
+
│ │
69
+
│ ◄─── JSON-RPC response ──────── │
70
+
│ {result: {...}, │
71
+
│ id: 1} │
72
+
│ │
73
+
```
74
+
75
+
### RPC Operations
76
+
77
+
| Method | Parameters | Returns | Description |
78
+
|--------|------------|---------|-------------|
79
+
| `init` | `init_config` | `unit` | Initialize toplevel |
80
+
| `setup` | `unit` | `exec_result` | Start toplevel |
81
+
| `exec` | `string` | `exec_result` | Execute OCaml phrase |
82
+
| `typecheck` | `string` | `exec_result` | Type check without execution |
83
+
| `complete_prefix` | `id, deps, source, position` | `completions` | Autocomplete |
84
+
| `query_errors` | `id, deps, source` | `error list` | Get compilation errors |
85
+
| `type_enclosing` | `id, deps, source, position` | `typed_enclosings` | Type at position |
86
+
87
+
### Type Definitions
88
+
89
+
Key types from `idl/toplevel_api.ml`:
90
+
91
+
```ocaml
92
+
type exec_result = {
93
+
stdout : string option;
94
+
stderr : string option;
95
+
sharp_ppf : string option; (* # directive output *)
96
+
caml_ppf : string option; (* Regular output *)
97
+
highlight : highlight option; (* Error location *)
98
+
mime_vals : mime_val list; (* Rich output *)
99
+
}
100
+
101
+
type mime_val = {
102
+
mime_type : string; (* e.g., "text/html" *)
103
+
encoding : encoding; (* Noencoding | Base64 *)
104
+
data : string;
105
+
}
106
+
107
+
type init_config = {
108
+
findlib_requires : string list; (* Packages to preload *)
109
+
stdlib_dcs : string option; (* Dynamic CMIs URL *)
110
+
execute : bool; (* Allow execution? *)
111
+
}
112
+
```
113
+
114
+
## Core Implementation
115
+
116
+
### Module Structure (`lib/impl.ml`)
117
+
118
+
```ocaml
119
+
module type S = sig
120
+
type findlib_t
121
+
val capture : (unit -> 'a) -> unit -> captured * 'a
122
+
val sync_get : string -> string option
123
+
val async_get : string -> (string, [`Msg of string]) result Lwt.t
124
+
val import_scripts : string list -> unit
125
+
val get_stdlib_dcs : string -> dynamic_cmis list
126
+
val findlib_init : string -> findlib_t Lwt.t
127
+
val require : bool -> findlib_t -> string list -> dynamic_cmis list
128
+
val path : string
129
+
end
130
+
131
+
module Make (S : S) : sig
132
+
val init : init_config -> unit Lwt.t
133
+
val setup : unit -> exec_result Lwt.t
134
+
val exec : string -> exec_result Lwt.t
135
+
val typecheck : string -> exec_result Lwt.t
136
+
(* ... *)
137
+
end
138
+
```
139
+
140
+
### Execution Flow
141
+
142
+
```
143
+
exec(phrase)
144
+
│
145
+
▼
146
+
capture stdout/stderr
147
+
│
148
+
▼
149
+
parse phrase (Ocamltop.parse_toplevel)
150
+
│
151
+
▼
152
+
execute (Toploop.execute_phrase)
153
+
│
154
+
▼
155
+
collect MIME outputs
156
+
│
157
+
▼
158
+
return exec_result
159
+
```
160
+
161
+
### Cell Dependency System
162
+
163
+
Cells can depend on previous cells via module wrapping:
164
+
165
+
```ocaml
166
+
(* Cell "c1" defines: *)
167
+
let x = 1
168
+
169
+
(* Internally becomes module Cell__c1 *)
170
+
171
+
(* Cell "c2" with deps=["c1"]: *)
172
+
let y = x + 1
173
+
174
+
(* Prepended with: open Cell__c1 *)
175
+
```
176
+
177
+
The `mangle_toplevel` function handles this transformation.
178
+
179
+
## Library Loading
180
+
181
+
### findlibish.ml
182
+
183
+
Custom findlib-like implementation for WebWorker context:
184
+
185
+
```
186
+
┌─────────────────┐
187
+
│ findlib_index │ (list of META URLs)
188
+
└────────┬────────┘
189
+
│
190
+
┌──────────────┼──────────────┐
191
+
▼ ▼ ▼
192
+
┌─────────┐ ┌─────────┐ ┌─────────┐
193
+
│ META │ │ META │ │ META │
194
+
│ (pkg A) │ │ (pkg B) │ │ (pkg C) │
195
+
└────┬────┘ └────┬────┘ └────┬────┘
196
+
│ │ │
197
+
▼ ▼ ▼
198
+
┌─────────────────────────────────────┐
199
+
│ Dependency Resolution │
200
+
└─────────────────┬───────────────────┘
201
+
│
202
+
┌────────────┼────────────┐
203
+
▼ ▼ ▼
204
+
┌──────────┐ ┌──────────┐ ┌──────────┐
205
+
│ .cma.js │ │ .cma.js │ │ .cma.js │
206
+
│ (import) │ │ (import) │ │ (import) │
207
+
└──────────┘ └──────────┘ └──────────┘
208
+
```
209
+
210
+
### Package Loading Process
211
+
212
+
1. Fetch `findlib_index` (list of META file URLs)
213
+
2. Parse each META file with `Fl_metascanner`
214
+
3. Build dependency graph
215
+
4. On `#require`:
216
+
- Resolve dependencies
217
+
- Fetch `dynamic_cmis.json` for each package
218
+
- Load `.cma.js` via `import_scripts`
219
+
220
+
### Preloaded Packages
221
+
222
+
These are compiled into the worker and not loaded dynamically:
223
+
224
+
- `compiler-libs.common`, `compiler-libs.toplevel`
225
+
- `merlin-lib.*`
226
+
- `js_of_ocaml-compiler`, `js_of_ocaml-toplevel`
227
+
- `findlib`, `findlib.top`
228
+
229
+
## Merlin Integration
230
+
231
+
Code intelligence features use Merlin:
232
+
233
+
| Feature | Merlin Query | Implementation |
234
+
|---------|--------------|----------------|
235
+
| Completion | `Query_protocol.Complete_prefix` | `complete_prefix` |
236
+
| Type info | `Query_protocol.Type_enclosing` | `type_enclosing` |
237
+
| Errors | `Query_protocol.Errors` | `query_errors` |
238
+
239
+
Queries run through `Mpipeline` with source "mangled" to include cell dependencies.
240
+
241
+
## Planned Architecture Changes
242
+
243
+
### Phase 1: Communication Redesign
244
+
245
+
Replace JSON-RPC with CBOR-based bidirectional channel:
246
+
247
+
```
248
+
Current: Planned:
249
+
┌─────────┐ JSON-RPC ┌─────────┐ CBOR
250
+
│ Client │◄──────────────► │ Client │◄──────────────►
251
+
│ │ request/response │ │ bidirectional
252
+
└─────────┘ └─────────┘
253
+
254
+
Message types:
255
+
- Request/Response (like RPC)
256
+
- Push (server → client)
257
+
- Widget events (bidirectional)
258
+
```
259
+
260
+
### Phase 2: Environment Isolation
261
+
262
+
Multiple isolated execution contexts:
263
+
264
+
```
265
+
┌──────────────────────────────────────────┐
266
+
│ Web Worker │
267
+
│ │
268
+
│ ┌─────────────┐ ┌─────────────┐ │
269
+
│ │ Env "a" │ │ Env "b" │ │
270
+
│ │ │ │ │ │
271
+
│ │ Cell 1 │ │ Cell 1 │ │
272
+
│ │ Cell 2 │ │ Cell 2 │ │
273
+
│ │ (isolated) │ │ (isolated) │ │
274
+
│ └─────────────┘ └─────────────┘ │
275
+
│ │
276
+
│ Shared: stdlib, preloaded packages │
277
+
└──────────────────────────────────────────┘
278
+
```
279
+
280
+
### Phase 3: Rich Output & Widgets
281
+
282
+
MIME-typed output with bidirectional widget communication:
283
+
284
+
```ocaml
285
+
(* User code *)
286
+
let chart = Chart.bar [1; 2; 3; 4] in
287
+
Display.show chart
288
+
289
+
(* Generates *)
290
+
{
291
+
mime_type = "application/vnd.widget+json";
292
+
data = {widget_id = "w1"; state = ...}
293
+
}
294
+
295
+
(* Frontend renders widget, sends events back *)
296
+
Widget_event {widget_id = "w1"; event = Click {x; y}}
297
+
```
298
+
299
+
## File Reference
300
+
301
+
### Core Files
302
+
303
+
| File | Lines | Purpose |
304
+
|------|-------|---------|
305
+
| `lib/impl.ml` | 985 | Main implementation (execute, typecheck, etc.) |
306
+
| `lib/worker.ml` | 100 | WebWorker server setup |
307
+
| `lib/findlibish.ml` | 221 | Package loading |
308
+
| `idl/toplevel_api.ml` | 315 | RPC type definitions |
309
+
| `idl/js_top_worker_client.ml` | 126 | Lwt client |
310
+
311
+
### Build Outputs
312
+
313
+
| File | Description |
314
+
|------|-------------|
315
+
| `worker.bc.js` | Compiled Web Worker |
316
+
| `*.cma.js` | JavaScript-compiled OCaml libraries |
317
+
| `dynamic_cmis.json` | CMI metadata for each package |
318
+
319
+
## Dependencies
320
+
321
+
### Runtime
322
+
323
+
- `js_of_ocaml` >= 3.11.0
324
+
- `js_of_ocaml-toplevel`
325
+
- `js_of_ocaml-compiler`
326
+
- `rpclib`, `rpclib-lwt`
327
+
- `merlin-lib`
328
+
- `compiler-libs`
329
+
- `brr` >= 0.0.4
330
+
331
+
### Planned Additions
332
+
333
+
- `cbort` - CBOR codec (tangled.org)
334
+
- `zarith_stubs_js` - JS stubs for zarith
335
+
- `bytesrw` - Streaming I/O
336
+
337
+
---
338
+
339
+
*Last updated: 2026-01-20*
+568
js_top_worker/docs/investigation-report.md
+568
js_top_worker/docs/investigation-report.md
···
1
+
# js_top_worker Investigation Report
2
+
3
+
This document captures research findings for the communication layer redesign.
4
+
5
+
## Phase 0.1: Wire Format Research
6
+
7
+
### Goal
8
+
9
+
Find a suitable serialization format for bidirectional typed messaging between frontend (browser) and backend (WebWorker/remote).
10
+
11
+
### Requirements
12
+
13
+
- Binary format preferred (compact, fast)
14
+
- Type-safe OCaml codec (define once, use for both encode/decode)
15
+
- js_of_ocaml compatible
16
+
- Support for structured data (records, variants, arrays, maps)
17
+
18
+
### Options Evaluated
19
+
20
+
| Library | Format | js_of_ocaml | Notes |
21
+
|---------|--------|-------------|-------|
22
+
| ocaml-rpc (current) | JSON-RPC | Yes | Request-response only, no push |
23
+
| jsont | JSON | Yes (via brr) | Type-safe combinators, JSON only |
24
+
| msgpck | MessagePack | Likely (pure OCaml) | Less active |
25
+
| cbor | CBOR | Likely (pure OCaml) | Basic API |
26
+
| **cbort** | CBOR | Yes (via zarith_stubs_js) | Type-safe combinators, RFC 8949 |
27
+
28
+
### Recommendation: cbort
29
+
30
+
The [cbort](https://tangled.org/@anil.recoil.org/ocaml-cbort.git) library by Anil Madhavapeddy is the best choice:
31
+
32
+
1. **Type-safe combinators** following the jsont pattern - define codecs once, use bidirectionally
33
+
2. **CBOR format** (RFC 8949) - compact binary, smaller than JSON, widely supported
34
+
3. **js_of_ocaml compatible** via zarith_stubs_js for arbitrary-precision integers
35
+
4. **Built on bytesrw** for efficient streaming I/O
36
+
5. **Path-aware error messages** for debugging decode failures
37
+
38
+
#### Example Codec Definition
39
+
40
+
```ocaml
41
+
open Cbort
42
+
43
+
type person = { name : string; age : int }
44
+
45
+
let person_codec =
46
+
let open Obj in
47
+
let* name = mem "name" (fun p -> p.name) string in
48
+
let* age = mem "age" (fun p -> p.age) int in
49
+
return { name; age }
50
+
|> finish
51
+
52
+
(* Encode to CBOR bytes *)
53
+
let encoded = encode_string person_codec { name = "Alice"; age = 30 }
54
+
55
+
(* Decode from CBOR bytes *)
56
+
let decoded = decode_string person_codec encoded
57
+
```
58
+
59
+
#### Dependencies
60
+
61
+
- `bytesrw >= 0.2` - Pure OCaml streaming I/O
62
+
- `zarith >= 1.12` - Arbitrary precision integers (uses zarith_stubs_js for JS)
63
+
- `crowbar` - Fuzz testing (dev only)
64
+
65
+
#### Installation
66
+
67
+
Currently available from tangled.org:
68
+
```
69
+
git clone https://tangled.org/@anil.recoil.org/ocaml-cbort.git
70
+
```
71
+
72
+
Will need pin-depends in dune-project until published to opam.
73
+
74
+
### Jupyter Protocol Reference
75
+
76
+
For comparison, Jupyter uses:
77
+
- **JSON** for message content
78
+
- **ZeroMQ** for transport (multipart messages)
79
+
- **MIME types** for rich output (text/plain, text/html, image/png, etc.)
80
+
81
+
Key Jupyter message types:
82
+
- `execute_request` / `execute_reply` - Code execution
83
+
- `stream` - stdout/stderr output
84
+
- `display_data` - MIME-typed rich output
85
+
- `comm_open` / `comm_msg` - Bidirectional widget communication
86
+
87
+
Our design will follow similar patterns but use CBOR instead of JSON.
88
+
89
+
---
90
+
91
+
## Phase 0.2: Findlib Investigation
92
+
93
+
### Goal
94
+
95
+
Understand what real `findlib.top` does and whether to integrate it or improve `findlibish`.
96
+
97
+
### Current Implementation: findlibish
98
+
99
+
The project has a custom `findlibish.ml` (221 lines) that:
100
+
101
+
1. Parses META files using `Fl_metascanner`
102
+
2. Builds a library dependency graph
103
+
3. Resolves `#require` requests
104
+
4. Loads `.cma.js` archives via `import_scripts`
105
+
5. Fetches `dynamic_cmis.json` for type information
106
+
107
+
Key differences from real findlib:
108
+
- No `topfind` file mechanism
109
+
- No `#list`, `#camlp4o`, etc. directives
110
+
- Hardcoded list of "preloaded" packages (compiler-libs, merlin, etc.)
111
+
- URL-based fetching instead of filesystem access
112
+
113
+
### Real Findlib Behavior (from source analysis)
114
+
115
+
Studied [ocamlfind source](https://github.com/ocaml/ocamlfind) - specifically `src/findlib/topfind.ml.in`.
116
+
117
+
#### Directive Registration
118
+
119
+
Findlib registers directives by adding to `Toploop.directive_table`:
120
+
121
+
```ocaml
122
+
Hashtbl.add
123
+
Toploop.directive_table
124
+
"require"
125
+
(Toploop.Directive_string
126
+
(fun s -> protect load_deeply (Fl_split.in_words s)))
127
+
```
128
+
129
+
#### Package Loading (`load` function)
130
+
131
+
The `load` function performs these steps:
132
+
1. Get package directory via `Findlib.package_directory pkg`
133
+
2. Add directory to search path via `Topdirs.dir_directory d`
134
+
3. Get `archive` property from META file
135
+
4. Load archives via `Topdirs.dir_load Format.std_formatter archive`
136
+
5. Handle PPX properties (if defined)
137
+
6. Record package as loaded via `Findlib.record_package`
138
+
139
+
#### Deep Loading (`load_deeply` function)
140
+
141
+
```ocaml
142
+
let load_deeply pkglist =
143
+
(* Get the sorted list of ancestors *)
144
+
let eff_pkglist =
145
+
Findlib.package_deep_ancestors !predicates pkglist in
146
+
(* Check for error properties *)
147
+
List.iter (fun pkg ->
148
+
try let error = Findlib.package_property !predicates pkg "error" in
149
+
failwith ("Error from package `" ^ pkg ^ "': " ^ error)
150
+
with Not_found -> ()) eff_pkglist ;
151
+
(* Load the packages in turn: *)
152
+
load eff_pkglist
153
+
```
154
+
155
+
#### Key Mechanisms
156
+
157
+
| Findlib | findlibish | Notes |
158
+
|---------|------------|-------|
159
+
| `Topdirs.dir_load` | `import_scripts` | Native .cma vs .cma.js |
160
+
| `Topdirs.dir_directory` | N/A | Search path management |
161
+
| `Findlib.package_directory` | URL-based | Filesystem vs HTTP |
162
+
| Predicate system | Hardcoded | `["byte"; "toploop"]` etc. |
163
+
| `Findlib.record_package` | `loaded` mutable field | Track loaded packages |
164
+
165
+
### Recommendation
166
+
167
+
**Keep findlibish but improve it**. The architectures are fundamentally different:
168
+
169
+
1. **Findlib**: Native bytecode loading, filesystem access, Toploop integration
170
+
2. **findlibish**: JavaScript module loading, URL fetching, WebWorker context
171
+
172
+
Key improvements to make:
173
+
1. Add `.mli` file documenting the API
174
+
2. Support `#list` directive for discoverability
175
+
3. Better error messages when packages not found
176
+
4. Add test to verify `preloaded` list matches build (see below)
177
+
5. Add predicate support for conditional archives
178
+
179
+
#### Preloaded List Synchronization
180
+
181
+
The `preloaded` list in `findlibish.ml` must match packages linked into the
182
+
worker via dune. Currently this is manually maintained and can drift.
183
+
184
+
**Solution**: Add a test that verifies consistency:
185
+
- Query actually-linked packages (via `Findlib.recorded_packages()` or similar)
186
+
- Compare against `preloaded` list
187
+
- Fail with clear message if they differ
188
+
189
+
This catches drift without adding build-time complexity. The current list also
190
+
has duplicates (`js_of_ocaml-ppx`, `findlib`) that should be cleaned up.
191
+
192
+
---
193
+
194
+
## Phase 0.3: Environment Model Research
195
+
196
+
### Goal
197
+
198
+
Understand how to support multiple isolated execution environments (like mdx `x-ocaml` blocks).
199
+
200
+
### Current State
201
+
202
+
The project already has cell ID support:
203
+
- `opt_id` parameter on API calls
204
+
- `Cell__<id>` modules for cell outputs
205
+
- `failed_cells` tracking for dependency management
206
+
- `mangle_toplevel` adds `open Cell__<dep>` for dependencies
207
+
208
+
### MDX Implementation (from source analysis)
209
+
210
+
Studied [mdx source](https://github.com/realworldocaml/mdx) - specifically `lib/top/mdx_top.ml`.
211
+
212
+
MDX implements environment isolation by capturing and restoring Toploop state:
213
+
214
+
```ocaml
215
+
(* Environment storage: name -> (type_env, binding_names, runtime_values) *)
216
+
let envs = Hashtbl.create 8
217
+
218
+
(* Extract user-defined bindings from environment summary *)
219
+
let env_deps env =
220
+
let names = save_summary [] (Env.summary env) in
221
+
let objs = List.map Toploop.getvalue names in
222
+
(env, names, objs)
223
+
224
+
(* Restore environment state *)
225
+
let load_env env names objs =
226
+
Toploop.toplevel_env := env;
227
+
List.iter2 Toploop.setvalue names objs
228
+
229
+
(* Execute code in a named environment *)
230
+
let in_env e f =
231
+
let env_name = Mdx.Ocaml_env.name e in
232
+
let env, names, objs =
233
+
try Hashtbl.find envs env_name
234
+
with Not_found -> env_deps !default_env
235
+
in
236
+
load_env env names objs;
237
+
let res = f () in
238
+
(* Save updated state *)
239
+
Hashtbl.replace envs env_name (env_deps !Toploop.toplevel_env);
240
+
res
241
+
```
242
+
243
+
#### Key Toploop State Components
244
+
245
+
| Component | Access Method | Description |
246
+
|-----------|---------------|-------------|
247
+
| Type environment | `Toploop.toplevel_env` | Type bindings, modules |
248
+
| Runtime values | `Toploop.getvalue`/`setvalue` | Actual OCaml values |
249
+
| Environment summary | `Env.summary` | List of binding operations |
250
+
251
+
#### MDX's Strategy
252
+
253
+
1. **Shared base**: All environments start from `default_env` (initial Toploop state)
254
+
2. **Capture on exit**: After execution, save `(env, names, objs)` tuple
255
+
3. **Restore on entry**: Before execution, restore the saved state
256
+
4. **Hashtable storage**: Environments keyed by string name
257
+
258
+
### Implications for js_top_worker
259
+
260
+
The MDX approach works because it runs in a native OCaml process with mutable global state. For WebWorker:
261
+
262
+
1. **Same approach possible**: We have Toploop in js_of_ocaml-toplevel
263
+
2. **Memory concern**: Each environment stores captured values - could grow large
264
+
3. **No true fork**: Can't fork WebWorker, must use save/restore pattern
265
+
4. **Cell IDs vs Environments**: Current cell system is different - cells can depend on each other, environments are isolated
266
+
267
+
### x-ocaml Implementation (better than mdx)
268
+
269
+
Studied [x-ocaml](https://github.com/art-w/x-ocaml) by @art-w - cleaner approach.
270
+
271
+
#### Value Capture with Env.diff
272
+
273
+
```ocaml
274
+
module Value_env = struct
275
+
type t = Obj.t String_map.t
276
+
277
+
let capture t idents =
278
+
List.fold_left (fun t ident ->
279
+
let name = Translmod.toplevel_name ident in
280
+
let v = Topeval.getvalue name in
281
+
String_map.add name v t
282
+
) t idents
283
+
284
+
let restore t =
285
+
String_map.iter (fun name v -> Topeval.setvalue name v) t
286
+
end
287
+
```
288
+
289
+
Key insight: Uses `Env.diff previous_env current_env` to get only NEW bindings,
290
+
rather than walking the full environment summary like mdx does.
291
+
292
+
#### Stack-based Environment Management
293
+
294
+
```ocaml
295
+
module Environment = struct
296
+
let environments = ref [] (* stack of (id, typing_env, value_env) *)
297
+
298
+
let reset id =
299
+
(* Walk stack until we find id, restore that state *)
300
+
environments := go id !environments
301
+
302
+
let capture id =
303
+
let idents = Env.diff previous_env !Toploop.toplevel_env in
304
+
let values = Value_env.capture previous_values idents in
305
+
environments := (id, !Toploop.toplevel_env, values) :: !environments
306
+
end
307
+
```
308
+
309
+
Benefits:
310
+
- Can backtrack to any previous checkpoint
311
+
- Only captures incremental changes (memory efficient)
312
+
- Simple integer IDs
313
+
314
+
#### PPX Integration
315
+
316
+
```ocaml
317
+
(* Capture all registered PPX rewriters *)
318
+
let ppx_rewriters = ref []
319
+
320
+
let () =
321
+
Ast_mapper.register_function :=
322
+
fun _ f -> ppx_rewriters := f :: !ppx_rewriters
323
+
324
+
(* Apply during phrase preprocessing *)
325
+
let preprocess_phrase phrase =
326
+
match phrase with
327
+
| Ptop_def str -> Ptop_def (preprocess_structure str)
328
+
| Ptop_dir _ as x -> x
329
+
```
330
+
331
+
ppxlib bridge (`ppxlib_register.ml`):
332
+
```ocaml
333
+
let () = Ast_mapper.register "ppxlib" mapper
334
+
```
335
+
336
+
### Recommended Design
337
+
338
+
Adopt x-ocaml's core patterns, adapted for js_top_worker's purpose as a
339
+
reusable backend library:
340
+
341
+
**From x-ocaml (adopt directly)**:
342
+
1. **Incremental capture** via `Env.diff` - replaces current cell wrapping
343
+
2. **PPX via `Ast_mapper.register_function`** override
344
+
3. **ppxlib bridge** for modern PPX ecosystem
345
+
346
+
**Adapted for js_top_worker**:
347
+
1. **Named environments** instead of pure stack (multiple notebooks can coexist)
348
+
2. **MIME output API** generalizing x-ocaml's `output_html`
349
+
3. **cbort protocol** instead of Marshal (type-safe, browser-friendly)
350
+
351
+
**API sketch**:
352
+
```ocaml
353
+
type env_id = string
354
+
355
+
(* Environment management *)
356
+
val create_env : ?base:env_id -> env_id -> unit
357
+
val checkpoint : env_id -> unit (* capture current state *)
358
+
val reset : env_id -> unit (* restore to last checkpoint *)
359
+
val destroy_env : env_id -> unit
360
+
361
+
(* Execution *)
362
+
val exec : env:env_id -> string -> exec_result
363
+
364
+
(* MIME output (callable from user code) *)
365
+
val display : ?mime_type:string -> string -> unit
366
+
```
367
+
368
+
This gives us x-ocaml's simplicity while supporting:
369
+
- Multiple concurrent environments (different notebooks)
370
+
- Checkpoint/reset within an environment (cell re-execution)
371
+
- Rich output beyond just HTML
372
+
373
+
---
374
+
375
+
## Phase 0.4: Existing Art Review
376
+
377
+
### Projects Analyzed
378
+
379
+
| Project | URL | Architecture |
380
+
|---------|-----|--------------|
381
+
| ocaml-jupyter | https://github.com/akabe/ocaml-jupyter | Native OCaml + ZeroMQ |
382
+
| js_of_ocaml toplevel | https://ocsigen.org/js_of_ocaml | Browser + js_of_ocaml |
383
+
| sketch.sh | https://github.com/Sketch-sh/sketch-sh | Browser + WebWorker |
384
+
| utop | https://github.com/ocaml-community/utop | Native OCaml + terminal |
385
+
386
+
### ocaml-jupyter
387
+
388
+
**Architecture**: Native OCaml kernel communicating via ZeroMQ (Jupyter protocol v5.2).
389
+
390
+
**Key components**:
391
+
- `jupyter` - Core protocol implementation
392
+
- `jupyter.notebook` - Rich output API (HTML, markdown, images, LaTeX)
393
+
- `jupyter.comm` - Bidirectional widget communication
394
+
395
+
**Rich output**: Programmatic generation via `jupyter.notebook` library:
396
+
```ocaml
397
+
(* Example from jupyter.notebook *)
398
+
Jupyter_notebook.display "text/html" "<b>Hello</b>"
399
+
```
400
+
401
+
**Code completion**: Merlin integration, reads `.merlin` files.
402
+
403
+
**Takeaway**: Good reference for MIME output API and comm protocol design.
404
+
405
+
### js_of_ocaml Toplevel
406
+
407
+
**Architecture**: OCaml bytecode compiled to JavaScript, runs in browser.
408
+
409
+
**Build flags**:
410
+
```bash
411
+
js_of_ocaml --toplevel --linkall +weak.js +toplevel.js +dynlink.js
412
+
```
413
+
414
+
**Library loading**: Two approaches:
415
+
1. Compile libraries into toplevel directly
416
+
2. Load dynamically via `--extern-fs` pseudo-filesystem
417
+
418
+
**Takeaway**: Foundation of our project. We already use js_of_ocaml-toplevel.
419
+
420
+
### Sketch.sh
421
+
422
+
**Architecture**: Browser-based notebook using js_of_ocaml toplevel in WebWorker.
423
+
424
+
**Key insight**: "rtop-evaluator loads refmt & js_of_ocaml compiler as a web worker"
425
+
426
+
**Features**:
427
+
- Multiple OCaml versions (4.06.1, 4.13.1, 5.3.0)
428
+
- Reason syntax support via refmt
429
+
- Notebook-style cells with inline evaluation
430
+
- OCaml 5 effects support (continuation-based in JS)
431
+
432
+
**Limitations**:
433
+
- No BuckleScript modules (Js module)
434
+
- Belt library support added later
435
+
436
+
**Takeaway**: Similar architecture to js_top_worker. Good reference for multi-version support.
437
+
438
+
### utop
439
+
440
+
**Architecture**: Enhanced native OCaml toplevel with:
441
+
- Line editing (lambda-term)
442
+
- History
443
+
- Context-sensitive completion
444
+
- Colors
445
+
446
+
**Features relevant to us**:
447
+
- `UTop.set_create_implicits` - Auto-generate module interfaces
448
+
- Merlin integration for completion
449
+
- PPX rewriter support
450
+
451
+
**Takeaway**: Reference for toplevel UX features (completion, error formatting).
452
+
453
+
### Comparison Summary
454
+
455
+
| Feature | ocaml-jupyter | sketch.sh | js_top_worker |
456
+
|---------|---------------|-----------|---------------|
457
+
| Runtime | Native | Browser/Worker | Browser/Worker |
458
+
| Protocol | Jupyter/ZMQ | Custom | RPC (current) |
459
+
| Rich output | MIME via API | Limited | MIME (planned) |
460
+
| Widgets | jupyter.comm | No | Planned |
461
+
| Multi-env | No | No | Planned |
462
+
| Completion | Merlin | Basic | Merlin |
463
+
464
+
### Key Lessons
465
+
466
+
1. **MIME output**: jupyter.notebook provides good API pattern
467
+
2. **Widget comm**: jupyter.comm shows bidirectional messaging
468
+
3. **WebWorker**: sketch.sh validates our architecture choice
469
+
4. **Environment isolation**: None of these support it - opportunity for differentiation
470
+
471
+
---
472
+
473
+
## Open Questions
474
+
475
+
1. **Widget state persistence**: How long should widget state live? Per-session? Per-environment?
476
+
477
+
2. **Streaming output**: Should stdout/stderr be pushed incrementally or batched?
478
+
479
+
3. **PPX scope**: When a PPX is installed, should it apply to:
480
+
- All environments?
481
+
- Just the current environment?
482
+
- Configurable?
483
+
484
+
4. **Error recovery**: If a cell fails, how do dependent cells behave?
485
+
- Current: tracked in `failed_cells` set
486
+
- Desired: TBD
487
+
488
+
---
489
+
490
+
## Summary of Findings
491
+
492
+
### Wire Format Decision: cbort
493
+
494
+
Use [cbort](https://tangled.org/@anil.recoil.org/ocaml-cbort.git) for CBOR-based typed messaging:
495
+
- Type-safe combinators (jsont-style)
496
+
- Binary format (compact, fast)
497
+
- js_of_ocaml compatible via zarith_stubs_js
498
+
499
+
### Findlib Decision: Keep findlibish
500
+
501
+
The current `findlibish.ml` is appropriate for WebWorker context:
502
+
- URL-based package loading (not filesystem)
503
+
- JavaScript module loading via `import_scripts`
504
+
- Add `.mli` file and improve error handling
505
+
- Add test to verify preloaded list matches build
506
+
507
+
### Environment Model Decision: x-ocaml-style capture/restore
508
+
509
+
Adopt [x-ocaml](https://github.com/art-w/x-ocaml)'s approach:
510
+
- **`Env.diff`** for incremental capture (only new bindings)
511
+
- **`Topeval.getvalue`/`setvalue`** for runtime values
512
+
- **Named environments** (adapting x-ocaml's integer stack)
513
+
- **PPX via `Ast_mapper.register_function`** override
514
+
515
+
This replaces the current cell module wrapping approach with something simpler
516
+
and more powerful (supports checkpoint/reset, not just forward execution).
517
+
518
+
### Key Differentiators
519
+
520
+
Features that set js_top_worker apart:
521
+
1. **Multiple named environments** - Not supported by competitors
522
+
2. **CBOR wire format** - More efficient than JSON/Marshal
523
+
3. **Bidirectional widgets** - Like Jupyter but in browser
524
+
4. **PPX support** - Via x-ocaml's pattern + ppxlib bridge
525
+
5. **Reusable backend** - Library for others to build on
526
+
527
+
---
528
+
529
+
## Next Steps
530
+
531
+
### Immediate (Phase 1)
532
+
533
+
1. **Add cbort dependency**: Pin-depends in dune-project
534
+
2. **Define message types**: Simple ADT like x-ocaml, encoded with cbort
535
+
```ocaml
536
+
type request =
537
+
| Setup
538
+
| Eval of { env : string; code : string }
539
+
| Merlin of { env : string; action : Merlin_protocol.action }
540
+
| Checkpoint of { env : string }
541
+
| Reset of { env : string }
542
+
543
+
type response =
544
+
| Setup_complete
545
+
| Output of { env : string; loc : int; data : output list }
546
+
| Eval_complete of { env : string; result : exec_result }
547
+
| Merlin_response of Merlin_protocol.answer
548
+
```
549
+
3. **Replace RPC with simple message handling**: Like x-ocaml's pattern match
550
+
4. ~~**Remove compile_js**: Delete unused method~~ ✓ Done
551
+
552
+
### Short-term (Phase 2)
553
+
554
+
5. **Environment isolation**: x-ocaml's `Env.diff` + `Topeval.getvalue/setvalue`
555
+
6. **PPX support**: `Ast_mapper.register_function` override + ppxlib bridge
556
+
7. **Add .mli files**: `impl.mli`, `findlibish.mli`
557
+
8. **CI setup**: GitHub Actions for OCaml 5.2+
558
+
9. **Preloaded list test**: Verify sync with build
559
+
560
+
### Medium-term (Phase 3)
561
+
562
+
10. **MIME output API**: Generalize x-ocaml's `output_html` pattern
563
+
11. **Widget protocol**: Bidirectional comm for interactive widgets
564
+
12. **OCamlformat integration**: Auto-format like x-ocaml
565
+
566
+
---
567
+
568
+
*Last updated: 2026-01-20*
+93
js_top_worker/docs/technical-qa.md
+93
js_top_worker/docs/technical-qa.md
···
1
+
# Technical Q&A Log
2
+
3
+
This file records technical questions and answers about the codebase, along with verification steps taken to ensure accuracy.
4
+
5
+
---
6
+
7
+
## 2026-02-06: Is js_of_ocaml compilation deterministic?
8
+
9
+
**Question**: Is js_of_ocaml compilation deterministic? If we rebuild the same package, will the `.cma.js` file have the same content hash? This matters for using content hashes as cache-busting URLs.
10
+
11
+
**Answer**: Yes, js_of_ocaml compilation is deterministic. Given the same inputs (bytecode, debug info, compiler version, flags), it produces byte-for-byte identical JavaScript output. This is confirmed by both the js_of_ocaml maintainer (hhugo) and empirical testing.
12
+
13
+
**Evidence**:
14
+
15
+
1. **Maintainer confirmation** (GitHub issue ocsigen/js_of_ocaml#1297): hhugo (Hugo Heuzard, core maintainer) stated: "Js_of_ocaml produces JS from ocaml bytecode and uses debug info (from the bytecode) to recover variable names. The renaming algo is deterministic. You should expect the jsoo build to be reproducible."
16
+
17
+
2. **Source code analysis**: The `js_output.ml` file in the compiler converts internal Hashtbl structures to sorted lists before output generation:
18
+
```ocaml
19
+
let hashtbl_to_list htb =
20
+
String.Hashtbl.fold (fun k v l -> (k, v) :: l) htb []
21
+
|> List.sort ~cmp:(fun (_, a) (_, b) -> compare a b)
22
+
|> List.map ~f:fst
23
+
```
24
+
This ensures deterministic output regardless of Hashtbl iteration order.
25
+
26
+
3. **No embedded non-deterministic data**: Grep of `.cma.js` files found no embedded timestamps, build paths, random values, or other non-deterministic content.
27
+
28
+
4. **Empirical testing** (OCaml 5.4.0, js_of_ocaml 6.2.0): Four consecutive `dune clean && dune build` cycles (including one with `-j 1`) produced byte-for-byte identical `.cma.js` files:
29
+
- `stdlib.cma.js`: `496346f4...` (all 4 builds)
30
+
- `lwt.cma.js`: `e65a4a54...` (all 4 builds)
31
+
- `rpclib.cma.js`: `ffaa5ffc...` (all 4 builds)
32
+
- `js_of_ocaml.cma.js`: `4169ea91...` (all 4 builds)
33
+
34
+
**Caveats**:
35
+
36
+
- **Different OCaml compiler versions** will produce different bytecode, which leads to different `.cma.js` output. Content hashes are stable only when the full toolchain is pinned.
37
+
- **Different js_of_ocaml versions** or different compiler flags (e.g., `--opt 3` vs default) will produce different output.
38
+
- **Dune parallel build bug** (dune#3863): On OCaml < 4.11, parallel builds could produce non-deterministic `.cmo` files due to debug info sensitivity. This is fixed in OCaml 4.11+ (we use 5.4.0).
39
+
- **`dune-build-info`**: If a package uses `dune-build-info`, the VCS revision can be embedded in the binary, but this does not affect `.cma.js` compilation for libraries that don't use it.
40
+
41
+
**Conclusion**: Content hashes of `.cma.js` files are safe to use for cache-busting URLs, provided the OCaml toolchain version and js_of_ocaml version are held constant (which they are within a single ohc layer build).
42
+
43
+
**Verification Steps**:
44
+
- Searched web for "js_of_ocaml deterministic", "js_of_ocaml reproducible build"
45
+
- Read GitHub issue ocsigen/js_of_ocaml#1297 and all comments
46
+
- Analyzed js_of_ocaml compiler source (`generate.ml`, `js_output.ml`) for non-determinism
47
+
- Performed 4 clean rebuilds and compared SHA-256 hashes
48
+
- Tested both default parallelism and `-j 1` single-core builds
49
+
- Grepped `.cma.js` output for embedded paths, timestamps, dates
50
+
51
+
---
52
+
53
+
## 2026-01-20: What does `--include-runtime` do in js_of_ocaml?
54
+
55
+
**Question**: What does the `--include-runtime` argument actually do when compiling with js_of_ocaml?
56
+
57
+
**Answer**: The `--include-runtime` flag embeds library-specific JS stubs (from the library's `runtime.js` files) into the compiled output. It does NOT include the full js_of_ocaml runtime.
58
+
59
+
When used with `--toplevel`, it:
60
+
1. Takes the library's `runtime.js` stubs (e.g., `+base/runtime.js`)
61
+
2. Embeds them in the compiled `.js` file
62
+
3. Registers them on `jsoo_runtime` via `Object.assign()`
63
+
64
+
This allows separate compilation where each library's `.cma.js` file carries its own stubs, rather than requiring all stubs to be bundled into the main toplevel.
65
+
66
+
**Verification Steps**:
67
+
68
+
1. **File size comparison**: Compiled `base.cma.js` with and without `--include-runtime`
69
+
- With: 629KB
70
+
- Without: 626KB
71
+
- Difference: ~3KB (just the stubs, not the full runtime)
72
+
73
+
2. **Searched for runtime functions**:
74
+
```bash
75
+
grep -c "function caml_call_gen" base.cma.js
76
+
# Result: 0 definitions, 215 references
77
+
78
+
grep -c "function caml_register_global" base.cma.js
79
+
# Result: 0 definitions, 146 references
80
+
```
81
+
This confirms the core runtime is NOT included.
82
+
83
+
3. **Found stub registration pattern**:
84
+
```javascript
85
+
Object.assign(a.jsoo_runtime, {Base_am_testing: m, Base_hash_stubs: n, ...})
86
+
```
87
+
This shows how stubs are registered on the global `jsoo_runtime` object.
88
+
89
+
4. **Runtime test**: The Node.js test in `test/node/` successfully loads `base` and uses functions that depend on JS stubs (hash functions), confirming the stubs work correctly when embedded this way.
90
+
91
+
**Related**: js_of_ocaml PR #1509 added support for this feature in toplevel mode.
92
+
93
+
---
+296
js_top_worker/docs/test-gaps-design.md
+296
js_top_worker/docs/test-gaps-design.md
···
1
+
# Test Gap Analysis and Design
2
+
3
+
## Current State
4
+
5
+
### Existing Infrastructure
6
+
7
+
| Type | Location | Framework | Status |
8
+
|------|----------|-----------|--------|
9
+
| Node.js tests | `test/node/` | OCaml → js_of_ocaml → Node.js | ✅ Integrated in dune |
10
+
| Cram tests | `test/cram/` | Shell + unix_worker/client | ✅ Integrated in dune |
11
+
| Unit tests | `test/libtest/` | ppx_expect | ✅ Integrated in dune |
12
+
| Browser tests | `test/browser/` | Playwright | ❌ **Not integrated** |
13
+
14
+
### Browser Test Files (exist but not wired up)
15
+
16
+
```
17
+
test/browser/
18
+
├── package.json # Playwright dependency
19
+
├── run_tests.js # Playwright runner (serves files, runs browser)
20
+
├── test.html # Test harness HTML
21
+
├── client_test.ml # OCaml test code (needs compilation)
22
+
├── test_worker.ml # Test worker (needs compilation)
23
+
├── test_features.js # Feature tests (MIME, autocomplete, etc.)
24
+
├── test_env_isolation.js # Environment isolation test
25
+
└── test_demo.js # Demo page test
26
+
```
27
+
28
+
## Critical Gaps
29
+
30
+
### 1. Cell Dependencies
31
+
32
+
**Current coverage:** Linear chain only (`c1 → c2 → c3 → c4`)
33
+
34
+
**Missing scenarios:**
35
+
36
+
```
37
+
A. Diamond dependency:
38
+
c1 (type t = int)
39
+
↓ ↓
40
+
c2 (x:t) c3 (y:t)
41
+
↓ ↓
42
+
c4 (x + y)
43
+
44
+
B. Missing dependency:
45
+
c2 depends on ["c1"] but c1 doesn't exist → should error gracefully
46
+
47
+
C. Circular reference handling:
48
+
c1 depends on ["c2"], c2 depends on ["c1"] → should detect/reject
49
+
50
+
D. Dependency update propagation:
51
+
c1 changes → c2, c3 that depend on c1 should see new types
52
+
53
+
E. Type shadowing across cells:
54
+
c1: type t = int
55
+
c2: type t = string (depends on c1)
56
+
c3: uses t (depends on c1, c2) → which t?
57
+
```
58
+
59
+
### 2. Error Recovery
60
+
61
+
**Missing scenarios:**
62
+
63
+
```
64
+
A. Syntax errors:
65
+
- Unterminated string/comment
66
+
- Mismatched brackets
67
+
- Invalid tokens
68
+
69
+
B. Type errors with recovery:
70
+
- First phrase errors, second should still work
71
+
- Error in middle of multi-phrase input
72
+
73
+
C. Runtime errors:
74
+
- Stack overflow (deep recursion)
75
+
- Out of memory (large data structures)
76
+
- Division by zero
77
+
78
+
D. Toplevel state corruption:
79
+
- Can we continue after an error?
80
+
- Is state consistent after partial execution?
81
+
```
82
+
83
+
### 3. Browser/WebWorker Integration
84
+
85
+
**Problem:** Tests exist but aren't run by `dune runtest`
86
+
87
+
**Current workflow (manual):**
88
+
```bash
89
+
cd test/browser
90
+
npm install
91
+
# Manually build OCaml files somehow
92
+
npm test
93
+
```
94
+
95
+
**Needed workflow:**
96
+
```bash
97
+
dune runtest # Should include browser tests
98
+
```
99
+
100
+
## Proposed Design
101
+
102
+
### Browser Test Integration
103
+
104
+
#### Option A: Playwright in dune (Recommended)
105
+
106
+
```
107
+
test/browser/dune:
108
+
─────────────────────
109
+
(executable
110
+
(name client_test)
111
+
(modes js)
112
+
(libraries js_top_worker-client lwt js_of_ocaml))
113
+
114
+
(executable
115
+
(name test_worker)
116
+
(modes js)
117
+
(libraries js_top_worker-web ...))
118
+
119
+
(rule
120
+
(alias runtest)
121
+
(deps
122
+
client_test.bc.js
123
+
test_worker.bc.js
124
+
test.html
125
+
(:runner run_tests.js))
126
+
(action
127
+
(run node %{runner})))
128
+
```
129
+
130
+
**Pros:**
131
+
- Integrated into normal `dune runtest`
132
+
- OCaml files compiled automatically
133
+
- Playwright handles browser lifecycle
134
+
135
+
**Cons:**
136
+
- Requires Node.js + Playwright installed
137
+
- Slower than headless Node tests
138
+
139
+
#### Option B: Separate browser test target
140
+
141
+
```bash
142
+
dune runtest # Node + cram tests only
143
+
dune runtest @browser # Browser tests (when Playwright available)
144
+
```
145
+
146
+
**Pros:**
147
+
- CI can skip browser tests if Playwright not available
148
+
- Faster default test runs
149
+
150
+
**Cons:**
151
+
- Easy to forget to run browser tests
152
+
153
+
#### Recommendation: Option B with CI integration
154
+
155
+
- Default `dune runtest` excludes browser tests
156
+
- `dune runtest @browser` for browser tests
157
+
- CI runs both
158
+
159
+
### Cell Dependency Tests
160
+
161
+
Add to `test/node/node_dependency_test.ml`:
162
+
163
+
```ocaml
164
+
(* Test diamond dependencies *)
165
+
let test_diamond rpc =
166
+
(* c1: base type *)
167
+
let* _ = query_errors rpc "" (Some "c1") [] false "type point = {x:int; y:int};;" in
168
+
169
+
(* c2, c3: both depend on c1 *)
170
+
let* _ = query_errors rpc "" (Some "c2") ["c1"] false "let origin : point = {x=0;y=0};;" in
171
+
let* _ = query_errors rpc "" (Some "c3") ["c1"] false "let unit_x : point = {x=1;y=0};;" in
172
+
173
+
(* c4: depends on c2 and c3 *)
174
+
let* errors = query_errors rpc "" (Some "c4") ["c2";"c3"] false
175
+
"let add p1 p2 = {x=p1.x+p2.x; y=p1.y+p2.y};; add origin unit_x;;" in
176
+
177
+
assert (List.length errors = 0);
178
+
Lwt.return (Ok ())
179
+
180
+
(* Test missing dependency *)
181
+
let test_missing_dep rpc =
182
+
let* errors = query_errors rpc "" (Some "c2") ["nonexistent"] false "let x = 1;;" in
183
+
(* Should either error or work without the dep *)
184
+
...
185
+
186
+
(* Test dependency update *)
187
+
let test_dep_update rpc =
188
+
let* _ = query_errors rpc "" (Some "c1") [] false "type t = int;;" in
189
+
let* _ = query_errors rpc "" (Some "c2") ["c1"] false "let x : t = 42;;" in
190
+
191
+
(* Update c1 *)
192
+
let* _ = query_errors rpc "" (Some "c1") [] false "type t = string;;" in
193
+
194
+
(* c2 should now have error (42 is not string) *)
195
+
let* errors = query_errors rpc "" (Some "c2") ["c1"] false "let x : t = 42;;" in
196
+
assert (List.length errors > 0);
197
+
Lwt.return (Ok ())
198
+
```
199
+
200
+
### Error Recovery Tests
201
+
202
+
Add to `test/node/node_error_test.ml`:
203
+
204
+
```ocaml
205
+
(* Test recovery after syntax error *)
206
+
let test_syntax_recovery rpc =
207
+
(* First phrase has error *)
208
+
let* _ = exec rpc "" "let x = ;;" in (* syntax error *)
209
+
210
+
(* Second phrase should still work *)
211
+
let* result = exec rpc "" "let y = 42;;" in
212
+
assert (result.caml_ppf |> Option.is_some);
213
+
Lwt.return (Ok ())
214
+
215
+
(* Test partial execution *)
216
+
let test_partial_exec rpc =
217
+
(* Multi-phrase where second fails *)
218
+
let* result = exec rpc "" "let a = 1;; let b : string = a;; let c = 3;;" in
219
+
(* a should be defined, b should error, c may or may not run *)
220
+
...
221
+
```
222
+
223
+
### Findlib Tests
224
+
225
+
Add more packages to cram tests:
226
+
227
+
```
228
+
test/cram/findlib.t/run.t:
229
+
──────────────────────────
230
+
# Test loading multiple packages with dependencies
231
+
$ unix_client exec_toplevel '' '#require "lwt";; #require "lwt.unix";;'
232
+
$ unix_client exec_toplevel '' 'Lwt_main.run (Lwt.return 42);;'
233
+
234
+
# Test package with PPX
235
+
$ unix_client exec_toplevel '' '#require "ppx_deriving.show";;'
236
+
$ unix_client exec_toplevel '' 'type t = A | B [@@deriving show];; show_t A;;'
237
+
238
+
# Test package not found
239
+
$ unix_client exec_toplevel '' '#require "nonexistent_package_12345";;'
240
+
```
241
+
242
+
## Implementation Plan
243
+
244
+
### Phase 1: Browser Test Integration ✅ COMPLETED
245
+
246
+
1. ✅ Added `test/browser/dune` to compile OCaml test files
247
+
2. ✅ Added `@browser` and `@runbrowser` aliases for Playwright tests
248
+
3. ✅ Fixed test_worker.ml to include `js_of_ocaml-toplevel` library
249
+
4. ✅ All browser tests pass (6/6)
250
+
251
+
**Key fix:** The test worker needed `js_of_ocaml-toplevel` in libraries to properly
252
+
initialize the OCaml toplevel for code compilation.
253
+
254
+
### Phase 2: Cell Dependency Tests ✅ COMPLETED
255
+
256
+
1. ✅ Created `test/node/node_dependency_test.ml`
257
+
2. ✅ Added tests for:
258
+
- Linear dependencies (c1 → c2 → c3 → c4)
259
+
- Diamond dependencies (d1 → d2,d3 → d4)
260
+
- Missing dependencies (errors properly when referencing non-existent cells)
261
+
- Dependency update propagation (type changes in d1 affect d2)
262
+
- Type shadowing across cells
263
+
- Complex dependency graphs with modules
264
+
3. ✅ Added to dune build with expected output
265
+
266
+
**Key finding:** Dependencies are NOT transitive. If cell d4 needs types from d1
267
+
through d2/d3, it must explicitly list d1 in its dependency array.
268
+
269
+
All 26 dependency tests pass.
270
+
271
+
### Phase 3: Error Recovery Tests (pending)
272
+
273
+
1. Create `test/node/node_error_test.ml`
274
+
2. Test syntax errors, type errors, runtime errors
275
+
3. Test state consistency after errors
276
+
277
+
### Phase 4: Expanded Findlib Tests (pending)
278
+
279
+
1. Add `test/cram/findlib.t/`
280
+
2. Test more packages (lwt, ppx_deriving, etc.)
281
+
3. Test error cases
282
+
283
+
## Decisions
284
+
285
+
1. **Browser test alias:** Separate `@browser` alias (not in default `runtest`)
286
+
287
+
2. **Browsers:** Chrome only for now
288
+
289
+
3. **Cell dependency semantics:**
290
+
- Circular deps → Error (unbound module)
291
+
- Missing deps → Error (unbound module)
292
+
- Dependencies are explicit, not transitive
293
+
294
+
4. **Error recovery:** TBD - needs investigation
295
+
296
+
5. **CI:** Browser tests advisory-only initially
+5
js_top_worker/dune-project
+5
js_top_worker/dune-project
+196
js_top_worker/example/README.md
+196
js_top_worker/example/README.md
···
1
+
# js_top_worker Demo
2
+
3
+
This directory contains a comprehensive demo showcasing all features of js_top_worker - an OCaml toplevel that runs in a browser WebWorker.
4
+
5
+
## Features Demonstrated
6
+
7
+
- **Basic Execution**: Run OCaml code and see results
8
+
- **Multiple Environments**: Create isolated execution contexts
9
+
- **MIME Output**: Rich output (HTML, SVG, images) via `Mime_printer`
10
+
- **Autocomplete**: Code completion suggestions
11
+
- **Type Information**: Hover-style type queries
12
+
- **Error Reporting**: Static analysis and error detection
13
+
- **Directives**: `#show`, `#install_printer`, `#help`, etc.
14
+
- **Custom Printers**: Install custom value formatters
15
+
- **Library Loading**: Dynamic `#require` for findlib packages
16
+
- **Toplevel Scripts**: Execute multi-phrase scripts
17
+
18
+
## Prerequisites
19
+
20
+
You need:
21
+
- OCaml 5.2+ with opam
22
+
- The following opam packages installed:
23
+
- js_of_ocaml, js_of_ocaml-ppx
24
+
- dune (3.0+)
25
+
- All js_top_worker dependencies
26
+
27
+
## Quick Start
28
+
29
+
### 1. Build the Project
30
+
31
+
From the repository root:
32
+
33
+
```bash
34
+
# Install dependencies (if not already done)
35
+
opam install . --deps-only
36
+
37
+
# Build everything
38
+
dune build
39
+
```
40
+
41
+
### 2. Prepare the Example Directory
42
+
43
+
The build generates the `_opam` directory with compiled libraries:
44
+
45
+
```bash
46
+
# This is done automatically by dune, but you can also run manually:
47
+
dune build @example/default
48
+
```
49
+
50
+
This creates `_build/default/example/_opam/` containing:
51
+
- `worker.js` - The WebWorker toplevel
52
+
- `lib/` - Compiled CMI files and JavaScript-compiled CMA files
53
+
- `findlib_index` - Index of available packages
54
+
55
+
### 3. Start the Web Server
56
+
57
+
```bash
58
+
cd _build/default/example
59
+
python3 server.py 8000
60
+
```
61
+
62
+
Or use any HTTP server with CORS support. The `server.py` script adds necessary headers.
63
+
64
+
### 4. Open the Demo
65
+
66
+
Navigate to: **http://localhost:8000/demo.html**
67
+
68
+
## File Structure
69
+
70
+
```
71
+
example/
72
+
├── demo.html # Main demo page (feature showcase)
73
+
├── demo.js # JavaScript client for the demo
74
+
├── worker.ml # WebWorker entry point (1 line!)
75
+
├── server.py # Development server with CORS
76
+
├── dune # Build configuration
77
+
├── _opam/ # Generated: compiled packages
78
+
│ ├── worker.js # The compiled WebWorker
79
+
│ ├── lib/ # CMI files and .cma.js files
80
+
│ └── findlib_index # Package index
81
+
└── *.html, *.ml # Other example files
82
+
```
83
+
84
+
## Adding More Libraries
85
+
86
+
To add additional OCaml libraries to the demo, edit the `dune` file:
87
+
88
+
```dune
89
+
(rule
90
+
(targets
91
+
(dir _opam))
92
+
(action
93
+
(run jtw opam -o _opam str stringext core YOUR_LIBRARY)))
94
+
```
95
+
96
+
Then rebuild:
97
+
98
+
```bash
99
+
dune build @example/default
100
+
```
101
+
102
+
The `jtw opam` command:
103
+
1. Finds all transitive dependencies
104
+
2. Copies CMI files for type information
105
+
3. Compiles CMA files to JavaScript with `js_of_ocaml`
106
+
4. Generates the findlib index and dynamic_cmis.json files
107
+
108
+
## How It Works
109
+
110
+
### Architecture
111
+
112
+
```
113
+
┌─────────────────┐ postMessage/JSON-RPC ┌─────────────────┐
114
+
│ Browser Tab │ ◄──────────────────────────► │ WebWorker │
115
+
│ (demo.js) │ │ (worker.js) │
116
+
│ │ │ │
117
+
│ - UI rendering │ │ - OCaml toplevel│
118
+
│ - RPC client │ │ - Merlin engine │
119
+
│ - MIME display │ │ - #require │
120
+
└─────────────────┘ └─────────────────┘
121
+
```
122
+
123
+
### RPC Methods
124
+
125
+
| Method | Description |
126
+
|--------|-------------|
127
+
| `init` | Initialize toplevel with config |
128
+
| `setup` | Setup an environment (start toplevel) |
129
+
| `exec` | Execute a phrase |
130
+
| `exec_toplevel` | Execute a toplevel script |
131
+
| `create_env` | Create isolated environment |
132
+
| `destroy_env` | Destroy an environment |
133
+
| `list_envs` | List all environments |
134
+
| `complete_prefix` | Get autocomplete suggestions |
135
+
| `type_enclosing` | Get type at position |
136
+
| `query_errors` | Get errors/warnings for code |
137
+
138
+
### MIME Output
139
+
140
+
User code can produce rich output using the `Mime_printer` module:
141
+
142
+
```ocaml
143
+
(* SVG output *)
144
+
Mime_printer.push "image/svg" "<svg>...</svg>";;
145
+
146
+
(* HTML output *)
147
+
Mime_printer.push "text/html" "<table>...</table>";;
148
+
149
+
(* Base64-encoded image *)
150
+
Mime_printer.push ~encoding:Base64 "image/png" "iVBORw0KGgo...";;
151
+
```
152
+
153
+
The demo page renders these appropriately in the UI.
154
+
155
+
## Troubleshooting
156
+
157
+
### "Worker error" on startup
158
+
159
+
- Check browser console for details
160
+
- Ensure `_opam/worker.js` exists
161
+
- Verify the server is running with CORS headers
162
+
163
+
### "Failed to fetch" errors
164
+
165
+
- The worker loads files via HTTP; check network tab
166
+
- Ensure `lib/ocaml/` directory has CMI files
167
+
- Check `findlib_index` file exists
168
+
169
+
### Library not found with #require
170
+
171
+
- Add the library to the `jtw opam` command in dune
172
+
- Rebuild with `dune build @example/default`
173
+
- Check `_opam/lib/PACKAGE/META` exists
174
+
175
+
### Autocomplete/type info not working
176
+
177
+
- Merlin needs CMI files; ensure they're in `_opam/lib/`
178
+
- The `dynamic_cmis.json` file must be present for each library
179
+
180
+
## Development
181
+
182
+
To modify the worker libraries:
183
+
184
+
1. Edit files in `lib/` (core implementation)
185
+
2. Edit files in `lib-web/` (browser-specific code)
186
+
3. Rebuild: `dune build`
187
+
4. Refresh the browser (worker is cached, may need hard refresh)
188
+
189
+
The worker entry point is minimal:
190
+
191
+
```ocaml
192
+
(* worker.ml *)
193
+
let _ = Js_top_worker_web.Worker.run ()
194
+
```
195
+
196
+
All the complexity is in the `js_top_worker-web` library.
+539
js_top_worker/example/demo.html
+539
js_top_worker/example/demo.html
···
1
+
<!DOCTYPE html>
2
+
<html lang="en">
3
+
<head>
4
+
<meta charset="UTF-8">
5
+
<meta name="viewport" content="width=device-width, initial-scale=1.0">
6
+
<title>js_top_worker Feature Demo</title>
7
+
<style>
8
+
:root {
9
+
--bg-primary: #1e1e2e;
10
+
--bg-secondary: #313244;
11
+
--bg-tertiary: #45475a;
12
+
--text-primary: #cdd6f4;
13
+
--text-secondary: #a6adc8;
14
+
--accent: #89b4fa;
15
+
--accent-hover: #b4befe;
16
+
--success: #a6e3a1;
17
+
--error: #f38ba8;
18
+
--warning: #fab387;
19
+
--border: #585b70;
20
+
}
21
+
22
+
* {
23
+
box-sizing: border-box;
24
+
margin: 0;
25
+
padding: 0;
26
+
}
27
+
28
+
body {
29
+
font-family: 'SF Mono', 'Consolas', 'Monaco', monospace;
30
+
background: var(--bg-primary);
31
+
color: var(--text-primary);
32
+
line-height: 1.6;
33
+
min-height: 100vh;
34
+
}
35
+
36
+
.container {
37
+
max-width: 1400px;
38
+
margin: 0 auto;
39
+
padding: 20px;
40
+
}
41
+
42
+
header {
43
+
text-align: center;
44
+
padding: 30px 0;
45
+
border-bottom: 1px solid var(--border);
46
+
margin-bottom: 30px;
47
+
}
48
+
49
+
h1 {
50
+
font-size: 2rem;
51
+
color: var(--accent);
52
+
margin-bottom: 10px;
53
+
}
54
+
55
+
.subtitle {
56
+
color: var(--text-secondary);
57
+
font-size: 0.9rem;
58
+
}
59
+
60
+
.status-bar {
61
+
display: flex;
62
+
align-items: center;
63
+
gap: 15px;
64
+
padding: 10px 15px;
65
+
background: var(--bg-secondary);
66
+
border-radius: 8px;
67
+
margin-bottom: 20px;
68
+
}
69
+
70
+
.status-indicator {
71
+
width: 10px;
72
+
height: 10px;
73
+
border-radius: 50%;
74
+
background: var(--warning);
75
+
}
76
+
77
+
.status-indicator.ready { background: var(--success); }
78
+
.status-indicator.error { background: var(--error); }
79
+
80
+
.status-text {
81
+
font-size: 0.85rem;
82
+
color: var(--text-secondary);
83
+
}
84
+
85
+
.demo-grid {
86
+
display: grid;
87
+
grid-template-columns: repeat(auto-fit, minmax(400px, 1fr));
88
+
gap: 20px;
89
+
}
90
+
91
+
.demo-card {
92
+
background: var(--bg-secondary);
93
+
border-radius: 12px;
94
+
overflow: hidden;
95
+
border: 1px solid var(--border);
96
+
}
97
+
98
+
.card-header {
99
+
padding: 15px 20px;
100
+
background: var(--bg-tertiary);
101
+
border-bottom: 1px solid var(--border);
102
+
display: flex;
103
+
justify-content: space-between;
104
+
align-items: center;
105
+
}
106
+
107
+
.card-title {
108
+
font-size: 1rem;
109
+
color: var(--accent);
110
+
}
111
+
112
+
.card-badge {
113
+
font-size: 0.7rem;
114
+
padding: 3px 8px;
115
+
border-radius: 4px;
116
+
background: var(--bg-primary);
117
+
color: var(--text-secondary);
118
+
}
119
+
120
+
.card-body {
121
+
padding: 20px;
122
+
}
123
+
124
+
.code-input {
125
+
width: 100%;
126
+
min-height: 100px;
127
+
padding: 12px;
128
+
background: var(--bg-primary);
129
+
border: 1px solid var(--border);
130
+
border-radius: 8px;
131
+
color: var(--text-primary);
132
+
font-family: inherit;
133
+
font-size: 0.9rem;
134
+
resize: vertical;
135
+
margin-bottom: 10px;
136
+
}
137
+
138
+
.code-input:focus {
139
+
outline: none;
140
+
border-color: var(--accent);
141
+
}
142
+
143
+
.btn-row {
144
+
display: flex;
145
+
gap: 10px;
146
+
margin-bottom: 15px;
147
+
}
148
+
149
+
.btn {
150
+
padding: 8px 16px;
151
+
border: none;
152
+
border-radius: 6px;
153
+
cursor: pointer;
154
+
font-family: inherit;
155
+
font-size: 0.85rem;
156
+
transition: all 0.2s;
157
+
}
158
+
159
+
.btn-primary {
160
+
background: var(--accent);
161
+
color: var(--bg-primary);
162
+
}
163
+
164
+
.btn-primary:hover {
165
+
background: var(--accent-hover);
166
+
}
167
+
168
+
.btn-secondary {
169
+
background: var(--bg-tertiary);
170
+
color: var(--text-primary);
171
+
}
172
+
173
+
.btn-secondary:hover {
174
+
background: var(--border);
175
+
}
176
+
177
+
.output-area {
178
+
background: var(--bg-primary);
179
+
border: 1px solid var(--border);
180
+
border-radius: 8px;
181
+
padding: 12px;
182
+
min-height: 80px;
183
+
max-height: 300px;
184
+
overflow-y: auto;
185
+
font-size: 0.85rem;
186
+
}
187
+
188
+
.output-line {
189
+
margin-bottom: 5px;
190
+
}
191
+
192
+
.output-line.stdout { color: var(--text-primary); }
193
+
.output-line.stderr { color: var(--error); }
194
+
.output-line.result { color: var(--success); }
195
+
.output-line.info { color: var(--text-secondary); font-style: italic; }
196
+
197
+
.mime-output {
198
+
background: white;
199
+
border-radius: 6px;
200
+
padding: 10px;
201
+
margin-top: 10px;
202
+
}
203
+
204
+
.completion-list {
205
+
background: var(--bg-primary);
206
+
border: 1px solid var(--border);
207
+
border-radius: 6px;
208
+
max-height: 200px;
209
+
overflow-y: auto;
210
+
}
211
+
212
+
.completion-item {
213
+
padding: 8px 12px;
214
+
border-bottom: 1px solid var(--border);
215
+
display: flex;
216
+
justify-content: space-between;
217
+
align-items: center;
218
+
}
219
+
220
+
.completion-item:last-child {
221
+
border-bottom: none;
222
+
}
223
+
224
+
.completion-name {
225
+
color: var(--accent);
226
+
}
227
+
228
+
.completion-kind {
229
+
font-size: 0.75rem;
230
+
color: var(--text-secondary);
231
+
background: var(--bg-tertiary);
232
+
padding: 2px 6px;
233
+
border-radius: 3px;
234
+
}
235
+
236
+
.type-info {
237
+
padding: 10px;
238
+
background: var(--bg-primary);
239
+
border: 1px solid var(--border);
240
+
border-radius: 6px;
241
+
color: var(--success);
242
+
}
243
+
244
+
.error-list {
245
+
background: var(--bg-primary);
246
+
border: 1px solid var(--border);
247
+
border-radius: 6px;
248
+
padding: 10px;
249
+
}
250
+
251
+
.error-item {
252
+
padding: 8px;
253
+
margin-bottom: 8px;
254
+
border-left: 3px solid var(--error);
255
+
background: rgba(243, 139, 168, 0.1);
256
+
}
257
+
258
+
.error-item.warning {
259
+
border-left-color: var(--warning);
260
+
background: rgba(250, 179, 135, 0.1);
261
+
}
262
+
263
+
.env-selector {
264
+
display: flex;
265
+
gap: 10px;
266
+
margin-bottom: 15px;
267
+
flex-wrap: wrap;
268
+
}
269
+
270
+
.env-btn {
271
+
padding: 6px 12px;
272
+
border: 1px solid var(--border);
273
+
background: var(--bg-primary);
274
+
color: var(--text-secondary);
275
+
border-radius: 4px;
276
+
cursor: pointer;
277
+
font-family: inherit;
278
+
font-size: 0.8rem;
279
+
}
280
+
281
+
.env-btn.active {
282
+
border-color: var(--accent);
283
+
color: var(--accent);
284
+
background: rgba(137, 180, 250, 0.1);
285
+
}
286
+
287
+
.log-panel {
288
+
position: fixed;
289
+
bottom: 0;
290
+
left: 0;
291
+
right: 0;
292
+
background: var(--bg-secondary);
293
+
border-top: 1px solid var(--border);
294
+
max-height: 200px;
295
+
overflow-y: auto;
296
+
padding: 10px 20px;
297
+
font-size: 0.8rem;
298
+
}
299
+
300
+
.log-entry {
301
+
color: var(--text-secondary);
302
+
margin-bottom: 3px;
303
+
}
304
+
305
+
.log-entry.error { color: var(--error); }
306
+
.log-entry.success { color: var(--success); }
307
+
308
+
.full-width {
309
+
grid-column: 1 / -1;
310
+
}
311
+
312
+
.hidden { display: none; }
313
+
314
+
pre {
315
+
white-space: pre-wrap;
316
+
word-wrap: break-word;
317
+
}
318
+
</style>
319
+
</head>
320
+
<body>
321
+
<div class="container">
322
+
<header>
323
+
<h1>js_top_worker Feature Demo</h1>
324
+
<p class="subtitle">OCaml Toplevel in the Browser via WebWorker</p>
325
+
</header>
326
+
327
+
<div class="status-bar">
328
+
<div class="status-indicator" id="status-indicator"></div>
329
+
<span class="status-text" id="status-text">Initializing...</span>
330
+
</div>
331
+
332
+
<div class="demo-grid">
333
+
<!-- Basic Execution -->
334
+
<div class="demo-card">
335
+
<div class="card-header">
336
+
<span class="card-title">Basic Execution</span>
337
+
<span class="card-badge">exec</span>
338
+
</div>
339
+
<div class="card-body">
340
+
<textarea class="code-input" id="exec-input">let greet name = Printf.sprintf "Hello, %s!" name;;
341
+
greet "OCaml";;</textarea>
342
+
<div class="btn-row">
343
+
<button class="btn btn-primary" onclick="runExec()">Execute</button>
344
+
<button class="btn btn-secondary" onclick="clearOutput('exec-output')">Clear</button>
345
+
</div>
346
+
<div class="output-area" id="exec-output"></div>
347
+
</div>
348
+
</div>
349
+
350
+
<!-- Multiple Environments -->
351
+
<div class="demo-card">
352
+
<div class="card-header">
353
+
<span class="card-title">Multiple Environments</span>
354
+
<span class="card-badge">isolation</span>
355
+
</div>
356
+
<div class="card-body">
357
+
<div class="env-selector" id="env-selector">
358
+
<button class="env-btn active" data-env="">default</button>
359
+
</div>
360
+
<div class="btn-row">
361
+
<button class="btn btn-secondary" onclick="createEnv()">+ New Env</button>
362
+
<button class="btn btn-secondary" onclick="listEnvs()">List Envs</button>
363
+
</div>
364
+
<textarea class="code-input" id="env-input">let env_value = 42;;</textarea>
365
+
<div class="btn-row">
366
+
<button class="btn btn-primary" onclick="runInEnv()">Execute in Selected Env</button>
367
+
</div>
368
+
<div class="output-area" id="env-output"></div>
369
+
</div>
370
+
</div>
371
+
372
+
<!-- MIME Output -->
373
+
<div class="demo-card">
374
+
<div class="card-header">
375
+
<span class="card-title">MIME Output</span>
376
+
<span class="card-badge">rich output</span>
377
+
</div>
378
+
<div class="card-body">
379
+
<textarea class="code-input" id="mime-input">(* SVG output *)
380
+
let svg = {|<svg width="100" height="100">
381
+
<circle cx="50" cy="50" r="40" fill="#89b4fa"/>
382
+
<text x="50" y="55" text-anchor="middle" fill="white">OCaml</text>
383
+
</svg>|};;
384
+
Mime_printer.push "image/svg" svg;;</textarea>
385
+
<div class="btn-row">
386
+
<button class="btn btn-primary" onclick="runMime()">Execute</button>
387
+
<button class="btn btn-secondary" onclick="loadMimeExamples()">Examples</button>
388
+
</div>
389
+
<div class="output-area" id="mime-output"></div>
390
+
<div class="mime-output hidden" id="mime-rendered"></div>
391
+
</div>
392
+
</div>
393
+
394
+
<!-- Autocomplete -->
395
+
<div class="demo-card">
396
+
<div class="card-header">
397
+
<span class="card-title">Autocomplete</span>
398
+
<span class="card-badge">complete_prefix</span>
399
+
</div>
400
+
<div class="card-body">
401
+
<textarea class="code-input" id="complete-input">List.ma</textarea>
402
+
<p style="font-size: 0.8rem; color: var(--text-secondary); margin-bottom: 10px;">
403
+
Enter partial code and click Complete to see suggestions
404
+
</p>
405
+
<div class="btn-row">
406
+
<button class="btn btn-primary" onclick="runComplete()">Complete</button>
407
+
</div>
408
+
<div class="completion-list" id="complete-output"></div>
409
+
</div>
410
+
</div>
411
+
412
+
<!-- Type Information -->
413
+
<div class="demo-card">
414
+
<div class="card-header">
415
+
<span class="card-title">Type Information</span>
416
+
<span class="card-badge">type_enclosing</span>
417
+
</div>
418
+
<div class="card-body">
419
+
<textarea class="code-input" id="type-input">let f x = List.map (fun y -> y + 1) x</textarea>
420
+
<p style="font-size: 0.8rem; color: var(--text-secondary); margin-bottom: 10px;">
421
+
Position (0-indexed): <input type="number" id="type-pos" value="8" style="width: 50px; background: var(--bg-primary); border: 1px solid var(--border); color: var(--text-primary); padding: 4px;">
422
+
</p>
423
+
<div class="btn-row">
424
+
<button class="btn btn-primary" onclick="runTypeEnclosing()">Get Type</button>
425
+
</div>
426
+
<div class="type-info" id="type-output">Click "Get Type" to see type information</div>
427
+
</div>
428
+
</div>
429
+
430
+
<!-- Error Reporting -->
431
+
<div class="demo-card">
432
+
<div class="card-header">
433
+
<span class="card-title">Error Reporting</span>
434
+
<span class="card-badge">query_errors</span>
435
+
</div>
436
+
<div class="card-body">
437
+
<textarea class="code-input" id="errors-input">let x : string = 42
438
+
let unused = "hello"
439
+
let y = unknown_function ()</textarea>
440
+
<div class="btn-row">
441
+
<button class="btn btn-primary" onclick="runQueryErrors()">Check Errors</button>
442
+
</div>
443
+
<div class="error-list" id="errors-output">Click "Check Errors" to analyze code</div>
444
+
</div>
445
+
</div>
446
+
447
+
<!-- Directives -->
448
+
<div class="demo-card full-width">
449
+
<div class="card-header">
450
+
<span class="card-title">Directives</span>
451
+
<span class="card-badge">#show, #install_printer, etc.</span>
452
+
</div>
453
+
<div class="card-body">
454
+
<div class="btn-row" style="flex-wrap: wrap;">
455
+
<button class="btn btn-secondary" onclick="runDirective('#show List;;')">show List</button>
456
+
<button class="btn btn-secondary" onclick="runDirective('#show_type option;;')">show_type option</button>
457
+
<button class="btn btn-secondary" onclick="runDirective('#help;;')">help</button>
458
+
<button class="btn btn-secondary" onclick="runDirective('#print_depth 5;;')">print_depth 5</button>
459
+
<button class="btn btn-secondary" onclick="runDirective('#warnings \"+a\";;')">warnings +a</button>
460
+
</div>
461
+
<textarea class="code-input" id="directive-input">#show List.map;;</textarea>
462
+
<div class="btn-row">
463
+
<button class="btn btn-primary" onclick="runDirective()">Run Directive</button>
464
+
</div>
465
+
<div class="output-area" id="directive-output"></div>
466
+
</div>
467
+
</div>
468
+
469
+
<!-- Custom Printers -->
470
+
<div class="demo-card">
471
+
<div class="card-header">
472
+
<span class="card-title">Custom Printers</span>
473
+
<span class="card-badge">#install_printer</span>
474
+
</div>
475
+
<div class="card-body">
476
+
<textarea class="code-input" id="printer-input">type color = Red | Green | Blue;;
477
+
478
+
let pp_color fmt c =
479
+
Format.fprintf fmt "[COLOR:%s]"
480
+
(match c with Red -> "red" | Green -> "green" | Blue -> "blue");;
481
+
482
+
#install_printer pp_color;;
483
+
484
+
[Red; Green; Blue];;</textarea>
485
+
<div class="btn-row">
486
+
<button class="btn btn-primary" onclick="runPrinter()">Execute</button>
487
+
</div>
488
+
<div class="output-area" id="printer-output"></div>
489
+
</div>
490
+
</div>
491
+
492
+
<!-- Library Loading -->
493
+
<div class="demo-card">
494
+
<div class="card-header">
495
+
<span class="card-title">Library Loading</span>
496
+
<span class="card-badge">#require</span>
497
+
</div>
498
+
<div class="card-body">
499
+
<p style="font-size: 0.8rem; color: var(--text-secondary); margin-bottom: 10px;">
500
+
Libraries must be prepared with <code>jtw opam</code> first.
501
+
</p>
502
+
<textarea class="code-input" id="require-input">#require "str";;
503
+
Str.split (Str.regexp ",") "a,b,c";;</textarea>
504
+
<div class="btn-row">
505
+
<button class="btn btn-primary" onclick="runRequire()">Execute</button>
506
+
</div>
507
+
<div class="output-area" id="require-output"></div>
508
+
</div>
509
+
</div>
510
+
511
+
<!-- Toplevel Script -->
512
+
<div class="demo-card full-width">
513
+
<div class="card-header">
514
+
<span class="card-title">Toplevel Script Execution</span>
515
+
<span class="card-badge">exec_toplevel</span>
516
+
</div>
517
+
<div class="card-body">
518
+
<p style="font-size: 0.8rem; color: var(--text-secondary); margin-bottom: 10px;">
519
+
Toplevel scripts use "# " prefix for input lines. Output is indented.
520
+
</p>
521
+
<textarea class="code-input" id="toplevel-input" style="min-height: 150px;"># let square x = x * x;;
522
+
# let numbers = [1; 2; 3; 4; 5];;
523
+
# List.map square numbers;;</textarea>
524
+
<div class="btn-row">
525
+
<button class="btn btn-primary" onclick="runToplevel()">Execute Script</button>
526
+
</div>
527
+
<div class="output-area" id="toplevel-output" style="min-height: 150px;"></div>
528
+
</div>
529
+
</div>
530
+
</div>
531
+
</div>
532
+
533
+
<div class="log-panel" id="log-panel">
534
+
<div id="log-entries"></div>
535
+
</div>
536
+
537
+
<script src="demo.js"></script>
538
+
</body>
539
+
</html>
+551
js_top_worker/example/demo.js
+551
js_top_worker/example/demo.js
···
1
+
/**
2
+
* js_top_worker Feature Demo
3
+
*
4
+
* This JavaScript file demonstrates all features of js_top_worker:
5
+
* - Basic execution
6
+
* - Multiple isolated environments
7
+
* - MIME output (HTML, SVG, images)
8
+
* - Autocomplete
9
+
* - Type information
10
+
* - Error reporting
11
+
* - Directives
12
+
* - Library loading
13
+
*/
14
+
15
+
// ============================================================================
16
+
// Worker Communication Setup
17
+
// ============================================================================
18
+
19
+
let worker = null;
20
+
let rpcId = 1;
21
+
const pendingCalls = new Map();
22
+
let currentEnv = "";
23
+
let envCount = 0;
24
+
25
+
function getWorkerURL(baseUrl) {
26
+
// Convert relative URL to absolute - importScripts in blob workers needs absolute URLs
27
+
const absoluteBase = new URL(baseUrl, window.location.href).href;
28
+
const content = `globalThis.__global_rel_url="${absoluteBase}"\nimportScripts("${absoluteBase}/worker.js");`;
29
+
return URL.createObjectURL(new Blob([content], { type: "text/javascript" }));
30
+
}
31
+
32
+
function log(message, type = "info") {
33
+
const entries = document.getElementById("log-entries");
34
+
const entry = document.createElement("div");
35
+
entry.className = `log-entry ${type}`;
36
+
entry.textContent = `[${new Date().toLocaleTimeString()}] ${message}`;
37
+
entries.appendChild(entry);
38
+
entries.parentElement.scrollTop = entries.parentElement.scrollHeight;
39
+
console.log(`[${type}] ${message}`);
40
+
}
41
+
42
+
function setStatus(status, text) {
43
+
const indicator = document.getElementById("status-indicator");
44
+
const statusText = document.getElementById("status-text");
45
+
indicator.className = `status-indicator ${status}`;
46
+
statusText.textContent = text;
47
+
}
48
+
49
+
// RPC call wrapper
50
+
function rpc(method, params) {
51
+
return new Promise((resolve, reject) => {
52
+
const id = rpcId++;
53
+
const message = JSON.stringify({ id, method, params });
54
+
55
+
pendingCalls.set(id, { resolve, reject });
56
+
worker.postMessage(message);
57
+
58
+
log(`RPC: ${method}(${JSON.stringify(params).substring(0, 100)}...)`, "info");
59
+
});
60
+
}
61
+
62
+
// Handle incoming messages from worker
63
+
function onWorkerMessage(e) {
64
+
try {
65
+
const response = JSON.parse(e.data);
66
+
if (response.id && pendingCalls.has(response.id)) {
67
+
const { resolve, reject } = pendingCalls.get(response.id);
68
+
pendingCalls.delete(response.id);
69
+
70
+
if (response.error) {
71
+
log(`RPC Error: ${JSON.stringify(response.error)}`, "error");
72
+
reject(response.error);
73
+
} else {
74
+
resolve(response.result);
75
+
}
76
+
}
77
+
} catch (err) {
78
+
log(`Parse error: ${err.message}`, "error");
79
+
}
80
+
}
81
+
82
+
// ============================================================================
83
+
// Initialization
84
+
// ============================================================================
85
+
86
+
async function initWorker() {
87
+
try {
88
+
setStatus("", "Loading worker...");
89
+
90
+
// Create worker from the _opam directory
91
+
const workerUrl = getWorkerURL("_opam");
92
+
worker = new Worker(workerUrl);
93
+
worker.onmessage = onWorkerMessage;
94
+
worker.onerror = (e) => {
95
+
log(`Worker error: ${e.message}`, "error");
96
+
setStatus("error", "Worker error");
97
+
};
98
+
99
+
setStatus("", "Initializing toplevel...");
100
+
101
+
// Initialize the toplevel - named params are in first element of array
102
+
// Include mime_printer for MIME output support
103
+
await rpc("init", [
104
+
{ init_libs: { stdlib_dcs: "lib/ocaml/dynamic_cmis.json", findlib_requires: ["mime_printer"], execute: true } }
105
+
]);
106
+
107
+
log("Toplevel initialized", "success");
108
+
109
+
// Setup default environment
110
+
setStatus("", "Setting up default environment...");
111
+
const setupResult = await rpc("setup", [{ env_id: "" }]);
112
+
log("Default environment ready", "success");
113
+
114
+
setStatus("ready", "Ready");
115
+
116
+
// Show setup blurb
117
+
if (setupResult && setupResult.caml_ppf) {
118
+
log(`OCaml toplevel: ${setupResult.caml_ppf.substring(0, 100)}...`, "info");
119
+
}
120
+
121
+
} catch (err) {
122
+
log(`Initialization failed: ${err.message || JSON.stringify(err)}`, "error");
123
+
setStatus("error", "Initialization failed");
124
+
}
125
+
}
126
+
127
+
// ============================================================================
128
+
// Output Helpers
129
+
// ============================================================================
130
+
131
+
function formatOutput(result) {
132
+
let html = "";
133
+
134
+
if (result.stdout) {
135
+
html += `<div class="output-line stdout"><pre>${escapeHtml(result.stdout)}</pre></div>`;
136
+
}
137
+
if (result.stderr) {
138
+
html += `<div class="output-line stderr"><pre>${escapeHtml(result.stderr)}</pre></div>`;
139
+
}
140
+
if (result.sharp_ppf) {
141
+
html += `<div class="output-line info"><pre>${escapeHtml(result.sharp_ppf)}</pre></div>`;
142
+
}
143
+
if (result.caml_ppf) {
144
+
html += `<div class="output-line result"><pre>${escapeHtml(result.caml_ppf)}</pre></div>`;
145
+
}
146
+
if (result.highlight) {
147
+
const h = result.highlight;
148
+
html += `<div class="output-line info">Highlight: (${h.line1}:${h.col1}) to (${h.line2}:${h.col2})</div>`;
149
+
}
150
+
151
+
return html || '<div class="output-line info">No output</div>';
152
+
}
153
+
154
+
function escapeHtml(str) {
155
+
return str
156
+
.replace(/&/g, "&")
157
+
.replace(/</g, "<")
158
+
.replace(/>/g, ">")
159
+
.replace(/"/g, """)
160
+
.replace(/'/g, "'");
161
+
}
162
+
163
+
function clearOutput(elementId) {
164
+
document.getElementById(elementId).innerHTML = "";
165
+
}
166
+
167
+
// ============================================================================
168
+
// Feature: Basic Execution
169
+
// ============================================================================
170
+
171
+
async function runExec() {
172
+
const input = document.getElementById("exec-input").value;
173
+
const output = document.getElementById("exec-output");
174
+
175
+
try {
176
+
output.innerHTML = '<div class="output-line info">Executing...</div>';
177
+
const result = await rpc("exec", [{ env_id: "" }, input]);
178
+
output.innerHTML = formatOutput(result);
179
+
} catch (err) {
180
+
output.innerHTML = `<div class="output-line stderr">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
181
+
}
182
+
}
183
+
184
+
// ============================================================================
185
+
// Feature: Multiple Environments
186
+
// ============================================================================
187
+
188
+
function updateEnvSelector() {
189
+
const selector = document.getElementById("env-selector");
190
+
const buttons = selector.querySelectorAll(".env-btn");
191
+
buttons.forEach(btn => {
192
+
btn.classList.toggle("active", btn.dataset.env === currentEnv);
193
+
});
194
+
}
195
+
196
+
async function createEnv() {
197
+
const envId = `env${++envCount}`;
198
+
199
+
try {
200
+
await rpc("create_env", [{ env_id: envId }]);
201
+
await rpc("setup", [{ env_id: envId }]);
202
+
203
+
const selector = document.getElementById("env-selector");
204
+
const btn = document.createElement("button");
205
+
btn.className = "env-btn";
206
+
btn.dataset.env = envId;
207
+
btn.textContent = envId;
208
+
btn.onclick = () => selectEnv(envId);
209
+
selector.appendChild(btn);
210
+
211
+
log(`Created environment: ${envId}`, "success");
212
+
selectEnv(envId);
213
+
} catch (err) {
214
+
log(`Failed to create environment: ${err.message || JSON.stringify(err)}`, "error");
215
+
}
216
+
}
217
+
218
+
function selectEnv(envId) {
219
+
currentEnv = envId;
220
+
updateEnvSelector();
221
+
log(`Selected environment: ${envId || "default"}`, "info");
222
+
}
223
+
224
+
async function listEnvs() {
225
+
try {
226
+
const envs = await rpc("list_envs", []);
227
+
const output = document.getElementById("env-output");
228
+
output.innerHTML = `<div class="output-line result">Environments: ${envs.join(", ")}</div>`;
229
+
} catch (err) {
230
+
log(`Failed to list environments: ${err.message || JSON.stringify(err)}`, "error");
231
+
}
232
+
}
233
+
234
+
async function runInEnv() {
235
+
const input = document.getElementById("env-input").value;
236
+
const output = document.getElementById("env-output");
237
+
238
+
try {
239
+
output.innerHTML = `<div class="output-line info">Executing in "${currentEnv || "default"}"...</div>`;
240
+
const result = await rpc("exec", [{ env_id: currentEnv }, input]);
241
+
output.innerHTML = formatOutput(result);
242
+
} catch (err) {
243
+
output.innerHTML = `<div class="output-line stderr">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
244
+
}
245
+
}
246
+
247
+
// Make selectEnv available for onclick
248
+
document.addEventListener("DOMContentLoaded", () => {
249
+
document.querySelector('.env-btn[data-env=""]').onclick = () => selectEnv("");
250
+
});
251
+
252
+
// ============================================================================
253
+
// Feature: MIME Output
254
+
// ============================================================================
255
+
256
+
async function runMime() {
257
+
const input = document.getElementById("mime-input").value;
258
+
const output = document.getElementById("mime-output");
259
+
const rendered = document.getElementById("mime-rendered");
260
+
261
+
try {
262
+
output.innerHTML = '<div class="output-line info">Executing...</div>';
263
+
rendered.classList.add("hidden");
264
+
265
+
const result = await rpc("exec", [{ env_id: "" }, input]);
266
+
output.innerHTML = formatOutput(result);
267
+
268
+
// Render MIME values
269
+
if (result.mime_vals && result.mime_vals.length > 0) {
270
+
rendered.classList.remove("hidden");
271
+
rendered.innerHTML = "";
272
+
273
+
for (const mime of result.mime_vals) {
274
+
const div = document.createElement("div");
275
+
div.style.marginBottom = "10px";
276
+
277
+
if (mime.mime_type.startsWith("image/svg")) {
278
+
div.innerHTML = mime.data;
279
+
} else if (mime.mime_type.startsWith("image/") && mime.encoding === "Base64") {
280
+
div.innerHTML = `<img src="data:${mime.mime_type};base64,${mime.data}" />`;
281
+
} else if (mime.mime_type === "text/html") {
282
+
div.innerHTML = mime.data;
283
+
} else {
284
+
div.innerHTML = `<pre>${escapeHtml(mime.data)}</pre>`;
285
+
}
286
+
287
+
const label = document.createElement("div");
288
+
label.style.fontSize = "0.75rem";
289
+
label.style.color = "#666";
290
+
label.textContent = `MIME: ${mime.mime_type}`;
291
+
div.appendChild(label);
292
+
293
+
rendered.appendChild(div);
294
+
}
295
+
}
296
+
} catch (err) {
297
+
output.innerHTML = `<div class="output-line stderr">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
298
+
}
299
+
}
300
+
301
+
function loadMimeExamples() {
302
+
const examples = [
303
+
{
304
+
name: "SVG Circle",
305
+
code: `let svg = {|<svg width="100" height="100">
306
+
<circle cx="50" cy="50" r="40" fill="#89b4fa"/>
307
+
<text x="50" y="55" text-anchor="middle" fill="white">OCaml</text>
308
+
</svg>|};;
309
+
Mime_printer.push "image/svg" svg;;`
310
+
},
311
+
{
312
+
name: "HTML Table",
313
+
code: `let html = {|<table style="border-collapse: collapse;">
314
+
<tr><th style="border: 1px solid #ccc; padding: 8px;">Name</th><th style="border: 1px solid #ccc; padding: 8px;">Value</th></tr>
315
+
<tr><td style="border: 1px solid #ccc; padding: 8px;">x</td><td style="border: 1px solid #ccc; padding: 8px;">42</td></tr>
316
+
<tr><td style="border: 1px solid #ccc; padding: 8px;">y</td><td style="border: 1px solid #ccc; padding: 8px;">3.14</td></tr>
317
+
</table>|};;
318
+
Mime_printer.push "text/html" html;;`
319
+
},
320
+
{
321
+
name: "SVG Bar Chart",
322
+
code: `let bars = [20; 45; 30; 60; 35];;
323
+
let bar_svg =
324
+
let bar i h =
325
+
Printf.sprintf {|<rect x="%d" y="%d" width="30" height="%d" fill="#89b4fa"/>|} (i * 40 + 10) (100 - h) h
326
+
in
327
+
Printf.sprintf {|<svg width="220" height="110">%s</svg>|}
328
+
(String.concat "" (List.mapi bar bars));;
329
+
Mime_printer.push "image/svg" bar_svg;;`
330
+
}
331
+
];
332
+
333
+
const idx = Math.floor(Math.random() * examples.length);
334
+
document.getElementById("mime-input").value = examples[idx].code;
335
+
log(`Loaded example: ${examples[idx].name}`, "info");
336
+
}
337
+
338
+
// ============================================================================
339
+
// Feature: Autocomplete
340
+
// ============================================================================
341
+
342
+
async function runComplete() {
343
+
const input = document.getElementById("complete-input").value;
344
+
const output = document.getElementById("complete-output");
345
+
346
+
try {
347
+
output.innerHTML = '<div class="completion-item">Loading...</div>';
348
+
349
+
// Position at end of input - variants encoded as arrays in rpclib
350
+
const pos = ["Offset", input.length];
351
+
352
+
const result = await rpc("complete_prefix", [{ env_id: "", is_toplevel: true }, [], [], input, pos]);
353
+
354
+
if (result.entries && result.entries.length > 0) {
355
+
output.innerHTML = result.entries.map(entry => `
356
+
<div class="completion-item">
357
+
<span class="completion-name">${escapeHtml(entry.name)}</span>
358
+
<span class="completion-kind">${escapeHtml(entry.kind)}</span>
359
+
</div>
360
+
`).join("");
361
+
} else {
362
+
output.innerHTML = '<div class="completion-item">No completions found</div>';
363
+
}
364
+
} catch (err) {
365
+
output.innerHTML = `<div class="completion-item">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
366
+
}
367
+
}
368
+
369
+
// ============================================================================
370
+
// Feature: Type Information
371
+
// ============================================================================
372
+
373
+
async function runTypeEnclosing() {
374
+
const input = document.getElementById("type-input").value;
375
+
const pos = parseInt(document.getElementById("type-pos").value) || 0;
376
+
const output = document.getElementById("type-output");
377
+
378
+
try {
379
+
output.textContent = "Loading...";
380
+
381
+
const position = ["Offset", pos];
382
+
const result = await rpc("type_enclosing", [{ env_id: "", is_toplevel: true }, [], [], input, position]);
383
+
384
+
if (result && result.length > 0) {
385
+
output.innerHTML = result.map(([loc, typeStr, tailPos]) => {
386
+
const typeText = typeof typeStr === "object" && typeStr.String
387
+
? typeStr.String
388
+
: (typeof typeStr === "object" && typeStr.Index !== undefined
389
+
? `(index ${typeStr.Index})`
390
+
: JSON.stringify(typeStr));
391
+
return `<div style="margin-bottom: 5px;">${escapeHtml(typeText)}</div>`;
392
+
}).join("");
393
+
} else {
394
+
output.textContent = "No type information at this position";
395
+
}
396
+
} catch (err) {
397
+
output.textContent = `Error: ${JSON.stringify(err)}`;
398
+
}
399
+
}
400
+
401
+
// ============================================================================
402
+
// Feature: Error Reporting
403
+
// ============================================================================
404
+
405
+
async function runQueryErrors() {
406
+
const input = document.getElementById("errors-input").value;
407
+
const output = document.getElementById("errors-output");
408
+
409
+
try {
410
+
output.innerHTML = '<div>Analyzing...</div>';
411
+
412
+
// Named params: env_id, is_toplevel. Positional: id, dependencies, source
413
+
const result = await rpc("query_errors", [{ env_id: "", is_toplevel: true }, [], [], input]);
414
+
415
+
if (result && result.length > 0) {
416
+
output.innerHTML = result.map(err => {
417
+
const isWarning = err.kind && (err.kind.Report_warning || err.kind.Report_alert);
418
+
return `
419
+
<div class="error-item ${isWarning ? 'warning' : ''}">
420
+
<strong>Line ${err.loc.loc_start.pos_lnum}:</strong> ${escapeHtml(err.main)}
421
+
${err.sub && err.sub.length > 0 ? `<br><small>${err.sub.map(escapeHtml).join("<br>")}</small>` : ""}
422
+
</div>
423
+
`;
424
+
}).join("");
425
+
} else {
426
+
output.innerHTML = '<div style="color: var(--success);">No errors found!</div>';
427
+
}
428
+
} catch (err) {
429
+
output.innerHTML = `<div class="error-item">Analysis error: ${escapeHtml(JSON.stringify(err))}</div>`;
430
+
}
431
+
}
432
+
433
+
// ============================================================================
434
+
// Feature: Directives
435
+
// ============================================================================
436
+
437
+
async function runDirective(directive) {
438
+
const input = directive || document.getElementById("directive-input").value;
439
+
const output = document.getElementById("directive-output");
440
+
441
+
if (directive) {
442
+
document.getElementById("directive-input").value = directive;
443
+
}
444
+
445
+
try {
446
+
output.innerHTML = '<div class="output-line info">Executing...</div>';
447
+
const result = await rpc("exec", [{ env_id: "" }, input]);
448
+
output.innerHTML = formatOutput(result);
449
+
} catch (err) {
450
+
output.innerHTML = `<div class="output-line stderr">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
451
+
}
452
+
}
453
+
454
+
// ============================================================================
455
+
// Feature: Custom Printers
456
+
// ============================================================================
457
+
458
+
async function runPrinter() {
459
+
const input = document.getElementById("printer-input").value;
460
+
const output = document.getElementById("printer-output");
461
+
462
+
try {
463
+
output.innerHTML = '<div class="output-line info">Executing...</div>';
464
+
465
+
// Execute each phrase separately
466
+
const phrases = input.split(";;").filter(p => p.trim()).map(p => p.trim() + ";;");
467
+
let allOutput = "";
468
+
469
+
for (const phrase of phrases) {
470
+
const result = await rpc("exec", [{ env_id: "" }, phrase]);
471
+
allOutput += formatOutput(result);
472
+
}
473
+
474
+
output.innerHTML = allOutput;
475
+
} catch (err) {
476
+
output.innerHTML = `<div class="output-line stderr">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
477
+
}
478
+
}
479
+
480
+
// ============================================================================
481
+
// Feature: Library Loading
482
+
// ============================================================================
483
+
484
+
async function runRequire() {
485
+
const input = document.getElementById("require-input").value;
486
+
const output = document.getElementById("require-output");
487
+
488
+
try {
489
+
output.innerHTML = '<div class="output-line info">Executing (loading libraries may take a moment)...</div>';
490
+
491
+
// Execute each phrase separately
492
+
const phrases = input.split(";;").filter(p => p.trim()).map(p => p.trim() + ";;");
493
+
let allOutput = "";
494
+
495
+
for (const phrase of phrases) {
496
+
const result = await rpc("exec", [{ env_id: "" }, phrase]);
497
+
allOutput += formatOutput(result);
498
+
}
499
+
500
+
output.innerHTML = allOutput;
501
+
} catch (err) {
502
+
output.innerHTML = `<div class="output-line stderr">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
503
+
}
504
+
}
505
+
506
+
// ============================================================================
507
+
// Feature: Toplevel Script
508
+
// ============================================================================
509
+
510
+
async function runToplevel() {
511
+
const input = document.getElementById("toplevel-input").value;
512
+
const output = document.getElementById("toplevel-output");
513
+
514
+
try {
515
+
output.innerHTML = '<div class="output-line info">Executing script...</div>';
516
+
const result = await rpc("exec_toplevel", [{ env_id: "" }, input]);
517
+
518
+
if (result.script) {
519
+
output.innerHTML = `<div class="output-line result"><pre>${escapeHtml(result.script)}</pre></div>`;
520
+
} else {
521
+
output.innerHTML = formatOutput(result);
522
+
}
523
+
524
+
// Handle MIME output from toplevel
525
+
if (result.mime_vals && result.mime_vals.length > 0) {
526
+
const mimeDiv = document.createElement("div");
527
+
mimeDiv.className = "mime-output";
528
+
mimeDiv.style.marginTop = "10px";
529
+
530
+
for (const mime of result.mime_vals) {
531
+
if (mime.mime_type.startsWith("image/svg")) {
532
+
mimeDiv.innerHTML += mime.data;
533
+
} else if (mime.mime_type === "text/html") {
534
+
mimeDiv.innerHTML += mime.data;
535
+
}
536
+
}
537
+
538
+
if (mimeDiv.innerHTML) {
539
+
output.appendChild(mimeDiv);
540
+
}
541
+
}
542
+
} catch (err) {
543
+
output.innerHTML = `<div class="output-line stderr">Error: ${escapeHtml(JSON.stringify(err))}</div>`;
544
+
}
545
+
}
546
+
547
+
// ============================================================================
548
+
// Initialize on page load
549
+
// ============================================================================
550
+
551
+
document.addEventListener("DOMContentLoaded", initWorker);
+91
js_top_worker/example/dune
+91
js_top_worker/example/dune
···
1
+
(executable
2
+
(name example)
3
+
(preprocess
4
+
(pps js_of_ocaml-ppx))
5
+
(modes js)
6
+
(modules example)
7
+
(libraries js_top_worker_client lwt js_of_ocaml))
8
+
9
+
(executable
10
+
(name example2)
11
+
(preprocess
12
+
(pps js_of_ocaml-ppx))
13
+
(modes js)
14
+
(modules example2)
15
+
(libraries js_top_worker_client lwt js_of_ocaml))
16
+
17
+
(executable
18
+
(name example3)
19
+
(preprocess
20
+
(pps js_of_ocaml-ppx))
21
+
(modes js)
22
+
(modules example3)
23
+
(libraries js_top_worker_client lwt js_of_ocaml))
24
+
25
+
(executable
26
+
(name example4)
27
+
(preprocess
28
+
(pps js_of_ocaml-ppx))
29
+
(modes js)
30
+
(modules example4)
31
+
(libraries js_top_worker_client lwt js_of_ocaml))
32
+
33
+
(executable
34
+
(name worker)
35
+
(modes byte js)
36
+
(modules worker)
37
+
(link_flags (-linkall))
38
+
(js_of_ocaml
39
+
(javascript_files ../lib/stubs.js)
40
+
(flags --effects=disabled --toplevel --opt 3 +toplevel.js +dynlink.js))
41
+
(libraries js_top_worker-web logs.browser mime_printer tyxml))
42
+
43
+
(executable
44
+
(name unix_worker)
45
+
(public_name unix_worker)
46
+
(modes byte)
47
+
(package js_top_worker-unix)
48
+
(modules unix_worker)
49
+
(link_flags (-linkall))
50
+
(libraries
51
+
unix
52
+
js_top_worker
53
+
logs
54
+
logs.fmt
55
+
rpclib.core
56
+
rpclib.json
57
+
findlib.top
58
+
lwt.unix))
59
+
60
+
(executable
61
+
(name unix_client)
62
+
(public_name unix_client)
63
+
(package js_top_worker-unix)
64
+
(modules unix_client)
65
+
(libraries js_top_worker_client rpclib.cmdliner))
66
+
67
+
(rule
68
+
(targets
69
+
(dir _opam))
70
+
(action
71
+
(run jtw opam -o _opam str stringext mime_printer)))
72
+
73
+
(alias
74
+
(name default)
75
+
(deps
76
+
index.html
77
+
demo.html
78
+
demo.js
79
+
README.md
80
+
example.bc.js
81
+
example2.bc.js
82
+
example3.bc.js
83
+
example4.bc.js
84
+
example5.js
85
+
index2.html
86
+
index3.html
87
+
index4.html
88
+
index5.html
89
+
_opam
90
+
server.py
91
+
(alias_rec all)))
+48
js_top_worker/example/example.ml
+48
js_top_worker/example/example.ml
···
1
+
(* Simplest example *)
2
+
open Js_of_ocaml
3
+
open Js_top_worker_rpc
4
+
module W = Js_top_worker_client.W
5
+
6
+
let log s = Console.console##log (Js.string s)
7
+
8
+
let initialise s callback =
9
+
let ( let* ) = Lwt_result.bind in
10
+
let rpc = Js_top_worker_client.start s 100000 callback in
11
+
let* () =
12
+
W.init rpc
13
+
Toplevel_api_gen.
14
+
{
15
+
stdlib_dcs = None;
16
+
findlib_requires = [ "stringext" ];
17
+
findlib_index = None;
18
+
execute = true;
19
+
}
20
+
in
21
+
Lwt.return (Ok rpc)
22
+
23
+
let log_output (o : Toplevel_api_gen.exec_result) =
24
+
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
25
+
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
26
+
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
27
+
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
28
+
let strloc (line, col) =
29
+
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
30
+
in
31
+
Option.iter
32
+
(fun h ->
33
+
let open Toplevel_api_gen in
34
+
log
35
+
("highlight "
36
+
^ strloc (h.line1, h.col1)
37
+
^ " to "
38
+
^ strloc (h.line2, h.col2)))
39
+
o.highlight
40
+
41
+
let _ =
42
+
let ( let* ) = Lwt_result.bind in
43
+
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
44
+
let* o = W.setup rpc "" in
45
+
log_output o;
46
+
let* o = W.exec rpc "" "Stringext.of_list ['a';'b';'c'];;" in
47
+
log_output o;
48
+
Lwt.return (Ok ())
+43
js_top_worker/example/example2.ml
+43
js_top_worker/example/example2.ml
···
1
+
(* Simplest example *)
2
+
open Js_of_ocaml
3
+
open Js_top_worker_rpc
4
+
module W = Js_top_worker_client.W
5
+
6
+
let log s = Console.console##log (Js.string s)
7
+
8
+
let initialise s callback =
9
+
let ( let* ) = Lwt_result.bind in
10
+
let rpc = Js_top_worker_client.start s 100000 callback in
11
+
let* () =
12
+
W.init rpc
13
+
Toplevel_api_gen.
14
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
15
+
in
16
+
Lwt.return (Ok rpc)
17
+
18
+
let log_output (o : Toplevel_api_gen.exec_result) =
19
+
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
20
+
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
21
+
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
22
+
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
23
+
let strloc (line, col) =
24
+
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
25
+
in
26
+
Option.iter
27
+
(fun h ->
28
+
let open Toplevel_api_gen in
29
+
log
30
+
("highlight "
31
+
^ strloc (h.line1, h.col1)
32
+
^ " to "
33
+
^ strloc (h.line2, h.col2)))
34
+
o.highlight
35
+
36
+
let _ =
37
+
let ( let* ) = Lwt_result.bind in
38
+
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
39
+
let* o = W.setup rpc "" in
40
+
log_output o;
41
+
let* o = W.exec rpc "" "2*2;;" in
42
+
log_output o;
43
+
Lwt.return (Ok ())
+46
js_top_worker/example/example3.ml
+46
js_top_worker/example/example3.ml
···
1
+
(* Simplest example *)
2
+
open Js_of_ocaml
3
+
open Js_top_worker_rpc
4
+
module W = Js_top_worker_client.W
5
+
6
+
let log s = Console.console##log (Js.string s)
7
+
8
+
let initialise s callback =
9
+
let ( let* ) = Lwt_result.bind in
10
+
let rpc = Js_top_worker_client.start s 10000000 callback in
11
+
let* () =
12
+
W.init rpc
13
+
Toplevel_api_gen.
14
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
15
+
in
16
+
Lwt.return (Ok rpc)
17
+
18
+
let log_output (o : Toplevel_api_gen.exec_result) =
19
+
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
20
+
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
21
+
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
22
+
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
23
+
let strloc (line, col) =
24
+
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
25
+
in
26
+
Option.iter
27
+
(fun h ->
28
+
let open Toplevel_api_gen in
29
+
log
30
+
("highlight "
31
+
^ strloc (h.line1, h.col1)
32
+
^ " to "
33
+
^ strloc (h.line2, h.col2)))
34
+
o.highlight
35
+
36
+
let _ =
37
+
let ( let* ) = Lwt_result.bind in
38
+
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
39
+
let* o = W.setup rpc "" in
40
+
log_output o;
41
+
let* _o = W.query_errors rpc "" (Some "c1") [] false "type xxx = int;;\n" in
42
+
let* _o2 =
43
+
W.query_errors rpc "" (Some "c2") [ "c1" ] true
44
+
"# type yyy = xxx;;\n type yyy = xxx\n"
45
+
in
46
+
Lwt.return (Ok ())
+52
js_top_worker/example/example4.ml
+52
js_top_worker/example/example4.ml
···
1
+
(* Simplest example *)
2
+
open Js_of_ocaml
3
+
open Js_top_worker_rpc
4
+
module W = Js_top_worker_client.W
5
+
6
+
let log s = Console.console##log (Js.string s)
7
+
8
+
let initialise s callback =
9
+
let ( let* ) = Lwt_result.bind in
10
+
let rpc = Js_top_worker_client.start s 10000000 callback in
11
+
let* () =
12
+
W.init rpc
13
+
Toplevel_api_gen.
14
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
15
+
in
16
+
Lwt.return (Ok rpc)
17
+
18
+
let log_output (o : Toplevel_api_gen.exec_result) =
19
+
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
20
+
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
21
+
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
22
+
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
23
+
let strloc (line, col) =
24
+
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
25
+
in
26
+
Option.iter
27
+
(fun h ->
28
+
let open Toplevel_api_gen in
29
+
log
30
+
("highlight "
31
+
^ strloc (h.line1, h.col1)
32
+
^ " to "
33
+
^ strloc (h.line2, h.col2)))
34
+
o.highlight
35
+
36
+
let _ =
37
+
let ( let* ) = Lwt_result.bind in
38
+
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
39
+
let* o = W.setup rpc "" in
40
+
log_output o;
41
+
let* _o = W.query_errors rpc "" (Some "c1") [] false "type xxxx = int;;\n" in
42
+
let* _o2 =
43
+
W.query_errors rpc "" (Some "c2") [ "c1" ] true
44
+
"# type yyy = xxx;;\n type yyy = xxx\n"
45
+
in
46
+
let* _o = W.query_errors rpc "" (Some "c1") [] false "type xxx = int;;\n" in
47
+
let* _o2 =
48
+
W.query_errors rpc "" (Some "c2") [ "c1" ] true
49
+
"# type yyy = xxx (* With a comment *);;\n type yyy = xxx\n"
50
+
in
51
+
52
+
Lwt.return (Ok ())
+46
js_top_worker/example/example5.js
+46
js_top_worker/example/example5.js
···
1
+
2
+
function getWorkerURL( url ) {
3
+
const content = `globalThis.__global_rel_url="${ url }"\nimportScripts( "${ url }/worker.js" );`;
4
+
return URL.createObjectURL( new Blob( [ content ], { type: "text/javascript" } ) );
5
+
}
6
+
7
+
const worker = new Worker(getWorkerURL("https://jon-test.ludl.am/_opam"))
8
+
9
+
var promises = new Map()
10
+
var id = 1
11
+
12
+
worker.onmessage = function (e) {
13
+
j = JSON.parse(e.data)
14
+
if (j.id) {
15
+
promise = promises[j.id]
16
+
promises.delete(j.id)
17
+
promise(j.result)
18
+
}
19
+
}
20
+
21
+
function rpc(method, params) {
22
+
const localid = id++;
23
+
return new Promise(function (resolve, reject) {
24
+
worker.postMessage(JSON.stringify({ id:localid, method, params }));
25
+
promises[localid] = resolve
26
+
})
27
+
}
28
+
29
+
function init(cmas,cmi_urls) {
30
+
return rpc("init",[{init_libs: {execute: true, findlib_requires:[]}}])
31
+
}
32
+
33
+
function setup() {
34
+
return rpc("setup",[null])
35
+
}
36
+
37
+
function exec(phrase) {
38
+
return rpc("exec",[phrase])
39
+
}
40
+
41
+
function dump(result) {
42
+
console.log(result.stdout)
43
+
}
44
+
45
+
init([],[]).then(() => setup()).then(function(result) { dump(result); exec("let _ = Mime_printer.push \"text/text\" \"hello, world\";;").then((result) => dump(result))})
46
+
+10
js_top_worker/example/index.html
+10
js_top_worker/example/index.html
+10
js_top_worker/example/index2.html
+10
js_top_worker/example/index2.html
+10
js_top_worker/example/index3.html
+10
js_top_worker/example/index3.html
+10
js_top_worker/example/index4.html
+10
js_top_worker/example/index4.html
+10
js_top_worker/example/index5.html
+10
js_top_worker/example/index5.html
+19
js_top_worker/example/server.py
+19
js_top_worker/example/server.py
···
1
+
#!/usr/bin/env python3
2
+
3
+
import http.server
4
+
import sys
5
+
6
+
class MyHTTPRequestHandler(http.server.SimpleHTTPRequestHandler):
7
+
def end_headers(self):
8
+
self.send_header('Access-Control-Allow-Origin', '*')
9
+
self.send_my_headers()
10
+
http.server.SimpleHTTPRequestHandler.end_headers(self)
11
+
12
+
def send_my_headers(self):
13
+
self.send_header("Cache-Control", "no-cache, no-store, must-revalidate")
14
+
self.send_header("Pragma", "no-cache")
15
+
self.send_header("Expires", "0")
16
+
17
+
18
+
if __name__ == '__main__':
19
+
http.server.test(MyHTTPRequestHandler, http.server.HTTPServer, port=int(sys.argv[1]) if len(sys.argv) > 1 else 8000)
+14
js_top_worker/example/stubs.js
+14
js_top_worker/example/stubs.js
···
1
+
//Provides: caml_unix_times
2
+
function caml_unix_times() {
3
+
return 4.2
4
+
}
5
+
6
+
//Provides: ml_merlin_fs_exact_case_basename
7
+
function ml_merlin_fs_exact_case_basename(str) {
8
+
return 0
9
+
}
10
+
11
+
//Provides: ml_merlin_fs_exact_case
12
+
function ml_merlin_fs_exact_case(str) {
13
+
return str
14
+
}
+45
js_top_worker/example/unix_client.ml
+45
js_top_worker/example/unix_client.ml
···
1
+
open Js_top_worker_rpc
2
+
module M = Idl.IdM (* Server is synchronous *)
3
+
module IdlM = Idl.Make (M)
4
+
module Client = Toplevel_api_gen.Make (IdlM.GenClient ())
5
+
module Cmds = Toplevel_api_gen.Make (Cmdlinergen.Gen ())
6
+
7
+
(* Use a binary 16-byte length to frame RPC messages *)
8
+
let binary_rpc path (call : Rpc.call) : Rpc.response =
9
+
let sockaddr = Unix.ADDR_UNIX path in
10
+
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
11
+
Unix.connect s sockaddr;
12
+
let ic = Unix.in_channel_of_descr s in
13
+
let oc = Unix.out_channel_of_descr s in
14
+
let msg_buf = Transport.Json.string_of_call call in
15
+
let len = Printf.sprintf "%016d" (String.length msg_buf) in
16
+
output_string oc len;
17
+
output_string oc msg_buf;
18
+
flush oc;
19
+
let len_buf = Bytes.make 16 '\000' in
20
+
really_input ic len_buf 0 16;
21
+
let len = int_of_string (Bytes.unsafe_to_string len_buf) in
22
+
let msg_buf = Bytes.make len '\000' in
23
+
really_input ic msg_buf 0 len;
24
+
let (response : Rpc.response) =
25
+
Transport.Json.response_of_string (Bytes.unsafe_to_string msg_buf)
26
+
in
27
+
response
28
+
29
+
let cli () =
30
+
let default =
31
+
Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ()))
32
+
in
33
+
let info = Cmdliner.Cmd.info "cli" ~version:"1.6.1" ~doc:"a cli for an API" in
34
+
let rpc = binary_rpc Toplevel_api_gen.sockpath in
35
+
let cmds =
36
+
List.map
37
+
(fun t ->
38
+
let term, info = t rpc in
39
+
Cmdliner.(Cmd.v info Term.(term $ const ())))
40
+
(Cmds.implementation ())
41
+
in
42
+
let cmd = Cmdliner.Cmd.group ~default info cmds in
43
+
exit (Cmdliner.Cmd.eval cmd)
44
+
45
+
let () = cli ()
+213
js_top_worker/example/unix_worker.ml
+213
js_top_worker/example/unix_worker.ml
···
1
+
(* Unix worker *)
2
+
open Js_top_worker
3
+
open Impl
4
+
5
+
let capture f () =
6
+
let stdout_backup = Unix.dup ~cloexec:true Unix.stdout in
7
+
let stderr_backup = Unix.dup ~cloexec:true Unix.stderr in
8
+
let filename_out = Filename.temp_file "ocaml-mdx-" ".stdout" in
9
+
let filename_err = Filename.temp_file "ocaml-mdx-" ".stderr" in
10
+
let fd_out =
11
+
Unix.openfile filename_out
12
+
Unix.[ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ]
13
+
0o600
14
+
in
15
+
let fd_err =
16
+
Unix.openfile filename_err
17
+
Unix.[ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ]
18
+
0o600
19
+
in
20
+
Unix.dup2 ~cloexec:false fd_out Unix.stdout;
21
+
Unix.dup2 ~cloexec:false fd_err Unix.stderr;
22
+
let ic_out = open_in filename_out in
23
+
let ic_err = open_in filename_err in
24
+
let capture oc ic fd buf =
25
+
flush oc;
26
+
let len = Unix.lseek fd 0 Unix.SEEK_CUR in
27
+
Buffer.add_channel buf ic len
28
+
in
29
+
Fun.protect
30
+
(fun () ->
31
+
let x = f () in
32
+
let buf_out = Buffer.create 1024 in
33
+
let buf_err = Buffer.create 1024 in
34
+
capture stdout ic_out fd_out buf_out;
35
+
capture stderr ic_err fd_err buf_err;
36
+
( {
37
+
Impl.stdout = Buffer.contents buf_out;
38
+
stderr = Buffer.contents buf_err;
39
+
},
40
+
x ))
41
+
~finally:(fun () ->
42
+
close_in_noerr ic_out;
43
+
close_in_noerr ic_out;
44
+
Unix.close fd_out;
45
+
Unix.close fd_err;
46
+
Unix.dup2 ~cloexec:false stdout_backup Unix.stdout;
47
+
Unix.dup2 ~cloexec:false stderr_backup Unix.stderr;
48
+
Unix.close stdout_backup;
49
+
Unix.close stderr_backup;
50
+
Sys.remove filename_out;
51
+
Sys.remove filename_err)
52
+
53
+
let ( let* ) = Lwt.bind
54
+
55
+
let rec read_exact s buf off len =
56
+
if len <= 0 then Lwt.return ()
57
+
else
58
+
let* n = Lwt_unix.read s buf off len in
59
+
if n = 0 then Lwt.fail End_of_file
60
+
else read_exact s buf (off + n) (len - n)
61
+
62
+
let binary_handler process s =
63
+
(* Read a 16 byte length encoded as a string *)
64
+
let len_buf = Bytes.make 16 '\000' in
65
+
let* () = read_exact s len_buf 0 16 in
66
+
let len = int_of_string (Bytes.unsafe_to_string len_buf) in
67
+
let msg_buf = Bytes.make len '\000' in
68
+
let* () = read_exact s msg_buf 0 len in
69
+
let* result = process msg_buf in
70
+
let len_buf = Printf.sprintf "%016d" (String.length result) in
71
+
let* _ = Lwt_unix.write s (Bytes.of_string len_buf) 0 16 in
72
+
let* _ = Lwt_unix.write s (Bytes.of_string result) 0 (String.length result) in
73
+
Lwt.return ()
74
+
75
+
let mkdir_rec dir perm =
76
+
let rec p_mkdir dir =
77
+
let p_name = Filename.dirname dir in
78
+
if p_name <> "/" && p_name <> "." then p_mkdir p_name;
79
+
try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
80
+
in
81
+
p_mkdir dir
82
+
83
+
let serve_requests rpcfn path ~ready_fd =
84
+
let ( let* ) = Lwt.bind in
85
+
(try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ());
86
+
mkdir_rec (Filename.dirname path) 0o0755;
87
+
let sock = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
88
+
let* () = Lwt_unix.bind sock (Unix.ADDR_UNIX path) in
89
+
Lwt_unix.listen sock 5;
90
+
(* Signal readiness via pipe to parent process *)
91
+
(match ready_fd with
92
+
| Some fd ->
93
+
ignore (Unix.write fd (Bytes.of_string "R") 0 1);
94
+
Unix.close fd
95
+
| None -> ());
96
+
let rec loop () =
97
+
let* this_connection, _ = Lwt_unix.accept sock in
98
+
let* () =
99
+
Lwt.finalize
100
+
(fun () ->
101
+
(* Here I am calling M.run to make sure that I am running the process,
102
+
this is not much of a problem with IdM or ExnM, but in general you
103
+
should ensure that the computation is started by a runner. *)
104
+
binary_handler rpcfn this_connection)
105
+
(fun () -> Lwt_unix.close this_connection)
106
+
in
107
+
loop ()
108
+
in
109
+
loop ()
110
+
111
+
let handle_findlib_error = function
112
+
| Failure msg -> Printf.fprintf stderr "%s" msg
113
+
| Fl_package_base.No_such_package (pkg, reason) ->
114
+
Printf.fprintf stderr "No such package: %s%s\n" pkg
115
+
(if reason <> "" then " - " ^ reason else "")
116
+
| Fl_package_base.Package_loop pkg ->
117
+
Printf.fprintf stderr "Package requires itself: %s\n" pkg
118
+
| exn -> raise exn
119
+
120
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
121
+
122
+
module S : Impl.S = struct
123
+
type findlib_t = unit
124
+
125
+
let capture = capture
126
+
let sync_get _ = None
127
+
let async_get _ = Lwt.return (Error (`Msg "Not implemented"))
128
+
let create_file ~name:_ ~content:_ = failwith "Not implemented"
129
+
130
+
let import_scripts urls =
131
+
if List.length urls > 0 then failwith "Not implemented" else ()
132
+
133
+
let init_function _ () = failwith "Not implemented"
134
+
let findlib_init _ = Lwt.return ()
135
+
let get_stdlib_dcs _uri = []
136
+
137
+
let require _ () packages =
138
+
try
139
+
let eff_packages =
140
+
Findlib.package_deep_ancestors !Topfind.predicates packages
141
+
in
142
+
Topfind.load eff_packages;
143
+
[]
144
+
with exn ->
145
+
handle_findlib_error exn;
146
+
[]
147
+
148
+
let path = "/tmp"
149
+
end
150
+
151
+
module U = Impl.Make (S)
152
+
153
+
(* let test () =
154
+
let _x = Compmisc.initial_env in
155
+
let oc = open_out "/tmp/unix_worker.ml" in
156
+
Printf.fprintf oc "let x=1;;\n";
157
+
close_out oc;
158
+
let unit_info = Unit_info.make ~source_file:"/tmp/unix_worker.ml" "/tmp/unix_worker" in
159
+
try
160
+
let _ast = Pparse.parse_implementation ~tool_name:"worker" "/tmp/unix_worker.ml" in
161
+
let _ = Typemod.type_implementation unit_info (Compmisc.initial_env ()) _ast in
162
+
()
163
+
with exn ->
164
+
Printf.eprintf "error: %s\n%!" (Printexc.to_string exn);
165
+
let ppf = Format.err_formatter in
166
+
let _ = Location.report_exception ppf exn in
167
+
() *)
168
+
169
+
let start_server ~ready_fd =
170
+
let open U in
171
+
Logs.set_reporter (Logs_fmt.reporter ());
172
+
Logs.set_level (Some Logs.Warning);
173
+
Server.init (IdlM.T.lift init);
174
+
Server.create_env (IdlM.T.lift create_env);
175
+
Server.destroy_env (IdlM.T.lift destroy_env);
176
+
Server.list_envs (IdlM.T.lift list_envs);
177
+
Server.setup (IdlM.T.lift setup);
178
+
Server.exec execute;
179
+
Server.complete_prefix complete_prefix;
180
+
Server.query_errors query_errors;
181
+
Server.type_enclosing type_enclosing;
182
+
Server.exec_toplevel exec_toplevel;
183
+
let rpc_fn = IdlM.server Server.implementation in
184
+
let process x =
185
+
let open Lwt in
186
+
let _, call = Js_top_worker_rpc.Transport.Json.id_and_call_of_string (Bytes.unsafe_to_string x) in
187
+
rpc_fn call >>= fun response ->
188
+
Js_top_worker_rpc.Transport.Json.string_of_response ~id:(Rpc.Int 0L) response |> return
189
+
in
190
+
serve_requests process Js_top_worker_rpc.Toplevel_api_gen.sockpath ~ready_fd
191
+
192
+
let () =
193
+
(* Fork so parent only exits once child is ready to accept connections *)
194
+
let read_fd, write_fd = Unix.pipe ~cloexec:false () in
195
+
match Unix.fork () with
196
+
| 0 ->
197
+
(* Child: close read end and detach from terminal *)
198
+
Unix.close read_fd;
199
+
(* Redirect stdout/stderr to /dev/null so parent's $() can complete *)
200
+
let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0 in
201
+
Unix.dup2 dev_null Unix.stdout;
202
+
Unix.dup2 dev_null Unix.stderr;
203
+
Unix.close dev_null;
204
+
(* Run server, signal via write end *)
205
+
Lwt_main.run (start_server ~ready_fd:(Some write_fd))
206
+
| child_pid ->
207
+
(* Parent: close write end, wait for ready signal, print child PID, exit *)
208
+
Unix.close write_fd;
209
+
let buf = Bytes.create 1 in
210
+
ignore (Unix.read read_fd buf 0 1);
211
+
Unix.close read_fd;
212
+
Printf.printf "%d\n%!" child_pid
213
+
(* Parent exits here, child continues serving *)
+1
js_top_worker/example/worker.ml
+1
js_top_worker/example/worker.ml
···
1
+
let _ = Js_top_worker_web.Worker.run ()
+1
js_top_worker/idl/.ocamlformat-ignore
+1
js_top_worker/idl/.ocamlformat-ignore
···
1
+
toplevel_api_gen.ml
+660
js_top_worker/idl/_old/idl.ml
+660
js_top_worker/idl/_old/idl.ml
···
1
+
let logfn = ref (fun (_ : string) -> ())
2
+
3
+
module Param = struct
4
+
type 'a t = {
5
+
name : string option;
6
+
description : string list;
7
+
typedef : 'a Rpc.Types.def;
8
+
version : Rpc.Version.t option;
9
+
}
10
+
11
+
type boxed = Boxed : 'a t -> boxed
12
+
13
+
let mk ?name ?description ?version typedef =
14
+
let description =
15
+
match description with
16
+
| Some d -> d
17
+
| None -> typedef.Rpc.Types.description
18
+
in
19
+
{ name; description; version; typedef }
20
+
end
21
+
22
+
module Error = struct
23
+
type 'a t = {
24
+
def : 'a Rpc.Types.def;
25
+
raiser : 'a -> exn;
26
+
matcher : exn -> 'a option;
27
+
}
28
+
29
+
module type ERROR = sig
30
+
type t
31
+
32
+
val t : t Rpc.Types.def
33
+
val internal_error_of : exn -> t option
34
+
end
35
+
36
+
module Make (T : ERROR) = struct
37
+
exception Exn of T.t
38
+
39
+
let () =
40
+
let printer = function
41
+
| Exn x ->
42
+
Some
43
+
(Printf.sprintf "IDL Error: %s"
44
+
(Rpcmarshal.marshal T.t.Rpc.Types.ty x |> Rpc.to_string))
45
+
| _ -> None
46
+
in
47
+
Printexc.register_printer printer
48
+
49
+
let error =
50
+
{
51
+
def = T.t;
52
+
raiser = (function e -> Exn e);
53
+
matcher = (function Exn e -> Some e | e -> T.internal_error_of e);
54
+
}
55
+
end
56
+
end
57
+
58
+
module Interface = struct
59
+
type description = {
60
+
name : string;
61
+
namespace : string option;
62
+
description : string list;
63
+
version : Rpc.Version.t;
64
+
}
65
+
end
66
+
67
+
module type RPC = sig
68
+
type implementation
69
+
type 'a res
70
+
type ('a, 'b) comp
71
+
type _ fn
72
+
73
+
val implement : Interface.description -> implementation
74
+
val ( @-> ) : 'a Param.t -> 'b fn -> ('a -> 'b) fn
75
+
val returning : 'a Param.t -> 'b Error.t -> ('a, 'b) comp fn
76
+
val declare : string -> string list -> 'a fn -> 'a res
77
+
val declare_notification : string -> string list -> 'a fn -> 'a res
78
+
end
79
+
80
+
module type MONAD = sig
81
+
type 'a t
82
+
83
+
val return : 'a -> 'a t
84
+
val bind : 'a t -> ('a -> 'b t) -> 'b t
85
+
val fail : exn -> 'a t
86
+
end
87
+
88
+
exception MarshalError of string
89
+
exception UnknownMethod of string
90
+
exception UnboundImplementation of string list
91
+
exception NoDescription
92
+
93
+
let get_wire_name description name =
94
+
match description with
95
+
| None -> name
96
+
| Some d -> (
97
+
match d.Interface.namespace with
98
+
| Some ns -> Printf.sprintf "%s.%s" ns name
99
+
| None -> name)
100
+
101
+
let get_arg call has_named name is_opt =
102
+
match (has_named, name, call.Rpc.params) with
103
+
| true, Some n, Rpc.Dict named :: unnamed -> (
104
+
match List.partition (fun (x, _) -> x = n) named with
105
+
| (_, arg) :: dups, others when is_opt ->
106
+
Ok
107
+
( Rpc.Enum [ arg ],
108
+
{ call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed } )
109
+
| (_, arg) :: dups, others ->
110
+
Ok
111
+
(arg, { call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed })
112
+
| [], _others when is_opt -> Ok (Rpc.Enum [], call)
113
+
| _, _ -> Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)))
114
+
| true, None, Rpc.Dict named :: unnamed -> (
115
+
match unnamed with
116
+
| head :: tail ->
117
+
Ok (head, { call with Rpc.params = Rpc.Dict named :: tail })
118
+
| _ -> Error (`Msg "Incorrect number of arguments"))
119
+
| true, _, _ ->
120
+
Error
121
+
(`Msg
122
+
"Marshalling error: Expecting dict as first argument when named \
123
+
parameters exist")
124
+
| false, None, head :: tail -> Ok (head, { call with Rpc.params = tail })
125
+
| false, None, [] -> Error (`Msg "Incorrect number of arguments")
126
+
| false, Some _, _ -> failwith "Can't happen by construction"
127
+
128
+
module Make (M : MONAD) = struct
129
+
module type RPCTRANSFORMER = sig
130
+
type 'a box
131
+
type ('a, 'b) resultb = ('a, 'b) result box
132
+
type rpcfn = Rpc.call -> Rpc.response M.t
133
+
134
+
val lift : ('a -> 'b M.t) -> 'a -> 'b box
135
+
val bind : 'a box -> ('a -> 'b M.t) -> 'b box
136
+
val return : 'a -> 'a box
137
+
val get : 'a box -> 'a M.t
138
+
val ( !@ ) : 'a box -> 'a M.t
139
+
val put : 'a M.t -> 'a box
140
+
val ( ~@ ) : 'a M.t -> 'a box
141
+
end
142
+
143
+
module T = struct
144
+
type 'a box = { box : 'a M.t }
145
+
type ('a, 'b) resultb = ('a, 'b) result box
146
+
type rpcfn = Rpc.call -> Rpc.response M.t
147
+
148
+
let lift f x = { box = f x }
149
+
let bind { box = x } f = { box = M.bind x f }
150
+
let return x = { box = M.return x }
151
+
let get { box = x } = x
152
+
let ( !@ ) = get
153
+
let put x = { box = x }
154
+
let ( ~@ ) = put
155
+
end
156
+
157
+
type client_implementation = unit
158
+
type server_implementation = (string, T.rpcfn option) Hashtbl.t
159
+
160
+
module ErrM : sig
161
+
val return : 'a -> ('a, 'b) T.resultb
162
+
val return_err : 'b -> ('a, 'b) T.resultb
163
+
164
+
val checked_bind :
165
+
('a, 'b) T.resultb ->
166
+
('a -> ('c, 'd) T.resultb) ->
167
+
('b -> ('c, 'd) T.resultb) ->
168
+
('c, 'd) T.resultb
169
+
170
+
val bind :
171
+
('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
172
+
173
+
val ( >>= ) :
174
+
('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
175
+
end = struct
176
+
let return x = T.put (M.return (Ok x))
177
+
let return_err e = T.put (M.return (Error e))
178
+
179
+
let checked_bind x f f1 =
180
+
T.bind x T.(function Ok x -> !@(f x) | Error x -> !@(f1 x))
181
+
182
+
let bind x f = checked_bind x f return_err
183
+
let ( >>= ) x f = bind x f
184
+
end
185
+
186
+
module GenClient () = struct
187
+
type implementation = client_implementation
188
+
type 'a res = T.rpcfn -> 'a
189
+
type ('a, 'b) comp = ('a, 'b) T.resultb
190
+
191
+
type _ fn =
192
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
193
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
194
+
195
+
let description = ref None
196
+
let strict = ref false
197
+
let make_strict () = strict := true
198
+
199
+
let implement x =
200
+
description := Some x;
201
+
()
202
+
203
+
let returning a err = Returning (a, err)
204
+
let ( @-> ) t f = Function (t, f)
205
+
206
+
let declare_ is_notification name _ ty (rpc : T.rpcfn) =
207
+
let rec inner :
208
+
type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
209
+
fun (named, unnamed) -> function
210
+
| Function (t, f) -> (
211
+
let cur_named = match named with Some l -> l | None -> [] in
212
+
fun v ->
213
+
match t.Param.name with
214
+
| Some n -> (
215
+
match (t.Param.typedef.Rpc.Types.ty, v) with
216
+
| Rpc.Types.Option ty, Some v' ->
217
+
let marshalled = Rpcmarshal.marshal ty v' in
218
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f
219
+
| Rpc.Types.Option _ty, None ->
220
+
inner (Some cur_named, unnamed) f
221
+
| ty, v ->
222
+
let marshalled = Rpcmarshal.marshal ty v in
223
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
224
+
| None ->
225
+
let marshalled =
226
+
Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v
227
+
in
228
+
inner (named, marshalled :: unnamed) f)
229
+
| Returning (t, e) ->
230
+
let wire_name = get_wire_name !description name in
231
+
let args =
232
+
match named with
233
+
| None -> List.rev unnamed
234
+
| Some l -> Rpc.Dict l :: List.rev unnamed
235
+
in
236
+
let call' = Rpc.call wire_name args in
237
+
let call = { call' with is_notification } in
238
+
let rpc = T.put (rpc call) in
239
+
let res =
240
+
T.bind rpc (fun r ->
241
+
if r.Rpc.success then
242
+
match
243
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty
244
+
r.Rpc.contents
245
+
with
246
+
| Ok x -> M.return (Ok x)
247
+
| Error (`Msg x) -> M.fail (MarshalError x)
248
+
else
249
+
match
250
+
Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty
251
+
r.Rpc.contents
252
+
with
253
+
| Ok x ->
254
+
if !strict then M.fail (e.Error.raiser x)
255
+
else M.return (Error x)
256
+
| Error (`Msg x) -> M.fail (MarshalError x))
257
+
in
258
+
res
259
+
in
260
+
inner (None, []) ty
261
+
262
+
let declare_notification name a ty (rpc : T.rpcfn) =
263
+
declare_ true name a ty rpc
264
+
265
+
let declare name a ty (rpc : T.rpcfn) = declare_ false name a ty rpc
266
+
end
267
+
268
+
let server hashtbl =
269
+
let impl = Hashtbl.create (Hashtbl.length hashtbl) in
270
+
let unbound_impls =
271
+
Hashtbl.fold
272
+
(fun key fn acc ->
273
+
match fn with
274
+
| None -> key :: acc
275
+
| Some fn ->
276
+
Hashtbl.add impl key fn;
277
+
acc)
278
+
hashtbl []
279
+
in
280
+
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
281
+
fun call ->
282
+
let fn =
283
+
try Hashtbl.find impl call.Rpc.name
284
+
with Not_found ->
285
+
!logfn "1";
286
+
Hashtbl.iter
287
+
(fun key _ ->
288
+
!logfn ("method: " ^ key ^ (Hashtbl.hash key |> string_of_int));
289
+
!logfn key)
290
+
impl;
291
+
let _h = Hashtbl.hash call.Rpc.name in
292
+
293
+
!logfn
294
+
(Printf.sprintf "Unknown method: %s %d" call.Rpc.name
295
+
(Hashtbl.hash call.Rpc.name));
296
+
!logfn call.Rpc.name;
297
+
raise (UnknownMethod call.Rpc.name)
298
+
in
299
+
fn call
300
+
301
+
let combine hashtbls =
302
+
let result = Hashtbl.create 16 in
303
+
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
304
+
result
305
+
306
+
module GenServer () = struct
307
+
type implementation = server_implementation
308
+
type ('a, 'b) comp = ('a, 'b) T.resultb
309
+
type 'a res = 'a -> unit
310
+
311
+
type _ fn =
312
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
313
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
314
+
315
+
let funcs = Hashtbl.create 20
316
+
let description = ref None
317
+
318
+
let implement x =
319
+
description := Some x;
320
+
funcs
321
+
322
+
let returning a b = Returning (a, b)
323
+
let ( @-> ) t f = Function (t, f)
324
+
325
+
let rec has_named_args : type a. a fn -> bool = function
326
+
| Function (t, f) -> (
327
+
match t.Param.name with Some _ -> true | None -> has_named_args f)
328
+
| Returning (_, _) -> false
329
+
330
+
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
331
+
fun is_notification name _ ty ->
332
+
let ( >>= ) = M.bind in
333
+
(* We do not know the wire name yet as the description may still be unset *)
334
+
Hashtbl.add funcs name None;
335
+
fun impl ->
336
+
(* Sanity check: ensure the description has been set before we declare
337
+
any RPCs. Here we raise an exception immediately and let everything fail. *)
338
+
(match !description with Some _ -> () | None -> raise NoDescription);
339
+
let rpcfn =
340
+
let has_named = has_named_args ty in
341
+
let rec inner : type a. a fn -> a -> T.rpcfn =
342
+
fun f impl call ->
343
+
match f with
344
+
| Function (t, f) -> (
345
+
let is_opt =
346
+
match t.Param.typedef.Rpc.Types.ty with
347
+
| Rpc.Types.Option _ -> true
348
+
| _ -> false
349
+
in
350
+
(match get_arg call has_named t.Param.name is_opt with
351
+
| Ok (x, y) -> M.return (x, y)
352
+
| Error (`Msg m) -> M.fail (MarshalError m))
353
+
>>= fun (arg_rpc, call') ->
354
+
let z =
355
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc
356
+
in
357
+
match z with
358
+
| Ok arg -> inner f (impl arg) call'
359
+
| Error (`Msg m) -> M.fail (MarshalError m))
360
+
| Returning (t, e) ->
361
+
T.bind impl (function
362
+
| Ok x ->
363
+
let res =
364
+
Rpc.success
365
+
(Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty x)
366
+
in
367
+
M.return { res with is_notification }
368
+
| Error y ->
369
+
let res =
370
+
Rpc.failure
371
+
(Rpcmarshal.marshal e.Error.def.Rpc.Types.ty y)
372
+
in
373
+
M.return { res with is_notification })
374
+
|> T.get
375
+
in
376
+
inner ty impl
377
+
in
378
+
Hashtbl.remove funcs name;
379
+
(* The wire name might be different from the name *)
380
+
let wire_name = get_wire_name !description name in
381
+
Hashtbl.add funcs wire_name (Some rpcfn)
382
+
383
+
let declare_notification name a ty = declare_ true name a ty
384
+
let declare name a ty = declare_ false name a ty
385
+
end
386
+
end
387
+
388
+
module ExnM = struct
389
+
type 'a t = V of 'a | E of exn
390
+
391
+
let return x = V x
392
+
let lift f x = match f x with y -> V y | exception e -> E e
393
+
let bind x (f : 'a -> 'b t) : 'b t = match x with V x -> f x | E e -> E e
394
+
let ( >>= ) = bind
395
+
let fail e = E e
396
+
let run = function V x -> x | E e -> raise e
397
+
end
398
+
399
+
module IdM = struct
400
+
type 'a t = T of 'a
401
+
402
+
let return x = T x
403
+
let lift f x = T (f x)
404
+
let bind (T x) f = f x
405
+
let ( >>= ) = bind
406
+
let fail e = raise e
407
+
let run (T x) = x
408
+
end
409
+
410
+
(* A default error variant as an example. In real code, this is more easily expressed by using the PPX:
411
+
type default_error = InternalError of string [@@deriving rpcty]
412
+
*)
413
+
module DefaultError = struct
414
+
type t = InternalError of string
415
+
416
+
exception InternalErrorExn of string
417
+
418
+
let internalerror : (string, t) Rpc.Types.tag =
419
+
let open Rpc.Types in
420
+
{
421
+
tname = "InternalError";
422
+
tdescription = [ "Internal Error" ];
423
+
tversion = Some (1, 0, 0);
424
+
tcontents = Basic String;
425
+
tpreview = (function InternalError s -> Some s);
426
+
treview = (fun s -> InternalError s);
427
+
}
428
+
429
+
(* And then we can create the 'variant' type *)
430
+
let t : t Rpc.Types.variant =
431
+
let open Rpc.Types in
432
+
{
433
+
vname = "t";
434
+
variants = [ BoxedTag internalerror ];
435
+
vversion = Some (1, 0, 0);
436
+
vdefault = Some (InternalError "Unknown error tag!");
437
+
vconstructor =
438
+
(fun s t ->
439
+
match s with
440
+
| "InternalError" -> (
441
+
match t.tget (Basic String) with
442
+
| Ok s -> Ok (internalerror.treview s)
443
+
| Error y -> Error y)
444
+
| s -> Error (`Msg (Printf.sprintf "Unknown tag '%s'" s)));
445
+
}
446
+
447
+
let def =
448
+
let open Rpc.Types in
449
+
{
450
+
name = "default_error";
451
+
description = [ "Errors declared as part of the interface" ];
452
+
ty = Variant t;
453
+
}
454
+
455
+
let err =
456
+
let open Error in
457
+
{
458
+
def;
459
+
raiser = (function InternalError s -> raise (InternalErrorExn s));
460
+
matcher =
461
+
(function InternalErrorExn s -> Some (InternalError s) | _ -> None);
462
+
}
463
+
end
464
+
465
+
module Exn = struct
466
+
type rpcfn = Rpc.call -> Rpc.response
467
+
type client_implementation = unit
468
+
type server_implementation = (string, rpcfn option) Hashtbl.t
469
+
470
+
module GenClient (R : sig
471
+
val rpc : rpcfn
472
+
end) =
473
+
struct
474
+
type implementation = client_implementation
475
+
type ('a, 'b) comp = 'a
476
+
type 'a res = 'a
477
+
478
+
type _ fn =
479
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
480
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn
481
+
482
+
let description = ref None
483
+
484
+
let implement x =
485
+
description := Some x;
486
+
()
487
+
488
+
let returning a err = Returning (a, err)
489
+
let ( @-> ) t f = Function (t, f)
490
+
491
+
let declare_ is_notification name _ ty =
492
+
let rec inner :
493
+
type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
494
+
fun (named, unnamed) -> function
495
+
| Function (t, f) -> (
496
+
let cur_named = match named with Some l -> l | None -> [] in
497
+
fun v ->
498
+
match t.Param.name with
499
+
| Some n -> (
500
+
match (t.Param.typedef.Rpc.Types.ty, v) with
501
+
| Rpc.Types.Option ty, Some v' ->
502
+
let marshalled = Rpcmarshal.marshal ty v' in
503
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f
504
+
| Rpc.Types.Option _ty, None ->
505
+
inner (Some cur_named, unnamed) f
506
+
| ty, v ->
507
+
let marshalled = Rpcmarshal.marshal ty v in
508
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
509
+
| None ->
510
+
let marshalled =
511
+
Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v
512
+
in
513
+
inner (named, marshalled :: unnamed) f)
514
+
| Returning (t, e) -> (
515
+
let wire_name = get_wire_name !description name in
516
+
let args =
517
+
match named with
518
+
| None -> List.rev unnamed
519
+
| Some l -> Rpc.Dict l :: List.rev unnamed
520
+
in
521
+
let call' = Rpc.call wire_name args in
522
+
let call = { call' with is_notification } in
523
+
let r = R.rpc call in
524
+
if r.Rpc.success then
525
+
match
526
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty r.Rpc.contents
527
+
with
528
+
| Ok x -> x
529
+
| Error (`Msg x) -> raise (MarshalError x)
530
+
else
531
+
match
532
+
Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty r.Rpc.contents
533
+
with
534
+
| Ok x -> raise (e.Error.raiser x)
535
+
| Error (`Msg x) -> raise (MarshalError x))
536
+
in
537
+
inner (None, []) ty
538
+
539
+
let declare name a ty = declare_ false name a ty
540
+
let declare_notification name a ty = declare_ true name a ty
541
+
end
542
+
543
+
let server hashtbl =
544
+
let impl = Hashtbl.create (Hashtbl.length hashtbl) in
545
+
let unbound_impls =
546
+
Hashtbl.fold
547
+
(fun key fn acc ->
548
+
match fn with
549
+
| None -> key :: acc
550
+
| Some fn ->
551
+
Hashtbl.add impl key fn;
552
+
acc)
553
+
hashtbl []
554
+
in
555
+
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
556
+
fun call ->
557
+
let fn =
558
+
try Hashtbl.find impl call.Rpc.name
559
+
with Not_found ->
560
+
!logfn "2";
561
+
Hashtbl.iter (fun key _ -> !logfn ("method: " ^ key)) impl;
562
+
!logfn (Printf.sprintf "Unknown method: %s" call.Rpc.name);
563
+
raise (UnknownMethod call.Rpc.name)
564
+
in
565
+
fn call
566
+
567
+
let combine hashtbls =
568
+
let result = Hashtbl.create 16 in
569
+
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
570
+
result
571
+
572
+
module GenServer () = struct
573
+
type implementation = server_implementation
574
+
type ('a, 'b) comp = 'a
575
+
type 'a res = 'a -> unit
576
+
577
+
type _ fn =
578
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
579
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn
580
+
581
+
let funcs = Hashtbl.create 20
582
+
let description = ref None
583
+
584
+
let implement x =
585
+
description := Some x;
586
+
funcs
587
+
588
+
let returning a b = Returning (a, b)
589
+
let ( @-> ) t f = Function (t, f)
590
+
591
+
type boxed_error = BoxedError : 'a Error.t -> boxed_error
592
+
593
+
let rec get_error_ty : type a. a fn -> boxed_error = function
594
+
| Function (_, f) -> get_error_ty f
595
+
| Returning (_, e) -> BoxedError e
596
+
597
+
let rec has_named_args : type a. a fn -> bool = function
598
+
| Function (t, f) -> (
599
+
match t.Param.name with Some _ -> true | None -> has_named_args f)
600
+
| Returning (_, _) -> false
601
+
602
+
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
603
+
fun is_notification name _ ty ->
604
+
(* We do not know the wire name yet as the description may still be unset *)
605
+
Hashtbl.add funcs name None;
606
+
fun impl ->
607
+
(* Sanity check: ensure the description has been set before we declare
608
+
any RPCs *)
609
+
(match !description with Some _ -> () | None -> raise NoDescription);
610
+
let rpcfn =
611
+
let has_named = has_named_args ty in
612
+
let rec inner : type a. a fn -> a -> Rpc.call -> Rpc.response =
613
+
fun f impl call ->
614
+
try
615
+
match f with
616
+
| Function (t, f) ->
617
+
let is_opt =
618
+
match t.Param.typedef.Rpc.Types.ty with
619
+
| Rpc.Types.Option _ -> true
620
+
| _ -> false
621
+
in
622
+
let arg_rpc, call' =
623
+
match get_arg call has_named t.Param.name is_opt with
624
+
| Ok (x, y) -> (x, y)
625
+
| Error (`Msg m) -> raise (MarshalError m)
626
+
in
627
+
let z =
628
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc
629
+
in
630
+
let arg =
631
+
match z with
632
+
| Ok arg -> arg
633
+
| Error (`Msg m) -> raise (MarshalError m)
634
+
in
635
+
inner f (impl arg) call'
636
+
| Returning (t, _) ->
637
+
let call =
638
+
Rpc.success
639
+
(Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty impl)
640
+
in
641
+
{ call with is_notification }
642
+
with e -> (
643
+
let (BoxedError error_ty) = get_error_ty f in
644
+
match error_ty.Error.matcher e with
645
+
| Some y ->
646
+
Rpc.failure
647
+
(Rpcmarshal.marshal error_ty.Error.def.Rpc.Types.ty y)
648
+
| None -> raise e)
649
+
in
650
+
inner ty impl
651
+
in
652
+
Hashtbl.remove funcs name;
653
+
(* The wire name might be different from the name *)
654
+
let wire_name = get_wire_name !description name in
655
+
Hashtbl.add funcs wire_name (Some rpcfn)
656
+
657
+
let declare name a ty = declare_ true name a ty
658
+
let declare_notification name a ty = declare_ false name a ty
659
+
end
660
+
end
+312
js_top_worker/idl/_old/jsonrpc.ml
+312
js_top_worker/idl/_old/jsonrpc.ml
···
1
+
(*
2
+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3
+
* Copyright (c) 2006-2014 Thomas Gazagnaire <thomas@gazagnaire.org>
4
+
*
5
+
* Permission to use, copy, modify, and distribute this software for any
6
+
* purpose with or without fee is hereby granted, provided that the above
7
+
* copyright notice and this permission notice appear in all copies.
8
+
*
9
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
+
*)
17
+
18
+
open Rpc
19
+
20
+
module Yojson_private = struct
21
+
include Yojson.Safe
22
+
23
+
let from_string ?(strict = true) ?buf ?fname ?lnum s =
24
+
let open Yojson in
25
+
try
26
+
let lexbuf = Lexing.from_string s in
27
+
let v = init_lexer ?buf ?fname ?lnum () in
28
+
if strict then from_lexbuf v lexbuf else from_lexbuf v ~stream:true lexbuf
29
+
with End_of_input -> json_error "Blank input data"
30
+
end
31
+
32
+
module Y = Yojson_private
33
+
module U = Yojson.Basic.Util
34
+
35
+
type version = V1 | V2
36
+
37
+
let rec rpc_to_json t =
38
+
match t with
39
+
| Int i -> `Intlit (Int64.to_string i)
40
+
| Int32 i -> `Int (Int32.to_int i)
41
+
| Bool b -> `Bool b
42
+
| Float r -> `Float r
43
+
| String s -> `String s
44
+
| DateTime d -> `String d
45
+
| Base64 b -> `String b
46
+
| Null -> `Null
47
+
| Enum a -> `List (Rpcmarshal.tailrec_map rpc_to_json a)
48
+
| Dict a ->
49
+
`Assoc (Rpcmarshal.tailrec_map (fun (k, v) -> (k, rpc_to_json v)) a)
50
+
51
+
exception JsonToRpcError of Y.t
52
+
53
+
let rec json_to_rpc t =
54
+
match t with
55
+
| `Intlit i -> Int (Int64.of_string i)
56
+
| `Int i -> Int (Int64.of_int i)
57
+
| `Bool b -> Bool b
58
+
| `Float r -> Float r
59
+
| `String s -> (* TODO: check if it is a DateTime *) String s
60
+
(* | DateTime d -> `String d *)
61
+
(* | Base64 b -> `String b *)
62
+
| `Null -> Null
63
+
| `List a -> Enum (Rpcmarshal.tailrec_map json_to_rpc a)
64
+
| `Assoc a ->
65
+
Dict (Rpcmarshal.tailrec_map (fun (k, v) -> (k, json_to_rpc v)) a)
66
+
| unsupported -> raise (JsonToRpcError unsupported)
67
+
68
+
let to_fct t f = rpc_to_json t |> Y.to_string |> f
69
+
let to_buffer t buf = to_fct t (fun s -> Buffer.add_string buf s)
70
+
let to_string t = rpc_to_json t |> Y.to_string
71
+
72
+
let to_a ~empty ~append t =
73
+
let buf = empty () in
74
+
to_fct t (fun s -> append buf s);
75
+
buf
76
+
77
+
let new_id =
78
+
let count = ref 0L in
79
+
fun () ->
80
+
count := Int64.add 1L !count;
81
+
!count
82
+
83
+
let string_of_call ?(version = V1) call =
84
+
let json =
85
+
match version with
86
+
| V1 -> [ ("method", String call.name); ("params", Enum call.params) ]
87
+
| V2 ->
88
+
let params =
89
+
match call.params with [ Dict x ] -> Dict x | _ -> Enum call.params
90
+
in
91
+
[
92
+
("jsonrpc", String "2.0");
93
+
("method", String call.name);
94
+
("params", params);
95
+
]
96
+
in
97
+
let json =
98
+
if not call.is_notification then json @ [ ("id", Int (new_id ())) ]
99
+
else json
100
+
in
101
+
to_string (Dict json)
102
+
103
+
let json_of_response ?(id = Int 0L) version response =
104
+
if response.Rpc.success then
105
+
match version with
106
+
| V1 ->
107
+
Dict [ ("result", response.Rpc.contents); ("error", Null); ("id", id) ]
108
+
| V2 ->
109
+
Dict
110
+
[
111
+
("jsonrpc", String "2.0");
112
+
("result", response.Rpc.contents);
113
+
("id", id);
114
+
]
115
+
else
116
+
match version with
117
+
| V1 ->
118
+
Dict [ ("result", Null); ("error", response.Rpc.contents); ("id", id) ]
119
+
| V2 ->
120
+
Dict
121
+
[
122
+
("jsonrpc", String "2.0");
123
+
("error", response.Rpc.contents);
124
+
("id", id);
125
+
]
126
+
127
+
let json_of_error_object ?(data = None) code message =
128
+
let data_json = match data with Some d -> [ ("data", d) ] | None -> [] in
129
+
Dict ([ ("code", Int code); ("message", String message) ] @ data_json)
130
+
131
+
let string_of_response ?(id = Int 0L) ?(version = V1) response =
132
+
let json = json_of_response ~id version response in
133
+
to_string json
134
+
135
+
let a_of_response ?(id = Int 0L) ?(version = V1) ~empty ~append response =
136
+
let json = json_of_response ~id version response in
137
+
to_a ~empty ~append json
138
+
139
+
let of_string ?(strict = true) s = s |> Y.from_string ~strict |> json_to_rpc
140
+
141
+
let of_a ~next_char b =
142
+
let buf = Buffer.create 2048 in
143
+
let rec acc () =
144
+
match next_char b with
145
+
| Some c ->
146
+
Buffer.add_char buf c;
147
+
acc ()
148
+
| None -> ()
149
+
in
150
+
acc ();
151
+
Buffer.contents buf |> of_string
152
+
153
+
let get' name dict = try Some (List.assoc name dict) with Not_found -> None
154
+
155
+
exception Malformed_method_request of string
156
+
exception Malformed_method_response of string
157
+
exception Missing_field of string
158
+
159
+
let get name dict =
160
+
match get' name dict with
161
+
| None ->
162
+
if Rpc.get_debug () then
163
+
Printf.eprintf "%s was not found in the dictionary\n" name;
164
+
raise (Missing_field name)
165
+
| Some v -> v
166
+
167
+
let version_id_and_call_of_string_option str =
168
+
try
169
+
match of_string str with
170
+
| Dict d ->
171
+
let name =
172
+
match get "method" d with
173
+
| String s -> s
174
+
| _ ->
175
+
raise
176
+
(Malformed_method_request
177
+
"Invalid field 'method' in request body")
178
+
in
179
+
let version =
180
+
match get' "jsonrpc" d with
181
+
| None -> V1
182
+
| Some (String "2.0") -> V2
183
+
| _ ->
184
+
raise
185
+
(Malformed_method_request
186
+
"Invalid field 'jsonrpc' in request body")
187
+
in
188
+
let params =
189
+
match version with
190
+
| V1 -> (
191
+
match get "params" d with
192
+
| Enum l -> l
193
+
| _ ->
194
+
raise
195
+
(Malformed_method_request
196
+
"Invalid field 'params' in request body"))
197
+
| V2 -> (
198
+
match get' "params" d with
199
+
| None | Some Null -> []
200
+
| Some (Enum l) -> l
201
+
| Some (Dict l) -> [ Dict l ]
202
+
| _ ->
203
+
raise
204
+
(Malformed_method_request
205
+
"Invalid field 'params' in request body"))
206
+
in
207
+
let id =
208
+
match get' "id" d with
209
+
| None | Some Null -> None (* is a notification *)
210
+
| Some (Int a) -> Some (Int a)
211
+
| Some (String a) -> Some (String a)
212
+
| Some _ ->
213
+
raise
214
+
(Malformed_method_request "Invalid field 'id' in request body")
215
+
in
216
+
let c = call name params in
217
+
(version, id, { c with is_notification = id == None })
218
+
| _ -> raise (Malformed_method_request "Invalid request body")
219
+
with
220
+
| Missing_field field ->
221
+
raise
222
+
(Malformed_method_request
223
+
(Printf.sprintf "Required field %s is missing" field))
224
+
| JsonToRpcError json ->
225
+
raise
226
+
(Malformed_method_request
227
+
(Printf.sprintf "Unable to parse %s" (Y.to_string json)))
228
+
229
+
let version_id_and_call_of_string s =
230
+
let version, id_, call = version_id_and_call_of_string_option s in
231
+
match id_ with
232
+
| Some id -> (version, id, call)
233
+
| None ->
234
+
raise (Malformed_method_request "Invalid field 'id' in request body")
235
+
236
+
let call_of_string str =
237
+
let _, _, call = version_id_and_call_of_string str in
238
+
call
239
+
240
+
(* This functions parses the json and tries to extract a valid jsonrpc response
241
+
* (See http://www.jsonrpc.org/ for the exact specs). *)
242
+
let get_response extractor str =
243
+
try
244
+
match extractor str with
245
+
| Dict d -> (
246
+
let _ =
247
+
match get "id" d with
248
+
| Int _ as x -> x
249
+
| String _ as y -> y
250
+
| _ -> raise (Malformed_method_response "id")
251
+
in
252
+
match get' "jsonrpc" d with
253
+
| None -> (
254
+
let result = get "result" d in
255
+
let error = get "error" d in
256
+
match (result, error) with
257
+
| v, Null -> success v
258
+
| Null, v -> failure v
259
+
| x, y ->
260
+
raise
261
+
(Malformed_method_response
262
+
(Printf.sprintf "<result=%s><error=%s>" (Rpc.to_string x)
263
+
(Rpc.to_string y))))
264
+
| Some (String "2.0") -> (
265
+
let result = get' "result" d in
266
+
let error = get' "error" d in
267
+
match (result, error) with
268
+
| Some v, None -> success v
269
+
| None, Some v -> (
270
+
match v with
271
+
| Dict err ->
272
+
let (_ : int64) =
273
+
match get "code" err with
274
+
| Int i -> i
275
+
| _ -> raise (Malformed_method_response "Error code")
276
+
in
277
+
let _ =
278
+
match get "message" err with
279
+
| String s -> s
280
+
| _ -> raise (Malformed_method_response "Error message")
281
+
in
282
+
failure v
283
+
| _ -> raise (Malformed_method_response "Error object"))
284
+
| Some x, Some y ->
285
+
raise
286
+
(Malformed_method_response
287
+
(Printf.sprintf "<result=%s><error=%s>" (Rpc.to_string x)
288
+
(Rpc.to_string y)))
289
+
| None, None ->
290
+
raise
291
+
(Malformed_method_response
292
+
(Printf.sprintf "neither <result> nor <error> was found")))
293
+
| _ -> raise (Malformed_method_response "jsonrpc"))
294
+
| rpc ->
295
+
raise
296
+
(Malformed_method_response
297
+
(Printf.sprintf "<response_of_stream(%s)>" (to_string rpc)))
298
+
with
299
+
| Missing_field field ->
300
+
raise
301
+
(Malformed_method_response (Printf.sprintf "<%s was not found>" field))
302
+
| JsonToRpcError json ->
303
+
raise
304
+
(Malformed_method_response
305
+
(Printf.sprintf "<unable to parse %s>" (Y.to_string json)))
306
+
307
+
let response_of_string ?(strict = true) str =
308
+
get_response (of_string ~strict) str
309
+
310
+
let response_of_in_channel channel =
311
+
let of_channel s = s |> Y.from_channel |> json_to_rpc in
312
+
get_response of_channel channel
+343
js_top_worker/idl/_old/rpc.ml
+343
js_top_worker/idl/_old/rpc.ml
···
1
+
(*
2
+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3
+
* Copyright (c) 2006-2014 Thomas Gazagnaire <thomas@gazagnaire.org>
4
+
*
5
+
* Permission to use, copy, modify, and distribute this software for any
6
+
* purpose with or without fee is hereby granted, provided that the above
7
+
* copyright notice and this permission notice appear in all copies.
8
+
*
9
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
+
*)
17
+
18
+
let debug = ref false
19
+
let set_debug x = debug := x
20
+
let get_debug () = !debug
21
+
22
+
type msg = [ `Msg of string ]
23
+
24
+
type t =
25
+
| Int of int64
26
+
| Int32 of int32
27
+
| Bool of bool
28
+
| Float of float
29
+
| String of string
30
+
| DateTime of string
31
+
| Enum of t list
32
+
| Dict of (string * t) list
33
+
| Base64 of string
34
+
| Null
35
+
36
+
module Version = struct
37
+
type t = int * int * int
38
+
39
+
let compare (x, y, z) (x', y', z') =
40
+
let cmp a b fn () =
41
+
let c = compare a b in
42
+
if c <> 0 then c else fn ()
43
+
in
44
+
cmp x x' (cmp y y' (cmp z z' (fun () -> 0))) ()
45
+
end
46
+
47
+
module Types = struct
48
+
type _ basic =
49
+
| Int : int basic
50
+
| Int32 : int32 basic
51
+
| Int64 : int64 basic
52
+
| Bool : bool basic
53
+
| Float : float basic
54
+
| String : string basic
55
+
| Char : char basic
56
+
57
+
type _ typ =
58
+
| Basic : 'a basic -> 'a typ
59
+
| DateTime : string typ
60
+
| Base64 : string typ
61
+
| Array : 'a typ -> 'a array typ
62
+
| List : 'a typ -> 'a list typ
63
+
| Dict : 'a basic * 'b typ -> ('a * 'b) list typ
64
+
| Unit : unit typ
65
+
| Option : 'a typ -> 'a option typ
66
+
| Tuple : 'a typ * 'b typ -> ('a * 'b) typ
67
+
| Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ
68
+
| Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ
69
+
| Struct : 'a structure -> 'a typ
70
+
| Variant : 'a variant -> 'a typ
71
+
| Abstract : 'a abstract -> 'a typ
72
+
73
+
(* A type definition has a name and description *)
74
+
and 'a def = { name : string; description : string list; ty : 'a typ }
75
+
and boxed_def = BoxedDef : 'a def -> boxed_def
76
+
77
+
and ('a, 's) field = {
78
+
fname : string;
79
+
fdescription : string list;
80
+
fversion : Version.t option;
81
+
field : 'a typ;
82
+
fdefault : 'a option;
83
+
fget : 's -> 'a;
84
+
(* Lenses *)
85
+
fset : 'a -> 's -> 's;
86
+
}
87
+
88
+
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
89
+
and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result }
90
+
91
+
and 'a structure = {
92
+
sname : string;
93
+
fields : 'a boxed_field list;
94
+
version : Version.t option;
95
+
constructor : field_getter -> ('a, msg) result;
96
+
}
97
+
98
+
and ('a, 's) tag = {
99
+
tname : string;
100
+
tdescription : string list;
101
+
tversion : Version.t option;
102
+
tcontents : 'a typ;
103
+
tpreview : 's -> 'a option;
104
+
treview : 'a -> 's;
105
+
}
106
+
107
+
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
108
+
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
109
+
110
+
and 'a variant = {
111
+
vname : string;
112
+
variants : 'a boxed_tag list;
113
+
vdefault : 'a option;
114
+
vversion : Version.t option;
115
+
vconstructor : string -> tag_getter -> ('a, msg) result;
116
+
}
117
+
118
+
and 'a abstract = {
119
+
aname : string;
120
+
test_data : 'a list;
121
+
rpc_of : 'a -> t;
122
+
of_rpc : t -> ('a, msg) result;
123
+
}
124
+
125
+
let int = { name = "int"; ty = Basic Int; description = [ "Native integer" ] }
126
+
127
+
let int32 =
128
+
{ name = "int32"; ty = Basic Int32; description = [ "32-bit integer" ] }
129
+
130
+
let int64 =
131
+
{ name = "int64"; ty = Basic Int64; description = [ "64-bit integer" ] }
132
+
133
+
let bool = { name = "bool"; ty = Basic Bool; description = [ "Boolean" ] }
134
+
135
+
let float =
136
+
{
137
+
name = "float";
138
+
ty = Basic Float;
139
+
description = [ "Floating-point number" ];
140
+
}
141
+
142
+
let string =
143
+
{ name = "string"; ty = Basic String; description = [ "String" ] }
144
+
145
+
let char = { name = "char"; ty = Basic Char; description = [ "Char" ] }
146
+
let unit = { name = "unit"; ty = Unit; description = [ "Unit" ] }
147
+
148
+
let default_types =
149
+
[
150
+
BoxedDef int;
151
+
BoxedDef int32;
152
+
BoxedDef int64;
153
+
BoxedDef bool;
154
+
BoxedDef float;
155
+
BoxedDef string;
156
+
BoxedDef char;
157
+
BoxedDef unit;
158
+
]
159
+
end
160
+
161
+
exception Runtime_error of string * t
162
+
exception Runtime_exception of string * string
163
+
164
+
let map_strings sep fn l = String.concat sep (List.map fn l)
165
+
166
+
let rec to_string t =
167
+
let open Printf in
168
+
match t with
169
+
| Int i -> sprintf "I(%Li)" i
170
+
| Int32 i -> sprintf "I32(%li)" i
171
+
| Bool b -> sprintf "B(%b)" b
172
+
| Float f -> sprintf "F(%g)" f
173
+
| String s -> sprintf "S(%s)" s
174
+
| DateTime s -> sprintf "D(%s)" s
175
+
| Enum ts -> sprintf "[%s]" (map_strings ";" to_string ts)
176
+
| Dict ts ->
177
+
sprintf "{%s}"
178
+
(map_strings ";" (fun (s, t) -> sprintf "%s:%s" s (to_string t)) ts)
179
+
| Base64 s -> sprintf "B64(%s)" s
180
+
| Null -> "N"
181
+
182
+
let rpc_of_t x = x
183
+
let rpc_of_int64 i = Int i
184
+
let rpc_of_int32 i = Int (Int64.of_int32 i)
185
+
let rpc_of_int i = Int (Int64.of_int i)
186
+
let rpc_of_bool b = Bool b
187
+
let rpc_of_float f = Float f
188
+
let rpc_of_string s = String s
189
+
let rpc_of_dateTime s = DateTime s
190
+
let rpc_of_base64 s = Base64 s
191
+
let rpc_of_unit () = Null
192
+
let rpc_of_char x = Int (Int64.of_int (Char.code x))
193
+
194
+
let int64_of_rpc = function
195
+
| Int i -> i
196
+
| String s -> Int64.of_string s
197
+
| x -> failwith (Printf.sprintf "Expected int64, got '%s'" (to_string x))
198
+
199
+
let int32_of_rpc = function
200
+
| Int i -> Int64.to_int32 i
201
+
| String s -> Int32.of_string s
202
+
| x -> failwith (Printf.sprintf "Expected int32, got '%s'" (to_string x))
203
+
204
+
let int_of_rpc = function
205
+
| Int i -> Int64.to_int i
206
+
| String s -> int_of_string s
207
+
| x -> failwith (Printf.sprintf "Expected int, got '%s'" (to_string x))
208
+
209
+
let bool_of_rpc = function
210
+
| Bool b -> b
211
+
| x -> failwith (Printf.sprintf "Expected bool, got '%s'" (to_string x))
212
+
213
+
let float_of_rpc = function
214
+
| Float f -> f
215
+
| Int i -> Int64.to_float i
216
+
| Int32 i -> Int32.to_float i
217
+
| String s -> float_of_string s
218
+
| x -> failwith (Printf.sprintf "Expected float, got '%s'" (to_string x))
219
+
220
+
let string_of_rpc = function
221
+
| String s -> s
222
+
| x -> failwith (Printf.sprintf "Expected string, got '%s'" (to_string x))
223
+
224
+
let dateTime_of_rpc = function
225
+
| DateTime s -> s
226
+
| x -> failwith (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
227
+
228
+
let base64_of_rpc = function _ -> failwith "Base64 Unhandled"
229
+
230
+
let unit_of_rpc = function
231
+
| Null -> ()
232
+
| x -> failwith (Printf.sprintf "Expected unit, got '%s'" (to_string x))
233
+
234
+
let char_of_rpc x =
235
+
let x = int_of_rpc x in
236
+
if x < 0 || x > 255 then failwith (Printf.sprintf "Char out of range (%d)" x)
237
+
else Char.chr x
238
+
239
+
let t_of_rpc t = t
240
+
241
+
let lowerfn = function
242
+
| String s -> String (String.lowercase_ascii s)
243
+
| Enum (String s :: ss) -> Enum (String (String.lowercase_ascii s) :: ss)
244
+
| x -> x
245
+
246
+
module ResultUnmarshallers = struct
247
+
let error_msg m = Error (`Msg m)
248
+
let ok x = Ok x
249
+
250
+
let int64_of_rpc = function
251
+
| Int i -> ok i
252
+
| String s -> (
253
+
try ok (Int64.of_string s)
254
+
with _ ->
255
+
error_msg (Printf.sprintf "Expected int64, got string '%s'" s))
256
+
| x -> error_msg (Printf.sprintf "Expected int64, got '%s'" (to_string x))
257
+
258
+
let int32_of_rpc = function
259
+
| Int i -> ok (Int64.to_int32 i)
260
+
| String s -> (
261
+
try ok (Int32.of_string s)
262
+
with _ ->
263
+
error_msg (Printf.sprintf "Expected int32, got string '%s'" s))
264
+
| x -> error_msg (Printf.sprintf "Expected int32, got '%s'" (to_string x))
265
+
266
+
let int_of_rpc = function
267
+
| Int i -> ok (Int64.to_int i)
268
+
| String s -> (
269
+
try ok (int_of_string s)
270
+
with _ -> error_msg (Printf.sprintf "Expected int, got string '%s'" s))
271
+
| x -> error_msg (Printf.sprintf "Expected int, got '%s'" (to_string x))
272
+
273
+
let bool_of_rpc = function
274
+
| Bool b -> ok b
275
+
| x -> error_msg (Printf.sprintf "Expected bool, got '%s'" (to_string x))
276
+
277
+
let float_of_rpc = function
278
+
| Float f -> ok f
279
+
| Int i -> ok (Int64.to_float i)
280
+
| Int32 i -> ok (Int32.to_float i)
281
+
| String s -> (
282
+
try ok (float_of_string s)
283
+
with _ ->
284
+
error_msg (Printf.sprintf "Expected float, got string '%s'" s))
285
+
| x -> error_msg (Printf.sprintf "Expected float, got '%s'" (to_string x))
286
+
287
+
let string_of_rpc = function
288
+
| String s -> ok s
289
+
| x -> error_msg (Printf.sprintf "Expected string, got '%s'" (to_string x))
290
+
291
+
let dateTime_of_rpc = function
292
+
| DateTime s -> ok s
293
+
| x ->
294
+
error_msg (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
295
+
296
+
let base64_of_rpc = function _ -> error_msg "Base64 Unhandled"
297
+
298
+
let unit_of_rpc = function
299
+
| Null -> ok ()
300
+
| x -> error_msg (Printf.sprintf "Expected unit, got '%s'" (to_string x))
301
+
302
+
let char_of_rpc x =
303
+
match int_of_rpc x with
304
+
| Ok x ->
305
+
if x < 0 || x > 255 then
306
+
error_msg (Printf.sprintf "Char out of range (%d)" x)
307
+
else ok (Char.chr x)
308
+
| Error y -> Error y
309
+
310
+
let t_of_rpc t = ok t
311
+
end
312
+
313
+
let struct_extend rpc default_rpc =
314
+
match (rpc, default_rpc) with
315
+
| Dict real, Dict default_fields ->
316
+
Dict
317
+
(List.fold_left
318
+
(fun real (f, default) ->
319
+
if List.mem_assoc f real then real else (f, default) :: real)
320
+
real default_fields)
321
+
| _, _ -> rpc
322
+
323
+
type callback = string list -> t -> unit
324
+
type call = { name : string; params : t list; is_notification : bool }
325
+
326
+
let call name params = { name; params; is_notification = false }
327
+
let notification name params = { name; params; is_notification = true }
328
+
329
+
let string_of_call call =
330
+
Printf.sprintf "-> %s(%s)" call.name
331
+
(String.concat "," (List.map to_string call.params))
332
+
333
+
type response = { success : bool; contents : t; is_notification : bool }
334
+
335
+
let string_of_response response =
336
+
Printf.sprintf "<- %s(%s)"
337
+
(if response.success then "success" else "failure")
338
+
(to_string response.contents)
339
+
340
+
(* is_notification is to be set as true only if the call was a notification *)
341
+
342
+
let success v = { success = true; contents = v; is_notification = false }
343
+
let failure v = { success = false; contents = v; is_notification = false }
+203
js_top_worker/idl/_old/rpc.mli
+203
js_top_worker/idl/_old/rpc.mli
···
1
+
(*
2
+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3
+
* Copyright (c) 2006-2014 Thomas Gazagnaire <thomas@gazagnaire.org>
4
+
*
5
+
* Permission to use, copy, modify, and distribute this software for any
6
+
* purpose with or without fee is hereby granted, provided that the above
7
+
* copyright notice and this permission notice appear in all copies.
8
+
*
9
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
+
*)
17
+
18
+
type msg = [ `Msg of string ]
19
+
(** {2 Value} *)
20
+
21
+
type t =
22
+
| Int of int64
23
+
| Int32 of int32
24
+
| Bool of bool
25
+
| Float of float
26
+
| String of string
27
+
| DateTime of string
28
+
| Enum of t list
29
+
| Dict of (string * t) list
30
+
| Base64 of string
31
+
| Null
32
+
33
+
val to_string : t -> string
34
+
35
+
module Version : sig
36
+
type t = int * int * int
37
+
38
+
val compare : t -> t -> int
39
+
end
40
+
41
+
(** {2 Type declarations} *)
42
+
module Types : sig
43
+
type _ basic =
44
+
| Int : int basic
45
+
| Int32 : int32 basic
46
+
| Int64 : int64 basic
47
+
| Bool : bool basic
48
+
| Float : float basic
49
+
| String : string basic
50
+
| Char : char basic
51
+
52
+
type _ typ =
53
+
| Basic : 'a basic -> 'a typ
54
+
| DateTime : string typ
55
+
| Base64 : string typ
56
+
| Array : 'a typ -> 'a array typ
57
+
| List : 'a typ -> 'a list typ
58
+
| Dict : 'a basic * 'b typ -> ('a * 'b) list typ
59
+
| Unit : unit typ
60
+
| Option : 'a typ -> 'a option typ
61
+
| Tuple : 'a typ * 'b typ -> ('a * 'b) typ
62
+
| Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ
63
+
| Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ
64
+
| Struct : 'a structure -> 'a typ
65
+
| Variant : 'a variant -> 'a typ
66
+
| Abstract : 'a abstract -> 'a typ
67
+
68
+
and 'a def = { name : string; description : string list; ty : 'a typ }
69
+
and boxed_def = BoxedDef : 'a def -> boxed_def
70
+
71
+
and ('a, 's) field = {
72
+
fname : string;
73
+
fdescription : string list;
74
+
fversion : Version.t option;
75
+
field : 'a typ;
76
+
fdefault : 'a option;
77
+
fget : 's -> 'a;
78
+
fset : 'a -> 's -> 's;
79
+
}
80
+
81
+
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
82
+
and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result }
83
+
84
+
and 'a structure = {
85
+
sname : string;
86
+
fields : 'a boxed_field list;
87
+
version : Version.t option;
88
+
constructor : field_getter -> ('a, msg) result;
89
+
}
90
+
91
+
and ('a, 's) tag = {
92
+
tname : string;
93
+
tdescription : string list;
94
+
tversion : Version.t option;
95
+
tcontents : 'a typ;
96
+
tpreview : 's -> 'a option;
97
+
(* Prism *)
98
+
treview : 'a -> 's;
99
+
}
100
+
101
+
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
102
+
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
103
+
104
+
and 'a variant = {
105
+
vname : string;
106
+
variants : 'a boxed_tag list;
107
+
vdefault : 'a option;
108
+
vversion : Version.t option;
109
+
vconstructor : string -> tag_getter -> ('a, msg) result;
110
+
}
111
+
112
+
and 'a abstract = {
113
+
aname : string;
114
+
test_data : 'a list;
115
+
rpc_of : 'a -> t;
116
+
of_rpc : t -> ('a, msg) result;
117
+
}
118
+
119
+
val int : int def
120
+
val int32 : int32 def
121
+
val int64 : int64 def
122
+
val bool : bool def
123
+
val float : float def
124
+
val string : string def
125
+
val char : char def
126
+
val unit : unit def
127
+
val default_types : boxed_def list
128
+
end
129
+
130
+
(** {2 Basic constructors} *)
131
+
132
+
val rpc_of_int64 : int64 -> t
133
+
val rpc_of_int32 : int32 -> t
134
+
val rpc_of_int : int -> t
135
+
val rpc_of_bool : bool -> t
136
+
val rpc_of_float : float -> t
137
+
val rpc_of_string : string -> t
138
+
val rpc_of_dateTime : string -> t
139
+
val rpc_of_base64 : string -> t
140
+
val rpc_of_t : t -> t
141
+
val rpc_of_unit : unit -> t
142
+
val rpc_of_char : char -> t
143
+
val int64_of_rpc : t -> int64
144
+
val int32_of_rpc : t -> int32
145
+
val int_of_rpc : t -> int
146
+
val bool_of_rpc : t -> bool
147
+
val float_of_rpc : t -> float
148
+
val string_of_rpc : t -> string
149
+
val dateTime_of_rpc : t -> string
150
+
val base64_of_rpc : t -> string
151
+
val t_of_rpc : t -> t
152
+
val char_of_rpc : t -> char
153
+
val unit_of_rpc : t -> unit
154
+
155
+
module ResultUnmarshallers : sig
156
+
val int64_of_rpc : t -> (int64, msg) result
157
+
val int32_of_rpc : t -> (int32, msg) result
158
+
val int_of_rpc : t -> (int, msg) result
159
+
val bool_of_rpc : t -> (bool, msg) result
160
+
val float_of_rpc : t -> (float, msg) result
161
+
val string_of_rpc : t -> (string, msg) result
162
+
val dateTime_of_rpc : t -> (string, msg) result
163
+
val base64_of_rpc : t -> (string, msg) result
164
+
val t_of_rpc : t -> (t, msg) result
165
+
val unit_of_rpc : t -> (unit, msg) result
166
+
val char_of_rpc : t -> (char, msg) result
167
+
end
168
+
169
+
(** {2 Calls} *)
170
+
171
+
type callback = string list -> t -> unit
172
+
type call = { name : string; params : t list; is_notification : bool }
173
+
174
+
val call : string -> t list -> call
175
+
val notification : string -> t list -> call
176
+
val string_of_call : call -> string
177
+
178
+
(** {2 Responses} *)
179
+
180
+
type response = { success : bool; contents : t; is_notification : bool }
181
+
182
+
val string_of_response : response -> string
183
+
val success : t -> response
184
+
val failure : t -> response
185
+
186
+
(** {2 Run-time errors} *)
187
+
188
+
exception Runtime_error of string * t
189
+
exception Runtime_exception of string * string
190
+
191
+
val set_debug : bool -> unit
192
+
(** {2 Debug options} *)
193
+
194
+
val get_debug : unit -> bool
195
+
196
+
val lowerfn : t -> t
197
+
(** Helper *)
198
+
199
+
val struct_extend : t -> t -> t
200
+
(** [struct_extend rpc1 rpc2] first checks that [rpc1] and [rpc2] are both
201
+
* dictionaries. If this is the case then [struct_extend] will create a new
202
+
* [Rpc.t] which contains all key-value pairs from [rpc1], as well as all
203
+
* key-value pairs from [rpc2] for which the key does not exist in [rpc1]. *)
+271
js_top_worker/idl/_old/rpcmarshal.ml
+271
js_top_worker/idl/_old/rpcmarshal.ml
···
1
+
(* Basic type definitions *)
2
+
open Rpc.Types
3
+
4
+
type err = [ `Msg of string ]
5
+
6
+
let tailrec_map f l = List.rev_map f l |> List.rev
7
+
let ( >>| ) x f = match x with Ok x -> Ok (f x) | Error y -> Error y
8
+
let ( >>= ) x f = match x with Ok x -> f x | Error y -> Error y
9
+
let return x = Ok x
10
+
let ok x = Ok x
11
+
12
+
let rec unmarshal : type a. a typ -> Rpc.t -> (a, err) result =
13
+
fun t v ->
14
+
let open Rpc in
15
+
let open Rpc.ResultUnmarshallers in
16
+
let list_helper typ l =
17
+
List.fold_left
18
+
(fun acc v ->
19
+
match (acc, unmarshal typ v) with
20
+
| Ok a, Ok v -> Ok (v :: a)
21
+
| _, Error (`Msg s) ->
22
+
Error
23
+
(`Msg
24
+
(Printf.sprintf
25
+
"Failed to unmarshal array: %s (when unmarshalling: %s)" s
26
+
(Rpc.to_string v)))
27
+
| x, _ -> x)
28
+
(Ok []) l
29
+
>>| List.rev
30
+
in
31
+
match t with
32
+
| Basic Int -> int_of_rpc v
33
+
| Basic Int32 -> int32_of_rpc v
34
+
| Basic Int64 -> int64_of_rpc v
35
+
| Basic Bool -> bool_of_rpc v
36
+
| Basic Float -> float_of_rpc v
37
+
| Basic String -> string_of_rpc v
38
+
| Basic Char -> int_of_rpc v >>| Char.chr
39
+
| DateTime -> dateTime_of_rpc v
40
+
| Base64 -> base64_of_rpc v
41
+
| Array typ -> (
42
+
match v with
43
+
| Enum xs -> list_helper typ xs >>| Array.of_list
44
+
| _ -> Error (`Msg "Expecting Array"))
45
+
| List (Tuple (Basic String, typ)) -> (
46
+
match v with
47
+
| Dict xs ->
48
+
let keys = tailrec_map fst xs in
49
+
let vs = tailrec_map snd xs in
50
+
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
51
+
| _ -> Error (`Msg "Unhandled"))
52
+
| Dict (basic, typ) -> (
53
+
match v with
54
+
| Dict xs -> (
55
+
match basic with
56
+
| String ->
57
+
let keys = tailrec_map fst xs in
58
+
let vs = tailrec_map snd xs in
59
+
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
60
+
| _ -> Error (`Msg "Expecting something other than a Dict type"))
61
+
| _ -> Error (`Msg "Unhandled"))
62
+
| List typ -> (
63
+
match v with
64
+
| Enum xs -> list_helper typ xs
65
+
| _ -> Error (`Msg "Expecting array"))
66
+
| Unit -> unit_of_rpc v
67
+
| Option t -> (
68
+
match v with
69
+
| Enum [ x ] -> unmarshal t x >>= fun x -> return (Some x)
70
+
| Enum [] -> return None
71
+
| y ->
72
+
Error
73
+
(`Msg
74
+
(Printf.sprintf "Expecting an Enum value, got '%s'"
75
+
(Rpc.to_string y))))
76
+
| Tuple (t1, t2) -> (
77
+
match (v, t2) with
78
+
| Rpc.Enum list, Tuple (_, _) ->
79
+
unmarshal t1 (List.hd list) >>= fun v1 ->
80
+
unmarshal t2 (Rpc.Enum (List.tl list)) >>= fun v2 -> Ok (v1, v2)
81
+
| Rpc.Enum [ x; y ], _ ->
82
+
unmarshal t1 x >>= fun v1 ->
83
+
unmarshal t2 y >>= fun v2 -> Ok (v1, v2)
84
+
| Rpc.Enum _, _ -> Error (`Msg "Too many items in a tuple!")
85
+
| _, _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple"))
86
+
| Tuple3 (t1, t2, t3) -> (
87
+
match v with
88
+
| Rpc.Enum [ x; y; z ] ->
89
+
unmarshal t1 x >>= fun v1 ->
90
+
unmarshal t2 y >>= fun v2 ->
91
+
unmarshal t3 z >>= fun v3 -> Ok (v1, v2, v3)
92
+
| Rpc.Enum _ ->
93
+
Error (`Msg "Expecting precisely 3 items when unmarshalling a Tuple3")
94
+
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple3"))
95
+
| Tuple4 (t1, t2, t3, t4) -> (
96
+
match v with
97
+
| Rpc.Enum [ x; y; z; a ] ->
98
+
unmarshal t1 x >>= fun v1 ->
99
+
unmarshal t2 y >>= fun v2 ->
100
+
unmarshal t3 z >>= fun v3 ->
101
+
unmarshal t4 a >>= fun v4 -> Ok (v1, v2, v3, v4)
102
+
| Rpc.Enum _ ->
103
+
Error
104
+
(`Msg
105
+
"Expecting precisely 4 items in an Enum when unmarshalling a \
106
+
Tuple4")
107
+
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple4"))
108
+
| Struct { constructor; sname; _ } -> (
109
+
match v with
110
+
| Rpc.Dict keys' ->
111
+
let keys =
112
+
List.map (fun (s, v) -> (String.lowercase_ascii s, v)) keys'
113
+
in
114
+
constructor
115
+
{
116
+
field_get =
117
+
(let x : type a. string -> a typ -> (a, Rpc.msg) result =
118
+
fun s ty ->
119
+
let s = String.lowercase_ascii s in
120
+
match ty with
121
+
| Option x -> (
122
+
try
123
+
List.assoc s keys |> unmarshal x >>= fun o ->
124
+
return (Some o)
125
+
with _ -> return None)
126
+
| y -> (
127
+
try List.assoc s keys |> unmarshal y
128
+
with Not_found ->
129
+
Error
130
+
(`Msg
131
+
(Printf.sprintf
132
+
"No value found for key: '%s' when \
133
+
unmarshalling '%s'"
134
+
s sname)))
135
+
in
136
+
x);
137
+
}
138
+
| _ ->
139
+
Error
140
+
(`Msg
141
+
(Printf.sprintf "Expecting Rpc.Dict when unmarshalling a '%s'"
142
+
sname)))
143
+
| Variant { vconstructor; _ } ->
144
+
(match v with
145
+
| Rpc.String name -> ok (name, Rpc.Null)
146
+
| Rpc.Enum [ Rpc.String name; contents ] -> ok (name, contents)
147
+
| _ ->
148
+
Error (`Msg "Expecting String or Enum when unmarshalling a variant"))
149
+
>>= fun (name, contents) ->
150
+
let constr = { tget = (fun typ -> unmarshal typ contents) } in
151
+
vconstructor name constr
152
+
| Abstract { of_rpc; _ } -> of_rpc v
153
+
154
+
let rec marshal : type a. a typ -> a -> Rpc.t =
155
+
fun t v ->
156
+
let open Rpc in
157
+
let rpc_of_basic : type a. a basic -> a -> Rpc.t =
158
+
fun t v ->
159
+
match t with
160
+
| Int -> rpc_of_int v
161
+
| Int32 -> rpc_of_int32 v
162
+
| Int64 -> rpc_of_int64 v
163
+
| Bool -> rpc_of_bool v
164
+
| Float -> rpc_of_float v
165
+
| String -> rpc_of_string v
166
+
| Char -> rpc_of_int (Char.code v)
167
+
in
168
+
match t with
169
+
| Basic t -> rpc_of_basic t v
170
+
| DateTime -> rpc_of_dateTime v
171
+
| Base64 -> rpc_of_base64 v
172
+
| Array typ -> Enum (tailrec_map (marshal typ) (Array.to_list v))
173
+
| List (Tuple (Basic String, typ)) ->
174
+
Dict (tailrec_map (fun (x, y) -> (x, marshal typ y)) v)
175
+
| List typ -> Enum (tailrec_map (marshal typ) v)
176
+
| Dict (String, typ) ->
177
+
Rpc.Dict (tailrec_map (fun (k, v) -> (k, marshal typ v)) v)
178
+
| Dict (basic, typ) ->
179
+
Rpc.Enum
180
+
(tailrec_map
181
+
(fun (k, v) -> Rpc.Enum [ rpc_of_basic basic k; marshal typ v ])
182
+
v)
183
+
| Unit -> rpc_of_unit v
184
+
| Option ty ->
185
+
Rpc.Enum (match v with Some x -> [ marshal ty x ] | None -> [])
186
+
| Tuple (x, (Tuple (_, _) as y)) -> (
187
+
match marshal y (snd v) with
188
+
| Rpc.Enum xs -> Rpc.Enum (marshal x (fst v) :: xs)
189
+
| _ -> failwith "Marshalling a tuple should always give an Enum")
190
+
| Tuple (x, y) -> Rpc.Enum [ marshal x (fst v); marshal y (snd v) ]
191
+
| Tuple3 (x, y, z) ->
192
+
let vx, vy, vz = v in
193
+
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz ]
194
+
| Tuple4 (x, y, z, a) ->
195
+
let vx, vy, vz, va = v in
196
+
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz; marshal a va ]
197
+
| Struct { fields; _ } ->
198
+
let fields =
199
+
List.fold_left
200
+
(fun acc f ->
201
+
match f with
202
+
| BoxedField f -> (
203
+
let value = marshal f.field (f.fget v) in
204
+
match (f.field, value) with
205
+
| Option _, Rpc.Enum [] -> acc
206
+
| Option _, Rpc.Enum [ x ] -> (f.fname, x) :: acc
207
+
| _, _ -> (f.fname, value) :: acc))
208
+
[] fields
209
+
in
210
+
Rpc.Dict fields
211
+
| Variant { variants; _ } ->
212
+
List.fold_left
213
+
(fun acc t ->
214
+
match t with
215
+
| BoxedTag t -> (
216
+
match t.tpreview v with
217
+
| Some x -> (
218
+
match marshal t.tcontents x with
219
+
| Rpc.Null -> Rpc.String t.tname
220
+
| y -> Rpc.Enum [ Rpc.String t.tname; y ])
221
+
| None -> acc))
222
+
Rpc.Null variants
223
+
| Abstract { rpc_of; _ } -> rpc_of v
224
+
225
+
let ocaml_of_basic : type a. a basic -> string = function
226
+
| Int64 -> "int64"
227
+
| Int32 -> "int32"
228
+
| Int -> "int"
229
+
| String -> "string"
230
+
| Float -> "float"
231
+
| Bool -> "bool"
232
+
| Char -> "char"
233
+
234
+
let rec ocaml_of_t : type a. a typ -> string = function
235
+
| Basic b -> ocaml_of_basic b
236
+
| DateTime -> "string"
237
+
| Base64 -> "base64"
238
+
| Array t -> ocaml_of_t t ^ " list"
239
+
| List t -> ocaml_of_t t ^ " list"
240
+
| Dict (b, t) ->
241
+
Printf.sprintf "(%s * %s) list" (ocaml_of_basic b) (ocaml_of_t t)
242
+
| Unit -> "unit"
243
+
| Option t -> ocaml_of_t t ^ " option"
244
+
| Tuple (a, b) -> Printf.sprintf "(%s * %s)" (ocaml_of_t a) (ocaml_of_t b)
245
+
| Tuple3 (a, b, c) ->
246
+
Printf.sprintf "(%s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b)
247
+
(ocaml_of_t c)
248
+
| Tuple4 (a, b, c, d) ->
249
+
Printf.sprintf "(%s * %s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b)
250
+
(ocaml_of_t c) (ocaml_of_t d)
251
+
| Struct { fields; _ } ->
252
+
let fields =
253
+
List.map
254
+
(function
255
+
| BoxedField f ->
256
+
Printf.sprintf "%s: %s;" f.fname (ocaml_of_t f.field))
257
+
fields
258
+
in
259
+
Printf.sprintf "{ %s }" (String.concat " " fields)
260
+
| Variant { variants; _ } ->
261
+
let tags =
262
+
List.map
263
+
(function
264
+
| BoxedTag t ->
265
+
Printf.sprintf "| %s (%s) (** %s *)" t.tname
266
+
(ocaml_of_t t.tcontents)
267
+
(String.concat " " t.tdescription))
268
+
variants
269
+
in
270
+
String.concat " " tags
271
+
| Abstract _ -> "<abstract>"
+63
js_top_worker/idl/dune
+63
js_top_worker/idl/dune
···
1
+
(library
2
+
(name js_top_worker_rpc)
3
+
(public_name js_top_worker-rpc)
4
+
(modules toplevel_api_gen transport)
5
+
(libraries rresult mime_printer merlin-lib.query_protocol rpclib rpclib.json))
6
+
7
+
(library
8
+
(name js_top_worker_message)
9
+
(public_name js_top_worker-rpc.message)
10
+
(modules message)
11
+
(libraries js_of_ocaml)
12
+
(preprocess
13
+
(pps js_of_ocaml-ppx)))
14
+
15
+
(library
16
+
(name js_top_worker_client)
17
+
(public_name js_top_worker-client)
18
+
(modules js_top_worker_client)
19
+
(libraries js_top_worker-rpc lwt brr rpclib.json)
20
+
(preprocess
21
+
(pps js_of_ocaml-ppx)))
22
+
23
+
(library
24
+
(name js_top_worker_client_fut)
25
+
(public_name js_top_worker-client_fut)
26
+
(modules js_top_worker_client_fut)
27
+
(libraries js_top_worker-rpc rpclib.json brr)
28
+
(preprocess
29
+
(pps js_of_ocaml-ppx)))
30
+
31
+
(library
32
+
(name js_top_worker_client_msg)
33
+
(public_name js_top_worker-client.msg)
34
+
(modules js_top_worker_client_msg)
35
+
(libraries js_top_worker-rpc.message lwt brr js_of_ocaml)
36
+
(preprocess
37
+
(pps js_of_ocaml-ppx)))
38
+
39
+
(library
40
+
(name js_top_worker_rpc_def)
41
+
(modules toplevel_api)
42
+
(enabled_if
43
+
(>= %{ocaml_version} 4.12))
44
+
(package js_top_worker_rpc_def)
45
+
(libraries mime_printer merlin-lib.query_protocol)
46
+
(preprocess
47
+
(pps ppx_deriving_rpc)))
48
+
49
+
(rule
50
+
(target toplevel_api_gen.ml.gen)
51
+
(enabled_if
52
+
(>= %{ocaml_version} 4.12))
53
+
(action
54
+
(with-stderr-to
55
+
%{target}
56
+
(run ocamlc -stop-after parsing -dsource %{dep:toplevel_api.pp.ml}))))
57
+
58
+
(rule
59
+
(alias runtest)
60
+
(enabled_if
61
+
(>= %{ocaml_version} 4.12))
62
+
(action
63
+
(diff toplevel_api_gen.ml toplevel_api_gen.ml.gen)))
+137
js_top_worker/idl/js_top_worker_client.ml
+137
js_top_worker/idl/js_top_worker_client.ml
···
1
+
(** Worker rpc *)
2
+
3
+
(** Functions to facilitate RPC calls to web workers. *)
4
+
5
+
module Worker = Brr_webworkers.Worker
6
+
open Brr_io
7
+
open Js_top_worker_rpc
8
+
9
+
(** The assumption made in this module is that RPCs are answered in the order
10
+
they are made. *)
11
+
12
+
type context = {
13
+
worker : Worker.t;
14
+
timeout : int;
15
+
timeout_fn : unit -> unit;
16
+
waiting : ((Rpc.response, exn) Result.t Lwt_mvar.t * int) Queue.t;
17
+
}
18
+
19
+
type rpc = Rpc.call -> Rpc.response Lwt.t
20
+
21
+
exception Timeout
22
+
23
+
(* let log s = Js_of_ocaml.Firebug.console##log (Js_of_ocaml.Js.string s) *)
24
+
25
+
let demux context msg =
26
+
Lwt.async (fun () ->
27
+
match Queue.take_opt context.waiting with
28
+
| None -> Lwt.return ()
29
+
| Some (mv, outstanding_execution) ->
30
+
Brr.G.stop_timer outstanding_execution;
31
+
let msg = Message.Ev.data (Brr.Ev.as_type msg) in
32
+
Js_of_ocaml.Console.console##log
33
+
(Js_of_ocaml.Js.string
34
+
"Client received the following, to be converted to an OCaml \
35
+
string");
36
+
Js_of_ocaml.Console.console##log msg;
37
+
let msg = Js_of_ocaml.Js.to_string msg in
38
+
(* log (Printf.sprintf "Client received: %s" msg); *)
39
+
Lwt_mvar.put mv (Ok (Transport.Json.response_of_string msg)))
40
+
41
+
let rpc : context -> Rpc.call -> Rpc.response Lwt.t =
42
+
fun context call ->
43
+
let open Lwt in
44
+
let jv = Transport.Json.string_of_call call |> Js_of_ocaml.Js.string in
45
+
(* log (Printf.sprintf "Client sending: %s" jv); *)
46
+
let mv = Lwt_mvar.create_empty () in
47
+
let outstanding_execution =
48
+
Brr.G.set_timeout ~ms:context.timeout (fun () ->
49
+
Lwt.async (fun () -> Lwt_mvar.put mv (Error Timeout));
50
+
Worker.terminate context.worker;
51
+
context.timeout_fn ())
52
+
in
53
+
Queue.push (mv, outstanding_execution) context.waiting;
54
+
Worker.post context.worker jv;
55
+
Lwt_mvar.take mv >>= fun r ->
56
+
match r with
57
+
| Ok jv ->
58
+
let response = jv in
59
+
Lwt.return response
60
+
| Error exn -> Lwt.fail exn
61
+
62
+
let start url timeout timeout_fn : rpc =
63
+
let worker = Worker.create (Jstr.v url) in
64
+
let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in
65
+
let _listener =
66
+
Brr.Ev.listen Message.Ev.message (demux context) (Worker.as_target worker)
67
+
in
68
+
rpc context
69
+
70
+
module Rpc_lwt = Idl.Make (Lwt)
71
+
module Wraw = Toplevel_api_gen.Make (Rpc_lwt.GenClient ())
72
+
73
+
module W : sig
74
+
type init_config = Toplevel_api_gen.init_config
75
+
type err = Toplevel_api_gen.err
76
+
type exec_result = Toplevel_api_gen.exec_result
77
+
78
+
val init :
79
+
rpc ->
80
+
Toplevel_api_gen.init_config ->
81
+
(unit, Toplevel_api_gen.err) result Lwt.t
82
+
83
+
val create_env :
84
+
rpc ->
85
+
string ->
86
+
(unit, Toplevel_api_gen.err) result Lwt.t
87
+
88
+
val destroy_env :
89
+
rpc ->
90
+
string ->
91
+
(unit, Toplevel_api_gen.err) result Lwt.t
92
+
93
+
val list_envs :
94
+
rpc ->
95
+
(string list, Toplevel_api_gen.err) result Lwt.t
96
+
97
+
val setup :
98
+
rpc ->
99
+
string ->
100
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
101
+
102
+
val exec :
103
+
rpc ->
104
+
string ->
105
+
string ->
106
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
107
+
108
+
val exec_toplevel :
109
+
rpc ->
110
+
string ->
111
+
string ->
112
+
(Toplevel_api_gen.exec_toplevel_result, Toplevel_api_gen.err) result Lwt.t
113
+
114
+
val query_errors :
115
+
rpc ->
116
+
string ->
117
+
string option ->
118
+
string list ->
119
+
bool ->
120
+
string ->
121
+
(Toplevel_api_gen.error list, Toplevel_api_gen.err) result Lwt.t
122
+
end = struct
123
+
type init_config = Toplevel_api_gen.init_config
124
+
type err = Toplevel_api_gen.err
125
+
type exec_result = Toplevel_api_gen.exec_result
126
+
127
+
let init rpc a = Wraw.init rpc a |> Rpc_lwt.T.get
128
+
let create_env rpc env_id = Wraw.create_env rpc env_id |> Rpc_lwt.T.get
129
+
let destroy_env rpc env_id = Wraw.destroy_env rpc env_id |> Rpc_lwt.T.get
130
+
let list_envs rpc = Wraw.list_envs rpc () |> Rpc_lwt.T.get
131
+
let setup rpc env_id = Wraw.setup rpc env_id |> Rpc_lwt.T.get
132
+
let exec rpc env_id phrase = Wraw.exec rpc env_id phrase |> Rpc_lwt.T.get
133
+
let exec_toplevel rpc env_id script = Wraw.exec_toplevel rpc env_id script |> Rpc_lwt.T.get
134
+
135
+
let query_errors rpc env_id id deps is_toplevel doc =
136
+
Wraw.query_errors rpc env_id id deps is_toplevel doc |> Rpc_lwt.T.get
137
+
end
+76
js_top_worker/idl/js_top_worker_client.mli
+76
js_top_worker/idl/js_top_worker_client.mli
···
1
+
(* Worker_rpc *)
2
+
3
+
open Js_top_worker_rpc
4
+
5
+
(** Functions to facilitate RPC calls to web workers. *)
6
+
7
+
exception Timeout
8
+
(** When RPC calls take too long, the Lwt promise is set to failed state with
9
+
this exception. *)
10
+
11
+
type rpc = Rpc.call -> Rpc.response Lwt.t
12
+
(** RPC function for communicating with the worker. This is used by each RPC
13
+
function declared in {!W} *)
14
+
15
+
val start : string -> int -> (unit -> unit) -> rpc
16
+
(** [start url timeout timeout_fn] initialises a web worker from [url] and
17
+
starts communications with it. [timeout] is the number of seconds to wait
18
+
for a response from any RPC before raising an error, and [timeout_fn] is
19
+
called when a timeout occurs. Returns the {!type-rpc} function used in the
20
+
RPC calls. *)
21
+
22
+
module W : sig
23
+
(** {2 Type declarations}
24
+
25
+
The following types are redeclared here for convenience. *)
26
+
27
+
type init_config = Toplevel_api_gen.init_config
28
+
type err = Toplevel_api_gen.err
29
+
type exec_result = Toplevel_api_gen.exec_result
30
+
31
+
(** {2 RPC calls}
32
+
33
+
The first parameter of these calls is the rpc function returned by
34
+
{!val-start}. If any of these calls fails to receive a response from the
35
+
worker by the timeout set in the {!val-start} call, the {!Lwt} thread will
36
+
be {{!Lwt.fail}failed}. *)
37
+
38
+
val init : rpc -> init_config -> (unit, err) result Lwt.t
39
+
(** Initialise the toplevel. This must be called before any other API. *)
40
+
41
+
val create_env : rpc -> string -> (unit, err) result Lwt.t
42
+
(** Create a new isolated execution environment with the given ID. *)
43
+
44
+
val destroy_env : rpc -> string -> (unit, err) result Lwt.t
45
+
(** Destroy an execution environment. *)
46
+
47
+
val list_envs : rpc -> (string list, err) result Lwt.t
48
+
(** List all existing environment IDs. *)
49
+
50
+
val setup : rpc -> string -> (exec_result, err) result Lwt.t
51
+
(** Start the toplevel for the given environment. If [env_id] is empty string,
52
+
uses the default environment. Return value is the initial blurb printed
53
+
when starting a toplevel. Note that the toplevel must be initialised first. *)
54
+
55
+
val exec : rpc -> string -> string -> (exec_result, err) result Lwt.t
56
+
(** Execute a phrase using the toplevel. If [env_id] is empty string, uses the
57
+
default environment. The toplevel must have been initialised first. *)
58
+
59
+
val exec_toplevel :
60
+
rpc ->
61
+
string ->
62
+
string ->
63
+
(Toplevel_api_gen.exec_toplevel_result, err) result Lwt.t
64
+
(** Execute a toplevel script. If [env_id] is empty string, uses the default
65
+
environment. The toplevel must have been initialised first. *)
66
+
67
+
val query_errors :
68
+
rpc ->
69
+
string ->
70
+
string option ->
71
+
string list ->
72
+
bool ->
73
+
string ->
74
+
(Toplevel_api_gen.error list, err) result Lwt.t
75
+
(** Query the toplevel for errors. [env_id] specifies the environment. *)
76
+
end
+97
js_top_worker/idl/js_top_worker_client_fut.ml
+97
js_top_worker/idl/js_top_worker_client_fut.ml
···
1
+
(** Worker rpc *)
2
+
3
+
(** Functions to facilitate RPC calls to web workers. *)
4
+
5
+
module Worker = Brr_webworkers.Worker
6
+
open Brr_io
7
+
open Js_top_worker_rpc
8
+
9
+
(** The assumption made in this module is that RPCs are answered in the order
10
+
they are made. *)
11
+
12
+
type context = {
13
+
worker : Worker.t;
14
+
timeout : int;
15
+
timeout_fn : unit -> unit;
16
+
waiting : (((Rpc.response, exn) Result.t -> unit) * int) Queue.t;
17
+
}
18
+
19
+
type rpc = Rpc.call -> Rpc.response Fut.t
20
+
21
+
exception Timeout
22
+
23
+
(* let log s = Js_of_ocaml.Firebug.console##log (Js_of_ocaml.Js.string s) *)
24
+
25
+
let demux context msg =
26
+
match Queue.take_opt context.waiting with
27
+
| None -> ()
28
+
| Some (mv, outstanding_execution) ->
29
+
Brr.G.stop_timer outstanding_execution;
30
+
let msg = Message.Ev.data (Brr.Ev.as_type msg) in
31
+
(* Js_of_ocaml.Console.console##log (Js_of_ocaml.Js.string "Client received the following, to be converted to an OCaml string"); *)
32
+
(* Js_of_ocaml.Console.console##log msg; *)
33
+
let msg = Js_of_ocaml.Js.to_string msg in
34
+
(* log (Printf.sprintf "Client received: %s" msg); *)
35
+
mv (Ok (Transport.Json.response_of_string msg))
36
+
37
+
let rpc : context -> Rpc.call -> Rpc.response Fut.t =
38
+
fun context call ->
39
+
let open Fut.Syntax in
40
+
let jv = Transport.Json.string_of_call call |> Js_of_ocaml.Js.string in
41
+
(* log (Printf.sprintf "Client sending: %s" jv); *)
42
+
let v, mv = Fut.create () in
43
+
let outstanding_execution =
44
+
Brr.G.set_timeout ~ms:context.timeout (fun () ->
45
+
mv (Error Timeout);
46
+
Worker.terminate context.worker;
47
+
context.timeout_fn ())
48
+
in
49
+
Queue.push (mv, outstanding_execution) context.waiting;
50
+
Worker.post context.worker jv;
51
+
let* r = v in
52
+
match r with
53
+
| Ok jv ->
54
+
let response = jv in
55
+
Fut.return response
56
+
| Error exn -> raise exn
57
+
58
+
let start url timeout timeout_fn : rpc =
59
+
let worker = Worker.create (Jstr.v url) in
60
+
let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in
61
+
let _listener =
62
+
Brr.Ev.listen Message.Ev.message (demux context) (Worker.as_target worker)
63
+
in
64
+
rpc context
65
+
66
+
module M = struct
67
+
include Fut
68
+
69
+
let fail e = raise e
70
+
end
71
+
72
+
module Rpc_fut = Idl.Make (M)
73
+
module Wraw = Toplevel_api_gen.Make (Rpc_fut.GenClient ())
74
+
75
+
module W = struct
76
+
type init_config = Toplevel_api_gen.init_config
77
+
type err = Toplevel_api_gen.err
78
+
type exec_result = Toplevel_api_gen.exec_result
79
+
80
+
let init rpc a = Wraw.init rpc a |> Rpc_fut.T.get
81
+
let create_env rpc env_id = Wraw.create_env rpc env_id |> Rpc_fut.T.get
82
+
let destroy_env rpc env_id = Wraw.destroy_env rpc env_id |> Rpc_fut.T.get
83
+
let list_envs rpc = Wraw.list_envs rpc () |> Rpc_fut.T.get
84
+
let setup rpc env_id = Wraw.setup rpc env_id |> Rpc_fut.T.get
85
+
let exec rpc env_id phrase = Wraw.exec rpc env_id phrase |> Rpc_fut.T.get
86
+
87
+
let query_errors rpc env_id id deps is_toplevel doc =
88
+
Wraw.query_errors rpc env_id id deps is_toplevel doc |> Rpc_fut.T.get
89
+
90
+
let exec_toplevel rpc env_id doc = Wraw.exec_toplevel rpc env_id doc |> Rpc_fut.T.get
91
+
92
+
let complete_prefix rpc env_id id deps is_toplevel doc pos =
93
+
Wraw.complete_prefix rpc env_id id deps is_toplevel doc pos |> Rpc_fut.T.get
94
+
95
+
let type_enclosing rpc env_id id deps is_toplevel doc pos =
96
+
Wraw.type_enclosing rpc env_id id deps is_toplevel doc pos |> Rpc_fut.T.get
97
+
end
+404
js_top_worker/idl/js_top_worker_client_msg.ml
+404
js_top_worker/idl/js_top_worker_client_msg.ml
···
1
+
(** Worker client using the message protocol.
2
+
3
+
This client communicates with the OCaml toplevel worker using a simple
4
+
JSON message protocol instead of RPC. *)
5
+
6
+
module Brr_worker = Brr_webworkers.Worker
7
+
module Brr_message = Brr_io.Message
8
+
module Msg = Js_top_worker_message.Message
9
+
10
+
(** Incremental output from a single phrase *)
11
+
type output_at = {
12
+
cell_id : int;
13
+
loc : int; (** Character position after phrase (pos_cnum) *)
14
+
caml_ppf : string;
15
+
mime_vals : Msg.mime_val list;
16
+
}
17
+
18
+
(** Output result type *)
19
+
type output = {
20
+
cell_id : int;
21
+
stdout : string;
22
+
stderr : string;
23
+
caml_ppf : string;
24
+
mime_vals : Msg.mime_val list;
25
+
}
26
+
27
+
(** Eval stream event *)
28
+
type eval_event =
29
+
| Phrase of output_at (** Incremental output after each phrase *)
30
+
| Done of output (** Final result *)
31
+
| Error of string (** Error occurred *)
32
+
33
+
(** Client state *)
34
+
type t = {
35
+
worker : Brr_worker.t;
36
+
timeout : int;
37
+
mutable cell_id : int;
38
+
mutable ready : bool;
39
+
ready_waiters : (unit -> unit) Queue.t;
40
+
pending : (int, Msg.worker_msg Lwt.u) Hashtbl.t;
41
+
pending_env : (string, Msg.worker_msg Lwt.u) Hashtbl.t;
42
+
pending_stream : (int, eval_event option -> unit) Hashtbl.t;
43
+
}
44
+
45
+
exception Timeout
46
+
exception InitError of string
47
+
exception EvalError of string
48
+
49
+
(** Parse a worker message from JSON string *)
50
+
let parse_worker_msg s =
51
+
let open Js_of_ocaml in
52
+
let obj = Json.unsafe_input (Js.string s) in
53
+
let typ = Js.to_string (Js.Unsafe.get obj (Js.string "type")) in
54
+
let get_int key = Js.Unsafe.get obj (Js.string key) in
55
+
let get_string key = Js.to_string (Js.Unsafe.get obj (Js.string key)) in
56
+
let parse_position p =
57
+
{ Msg.pos_cnum = Js.Unsafe.get p (Js.string "pos_cnum");
58
+
pos_lnum = Js.Unsafe.get p (Js.string "pos_lnum");
59
+
pos_bol = Js.Unsafe.get p (Js.string "pos_bol") }
60
+
in
61
+
let parse_location loc =
62
+
{ Msg.loc_start = parse_position (Js.Unsafe.get loc (Js.string "loc_start"));
63
+
loc_end = parse_position (Js.Unsafe.get loc (Js.string "loc_end")) }
64
+
in
65
+
match typ with
66
+
| "ready" -> Msg.Ready
67
+
| "init_error" -> Msg.InitError { message = get_string "message" }
68
+
| "output" ->
69
+
let mime_vals_arr = Js.to_array (Js.Unsafe.get obj (Js.string "mime_vals")) in
70
+
let mime_vals = Array.to_list (Array.map (fun mv ->
71
+
{ Msg.mime_type = Js.to_string (Js.Unsafe.get mv (Js.string "mime_type"));
72
+
data = Js.to_string (Js.Unsafe.get mv (Js.string "data")) }
73
+
) mime_vals_arr) in
74
+
Msg.Output {
75
+
cell_id = get_int "cell_id";
76
+
stdout = get_string "stdout";
77
+
stderr = get_string "stderr";
78
+
caml_ppf = get_string "caml_ppf";
79
+
mime_vals;
80
+
}
81
+
| "completions" ->
82
+
let c = Js.Unsafe.get obj (Js.string "completions") in
83
+
let entries_arr = Js.to_array (Js.Unsafe.get c (Js.string "entries")) in
84
+
let entries = Array.to_list (Array.map (fun e ->
85
+
{ Msg.name = Js.to_string (Js.Unsafe.get e (Js.string "name"));
86
+
kind = Js.to_string (Js.Unsafe.get e (Js.string "kind"));
87
+
desc = Js.to_string (Js.Unsafe.get e (Js.string "desc"));
88
+
info = Js.to_string (Js.Unsafe.get e (Js.string "info"));
89
+
deprecated = Js.to_bool (Js.Unsafe.get e (Js.string "deprecated")) }
90
+
) entries_arr) in
91
+
Msg.Completions {
92
+
cell_id = get_int "cell_id";
93
+
completions = {
94
+
from = Js.Unsafe.get c (Js.string "from");
95
+
to_ = Js.Unsafe.get c (Js.string "to");
96
+
entries;
97
+
};
98
+
}
99
+
| "types" ->
100
+
let types_arr = Js.to_array (Js.Unsafe.get obj (Js.string "types")) in
101
+
let types = Array.to_list (Array.map (fun t ->
102
+
{ Msg.loc = parse_location (Js.Unsafe.get t (Js.string "loc"));
103
+
type_str = Js.to_string (Js.Unsafe.get t (Js.string "type_str"));
104
+
tail = Js.to_string (Js.Unsafe.get t (Js.string "tail")) }
105
+
) types_arr) in
106
+
Msg.Types { cell_id = get_int "cell_id"; types }
107
+
| "errors" ->
108
+
let errors_arr = Js.to_array (Js.Unsafe.get obj (Js.string "errors")) in
109
+
let errors = Array.to_list (Array.map (fun e ->
110
+
let sub_arr = Js.to_array (Js.Unsafe.get e (Js.string "sub")) in
111
+
let sub = Array.to_list (Array.map Js.to_string sub_arr) in
112
+
{ Msg.kind = Js.to_string (Js.Unsafe.get e (Js.string "kind"));
113
+
loc = parse_location (Js.Unsafe.get e (Js.string "loc"));
114
+
main = Js.to_string (Js.Unsafe.get e (Js.string "main"));
115
+
sub;
116
+
source = Js.to_string (Js.Unsafe.get e (Js.string "source")) }
117
+
) errors_arr) in
118
+
Msg.ErrorList { cell_id = get_int "cell_id"; errors }
119
+
| "eval_error" ->
120
+
Msg.EvalError { cell_id = get_int "cell_id"; message = get_string "message" }
121
+
| "env_created" ->
122
+
Msg.EnvCreated { env_id = get_string "env_id" }
123
+
| "env_destroyed" ->
124
+
Msg.EnvDestroyed { env_id = get_string "env_id" }
125
+
| "output_at" ->
126
+
let mime_vals_arr = Js.to_array (Js.Unsafe.get obj (Js.string "mime_vals")) in
127
+
let mime_vals = Array.to_list (Array.map (fun mv ->
128
+
{ Msg.mime_type = Js.to_string (Js.Unsafe.get mv (Js.string "mime_type"));
129
+
data = Js.to_string (Js.Unsafe.get mv (Js.string "data")) }
130
+
) mime_vals_arr) in
131
+
Msg.OutputAt {
132
+
cell_id = get_int "cell_id";
133
+
loc = get_int "loc";
134
+
caml_ppf = get_string "caml_ppf";
135
+
mime_vals;
136
+
}
137
+
| _ -> failwith ("Unknown message type: " ^ typ)
138
+
139
+
(** Handle incoming message from worker *)
140
+
let handle_message t msg =
141
+
let data = Brr_message.Ev.data (Brr.Ev.as_type msg) in
142
+
let parsed = parse_worker_msg (Js_of_ocaml.Js.to_string data) in
143
+
match parsed with
144
+
| Msg.Ready ->
145
+
t.ready <- true;
146
+
Queue.iter (fun f -> f ()) t.ready_waiters;
147
+
Queue.clear t.ready_waiters
148
+
| Msg.InitError _ ->
149
+
t.ready <- true;
150
+
Queue.iter (fun f -> f ()) t.ready_waiters;
151
+
Queue.clear t.ready_waiters
152
+
| Msg.OutputAt { cell_id; loc; caml_ppf; mime_vals } ->
153
+
(match Hashtbl.find_opt t.pending_stream cell_id with
154
+
| Some push -> push (Some (Phrase { cell_id; loc; caml_ppf; mime_vals }))
155
+
| None -> ())
156
+
| Msg.Output { cell_id; stdout; stderr; caml_ppf; mime_vals } ->
157
+
(* Handle streaming eval *)
158
+
(match Hashtbl.find_opt t.pending_stream cell_id with
159
+
| Some push ->
160
+
Hashtbl.remove t.pending_stream cell_id;
161
+
push (Some (Done { cell_id; stdout; stderr; caml_ppf; mime_vals }));
162
+
push None (* Close the stream *)
163
+
| None -> ());
164
+
(* Handle regular eval *)
165
+
(match Hashtbl.find_opt t.pending cell_id with
166
+
| Some resolver ->
167
+
Hashtbl.remove t.pending cell_id;
168
+
Lwt.wakeup resolver parsed
169
+
| None -> ())
170
+
| Msg.EvalError { cell_id; message } ->
171
+
(* Handle streaming eval *)
172
+
(match Hashtbl.find_opt t.pending_stream cell_id with
173
+
| Some push ->
174
+
Hashtbl.remove t.pending_stream cell_id;
175
+
push (Some (Error message));
176
+
push None (* Close the stream *)
177
+
| None -> ());
178
+
(* Handle regular eval *)
179
+
(match Hashtbl.find_opt t.pending cell_id with
180
+
| Some resolver ->
181
+
Hashtbl.remove t.pending cell_id;
182
+
Lwt.wakeup resolver parsed
183
+
| None -> ())
184
+
| Msg.Completions { cell_id; _ }
185
+
| Msg.Types { cell_id; _ } | Msg.ErrorList { cell_id; _ } ->
186
+
(match Hashtbl.find_opt t.pending cell_id with
187
+
| Some resolver ->
188
+
Hashtbl.remove t.pending cell_id;
189
+
Lwt.wakeup resolver parsed
190
+
| None -> ())
191
+
| Msg.EnvCreated { env_id } | Msg.EnvDestroyed { env_id } ->
192
+
(match Hashtbl.find_opt t.pending_env env_id with
193
+
| Some resolver ->
194
+
Hashtbl.remove t.pending_env env_id;
195
+
Lwt.wakeup resolver parsed
196
+
| None -> ())
197
+
198
+
(** Create a new worker client.
199
+
@param timeout Timeout in milliseconds (default: 30000) *)
200
+
let create ?(timeout = 30000) url =
201
+
let worker = Brr_worker.create (Jstr.v url) in
202
+
let t = {
203
+
worker;
204
+
timeout;
205
+
cell_id = 0;
206
+
ready = false;
207
+
ready_waiters = Queue.create ();
208
+
pending = Hashtbl.create 16;
209
+
pending_env = Hashtbl.create 16;
210
+
pending_stream = Hashtbl.create 16;
211
+
} in
212
+
let _listener =
213
+
Brr.Ev.listen Brr_message.Ev.message (handle_message t) (Brr_worker.as_target worker)
214
+
in
215
+
t
216
+
217
+
(** Get next cell ID *)
218
+
let next_cell_id t =
219
+
t.cell_id <- t.cell_id + 1;
220
+
t.cell_id
221
+
222
+
(** Send a message to the worker *)
223
+
let send t msg =
224
+
let open Js_of_ocaml in
225
+
let json = match msg with
226
+
| `Init config ->
227
+
let obj = Js.Unsafe.obj [|
228
+
("type", Js.Unsafe.inject (Js.string "init"));
229
+
("findlib_requires", Js.Unsafe.inject (Js.array (Array.of_list (List.map Js.string config.Msg.findlib_requires))));
230
+
("stdlib_dcs", Js.Unsafe.inject (match config.Msg.stdlib_dcs with Some s -> Js.some (Js.string s) | None -> Js.null));
231
+
("findlib_index", Js.Unsafe.inject (match config.Msg.findlib_index with Some s -> Js.some (Js.string s) | None -> Js.null));
232
+
|] in
233
+
Js.to_string (Json.output obj)
234
+
| `Eval (cell_id, env_id, code) ->
235
+
let obj = Js.Unsafe.obj [|
236
+
("type", Js.Unsafe.inject (Js.string "eval"));
237
+
("cell_id", Js.Unsafe.inject cell_id);
238
+
("env_id", Js.Unsafe.inject (Js.string env_id));
239
+
("code", Js.Unsafe.inject (Js.string code));
240
+
|] in
241
+
Js.to_string (Json.output obj)
242
+
| `Complete (cell_id, env_id, source, position) ->
243
+
let obj = Js.Unsafe.obj [|
244
+
("type", Js.Unsafe.inject (Js.string "complete"));
245
+
("cell_id", Js.Unsafe.inject cell_id);
246
+
("env_id", Js.Unsafe.inject (Js.string env_id));
247
+
("source", Js.Unsafe.inject (Js.string source));
248
+
("position", Js.Unsafe.inject position);
249
+
|] in
250
+
Js.to_string (Json.output obj)
251
+
| `TypeAt (cell_id, env_id, source, position) ->
252
+
let obj = Js.Unsafe.obj [|
253
+
("type", Js.Unsafe.inject (Js.string "type_at"));
254
+
("cell_id", Js.Unsafe.inject cell_id);
255
+
("env_id", Js.Unsafe.inject (Js.string env_id));
256
+
("source", Js.Unsafe.inject (Js.string source));
257
+
("position", Js.Unsafe.inject position);
258
+
|] in
259
+
Js.to_string (Json.output obj)
260
+
| `Errors (cell_id, env_id, source) ->
261
+
let obj = Js.Unsafe.obj [|
262
+
("type", Js.Unsafe.inject (Js.string "errors"));
263
+
("cell_id", Js.Unsafe.inject cell_id);
264
+
("env_id", Js.Unsafe.inject (Js.string env_id));
265
+
("source", Js.Unsafe.inject (Js.string source));
266
+
|] in
267
+
Js.to_string (Json.output obj)
268
+
| `CreateEnv env_id ->
269
+
let obj = Js.Unsafe.obj [|
270
+
("type", Js.Unsafe.inject (Js.string "create_env"));
271
+
("env_id", Js.Unsafe.inject (Js.string env_id));
272
+
|] in
273
+
Js.to_string (Json.output obj)
274
+
| `DestroyEnv env_id ->
275
+
let obj = Js.Unsafe.obj [|
276
+
("type", Js.Unsafe.inject (Js.string "destroy_env"));
277
+
("env_id", Js.Unsafe.inject (Js.string env_id));
278
+
|] in
279
+
Js.to_string (Json.output obj)
280
+
in
281
+
Brr_worker.post t.worker (Js.string json)
282
+
283
+
(** Wait for the worker to be ready *)
284
+
let wait_ready t =
285
+
if t.ready then Lwt.return_unit
286
+
else
287
+
let promise, resolver = Lwt.wait () in
288
+
Queue.push (fun () -> Lwt.wakeup resolver ()) t.ready_waiters;
289
+
promise
290
+
291
+
(** Initialize the worker *)
292
+
let init t config =
293
+
let open Lwt.Infix in
294
+
send t (`Init config);
295
+
wait_ready t >>= fun () ->
296
+
Lwt.return_unit
297
+
298
+
(** Evaluate OCaml code *)
299
+
let eval t ?(env_id = "default") code =
300
+
let open Lwt.Infix in
301
+
wait_ready t >>= fun () ->
302
+
let cell_id = next_cell_id t in
303
+
let promise, resolver = Lwt.wait () in
304
+
Hashtbl.add t.pending cell_id resolver;
305
+
send t (`Eval (cell_id, env_id, code));
306
+
promise >>= fun msg ->
307
+
match msg with
308
+
| Msg.Output { cell_id; stdout; stderr; caml_ppf; mime_vals } ->
309
+
Lwt.return { cell_id; stdout; stderr; caml_ppf; mime_vals }
310
+
| Msg.EvalError { message; _ } ->
311
+
Lwt.fail (EvalError message)
312
+
| _ -> Lwt.fail (Failure "Unexpected response")
313
+
314
+
(** Evaluate OCaml code with streaming output.
315
+
Returns a stream of events: [Phrase] for each phrase as it executes,
316
+
then [Done] with the final result, or [Error] if evaluation fails. *)
317
+
let eval_stream t ?(env_id = "default") code =
318
+
let stream, push = Lwt_stream.create () in
319
+
(* Wait for ready before sending, but return stream immediately *)
320
+
Lwt.async (fun () ->
321
+
let open Lwt.Infix in
322
+
wait_ready t >|= fun () ->
323
+
let cell_id = next_cell_id t in
324
+
Hashtbl.add t.pending_stream cell_id push;
325
+
send t (`Eval (cell_id, env_id, code)));
326
+
stream
327
+
328
+
(** Get completions *)
329
+
let complete t ?(env_id = "default") source position =
330
+
let open Lwt.Infix in
331
+
wait_ready t >>= fun () ->
332
+
let cell_id = next_cell_id t in
333
+
let promise, resolver = Lwt.wait () in
334
+
Hashtbl.add t.pending cell_id resolver;
335
+
send t (`Complete (cell_id, env_id, source, position));
336
+
promise >>= fun msg ->
337
+
match msg with
338
+
| Msg.Completions { completions; _ } ->
339
+
Lwt.return completions
340
+
| Msg.EvalError { message; _ } ->
341
+
Lwt.fail (EvalError message)
342
+
| _ -> Lwt.fail (Failure "Unexpected response")
343
+
344
+
(** Get type at position *)
345
+
let type_at t ?(env_id = "default") source position =
346
+
let open Lwt.Infix in
347
+
wait_ready t >>= fun () ->
348
+
let cell_id = next_cell_id t in
349
+
let promise, resolver = Lwt.wait () in
350
+
Hashtbl.add t.pending cell_id resolver;
351
+
send t (`TypeAt (cell_id, env_id, source, position));
352
+
promise >>= fun msg ->
353
+
match msg with
354
+
| Msg.Types { types; _ } ->
355
+
Lwt.return types
356
+
| Msg.EvalError { message; _ } ->
357
+
Lwt.fail (EvalError message)
358
+
| _ -> Lwt.fail (Failure "Unexpected response")
359
+
360
+
(** Get errors *)
361
+
let errors t ?(env_id = "default") source =
362
+
let open Lwt.Infix in
363
+
wait_ready t >>= fun () ->
364
+
let cell_id = next_cell_id t in
365
+
let promise, resolver = Lwt.wait () in
366
+
Hashtbl.add t.pending cell_id resolver;
367
+
send t (`Errors (cell_id, env_id, source));
368
+
promise >>= fun msg ->
369
+
match msg with
370
+
| Msg.ErrorList { errors; _ } ->
371
+
Lwt.return errors
372
+
| Msg.EvalError { message; _ } ->
373
+
Lwt.fail (EvalError message)
374
+
| _ -> Lwt.fail (Failure "Unexpected response")
375
+
376
+
(** Create environment *)
377
+
let create_env t env_id =
378
+
let open Lwt.Infix in
379
+
wait_ready t >>= fun () ->
380
+
let promise, resolver = Lwt.wait () in
381
+
Hashtbl.add t.pending_env env_id resolver;
382
+
send t (`CreateEnv env_id);
383
+
promise >>= fun msg ->
384
+
match msg with
385
+
| Msg.EnvCreated _ -> Lwt.return_unit
386
+
| Msg.InitError { message } -> Lwt.fail (InitError message)
387
+
| _ -> Lwt.fail (Failure "Unexpected response")
388
+
389
+
(** Destroy environment *)
390
+
let destroy_env t env_id =
391
+
let open Lwt.Infix in
392
+
wait_ready t >>= fun () ->
393
+
let promise, resolver = Lwt.wait () in
394
+
Hashtbl.add t.pending_env env_id resolver;
395
+
send t (`DestroyEnv env_id);
396
+
promise >>= fun msg ->
397
+
match msg with
398
+
| Msg.EnvDestroyed _ -> Lwt.return_unit
399
+
| Msg.InitError { message } -> Lwt.fail (InitError message)
400
+
| _ -> Lwt.fail (Failure "Unexpected response")
401
+
402
+
(** Terminate the worker *)
403
+
let terminate t =
404
+
Brr_worker.terminate t.worker
+297
js_top_worker/idl/message.ml
+297
js_top_worker/idl/message.ml
···
1
+
(** Message protocol for worker communication.
2
+
3
+
This module defines a simple JSON-based message protocol for communication
4
+
between the client and the OCaml toplevel worker. *)
5
+
6
+
open Js_of_ocaml
7
+
8
+
(** {1 Types} *)
9
+
10
+
type mime_val = {
11
+
mime_type : string;
12
+
data : string;
13
+
}
14
+
15
+
type position = {
16
+
pos_cnum : int;
17
+
pos_lnum : int;
18
+
pos_bol : int;
19
+
}
20
+
21
+
type location = {
22
+
loc_start : position;
23
+
loc_end : position;
24
+
}
25
+
26
+
type compl_entry = {
27
+
name : string;
28
+
kind : string;
29
+
desc : string;
30
+
info : string;
31
+
deprecated : bool;
32
+
}
33
+
34
+
type completions = {
35
+
from : int;
36
+
to_ : int;
37
+
entries : compl_entry list;
38
+
}
39
+
40
+
type error = {
41
+
kind : string;
42
+
loc : location;
43
+
main : string;
44
+
sub : string list;
45
+
source : string;
46
+
}
47
+
48
+
type type_info = {
49
+
loc : location;
50
+
type_str : string;
51
+
tail : string;
52
+
}
53
+
54
+
type init_config = {
55
+
findlib_requires : string list;
56
+
stdlib_dcs : string option;
57
+
findlib_index : string option;
58
+
}
59
+
60
+
(** {1 Client -> Worker messages} *)
61
+
62
+
type client_msg =
63
+
| Init of init_config
64
+
| Eval of { cell_id : int; env_id : string; code : string }
65
+
| Complete of { cell_id : int; env_id : string; source : string; position : int }
66
+
| TypeAt of { cell_id : int; env_id : string; source : string; position : int }
67
+
| Errors of { cell_id : int; env_id : string; source : string }
68
+
| CreateEnv of { env_id : string }
69
+
| DestroyEnv of { env_id : string }
70
+
71
+
(** {1 Worker -> Client messages} *)
72
+
73
+
type worker_msg =
74
+
| Ready
75
+
| InitError of { message : string }
76
+
| Output of {
77
+
cell_id : int;
78
+
stdout : string;
79
+
stderr : string;
80
+
caml_ppf : string;
81
+
mime_vals : mime_val list;
82
+
}
83
+
| OutputAt of {
84
+
cell_id : int;
85
+
loc : int; (* pos_cnum - character position after phrase *)
86
+
caml_ppf : string;
87
+
mime_vals : mime_val list;
88
+
}
89
+
| Completions of { cell_id : int; completions : completions }
90
+
| Types of { cell_id : int; types : type_info list }
91
+
| ErrorList of { cell_id : int; errors : error list }
92
+
| EvalError of { cell_id : int; message : string }
93
+
| EnvCreated of { env_id : string }
94
+
| EnvDestroyed of { env_id : string }
95
+
96
+
(** {1 JSON helpers} *)
97
+
98
+
let json_of_obj pairs =
99
+
Js.Unsafe.obj (Array.of_list (List.map (fun (k, v) -> (k, Js.Unsafe.inject v)) pairs))
100
+
101
+
let json_string s = Js.Unsafe.inject (Js.string s)
102
+
let json_int n = Js.Unsafe.inject n
103
+
let json_bool b = Js.Unsafe.inject (Js.bool b)
104
+
105
+
let json_array arr =
106
+
Js.Unsafe.inject (Js.array (Array.of_list arr))
107
+
108
+
let get_string obj key =
109
+
Js.to_string (Js.Unsafe.get obj (Js.string key))
110
+
111
+
let get_int obj key =
112
+
Js.Unsafe.get obj (Js.string key)
113
+
114
+
let get_string_opt obj key =
115
+
let v = Js.Unsafe.get obj (Js.string key) in
116
+
(* Handle both null and undefined *)
117
+
if Js.Opt.test v then
118
+
Some (Js.to_string v)
119
+
else
120
+
None
121
+
122
+
let get_array obj key =
123
+
let v = Js.Unsafe.get obj (Js.string key) in
124
+
(* Use Js.Opt.test to check if the value is not null *)
125
+
if Js.Opt.test v then
126
+
Js.to_array v
127
+
else
128
+
[||]
129
+
130
+
let get_string_array obj key =
131
+
Array.to_list (Array.map Js.to_string (get_array obj key))
132
+
133
+
(** {1 Worker message serialization} *)
134
+
135
+
let json_of_position p =
136
+
json_of_obj [
137
+
("pos_cnum", json_int p.pos_cnum);
138
+
("pos_lnum", json_int p.pos_lnum);
139
+
("pos_bol", json_int p.pos_bol);
140
+
]
141
+
142
+
let json_of_location loc =
143
+
json_of_obj [
144
+
("loc_start", Js.Unsafe.inject (json_of_position loc.loc_start));
145
+
("loc_end", Js.Unsafe.inject (json_of_position loc.loc_end));
146
+
]
147
+
148
+
let json_of_mime_val mv =
149
+
json_of_obj [
150
+
("mime_type", json_string mv.mime_type);
151
+
("data", json_string mv.data);
152
+
]
153
+
154
+
let json_of_compl_entry e =
155
+
json_of_obj [
156
+
("name", json_string e.name);
157
+
("kind", json_string e.kind);
158
+
("desc", json_string e.desc);
159
+
("info", json_string e.info);
160
+
("deprecated", json_bool e.deprecated);
161
+
]
162
+
163
+
let json_of_completions c =
164
+
json_of_obj [
165
+
("from", json_int c.from);
166
+
("to", json_int c.to_);
167
+
("entries", json_array (List.map (fun e -> Js.Unsafe.inject (json_of_compl_entry e)) c.entries));
168
+
]
169
+
170
+
let json_of_error e =
171
+
json_of_obj [
172
+
("kind", json_string e.kind);
173
+
("loc", Js.Unsafe.inject (json_of_location e.loc));
174
+
("main", json_string e.main);
175
+
("sub", json_array (List.map json_string e.sub));
176
+
("source", json_string e.source);
177
+
]
178
+
179
+
let json_of_type_info t =
180
+
json_of_obj [
181
+
("loc", Js.Unsafe.inject (json_of_location t.loc));
182
+
("type_str", json_string t.type_str);
183
+
("tail", json_string t.tail);
184
+
]
185
+
186
+
let json_of_worker_msg msg =
187
+
let obj = match msg with
188
+
| Ready ->
189
+
json_of_obj [("type", json_string "ready")]
190
+
| InitError { message } ->
191
+
json_of_obj [
192
+
("type", json_string "init_error");
193
+
("message", json_string message);
194
+
]
195
+
| Output { cell_id; stdout; stderr; caml_ppf; mime_vals } ->
196
+
json_of_obj [
197
+
("type", json_string "output");
198
+
("cell_id", json_int cell_id);
199
+
("stdout", json_string stdout);
200
+
("stderr", json_string stderr);
201
+
("caml_ppf", json_string caml_ppf);
202
+
("mime_vals", json_array (List.map (fun mv -> Js.Unsafe.inject (json_of_mime_val mv)) mime_vals));
203
+
]
204
+
| OutputAt { cell_id; loc; caml_ppf; mime_vals } ->
205
+
json_of_obj [
206
+
("type", json_string "output_at");
207
+
("cell_id", json_int cell_id);
208
+
("loc", json_int loc);
209
+
("caml_ppf", json_string caml_ppf);
210
+
("mime_vals", json_array (List.map (fun mv -> Js.Unsafe.inject (json_of_mime_val mv)) mime_vals));
211
+
]
212
+
| Completions { cell_id; completions } ->
213
+
json_of_obj [
214
+
("type", json_string "completions");
215
+
("cell_id", json_int cell_id);
216
+
("completions", Js.Unsafe.inject (json_of_completions completions));
217
+
]
218
+
| Types { cell_id; types } ->
219
+
json_of_obj [
220
+
("type", json_string "types");
221
+
("cell_id", json_int cell_id);
222
+
("types", json_array (List.map (fun t -> Js.Unsafe.inject (json_of_type_info t)) types));
223
+
]
224
+
| ErrorList { cell_id; errors } ->
225
+
json_of_obj [
226
+
("type", json_string "errors");
227
+
("cell_id", json_int cell_id);
228
+
("errors", json_array (List.map (fun e -> Js.Unsafe.inject (json_of_error e)) errors));
229
+
]
230
+
| EvalError { cell_id; message } ->
231
+
json_of_obj [
232
+
("type", json_string "eval_error");
233
+
("cell_id", json_int cell_id);
234
+
("message", json_string message);
235
+
]
236
+
| EnvCreated { env_id } ->
237
+
json_of_obj [
238
+
("type", json_string "env_created");
239
+
("env_id", json_string env_id);
240
+
]
241
+
| EnvDestroyed { env_id } ->
242
+
json_of_obj [
243
+
("type", json_string "env_destroyed");
244
+
("env_id", json_string env_id);
245
+
]
246
+
in
247
+
Js.to_string (Json.output obj)
248
+
249
+
(** {1 Client message parsing} *)
250
+
251
+
let parse_init_config obj =
252
+
{
253
+
findlib_requires = get_string_array obj "findlib_requires";
254
+
stdlib_dcs = get_string_opt obj "stdlib_dcs";
255
+
findlib_index = get_string_opt obj "findlib_index";
256
+
}
257
+
258
+
let client_msg_of_string s =
259
+
let obj = Json.unsafe_input (Js.string s) in
260
+
let typ = get_string obj "type" in
261
+
match typ with
262
+
| "init" ->
263
+
Init (parse_init_config obj)
264
+
| "eval" ->
265
+
Eval {
266
+
cell_id = get_int obj "cell_id";
267
+
env_id = get_string obj "env_id";
268
+
code = get_string obj "code";
269
+
}
270
+
| "complete" ->
271
+
Complete {
272
+
cell_id = get_int obj "cell_id";
273
+
env_id = get_string obj "env_id";
274
+
source = get_string obj "source";
275
+
position = get_int obj "position";
276
+
}
277
+
| "type_at" ->
278
+
TypeAt {
279
+
cell_id = get_int obj "cell_id";
280
+
env_id = get_string obj "env_id";
281
+
source = get_string obj "source";
282
+
position = get_int obj "position";
283
+
}
284
+
| "errors" ->
285
+
Errors {
286
+
cell_id = get_int obj "cell_id";
287
+
env_id = get_string obj "env_id";
288
+
source = get_string obj "source";
289
+
}
290
+
| "create_env" ->
291
+
CreateEnv { env_id = get_string obj "env_id" }
292
+
| "destroy_env" ->
293
+
DestroyEnv { env_id = get_string obj "env_id" }
294
+
| _ ->
295
+
failwith ("Unknown message type: " ^ typ)
296
+
297
+
let string_of_worker_msg = json_of_worker_msg
+341
js_top_worker/idl/toplevel_api.ml
+341
js_top_worker/idl/toplevel_api.ml
···
1
+
(** IDL for talking to the toplevel webworker *)
2
+
3
+
open Rpc
4
+
open Idl
5
+
6
+
let sockpath =
7
+
match Sys.getenv_opt "JS_TOP_WORKER_SOCK" with
8
+
| Some path -> path
9
+
| None -> "/tmp/js_top_worker.sock"
10
+
11
+
open Merlin_kernel
12
+
module Location = Ocaml_parsing.Location
13
+
14
+
type lexing_position = Lexing.position = {
15
+
pos_fname: string;
16
+
pos_lnum: int;
17
+
pos_bol: int;
18
+
pos_cnum: int;
19
+
} [@@deriving rpcty]
20
+
21
+
type location = Location.t = {
22
+
loc_start: lexing_position;
23
+
loc_end: lexing_position;
24
+
loc_ghost: bool;
25
+
} [@@deriving rpcty]
26
+
27
+
type location_error_source = Location.error_source =
28
+
| Lexer
29
+
| Parser
30
+
| Typer
31
+
| Warning
32
+
| Unknown
33
+
| Env
34
+
| Config [@@deriving rpcty]
35
+
36
+
type location_report_kind = Location.report_kind =
37
+
| Report_error
38
+
| Report_warning of string
39
+
| Report_warning_as_error of string
40
+
| Report_alert of string
41
+
| Report_alert_as_error of string [@@deriving rpcty]
42
+
43
+
type source = string [@@deriving rpcty]
44
+
45
+
(** CMIs are provided either statically or as URLs to be downloaded on demand *)
46
+
47
+
(** Dynamic cmis are loaded from beneath the given url. In addition the
48
+
top-level modules are specified, and prefixes for other modules. For
49
+
example, for the OCaml standard library, a user might pass:
50
+
51
+
{[
52
+
{ dcs_url="/static/stdlib";
53
+
dcs_toplevel_modules=["Stdlib"];
54
+
dcs_file_prefixes=["stdlib__"]; }
55
+
]}
56
+
57
+
In which case, merlin will expect to be able to download a valid file
58
+
from the url ["/static/stdlib/stdlib.cmi"] corresponding to the
59
+
specified toplevel module, and it will also attempt to download any
60
+
module with the prefix ["Stdlib__"] from the same base url, so for
61
+
example if an attempt is made to look up the module ["Stdlib__Foo"]
62
+
then merlin-js will attempt to download a file from the url
63
+
["/static/stdlib/stdlib__Foo.cmi"].
64
+
*)
65
+
66
+
type dynamic_cmis = {
67
+
dcs_url : string;
68
+
dcs_toplevel_modules : string list;
69
+
dcs_file_prefixes : string list;
70
+
}
71
+
72
+
and static_cmi = {
73
+
sc_name : string; (* capitalised, e.g. 'Stdlib' *)
74
+
sc_content : string;
75
+
}
76
+
77
+
and cmis = {
78
+
static_cmis : static_cmi list;
79
+
dynamic_cmis : dynamic_cmis list;
80
+
} [@@deriving rpcty]
81
+
82
+
type action =
83
+
| Complete_prefix of source * Msource.position
84
+
| Type_enclosing of source * Msource.position
85
+
| All_errors of source
86
+
| Add_cmis of cmis
87
+
88
+
type error = {
89
+
kind : location_report_kind;
90
+
loc: location;
91
+
main : string;
92
+
sub : string list;
93
+
source : location_error_source;
94
+
} [@@deriving rpcty]
95
+
96
+
type error_list = error list [@@deriving rpcty]
97
+
98
+
type kind_ty =
99
+
Constructor
100
+
| Keyword
101
+
| Label
102
+
| MethodCall
103
+
| Modtype
104
+
| Module
105
+
| Type
106
+
| Value
107
+
| Variant [@@deriving rpcty]
108
+
109
+
type query_protocol_compl_entry = {
110
+
name: string;
111
+
kind: kind_ty;
112
+
desc: string;
113
+
info: string;
114
+
deprecated: bool;
115
+
} [@@deriving rpcty]
116
+
117
+
118
+
type completions = {
119
+
from: int;
120
+
to_: int;
121
+
entries : query_protocol_compl_entry list
122
+
} [@@deriving rpcty]
123
+
124
+
type msource_position =
125
+
| Start
126
+
| Offset of int
127
+
| Logical of int * int
128
+
| End [@@deriving rpcty]
129
+
130
+
type is_tail_position =
131
+
| No | Tail_position | Tail_call [@@deriving rpcty]
132
+
133
+
type index_or_string =
134
+
| Index of int
135
+
| String of string [@@deriving rpcty]
136
+
137
+
138
+
type typed_enclosings = location * index_or_string * is_tail_position [@@deriving rpcty]
139
+
type typed_enclosings_list = typed_enclosings list [@@deriving rpcty]
140
+
let report_source_to_string = function
141
+
| Location.Lexer -> "lexer"
142
+
| Location.Parser -> "parser"
143
+
| Location.Typer -> "typer"
144
+
| Location.Warning -> "warning" (* todo incorrect ?*)
145
+
| Location.Unknown -> "unknown"
146
+
| Location.Env -> "env"
147
+
| Location.Config -> "config"
148
+
149
+
type highlight = { line1 : int; line2 : int; col1 : int; col2 : int }
150
+
[@@deriving rpcty]
151
+
(** An area to be highlighted *)
152
+
type encoding = Mime_printer.encoding = | Noencoding | Base64 [@@deriving rpcty]
153
+
154
+
type mime_val = Mime_printer.t = {
155
+
mime_type : string;
156
+
encoding : encoding;
157
+
data : string;
158
+
}
159
+
[@@deriving rpcty]
160
+
161
+
type exec_result = {
162
+
stdout : string option;
163
+
stderr : string option;
164
+
sharp_ppf : string option;
165
+
caml_ppf : string option;
166
+
highlight : highlight option;
167
+
mime_vals : mime_val list;
168
+
}
169
+
[@@deriving rpcty]
170
+
(** Represents the result of executing a toplevel phrase *)
171
+
172
+
type script_parts = (int * int) list (* Input length and output length *)
173
+
[@@deriving rpcty]
174
+
175
+
type exec_toplevel_result = {
176
+
script : string;
177
+
parts : script_parts;
178
+
mime_vals : mime_val list;
179
+
}
180
+
[@@deriving rpcty]
181
+
(** Represents the result of executing a toplevel script *)
182
+
183
+
type cma = {
184
+
url : string; (** URL where the cma is available *)
185
+
fn : string; (** Name of the 'wrapping' function *)
186
+
}
187
+
[@@deriving rpcty]
188
+
189
+
type init_config = {
190
+
findlib_requires : string list; (** Findlib packages to require *)
191
+
stdlib_dcs : string option; (** URL to the dynamic cmis for the OCaml standard library *)
192
+
findlib_index : string option; (** URL to the findlib_index file. Defaults to "findlib_index" *)
193
+
execute : bool (** Whether this session should support execution or not. *)
194
+
} [@@deriving rpcty]
195
+
type err = InternalError of string [@@deriving rpcty]
196
+
197
+
type opt_id = string option [@@deriving rpcty]
198
+
199
+
type env_id = string [@@deriving rpcty]
200
+
(** Environment identifier. If empty string, uses the default environment. *)
201
+
202
+
type env_id_list = string list [@@deriving rpcty]
203
+
(** List of environment identifiers *)
204
+
205
+
type dependencies = string list [@@deriving rpcty]
206
+
(** The ids of the cells that are dependencies *)
207
+
208
+
module E = Idl.Error.Make (struct
209
+
type t = err
210
+
211
+
let t = err
212
+
let internal_error_of e = Some (InternalError (Printexc.to_string e))
213
+
end)
214
+
215
+
let err = E.error
216
+
217
+
module Make (R : RPC) = struct
218
+
open R
219
+
220
+
let description =
221
+
Interface.
222
+
{
223
+
name = "Toplevel";
224
+
namespace = None;
225
+
description =
226
+
[ "Functions for manipulating the toplevel worker thread" ];
227
+
version = (1, 0, 0);
228
+
}
229
+
230
+
let implementation = implement description
231
+
let unit_p = Param.mk Types.unit
232
+
let phrase_p = Param.mk ~name:"string" ~description:["The OCaml phrase to execute"] Types.string
233
+
let id_p = Param.mk opt_id
234
+
let env_id_p = Param.mk ~name:"env_id" ~description:["Environment ID (empty string for default)"] env_id
235
+
let env_id_list_p = Param.mk env_id_list
236
+
let dependencies_p = Param.mk dependencies
237
+
let exec_result_p = Param.mk exec_result
238
+
239
+
let source_p = Param.mk source
240
+
let position_p = Param.mk msource_position
241
+
242
+
let completions_p = Param.mk completions
243
+
let error_list_p = Param.mk error_list
244
+
let typed_enclosings_p = Param.mk typed_enclosings_list
245
+
let is_toplevel_p = Param.mk ~name:"is_toplevel" Types.bool
246
+
247
+
let toplevel_script_p = Param.mk ~description:[
248
+
"A toplevel script is a sequence of toplevel phrases interspersed with";
249
+
"The output from the toplevel. Each phase must be preceded by '# ', and";
250
+
"the output from the toplevel is indented by 2 spaces."
251
+
] Types.string
252
+
253
+
let exec_toplevel_result_p = Param.mk exec_toplevel_result
254
+
255
+
let init_libs =
256
+
Param.mk ~name:"init_libs"
257
+
~description:
258
+
[
259
+
"Configuration for the toplevel.";
260
+
]
261
+
init_config
262
+
263
+
let init =
264
+
declare "init"
265
+
[ "Initialise the toplevel. This must be called before any other API." ]
266
+
(init_libs @-> returning unit_p err)
267
+
268
+
(** {2 Environment Management} *)
269
+
270
+
let create_env =
271
+
declare "create_env"
272
+
[
273
+
"Create a new isolated execution environment with the given ID.";
274
+
"Returns unit on success. The environment must be set up with";
275
+
"setup_env before use.";
276
+
]
277
+
(env_id_p @-> returning unit_p err)
278
+
279
+
let destroy_env =
280
+
declare "destroy_env"
281
+
[
282
+
"Destroy an execution environment, freeing its resources.";
283
+
"The environment ID must exist.";
284
+
]
285
+
(env_id_p @-> returning unit_p err)
286
+
287
+
let list_envs =
288
+
declare "list_envs"
289
+
[ "List all existing environment IDs." ]
290
+
(unit_p @-> returning env_id_list_p err)
291
+
292
+
let setup =
293
+
declare "setup"
294
+
[
295
+
"Start the toplevel for the given environment. Return value is the";
296
+
"initial blurb printed when starting a toplevel. Note that the";
297
+
"toplevel must be initialised first. If env_id is None, uses the";
298
+
"default environment.";
299
+
]
300
+
(env_id_p @-> returning exec_result_p err)
301
+
302
+
let exec =
303
+
declare "exec"
304
+
[
305
+
"Execute a phrase using the toplevel. The toplevel must have been";
306
+
"initialised first. If env_id is None, uses the default environment.";
307
+
]
308
+
(env_id_p @-> phrase_p @-> returning exec_result_p err)
309
+
310
+
let exec_toplevel =
311
+
declare "exec_toplevel"
312
+
[
313
+
"Execute a toplevel script. The toplevel must have been";
314
+
"initialised first. Returns the updated toplevel script.";
315
+
"If env_id is None, uses the default environment.";
316
+
]
317
+
(env_id_p @-> toplevel_script_p @-> returning exec_toplevel_result_p err)
318
+
319
+
let complete_prefix =
320
+
declare "complete_prefix"
321
+
[
322
+
"Complete a prefix. If env_id is None, uses the default environment.";
323
+
]
324
+
(env_id_p @-> id_p @-> dependencies_p @-> is_toplevel_p @-> source_p @-> position_p @-> returning completions_p err)
325
+
326
+
let query_errors =
327
+
declare "query_errors"
328
+
[
329
+
"Query the errors in the given source.";
330
+
"If env_id is None, uses the default environment.";
331
+
]
332
+
(env_id_p @-> id_p @-> dependencies_p @-> is_toplevel_p @-> source_p @-> returning error_list_p err)
333
+
334
+
let type_enclosing =
335
+
declare "type_enclosing"
336
+
[
337
+
"Get the type of the enclosing expression.";
338
+
"If env_id is None, uses the default environment.";
339
+
]
340
+
(env_id_p @-> id_p @-> dependencies_p @-> is_toplevel_p @-> source_p @-> position_p @-> returning typed_enclosings_p err)
341
+
end
+2310
js_top_worker/idl/toplevel_api_gen.ml
+2310
js_top_worker/idl/toplevel_api_gen.ml
···
1
+
[@@@ocaml.ppx.context
2
+
{
3
+
tool_name = "ppx_driver";
4
+
include_dirs = [];
5
+
hidden_include_dirs = [];
6
+
load_path = ([], []);
7
+
open_modules = [];
8
+
for_package = None;
9
+
debug = false;
10
+
use_threads = false;
11
+
use_vmthreads = false;
12
+
recursive_types = false;
13
+
principal = false;
14
+
no_alias_deps = false;
15
+
unboxed_types = false;
16
+
unsafe_string = false;
17
+
cookies = [("library-name", "js_top_worker_rpc_def")]
18
+
}]
19
+
[@@@ocaml.text " IDL for talking to the toplevel webworker "]
20
+
open Rpc
21
+
open Idl
22
+
let sockpath =
23
+
match Sys.getenv_opt "JS_TOP_WORKER_SOCK" with
24
+
| Some path -> path
25
+
| None -> "/tmp/js_top_worker.sock"
26
+
open Merlin_kernel
27
+
module Location = Ocaml_parsing.Location
28
+
type lexing_position = Lexing.position =
29
+
{
30
+
pos_fname: string ;
31
+
pos_lnum: int ;
32
+
pos_bol: int ;
33
+
pos_cnum: int }[@@deriving rpcty]
34
+
include
35
+
struct
36
+
let _ = fun (_ : lexing_position) -> ()
37
+
let rec lexing_position_pos_fname : (_, lexing_position) Rpc.Types.field
38
+
=
39
+
{
40
+
Rpc.Types.fname = "pos_fname";
41
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
42
+
Rpc.Types.fdefault = None;
43
+
Rpc.Types.fdescription = [];
44
+
Rpc.Types.fversion = None;
45
+
Rpc.Types.fget = (fun _r -> _r.pos_fname);
46
+
Rpc.Types.fset = (fun v _s -> { _s with pos_fname = v })
47
+
}
48
+
and lexing_position_pos_lnum : (_, lexing_position) Rpc.Types.field =
49
+
{
50
+
Rpc.Types.fname = "pos_lnum";
51
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
52
+
Rpc.Types.fdefault = None;
53
+
Rpc.Types.fdescription = [];
54
+
Rpc.Types.fversion = None;
55
+
Rpc.Types.fget = (fun _r -> _r.pos_lnum);
56
+
Rpc.Types.fset = (fun v _s -> { _s with pos_lnum = v })
57
+
}
58
+
and lexing_position_pos_bol : (_, lexing_position) Rpc.Types.field =
59
+
{
60
+
Rpc.Types.fname = "pos_bol";
61
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
62
+
Rpc.Types.fdefault = None;
63
+
Rpc.Types.fdescription = [];
64
+
Rpc.Types.fversion = None;
65
+
Rpc.Types.fget = (fun _r -> _r.pos_bol);
66
+
Rpc.Types.fset = (fun v _s -> { _s with pos_bol = v })
67
+
}
68
+
and lexing_position_pos_cnum : (_, lexing_position) Rpc.Types.field =
69
+
{
70
+
Rpc.Types.fname = "pos_cnum";
71
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
72
+
Rpc.Types.fdefault = None;
73
+
Rpc.Types.fdescription = [];
74
+
Rpc.Types.fversion = None;
75
+
Rpc.Types.fget = (fun _r -> _r.pos_cnum);
76
+
Rpc.Types.fset = (fun v _s -> { _s with pos_cnum = v })
77
+
}
78
+
and typ_of_lexing_position =
79
+
Rpc.Types.Struct
80
+
({
81
+
Rpc.Types.fields =
82
+
[Rpc.Types.BoxedField lexing_position_pos_fname;
83
+
Rpc.Types.BoxedField lexing_position_pos_lnum;
84
+
Rpc.Types.BoxedField lexing_position_pos_bol;
85
+
Rpc.Types.BoxedField lexing_position_pos_cnum];
86
+
Rpc.Types.sname = "lexing_position";
87
+
Rpc.Types.version = None;
88
+
Rpc.Types.constructor =
89
+
(fun getter ->
90
+
let open Rresult.R in
91
+
(getter.Rpc.Types.field_get "pos_cnum"
92
+
(let open Rpc.Types in Basic Int))
93
+
>>=
94
+
(fun lexing_position_pos_cnum ->
95
+
(getter.Rpc.Types.field_get "pos_bol"
96
+
(let open Rpc.Types in Basic Int))
97
+
>>=
98
+
(fun lexing_position_pos_bol ->
99
+
(getter.Rpc.Types.field_get "pos_lnum"
100
+
(let open Rpc.Types in Basic Int))
101
+
>>=
102
+
(fun lexing_position_pos_lnum ->
103
+
(getter.Rpc.Types.field_get "pos_fname"
104
+
(let open Rpc.Types in Basic String))
105
+
>>=
106
+
(fun lexing_position_pos_fname ->
107
+
return
108
+
{
109
+
pos_fname =
110
+
lexing_position_pos_fname;
111
+
pos_lnum = lexing_position_pos_lnum;
112
+
pos_bol = lexing_position_pos_bol;
113
+
pos_cnum = lexing_position_pos_cnum
114
+
})))))
115
+
} : lexing_position Rpc.Types.structure)
116
+
and lexing_position =
117
+
{
118
+
Rpc.Types.name = "lexing_position";
119
+
Rpc.Types.description = [];
120
+
Rpc.Types.ty = typ_of_lexing_position
121
+
}
122
+
let _ = lexing_position_pos_fname
123
+
and _ = lexing_position_pos_lnum
124
+
and _ = lexing_position_pos_bol
125
+
and _ = lexing_position_pos_cnum
126
+
and _ = typ_of_lexing_position
127
+
and _ = lexing_position
128
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
129
+
type location = Location.t =
130
+
{
131
+
loc_start: lexing_position ;
132
+
loc_end: lexing_position ;
133
+
loc_ghost: bool }[@@deriving rpcty]
134
+
include
135
+
struct
136
+
let _ = fun (_ : location) -> ()
137
+
let rec location_loc_start : (_, location) Rpc.Types.field =
138
+
{
139
+
Rpc.Types.fname = "loc_start";
140
+
Rpc.Types.field = typ_of_lexing_position;
141
+
Rpc.Types.fdefault = None;
142
+
Rpc.Types.fdescription = [];
143
+
Rpc.Types.fversion = None;
144
+
Rpc.Types.fget = (fun _r -> _r.loc_start);
145
+
Rpc.Types.fset = (fun v _s -> { _s with loc_start = v })
146
+
}
147
+
and location_loc_end : (_, location) Rpc.Types.field =
148
+
{
149
+
Rpc.Types.fname = "loc_end";
150
+
Rpc.Types.field = typ_of_lexing_position;
151
+
Rpc.Types.fdefault = None;
152
+
Rpc.Types.fdescription = [];
153
+
Rpc.Types.fversion = None;
154
+
Rpc.Types.fget = (fun _r -> _r.loc_end);
155
+
Rpc.Types.fset = (fun v _s -> { _s with loc_end = v })
156
+
}
157
+
and location_loc_ghost : (_, location) Rpc.Types.field =
158
+
{
159
+
Rpc.Types.fname = "loc_ghost";
160
+
Rpc.Types.field = (let open Rpc.Types in Basic Bool);
161
+
Rpc.Types.fdefault = None;
162
+
Rpc.Types.fdescription = [];
163
+
Rpc.Types.fversion = None;
164
+
Rpc.Types.fget = (fun _r -> _r.loc_ghost);
165
+
Rpc.Types.fset = (fun v _s -> { _s with loc_ghost = v })
166
+
}
167
+
and typ_of_location =
168
+
Rpc.Types.Struct
169
+
({
170
+
Rpc.Types.fields =
171
+
[Rpc.Types.BoxedField location_loc_start;
172
+
Rpc.Types.BoxedField location_loc_end;
173
+
Rpc.Types.BoxedField location_loc_ghost];
174
+
Rpc.Types.sname = "location";
175
+
Rpc.Types.version = None;
176
+
Rpc.Types.constructor =
177
+
(fun getter ->
178
+
let open Rresult.R in
179
+
(getter.Rpc.Types.field_get "loc_ghost"
180
+
(let open Rpc.Types in Basic Bool))
181
+
>>=
182
+
(fun location_loc_ghost ->
183
+
(getter.Rpc.Types.field_get "loc_end"
184
+
typ_of_lexing_position)
185
+
>>=
186
+
(fun location_loc_end ->
187
+
(getter.Rpc.Types.field_get "loc_start"
188
+
typ_of_lexing_position)
189
+
>>=
190
+
(fun location_loc_start ->
191
+
return
192
+
{
193
+
loc_start = location_loc_start;
194
+
loc_end = location_loc_end;
195
+
loc_ghost = location_loc_ghost
196
+
}))))
197
+
} : location Rpc.Types.structure)
198
+
and location =
199
+
{
200
+
Rpc.Types.name = "location";
201
+
Rpc.Types.description = [];
202
+
Rpc.Types.ty = typ_of_location
203
+
}
204
+
let _ = location_loc_start
205
+
and _ = location_loc_end
206
+
and _ = location_loc_ghost
207
+
and _ = typ_of_location
208
+
and _ = location
209
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
210
+
type location_error_source = Location.error_source =
211
+
| Lexer
212
+
| Parser
213
+
| Typer
214
+
| Warning
215
+
| Unknown
216
+
| Env
217
+
| Config [@@deriving rpcty]
218
+
include
219
+
struct
220
+
let _ = fun (_ : location_error_source) -> ()
221
+
let rec typ_of_location_error_source =
222
+
Rpc.Types.Variant
223
+
({
224
+
Rpc.Types.vname = "location_error_source";
225
+
Rpc.Types.variants =
226
+
[BoxedTag
227
+
{
228
+
Rpc.Types.tname = "Lexer";
229
+
Rpc.Types.tcontents = Unit;
230
+
Rpc.Types.tversion = None;
231
+
Rpc.Types.tdescription = [];
232
+
Rpc.Types.tpreview =
233
+
((function | Lexer -> Some () | _ -> None));
234
+
Rpc.Types.treview = ((function | () -> Lexer))
235
+
};
236
+
BoxedTag
237
+
{
238
+
Rpc.Types.tname = "Parser";
239
+
Rpc.Types.tcontents = Unit;
240
+
Rpc.Types.tversion = None;
241
+
Rpc.Types.tdescription = [];
242
+
Rpc.Types.tpreview =
243
+
((function | Parser -> Some () | _ -> None));
244
+
Rpc.Types.treview = ((function | () -> Parser))
245
+
};
246
+
BoxedTag
247
+
{
248
+
Rpc.Types.tname = "Typer";
249
+
Rpc.Types.tcontents = Unit;
250
+
Rpc.Types.tversion = None;
251
+
Rpc.Types.tdescription = [];
252
+
Rpc.Types.tpreview =
253
+
((function | Typer -> Some () | _ -> None));
254
+
Rpc.Types.treview = ((function | () -> Typer))
255
+
};
256
+
BoxedTag
257
+
{
258
+
Rpc.Types.tname = "Warning";
259
+
Rpc.Types.tcontents = Unit;
260
+
Rpc.Types.tversion = None;
261
+
Rpc.Types.tdescription = [];
262
+
Rpc.Types.tpreview =
263
+
((function | Warning -> Some () | _ -> None));
264
+
Rpc.Types.treview = ((function | () -> Warning))
265
+
};
266
+
BoxedTag
267
+
{
268
+
Rpc.Types.tname = "Unknown";
269
+
Rpc.Types.tcontents = Unit;
270
+
Rpc.Types.tversion = None;
271
+
Rpc.Types.tdescription = [];
272
+
Rpc.Types.tpreview =
273
+
((function | Unknown -> Some () | _ -> None));
274
+
Rpc.Types.treview = ((function | () -> Unknown))
275
+
};
276
+
BoxedTag
277
+
{
278
+
Rpc.Types.tname = "Env";
279
+
Rpc.Types.tcontents = Unit;
280
+
Rpc.Types.tversion = None;
281
+
Rpc.Types.tdescription = [];
282
+
Rpc.Types.tpreview =
283
+
((function | Env -> Some () | _ -> None));
284
+
Rpc.Types.treview = ((function | () -> Env))
285
+
};
286
+
BoxedTag
287
+
{
288
+
Rpc.Types.tname = "Config";
289
+
Rpc.Types.tcontents = Unit;
290
+
Rpc.Types.tversion = None;
291
+
Rpc.Types.tdescription = [];
292
+
Rpc.Types.tpreview =
293
+
((function | Config -> Some () | _ -> None));
294
+
Rpc.Types.treview = ((function | () -> Config))
295
+
}];
296
+
Rpc.Types.vdefault = None;
297
+
Rpc.Types.vversion = None;
298
+
Rpc.Types.vconstructor =
299
+
(fun s' t ->
300
+
let s = String.lowercase_ascii s' in
301
+
match s with
302
+
| "lexer" ->
303
+
Rresult.R.bind (t.tget Unit)
304
+
(function | () -> Rresult.R.ok Lexer)
305
+
| "parser" ->
306
+
Rresult.R.bind (t.tget Unit)
307
+
(function | () -> Rresult.R.ok Parser)
308
+
| "typer" ->
309
+
Rresult.R.bind (t.tget Unit)
310
+
(function | () -> Rresult.R.ok Typer)
311
+
| "warning" ->
312
+
Rresult.R.bind (t.tget Unit)
313
+
(function | () -> Rresult.R.ok Warning)
314
+
| "unknown" ->
315
+
Rresult.R.bind (t.tget Unit)
316
+
(function | () -> Rresult.R.ok Unknown)
317
+
| "env" ->
318
+
Rresult.R.bind (t.tget Unit)
319
+
(function | () -> Rresult.R.ok Env)
320
+
| "config" ->
321
+
Rresult.R.bind (t.tget Unit)
322
+
(function | () -> Rresult.R.ok Config)
323
+
| _ ->
324
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
325
+
} : location_error_source Rpc.Types.variant)
326
+
and location_error_source =
327
+
{
328
+
Rpc.Types.name = "location_error_source";
329
+
Rpc.Types.description = [];
330
+
Rpc.Types.ty = typ_of_location_error_source
331
+
}
332
+
let _ = typ_of_location_error_source
333
+
and _ = location_error_source
334
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
335
+
type location_report_kind = Location.report_kind =
336
+
| Report_error
337
+
| Report_warning of string
338
+
| Report_warning_as_error of string
339
+
| Report_alert of string
340
+
| Report_alert_as_error of string [@@deriving rpcty]
341
+
include
342
+
struct
343
+
let _ = fun (_ : location_report_kind) -> ()
344
+
let rec typ_of_location_report_kind =
345
+
Rpc.Types.Variant
346
+
({
347
+
Rpc.Types.vname = "location_report_kind";
348
+
Rpc.Types.variants =
349
+
[BoxedTag
350
+
{
351
+
Rpc.Types.tname = "Report_error";
352
+
Rpc.Types.tcontents = Unit;
353
+
Rpc.Types.tversion = None;
354
+
Rpc.Types.tdescription = [];
355
+
Rpc.Types.tpreview =
356
+
((function | Report_error -> Some () | _ -> None));
357
+
Rpc.Types.treview = ((function | () -> Report_error))
358
+
};
359
+
BoxedTag
360
+
{
361
+
Rpc.Types.tname = "Report_warning";
362
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
363
+
Rpc.Types.tversion = None;
364
+
Rpc.Types.tdescription = [];
365
+
Rpc.Types.tpreview =
366
+
((function | Report_warning a0 -> Some a0 | _ -> None));
367
+
Rpc.Types.treview = ((function | a0 -> Report_warning a0))
368
+
};
369
+
BoxedTag
370
+
{
371
+
Rpc.Types.tname = "Report_warning_as_error";
372
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
373
+
Rpc.Types.tversion = None;
374
+
Rpc.Types.tdescription = [];
375
+
Rpc.Types.tpreview =
376
+
((function
377
+
| Report_warning_as_error a0 -> Some a0
378
+
| _ -> None));
379
+
Rpc.Types.treview =
380
+
((function | a0 -> Report_warning_as_error a0))
381
+
};
382
+
BoxedTag
383
+
{
384
+
Rpc.Types.tname = "Report_alert";
385
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
386
+
Rpc.Types.tversion = None;
387
+
Rpc.Types.tdescription = [];
388
+
Rpc.Types.tpreview =
389
+
((function | Report_alert a0 -> Some a0 | _ -> None));
390
+
Rpc.Types.treview = ((function | a0 -> Report_alert a0))
391
+
};
392
+
BoxedTag
393
+
{
394
+
Rpc.Types.tname = "Report_alert_as_error";
395
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
396
+
Rpc.Types.tversion = None;
397
+
Rpc.Types.tdescription = [];
398
+
Rpc.Types.tpreview =
399
+
((function
400
+
| Report_alert_as_error a0 -> Some a0
401
+
| _ -> None));
402
+
Rpc.Types.treview =
403
+
((function | a0 -> Report_alert_as_error a0))
404
+
}];
405
+
Rpc.Types.vdefault = None;
406
+
Rpc.Types.vversion = None;
407
+
Rpc.Types.vconstructor =
408
+
(fun s' t ->
409
+
let s = String.lowercase_ascii s' in
410
+
match s with
411
+
| "report_error" ->
412
+
Rresult.R.bind (t.tget Unit)
413
+
(function | () -> Rresult.R.ok Report_error)
414
+
| "report_warning" ->
415
+
Rresult.R.bind
416
+
(t.tget (let open Rpc.Types in Basic String))
417
+
(function | a0 -> Rresult.R.ok (Report_warning a0))
418
+
| "report_warning_as_error" ->
419
+
Rresult.R.bind
420
+
(t.tget (let open Rpc.Types in Basic String))
421
+
(function
422
+
| a0 -> Rresult.R.ok (Report_warning_as_error a0))
423
+
| "report_alert" ->
424
+
Rresult.R.bind
425
+
(t.tget (let open Rpc.Types in Basic String))
426
+
(function | a0 -> Rresult.R.ok (Report_alert a0))
427
+
| "report_alert_as_error" ->
428
+
Rresult.R.bind
429
+
(t.tget (let open Rpc.Types in Basic String))
430
+
(function
431
+
| a0 -> Rresult.R.ok (Report_alert_as_error a0))
432
+
| _ ->
433
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
434
+
} : location_report_kind Rpc.Types.variant)
435
+
and location_report_kind =
436
+
{
437
+
Rpc.Types.name = "location_report_kind";
438
+
Rpc.Types.description = [];
439
+
Rpc.Types.ty = typ_of_location_report_kind
440
+
}
441
+
let _ = typ_of_location_report_kind
442
+
and _ = location_report_kind
443
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
444
+
type source = string[@@deriving rpcty]
445
+
include
446
+
struct
447
+
let _ = fun (_ : source) -> ()
448
+
let rec typ_of_source = let open Rpc.Types in Basic String
449
+
and source =
450
+
{
451
+
Rpc.Types.name = "source";
452
+
Rpc.Types.description = [];
453
+
Rpc.Types.ty = typ_of_source
454
+
}
455
+
let _ = typ_of_source
456
+
and _ = source
457
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
458
+
[@@@ocaml.text
459
+
" CMIs are provided either statically or as URLs to be downloaded on demand "]
460
+
[@@@ocaml.text
461
+
" Dynamic cmis are loaded from beneath the given url. In addition the\n top-level modules are specified, and prefixes for other modules. For\n example, for the OCaml standard library, a user might pass:\n\n {[\n { dcs_url=\"/static/stdlib\";\n dcs_toplevel_modules=[\"Stdlib\"];\n dcs_file_prefixes=[\"stdlib__\"]; }\n ]}\n\n In which case, merlin will expect to be able to download a valid file\n from the url [\"/static/stdlib/stdlib.cmi\"] corresponding to the\n specified toplevel module, and it will also attempt to download any\n module with the prefix [\"Stdlib__\"] from the same base url, so for\n example if an attempt is made to look up the module [\"Stdlib__Foo\"]\n then merlin-js will attempt to download a file from the url\n [\"/static/stdlib/stdlib__Foo.cmi\"].\n "]
462
+
type dynamic_cmis =
463
+
{
464
+
dcs_url: string ;
465
+
dcs_toplevel_modules: string list ;
466
+
dcs_file_prefixes: string list }
467
+
and static_cmi = {
468
+
sc_name: string ;
469
+
sc_content: string }
470
+
and cmis = {
471
+
static_cmis: static_cmi list ;
472
+
dynamic_cmis: dynamic_cmis list }[@@deriving rpcty]
473
+
include
474
+
struct
475
+
let _ = fun (_ : dynamic_cmis) -> ()
476
+
let _ = fun (_ : static_cmi) -> ()
477
+
let _ = fun (_ : cmis) -> ()
478
+
let rec dynamic_cmis_dcs_url : (_, dynamic_cmis) Rpc.Types.field =
479
+
{
480
+
Rpc.Types.fname = "dcs_url";
481
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
482
+
Rpc.Types.fdefault = None;
483
+
Rpc.Types.fdescription = [];
484
+
Rpc.Types.fversion = None;
485
+
Rpc.Types.fget = (fun _r -> _r.dcs_url);
486
+
Rpc.Types.fset = (fun v _s -> { _s with dcs_url = v })
487
+
}
488
+
and dynamic_cmis_dcs_toplevel_modules : (_, dynamic_cmis) Rpc.Types.field
489
+
=
490
+
{
491
+
Rpc.Types.fname = "dcs_toplevel_modules";
492
+
Rpc.Types.field =
493
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
494
+
Rpc.Types.fdefault = None;
495
+
Rpc.Types.fdescription = [];
496
+
Rpc.Types.fversion = None;
497
+
Rpc.Types.fget = (fun _r -> _r.dcs_toplevel_modules);
498
+
Rpc.Types.fset = (fun v _s -> { _s with dcs_toplevel_modules = v })
499
+
}
500
+
and dynamic_cmis_dcs_file_prefixes : (_, dynamic_cmis) Rpc.Types.field =
501
+
{
502
+
Rpc.Types.fname = "dcs_file_prefixes";
503
+
Rpc.Types.field =
504
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
505
+
Rpc.Types.fdefault = None;
506
+
Rpc.Types.fdescription = [];
507
+
Rpc.Types.fversion = None;
508
+
Rpc.Types.fget = (fun _r -> _r.dcs_file_prefixes);
509
+
Rpc.Types.fset = (fun v _s -> { _s with dcs_file_prefixes = v })
510
+
}
511
+
and typ_of_dynamic_cmis =
512
+
Rpc.Types.Struct
513
+
({
514
+
Rpc.Types.fields =
515
+
[Rpc.Types.BoxedField dynamic_cmis_dcs_url;
516
+
Rpc.Types.BoxedField dynamic_cmis_dcs_toplevel_modules;
517
+
Rpc.Types.BoxedField dynamic_cmis_dcs_file_prefixes];
518
+
Rpc.Types.sname = "dynamic_cmis";
519
+
Rpc.Types.version = None;
520
+
Rpc.Types.constructor =
521
+
(fun getter ->
522
+
let open Rresult.R in
523
+
(getter.Rpc.Types.field_get "dcs_file_prefixes"
524
+
(Rpc.Types.List (let open Rpc.Types in Basic String)))
525
+
>>=
526
+
(fun dynamic_cmis_dcs_file_prefixes ->
527
+
(getter.Rpc.Types.field_get "dcs_toplevel_modules"
528
+
(Rpc.Types.List
529
+
(let open Rpc.Types in Basic String)))
530
+
>>=
531
+
(fun dynamic_cmis_dcs_toplevel_modules ->
532
+
(getter.Rpc.Types.field_get "dcs_url"
533
+
(let open Rpc.Types in Basic String))
534
+
>>=
535
+
(fun dynamic_cmis_dcs_url ->
536
+
return
537
+
{
538
+
dcs_url = dynamic_cmis_dcs_url;
539
+
dcs_toplevel_modules =
540
+
dynamic_cmis_dcs_toplevel_modules;
541
+
dcs_file_prefixes =
542
+
dynamic_cmis_dcs_file_prefixes
543
+
}))))
544
+
} : dynamic_cmis Rpc.Types.structure)
545
+
and dynamic_cmis =
546
+
{
547
+
Rpc.Types.name = "dynamic_cmis";
548
+
Rpc.Types.description = [];
549
+
Rpc.Types.ty = typ_of_dynamic_cmis
550
+
}
551
+
and static_cmi_sc_name : (_, static_cmi) Rpc.Types.field =
552
+
{
553
+
Rpc.Types.fname = "sc_name";
554
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
555
+
Rpc.Types.fdefault = None;
556
+
Rpc.Types.fdescription = [];
557
+
Rpc.Types.fversion = None;
558
+
Rpc.Types.fget = (fun _r -> _r.sc_name);
559
+
Rpc.Types.fset = (fun v _s -> { _s with sc_name = v })
560
+
}
561
+
and static_cmi_sc_content : (_, static_cmi) Rpc.Types.field =
562
+
{
563
+
Rpc.Types.fname = "sc_content";
564
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
565
+
Rpc.Types.fdefault = None;
566
+
Rpc.Types.fdescription = [];
567
+
Rpc.Types.fversion = None;
568
+
Rpc.Types.fget = (fun _r -> _r.sc_content);
569
+
Rpc.Types.fset = (fun v _s -> { _s with sc_content = v })
570
+
}
571
+
and typ_of_static_cmi =
572
+
Rpc.Types.Struct
573
+
({
574
+
Rpc.Types.fields =
575
+
[Rpc.Types.BoxedField static_cmi_sc_name;
576
+
Rpc.Types.BoxedField static_cmi_sc_content];
577
+
Rpc.Types.sname = "static_cmi";
578
+
Rpc.Types.version = None;
579
+
Rpc.Types.constructor =
580
+
(fun getter ->
581
+
let open Rresult.R in
582
+
(getter.Rpc.Types.field_get "sc_content"
583
+
(let open Rpc.Types in Basic String))
584
+
>>=
585
+
(fun static_cmi_sc_content ->
586
+
(getter.Rpc.Types.field_get "sc_name"
587
+
(let open Rpc.Types in Basic String))
588
+
>>=
589
+
(fun static_cmi_sc_name ->
590
+
return
591
+
{
592
+
sc_name = static_cmi_sc_name;
593
+
sc_content = static_cmi_sc_content
594
+
})))
595
+
} : static_cmi Rpc.Types.structure)
596
+
and static_cmi =
597
+
{
598
+
Rpc.Types.name = "static_cmi";
599
+
Rpc.Types.description = [];
600
+
Rpc.Types.ty = typ_of_static_cmi
601
+
}
602
+
and cmis_static_cmis : (_, cmis) Rpc.Types.field =
603
+
{
604
+
Rpc.Types.fname = "static_cmis";
605
+
Rpc.Types.field = (Rpc.Types.List typ_of_static_cmi);
606
+
Rpc.Types.fdefault = None;
607
+
Rpc.Types.fdescription = [];
608
+
Rpc.Types.fversion = None;
609
+
Rpc.Types.fget = (fun _r -> _r.static_cmis);
610
+
Rpc.Types.fset = (fun v _s -> { _s with static_cmis = v })
611
+
}
612
+
and cmis_dynamic_cmis : (_, cmis) Rpc.Types.field =
613
+
{
614
+
Rpc.Types.fname = "dynamic_cmis";
615
+
Rpc.Types.field = (Rpc.Types.List typ_of_dynamic_cmis);
616
+
Rpc.Types.fdefault = None;
617
+
Rpc.Types.fdescription = [];
618
+
Rpc.Types.fversion = None;
619
+
Rpc.Types.fget = (fun _r -> _r.dynamic_cmis);
620
+
Rpc.Types.fset = (fun v _s -> { _s with dynamic_cmis = v })
621
+
}
622
+
and typ_of_cmis =
623
+
Rpc.Types.Struct
624
+
({
625
+
Rpc.Types.fields =
626
+
[Rpc.Types.BoxedField cmis_static_cmis;
627
+
Rpc.Types.BoxedField cmis_dynamic_cmis];
628
+
Rpc.Types.sname = "cmis";
629
+
Rpc.Types.version = None;
630
+
Rpc.Types.constructor =
631
+
(fun getter ->
632
+
let open Rresult.R in
633
+
(getter.Rpc.Types.field_get "dynamic_cmis"
634
+
(Rpc.Types.List typ_of_dynamic_cmis))
635
+
>>=
636
+
(fun cmis_dynamic_cmis ->
637
+
(getter.Rpc.Types.field_get "static_cmis"
638
+
(Rpc.Types.List typ_of_static_cmi))
639
+
>>=
640
+
(fun cmis_static_cmis ->
641
+
return
642
+
{
643
+
static_cmis = cmis_static_cmis;
644
+
dynamic_cmis = cmis_dynamic_cmis
645
+
})))
646
+
} : cmis Rpc.Types.structure)
647
+
and cmis =
648
+
{
649
+
Rpc.Types.name = "cmis";
650
+
Rpc.Types.description = [];
651
+
Rpc.Types.ty = typ_of_cmis
652
+
}
653
+
let _ = dynamic_cmis_dcs_url
654
+
and _ = dynamic_cmis_dcs_toplevel_modules
655
+
and _ = dynamic_cmis_dcs_file_prefixes
656
+
and _ = typ_of_dynamic_cmis
657
+
and _ = dynamic_cmis
658
+
and _ = static_cmi_sc_name
659
+
and _ = static_cmi_sc_content
660
+
and _ = typ_of_static_cmi
661
+
and _ = static_cmi
662
+
and _ = cmis_static_cmis
663
+
and _ = cmis_dynamic_cmis
664
+
and _ = typ_of_cmis
665
+
and _ = cmis
666
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
667
+
type action =
668
+
| Complete_prefix of source * Msource.position
669
+
| Type_enclosing of source * Msource.position
670
+
| All_errors of source
671
+
| Add_cmis of cmis
672
+
type error =
673
+
{
674
+
kind: location_report_kind ;
675
+
loc: location ;
676
+
main: string ;
677
+
sub: string list ;
678
+
source: location_error_source }[@@deriving rpcty]
679
+
include
680
+
struct
681
+
let _ = fun (_ : error) -> ()
682
+
let rec error_kind : (_, error) Rpc.Types.field =
683
+
{
684
+
Rpc.Types.fname = "kind";
685
+
Rpc.Types.field = typ_of_location_report_kind;
686
+
Rpc.Types.fdefault = None;
687
+
Rpc.Types.fdescription = [];
688
+
Rpc.Types.fversion = None;
689
+
Rpc.Types.fget = (fun _r -> _r.kind);
690
+
Rpc.Types.fset = (fun v _s -> { _s with kind = v })
691
+
}
692
+
and error_loc : (_, error) Rpc.Types.field =
693
+
{
694
+
Rpc.Types.fname = "loc";
695
+
Rpc.Types.field = typ_of_location;
696
+
Rpc.Types.fdefault = None;
697
+
Rpc.Types.fdescription = [];
698
+
Rpc.Types.fversion = None;
699
+
Rpc.Types.fget = (fun _r -> _r.loc);
700
+
Rpc.Types.fset = (fun v _s -> { _s with loc = v })
701
+
}
702
+
and error_main : (_, error) Rpc.Types.field =
703
+
{
704
+
Rpc.Types.fname = "main";
705
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
706
+
Rpc.Types.fdefault = None;
707
+
Rpc.Types.fdescription = [];
708
+
Rpc.Types.fversion = None;
709
+
Rpc.Types.fget = (fun _r -> _r.main);
710
+
Rpc.Types.fset = (fun v _s -> { _s with main = v })
711
+
}
712
+
and error_sub : (_, error) Rpc.Types.field =
713
+
{
714
+
Rpc.Types.fname = "sub";
715
+
Rpc.Types.field =
716
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
717
+
Rpc.Types.fdefault = None;
718
+
Rpc.Types.fdescription = [];
719
+
Rpc.Types.fversion = None;
720
+
Rpc.Types.fget = (fun _r -> _r.sub);
721
+
Rpc.Types.fset = (fun v _s -> { _s with sub = v })
722
+
}
723
+
and error_source : (_, error) Rpc.Types.field =
724
+
{
725
+
Rpc.Types.fname = "source";
726
+
Rpc.Types.field = typ_of_location_error_source;
727
+
Rpc.Types.fdefault = None;
728
+
Rpc.Types.fdescription = [];
729
+
Rpc.Types.fversion = None;
730
+
Rpc.Types.fget = (fun _r -> _r.source);
731
+
Rpc.Types.fset = (fun v _s -> { _s with source = v })
732
+
}
733
+
and typ_of_error =
734
+
Rpc.Types.Struct
735
+
({
736
+
Rpc.Types.fields =
737
+
[Rpc.Types.BoxedField error_kind;
738
+
Rpc.Types.BoxedField error_loc;
739
+
Rpc.Types.BoxedField error_main;
740
+
Rpc.Types.BoxedField error_sub;
741
+
Rpc.Types.BoxedField error_source];
742
+
Rpc.Types.sname = "error";
743
+
Rpc.Types.version = None;
744
+
Rpc.Types.constructor =
745
+
(fun getter ->
746
+
let open Rresult.R in
747
+
(getter.Rpc.Types.field_get "source"
748
+
typ_of_location_error_source)
749
+
>>=
750
+
(fun error_source ->
751
+
(getter.Rpc.Types.field_get "sub"
752
+
(Rpc.Types.List
753
+
(let open Rpc.Types in Basic String)))
754
+
>>=
755
+
(fun error_sub ->
756
+
(getter.Rpc.Types.field_get "main"
757
+
(let open Rpc.Types in Basic String))
758
+
>>=
759
+
(fun error_main ->
760
+
(getter.Rpc.Types.field_get "loc"
761
+
typ_of_location)
762
+
>>=
763
+
(fun error_loc ->
764
+
(getter.Rpc.Types.field_get "kind"
765
+
typ_of_location_report_kind)
766
+
>>=
767
+
(fun error_kind ->
768
+
return
769
+
{
770
+
kind = error_kind;
771
+
loc = error_loc;
772
+
main = error_main;
773
+
sub = error_sub;
774
+
source = error_source
775
+
}))))))
776
+
} : error Rpc.Types.structure)
777
+
and error =
778
+
{
779
+
Rpc.Types.name = "error";
780
+
Rpc.Types.description = [];
781
+
Rpc.Types.ty = typ_of_error
782
+
}
783
+
let _ = error_kind
784
+
and _ = error_loc
785
+
and _ = error_main
786
+
and _ = error_sub
787
+
and _ = error_source
788
+
and _ = typ_of_error
789
+
and _ = error
790
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
791
+
type error_list = error list[@@deriving rpcty]
792
+
include
793
+
struct
794
+
let _ = fun (_ : error_list) -> ()
795
+
let rec typ_of_error_list = Rpc.Types.List typ_of_error
796
+
and error_list =
797
+
{
798
+
Rpc.Types.name = "error_list";
799
+
Rpc.Types.description = [];
800
+
Rpc.Types.ty = typ_of_error_list
801
+
}
802
+
let _ = typ_of_error_list
803
+
and _ = error_list
804
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
805
+
type kind_ty =
806
+
| Constructor
807
+
| Keyword
808
+
| Label
809
+
| MethodCall
810
+
| Modtype
811
+
| Module
812
+
| Type
813
+
| Value
814
+
| Variant [@@deriving rpcty]
815
+
include
816
+
struct
817
+
let _ = fun (_ : kind_ty) -> ()
818
+
let rec typ_of_kind_ty =
819
+
Rpc.Types.Variant
820
+
({
821
+
Rpc.Types.vname = "kind_ty";
822
+
Rpc.Types.variants =
823
+
[BoxedTag
824
+
{
825
+
Rpc.Types.tname = "Constructor";
826
+
Rpc.Types.tcontents = Unit;
827
+
Rpc.Types.tversion = None;
828
+
Rpc.Types.tdescription = [];
829
+
Rpc.Types.tpreview =
830
+
((function | Constructor -> Some () | _ -> None));
831
+
Rpc.Types.treview = ((function | () -> Constructor))
832
+
};
833
+
BoxedTag
834
+
{
835
+
Rpc.Types.tname = "Keyword";
836
+
Rpc.Types.tcontents = Unit;
837
+
Rpc.Types.tversion = None;
838
+
Rpc.Types.tdescription = [];
839
+
Rpc.Types.tpreview =
840
+
((function | Keyword -> Some () | _ -> None));
841
+
Rpc.Types.treview = ((function | () -> Keyword))
842
+
};
843
+
BoxedTag
844
+
{
845
+
Rpc.Types.tname = "Label";
846
+
Rpc.Types.tcontents = Unit;
847
+
Rpc.Types.tversion = None;
848
+
Rpc.Types.tdescription = [];
849
+
Rpc.Types.tpreview =
850
+
((function | Label -> Some () | _ -> None));
851
+
Rpc.Types.treview = ((function | () -> Label))
852
+
};
853
+
BoxedTag
854
+
{
855
+
Rpc.Types.tname = "MethodCall";
856
+
Rpc.Types.tcontents = Unit;
857
+
Rpc.Types.tversion = None;
858
+
Rpc.Types.tdescription = [];
859
+
Rpc.Types.tpreview =
860
+
((function | MethodCall -> Some () | _ -> None));
861
+
Rpc.Types.treview = ((function | () -> MethodCall))
862
+
};
863
+
BoxedTag
864
+
{
865
+
Rpc.Types.tname = "Modtype";
866
+
Rpc.Types.tcontents = Unit;
867
+
Rpc.Types.tversion = None;
868
+
Rpc.Types.tdescription = [];
869
+
Rpc.Types.tpreview =
870
+
((function | Modtype -> Some () | _ -> None));
871
+
Rpc.Types.treview = ((function | () -> Modtype))
872
+
};
873
+
BoxedTag
874
+
{
875
+
Rpc.Types.tname = "Module";
876
+
Rpc.Types.tcontents = Unit;
877
+
Rpc.Types.tversion = None;
878
+
Rpc.Types.tdescription = [];
879
+
Rpc.Types.tpreview =
880
+
((function | Module -> Some () | _ -> None));
881
+
Rpc.Types.treview = ((function | () -> Module))
882
+
};
883
+
BoxedTag
884
+
{
885
+
Rpc.Types.tname = "Type";
886
+
Rpc.Types.tcontents = Unit;
887
+
Rpc.Types.tversion = None;
888
+
Rpc.Types.tdescription = [];
889
+
Rpc.Types.tpreview =
890
+
((function | Type -> Some () | _ -> None));
891
+
Rpc.Types.treview = ((function | () -> Type))
892
+
};
893
+
BoxedTag
894
+
{
895
+
Rpc.Types.tname = "Value";
896
+
Rpc.Types.tcontents = Unit;
897
+
Rpc.Types.tversion = None;
898
+
Rpc.Types.tdescription = [];
899
+
Rpc.Types.tpreview =
900
+
((function | Value -> Some () | _ -> None));
901
+
Rpc.Types.treview = ((function | () -> Value))
902
+
};
903
+
BoxedTag
904
+
{
905
+
Rpc.Types.tname = "Variant";
906
+
Rpc.Types.tcontents = Unit;
907
+
Rpc.Types.tversion = None;
908
+
Rpc.Types.tdescription = [];
909
+
Rpc.Types.tpreview =
910
+
((function | Variant -> Some () | _ -> None));
911
+
Rpc.Types.treview = ((function | () -> Variant))
912
+
}];
913
+
Rpc.Types.vdefault = None;
914
+
Rpc.Types.vversion = None;
915
+
Rpc.Types.vconstructor =
916
+
(fun s' t ->
917
+
let s = String.lowercase_ascii s' in
918
+
match s with
919
+
| "constructor" ->
920
+
Rresult.R.bind (t.tget Unit)
921
+
(function | () -> Rresult.R.ok Constructor)
922
+
| "keyword" ->
923
+
Rresult.R.bind (t.tget Unit)
924
+
(function | () -> Rresult.R.ok Keyword)
925
+
| "label" ->
926
+
Rresult.R.bind (t.tget Unit)
927
+
(function | () -> Rresult.R.ok Label)
928
+
| "methodcall" ->
929
+
Rresult.R.bind (t.tget Unit)
930
+
(function | () -> Rresult.R.ok MethodCall)
931
+
| "modtype" ->
932
+
Rresult.R.bind (t.tget Unit)
933
+
(function | () -> Rresult.R.ok Modtype)
934
+
| "module" ->
935
+
Rresult.R.bind (t.tget Unit)
936
+
(function | () -> Rresult.R.ok Module)
937
+
| "type" ->
938
+
Rresult.R.bind (t.tget Unit)
939
+
(function | () -> Rresult.R.ok Type)
940
+
| "value" ->
941
+
Rresult.R.bind (t.tget Unit)
942
+
(function | () -> Rresult.R.ok Value)
943
+
| "variant" ->
944
+
Rresult.R.bind (t.tget Unit)
945
+
(function | () -> Rresult.R.ok Variant)
946
+
| _ ->
947
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
948
+
} : kind_ty Rpc.Types.variant)
949
+
and kind_ty =
950
+
{
951
+
Rpc.Types.name = "kind_ty";
952
+
Rpc.Types.description = [];
953
+
Rpc.Types.ty = typ_of_kind_ty
954
+
}
955
+
let _ = typ_of_kind_ty
956
+
and _ = kind_ty
957
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
958
+
type query_protocol_compl_entry =
959
+
{
960
+
name: string ;
961
+
kind: kind_ty ;
962
+
desc: string ;
963
+
info: string ;
964
+
deprecated: bool }[@@deriving rpcty]
965
+
include
966
+
struct
967
+
let _ = fun (_ : query_protocol_compl_entry) -> ()
968
+
let rec query_protocol_compl_entry_name :
969
+
(_, query_protocol_compl_entry) Rpc.Types.field =
970
+
{
971
+
Rpc.Types.fname = "name";
972
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
973
+
Rpc.Types.fdefault = None;
974
+
Rpc.Types.fdescription = [];
975
+
Rpc.Types.fversion = None;
976
+
Rpc.Types.fget = (fun _r -> _r.name);
977
+
Rpc.Types.fset = (fun v _s -> { _s with name = v })
978
+
}
979
+
and query_protocol_compl_entry_kind :
980
+
(_, query_protocol_compl_entry) Rpc.Types.field =
981
+
{
982
+
Rpc.Types.fname = "kind";
983
+
Rpc.Types.field = typ_of_kind_ty;
984
+
Rpc.Types.fdefault = None;
985
+
Rpc.Types.fdescription = [];
986
+
Rpc.Types.fversion = None;
987
+
Rpc.Types.fget = (fun _r -> _r.kind);
988
+
Rpc.Types.fset = (fun v _s -> { _s with kind = v })
989
+
}
990
+
and query_protocol_compl_entry_desc :
991
+
(_, query_protocol_compl_entry) Rpc.Types.field =
992
+
{
993
+
Rpc.Types.fname = "desc";
994
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
995
+
Rpc.Types.fdefault = None;
996
+
Rpc.Types.fdescription = [];
997
+
Rpc.Types.fversion = None;
998
+
Rpc.Types.fget = (fun _r -> _r.desc);
999
+
Rpc.Types.fset = (fun v _s -> { _s with desc = v })
1000
+
}
1001
+
and query_protocol_compl_entry_info :
1002
+
(_, query_protocol_compl_entry) Rpc.Types.field =
1003
+
{
1004
+
Rpc.Types.fname = "info";
1005
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
1006
+
Rpc.Types.fdefault = None;
1007
+
Rpc.Types.fdescription = [];
1008
+
Rpc.Types.fversion = None;
1009
+
Rpc.Types.fget = (fun _r -> _r.info);
1010
+
Rpc.Types.fset = (fun v _s -> { _s with info = v })
1011
+
}
1012
+
and query_protocol_compl_entry_deprecated :
1013
+
(_, query_protocol_compl_entry) Rpc.Types.field =
1014
+
{
1015
+
Rpc.Types.fname = "deprecated";
1016
+
Rpc.Types.field = (let open Rpc.Types in Basic Bool);
1017
+
Rpc.Types.fdefault = None;
1018
+
Rpc.Types.fdescription = [];
1019
+
Rpc.Types.fversion = None;
1020
+
Rpc.Types.fget = (fun _r -> _r.deprecated);
1021
+
Rpc.Types.fset = (fun v _s -> { _s with deprecated = v })
1022
+
}
1023
+
and typ_of_query_protocol_compl_entry =
1024
+
Rpc.Types.Struct
1025
+
({
1026
+
Rpc.Types.fields =
1027
+
[Rpc.Types.BoxedField query_protocol_compl_entry_name;
1028
+
Rpc.Types.BoxedField query_protocol_compl_entry_kind;
1029
+
Rpc.Types.BoxedField query_protocol_compl_entry_desc;
1030
+
Rpc.Types.BoxedField query_protocol_compl_entry_info;
1031
+
Rpc.Types.BoxedField query_protocol_compl_entry_deprecated];
1032
+
Rpc.Types.sname = "query_protocol_compl_entry";
1033
+
Rpc.Types.version = None;
1034
+
Rpc.Types.constructor =
1035
+
(fun getter ->
1036
+
let open Rresult.R in
1037
+
(getter.Rpc.Types.field_get "deprecated"
1038
+
(let open Rpc.Types in Basic Bool))
1039
+
>>=
1040
+
(fun query_protocol_compl_entry_deprecated ->
1041
+
(getter.Rpc.Types.field_get "info"
1042
+
(let open Rpc.Types in Basic String))
1043
+
>>=
1044
+
(fun query_protocol_compl_entry_info ->
1045
+
(getter.Rpc.Types.field_get "desc"
1046
+
(let open Rpc.Types in Basic String))
1047
+
>>=
1048
+
(fun query_protocol_compl_entry_desc ->
1049
+
(getter.Rpc.Types.field_get "kind"
1050
+
typ_of_kind_ty)
1051
+
>>=
1052
+
(fun query_protocol_compl_entry_kind ->
1053
+
(getter.Rpc.Types.field_get "name"
1054
+
(let open Rpc.Types in Basic String))
1055
+
>>=
1056
+
(fun query_protocol_compl_entry_name
1057
+
->
1058
+
return
1059
+
{
1060
+
name =
1061
+
query_protocol_compl_entry_name;
1062
+
kind =
1063
+
query_protocol_compl_entry_kind;
1064
+
desc =
1065
+
query_protocol_compl_entry_desc;
1066
+
info =
1067
+
query_protocol_compl_entry_info;
1068
+
deprecated =
1069
+
query_protocol_compl_entry_deprecated
1070
+
}))))))
1071
+
} : query_protocol_compl_entry Rpc.Types.structure)
1072
+
and query_protocol_compl_entry =
1073
+
{
1074
+
Rpc.Types.name = "query_protocol_compl_entry";
1075
+
Rpc.Types.description = [];
1076
+
Rpc.Types.ty = typ_of_query_protocol_compl_entry
1077
+
}
1078
+
let _ = query_protocol_compl_entry_name
1079
+
and _ = query_protocol_compl_entry_kind
1080
+
and _ = query_protocol_compl_entry_desc
1081
+
and _ = query_protocol_compl_entry_info
1082
+
and _ = query_protocol_compl_entry_deprecated
1083
+
and _ = typ_of_query_protocol_compl_entry
1084
+
and _ = query_protocol_compl_entry
1085
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1086
+
type completions =
1087
+
{
1088
+
from: int ;
1089
+
to_: int ;
1090
+
entries: query_protocol_compl_entry list }[@@deriving rpcty]
1091
+
include
1092
+
struct
1093
+
let _ = fun (_ : completions) -> ()
1094
+
let rec completions_from : (_, completions) Rpc.Types.field =
1095
+
{
1096
+
Rpc.Types.fname = "from";
1097
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1098
+
Rpc.Types.fdefault = None;
1099
+
Rpc.Types.fdescription = [];
1100
+
Rpc.Types.fversion = None;
1101
+
Rpc.Types.fget = (fun _r -> _r.from);
1102
+
Rpc.Types.fset = (fun v _s -> { _s with from = v })
1103
+
}
1104
+
and completions_to_ : (_, completions) Rpc.Types.field =
1105
+
{
1106
+
Rpc.Types.fname = "to_";
1107
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1108
+
Rpc.Types.fdefault = None;
1109
+
Rpc.Types.fdescription = [];
1110
+
Rpc.Types.fversion = None;
1111
+
Rpc.Types.fget = (fun _r -> _r.to_);
1112
+
Rpc.Types.fset = (fun v _s -> { _s with to_ = v })
1113
+
}
1114
+
and completions_entries : (_, completions) Rpc.Types.field =
1115
+
{
1116
+
Rpc.Types.fname = "entries";
1117
+
Rpc.Types.field = (Rpc.Types.List typ_of_query_protocol_compl_entry);
1118
+
Rpc.Types.fdefault = None;
1119
+
Rpc.Types.fdescription = [];
1120
+
Rpc.Types.fversion = None;
1121
+
Rpc.Types.fget = (fun _r -> _r.entries);
1122
+
Rpc.Types.fset = (fun v _s -> { _s with entries = v })
1123
+
}
1124
+
and typ_of_completions =
1125
+
Rpc.Types.Struct
1126
+
({
1127
+
Rpc.Types.fields =
1128
+
[Rpc.Types.BoxedField completions_from;
1129
+
Rpc.Types.BoxedField completions_to_;
1130
+
Rpc.Types.BoxedField completions_entries];
1131
+
Rpc.Types.sname = "completions";
1132
+
Rpc.Types.version = None;
1133
+
Rpc.Types.constructor =
1134
+
(fun getter ->
1135
+
let open Rresult.R in
1136
+
(getter.Rpc.Types.field_get "entries"
1137
+
(Rpc.Types.List typ_of_query_protocol_compl_entry))
1138
+
>>=
1139
+
(fun completions_entries ->
1140
+
(getter.Rpc.Types.field_get "to_"
1141
+
(let open Rpc.Types in Basic Int))
1142
+
>>=
1143
+
(fun completions_to_ ->
1144
+
(getter.Rpc.Types.field_get "from"
1145
+
(let open Rpc.Types in Basic Int))
1146
+
>>=
1147
+
(fun completions_from ->
1148
+
return
1149
+
{
1150
+
from = completions_from;
1151
+
to_ = completions_to_;
1152
+
entries = completions_entries
1153
+
}))))
1154
+
} : completions Rpc.Types.structure)
1155
+
and completions =
1156
+
{
1157
+
Rpc.Types.name = "completions";
1158
+
Rpc.Types.description = [];
1159
+
Rpc.Types.ty = typ_of_completions
1160
+
}
1161
+
let _ = completions_from
1162
+
and _ = completions_to_
1163
+
and _ = completions_entries
1164
+
and _ = typ_of_completions
1165
+
and _ = completions
1166
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1167
+
type msource_position =
1168
+
| Start
1169
+
| Offset of int
1170
+
| Logical of int * int
1171
+
| End [@@deriving rpcty]
1172
+
include
1173
+
struct
1174
+
let _ = fun (_ : msource_position) -> ()
1175
+
let rec typ_of_msource_position =
1176
+
Rpc.Types.Variant
1177
+
({
1178
+
Rpc.Types.vname = "msource_position";
1179
+
Rpc.Types.variants =
1180
+
[BoxedTag
1181
+
{
1182
+
Rpc.Types.tname = "Start";
1183
+
Rpc.Types.tcontents = Unit;
1184
+
Rpc.Types.tversion = None;
1185
+
Rpc.Types.tdescription = [];
1186
+
Rpc.Types.tpreview =
1187
+
((function | Start -> Some () | _ -> None));
1188
+
Rpc.Types.treview = ((function | () -> Start))
1189
+
};
1190
+
BoxedTag
1191
+
{
1192
+
Rpc.Types.tname = "Offset";
1193
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic Int));
1194
+
Rpc.Types.tversion = None;
1195
+
Rpc.Types.tdescription = [];
1196
+
Rpc.Types.tpreview =
1197
+
((function | Offset a0 -> Some a0 | _ -> None));
1198
+
Rpc.Types.treview = ((function | a0 -> Offset a0))
1199
+
};
1200
+
BoxedTag
1201
+
{
1202
+
Rpc.Types.tname = "Logical";
1203
+
Rpc.Types.tcontents =
1204
+
(Tuple
1205
+
(((let open Rpc.Types in Basic Int)),
1206
+
((let open Rpc.Types in Basic Int))));
1207
+
Rpc.Types.tversion = None;
1208
+
Rpc.Types.tdescription = [];
1209
+
Rpc.Types.tpreview =
1210
+
((function | Logical (a0, a1) -> Some (a0, a1) | _ -> None));
1211
+
Rpc.Types.treview =
1212
+
((function | (a0, a1) -> Logical (a0, a1)))
1213
+
};
1214
+
BoxedTag
1215
+
{
1216
+
Rpc.Types.tname = "End";
1217
+
Rpc.Types.tcontents = Unit;
1218
+
Rpc.Types.tversion = None;
1219
+
Rpc.Types.tdescription = [];
1220
+
Rpc.Types.tpreview =
1221
+
((function | End -> Some () | _ -> None));
1222
+
Rpc.Types.treview = ((function | () -> End))
1223
+
}];
1224
+
Rpc.Types.vdefault = None;
1225
+
Rpc.Types.vversion = None;
1226
+
Rpc.Types.vconstructor =
1227
+
(fun s' t ->
1228
+
let s = String.lowercase_ascii s' in
1229
+
match s with
1230
+
| "start" ->
1231
+
Rresult.R.bind (t.tget Unit)
1232
+
(function | () -> Rresult.R.ok Start)
1233
+
| "offset" ->
1234
+
Rresult.R.bind (t.tget (let open Rpc.Types in Basic Int))
1235
+
(function | a0 -> Rresult.R.ok (Offset a0))
1236
+
| "logical" ->
1237
+
Rresult.R.bind
1238
+
(t.tget
1239
+
(Tuple
1240
+
((let open Rpc.Types in Basic Int),
1241
+
(let open Rpc.Types in Basic Int))))
1242
+
(function | (a0, a1) -> Rresult.R.ok (Logical (a0, a1)))
1243
+
| "end" ->
1244
+
Rresult.R.bind (t.tget Unit)
1245
+
(function | () -> Rresult.R.ok End)
1246
+
| _ ->
1247
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1248
+
} : msource_position Rpc.Types.variant)
1249
+
and msource_position =
1250
+
{
1251
+
Rpc.Types.name = "msource_position";
1252
+
Rpc.Types.description = [];
1253
+
Rpc.Types.ty = typ_of_msource_position
1254
+
}
1255
+
let _ = typ_of_msource_position
1256
+
and _ = msource_position
1257
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1258
+
type is_tail_position =
1259
+
| No
1260
+
| Tail_position
1261
+
| Tail_call [@@deriving rpcty]
1262
+
include
1263
+
struct
1264
+
let _ = fun (_ : is_tail_position) -> ()
1265
+
let rec typ_of_is_tail_position =
1266
+
Rpc.Types.Variant
1267
+
({
1268
+
Rpc.Types.vname = "is_tail_position";
1269
+
Rpc.Types.variants =
1270
+
[BoxedTag
1271
+
{
1272
+
Rpc.Types.tname = "No";
1273
+
Rpc.Types.tcontents = Unit;
1274
+
Rpc.Types.tversion = None;
1275
+
Rpc.Types.tdescription = [];
1276
+
Rpc.Types.tpreview =
1277
+
((function | No -> Some () | _ -> None));
1278
+
Rpc.Types.treview = ((function | () -> No))
1279
+
};
1280
+
BoxedTag
1281
+
{
1282
+
Rpc.Types.tname = "Tail_position";
1283
+
Rpc.Types.tcontents = Unit;
1284
+
Rpc.Types.tversion = None;
1285
+
Rpc.Types.tdescription = [];
1286
+
Rpc.Types.tpreview =
1287
+
((function | Tail_position -> Some () | _ -> None));
1288
+
Rpc.Types.treview = ((function | () -> Tail_position))
1289
+
};
1290
+
BoxedTag
1291
+
{
1292
+
Rpc.Types.tname = "Tail_call";
1293
+
Rpc.Types.tcontents = Unit;
1294
+
Rpc.Types.tversion = None;
1295
+
Rpc.Types.tdescription = [];
1296
+
Rpc.Types.tpreview =
1297
+
((function | Tail_call -> Some () | _ -> None));
1298
+
Rpc.Types.treview = ((function | () -> Tail_call))
1299
+
}];
1300
+
Rpc.Types.vdefault = None;
1301
+
Rpc.Types.vversion = None;
1302
+
Rpc.Types.vconstructor =
1303
+
(fun s' t ->
1304
+
let s = String.lowercase_ascii s' in
1305
+
match s with
1306
+
| "no" ->
1307
+
Rresult.R.bind (t.tget Unit)
1308
+
(function | () -> Rresult.R.ok No)
1309
+
| "tail_position" ->
1310
+
Rresult.R.bind (t.tget Unit)
1311
+
(function | () -> Rresult.R.ok Tail_position)
1312
+
| "tail_call" ->
1313
+
Rresult.R.bind (t.tget Unit)
1314
+
(function | () -> Rresult.R.ok Tail_call)
1315
+
| _ ->
1316
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1317
+
} : is_tail_position Rpc.Types.variant)
1318
+
and is_tail_position =
1319
+
{
1320
+
Rpc.Types.name = "is_tail_position";
1321
+
Rpc.Types.description = [];
1322
+
Rpc.Types.ty = typ_of_is_tail_position
1323
+
}
1324
+
let _ = typ_of_is_tail_position
1325
+
and _ = is_tail_position
1326
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1327
+
type index_or_string =
1328
+
| Index of int
1329
+
| String of string [@@deriving rpcty]
1330
+
include
1331
+
struct
1332
+
let _ = fun (_ : index_or_string) -> ()
1333
+
let rec typ_of_index_or_string =
1334
+
Rpc.Types.Variant
1335
+
({
1336
+
Rpc.Types.vname = "index_or_string";
1337
+
Rpc.Types.variants =
1338
+
[BoxedTag
1339
+
{
1340
+
Rpc.Types.tname = "Index";
1341
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic Int));
1342
+
Rpc.Types.tversion = None;
1343
+
Rpc.Types.tdescription = [];
1344
+
Rpc.Types.tpreview =
1345
+
((function | Index a0 -> Some a0 | _ -> None));
1346
+
Rpc.Types.treview = ((function | a0 -> Index a0))
1347
+
};
1348
+
BoxedTag
1349
+
{
1350
+
Rpc.Types.tname = "String";
1351
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
1352
+
Rpc.Types.tversion = None;
1353
+
Rpc.Types.tdescription = [];
1354
+
Rpc.Types.tpreview =
1355
+
((function | String a0 -> Some a0 | _ -> None));
1356
+
Rpc.Types.treview = ((function | a0 -> String a0))
1357
+
}];
1358
+
Rpc.Types.vdefault = None;
1359
+
Rpc.Types.vversion = None;
1360
+
Rpc.Types.vconstructor =
1361
+
(fun s' t ->
1362
+
let s = String.lowercase_ascii s' in
1363
+
match s with
1364
+
| "index" ->
1365
+
Rresult.R.bind (t.tget (let open Rpc.Types in Basic Int))
1366
+
(function | a0 -> Rresult.R.ok (Index a0))
1367
+
| "string" ->
1368
+
Rresult.R.bind
1369
+
(t.tget (let open Rpc.Types in Basic String))
1370
+
(function | a0 -> Rresult.R.ok (String a0))
1371
+
| _ ->
1372
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1373
+
} : index_or_string Rpc.Types.variant)
1374
+
and index_or_string =
1375
+
{
1376
+
Rpc.Types.name = "index_or_string";
1377
+
Rpc.Types.description = [];
1378
+
Rpc.Types.ty = typ_of_index_or_string
1379
+
}
1380
+
let _ = typ_of_index_or_string
1381
+
and _ = index_or_string
1382
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1383
+
type typed_enclosings = (location * index_or_string * is_tail_position)
1384
+
[@@deriving rpcty]
1385
+
include
1386
+
struct
1387
+
let _ = fun (_ : typed_enclosings) -> ()
1388
+
let rec typ_of_typed_enclosings =
1389
+
Rpc.Types.Tuple3
1390
+
(typ_of_location, typ_of_index_or_string, typ_of_is_tail_position)
1391
+
and typed_enclosings =
1392
+
{
1393
+
Rpc.Types.name = "typed_enclosings";
1394
+
Rpc.Types.description = [];
1395
+
Rpc.Types.ty = typ_of_typed_enclosings
1396
+
}
1397
+
let _ = typ_of_typed_enclosings
1398
+
and _ = typed_enclosings
1399
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1400
+
type typed_enclosings_list = typed_enclosings list[@@deriving rpcty]
1401
+
include
1402
+
struct
1403
+
let _ = fun (_ : typed_enclosings_list) -> ()
1404
+
let rec typ_of_typed_enclosings_list =
1405
+
Rpc.Types.List typ_of_typed_enclosings
1406
+
and typed_enclosings_list =
1407
+
{
1408
+
Rpc.Types.name = "typed_enclosings_list";
1409
+
Rpc.Types.description = [];
1410
+
Rpc.Types.ty = typ_of_typed_enclosings_list
1411
+
}
1412
+
let _ = typ_of_typed_enclosings_list
1413
+
and _ = typed_enclosings_list
1414
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1415
+
let report_source_to_string =
1416
+
function
1417
+
| Location.Lexer -> "lexer"
1418
+
| Location.Parser -> "parser"
1419
+
| Location.Typer -> "typer"
1420
+
| Location.Warning -> "warning"
1421
+
| Location.Unknown -> "unknown"
1422
+
| Location.Env -> "env"
1423
+
| Location.Config -> "config"
1424
+
type highlight = {
1425
+
line1: int ;
1426
+
line2: int ;
1427
+
col1: int ;
1428
+
col2: int }[@@deriving rpcty][@@ocaml.doc " An area to be highlighted "]
1429
+
include
1430
+
struct
1431
+
let _ = fun (_ : highlight) -> ()
1432
+
let rec highlight_line1 : (_, highlight) Rpc.Types.field =
1433
+
{
1434
+
Rpc.Types.fname = "line1";
1435
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1436
+
Rpc.Types.fdefault = None;
1437
+
Rpc.Types.fdescription = [];
1438
+
Rpc.Types.fversion = None;
1439
+
Rpc.Types.fget = (fun _r -> _r.line1);
1440
+
Rpc.Types.fset = (fun v _s -> { _s with line1 = v })
1441
+
}
1442
+
and highlight_line2 : (_, highlight) Rpc.Types.field =
1443
+
{
1444
+
Rpc.Types.fname = "line2";
1445
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1446
+
Rpc.Types.fdefault = None;
1447
+
Rpc.Types.fdescription = [];
1448
+
Rpc.Types.fversion = None;
1449
+
Rpc.Types.fget = (fun _r -> _r.line2);
1450
+
Rpc.Types.fset = (fun v _s -> { _s with line2 = v })
1451
+
}
1452
+
and highlight_col1 : (_, highlight) Rpc.Types.field =
1453
+
{
1454
+
Rpc.Types.fname = "col1";
1455
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1456
+
Rpc.Types.fdefault = None;
1457
+
Rpc.Types.fdescription = [];
1458
+
Rpc.Types.fversion = None;
1459
+
Rpc.Types.fget = (fun _r -> _r.col1);
1460
+
Rpc.Types.fset = (fun v _s -> { _s with col1 = v })
1461
+
}
1462
+
and highlight_col2 : (_, highlight) Rpc.Types.field =
1463
+
{
1464
+
Rpc.Types.fname = "col2";
1465
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1466
+
Rpc.Types.fdefault = None;
1467
+
Rpc.Types.fdescription = [];
1468
+
Rpc.Types.fversion = None;
1469
+
Rpc.Types.fget = (fun _r -> _r.col2);
1470
+
Rpc.Types.fset = (fun v _s -> { _s with col2 = v })
1471
+
}
1472
+
and typ_of_highlight =
1473
+
Rpc.Types.Struct
1474
+
({
1475
+
Rpc.Types.fields =
1476
+
[Rpc.Types.BoxedField highlight_line1;
1477
+
Rpc.Types.BoxedField highlight_line2;
1478
+
Rpc.Types.BoxedField highlight_col1;
1479
+
Rpc.Types.BoxedField highlight_col2];
1480
+
Rpc.Types.sname = "highlight";
1481
+
Rpc.Types.version = None;
1482
+
Rpc.Types.constructor =
1483
+
(fun getter ->
1484
+
let open Rresult.R in
1485
+
(getter.Rpc.Types.field_get "col2"
1486
+
(let open Rpc.Types in Basic Int))
1487
+
>>=
1488
+
(fun highlight_col2 ->
1489
+
(getter.Rpc.Types.field_get "col1"
1490
+
(let open Rpc.Types in Basic Int))
1491
+
>>=
1492
+
(fun highlight_col1 ->
1493
+
(getter.Rpc.Types.field_get "line2"
1494
+
(let open Rpc.Types in Basic Int))
1495
+
>>=
1496
+
(fun highlight_line2 ->
1497
+
(getter.Rpc.Types.field_get "line1"
1498
+
(let open Rpc.Types in Basic Int))
1499
+
>>=
1500
+
(fun highlight_line1 ->
1501
+
return
1502
+
{
1503
+
line1 = highlight_line1;
1504
+
line2 = highlight_line2;
1505
+
col1 = highlight_col1;
1506
+
col2 = highlight_col2
1507
+
})))))
1508
+
} : highlight Rpc.Types.structure)
1509
+
and highlight =
1510
+
{
1511
+
Rpc.Types.name = "highlight";
1512
+
Rpc.Types.description = ["An area to be highlighted"];
1513
+
Rpc.Types.ty = typ_of_highlight
1514
+
}
1515
+
let _ = highlight_line1
1516
+
and _ = highlight_line2
1517
+
and _ = highlight_col1
1518
+
and _ = highlight_col2
1519
+
and _ = typ_of_highlight
1520
+
and _ = highlight
1521
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1522
+
type encoding = Mime_printer.encoding =
1523
+
| Noencoding
1524
+
| Base64 [@@ocaml.doc " An area to be highlighted "][@@deriving rpcty]
1525
+
include
1526
+
struct
1527
+
let _ = fun (_ : encoding) -> ()
1528
+
let rec typ_of_encoding =
1529
+
Rpc.Types.Variant
1530
+
({
1531
+
Rpc.Types.vname = "encoding";
1532
+
Rpc.Types.variants =
1533
+
[BoxedTag
1534
+
{
1535
+
Rpc.Types.tname = "Noencoding";
1536
+
Rpc.Types.tcontents = Unit;
1537
+
Rpc.Types.tversion = None;
1538
+
Rpc.Types.tdescription = [];
1539
+
Rpc.Types.tpreview =
1540
+
((function | Noencoding -> Some () | _ -> None));
1541
+
Rpc.Types.treview = ((function | () -> Noencoding))
1542
+
};
1543
+
BoxedTag
1544
+
{
1545
+
Rpc.Types.tname = "Base64";
1546
+
Rpc.Types.tcontents = Unit;
1547
+
Rpc.Types.tversion = None;
1548
+
Rpc.Types.tdescription = [];
1549
+
Rpc.Types.tpreview =
1550
+
((function | Base64 -> Some () | _ -> None));
1551
+
Rpc.Types.treview = ((function | () -> Base64))
1552
+
}];
1553
+
Rpc.Types.vdefault = None;
1554
+
Rpc.Types.vversion = None;
1555
+
Rpc.Types.vconstructor =
1556
+
(fun s' t ->
1557
+
let s = String.lowercase_ascii s' in
1558
+
match s with
1559
+
| "noencoding" ->
1560
+
Rresult.R.bind (t.tget Unit)
1561
+
(function | () -> Rresult.R.ok Noencoding)
1562
+
| "base64" ->
1563
+
Rresult.R.bind (t.tget Unit)
1564
+
(function | () -> Rresult.R.ok Base64)
1565
+
| _ ->
1566
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1567
+
} : encoding Rpc.Types.variant)
1568
+
and encoding =
1569
+
{
1570
+
Rpc.Types.name = "encoding";
1571
+
Rpc.Types.description = ["An area to be highlighted"];
1572
+
Rpc.Types.ty = typ_of_encoding
1573
+
}
1574
+
let _ = typ_of_encoding
1575
+
and _ = encoding
1576
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1577
+
type mime_val = Mime_printer.t =
1578
+
{
1579
+
mime_type: string ;
1580
+
encoding: encoding ;
1581
+
data: string }[@@deriving rpcty]
1582
+
include
1583
+
struct
1584
+
let _ = fun (_ : mime_val) -> ()
1585
+
let rec mime_val_mime_type : (_, mime_val) Rpc.Types.field =
1586
+
{
1587
+
Rpc.Types.fname = "mime_type";
1588
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
1589
+
Rpc.Types.fdefault = None;
1590
+
Rpc.Types.fdescription = [];
1591
+
Rpc.Types.fversion = None;
1592
+
Rpc.Types.fget = (fun _r -> _r.mime_type);
1593
+
Rpc.Types.fset = (fun v _s -> { _s with mime_type = v })
1594
+
}
1595
+
and mime_val_encoding : (_, mime_val) Rpc.Types.field =
1596
+
{
1597
+
Rpc.Types.fname = "encoding";
1598
+
Rpc.Types.field = typ_of_encoding;
1599
+
Rpc.Types.fdefault = None;
1600
+
Rpc.Types.fdescription = [];
1601
+
Rpc.Types.fversion = None;
1602
+
Rpc.Types.fget = (fun _r -> _r.encoding);
1603
+
Rpc.Types.fset = (fun v _s -> { _s with encoding = v })
1604
+
}
1605
+
and mime_val_data : (_, mime_val) Rpc.Types.field =
1606
+
{
1607
+
Rpc.Types.fname = "data";
1608
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
1609
+
Rpc.Types.fdefault = None;
1610
+
Rpc.Types.fdescription = [];
1611
+
Rpc.Types.fversion = None;
1612
+
Rpc.Types.fget = (fun _r -> _r.data);
1613
+
Rpc.Types.fset = (fun v _s -> { _s with data = v })
1614
+
}
1615
+
and typ_of_mime_val =
1616
+
Rpc.Types.Struct
1617
+
({
1618
+
Rpc.Types.fields =
1619
+
[Rpc.Types.BoxedField mime_val_mime_type;
1620
+
Rpc.Types.BoxedField mime_val_encoding;
1621
+
Rpc.Types.BoxedField mime_val_data];
1622
+
Rpc.Types.sname = "mime_val";
1623
+
Rpc.Types.version = None;
1624
+
Rpc.Types.constructor =
1625
+
(fun getter ->
1626
+
let open Rresult.R in
1627
+
(getter.Rpc.Types.field_get "data"
1628
+
(let open Rpc.Types in Basic String))
1629
+
>>=
1630
+
(fun mime_val_data ->
1631
+
(getter.Rpc.Types.field_get "encoding" typ_of_encoding)
1632
+
>>=
1633
+
(fun mime_val_encoding ->
1634
+
(getter.Rpc.Types.field_get "mime_type"
1635
+
(let open Rpc.Types in Basic String))
1636
+
>>=
1637
+
(fun mime_val_mime_type ->
1638
+
return
1639
+
{
1640
+
mime_type = mime_val_mime_type;
1641
+
encoding = mime_val_encoding;
1642
+
data = mime_val_data
1643
+
}))))
1644
+
} : mime_val Rpc.Types.structure)
1645
+
and mime_val =
1646
+
{
1647
+
Rpc.Types.name = "mime_val";
1648
+
Rpc.Types.description = [];
1649
+
Rpc.Types.ty = typ_of_mime_val
1650
+
}
1651
+
let _ = mime_val_mime_type
1652
+
and _ = mime_val_encoding
1653
+
and _ = mime_val_data
1654
+
and _ = typ_of_mime_val
1655
+
and _ = mime_val
1656
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1657
+
type exec_result =
1658
+
{
1659
+
stdout: string option ;
1660
+
stderr: string option ;
1661
+
sharp_ppf: string option ;
1662
+
caml_ppf: string option ;
1663
+
highlight: highlight option ;
1664
+
mime_vals: mime_val list }[@@deriving rpcty][@@ocaml.doc
1665
+
" Represents the result of executing a toplevel phrase "]
1666
+
include
1667
+
struct
1668
+
let _ = fun (_ : exec_result) -> ()
1669
+
let rec exec_result_stdout : (_, exec_result) Rpc.Types.field =
1670
+
{
1671
+
Rpc.Types.fname = "stdout";
1672
+
Rpc.Types.field =
1673
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1674
+
Rpc.Types.fdefault = None;
1675
+
Rpc.Types.fdescription = [];
1676
+
Rpc.Types.fversion = None;
1677
+
Rpc.Types.fget = (fun _r -> _r.stdout);
1678
+
Rpc.Types.fset = (fun v _s -> { _s with stdout = v })
1679
+
}
1680
+
and exec_result_stderr : (_, exec_result) Rpc.Types.field =
1681
+
{
1682
+
Rpc.Types.fname = "stderr";
1683
+
Rpc.Types.field =
1684
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1685
+
Rpc.Types.fdefault = None;
1686
+
Rpc.Types.fdescription = [];
1687
+
Rpc.Types.fversion = None;
1688
+
Rpc.Types.fget = (fun _r -> _r.stderr);
1689
+
Rpc.Types.fset = (fun v _s -> { _s with stderr = v })
1690
+
}
1691
+
and exec_result_sharp_ppf : (_, exec_result) Rpc.Types.field =
1692
+
{
1693
+
Rpc.Types.fname = "sharp_ppf";
1694
+
Rpc.Types.field =
1695
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1696
+
Rpc.Types.fdefault = None;
1697
+
Rpc.Types.fdescription = [];
1698
+
Rpc.Types.fversion = None;
1699
+
Rpc.Types.fget = (fun _r -> _r.sharp_ppf);
1700
+
Rpc.Types.fset = (fun v _s -> { _s with sharp_ppf = v })
1701
+
}
1702
+
and exec_result_caml_ppf : (_, exec_result) Rpc.Types.field =
1703
+
{
1704
+
Rpc.Types.fname = "caml_ppf";
1705
+
Rpc.Types.field =
1706
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1707
+
Rpc.Types.fdefault = None;
1708
+
Rpc.Types.fdescription = [];
1709
+
Rpc.Types.fversion = None;
1710
+
Rpc.Types.fget = (fun _r -> _r.caml_ppf);
1711
+
Rpc.Types.fset = (fun v _s -> { _s with caml_ppf = v })
1712
+
}
1713
+
and exec_result_highlight : (_, exec_result) Rpc.Types.field =
1714
+
{
1715
+
Rpc.Types.fname = "highlight";
1716
+
Rpc.Types.field = (Rpc.Types.Option typ_of_highlight);
1717
+
Rpc.Types.fdefault = None;
1718
+
Rpc.Types.fdescription = [];
1719
+
Rpc.Types.fversion = None;
1720
+
Rpc.Types.fget = (fun _r -> _r.highlight);
1721
+
Rpc.Types.fset = (fun v _s -> { _s with highlight = v })
1722
+
}
1723
+
and exec_result_mime_vals : (_, exec_result) Rpc.Types.field =
1724
+
{
1725
+
Rpc.Types.fname = "mime_vals";
1726
+
Rpc.Types.field = (Rpc.Types.List typ_of_mime_val);
1727
+
Rpc.Types.fdefault = None;
1728
+
Rpc.Types.fdescription = [];
1729
+
Rpc.Types.fversion = None;
1730
+
Rpc.Types.fget = (fun _r -> _r.mime_vals);
1731
+
Rpc.Types.fset = (fun v _s -> { _s with mime_vals = v })
1732
+
}
1733
+
and typ_of_exec_result =
1734
+
Rpc.Types.Struct
1735
+
({
1736
+
Rpc.Types.fields =
1737
+
[Rpc.Types.BoxedField exec_result_stdout;
1738
+
Rpc.Types.BoxedField exec_result_stderr;
1739
+
Rpc.Types.BoxedField exec_result_sharp_ppf;
1740
+
Rpc.Types.BoxedField exec_result_caml_ppf;
1741
+
Rpc.Types.BoxedField exec_result_highlight;
1742
+
Rpc.Types.BoxedField exec_result_mime_vals];
1743
+
Rpc.Types.sname = "exec_result";
1744
+
Rpc.Types.version = None;
1745
+
Rpc.Types.constructor =
1746
+
(fun getter ->
1747
+
let open Rresult.R in
1748
+
(getter.Rpc.Types.field_get "mime_vals"
1749
+
(Rpc.Types.List typ_of_mime_val))
1750
+
>>=
1751
+
(fun exec_result_mime_vals ->
1752
+
(getter.Rpc.Types.field_get "highlight"
1753
+
(Rpc.Types.Option typ_of_highlight))
1754
+
>>=
1755
+
(fun exec_result_highlight ->
1756
+
(getter.Rpc.Types.field_get "caml_ppf"
1757
+
(Rpc.Types.Option
1758
+
(let open Rpc.Types in Basic String)))
1759
+
>>=
1760
+
(fun exec_result_caml_ppf ->
1761
+
(getter.Rpc.Types.field_get "sharp_ppf"
1762
+
(Rpc.Types.Option
1763
+
(let open Rpc.Types in Basic String)))
1764
+
>>=
1765
+
(fun exec_result_sharp_ppf ->
1766
+
(getter.Rpc.Types.field_get "stderr"
1767
+
(Rpc.Types.Option
1768
+
(let open Rpc.Types in
1769
+
Basic String)))
1770
+
>>=
1771
+
(fun exec_result_stderr ->
1772
+
(getter.Rpc.Types.field_get
1773
+
"stdout"
1774
+
(Rpc.Types.Option
1775
+
(let open Rpc.Types in
1776
+
Basic String)))
1777
+
>>=
1778
+
(fun exec_result_stdout ->
1779
+
return
1780
+
{
1781
+
stdout =
1782
+
exec_result_stdout;
1783
+
stderr =
1784
+
exec_result_stderr;
1785
+
sharp_ppf =
1786
+
exec_result_sharp_ppf;
1787
+
caml_ppf =
1788
+
exec_result_caml_ppf;
1789
+
highlight =
1790
+
exec_result_highlight;
1791
+
mime_vals =
1792
+
exec_result_mime_vals
1793
+
})))))))
1794
+
} : exec_result Rpc.Types.structure)
1795
+
and exec_result =
1796
+
{
1797
+
Rpc.Types.name = "exec_result";
1798
+
Rpc.Types.description =
1799
+
["Represents the result of executing a toplevel phrase"];
1800
+
Rpc.Types.ty = typ_of_exec_result
1801
+
}
1802
+
let _ = exec_result_stdout
1803
+
and _ = exec_result_stderr
1804
+
and _ = exec_result_sharp_ppf
1805
+
and _ = exec_result_caml_ppf
1806
+
and _ = exec_result_highlight
1807
+
and _ = exec_result_mime_vals
1808
+
and _ = typ_of_exec_result
1809
+
and _ = exec_result
1810
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1811
+
type script_parts = (int * int) list[@@deriving rpcty]
1812
+
include
1813
+
struct
1814
+
let _ = fun (_ : script_parts) -> ()
1815
+
let rec typ_of_script_parts =
1816
+
Rpc.Types.List
1817
+
(Rpc.Types.Tuple
1818
+
((let open Rpc.Types in Basic Int),
1819
+
(let open Rpc.Types in Basic Int)))
1820
+
and script_parts =
1821
+
{
1822
+
Rpc.Types.name = "script_parts";
1823
+
Rpc.Types.description = [];
1824
+
Rpc.Types.ty = typ_of_script_parts
1825
+
}
1826
+
let _ = typ_of_script_parts
1827
+
and _ = script_parts
1828
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1829
+
type exec_toplevel_result =
1830
+
{
1831
+
script: string ;
1832
+
parts: script_parts ;
1833
+
mime_vals: mime_val list }[@@deriving rpcty][@@ocaml.doc
1834
+
" Represents the result of executing a toplevel script "]
1835
+
include
1836
+
struct
1837
+
let _ = fun (_ : exec_toplevel_result) -> ()
1838
+
let rec exec_toplevel_result_script :
1839
+
(_, exec_toplevel_result) Rpc.Types.field =
1840
+
{
1841
+
Rpc.Types.fname = "script";
1842
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
1843
+
Rpc.Types.fdefault = None;
1844
+
Rpc.Types.fdescription = [];
1845
+
Rpc.Types.fversion = None;
1846
+
Rpc.Types.fget = (fun _r -> _r.script);
1847
+
Rpc.Types.fset = (fun v _s -> { _s with script = v })
1848
+
}
1849
+
and exec_toplevel_result_parts :
1850
+
(_, exec_toplevel_result) Rpc.Types.field =
1851
+
{
1852
+
Rpc.Types.fname = "parts";
1853
+
Rpc.Types.field = typ_of_script_parts;
1854
+
Rpc.Types.fdefault = None;
1855
+
Rpc.Types.fdescription = [];
1856
+
Rpc.Types.fversion = None;
1857
+
Rpc.Types.fget = (fun _r -> _r.parts);
1858
+
Rpc.Types.fset = (fun v _s -> { _s with parts = v })
1859
+
}
1860
+
and exec_toplevel_result_mime_vals :
1861
+
(_, exec_toplevel_result) Rpc.Types.field =
1862
+
{
1863
+
Rpc.Types.fname = "mime_vals";
1864
+
Rpc.Types.field = (Rpc.Types.List typ_of_mime_val);
1865
+
Rpc.Types.fdefault = None;
1866
+
Rpc.Types.fdescription = [];
1867
+
Rpc.Types.fversion = None;
1868
+
Rpc.Types.fget = (fun _r -> _r.mime_vals);
1869
+
Rpc.Types.fset = (fun v _s -> { _s with mime_vals = v })
1870
+
}
1871
+
and typ_of_exec_toplevel_result =
1872
+
Rpc.Types.Struct
1873
+
({
1874
+
Rpc.Types.fields =
1875
+
[Rpc.Types.BoxedField exec_toplevel_result_script;
1876
+
Rpc.Types.BoxedField exec_toplevel_result_parts;
1877
+
Rpc.Types.BoxedField exec_toplevel_result_mime_vals];
1878
+
Rpc.Types.sname = "exec_toplevel_result";
1879
+
Rpc.Types.version = None;
1880
+
Rpc.Types.constructor =
1881
+
(fun getter ->
1882
+
let open Rresult.R in
1883
+
(getter.Rpc.Types.field_get "mime_vals"
1884
+
(Rpc.Types.List typ_of_mime_val))
1885
+
>>=
1886
+
(fun exec_toplevel_result_mime_vals ->
1887
+
(getter.Rpc.Types.field_get "parts"
1888
+
typ_of_script_parts)
1889
+
>>=
1890
+
(fun exec_toplevel_result_parts ->
1891
+
(getter.Rpc.Types.field_get "script"
1892
+
(let open Rpc.Types in Basic String))
1893
+
>>=
1894
+
(fun exec_toplevel_result_script ->
1895
+
return
1896
+
{
1897
+
script = exec_toplevel_result_script;
1898
+
parts = exec_toplevel_result_parts;
1899
+
mime_vals =
1900
+
exec_toplevel_result_mime_vals
1901
+
}))))
1902
+
} : exec_toplevel_result Rpc.Types.structure)
1903
+
and exec_toplevel_result =
1904
+
{
1905
+
Rpc.Types.name = "exec_toplevel_result";
1906
+
Rpc.Types.description =
1907
+
["Represents the result of executing a toplevel script"];
1908
+
Rpc.Types.ty = typ_of_exec_toplevel_result
1909
+
}
1910
+
let _ = exec_toplevel_result_script
1911
+
and _ = exec_toplevel_result_parts
1912
+
and _ = exec_toplevel_result_mime_vals
1913
+
and _ = typ_of_exec_toplevel_result
1914
+
and _ = exec_toplevel_result
1915
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1916
+
type cma =
1917
+
{
1918
+
url: string [@ocaml.doc " URL where the cma is available "];
1919
+
fn: string [@ocaml.doc " Name of the 'wrapping' function "]}[@@deriving
1920
+
rpcty]
1921
+
include
1922
+
struct
1923
+
let _ = fun (_ : cma) -> ()
1924
+
let rec cma_url : (_, cma) Rpc.Types.field =
1925
+
{
1926
+
Rpc.Types.fname = "url";
1927
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
1928
+
Rpc.Types.fdefault = None;
1929
+
Rpc.Types.fdescription = ["URL where the cma is available"];
1930
+
Rpc.Types.fversion = None;
1931
+
Rpc.Types.fget = (fun _r -> _r.url);
1932
+
Rpc.Types.fset = (fun v _s -> { _s with url = v })
1933
+
}
1934
+
and cma_fn : (_, cma) Rpc.Types.field =
1935
+
{
1936
+
Rpc.Types.fname = "fn";
1937
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
1938
+
Rpc.Types.fdefault = None;
1939
+
Rpc.Types.fdescription = ["Name of the 'wrapping' function"];
1940
+
Rpc.Types.fversion = None;
1941
+
Rpc.Types.fget = (fun _r -> _r.fn);
1942
+
Rpc.Types.fset = (fun v _s -> { _s with fn = v })
1943
+
}
1944
+
and typ_of_cma =
1945
+
Rpc.Types.Struct
1946
+
({
1947
+
Rpc.Types.fields =
1948
+
[Rpc.Types.BoxedField cma_url; Rpc.Types.BoxedField cma_fn];
1949
+
Rpc.Types.sname = "cma";
1950
+
Rpc.Types.version = None;
1951
+
Rpc.Types.constructor =
1952
+
(fun getter ->
1953
+
let open Rresult.R in
1954
+
(getter.Rpc.Types.field_get "fn"
1955
+
(let open Rpc.Types in Basic String))
1956
+
>>=
1957
+
(fun cma_fn ->
1958
+
(getter.Rpc.Types.field_get "url"
1959
+
(let open Rpc.Types in Basic String))
1960
+
>>=
1961
+
(fun cma_url ->
1962
+
return { url = cma_url; fn = cma_fn })))
1963
+
} : cma Rpc.Types.structure)
1964
+
and cma =
1965
+
{
1966
+
Rpc.Types.name = "cma";
1967
+
Rpc.Types.description = [];
1968
+
Rpc.Types.ty = typ_of_cma
1969
+
}
1970
+
let _ = cma_url
1971
+
and _ = cma_fn
1972
+
and _ = typ_of_cma
1973
+
and _ = cma
1974
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1975
+
type init_config =
1976
+
{
1977
+
findlib_requires: string list [@ocaml.doc " Findlib packages to require "];
1978
+
stdlib_dcs: string option
1979
+
[@ocaml.doc " URL to the dynamic cmis for the OCaml standard library "];
1980
+
findlib_index: string option
1981
+
[@ocaml.doc
1982
+
" URL to the findlib_index file. Defaults to \"findlib_index\" "];
1983
+
execute: bool
1984
+
[@ocaml.doc " Whether this session should support execution or not. "]}
1985
+
[@@deriving rpcty]
1986
+
include
1987
+
struct
1988
+
let _ = fun (_ : init_config) -> ()
1989
+
let rec init_config_findlib_requires : (_, init_config) Rpc.Types.field =
1990
+
{
1991
+
Rpc.Types.fname = "findlib_requires";
1992
+
Rpc.Types.field =
1993
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
1994
+
Rpc.Types.fdefault = None;
1995
+
Rpc.Types.fdescription = ["Findlib packages to require"];
1996
+
Rpc.Types.fversion = None;
1997
+
Rpc.Types.fget = (fun _r -> _r.findlib_requires);
1998
+
Rpc.Types.fset = (fun v _s -> { _s with findlib_requires = v })
1999
+
}
2000
+
and init_config_stdlib_dcs : (_, init_config) Rpc.Types.field =
2001
+
{
2002
+
Rpc.Types.fname = "stdlib_dcs";
2003
+
Rpc.Types.field =
2004
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
2005
+
Rpc.Types.fdefault = None;
2006
+
Rpc.Types.fdescription =
2007
+
["URL to the dynamic cmis for the OCaml standard library"];
2008
+
Rpc.Types.fversion = None;
2009
+
Rpc.Types.fget = (fun _r -> _r.stdlib_dcs);
2010
+
Rpc.Types.fset = (fun v _s -> { _s with stdlib_dcs = v })
2011
+
}
2012
+
and init_config_findlib_index : (_, init_config) Rpc.Types.field =
2013
+
{
2014
+
Rpc.Types.fname = "findlib_index";
2015
+
Rpc.Types.field =
2016
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
2017
+
Rpc.Types.fdefault = None;
2018
+
Rpc.Types.fdescription =
2019
+
["URL to the findlib_index file. Defaults to \"findlib_index\""];
2020
+
Rpc.Types.fversion = None;
2021
+
Rpc.Types.fget = (fun _r -> _r.findlib_index);
2022
+
Rpc.Types.fset = (fun v _s -> { _s with findlib_index = v })
2023
+
}
2024
+
and init_config_execute : (_, init_config) Rpc.Types.field =
2025
+
{
2026
+
Rpc.Types.fname = "execute";
2027
+
Rpc.Types.field = (let open Rpc.Types in Basic Bool);
2028
+
Rpc.Types.fdefault = None;
2029
+
Rpc.Types.fdescription =
2030
+
["Whether this session should support execution or not."];
2031
+
Rpc.Types.fversion = None;
2032
+
Rpc.Types.fget = (fun _r -> _r.execute);
2033
+
Rpc.Types.fset = (fun v _s -> { _s with execute = v })
2034
+
}
2035
+
and typ_of_init_config =
2036
+
Rpc.Types.Struct
2037
+
({
2038
+
Rpc.Types.fields =
2039
+
[Rpc.Types.BoxedField init_config_findlib_requires;
2040
+
Rpc.Types.BoxedField init_config_stdlib_dcs;
2041
+
Rpc.Types.BoxedField init_config_findlib_index;
2042
+
Rpc.Types.BoxedField init_config_execute];
2043
+
Rpc.Types.sname = "init_config";
2044
+
Rpc.Types.version = None;
2045
+
Rpc.Types.constructor =
2046
+
(fun getter ->
2047
+
let open Rresult.R in
2048
+
(getter.Rpc.Types.field_get "execute"
2049
+
(let open Rpc.Types in Basic Bool))
2050
+
>>=
2051
+
(fun init_config_execute ->
2052
+
(getter.Rpc.Types.field_get "findlib_index"
2053
+
(Rpc.Types.Option
2054
+
(let open Rpc.Types in Basic String)))
2055
+
>>=
2056
+
(fun init_config_findlib_index ->
2057
+
(getter.Rpc.Types.field_get "stdlib_dcs"
2058
+
(Rpc.Types.Option
2059
+
(let open Rpc.Types in Basic String)))
2060
+
>>=
2061
+
(fun init_config_stdlib_dcs ->
2062
+
(getter.Rpc.Types.field_get
2063
+
"findlib_requires"
2064
+
(Rpc.Types.List
2065
+
(let open Rpc.Types in Basic String)))
2066
+
>>=
2067
+
(fun init_config_findlib_requires ->
2068
+
return
2069
+
{
2070
+
findlib_requires =
2071
+
init_config_findlib_requires;
2072
+
stdlib_dcs = init_config_stdlib_dcs;
2073
+
findlib_index =
2074
+
init_config_findlib_index;
2075
+
execute = init_config_execute
2076
+
})))))
2077
+
} : init_config Rpc.Types.structure)
2078
+
and init_config =
2079
+
{
2080
+
Rpc.Types.name = "init_config";
2081
+
Rpc.Types.description = [];
2082
+
Rpc.Types.ty = typ_of_init_config
2083
+
}
2084
+
let _ = init_config_findlib_requires
2085
+
and _ = init_config_stdlib_dcs
2086
+
and _ = init_config_findlib_index
2087
+
and _ = init_config_execute
2088
+
and _ = typ_of_init_config
2089
+
and _ = init_config
2090
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2091
+
type err =
2092
+
| InternalError of string [@@deriving rpcty]
2093
+
include
2094
+
struct
2095
+
let _ = fun (_ : err) -> ()
2096
+
let rec typ_of_err =
2097
+
Rpc.Types.Variant
2098
+
({
2099
+
Rpc.Types.vname = "err";
2100
+
Rpc.Types.variants =
2101
+
[BoxedTag
2102
+
{
2103
+
Rpc.Types.tname = "InternalError";
2104
+
Rpc.Types.tcontents =
2105
+
((let open Rpc.Types in Basic String));
2106
+
Rpc.Types.tversion = None;
2107
+
Rpc.Types.tdescription = [];
2108
+
Rpc.Types.tpreview =
2109
+
((function | InternalError a0 -> Some a0));
2110
+
Rpc.Types.treview = ((function | a0 -> InternalError a0))
2111
+
}];
2112
+
Rpc.Types.vdefault = None;
2113
+
Rpc.Types.vversion = None;
2114
+
Rpc.Types.vconstructor =
2115
+
(fun s' t ->
2116
+
let s = String.lowercase_ascii s' in
2117
+
match s with
2118
+
| "internalerror" ->
2119
+
Rresult.R.bind
2120
+
(t.tget (let open Rpc.Types in Basic String))
2121
+
(function | a0 -> Rresult.R.ok (InternalError a0))
2122
+
| _ ->
2123
+
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
2124
+
} : err Rpc.Types.variant)
2125
+
and err =
2126
+
{
2127
+
Rpc.Types.name = "err";
2128
+
Rpc.Types.description = [];
2129
+
Rpc.Types.ty = typ_of_err
2130
+
}
2131
+
let _ = typ_of_err
2132
+
and _ = err
2133
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2134
+
type opt_id = string option[@@deriving rpcty]
2135
+
include
2136
+
struct
2137
+
let _ = fun (_ : opt_id) -> ()
2138
+
let rec typ_of_opt_id =
2139
+
Rpc.Types.Option (let open Rpc.Types in Basic String)
2140
+
and opt_id =
2141
+
{
2142
+
Rpc.Types.name = "opt_id";
2143
+
Rpc.Types.description = [];
2144
+
Rpc.Types.ty = typ_of_opt_id
2145
+
}
2146
+
let _ = typ_of_opt_id
2147
+
and _ = opt_id
2148
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2149
+
type env_id = string[@@deriving rpcty][@@ocaml.doc
2150
+
" Environment identifier. If empty string, uses the default environment. "]
2151
+
include
2152
+
struct
2153
+
let _ = fun (_ : env_id) -> ()
2154
+
let rec typ_of_env_id = let open Rpc.Types in Basic String
2155
+
and env_id =
2156
+
{
2157
+
Rpc.Types.name = "env_id";
2158
+
Rpc.Types.description =
2159
+
["Environment identifier. If empty string, uses the default environment."];
2160
+
Rpc.Types.ty = typ_of_env_id
2161
+
}
2162
+
let _ = typ_of_env_id
2163
+
and _ = env_id
2164
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2165
+
type env_id_list = string list[@@deriving rpcty][@@ocaml.doc
2166
+
" List of environment identifiers "]
2167
+
include
2168
+
struct
2169
+
let _ = fun (_ : env_id_list) -> ()
2170
+
let rec typ_of_env_id_list =
2171
+
Rpc.Types.List (let open Rpc.Types in Basic String)
2172
+
and env_id_list =
2173
+
{
2174
+
Rpc.Types.name = "env_id_list";
2175
+
Rpc.Types.description = ["List of environment identifiers"];
2176
+
Rpc.Types.ty = typ_of_env_id_list
2177
+
}
2178
+
let _ = typ_of_env_id_list
2179
+
and _ = env_id_list
2180
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2181
+
type dependencies = string list[@@deriving rpcty][@@ocaml.doc
2182
+
" The ids of the cells that are dependencies "]
2183
+
include
2184
+
struct
2185
+
let _ = fun (_ : dependencies) -> ()
2186
+
let rec typ_of_dependencies =
2187
+
Rpc.Types.List (let open Rpc.Types in Basic String)
2188
+
and dependencies =
2189
+
{
2190
+
Rpc.Types.name = "dependencies";
2191
+
Rpc.Types.description =
2192
+
["The ids of the cells that are dependencies"];
2193
+
Rpc.Types.ty = typ_of_dependencies
2194
+
}
2195
+
let _ = typ_of_dependencies
2196
+
and _ = dependencies
2197
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2198
+
module E =
2199
+
(Idl.Error.Make)(struct
2200
+
type t = err
2201
+
let t = err
2202
+
let internal_error_of e =
2203
+
Some (InternalError (Printexc.to_string e))
2204
+
end)
2205
+
let err = E.error
2206
+
module Make(R:RPC) =
2207
+
struct
2208
+
open R
2209
+
let description =
2210
+
let open Interface in
2211
+
{
2212
+
name = "Toplevel";
2213
+
namespace = None;
2214
+
description =
2215
+
["Functions for manipulating the toplevel worker thread"];
2216
+
version = (1, 0, 0)
2217
+
}
2218
+
let implementation = implement description
2219
+
let unit_p = Param.mk Types.unit
2220
+
let phrase_p =
2221
+
Param.mk ~name:"string" ~description:["The OCaml phrase to execute"]
2222
+
Types.string
2223
+
let id_p = Param.mk opt_id
2224
+
let env_id_p =
2225
+
Param.mk ~name:"env_id"
2226
+
~description:["Environment ID (empty string for default)"] env_id
2227
+
let env_id_list_p = Param.mk env_id_list
2228
+
let dependencies_p = Param.mk dependencies
2229
+
let exec_result_p = Param.mk exec_result
2230
+
let source_p = Param.mk source
2231
+
let position_p = Param.mk msource_position
2232
+
let completions_p = Param.mk completions
2233
+
let error_list_p = Param.mk error_list
2234
+
let typed_enclosings_p = Param.mk typed_enclosings_list
2235
+
let is_toplevel_p = Param.mk ~name:"is_toplevel" Types.bool
2236
+
let toplevel_script_p =
2237
+
Param.mk
2238
+
~description:["A toplevel script is a sequence of toplevel phrases interspersed with";
2239
+
"The output from the toplevel. Each phase must be preceded by '# ', and";
2240
+
"the output from the toplevel is indented by 2 spaces."]
2241
+
Types.string
2242
+
let exec_toplevel_result_p = Param.mk exec_toplevel_result
2243
+
let init_libs =
2244
+
Param.mk ~name:"init_libs"
2245
+
~description:["Configuration for the toplevel."] init_config
2246
+
let init =
2247
+
declare "init"
2248
+
["Initialise the toplevel. This must be called before any other API."]
2249
+
(init_libs @-> (returning unit_p err))
2250
+
[@@@ocaml.text " {2 Environment Management} "]
2251
+
let create_env =
2252
+
declare "create_env"
2253
+
["Create a new isolated execution environment with the given ID.";
2254
+
"Returns unit on success. The environment must be set up with";
2255
+
"setup_env before use."] (env_id_p @-> (returning unit_p err))
2256
+
let destroy_env =
2257
+
declare "destroy_env"
2258
+
["Destroy an execution environment, freeing its resources.";
2259
+
"The environment ID must exist."]
2260
+
(env_id_p @-> (returning unit_p err))
2261
+
let list_envs =
2262
+
declare "list_envs" ["List all existing environment IDs."]
2263
+
(unit_p @-> (returning env_id_list_p err))
2264
+
let setup =
2265
+
declare "setup"
2266
+
["Start the toplevel for the given environment. Return value is the";
2267
+
"initial blurb printed when starting a toplevel. Note that the";
2268
+
"toplevel must be initialised first. If env_id is None, uses the";
2269
+
"default environment."] (env_id_p @-> (returning exec_result_p err))
2270
+
let exec =
2271
+
declare "exec"
2272
+
["Execute a phrase using the toplevel. The toplevel must have been";
2273
+
"initialised first. If env_id is None, uses the default environment."]
2274
+
(env_id_p @-> (phrase_p @-> (returning exec_result_p err)))
2275
+
let exec_toplevel =
2276
+
declare "exec_toplevel"
2277
+
["Execute a toplevel script. The toplevel must have been";
2278
+
"initialised first. Returns the updated toplevel script.";
2279
+
"If env_id is None, uses the default environment."]
2280
+
(env_id_p @->
2281
+
(toplevel_script_p @-> (returning exec_toplevel_result_p err)))
2282
+
let complete_prefix =
2283
+
declare "complete_prefix"
2284
+
["Complete a prefix. If env_id is None, uses the default environment."]
2285
+
(env_id_p @->
2286
+
(id_p @->
2287
+
(dependencies_p @->
2288
+
(is_toplevel_p @->
2289
+
(source_p @->
2290
+
(position_p @-> (returning completions_p err)))))))
2291
+
let query_errors =
2292
+
declare "query_errors"
2293
+
["Query the errors in the given source.";
2294
+
"If env_id is None, uses the default environment."]
2295
+
(env_id_p @->
2296
+
(id_p @->
2297
+
(dependencies_p @->
2298
+
(is_toplevel_p @->
2299
+
(source_p @-> (returning error_list_p err))))))
2300
+
let type_enclosing =
2301
+
declare "type_enclosing"
2302
+
["Get the type of the enclosing expression.";
2303
+
"If env_id is None, uses the default environment."]
2304
+
(env_id_p @->
2305
+
(id_p @->
2306
+
(dependencies_p @->
2307
+
(is_toplevel_p @->
2308
+
(source_p @->
2309
+
(position_p @-> (returning typed_enclosings_p err)))))))
2310
+
end
+34
js_top_worker/idl/transport.ml
+34
js_top_worker/idl/transport.ml
···
1
+
(** Transport abstraction for RPC encoding.
2
+
3
+
This module provides a common interface for encoding/decoding RPC messages.
4
+
Uses JSON-RPC for browser compatibility. *)
5
+
6
+
module type S = sig
7
+
(** Encode a call (ID is auto-generated) *)
8
+
val string_of_call : Rpc.call -> string
9
+
10
+
(** Decode a message to get the ID and call *)
11
+
val id_and_call_of_string : string -> Rpc.t * Rpc.call
12
+
13
+
(** Encode a response with the given ID *)
14
+
val string_of_response : id:Rpc.t -> Rpc.response -> string
15
+
16
+
(** Decode a message to get the response *)
17
+
val response_of_string : string -> Rpc.response
18
+
end
19
+
20
+
(** JSON-RPC transport *)
21
+
module Json : S = struct
22
+
let string_of_call call =
23
+
Jsonrpc.string_of_call call
24
+
25
+
let id_and_call_of_string s =
26
+
let _, id, call = Jsonrpc.version_id_and_call_of_string s in
27
+
(id, call)
28
+
29
+
let string_of_response ~id response =
30
+
Jsonrpc.string_of_response ~id response
31
+
32
+
let response_of_string s =
33
+
Jsonrpc.response_of_string s
34
+
end
+25
js_top_worker/idl/transport.mli
+25
js_top_worker/idl/transport.mli
···
1
+
(** Transport abstraction for RPC encoding.
2
+
3
+
This module provides a common interface for encoding/decoding RPC messages.
4
+
Uses JSON-RPC for browser compatibility. *)
5
+
6
+
(** Transport signature defining the encoding/decoding interface. *)
7
+
module type S = sig
8
+
val string_of_call : Rpc.call -> string
9
+
(** Encode a call. A unique request ID is auto-generated. *)
10
+
11
+
val id_and_call_of_string : string -> Rpc.t * Rpc.call
12
+
(** Decode a message to get the ID and call.
13
+
@raise Failure if decoding fails. *)
14
+
15
+
val string_of_response : id:Rpc.t -> Rpc.response -> string
16
+
(** Encode a response with the given ID. *)
17
+
18
+
val response_of_string : string -> Rpc.response
19
+
(** Decode a message to get the response.
20
+
@raise Failure if decoding fails. *)
21
+
end
22
+
23
+
(** JSON-RPC transport.
24
+
Uses the standard JSON-RPC 2.0 encoding from [rpclib.json]. *)
25
+
module Json : S
+30
js_top_worker/js_top_worker-bin.opam
+30
js_top_worker/js_top_worker-bin.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"eio"
10
+
"eio_main"
11
+
"bos"
12
+
"opam-format"
13
+
"ocamlfind"
14
+
"logs"
15
+
"fmt"
16
+
"ocaml"
17
+
"dune" {>= "2.9.1"}
18
+
"js_of_ocaml" {>= "3.11.0"}
19
+
"astring"
20
+
"js_top_worker" {= version}
21
+
"js_top_worker-rpc" {= version}
22
+
]
23
+
build : [
24
+
["dune" "subst"] {pinned}
25
+
["dune" "build" "-p" name "-j" jobs]
26
+
]
27
+
synopsis: "JS Toplevel worker web"
28
+
description: """
29
+
An OCaml toplevel designed to run as a web worker
30
+
"""
+26
js_top_worker/js_top_worker-client.opam
+26
js_top_worker/js_top_worker-client.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml"
10
+
"dune" {>= "2.9.1"}
11
+
"js_of_ocaml" {>= "3.11.0"}
12
+
"rresult"
13
+
"astring"
14
+
"brr" {>= "0.0.4"}
15
+
"js_top_worker" {= version}
16
+
"js_top_worker-rpc" {= version}
17
+
"lwt"
18
+
]
19
+
build : [
20
+
["dune" "subst"] {pinned}
21
+
["dune" "build" "-p" name "-j" jobs]
22
+
]
23
+
synopsis: "JS Toplevel worker client"
24
+
description: """
25
+
An OCaml toplevel designed to run as a web worker
26
+
"""
+25
js_top_worker/js_top_worker-client_fut.opam
+25
js_top_worker/js_top_worker-client_fut.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml"
10
+
"dune" {>= "2.9.1"}
11
+
"js_of_ocaml" {>= "3.11.0"}
12
+
"rresult"
13
+
"astring"
14
+
"brr" {>= "0.0.4"}
15
+
"js_top_worker" {= version}
16
+
"js_top_worker-rpc" {= version}
17
+
]
18
+
build : [
19
+
["dune" "subst"] {pinned}
20
+
["dune" "build" "-p" name "-j" jobs]
21
+
]
22
+
synopsis: "JS Toplevel worker client"
23
+
description: """
24
+
An OCaml toplevel designed to run as a web worker
25
+
"""
+32
js_top_worker/js_top_worker-rpc.opam
+32
js_top_worker/js_top_worker-rpc.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml" {>= "5.1"}
10
+
"dune" {>= "3.10"}
11
+
"mime_printer"
12
+
"rresult"
13
+
"merlin-lib"
14
+
"rpclib"
15
+
"cbort"
16
+
"zarith"
17
+
"bytesrw"
18
+
"js_of_ocaml" {>= "5.0"}
19
+
"js_of_ocaml-ppx" {>= "5.0"}
20
+
]
21
+
build : [
22
+
["dune" "subst"] {pinned}
23
+
["dune" "build" "-p" name "-j" jobs]
24
+
]
25
+
synopsis: "JS Toplevel worker - RPC functions"
26
+
description: """
27
+
An OCaml toplevel designed to run as a web worker
28
+
"""
29
+
pin-depends: [
30
+
[ "mime_printer.dev" "git+https://github.com/jonludlam/mime_printer.git#odoc_notebook" ]
31
+
[ "cbort.dev" "git+https://tangled.org/@anil.recoil.org/ocaml-cbort.git" ]
32
+
]
js_top_worker/js_top_worker-unix.opam
js_top_worker/js_top_worker-unix.opam
This is a binary file and will not be displayed.
+34
js_top_worker/js_top_worker-web.opam
+34
js_top_worker/js_top_worker-web.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml"
10
+
"dune" {>= "2.9.1"}
11
+
"js_of_ocaml" {>= "3.11.0"}
12
+
"rresult"
13
+
"astring"
14
+
"brr" {>= "0.0.4"}
15
+
"js_top_worker" {= version}
16
+
"js_top_worker-rpc" {= version}
17
+
"lwt"
18
+
"js_of_ocaml-lwt"
19
+
"js_of_ocaml-toplevel"
20
+
"logs"
21
+
"angstrom"
22
+
"uri"
23
+
"ocamlfind"
24
+
"fpath"
25
+
"js_of_ocaml-ppx" {>= "5.0"}
26
+
]
27
+
build : [
28
+
["dune" "subst"] {pinned}
29
+
["dune" "build" "-p" name "-j" jobs]
30
+
]
31
+
synopsis: "JS Toplevel worker web"
32
+
description: """
33
+
An OCaml toplevel designed to run as a web worker
34
+
"""
+33
js_top_worker/js_top_worker.opam
+33
js_top_worker/js_top_worker.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml" {>= "4.04"}
10
+
"dune" {>= "2.9.1"}
11
+
"js_of_ocaml" {>= "3.11.0"}
12
+
"rresult"
13
+
"astring"
14
+
"js_of_ocaml-toplevel"
15
+
"js_of_ocaml-compiler"
16
+
"js_of_ocaml-ppx"
17
+
"js_top_worker-rpc"
18
+
"rpclib-lwt"
19
+
"ppx_deriving" {>= "5.0"}
20
+
"ppxlib"
21
+
"merlin-lib" {>= "4.7"}
22
+
"mime_printer"
23
+
"logs"
24
+
"cppo" {build}
25
+
]
26
+
build : [
27
+
["dune" "subst"] {pinned}
28
+
["dune" "build" "-p" name "-j" jobs]
29
+
]
30
+
synopsis: "JS Toplevel worker"
31
+
description: """
32
+
An OCaml toplevel designed to run as a web worker
33
+
"""
+21
js_top_worker/js_top_worker_rpc_def.opam
+21
js_top_worker/js_top_worker_rpc_def.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml"
10
+
"dune" {>= "2.9.1"}
11
+
"ppx_deriving_rpc"
12
+
"rresult"
13
+
]
14
+
build : [
15
+
["dune" "subst"] {pinned}
16
+
["dune" "build" "-p" name "-j" jobs]
17
+
]
18
+
synopsis: "JS Toplevel worker IDL generator"
19
+
description: """
20
+
An OCaml toplevel designed to run as a web worker: IDL generator edition
21
+
"""
+52
js_top_worker/lib/dune
+52
js_top_worker/lib/dune
···
1
+
; Worker library
2
+
3
+
(library
4
+
(public_name js_top_worker)
5
+
(modules toplexer ocamltop impl environment)
6
+
(libraries
7
+
logs
8
+
js_top_worker-rpc
9
+
rpclib-lwt
10
+
js_of_ocaml-compiler
11
+
js_of_ocaml-ppx
12
+
astring
13
+
mime_printer
14
+
compiler-libs.common
15
+
compiler-libs.toplevel
16
+
merlin-lib.kernel
17
+
merlin-lib.utils
18
+
merlin-lib.query_protocol
19
+
merlin-lib.query_commands
20
+
merlin-lib.ocaml_parsing
21
+
ppxlib
22
+
ppx_deriving.api)
23
+
(js_of_ocaml
24
+
(javascript_files stubs.js))
25
+
(preprocess
26
+
(per_module
27
+
((action
28
+
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))
29
+
uTop_complete
30
+
uTop_compat
31
+
uTop))))
32
+
33
+
(ocamllex toplexer)
34
+
35
+
(library
36
+
(public_name js_top_worker-web)
37
+
(name js_top_worker_web)
38
+
(modules worker findlibish jslib)
39
+
(preprocess
40
+
(pps js_of_ocaml-ppx))
41
+
(libraries
42
+
js_top_worker
43
+
js_top_worker-rpc.message
44
+
js_of_ocaml-ppx
45
+
js_of_ocaml-toplevel
46
+
js_of_ocaml-lwt
47
+
logs.browser
48
+
uri
49
+
angstrom
50
+
findlib
51
+
fpath
52
+
rpclib.json))
+169
js_top_worker/lib/environment.ml
+169
js_top_worker/lib/environment.ml
···
1
+
(** Multiple isolated execution environments.
2
+
3
+
This module provides isolated execution environments for the OCaml toplevel.
4
+
Each environment maintains both:
5
+
- The typing environment (Env.t) which tracks type bindings
6
+
- Runtime values (via Toploop.getvalue/setvalue) which store actual values
7
+
8
+
When switching between environments, both are saved and restored to ensure
9
+
complete isolation of definitions. *)
10
+
11
+
module StringSet = Set.Make (String)
12
+
module StringMap = Map.Make (String)
13
+
14
+
(* Debug logging - uses the Logs module which is configured in the worker *)
15
+
let log_debug msg = Logs.debug (fun m -> m "%s" msg)
16
+
17
+
type id = string
18
+
19
+
(** Runtime values are stored as a map from binding name to Obj.t.
20
+
We use Obj.t because Toploop.getvalue/setvalue work with Obj.t. *)
21
+
type runtime_values = Obj.t StringMap.t
22
+
23
+
type t = {
24
+
id : id;
25
+
mutable toplevel_env : Env.t option;
26
+
mutable runtime_values : runtime_values;
27
+
mutable is_setup : bool;
28
+
failed_cells : StringSet.t ref;
29
+
}
30
+
31
+
let default_id = "default"
32
+
33
+
(* Global table of environments *)
34
+
let environments : (id, t) Hashtbl.t = Hashtbl.create 16
35
+
36
+
let create id =
37
+
let env = {
38
+
id;
39
+
toplevel_env = None;
40
+
runtime_values = StringMap.empty;
41
+
is_setup = false;
42
+
failed_cells = ref StringSet.empty;
43
+
} in
44
+
Hashtbl.replace environments id env;
45
+
env
46
+
47
+
let get id = Hashtbl.find_opt environments id
48
+
49
+
let get_or_create id =
50
+
match get id with
51
+
| Some env -> env
52
+
| None -> create id
53
+
54
+
let destroy id = Hashtbl.remove environments id
55
+
56
+
let list () = Hashtbl.fold (fun id _ acc -> id :: acc) environments []
57
+
58
+
let id env = env.id
59
+
60
+
(** Get the toplevel name for a binding identifier.
61
+
This is used to look up runtime values via Toploop.getvalue. *)
62
+
let toplevel_name ident = Translmod.toplevel_name ident
63
+
64
+
(** Restore runtime values from the stored map.
65
+
This sets the values in the bytecode global table. *)
66
+
let restore_runtime_values env_id values =
67
+
let count = StringMap.cardinal values in
68
+
if count > 0 then
69
+
log_debug (Printf.sprintf "[ENV] Restoring %d runtime values for env %s" count env_id);
70
+
StringMap.iter (fun name value ->
71
+
try
72
+
log_debug (Printf.sprintf "[ENV] setvalue %s" name);
73
+
Toploop.setvalue name value
74
+
with e ->
75
+
log_debug (Printf.sprintf "[ENV] setvalue %s failed: %s" name (Printexc.to_string e))
76
+
) values
77
+
78
+
(** Check if an identifier is a value binding in the given environment.
79
+
Returns true for let-bindings, false for exceptions, modules, types, etc. *)
80
+
let is_value_binding typing_env ident =
81
+
try
82
+
let path = Path.Pident ident in
83
+
let _ = Env.find_value path typing_env in
84
+
true
85
+
with Not_found -> false
86
+
87
+
(** Capture runtime values for the given identifiers.
88
+
Only captures value bindings (not exceptions, modules, etc.).
89
+
Returns an updated map with the new values. *)
90
+
let capture_runtime_values typing_env env_id base_map idents =
91
+
(* Filter to only value bindings to avoid "Fatal error" from Toploop.getvalue *)
92
+
let value_idents = List.filter (is_value_binding typing_env) idents in
93
+
if value_idents <> [] then
94
+
log_debug (Printf.sprintf "[ENV] Capturing %d value bindings for env %s (filtered from %d total)"
95
+
(List.length value_idents) env_id (List.length idents));
96
+
List.fold_left (fun map ident ->
97
+
let name = toplevel_name ident in
98
+
try
99
+
let value = Toploop.getvalue name in
100
+
log_debug (Printf.sprintf "[ENV] captured %s" name);
101
+
StringMap.add name value map
102
+
with e ->
103
+
log_debug (Printf.sprintf "[ENV] could not capture %s: %s" name (Printexc.to_string e));
104
+
map
105
+
) base_map value_idents
106
+
107
+
let with_env env f =
108
+
log_debug (Printf.sprintf "[ENV] with_env called for %s (has_saved_env=%b, runtime_values_count=%d)"
109
+
env.id (Option.is_some env.toplevel_env) (StringMap.cardinal env.runtime_values));
110
+
111
+
(* Save current toplevel environment *)
112
+
let saved_typing_env = !Toploop.toplevel_env in
113
+
let saved_typing_env_before =
114
+
match env.toplevel_env with
115
+
| Some e -> e
116
+
| None -> saved_typing_env
117
+
in
118
+
119
+
(* Restore this environment's typing environment if we have one *)
120
+
(match env.toplevel_env with
121
+
| Some e -> Toploop.toplevel_env := e
122
+
| None -> ());
123
+
124
+
(* Restore this environment's runtime values *)
125
+
restore_runtime_values env.id env.runtime_values;
126
+
127
+
(* Run the function *)
128
+
let result =
129
+
try f ()
130
+
with exn ->
131
+
(* Capture new bindings before re-raising *)
132
+
let current_typing_env = !Toploop.toplevel_env in
133
+
let new_idents = Env.diff saved_typing_env_before current_typing_env in
134
+
let updated_values = capture_runtime_values current_typing_env env.id env.runtime_values new_idents in
135
+
env.runtime_values <- updated_values;
136
+
env.toplevel_env <- Some current_typing_env;
137
+
Toploop.toplevel_env := saved_typing_env;
138
+
raise exn
139
+
in
140
+
141
+
(* Capture new bindings that were added during execution *)
142
+
let current_typing_env = !Toploop.toplevel_env in
143
+
let new_idents = Env.diff saved_typing_env_before current_typing_env in
144
+
log_debug (Printf.sprintf "[ENV] Env.diff found %d new idents for %s" (List.length new_idents) env.id);
145
+
let updated_values = capture_runtime_values current_typing_env env.id env.runtime_values new_idents in
146
+
147
+
(* Save the updated environment state *)
148
+
env.runtime_values <- updated_values;
149
+
env.toplevel_env <- Some !Toploop.toplevel_env;
150
+
151
+
(* Restore the previous typing environment *)
152
+
Toploop.toplevel_env := saved_typing_env;
153
+
154
+
result
155
+
156
+
let is_setup env = env.is_setup
157
+
158
+
let mark_setup env = env.is_setup <- true
159
+
160
+
let get_failed_cells env = !(env.failed_cells)
161
+
162
+
let add_failed_cell env cell_id =
163
+
env.failed_cells := StringSet.add cell_id !(env.failed_cells)
164
+
165
+
let remove_failed_cell env cell_id =
166
+
env.failed_cells := StringSet.remove cell_id !(env.failed_cells)
167
+
168
+
let is_cell_failed env cell_id =
169
+
StringSet.mem cell_id !(env.failed_cells)
+72
js_top_worker/lib/environment.mli
+72
js_top_worker/lib/environment.mli
···
1
+
(** Multiple isolated execution environments.
2
+
3
+
This module provides support for running multiple isolated OCaml
4
+
evaluation contexts within a single worker. Each environment has
5
+
its own type environment, allowing independent code execution
6
+
without interference.
7
+
8
+
Libraries are shared across all environments to save memory - once
9
+
a library is loaded, it's available to all environments. *)
10
+
11
+
(** {1 Types} *)
12
+
13
+
type t
14
+
(** An isolated execution environment. *)
15
+
16
+
type id = string
17
+
(** Environment identifier. *)
18
+
19
+
(** {1 Environment Management} *)
20
+
21
+
val create : id -> t
22
+
(** [create id] creates a new environment with the given identifier.
23
+
The environment starts uninitialized; call [setup] after creation. *)
24
+
25
+
val get : id -> t option
26
+
(** [get id] returns the environment with the given identifier, if it exists. *)
27
+
28
+
val get_or_create : id -> t
29
+
(** [get_or_create id] returns the existing environment or creates a new one. *)
30
+
31
+
val destroy : id -> unit
32
+
(** [destroy id] removes the environment with the given identifier. *)
33
+
34
+
val list : unit -> id list
35
+
(** [list ()] returns all environment identifiers. *)
36
+
37
+
val default_id : id
38
+
(** The default environment identifier used when none is specified. *)
39
+
40
+
val id : t -> id
41
+
(** [id env] returns the identifier of the environment. *)
42
+
43
+
(** {1 Environment Switching} *)
44
+
45
+
val with_env : t -> (unit -> 'a) -> 'a
46
+
(** [with_env env f] runs [f ()] in the context of environment [env].
47
+
The toplevel environment is saved before and restored after,
48
+
allowing isolated execution. *)
49
+
50
+
(** {1 Environment State} *)
51
+
52
+
val is_setup : t -> bool
53
+
(** [is_setup env] returns whether [setup] has been called for this environment. *)
54
+
55
+
val mark_setup : t -> unit
56
+
(** [mark_setup env] marks the environment as having completed setup. *)
57
+
58
+
(** {1 Failed Cells Tracking} *)
59
+
60
+
module StringSet : Set.S with type elt = string
61
+
62
+
val get_failed_cells : t -> StringSet.t
63
+
(** [get_failed_cells env] returns the set of cell IDs that failed to compile. *)
64
+
65
+
val add_failed_cell : t -> string -> unit
66
+
(** [add_failed_cell env cell_id] marks a cell as failed. *)
67
+
68
+
val remove_failed_cell : t -> string -> unit
69
+
(** [remove_failed_cell env cell_id] marks a cell as no longer failed. *)
70
+
71
+
val is_cell_failed : t -> string -> bool
72
+
(** [is_cell_failed env cell_id] checks if a cell is marked as failed. *)
+313
js_top_worker/lib/findlibish.ml
+313
js_top_worker/lib/findlibish.ml
···
1
+
(* Kinda findlib, sorta *)
2
+
3
+
type library = {
4
+
name : string;
5
+
meta_uri : Uri.t;
6
+
archive_name : string option;
7
+
dir : string option;
8
+
deps : string list;
9
+
children : library list;
10
+
mutable loaded : bool;
11
+
}
12
+
13
+
let rec flatten_libs libs =
14
+
let handle_lib l =
15
+
let children = flatten_libs l.children in
16
+
l :: children
17
+
in
18
+
List.map handle_lib libs |> List.flatten
19
+
20
+
let preloaded =
21
+
[
22
+
"angstrom";
23
+
"astring";
24
+
"compiler-libs.common";
25
+
"compiler-libs.toplevel";
26
+
"findlib";
27
+
"findlib.top";
28
+
"fpath";
29
+
"js_of_ocaml-compiler";
30
+
"js_of_ocaml-ppx";
31
+
"js_of_ocaml-toplevel";
32
+
"js_top_worker";
33
+
"js_top_worker-rpc";
34
+
"logs";
35
+
"logs.browser";
36
+
"merlin-lib.kernel";
37
+
"merlin-lib.ocaml_parsing";
38
+
"merlin-lib.query_commands";
39
+
"merlin-lib.query_protocol";
40
+
"merlin-lib.utils";
41
+
"mime_printer";
42
+
"uri";
43
+
]
44
+
45
+
let rec read_libraries_from_pkg_defs ~library_name ~dir meta_uri pkg_expr =
46
+
try
47
+
Jslib.log "Reading library: %s" library_name;
48
+
let pkg_defs = pkg_expr.Fl_metascanner.pkg_defs in
49
+
(* Try to find archive with various predicates.
50
+
PPX packages often only define archive(ppx_driver,byte), so we need to
51
+
check multiple predicate combinations to find the right archive. *)
52
+
let archive_filename =
53
+
(* First try with ppx_driver,byte - this catches PPX libraries like ppx_deriving.show *)
54
+
try Some (Fl_metascanner.lookup "archive" [ "ppx_driver"; "byte" ] pkg_defs)
55
+
with _ -> (
56
+
(* Then try plain byte *)
57
+
try Some (Fl_metascanner.lookup "archive" [ "byte" ] pkg_defs)
58
+
with _ -> (
59
+
(* Then try native as fallback *)
60
+
try Some (Fl_metascanner.lookup "archive" [ "native" ] pkg_defs)
61
+
with _ -> None))
62
+
in
63
+
64
+
(* Use -ppx_driver predicate for toplevel use - this ensures PPX packages
65
+
pull in their runtime dependencies (e.g., ppx_deriving.show requires
66
+
ppx_deriving.runtime when not using ppx_driver) *)
67
+
let predicates = ["-ppx_driver"] in
68
+
let deps_str =
69
+
try Fl_metascanner.lookup "requires" predicates pkg_defs with _ -> "" in
70
+
let deps = Astring.String.fields ~empty:false deps_str in
71
+
let subdir =
72
+
List.find_opt (fun d -> d.Fl_metascanner.def_var = "directory") pkg_defs
73
+
|> Option.map (fun d -> d.Fl_metascanner.def_value)
74
+
in
75
+
let dir =
76
+
match (dir, subdir) with
77
+
| None, None -> None
78
+
| Some d, None -> Some d
79
+
| None, Some d -> Some d
80
+
| Some d1, Some d2 -> Some (Filename.concat d1 d2)
81
+
in
82
+
let archive_name =
83
+
Option.bind archive_filename (fun a ->
84
+
let file_name_len = String.length a in
85
+
if file_name_len > 0 then Some (Filename.chop_extension a) else None)
86
+
in
87
+
Jslib.log "Number of children: %d" (List.length pkg_expr.pkg_children);
88
+
let children =
89
+
List.filter_map
90
+
(fun (n, expr) ->
91
+
Jslib.log "Found child: %s" n;
92
+
let library_name = library_name ^ "." ^ n in
93
+
match
94
+
read_libraries_from_pkg_defs ~library_name ~dir meta_uri expr
95
+
with
96
+
| Ok l -> Some l
97
+
| Error (`Msg m) ->
98
+
Jslib.log "Error reading sub-library: %s" m;
99
+
None)
100
+
pkg_expr.pkg_children
101
+
in
102
+
Ok
103
+
{
104
+
name = library_name;
105
+
archive_name;
106
+
dir;
107
+
deps;
108
+
meta_uri;
109
+
loaded = false;
110
+
children;
111
+
}
112
+
with Not_found -> Error (`Msg "Failed to read libraries from pkg_defs")
113
+
114
+
type t = library list
115
+
116
+
let dcs_filename = "dynamic_cmis.json"
117
+
118
+
let fetch_dynamic_cmis sync_get url =
119
+
match sync_get url with
120
+
| None -> Error (`Msg "Failed to fetch dynamic cmis")
121
+
| Some json ->
122
+
let rpc = Jsonrpc.of_string json in
123
+
Rpcmarshal.unmarshal
124
+
Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis rpc
125
+
126
+
let (let*) = Lwt.bind
127
+
128
+
(** Parse a findlib_index file (JSON or legacy text format) and return
129
+
the list of META file paths and universe paths.
130
+
131
+
JSON format: {"meta_files": ["path/to/META", ...], "universes": ["universe1", ...]}
132
+
133
+
meta_files: direct paths to META files
134
+
universes: paths to other universes (directories containing findlib_index) *)
135
+
let parse_findlib_index content =
136
+
(* Try JSON format first *)
137
+
try
138
+
let json = Yojson.Safe.from_string content in
139
+
let open Yojson.Safe.Util in
140
+
(* Support both "meta_files" and "metas" for compatibility *)
141
+
let meta_files =
142
+
try json |> member "meta_files" |> to_list |> List.map to_string
143
+
with _ ->
144
+
try json |> member "metas" |> to_list |> List.map to_string
145
+
with _ -> []
146
+
in
147
+
(* Support both "universes" and "deps" for compatibility *)
148
+
let universes =
149
+
try json |> member "universes" |> to_list |> List.map to_string
150
+
with _ ->
151
+
try json |> member "deps" |> to_list |> List.map to_string
152
+
with _ -> []
153
+
in
154
+
(meta_files, universes)
155
+
with _ ->
156
+
(* Fall back to legacy whitespace-separated format (no universes) *)
157
+
(Astring.String.fields ~empty:false content, [])
158
+
159
+
(** Load a single META file and parse it into a library *)
160
+
let load_meta async_get meta_path =
161
+
let* res = async_get meta_path in
162
+
match res with
163
+
| Error (`Msg m) ->
164
+
Jslib.log "Error fetching findlib meta %s: %s" meta_path m;
165
+
Lwt.return_none
166
+
| Ok meta_content ->
167
+
match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference meta_path with
168
+
| Ok uri -> (
169
+
Jslib.log "Parsed uri: %s" (Uri.path uri);
170
+
let path = Uri.path uri in
171
+
let file = Fpath.v path in
172
+
let base_library_name =
173
+
if Fpath.basename file = "META" then
174
+
Fpath.parent file |> Fpath.basename
175
+
else Fpath.get_ext file
176
+
in
177
+
let lexing = Lexing.from_string meta_content in
178
+
try
179
+
let meta = Fl_metascanner.parse_lexing lexing in
180
+
let libraries =
181
+
read_libraries_from_pkg_defs ~library_name:base_library_name
182
+
~dir:None uri meta
183
+
in
184
+
Lwt.return (Result.to_option libraries)
185
+
with _ ->
186
+
Jslib.log "Failed to parse meta: %s" (Uri.path uri);
187
+
Lwt.return_none)
188
+
| Error m ->
189
+
Jslib.log "Failed to parse uri: %s" m;
190
+
Lwt.return_none
191
+
192
+
(** Resolve a path relative to the directory of the base URL.
193
+
Used for meta_files which are relative to their findlib_index.
194
+
e.g. base="http://host/demo1/base/findlib_index", path="lib/base/META"
195
+
=> "http://host/demo1/base/lib/base/META" *)
196
+
let resolve_relative_to_dir ~base path =
197
+
match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference base with
198
+
| Ok base_uri ->
199
+
let base_path = Uri.path base_uri in
200
+
let parent_dir =
201
+
match Fpath.of_string base_path with
202
+
| Ok p -> Fpath.parent p |> Fpath.to_string
203
+
| Error _ -> "/"
204
+
in
205
+
let resolved = Filename.concat parent_dir path in
206
+
Uri.with_path base_uri resolved |> Uri.to_string
207
+
| Error _ -> path
208
+
209
+
(** Resolve a path as absolute from root (preserving scheme/host from base).
210
+
Used for universe paths which are already full paths from root.
211
+
e.g. base="http://host/demo1/findlib_index", path="demo1/base/findlib_index"
212
+
=> "http://host/demo1/base/findlib_index" *)
213
+
let resolve_from_root ~base path =
214
+
match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference base with
215
+
| Ok base_uri ->
216
+
let resolved = "/" ^ path in
217
+
Uri.with_path base_uri resolved |> Uri.to_string
218
+
| Error _ -> "/" ^ path
219
+
220
+
let init (async_get : string -> (string, [>`Msg of string]) result Lwt.t) findlib_index : t Lwt.t =
221
+
Jslib.log "Initializing findlib";
222
+
(* Track visited universes to avoid infinite loops *)
223
+
let visited = Hashtbl.create 16 in
224
+
let rec load_universe index_url =
225
+
if Hashtbl.mem visited index_url then
226
+
Lwt.return []
227
+
else begin
228
+
Hashtbl.add visited index_url ();
229
+
let* findlib_txt = async_get index_url in
230
+
match findlib_txt with
231
+
| Error (`Msg m) ->
232
+
Jslib.log "Error fetching findlib index %s: %s" index_url m;
233
+
Lwt.return []
234
+
| Ok content ->
235
+
let meta_files, universes = parse_findlib_index content in
236
+
Jslib.log "Loaded findlib_index %s: %d META files, %d universes"
237
+
index_url (List.length meta_files) (List.length universes);
238
+
(* Resolve META paths relative to findlib_index directory *)
239
+
let resolved_metas =
240
+
List.map (fun p -> resolve_relative_to_dir ~base:index_url p) meta_files
241
+
in
242
+
(* Load META files from this universe *)
243
+
let* local_libs = Lwt_list.filter_map_p (load_meta async_get) resolved_metas in
244
+
(* Resolve universe paths from root (they're already full paths) *)
245
+
let universe_index_urls =
246
+
List.map (fun u ->
247
+
resolve_from_root ~base:index_url (Filename.concat u "findlib_index"))
248
+
universes
249
+
in
250
+
let* universe_libs = Lwt_list.map_p load_universe universe_index_urls in
251
+
Lwt.return (local_libs @ List.flatten universe_libs)
252
+
end
253
+
in
254
+
let* all_libs = load_universe findlib_index in
255
+
Lwt.return (flatten_libs all_libs)
256
+
257
+
let require ~import_scripts sync_get cmi_only v packages =
258
+
let rec require dcss package :
259
+
Js_top_worker_rpc.Toplevel_api_gen.dynamic_cmis list =
260
+
match List.find (fun lib -> lib.name = package) v with
261
+
| exception Not_found ->
262
+
Jslib.log "Package %s not found" package;
263
+
let available =
264
+
v
265
+
|> List.map (fun lib ->
266
+
Printf.sprintf "%s (%d)" lib.name (List.length lib.children))
267
+
|> String.concat ", "
268
+
in
269
+
Jslib.log "Available packages: %s" available;
270
+
dcss
271
+
| lib ->
272
+
if lib.loaded then dcss
273
+
else (
274
+
Jslib.log "Loading package %s" lib.name;
275
+
Jslib.log "lib.dir: %s" (Option.value ~default:"None" lib.dir);
276
+
let dep_dcs = List.fold_left require dcss lib.deps in
277
+
let path = Fpath.(v (Uri.path lib.meta_uri) |> parent) in
278
+
let dir =
279
+
match lib.dir with
280
+
| None -> path
281
+
| Some "+" -> Fpath.parent path (* "+" means parent dir in findlib *)
282
+
| Some d when String.length d > 0 && d.[0] = '^' ->
283
+
(* "^" prefix means relative to stdlib dir - treat as parent *)
284
+
Fpath.parent path
285
+
| Some d -> Fpath.(path // v d)
286
+
in
287
+
let dcs = Fpath.(dir / dcs_filename |> to_string) in
288
+
let uri = Uri.with_path lib.meta_uri dcs in
289
+
Jslib.log "uri: %s" (Uri.to_string uri);
290
+
match fetch_dynamic_cmis sync_get (Uri.to_string uri) with
291
+
| Ok dcs ->
292
+
let should_load =
293
+
(not (List.mem lib.name preloaded)) && not cmi_only
294
+
in
295
+
Option.iter
296
+
(fun archive ->
297
+
if should_load then begin
298
+
let archive_js =
299
+
Fpath.(dir / (archive ^ ".cma.js") |> to_string)
300
+
in
301
+
import_scripts
302
+
[ Uri.with_path uri archive_js |> Uri.to_string ]
303
+
end)
304
+
lib.archive_name;
305
+
lib.loaded <- true;
306
+
Jslib.log "Finished loading package %s" lib.name;
307
+
dcs :: dep_dcs
308
+
| Error (`Msg m) ->
309
+
Jslib.log "Failed to unmarshal dynamic_cms from url %s: %s"
310
+
(Uri.to_string uri) m;
311
+
dcss)
312
+
in
313
+
List.fold_left require [] packages
+1164
js_top_worker/lib/impl.ml
+1164
js_top_worker/lib/impl.ml
···
1
+
(** {1 OCaml Toplevel Implementation}
2
+
3
+
This module provides the core toplevel functionality for js_top_worker.
4
+
It implements phrase execution, type checking, and Merlin integration
5
+
(completion, errors, type info).
6
+
7
+
The module is parameterized by a backend signature [S] which provides
8
+
platform-specific operations for different environments (WebWorker,
9
+
Node.js, Unix). *)
10
+
11
+
open Js_top_worker_rpc
12
+
module M = Rpc_lwt.ErrM (* Server is not synchronous *)
13
+
module IdlM = Rpc_lwt
14
+
15
+
let ( let* ) = Lwt.bind
16
+
17
+
(** {2 Cell Dependency System}
18
+
19
+
Cells are identified by string IDs and can depend on previous cells.
20
+
Each cell is wrapped in a module [Cell__<id>] so that later cells can
21
+
access earlier bindings via [open Cell__<id>]. *)
22
+
23
+
type captured = { stdout : string; stderr : string }
24
+
25
+
let modname_of_id id = "Cell__" ^ id
26
+
27
+
let is_mangled_broken orig src =
28
+
String.length orig <> String.length src
29
+
|| Seq.exists2
30
+
(fun c c' -> c <> c' && c' <> ' ')
31
+
(String.to_seq orig) (String.to_seq src)
32
+
33
+
let mangle_toplevel is_toplevel orig_source deps =
34
+
let src =
35
+
if not is_toplevel then orig_source
36
+
else if
37
+
String.length orig_source < 2
38
+
|| orig_source.[0] <> '#'
39
+
|| orig_source.[1] <> ' '
40
+
then (
41
+
Logs.err (fun m ->
42
+
m "xx Warning, ignoring toplevel block without a leading '# '.\n%!");
43
+
orig_source)
44
+
else
45
+
try
46
+
let s = String.sub orig_source 2 (String.length orig_source - 2) in
47
+
let list =
48
+
try Ocamltop.parse_toplevel s
49
+
with _ -> Ocamltop.fallback_parse_toplevel s
50
+
in
51
+
let lines =
52
+
List.map
53
+
(fun (phr, junk, output) ->
54
+
let l1 =
55
+
Printf.sprintf " %s%s" phr
56
+
(String.make (String.length junk) ' ')
57
+
in
58
+
match output with
59
+
| [] -> l1
60
+
| _ ->
61
+
let s =
62
+
List.map (fun x -> String.make (String.length x) ' ') output
63
+
in
64
+
String.concat "\n" (l1 :: s))
65
+
list
66
+
in
67
+
String.concat "\n" lines
68
+
with e ->
69
+
Logs.err (fun m ->
70
+
m "Error in mangle_toplevel: %s" (Printexc.to_string e));
71
+
let ppf = Format.err_formatter in
72
+
let _ = Location.report_exception ppf e in
73
+
orig_source
74
+
in
75
+
let line1 =
76
+
List.map (fun id -> Printf.sprintf "open %s" (modname_of_id id)) deps
77
+
|> String.concat " "
78
+
in
79
+
let line1 = if line1 = "" then "" else line1 ^ ";;\n" in
80
+
Logs.debug (fun m -> m "Line 1: '%s'\n%!" line1);
81
+
Logs.debug (fun m -> m "Source: %s\n%!" src);
82
+
if is_mangled_broken orig_source src then (
83
+
Printf.printf "Warning: mangled source is broken\n%!";
84
+
Printf.printf "orig length: %d\n%!" (String.length orig_source);
85
+
Printf.printf "src length: %d\n%!" (String.length src));
86
+
(line1, src)
87
+
88
+
(** {2 PPX Preprocessing}
89
+
90
+
Handles PPX rewriter registration and application. Supports:
91
+
- Old-style [Ast_mapper] PPXs (e.g., [Ppx_js.mapper] for js_of_ocaml)
92
+
- [ppx_deriving]-based PPXs (registered via [Ppx_deriving.register])
93
+
- Modern [ppxlib]-based PPXs (registered via [Ppxlib.Driver])
94
+
95
+
The [Ppx_js.mapper] is registered by default to support js_of_ocaml
96
+
syntax extensions. Other PPXs can be dynamically loaded via [#require]. *)
97
+
98
+
module JsooTopPpx = struct
99
+
open Js_of_ocaml_compiler.Stdlib
100
+
101
+
(** Old-style Ast_mapper rewriters *)
102
+
let ppx_rewriters = ref [ (fun _ -> Ppx_js.mapper) ]
103
+
104
+
let () =
105
+
Ast_mapper.register_function :=
106
+
fun _ f -> ppx_rewriters := f :: !ppx_rewriters
107
+
108
+
(** Apply old-style Ast_mapper rewriters *)
109
+
let apply_ast_mapper_rewriters_structure str =
110
+
let open Ast_mapper in
111
+
List.fold_right !ppx_rewriters ~init:str ~f:(fun ppx_rewriter str ->
112
+
let mapper = ppx_rewriter [] in
113
+
mapper.structure mapper str)
114
+
115
+
let apply_ast_mapper_rewriters_signature sg =
116
+
let open Ast_mapper in
117
+
List.fold_right !ppx_rewriters ~init:sg ~f:(fun ppx_rewriter sg ->
118
+
let mapper = ppx_rewriter [] in
119
+
mapper.signature mapper sg)
120
+
121
+
(** Apply ppx_deriving transformations using its mapper class.
122
+
This handles [@@deriving] attributes for dynamically loaded derivers. *)
123
+
let apply_ppx_deriving_structure str =
124
+
let mapper = new Ppx_deriving.mapper in
125
+
mapper#structure str
126
+
127
+
let apply_ppx_deriving_signature sg =
128
+
let mapper = new Ppx_deriving.mapper in
129
+
mapper#signature sg
130
+
131
+
(** Apply all PPX transformations in order:
132
+
1. Old-style Ast_mapper (e.g., Ppx_js)
133
+
2. ppx_deriving derivers
134
+
3. ppxlib-based PPXs
135
+
Handles AST version conversion between compiler's Parsetree and ppxlib's internal AST. *)
136
+
let preprocess_structure str =
137
+
str
138
+
|> apply_ast_mapper_rewriters_structure
139
+
|> Ppxlib_ast.Selected_ast.of_ocaml Structure
140
+
|> apply_ppx_deriving_structure
141
+
|> Ppxlib.Driver.map_structure
142
+
|> Ppxlib_ast.Selected_ast.to_ocaml Structure
143
+
144
+
let preprocess_signature sg =
145
+
sg
146
+
|> apply_ast_mapper_rewriters_signature
147
+
|> Ppxlib_ast.Selected_ast.of_ocaml Signature
148
+
|> apply_ppx_deriving_signature
149
+
|> Ppxlib.Driver.map_signature
150
+
|> Ppxlib_ast.Selected_ast.to_ocaml Signature
151
+
152
+
let preprocess_phrase phrase =
153
+
let open Parsetree in
154
+
match phrase with
155
+
| Ptop_def str -> Ptop_def (preprocess_structure str)
156
+
| Ptop_dir _ as x -> x
157
+
end
158
+
159
+
(** {2 Backend Signature}
160
+
161
+
Platform-specific operations that must be provided by each backend
162
+
(WebWorker, Node.js, Unix). *)
163
+
164
+
module type S = sig
165
+
type findlib_t
166
+
167
+
val capture : (unit -> 'a) -> unit -> captured * 'a
168
+
val create_file : name:string -> content:string -> unit
169
+
val sync_get : string -> string option
170
+
val async_get : string -> (string, [> `Msg of string ]) result Lwt.t
171
+
val import_scripts : string list -> unit
172
+
val init_function : string -> unit -> unit
173
+
val get_stdlib_dcs : string -> Toplevel_api_gen.dynamic_cmis list
174
+
val findlib_init : string -> findlib_t Lwt.t
175
+
val path : string
176
+
177
+
val require :
178
+
bool -> findlib_t -> string list -> Toplevel_api_gen.dynamic_cmis list
179
+
end
180
+
181
+
(** {2 Main Functor}
182
+
183
+
The toplevel implementation, parameterized by backend operations. *)
184
+
185
+
module Make (S : S) = struct
186
+
(** {3 Global State}
187
+
188
+
These are shared across all environments. *)
189
+
190
+
let functions : (unit -> unit) list option ref = ref None
191
+
let requires : string list ref = ref []
192
+
let path : string option ref = ref None
193
+
let findlib_v : S.findlib_t Lwt.t option ref = ref None
194
+
let findlib_resolved : S.findlib_t option ref = ref None
195
+
let execution_allowed = ref true
196
+
197
+
(** {3 Environment Management}
198
+
199
+
Helper to resolve env_id string to an Environment.t.
200
+
Empty string means the default environment. *)
201
+
202
+
let resolve_env env_id =
203
+
let id = if env_id = "" then Environment.default_id else env_id in
204
+
Environment.get_or_create id
205
+
206
+
(** {3 Lexer Helpers} *)
207
+
208
+
let refill_lexbuf s p ppf buffer len =
209
+
if !p = String.length s then 0
210
+
else
211
+
let len', nl =
212
+
try (String.index_from s !p '\n' - !p + 1, false)
213
+
with _ -> (String.length s - !p, true)
214
+
in
215
+
let len'' = min len len' in
216
+
String.blit s !p buffer 0 len'';
217
+
(match ppf with
218
+
| Some ppf ->
219
+
Format.fprintf ppf "%s" (Bytes.sub_string buffer 0 len'');
220
+
if nl then Format.pp_print_newline ppf ();
221
+
Format.pp_print_flush ppf ()
222
+
| None -> ());
223
+
p := !p + len'';
224
+
len''
225
+
226
+
(** {3 Setup and Initialization} *)
227
+
228
+
let exec' s =
229
+
S.capture
230
+
(fun () ->
231
+
let res : bool = Toploop.use_silently Format.std_formatter (String s) in
232
+
if not res then Format.eprintf "error while evaluating %s@." s)
233
+
()
234
+
235
+
(** {3 Custom Require Directive}
236
+
237
+
Replaces the standard findlib #require with one that loads JavaScript
238
+
archives via importScripts. This is necessary because in js_of_ocaml,
239
+
we can't use Topdirs.dir_load to load .cma files - we need to load
240
+
.cma.js files via importScripts instead. *)
241
+
242
+
let add_dynamic_cmis_sync dcs =
243
+
(* Synchronous version for #require directive.
244
+
Fetches and installs toplevel CMIs synchronously. *)
245
+
let furl = "file://" in
246
+
let l = String.length furl in
247
+
if String.length dcs.Toplevel_api_gen.dcs_url > l
248
+
&& String.sub dcs.dcs_url 0 l = furl
249
+
then begin
250
+
let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
251
+
Topdirs.dir_directory path
252
+
end
253
+
else begin
254
+
(* Web URL - fetch CMIs synchronously *)
255
+
let fetch_sync filename =
256
+
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
257
+
S.sync_get url
258
+
in
259
+
let path =
260
+
match !path with Some p -> p | None -> failwith "Path not set"
261
+
in
262
+
let to_cmi_filename name =
263
+
Printf.sprintf "%s.cmi" (String.uncapitalize_ascii name)
264
+
in
265
+
Logs.info (fun m -> m "Adding toplevel modules for dynamic cmis from %s" dcs.dcs_url);
266
+
Logs.info (fun m -> m " toplevel modules: %s"
267
+
(String.concat ", " dcs.dcs_toplevel_modules));
268
+
(* Fetch and create toplevel module CMIs *)
269
+
List.iter
270
+
(fun name ->
271
+
let filename = to_cmi_filename name in
272
+
match fetch_sync filename with
273
+
| Some content ->
274
+
let fs_name = Filename.(concat path filename) in
275
+
(try S.create_file ~name:fs_name ~content with _ -> ())
276
+
| None -> ())
277
+
dcs.dcs_toplevel_modules;
278
+
(* Install on-demand loader for prefixed modules *)
279
+
if dcs.dcs_file_prefixes <> [] then begin
280
+
let open Persistent_env.Persistent_signature in
281
+
let old_loader = !load in
282
+
load := fun ~allow_hidden ~unit_name ->
283
+
let filename = to_cmi_filename unit_name in
284
+
let fs_name = Filename.(concat path filename) in
285
+
if (not (Sys.file_exists fs_name))
286
+
&& List.exists
287
+
(fun prefix -> String.starts_with ~prefix filename)
288
+
dcs.dcs_file_prefixes
289
+
then begin
290
+
Logs.info (fun m -> m "Fetching %s\n%!" filename);
291
+
match fetch_sync filename with
292
+
| Some content ->
293
+
(try S.create_file ~name:fs_name ~content with _ -> ())
294
+
| None -> ()
295
+
end;
296
+
old_loader ~allow_hidden ~unit_name
297
+
end
298
+
end
299
+
300
+
let register_require_directive () =
301
+
let require_handler pkg =
302
+
Logs.info (fun m -> m "Custom #require: loading %s" pkg);
303
+
match !findlib_resolved with
304
+
| None ->
305
+
Format.eprintf "Error: findlib not initialized@."
306
+
| Some v ->
307
+
let cmi_only = not !execution_allowed in
308
+
let dcs_list = S.require cmi_only v [pkg] in
309
+
List.iter add_dynamic_cmis_sync dcs_list;
310
+
Logs.info (fun m -> m "Custom #require: %s loaded" pkg)
311
+
in
312
+
(* Replace the standard findlib #require directive with our custom one.
313
+
We use add_directive which will override the existing one. *)
314
+
let info = { Toploop.section = "Findlib"; doc = "Load a package (js_top_worker)" } in
315
+
Toploop.add_directive "require" (Toploop.Directive_string require_handler) info
316
+
317
+
let setup functions () =
318
+
let stdout_buff = Buffer.create 100 in
319
+
let stderr_buff = Buffer.create 100 in
320
+
321
+
let combine o =
322
+
Buffer.add_string stdout_buff o.stdout;
323
+
Buffer.add_string stderr_buff o.stderr
324
+
in
325
+
326
+
let exec' s =
327
+
let o, () = exec' s in
328
+
combine o
329
+
in
330
+
Sys.interactive := false;
331
+
332
+
Toploop.input_name := "//toplevel//";
333
+
let path =
334
+
match !path with Some p -> p | None -> failwith "Path not set"
335
+
in
336
+
337
+
Topdirs.dir_directory path;
338
+
339
+
Toploop.initialize_toplevel_env ();
340
+
341
+
List.iter (fun f -> f ()) functions;
342
+
exec' "open Stdlib";
343
+
let header1 = Printf.sprintf " %s version %%s" "OCaml" in
344
+
exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
345
+
exec' "#enable \"pretty\";;";
346
+
exec' "#disable \"shortvar\";;";
347
+
Sys.interactive := true;
348
+
Logs.info (fun m -> m "Setup complete");
349
+
{
350
+
stdout = Buffer.contents stdout_buff;
351
+
stderr = Buffer.contents stderr_buff;
352
+
}
353
+
354
+
(** {3 Output Helpers} *)
355
+
356
+
let stdout_buff = Buffer.create 100
357
+
let stderr_buff = Buffer.create 100
358
+
359
+
let buff_opt b =
360
+
match String.trim (Buffer.contents b) with "" -> None | s -> Some s
361
+
362
+
let string_opt s = match String.trim s with "" -> None | s -> Some s
363
+
364
+
let loc = function
365
+
| Syntaxerr.Error x -> Some (Syntaxerr.location_of_error x)
366
+
| Lexer.Error (_, loc)
367
+
| Typecore.Error (loc, _, _)
368
+
| Typetexp.Error (loc, _, _)
369
+
| Typeclass.Error (loc, _, _)
370
+
| Typemod.Error (loc, _, _)
371
+
| Typedecl.Error (loc, _)
372
+
| Translcore.Error (loc, _)
373
+
| Translclass.Error (loc, _)
374
+
| Translmod.Error (loc, _) ->
375
+
Some loc
376
+
| _ -> None
377
+
378
+
(** {3 Phrase Execution}
379
+
380
+
Executes OCaml phrases in an environment, capturing all output.
381
+
Handles parsing, PPX preprocessing, and execution with error reporting. *)
382
+
383
+
let execute_in_env env phrase =
384
+
let code_buff = Buffer.create 100 in
385
+
let res_buff = Buffer.create 100 in
386
+
let pp_code = Format.formatter_of_buffer code_buff in
387
+
let pp_result = Format.formatter_of_buffer res_buff in
388
+
let highlighted = ref None in
389
+
let set_highlight loc =
390
+
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
391
+
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
392
+
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
393
+
in
394
+
Buffer.clear code_buff;
395
+
Buffer.clear res_buff;
396
+
Buffer.clear stderr_buff;
397
+
Buffer.clear stdout_buff;
398
+
let phrase =
399
+
let l = String.length phrase in
400
+
if l >= 2 && String.sub phrase (l - 2) 2 = ";;" then phrase
401
+
else phrase ^ ";;"
402
+
in
403
+
let o, () =
404
+
Environment.with_env env (fun () ->
405
+
S.capture
406
+
(fun () ->
407
+
let lb = Lexing.from_function (refill_lexbuf phrase (ref 0) (Some pp_code)) in
408
+
(try
409
+
while true do
410
+
try
411
+
let phr = !Toploop.parse_toplevel_phrase lb in
412
+
let phr = JsooTopPpx.preprocess_phrase phr in
413
+
ignore (Toploop.execute_phrase true pp_result phr : bool)
414
+
with
415
+
| End_of_file -> raise End_of_file
416
+
| x ->
417
+
(match loc x with Some l -> set_highlight l | None -> ());
418
+
Errors.report_error Format.err_formatter x
419
+
done
420
+
with End_of_file -> ());
421
+
flush_all ())
422
+
())
423
+
in
424
+
let mime_vals = Mime_printer.get () in
425
+
Format.pp_print_flush pp_code ();
426
+
Format.pp_print_flush pp_result ();
427
+
Toplevel_api_gen.
428
+
{
429
+
stdout = string_opt o.stdout;
430
+
stderr = string_opt o.stderr;
431
+
sharp_ppf = buff_opt code_buff;
432
+
caml_ppf = buff_opt res_buff;
433
+
highlight = !highlighted;
434
+
mime_vals;
435
+
}
436
+
437
+
(** {3 Incremental Phrase Execution}
438
+
439
+
Executes OCaml phrases incrementally, calling a callback after each
440
+
phrase with its output and location. *)
441
+
442
+
type phrase_output = {
443
+
loc : int;
444
+
caml_ppf : string option;
445
+
mime_vals : Toplevel_api_gen.mime_val list;
446
+
}
447
+
448
+
let execute_in_env_incremental env phrase ~on_phrase_output =
449
+
let code_buff = Buffer.create 100 in
450
+
let res_buff = Buffer.create 100 in
451
+
let pp_code = Format.formatter_of_buffer code_buff in
452
+
let pp_result = Format.formatter_of_buffer res_buff in
453
+
let highlighted = ref None in
454
+
let set_highlight loc =
455
+
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
456
+
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
457
+
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
458
+
in
459
+
Buffer.clear code_buff;
460
+
Buffer.clear res_buff;
461
+
Buffer.clear stderr_buff;
462
+
Buffer.clear stdout_buff;
463
+
let phrase =
464
+
let l = String.length phrase in
465
+
if l >= 2 && String.sub phrase (l - 2) 2 = ";;" then phrase
466
+
else phrase ^ ";;"
467
+
in
468
+
let o, () =
469
+
Environment.with_env env (fun () ->
470
+
S.capture
471
+
(fun () ->
472
+
let lb = Lexing.from_function (refill_lexbuf phrase (ref 0) (Some pp_code)) in
473
+
(try
474
+
while true do
475
+
try
476
+
let phr = !Toploop.parse_toplevel_phrase lb in
477
+
let phr = JsooTopPpx.preprocess_phrase phr in
478
+
ignore (Toploop.execute_phrase true pp_result phr : bool);
479
+
(* Get location from phrase AST *)
480
+
let loc = match phr with
481
+
| Parsetree.Ptop_def ({ pstr_loc; _ } :: _) ->
482
+
pstr_loc.loc_end.pos_cnum
483
+
| Parsetree.Ptop_dir { pdir_loc; _ } ->
484
+
pdir_loc.loc_end.pos_cnum
485
+
| _ -> lb.lex_curr_p.pos_cnum
486
+
in
487
+
(* Flush and get current output *)
488
+
Format.pp_print_flush pp_result ();
489
+
let caml_ppf = buff_opt res_buff in
490
+
let mime_vals = Mime_printer.get () in
491
+
(* Call callback with phrase output *)
492
+
on_phrase_output { loc; caml_ppf; mime_vals };
493
+
(* Clear for next phrase *)
494
+
Buffer.clear res_buff
495
+
with
496
+
| End_of_file -> raise End_of_file
497
+
| x ->
498
+
(match loc x with Some l -> set_highlight l | None -> ());
499
+
Errors.report_error Format.err_formatter x
500
+
done
501
+
with End_of_file -> ());
502
+
flush_all ())
503
+
())
504
+
in
505
+
(* Get any remaining mime_vals (shouldn't be any after last callback) *)
506
+
let mime_vals = Mime_printer.get () in
507
+
Format.pp_print_flush pp_code ();
508
+
Format.pp_print_flush pp_result ();
509
+
Toplevel_api_gen.
510
+
{
511
+
stdout = string_opt o.stdout;
512
+
stderr = string_opt o.stderr;
513
+
sharp_ppf = buff_opt code_buff;
514
+
caml_ppf = buff_opt res_buff;
515
+
highlight = !highlighted;
516
+
mime_vals;
517
+
}
518
+
519
+
(** {3 Dynamic CMI Loading}
520
+
521
+
Handles loading .cmi files on demand for packages that weren't
522
+
compiled into the worker. *)
523
+
524
+
let filename_of_module unit_name =
525
+
Printf.sprintf "%s.cmi" (String.uncapitalize_ascii unit_name)
526
+
527
+
let get_dirs () =
528
+
let { Load_path.visible; hidden } = Load_path.get_paths () in
529
+
visible @ hidden
530
+
531
+
let reset_dirs () =
532
+
Ocaml_utils.Directory_content_cache.clear ();
533
+
let open Ocaml_utils.Load_path in
534
+
let dirs = get_dirs () in
535
+
reset ();
536
+
List.iter (fun p -> prepend_dir (Dir.create ~hidden:false p)) dirs
537
+
538
+
let reset_dirs_comp () =
539
+
let open Load_path in
540
+
let dirs = get_dirs () in
541
+
reset ();
542
+
List.iter (fun p -> prepend_dir (Dir.create ~hidden:false p)) dirs
543
+
544
+
let add_dynamic_cmis dcs =
545
+
let fetch filename =
546
+
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
547
+
S.async_get url
548
+
in
549
+
let fetch_sync filename =
550
+
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
551
+
S.sync_get url
552
+
in
553
+
let path =
554
+
match !path with Some p -> p | None -> failwith "Path not set"
555
+
in
556
+
let ( let* ) = Lwt.bind in
557
+
let* () =
558
+
Logs.info (fun m -> m "Adding toplevel modules for dynamic cmis from %s" dcs.dcs_url);
559
+
Logs.info (fun m -> m " toplevel modules: %s"
560
+
(String.concat ", " dcs.dcs_toplevel_modules));
561
+
Lwt_list.iter_p
562
+
(fun name ->
563
+
let filename = filename_of_module name in
564
+
let* r = fetch (filename_of_module name) in
565
+
let () =
566
+
match r with
567
+
| Ok content -> (
568
+
let name = Filename.(concat path filename) in
569
+
try S.create_file ~name ~content with _ -> ())
570
+
| Error _ -> ()
571
+
in
572
+
Lwt.return ())
573
+
dcs.dcs_toplevel_modules
574
+
in
575
+
576
+
let new_load ~s ~old_loader ~allow_hidden ~unit_name =
577
+
(* Logs.info (fun m -> m "%s Loading: %s" s unit_name); *)
578
+
let filename = filename_of_module unit_name in
579
+
580
+
let fs_name = Filename.(concat path filename) in
581
+
(* Check if it's already been downloaded. This will be the
582
+
case for all toplevel cmis. Also check whether we're supposed
583
+
to handle this cmi *)
584
+
(* if Sys.file_exists fs_name
585
+
then Logs.info (fun m -> m "Found: %s" fs_name)
586
+
else Logs.info (fun m -> m "No sign of %s locally" fs_name); *)
587
+
if
588
+
(not (Sys.file_exists fs_name))
589
+
&& List.exists
590
+
(fun prefix -> String.starts_with ~prefix filename)
591
+
dcs.dcs_file_prefixes
592
+
then (
593
+
Logs.info (fun m -> m "Fetching %s\n%!" filename);
594
+
match fetch_sync filename with
595
+
| Some x ->
596
+
(try S.create_file ~name:fs_name ~content:x with _ -> ());
597
+
(* At this point we need to tell merlin that the dir contents
598
+
have changed *)
599
+
if s = "merl" then reset_dirs () else reset_dirs_comp ()
600
+
| None ->
601
+
Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
602
+
(Filename.concat dcs.Toplevel_api_gen.dcs_url filename));
603
+
if s = "merl" then reset_dirs () else reset_dirs_comp ();
604
+
old_loader ~allow_hidden ~unit_name
605
+
in
606
+
let furl = "file://" in
607
+
let l = String.length furl in
608
+
let () =
609
+
if String.length dcs.dcs_url > l && String.sub dcs.dcs_url 0 l = furl then
610
+
let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
611
+
Topdirs.dir_directory path
612
+
else
613
+
let open Persistent_env.Persistent_signature in
614
+
let old_loader = !load in
615
+
load := new_load ~s:"comp" ~old_loader;
616
+
617
+
let open Ocaml_typing.Persistent_env.Persistent_signature in
618
+
let old_loader = !load in
619
+
load := new_load ~s:"merl" ~old_loader
620
+
in
621
+
Lwt.return ()
622
+
623
+
(** {3 RPC Handlers}
624
+
625
+
Functions that implement the toplevel RPC API. Each function returns
626
+
results in the [IdlM.ErrM] monad. *)
627
+
628
+
let init (init_libs : Toplevel_api_gen.init_config) =
629
+
Lwt.catch
630
+
(fun () ->
631
+
Logs.info (fun m -> m "init()");
632
+
path := Some S.path;
633
+
634
+
let findlib_path = Option.value ~default:"findlib_index" init_libs.findlib_index in
635
+
findlib_v := Some (S.findlib_init findlib_path);
636
+
637
+
let stdlib_dcs =
638
+
match init_libs.stdlib_dcs with
639
+
| Some dcs -> dcs
640
+
| None -> "lib/ocaml/dynamic_cmis.json"
641
+
in
642
+
let* () =
643
+
match S.get_stdlib_dcs stdlib_dcs with
644
+
| [ dcs ] -> add_dynamic_cmis dcs
645
+
| _ -> Lwt.return ()
646
+
in
647
+
Clflags.no_check_prims := true;
648
+
649
+
requires := init_libs.findlib_requires;
650
+
functions := Some [];
651
+
execution_allowed := init_libs.execute;
652
+
653
+
(* Set up the toplevel environment *)
654
+
Logs.info (fun m -> m "init() finished");
655
+
656
+
Lwt.return (Ok ()))
657
+
(fun e ->
658
+
Lwt.return
659
+
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
660
+
661
+
let setup env_id =
662
+
Lwt.catch
663
+
(fun () ->
664
+
let env = resolve_env env_id in
665
+
Logs.info (fun m -> m "setup() for env %s..." (Environment.id env));
666
+
667
+
if Environment.is_setup env then (
668
+
Logs.info (fun m -> m "setup() already done for env %s" (Environment.id env));
669
+
Lwt.return
670
+
(Ok
671
+
Toplevel_api_gen.
672
+
{
673
+
stdout = None;
674
+
stderr = Some "Environment already set up";
675
+
sharp_ppf = None;
676
+
caml_ppf = None;
677
+
highlight = None;
678
+
mime_vals = [];
679
+
}))
680
+
else
681
+
let o =
682
+
Environment.with_env env (fun () ->
683
+
try
684
+
match !functions with
685
+
| Some l -> setup l ()
686
+
| None -> failwith "Error: toplevel has not been initialised"
687
+
with
688
+
| Persistent_env.Error e ->
689
+
Persistent_env.report_error Format.err_formatter e;
690
+
let err = Format.asprintf "%a" Persistent_env.report_error e in
691
+
failwith ("Error: " ^ err)
692
+
| Env.Error _ as exn ->
693
+
Location.report_exception Format.err_formatter exn;
694
+
let err = Format.asprintf "%a" Location.report_exception exn in
695
+
failwith ("Error: " ^ err))
696
+
in
697
+
698
+
let* dcs =
699
+
match !findlib_v with
700
+
| Some v ->
701
+
let* v = v in
702
+
(* Store the resolved findlib value for use by #require directive *)
703
+
findlib_resolved := Some v;
704
+
(* Register our custom #require directive that uses findlibish *)
705
+
register_require_directive ();
706
+
Lwt.return (S.require (not !execution_allowed) v !requires)
707
+
| None -> Lwt.return []
708
+
in
709
+
710
+
let* () = Lwt_list.iter_p add_dynamic_cmis dcs in
711
+
712
+
Environment.mark_setup env;
713
+
Logs.info (fun m -> m "setup() finished for env %s" (Environment.id env));
714
+
715
+
Lwt.return
716
+
(Ok
717
+
Toplevel_api_gen.
718
+
{
719
+
stdout = string_opt o.stdout;
720
+
stderr = string_opt o.stderr;
721
+
sharp_ppf = None;
722
+
caml_ppf = None;
723
+
highlight = None;
724
+
mime_vals = [];
725
+
}))
726
+
(fun e ->
727
+
Lwt.return
728
+
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
729
+
730
+
let handle_toplevel env stripped =
731
+
if String.length stripped < 2 || stripped.[0] <> '#' || stripped.[1] <> ' '
732
+
then (
733
+
Printf.eprintf
734
+
"Warning, ignoring toplevel block without a leading '# '.\n";
735
+
IdlM.ErrM.return
736
+
{ Toplevel_api_gen.script = stripped; mime_vals = []; parts = [] })
737
+
else
738
+
let s = String.sub stripped 2 (String.length stripped - 2) in
739
+
let list = Ocamltop.parse_toplevel s in
740
+
let buf = Buffer.create 1024 in
741
+
let mime_vals =
742
+
List.fold_left
743
+
(fun acc (phr, _junk, _output) ->
744
+
let new_output = execute_in_env env phr in
745
+
Printf.bprintf buf "# %s\n" phr;
746
+
let r =
747
+
Option.to_list new_output.stdout
748
+
@ Option.to_list new_output.stderr
749
+
@ Option.to_list new_output.caml_ppf
750
+
in
751
+
let r =
752
+
List.concat_map (fun l -> Astring.String.cuts ~sep:"\n" l) r
753
+
in
754
+
List.iter (fun x -> Printf.bprintf buf " %s\n" x) r;
755
+
let mime_vals = new_output.mime_vals in
756
+
acc @ mime_vals)
757
+
[] list
758
+
in
759
+
let content_txt = Buffer.contents buf in
760
+
let content_txt =
761
+
String.sub content_txt 0 (String.length content_txt - 1)
762
+
in
763
+
let result =
764
+
{ Toplevel_api_gen.script = content_txt; mime_vals; parts = [] }
765
+
in
766
+
IdlM.ErrM.return result
767
+
768
+
let exec_toplevel env_id (phrase : string) =
769
+
let env = resolve_env env_id in
770
+
try handle_toplevel env phrase
771
+
with e ->
772
+
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
773
+
IdlM.ErrM.return_err
774
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))
775
+
776
+
let execute env_id (phrase : string) =
777
+
Logs.info (fun m -> m "execute() for env_id=%s" env_id);
778
+
let env = resolve_env env_id in
779
+
let result = execute_in_env env phrase in
780
+
Logs.info (fun m -> m "execute() done for env_id=%s" env_id);
781
+
IdlM.ErrM.return result
782
+
783
+
let execute_incremental env_id (phrase : string) ~on_phrase_output =
784
+
Logs.info (fun m -> m "execute_incremental() for env_id=%s" env_id);
785
+
let env = resolve_env env_id in
786
+
let result = execute_in_env_incremental env phrase ~on_phrase_output in
787
+
Logs.info (fun m -> m "execute_incremental() done for env_id=%s" env_id);
788
+
IdlM.ErrM.return result
789
+
790
+
(** {3 Merlin Integration}
791
+
792
+
Code intelligence features powered by Merlin: completion, type info,
793
+
error diagnostics. *)
794
+
795
+
let config () =
796
+
let path =
797
+
match !path with Some p -> p | None -> failwith "Path not set"
798
+
in
799
+
let initial = Merlin_kernel.Mconfig.initial in
800
+
{ initial with merlin = { initial.merlin with stdlib = Some path } }
801
+
802
+
let make_pipeline source = Merlin_kernel.Mpipeline.make (config ()) source
803
+
804
+
let wdispatch source query =
805
+
let pipeline = make_pipeline source in
806
+
Merlin_kernel.Mpipeline.with_pipeline pipeline @@ fun () ->
807
+
Query_commands.dispatch pipeline query
808
+
809
+
(** Completion prefix extraction, adapted from ocaml-lsp-server. *)
810
+
module Completion = struct
811
+
open Merlin_utils
812
+
open Std
813
+
open Merlin_kernel
814
+
815
+
(* Prefixing code from ocaml-lsp-server *)
816
+
let rfindi =
817
+
let rec loop s ~f i =
818
+
if i < 0 then None
819
+
else if f (String.unsafe_get s i) then Some i
820
+
else loop s ~f (i - 1)
821
+
in
822
+
fun ?from s ~f ->
823
+
let from =
824
+
let len = String.length s in
825
+
match from with
826
+
| None -> len - 1
827
+
| Some i ->
828
+
if i > len - 1 then
829
+
raise @@ Invalid_argument "rfindi: invalid from"
830
+
else i
831
+
in
832
+
loop s ~f from
833
+
834
+
let lsplit2 s ~on =
835
+
match String.index_opt s on with
836
+
| None -> None
837
+
| Some i ->
838
+
let open StdLabels.String in
839
+
Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1))
840
+
841
+
(** @see <https://ocaml.org/manual/lex.html> reference *)
842
+
let prefix_of_position ?(short_path = false) source position =
843
+
match Msource.text source with
844
+
| "" -> ""
845
+
| text ->
846
+
let from =
847
+
let (`Offset index) = Msource.get_offset source position in
848
+
min (String.length text - 1) (index - 1)
849
+
in
850
+
let pos =
851
+
let should_terminate = ref false in
852
+
let has_seen_dot = ref false in
853
+
let is_prefix_char c =
854
+
if !should_terminate then false
855
+
else
856
+
match c with
857
+
| 'a' .. 'z'
858
+
| 'A' .. 'Z'
859
+
| '0' .. '9'
860
+
| '\'' | '_'
861
+
(* Infix function characters *)
862
+
| '$' | '&' | '*' | '+' | '-' | '/' | '=' | '>' | '@' | '^'
863
+
| '!' | '?' | '%' | '<' | ':' | '~' | '#' ->
864
+
true
865
+
| '`' ->
866
+
if !has_seen_dot then false
867
+
else (
868
+
should_terminate := true;
869
+
true)
870
+
| '.' ->
871
+
has_seen_dot := true;
872
+
not short_path
873
+
| _ -> false
874
+
in
875
+
rfindi text ~from ~f:(fun c -> not (is_prefix_char c))
876
+
in
877
+
let pos = match pos with None -> 0 | Some pos -> pos + 1 in
878
+
let len = from - pos + 1 in
879
+
let reconstructed_prefix = StdLabels.String.sub text ~pos ~len in
880
+
(* if we reconstructed [~f:ignore] or [?f:ignore], we should take only
881
+
[ignore], so: *)
882
+
if
883
+
String.is_prefixed ~by:"~" reconstructed_prefix
884
+
|| String.is_prefixed ~by:"?" reconstructed_prefix
885
+
then
886
+
match lsplit2 reconstructed_prefix ~on:':' with
887
+
| Some (_, s) -> s
888
+
| None -> reconstructed_prefix
889
+
else reconstructed_prefix
890
+
891
+
let at_pos source position =
892
+
let prefix = prefix_of_position source position in
893
+
let (`Offset to_) = Msource.get_offset source position in
894
+
let from =
895
+
to_
896
+
- String.length (prefix_of_position ~short_path:true source position)
897
+
in
898
+
if prefix = "" then None
899
+
else
900
+
let query =
901
+
Query_protocol.Complete_prefix (prefix, position, [], true, true)
902
+
in
903
+
Some (from, to_, wdispatch source query)
904
+
end
905
+
906
+
let complete_prefix env_id id deps is_toplevel source position =
907
+
let _env = resolve_env env_id in (* Reserved for future use *)
908
+
try
909
+
Logs.info (fun m -> m "completing for id: %s" (match id with Some x -> x | None -> "(none)"));
910
+
911
+
let line1, src = mangle_toplevel is_toplevel source deps in
912
+
Logs.info (fun m -> m "line1: '%s' (length: %d)" line1 (String.length line1));
913
+
Logs.info (fun m -> m "src: '%s' (length: %d)" src (String.length src));
914
+
let src = line1 ^ src in
915
+
let source = Merlin_kernel.Msource.make src in
916
+
let map_kind :
917
+
[ `Value
918
+
| `Constructor
919
+
| `Variant
920
+
| `Label
921
+
| `Module
922
+
| `Modtype
923
+
| `Type
924
+
| `MethodCall
925
+
| `Keyword ] ->
926
+
Toplevel_api_gen.kind_ty = function
927
+
| `Value -> Value
928
+
| `Constructor -> Constructor
929
+
| `Variant -> Variant
930
+
| `Label -> Label
931
+
| `Module -> Module
932
+
| `Modtype -> Modtype
933
+
| `Type -> Type
934
+
| `MethodCall -> MethodCall
935
+
| `Keyword -> Keyword
936
+
in
937
+
let position =
938
+
match position with
939
+
| Toplevel_api_gen.Start -> `Offset (String.length line1)
940
+
| Offset x -> `Offset (x + String.length line1)
941
+
| Logical (x, y) -> `Logical (x + 1, y)
942
+
| End -> `End
943
+
in
944
+
945
+
(match position with
946
+
| `Offset x ->
947
+
let first_char = String.sub src (x-1) 1 in
948
+
Logs.info (fun m -> m "complete after offset: %s" first_char)
949
+
| _ -> ());
950
+
951
+
match Completion.at_pos source position with
952
+
| Some (from, to_, compl) ->
953
+
let entries =
954
+
List.map
955
+
(fun (entry : Query_protocol.Compl.entry) ->
956
+
{
957
+
Toplevel_api_gen.name = entry.name;
958
+
kind = map_kind entry.kind;
959
+
desc = entry.desc;
960
+
info = entry.info;
961
+
deprecated = entry.deprecated;
962
+
})
963
+
compl.entries
964
+
in
965
+
let l1l = String.length line1 in
966
+
IdlM.ErrM.return { Toplevel_api_gen.from = from - l1l; to_ = to_ - l1l; entries }
967
+
| None ->
968
+
IdlM.ErrM.return { Toplevel_api_gen.from = 0; to_ = 0; entries = [] }
969
+
with e ->
970
+
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
971
+
IdlM.ErrM.return_err
972
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))
973
+
974
+
let add_cmi execution_env id deps source =
975
+
Logs.info (fun m -> m "add_cmi");
976
+
let dep_modules = List.map modname_of_id deps in
977
+
let loc = Location.none in
978
+
let path =
979
+
match !path with Some p -> p | None -> failwith "Path not set"
980
+
in
981
+
let filename = modname_of_id id |> String.uncapitalize_ascii in
982
+
let prefix = Printf.sprintf "%s/%s" path filename in
983
+
let filename = Printf.sprintf "%s.ml" prefix in
984
+
Logs.info (fun m -> m "prefix: %s" prefix);
985
+
let oc = open_out filename in
986
+
Printf.fprintf oc "%s" source;
987
+
close_out oc;
988
+
(try Sys.remove (prefix ^ ".cmi") with Sys_error _ -> ());
989
+
let unit_info = Unit_info.make ~source_file:filename Impl prefix in
990
+
try
991
+
let store = Local_store.fresh () in
992
+
Local_store.with_store store (fun () ->
993
+
Local_store.reset ();
994
+
let env =
995
+
Typemod.initial_env ~loc ~initially_opened_module:(Some "Stdlib")
996
+
~open_implicit_modules:dep_modules
997
+
in
998
+
let lexbuf = Lexing.from_string source in
999
+
let ast = Parse.implementation lexbuf in
1000
+
Logs.info (fun m -> m "About to type_implementation");
1001
+
let _ = Typemod.type_implementation unit_info env ast in
1002
+
let b = Sys.file_exists (prefix ^ ".cmi") in
1003
+
Environment.remove_failed_cell execution_env id;
1004
+
Logs.info (fun m -> m "file_exists: %s = %b" (prefix ^ ".cmi") b));
1005
+
Ocaml_typing.Cmi_cache.clear ()
1006
+
with
1007
+
| Env.Error _ as exn ->
1008
+
Logs.err (fun m -> m "Env.Error: %a" Location.report_exception exn);
1009
+
Environment.add_failed_cell execution_env id;
1010
+
()
1011
+
| exn ->
1012
+
let s = Printexc.to_string exn in
1013
+
Logs.err (fun m -> m "Error in add_cmi: %s" s);
1014
+
Logs.err (fun m -> m "Backtrace: %s" (Printexc.get_backtrace ()));
1015
+
let ppf = Format.err_formatter in
1016
+
let _ = Location.report_exception ppf exn in
1017
+
Environment.add_failed_cell execution_env id;
1018
+
()
1019
+
1020
+
let map_pos line1 pos =
1021
+
(* Only subtract line number when there's actually a prepended line *)
1022
+
let line_offset = if line1 = "" then 0 else 1 in
1023
+
Lexing.
1024
+
{
1025
+
pos with
1026
+
pos_bol = pos.pos_bol - String.length line1;
1027
+
pos_lnum = pos.pos_lnum - line_offset;
1028
+
pos_cnum = pos.pos_cnum - String.length line1;
1029
+
}
1030
+
1031
+
let map_loc line1 (loc : Ocaml_parsing.Location.t) =
1032
+
{
1033
+
loc with
1034
+
Ocaml_utils.Warnings.loc_start = map_pos line1 loc.loc_start;
1035
+
Ocaml_utils.Warnings.loc_end = map_pos line1 loc.loc_end;
1036
+
}
1037
+
1038
+
let query_errors env_id id deps is_toplevel orig_source =
1039
+
let execution_env = resolve_env env_id in
1040
+
try
1041
+
let deps =
1042
+
List.filter (fun dep -> not (Environment.is_cell_failed execution_env dep)) deps
1043
+
in
1044
+
let line1, src = mangle_toplevel is_toplevel orig_source deps in
1045
+
let full_source = line1 ^ src in
1046
+
let source = Merlin_kernel.Msource.make full_source in
1047
+
let query =
1048
+
Query_protocol.Errors { lexing = true; parsing = true; typing = true }
1049
+
in
1050
+
let errors =
1051
+
wdispatch source query
1052
+
|> StdLabels.List.filter_map
1053
+
~f:(fun
1054
+
(Ocaml_parsing.Location.{ kind; main = _; sub; source; _ } as
1055
+
error)
1056
+
->
1057
+
let of_sub sub =
1058
+
Ocaml_parsing.Location.print_sub_msg Format.str_formatter sub;
1059
+
String.trim (Format.flush_str_formatter ())
1060
+
in
1061
+
let loc =
1062
+
map_loc line1 (Ocaml_parsing.Location.loc_of_report error)
1063
+
in
1064
+
let main =
1065
+
Format.asprintf "@[%a@]" Ocaml_parsing.Location.print_main
1066
+
error
1067
+
|> String.trim
1068
+
in
1069
+
if loc.loc_start.pos_lnum = 0 then None
1070
+
else
1071
+
Some
1072
+
{
1073
+
Toplevel_api_gen.kind;
1074
+
loc;
1075
+
main;
1076
+
sub = StdLabels.List.map ~f:of_sub sub;
1077
+
source;
1078
+
})
1079
+
in
1080
+
(* Only track cell CMIs when id is provided (notebook mode) *)
1081
+
(match id with
1082
+
| Some cell_id ->
1083
+
if List.length errors = 0 then add_cmi execution_env cell_id deps src
1084
+
else Environment.add_failed_cell execution_env cell_id
1085
+
| None -> ());
1086
+
1087
+
(* Logs.info (fun m -> m "Got to end"); *)
1088
+
IdlM.ErrM.return errors
1089
+
with e ->
1090
+
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1091
+
IdlM.ErrM.return_err
1092
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))
1093
+
1094
+
let type_enclosing env_id _id deps is_toplevel orig_source position =
1095
+
let execution_env = resolve_env env_id in
1096
+
try
1097
+
let deps =
1098
+
List.filter (fun dep -> not (Environment.is_cell_failed execution_env dep)) deps
1099
+
in
1100
+
let line1, src = mangle_toplevel is_toplevel orig_source deps in
1101
+
let src = line1 ^ src in
1102
+
let position =
1103
+
match position with
1104
+
| Toplevel_api_gen.Start -> `Start
1105
+
| Offset x -> `Offset (x + String.length line1)
1106
+
| Logical (x, y) -> `Logical (x + 1, y)
1107
+
| End -> `End
1108
+
in
1109
+
let source = Merlin_kernel.Msource.make src in
1110
+
let query = Query_protocol.Type_enclosing (None, position, None) in
1111
+
let enclosing = wdispatch source query in
1112
+
let map_index_or_string = function
1113
+
| `Index i -> Toplevel_api_gen.Index i
1114
+
| `String s -> String s
1115
+
in
1116
+
let map_tail_position = function
1117
+
| `No -> Toplevel_api_gen.No
1118
+
| `Tail_position -> Tail_position
1119
+
| `Tail_call -> Tail_call
1120
+
in
1121
+
let enclosing =
1122
+
List.map
1123
+
(fun (x, y, z) ->
1124
+
(map_loc line1 x, map_index_or_string y, map_tail_position z))
1125
+
enclosing
1126
+
in
1127
+
IdlM.ErrM.return enclosing
1128
+
with e ->
1129
+
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1130
+
IdlM.ErrM.return_err
1131
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))
1132
+
1133
+
(** {3 Environment Management RPCs} *)
1134
+
1135
+
let create_env env_id =
1136
+
Lwt.catch
1137
+
(fun () ->
1138
+
Logs.info (fun m -> m "create_env(%s)" env_id);
1139
+
let _env = Environment.create env_id in
1140
+
Lwt.return (Ok ()))
1141
+
(fun e ->
1142
+
Lwt.return
1143
+
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1144
+
1145
+
let destroy_env env_id =
1146
+
Lwt.catch
1147
+
(fun () ->
1148
+
Logs.info (fun m -> m "destroy_env(%s)" env_id);
1149
+
Environment.destroy env_id;
1150
+
Lwt.return (Ok ()))
1151
+
(fun e ->
1152
+
Lwt.return
1153
+
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1154
+
1155
+
let list_envs () =
1156
+
Lwt.catch
1157
+
(fun () ->
1158
+
let envs = Environment.list () in
1159
+
Logs.info (fun m -> m "list_envs() -> [%s]" (String.concat ", " envs));
1160
+
Lwt.return (Ok envs))
1161
+
(fun e ->
1162
+
Lwt.return
1163
+
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1164
+
end
+64
js_top_worker/lib/jslib.ml
+64
js_top_worker/lib/jslib.ml
···
1
+
let log fmt =
2
+
Format.kasprintf
3
+
(fun s -> Js_of_ocaml.(Console.console##log (Js.string s)))
4
+
fmt
5
+
6
+
let map_url url =
7
+
let open Js_of_ocaml in
8
+
let global_rel_url =
9
+
let x : Js.js_string Js.t option =
10
+
Js.Unsafe.js_expr "globalThis.__global_rel_url" |> Js.Optdef.to_option
11
+
in
12
+
Option.map Js.to_string x
13
+
in
14
+
match global_rel_url with
15
+
| Some rel ->
16
+
(* If url starts with /, it's relative to server root - just use the scheme/host *)
17
+
if String.length url > 0 && url.[0] = '/' then
18
+
(* Extract scheme://host from rel and append url *)
19
+
match String.index_opt rel ':' with
20
+
| Some colon_idx ->
21
+
let after_scheme = colon_idx + 3 in (* skip "://" *)
22
+
(match String.index_from_opt rel after_scheme '/' with
23
+
| Some slash_idx -> String.sub rel 0 slash_idx ^ url
24
+
| None -> rel ^ url)
25
+
| None -> url
26
+
else
27
+
Filename.concat rel url
28
+
| None -> url
29
+
30
+
let sync_get url =
31
+
let open Js_of_ocaml in
32
+
let url = map_url url in
33
+
Console.console##log (Js.string ("Fetching: " ^ url));
34
+
let x = XmlHttpRequest.create () in
35
+
x##.responseType := Js.string "arraybuffer";
36
+
x##_open (Js.string "GET") (Js.string url) Js._false;
37
+
x##send Js.null;
38
+
match x##.status with
39
+
| 200 ->
40
+
Js.Opt.case
41
+
(File.CoerceTo.arrayBuffer x##.response)
42
+
(fun () ->
43
+
Console.console##log (Js.string "Failed to receive file");
44
+
None)
45
+
(fun b -> Some (Typed_array.String.of_arrayBuffer b))
46
+
| _ -> None
47
+
48
+
let async_get url =
49
+
let ( let* ) = Lwt.bind in
50
+
let open Js_of_ocaml in
51
+
let url = map_url url in
52
+
Console.console##log (Js.string ("Fetching: " ^ url));
53
+
let* frame =
54
+
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw ~response_type:ArrayBuffer url
55
+
in
56
+
match frame.code with
57
+
| 200 ->
58
+
Lwt.return
59
+
(Js.Opt.case frame.content
60
+
(fun () -> Error (`Msg "Failed to receive file"))
61
+
(fun b -> Ok (Typed_array.String.of_arrayBuffer b)))
62
+
| _ ->
63
+
Lwt.return
64
+
(Error (`Msg (Printf.sprintf "Failed to fetch %s: %d" url frame.code)))
+38
js_top_worker/lib/ocamltop.ml
+38
js_top_worker/lib/ocamltop.ml
···
1
+
let refill_lexbuf s p buffer len =
2
+
if !p = String.length s then 0
3
+
else
4
+
let len' =
5
+
try String.index_from s !p '\n' - !p + 1 with _ -> String.length s - !p
6
+
in
7
+
let len'' = min len len' in
8
+
String.blit s !p buffer 0 len'';
9
+
p := !p + len'';
10
+
len''
11
+
12
+
let fallback_parse_toplevel s =
13
+
Printf.printf "fallback parser\n%!";
14
+
let lexbuf = Lexing.from_string s in
15
+
let rec loop pos =
16
+
let _phr = Toplexer.fallback_expression lexbuf in
17
+
Printf.printf "Got phrase\n%!";
18
+
let new_pos = Lexing.lexeme_end lexbuf in
19
+
let phr = String.sub s pos (new_pos - pos) in
20
+
let junk, (cont, output) = Toplexer.entry lexbuf in
21
+
let new_pos = Lexing.lexeme_end lexbuf in
22
+
if cont then (phr, junk, output) :: loop new_pos
23
+
else [ (phr, junk, output) ]
24
+
in
25
+
loop 0
26
+
27
+
let parse_toplevel s =
28
+
let lexbuf = Lexing.from_string s in
29
+
let rec loop pos =
30
+
let _phr = !Toploop.parse_toplevel_phrase lexbuf in
31
+
let new_pos = Lexing.lexeme_end lexbuf in
32
+
let phr = String.sub s pos (new_pos - pos) in
33
+
let junk, (cont, output) = Toplexer.entry lexbuf in
34
+
let new_pos = Lexing.lexeme_end lexbuf in
35
+
if cont then (phr, junk, output) :: loop new_pos
36
+
else [ (phr, junk, output) ]
37
+
in
38
+
loop 0
+25
js_top_worker/lib/stubs.js
+25
js_top_worker/lib/stubs.js
···
1
+
//Provides: caml_unix_times
2
+
function caml_unix_times() {
3
+
return 4.2
4
+
}
5
+
6
+
//Provides: ml_merlin_fs_exact_case_basename
7
+
function ml_merlin_fs_exact_case_basename(str) {
8
+
return 0
9
+
}
10
+
11
+
//Provides: ml_merlin_fs_exact_case
12
+
function ml_merlin_fs_exact_case(str) {
13
+
return str
14
+
}
15
+
16
+
//Provides: stub_sha512_init
17
+
function stub_sha512_init() {
18
+
return 0
19
+
}
20
+
21
+
//Provides: caml_thread_initialize
22
+
function caml_thread_initialize() {
23
+
return 0
24
+
}
25
+
+41
js_top_worker/lib/toplexer.mll
+41
js_top_worker/lib/toplexer.mll
···
1
+
{ }
2
+
3
+
(* TODO: implement strings, comments, etc, to ignore ';;' in them *)
4
+
rule fallback_expression = shortest
5
+
| (_ as expr)* ";;" {
6
+
expr
7
+
}
8
+
| (_ as expr)* eof {
9
+
expr
10
+
}
11
+
12
+
and entry = parse
13
+
| ((_ # '\n')* as junk) "\n" {
14
+
(junk, line_prefix [] lexbuf)
15
+
}
16
+
| ((_ # '\n')* as junk) eof {
17
+
(junk, (false, []))
18
+
}
19
+
20
+
and line_prefix acc = parse
21
+
| "# " {
22
+
true, List.rev acc
23
+
}
24
+
| '\n' {
25
+
line_prefix (""::acc) lexbuf
26
+
}
27
+
| _ as c {
28
+
output_line_legacy c acc lexbuf
29
+
}
30
+
| eof {
31
+
false, List.rev ("" :: acc)
32
+
}
33
+
34
+
and output_line_legacy c acc = parse
35
+
| ((_ # '\n')* as line) "\n" {
36
+
line_prefix ((String.make 1 c ^ line) :: acc) lexbuf
37
+
}
38
+
| (_ # '\n')* as line eof {
39
+
false, List.rev ((String.make 1 c ^ line) :: acc)
40
+
}
41
+
+297
js_top_worker/lib/worker.ml
+297
js_top_worker/lib/worker.ml
···
1
+
open Js_top_worker_rpc
2
+
open Js_top_worker
3
+
4
+
(* OCamlorg toplevel in a web worker
5
+
6
+
This communicates with the toplevel code via a simple message-based
7
+
protocol defined in {!Js_top_worker_message.Message}. This allows
8
+
the OCaml execution to not block the "main thread" keeping the page
9
+
responsive. *)
10
+
11
+
module Msg = Js_top_worker_message.Message
12
+
13
+
let loc = function
14
+
| Syntaxerr.Error x -> Some (Syntaxerr.location_of_error x)
15
+
| Lexer.Error (_, loc)
16
+
| Typecore.Error (loc, _, _)
17
+
| Typetexp.Error (loc, _, _)
18
+
| Typeclass.Error (loc, _, _)
19
+
| Typemod.Error (loc, _, _)
20
+
| Typedecl.Error (loc, _)
21
+
| Translcore.Error (loc, _)
22
+
| Translclass.Error (loc, _)
23
+
| Translmod.Error (loc, _) ->
24
+
Some loc
25
+
| _ -> None
26
+
27
+
module S : Impl.S = struct
28
+
type findlib_t = Findlibish.t
29
+
30
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
31
+
fun f () ->
32
+
let stdout_buff = Buffer.create 1024 in
33
+
let stderr_buff = Buffer.create 1024 in
34
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout
35
+
(Buffer.add_string stdout_buff);
36
+
Js_of_ocaml.Sys_js.set_channel_flusher stderr
37
+
(Buffer.add_string stderr_buff);
38
+
let x = f () in
39
+
let captured =
40
+
{
41
+
Impl.stdout = Buffer.contents stdout_buff;
42
+
stderr = Buffer.contents stderr_buff;
43
+
}
44
+
in
45
+
(captured, x)
46
+
47
+
let sync_get = Jslib.sync_get
48
+
let async_get = Jslib.async_get
49
+
50
+
(* Idempotent create_file that ignores "file already exists" errors.
51
+
This is needed because multiple .cma.js files compiled with --toplevel
52
+
may embed the same CMI files, and when loaded via import_scripts they
53
+
all try to register those CMIs. *)
54
+
let create_file ~name ~content =
55
+
try Js_of_ocaml.Sys_js.create_file ~name ~content
56
+
with Sys_error _ -> ()
57
+
58
+
let get_stdlib_dcs uri =
59
+
Findlibish.fetch_dynamic_cmis sync_get uri |> Result.to_list
60
+
61
+
let import_scripts urls =
62
+
(* Map relative URLs to absolute using the global base URL *)
63
+
let absolute_urls = List.map Jslib.map_url urls in
64
+
Js_of_ocaml.Worker.import_scripts absolute_urls
65
+
let findlib_init = Findlibish.init async_get
66
+
67
+
let require b v = function
68
+
| [] -> []
69
+
| packages -> Findlibish.require ~import_scripts sync_get b v packages
70
+
71
+
let init_function func_name =
72
+
let open Js_of_ocaml in
73
+
let func = Js.Unsafe.js_expr func_name in
74
+
fun () -> Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |]
75
+
76
+
let path = "/static/cmis"
77
+
end
78
+
79
+
module M = Impl.Make (S)
80
+
81
+
(** Send a message back to the client *)
82
+
let send_message msg =
83
+
let json = Msg.string_of_worker_msg msg in
84
+
Jslib.log "Worker sending: %s" json;
85
+
Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string json)
86
+
87
+
(** Convert exec_result to Message.Output *)
88
+
let output_of_exec_result cell_id (r : Toplevel_api_gen.exec_result) =
89
+
let mime_vals = List.map (fun (mv : Toplevel_api_gen.mime_val) ->
90
+
{ Msg.mime_type = mv.mime_type; data = mv.data }
91
+
) r.mime_vals in
92
+
Msg.Output {
93
+
cell_id;
94
+
stdout = Option.value ~default:"" r.stdout;
95
+
stderr = Option.value ~default:"" r.stderr;
96
+
caml_ppf = Option.value ~default:"" r.caml_ppf;
97
+
mime_vals;
98
+
}
99
+
100
+
(** Convert phrase_output to Message.OutputAt *)
101
+
let output_at_of_phrase cell_id (p : Impl.Make(S).phrase_output) =
102
+
let mime_vals = List.map (fun (mv : Toplevel_api_gen.mime_val) ->
103
+
{ Msg.mime_type = mv.mime_type; data = mv.data }
104
+
) p.mime_vals in
105
+
Msg.OutputAt {
106
+
cell_id;
107
+
loc = p.loc;
108
+
caml_ppf = Option.value ~default:"" p.caml_ppf;
109
+
mime_vals;
110
+
}
111
+
112
+
(** Convert completions to Message.Completions *)
113
+
let completions_of_result cell_id (c : Toplevel_api_gen.completions) =
114
+
let entries = List.map (fun (e : Toplevel_api_gen.query_protocol_compl_entry) ->
115
+
let kind = match e.kind with
116
+
| Constructor -> "Constructor"
117
+
| Keyword -> "Keyword"
118
+
| Label -> "Label"
119
+
| MethodCall -> "MethodCall"
120
+
| Modtype -> "Modtype"
121
+
| Module -> "Module"
122
+
| Type -> "Type"
123
+
| Value -> "Value"
124
+
| Variant -> "Variant"
125
+
in
126
+
{ Msg.name = e.name; kind; desc = e.desc; info = e.info; deprecated = e.deprecated }
127
+
) c.entries in
128
+
Msg.Completions {
129
+
cell_id;
130
+
completions = { from = c.from; to_ = c.to_; entries };
131
+
}
132
+
133
+
(** Convert location to Message.location *)
134
+
let location_of_loc (loc : Toplevel_api_gen.location) : Msg.location =
135
+
{
136
+
loc_start = {
137
+
pos_cnum = loc.loc_start.pos_cnum;
138
+
pos_lnum = loc.loc_start.pos_lnum;
139
+
pos_bol = loc.loc_start.pos_bol;
140
+
};
141
+
loc_end = {
142
+
pos_cnum = loc.loc_end.pos_cnum;
143
+
pos_lnum = loc.loc_end.pos_lnum;
144
+
pos_bol = loc.loc_end.pos_bol;
145
+
};
146
+
}
147
+
148
+
(** Convert error_kind to string *)
149
+
let string_of_error_kind = function
150
+
| Toplevel_api_gen.Report_error -> "error"
151
+
| Report_warning s -> "warning:" ^ s
152
+
| Report_warning_as_error s -> "warning_as_error:" ^ s
153
+
| Report_alert s -> "alert:" ^ s
154
+
| Report_alert_as_error s -> "alert_as_error:" ^ s
155
+
156
+
(** Convert error_source to string *)
157
+
let string_of_error_source = function
158
+
| Toplevel_api_gen.Lexer -> "lexer"
159
+
| Parser -> "parser"
160
+
| Typer -> "typer"
161
+
| Warning -> "warning"
162
+
| Unknown -> "unknown"
163
+
| Env -> "env"
164
+
| Config -> "config"
165
+
166
+
(** Convert errors to Message.ErrorList *)
167
+
let errors_of_result cell_id (errors : Toplevel_api_gen.error list) =
168
+
let errors = List.map (fun (e : Toplevel_api_gen.error) ->
169
+
{
170
+
Msg.kind = string_of_error_kind e.kind;
171
+
loc = location_of_loc e.loc;
172
+
main = e.main;
173
+
sub = e.sub;
174
+
source = string_of_error_source e.source;
175
+
}
176
+
) errors in
177
+
Msg.ErrorList { cell_id; errors }
178
+
179
+
(** Convert typed_enclosings to Message.Types *)
180
+
let types_of_result cell_id (enclosings : Toplevel_api_gen.typed_enclosings list) =
181
+
let types = List.map (fun ((loc, idx_or_str, tail) : Toplevel_api_gen.typed_enclosings) ->
182
+
let type_str = match idx_or_str with
183
+
| Toplevel_api_gen.String s -> s
184
+
| Index _ -> ""
185
+
in
186
+
let tail = match tail with
187
+
| Toplevel_api_gen.No -> "no"
188
+
| Tail_position -> "tail_position"
189
+
| Tail_call -> "tail_call"
190
+
in
191
+
{
192
+
Msg.loc = location_of_loc loc;
193
+
type_str;
194
+
tail;
195
+
}
196
+
) enclosings in
197
+
Msg.Types { cell_id; types }
198
+
199
+
(** Convert position from int to Toplevel_api_gen.msource_position *)
200
+
let position_of_int pos =
201
+
Toplevel_api_gen.Offset pos
202
+
203
+
(** Handle a client message *)
204
+
let handle_message msg =
205
+
let open Lwt.Infix in
206
+
match msg with
207
+
| Msg.Init config ->
208
+
let init_config : Toplevel_api_gen.init_config = {
209
+
findlib_requires = config.findlib_requires;
210
+
stdlib_dcs = config.stdlib_dcs;
211
+
findlib_index = config.findlib_index;
212
+
execute = true;
213
+
} in
214
+
M.init init_config >>= fun result ->
215
+
(match result with
216
+
| Ok () ->
217
+
(* After init, automatically setup the default environment *)
218
+
M.setup "" >|= fun setup_result ->
219
+
(match setup_result with
220
+
| Ok _ -> send_message Msg.Ready
221
+
| Error (Toplevel_api_gen.InternalError msg) ->
222
+
send_message (Msg.InitError { message = msg }))
223
+
| Error (Toplevel_api_gen.InternalError msg) ->
224
+
send_message (Msg.InitError { message = msg });
225
+
Lwt.return_unit)
226
+
227
+
| Msg.Eval { cell_id; env_id; code } ->
228
+
Jslib.log "Eval cell_id=%d env_id=%s" cell_id env_id;
229
+
let on_phrase_output p = send_message (output_at_of_phrase cell_id p) in
230
+
Rpc_lwt.T.get (M.execute_incremental env_id code ~on_phrase_output) >|= fun result ->
231
+
(match result with
232
+
| Ok exec_result ->
233
+
send_message (output_of_exec_result cell_id exec_result)
234
+
| Error (Toplevel_api_gen.InternalError msg) ->
235
+
send_message (Msg.EvalError { cell_id; message = msg }))
236
+
237
+
| Msg.Complete { cell_id; env_id; source; position } ->
238
+
let pos = position_of_int position in
239
+
Rpc_lwt.T.get (M.complete_prefix env_id None [] false source pos) >|= fun result ->
240
+
(match result with
241
+
| Ok completions ->
242
+
send_message (completions_of_result cell_id completions)
243
+
| Error (Toplevel_api_gen.InternalError msg) ->
244
+
send_message (Msg.EvalError { cell_id; message = msg }))
245
+
246
+
| Msg.TypeAt { cell_id; env_id; source; position } ->
247
+
let pos = position_of_int position in
248
+
Rpc_lwt.T.get (M.type_enclosing env_id None [] false source pos) >|= fun result ->
249
+
(match result with
250
+
| Ok types ->
251
+
send_message (types_of_result cell_id types)
252
+
| Error (Toplevel_api_gen.InternalError msg) ->
253
+
send_message (Msg.EvalError { cell_id; message = msg }))
254
+
255
+
| Msg.Errors { cell_id; env_id; source } ->
256
+
Rpc_lwt.T.get (M.query_errors env_id None [] false source) >|= fun result ->
257
+
(match result with
258
+
| Ok errors ->
259
+
send_message (errors_of_result cell_id errors)
260
+
| Error (Toplevel_api_gen.InternalError msg) ->
261
+
send_message (Msg.EvalError { cell_id; message = msg }))
262
+
263
+
| Msg.CreateEnv { env_id } ->
264
+
M.create_env env_id >|= fun result ->
265
+
(match result with
266
+
| Ok () -> send_message (Msg.EnvCreated { env_id })
267
+
| Error (Toplevel_api_gen.InternalError msg) ->
268
+
send_message (Msg.InitError { message = msg }))
269
+
270
+
| Msg.DestroyEnv { env_id } ->
271
+
M.destroy_env env_id >|= fun result ->
272
+
(match result with
273
+
| Ok () -> send_message (Msg.EnvDestroyed { env_id })
274
+
| Error (Toplevel_api_gen.InternalError msg) ->
275
+
send_message (Msg.InitError { message = msg }))
276
+
277
+
let run () =
278
+
let open Js_of_ocaml in
279
+
try
280
+
Console.console##log (Js.string "Starting worker (message protocol)...");
281
+
282
+
Logs.set_reporter (Logs_browser.console_reporter ());
283
+
Logs.set_level (Some Logs.Debug);
284
+
285
+
Js_of_ocaml.Worker.set_onmessage (fun x ->
286
+
let s = Js_of_ocaml.Js.to_string x in
287
+
Jslib.log "Worker received: %s" s;
288
+
try
289
+
let msg = Msg.client_msg_of_string s in
290
+
Lwt.async (fun () -> handle_message msg)
291
+
with e ->
292
+
Jslib.log "Error parsing message: %s" (Printexc.to_string e);
293
+
send_message (Msg.InitError { message = Printexc.to_string e }));
294
+
295
+
Console.console##log (Js.string "Worker ready")
296
+
with e ->
297
+
Console.console##log (Js.string ("Exception: " ^ Printexc.to_string e))
+1
js_top_worker/test/browser/.gitignore
+1
js_top_worker/test/browser/.gitignore
···
1
+
node_modules/
+111
js_top_worker/test/browser/client_test.ml
+111
js_top_worker/test/browser/client_test.ml
···
1
+
(** Browser test for js_top_worker_client library.
2
+
3
+
This test runs in a browser via Playwright and exercises:
4
+
- Worker spawning
5
+
- RPC communication via postMessage
6
+
- Timeout handling
7
+
- All W module functions *)
8
+
9
+
open Js_of_ocaml
10
+
open Js_top_worker_rpc
11
+
module W = Js_top_worker_client.W
12
+
13
+
(* Test result tracking *)
14
+
type test_result = { name : string; passed : bool; message : string }
15
+
16
+
let results : test_result list ref = ref []
17
+
18
+
let log s = Console.console##log (Js.string s)
19
+
20
+
let add_result name passed message =
21
+
results := { name; passed; message } :: !results;
22
+
let status = if passed then "PASS" else "FAIL" in
23
+
log (Printf.sprintf "[%s] %s: %s" status name message)
24
+
25
+
let report_results () =
26
+
let total = List.length !results in
27
+
let passed = List.filter (fun r -> r.passed) !results |> List.length in
28
+
let failed = total - passed in
29
+
log (Printf.sprintf "\n=== Test Results: %d passed, %d failed ===" passed failed);
30
+
List.iter (fun r ->
31
+
let status = if r.passed then "OK" else "FAILED" in
32
+
log (Printf.sprintf " %s: %s - %s" status r.name r.message)
33
+
) (List.rev !results);
34
+
(* Set a global variable for Playwright to check *)
35
+
Js.Unsafe.set Js.Unsafe.global (Js.string "testResults")
36
+
(object%js
37
+
val total = total
38
+
val passed = passed
39
+
val failed = failed
40
+
val done_ = Js._true
41
+
end)
42
+
43
+
let test_init_and_setup rpc =
44
+
let ( let* ) = Lwt_result.bind in
45
+
let* () =
46
+
W.init rpc
47
+
Toplevel_api_gen.
48
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
49
+
in
50
+
add_result "init" true "Initialized successfully";
51
+
let* _o = W.setup rpc "" in
52
+
add_result "setup" true "Setup completed";
53
+
Lwt.return (Ok ())
54
+
55
+
let test_exec rpc =
56
+
let ( let* ) = Lwt_result.bind in
57
+
let* o = W.exec rpc "" "let x = 1 + 2;;" in
58
+
let has_output =
59
+
match o.caml_ppf with Some s -> String.length s > 0 | None -> false
60
+
in
61
+
add_result "exec" has_output
62
+
(Printf.sprintf "caml_ppf=%s"
63
+
(Option.value ~default:"(none)" o.caml_ppf));
64
+
Lwt.return (Ok ())
65
+
66
+
let test_exec_with_output rpc =
67
+
let ( let* ) = Lwt_result.bind in
68
+
let* o = W.exec rpc "" "print_endline \"hello from test\";;" in
69
+
let has_stdout =
70
+
match o.stdout with
71
+
| Some s -> Astring.String.is_prefix ~affix:"hello" s
72
+
| None -> false
73
+
in
74
+
add_result "exec_stdout" has_stdout
75
+
(Printf.sprintf "stdout=%s" (Option.value ~default:"(none)" o.stdout));
76
+
Lwt.return (Ok ())
77
+
78
+
let test_query_errors rpc =
79
+
let ( let* ) = Lwt_result.bind in
80
+
(* Test that query_errors RPC call works - result depends on context *)
81
+
let* _errors = W.query_errors rpc "" (Some "test1") [] false "let x : int = \"foo\";;" in
82
+
(* Success = the RPC call completed without error *)
83
+
add_result "query_errors" true "query_errors RPC call succeeded";
84
+
Lwt.return (Ok ())
85
+
86
+
let run_tests worker_url =
87
+
let ( let* ) = Lwt.bind in
88
+
log (Printf.sprintf "Starting tests with worker: %s" worker_url);
89
+
let rpc =
90
+
Js_top_worker_client.start worker_url 30000 (fun () ->
91
+
add_result "timeout" false "Unexpected timeout")
92
+
in
93
+
let test_sequence =
94
+
let ( let* ) = Lwt_result.bind in
95
+
let* () = test_init_and_setup rpc in
96
+
let* () = test_exec rpc in
97
+
let* () = test_exec_with_output rpc in
98
+
let* () = test_query_errors rpc in
99
+
Lwt.return (Ok ())
100
+
in
101
+
let* result = test_sequence in
102
+
(match result with
103
+
| Ok () -> add_result "all_tests" true "All tests completed"
104
+
| Error (Toplevel_api_gen.InternalError msg) ->
105
+
add_result "all_tests" false (Printf.sprintf "Error: %s" msg));
106
+
report_results ();
107
+
Lwt.return ()
108
+
109
+
let () =
110
+
(* Use test_worker.bc.js by default *)
111
+
ignore (run_tests "test_worker.bc.js")
+41
js_top_worker/test/browser/dune
+41
js_top_worker/test/browser/dune
···
1
+
; Browser tests using Playwright
2
+
; Run with: dune build @browser
3
+
4
+
(executable
5
+
(name client_test)
6
+
(modes js)
7
+
(modules client_test)
8
+
(preprocess (pps js_of_ocaml-ppx))
9
+
(libraries js_top_worker-client js_top_worker-rpc astring lwt js_of_ocaml))
10
+
11
+
(executable
12
+
(name test_worker)
13
+
(modes js)
14
+
(modules test_worker)
15
+
(link_flags (-linkall))
16
+
(preprocess (pps js_of_ocaml-ppx))
17
+
(js_of_ocaml
18
+
(javascript_files ../../lib/stubs.js)
19
+
(flags --effects=disabled --toplevel +toplevel.js +dynlink.js))
20
+
(libraries js_top_worker js_top_worker-rpc js_of_ocaml js_of_ocaml-toplevel lwt))
21
+
22
+
; Browser test alias - runs Playwright
23
+
; Requires: cd test/browser && npm install (once)
24
+
(alias
25
+
(name browser)
26
+
(deps
27
+
client_test.bc.js
28
+
test_worker.bc.js
29
+
(source_tree .)))
30
+
31
+
(rule
32
+
(alias runbrowser)
33
+
(deps
34
+
client_test.bc.js
35
+
test_worker.bc.js
36
+
(source_tree .))
37
+
(action
38
+
(chdir %{project_root}/test/browser
39
+
(progn
40
+
(echo "Running browser tests with Playwright...\n")
41
+
(run node run_tests.js)))))
+62
js_top_worker/test/browser/package-lock.json
+62
js_top_worker/test/browser/package-lock.json
···
1
+
{
2
+
"name": "js_top_worker_browser_tests",
3
+
"version": "1.0.0",
4
+
"lockfileVersion": 3,
5
+
"requires": true,
6
+
"packages": {
7
+
"": {
8
+
"name": "js_top_worker_browser_tests",
9
+
"version": "1.0.0",
10
+
"devDependencies": {
11
+
"playwright": "^1.40.0"
12
+
}
13
+
},
14
+
"node_modules/fsevents": {
15
+
"version": "2.3.2",
16
+
"resolved": "https://registry.npmjs.org/fsevents/-/fsevents-2.3.2.tgz",
17
+
"integrity": "sha512-xiqMQR4xAeHTuB9uWm+fFRcIOgKBMiOBP+eXiyT7jsgVCq1bkVygt00oASowB7EdtpOHaaPgKt812P9ab+DDKA==",
18
+
"dev": true,
19
+
"hasInstallScript": true,
20
+
"license": "MIT",
21
+
"optional": true,
22
+
"os": [
23
+
"darwin"
24
+
],
25
+
"engines": {
26
+
"node": "^8.16.0 || ^10.6.0 || >=11.0.0"
27
+
}
28
+
},
29
+
"node_modules/playwright": {
30
+
"version": "1.57.0",
31
+
"resolved": "https://registry.npmjs.org/playwright/-/playwright-1.57.0.tgz",
32
+
"integrity": "sha512-ilYQj1s8sr2ppEJ2YVadYBN0Mb3mdo9J0wQ+UuDhzYqURwSoW4n1Xs5vs7ORwgDGmyEh33tRMeS8KhdkMoLXQw==",
33
+
"dev": true,
34
+
"license": "Apache-2.0",
35
+
"dependencies": {
36
+
"playwright-core": "1.57.0"
37
+
},
38
+
"bin": {
39
+
"playwright": "cli.js"
40
+
},
41
+
"engines": {
42
+
"node": ">=18"
43
+
},
44
+
"optionalDependencies": {
45
+
"fsevents": "2.3.2"
46
+
}
47
+
},
48
+
"node_modules/playwright-core": {
49
+
"version": "1.57.0",
50
+
"resolved": "https://registry.npmjs.org/playwright-core/-/playwright-core-1.57.0.tgz",
51
+
"integrity": "sha512-agTcKlMw/mjBWOnD6kFZttAAGHgi/Nw0CZ2o6JqWSbMlI219lAFLZZCyqByTsvVAJq5XA5H8cA6PrvBRpBWEuQ==",
52
+
"dev": true,
53
+
"license": "Apache-2.0",
54
+
"bin": {
55
+
"playwright-core": "cli.js"
56
+
},
57
+
"engines": {
58
+
"node": ">=18"
59
+
}
60
+
}
61
+
}
62
+
}
+13
js_top_worker/test/browser/package.json
+13
js_top_worker/test/browser/package.json
···
1
+
{
2
+
"name": "js_top_worker_browser_tests",
3
+
"version": "1.0.0",
4
+
"description": "Browser tests for js_top_worker_client",
5
+
"private": true,
6
+
"scripts": {
7
+
"test": "node run_tests.js",
8
+
"test:headed": "node run_tests.js --headed"
9
+
},
10
+
"devDependencies": {
11
+
"playwright": "^1.40.0"
12
+
}
13
+
}
+133
js_top_worker/test/browser/run_tests.js
+133
js_top_worker/test/browser/run_tests.js
···
1
+
#!/usr/bin/env node
2
+
/**
3
+
* Playwright test runner for js_top_worker_client browser tests.
4
+
*
5
+
* Usage:
6
+
* node run_tests.js [--headed]
7
+
*
8
+
* Starts an HTTP server, runs tests in a browser, reports results.
9
+
*/
10
+
11
+
const { chromium } = require('playwright');
12
+
const http = require('http');
13
+
const fs = require('fs');
14
+
const path = require('path');
15
+
16
+
const PORT = 8765;
17
+
const TIMEOUT = 60000; // 60 seconds max test time
18
+
19
+
// Determine the directory where test files are located
20
+
const testDir = path.dirname(fs.realpathSync(__filename));
21
+
const buildDir = path.resolve(testDir, '../../_build/default/test/browser');
22
+
23
+
// MIME types for serving files
24
+
const mimeTypes = {
25
+
'.html': 'text/html',
26
+
'.js': 'application/javascript',
27
+
'.css': 'text/css',
28
+
};
29
+
30
+
function startServer() {
31
+
return new Promise((resolve, reject) => {
32
+
const server = http.createServer((req, res) => {
33
+
let filePath = req.url === '/' ? '/test.html' : req.url;
34
+
35
+
// Try build directory first, then test source directory
36
+
let fullPath = path.join(buildDir, filePath);
37
+
if (!fs.existsSync(fullPath)) {
38
+
fullPath = path.join(testDir, filePath);
39
+
}
40
+
41
+
if (!fs.existsSync(fullPath)) {
42
+
res.writeHead(404);
43
+
res.end('Not found: ' + filePath);
44
+
return;
45
+
}
46
+
47
+
const ext = path.extname(fullPath);
48
+
const contentType = mimeTypes[ext] || 'application/octet-stream';
49
+
50
+
fs.readFile(fullPath, (err, content) => {
51
+
if (err) {
52
+
res.writeHead(500);
53
+
res.end('Error reading file');
54
+
return;
55
+
}
56
+
res.writeHead(200, { 'Content-Type': contentType });
57
+
res.end(content);
58
+
});
59
+
});
60
+
61
+
server.listen(PORT, () => {
62
+
console.log(`Test server running at http://localhost:${PORT}/`);
63
+
resolve(server);
64
+
});
65
+
66
+
server.on('error', reject);
67
+
});
68
+
}
69
+
70
+
async function runTests(headed = false) {
71
+
let server;
72
+
let browser;
73
+
let exitCode = 0;
74
+
75
+
try {
76
+
// Start the HTTP server
77
+
server = await startServer();
78
+
79
+
// Launch browser
80
+
browser = await chromium.launch({ headless: !headed });
81
+
const page = await browser.newPage();
82
+
83
+
// Collect console messages
84
+
const logs = [];
85
+
page.on('console', msg => {
86
+
const text = msg.text();
87
+
logs.push(text);
88
+
console.log(`[browser] ${text}`);
89
+
});
90
+
91
+
// Navigate to test page
92
+
console.log('Loading test page...');
93
+
await page.goto(`http://localhost:${PORT}/`);
94
+
95
+
// Wait for tests to complete
96
+
console.log('Waiting for tests to complete...');
97
+
const results = await page.waitForFunction(
98
+
() => window.testResults && window.testResults.done,
99
+
{ timeout: TIMEOUT }
100
+
);
101
+
102
+
// Get final results
103
+
const testResults = await page.evaluate(() => ({
104
+
total: window.testResults.total,
105
+
passed: window.testResults.passed,
106
+
failed: window.testResults.failed,
107
+
}));
108
+
109
+
console.log('\n========================================');
110
+
console.log(`Test Results: ${testResults.passed}/${testResults.total} passed`);
111
+
console.log('========================================\n');
112
+
113
+
if (testResults.failed > 0) {
114
+
console.log('FAILED: Some tests did not pass');
115
+
exitCode = 1;
116
+
} else {
117
+
console.log('SUCCESS: All tests passed');
118
+
}
119
+
120
+
} catch (err) {
121
+
console.error('Error running tests:', err.message);
122
+
exitCode = 1;
123
+
} finally {
124
+
if (browser) await browser.close();
125
+
if (server) server.close();
126
+
}
127
+
128
+
process.exit(exitCode);
129
+
}
130
+
131
+
// Parse command line args
132
+
const headed = process.argv.includes('--headed');
133
+
runTests(headed);
+41
js_top_worker/test/browser/test.html
+41
js_top_worker/test/browser/test.html
···
1
+
<!DOCTYPE html>
2
+
<html>
3
+
<head>
4
+
<title>js_top_worker_client Browser Test</title>
5
+
<style>
6
+
body { font-family: monospace; padding: 20px; }
7
+
#status { margin-bottom: 20px; }
8
+
.pass { color: green; }
9
+
.fail { color: red; }
10
+
</style>
11
+
</head>
12
+
<body>
13
+
<h1>js_top_worker_client Browser Test</h1>
14
+
<div id="status">Running tests...</div>
15
+
<pre id="log"></pre>
16
+
17
+
<script>
18
+
// Capture console.log for display
19
+
const logEl = document.getElementById('log');
20
+
const originalLog = console.log;
21
+
console.log = function(...args) {
22
+
originalLog.apply(console, args);
23
+
const text = args.map(a => typeof a === 'string' ? a : JSON.stringify(a)).join(' ');
24
+
logEl.textContent += text + '\n';
25
+
26
+
// Update status when done
27
+
if (window.testResults && window.testResults.done) {
28
+
const status = document.getElementById('status');
29
+
const passed = window.testResults.passed;
30
+
const failed = window.testResults.failed;
31
+
if (failed === 0) {
32
+
status.innerHTML = '<span class="pass">All ' + passed + ' tests passed!</span>';
33
+
} else {
34
+
status.innerHTML = '<span class="fail">' + failed + ' tests failed</span> (' + passed + ' passed)';
35
+
}
36
+
}
37
+
};
38
+
</script>
39
+
<script src="client_test.bc.js"></script>
40
+
</body>
41
+
</html>
+323
js_top_worker/test/browser/test_demo.js
+323
js_top_worker/test/browser/test_demo.js
···
1
+
/**
2
+
* Playwright test for js_top_worker demo page
3
+
* Run with: node test/browser/test_demo.js
4
+
*/
5
+
6
+
const { chromium } = require('playwright');
7
+
8
+
async function runTests() {
9
+
console.log('Launching browser...');
10
+
const browser = await chromium.launch({
11
+
headless: true,
12
+
args: ['--no-sandbox', '--disable-setuid-sandbox']
13
+
});
14
+
15
+
const context = await browser.newContext();
16
+
const page = await context.newPage();
17
+
18
+
// Collect console messages
19
+
const consoleMessages = [];
20
+
page.on('console', msg => {
21
+
consoleMessages.push({ type: msg.type(), text: msg.text() });
22
+
console.log(`[browser ${msg.type()}] ${msg.text()}`);
23
+
});
24
+
25
+
// Collect page errors
26
+
const pageErrors = [];
27
+
page.on('pageerror', err => {
28
+
pageErrors.push(err.message);
29
+
console.log(`[page error] ${err.message}`);
30
+
});
31
+
32
+
console.log('Navigating to demo page...');
33
+
await page.goto('http://localhost:8000/demo.html', { timeout: 30000 });
34
+
35
+
// Wait for initialization
36
+
console.log('Waiting for toplevel to initialize...');
37
+
try {
38
+
await page.waitForFunction(
39
+
() => document.getElementById('status-indicator')?.classList.contains('ready'),
40
+
{ timeout: 60000 }
41
+
);
42
+
console.log('✓ Toplevel initialized successfully');
43
+
} catch (e) {
44
+
const status = await page.$eval('#status-text', el => el.textContent);
45
+
console.log(`✗ Initialization failed. Status: ${status}`);
46
+
47
+
// Print relevant console messages
48
+
const errors = consoleMessages.filter(m => m.type === 'error' || m.text.includes('error'));
49
+
if (errors.length > 0) {
50
+
console.log('Console errors:');
51
+
errors.slice(0, 10).forEach(m => console.log(` [${m.type}] ${m.text}`));
52
+
}
53
+
54
+
await browser.close();
55
+
process.exit(1);
56
+
}
57
+
58
+
const results = {
59
+
passed: [],
60
+
failed: []
61
+
};
62
+
63
+
// Test 1: Basic Execution
64
+
console.log('\nTesting Basic Execution...');
65
+
try {
66
+
await page.click('button:has-text("Execute"):near(#exec-input)');
67
+
await page.waitForFunction(
68
+
() => !document.getElementById('exec-output')?.textContent.includes('Executing...'),
69
+
{ timeout: 10000 }
70
+
);
71
+
const execOutput = await page.$eval('#exec-output', el => el.textContent);
72
+
if (execOutput.includes('Hello, OCaml!')) {
73
+
console.log('✓ Basic Execution works');
74
+
results.passed.push('Basic Execution');
75
+
} else {
76
+
console.log(`✗ Basic Execution failed. Output: ${execOutput}`);
77
+
results.failed.push({ name: 'Basic Execution', error: execOutput });
78
+
}
79
+
} catch (e) {
80
+
console.log(`✗ Basic Execution error: ${e.message}`);
81
+
results.failed.push({ name: 'Basic Execution', error: e.message });
82
+
}
83
+
84
+
// Test 2: Multiple Environments
85
+
console.log('\nTesting Multiple Environments...');
86
+
try {
87
+
await page.click('button:has-text("+ New Env")');
88
+
await page.waitForTimeout(1000);
89
+
90
+
const envButtons = await page.$$eval('#env-selector .env-btn', btns => btns.map(b => b.textContent));
91
+
if (envButtons.length > 1) {
92
+
console.log('✓ Environment creation works');
93
+
results.passed.push('Multiple Environments');
94
+
} else {
95
+
console.log(`✗ Environment creation failed. Buttons: ${envButtons.join(', ')}`);
96
+
results.failed.push({ name: 'Multiple Environments', error: 'No new env button appeared' });
97
+
}
98
+
} catch (e) {
99
+
console.log(`✗ Multiple Environments error: ${e.message}`);
100
+
results.failed.push({ name: 'Multiple Environments', error: e.message });
101
+
}
102
+
103
+
// Test 3: MIME Output
104
+
console.log('\nTesting MIME Output...');
105
+
try {
106
+
await page.click('button:has-text("Execute"):near(#mime-input)');
107
+
await page.waitForFunction(
108
+
() => !document.getElementById('mime-output')?.textContent.includes('Executing...'),
109
+
{ timeout: 10000 }
110
+
);
111
+
112
+
// Check if rendered MIME content is visible
113
+
const mimeRendered = await page.$('#mime-rendered');
114
+
const isHidden = await mimeRendered?.evaluate(el => el.classList.contains('hidden'));
115
+
const mimeOutput = await page.$eval('#mime-output', el => el.textContent);
116
+
117
+
if (!isHidden) {
118
+
const svgContent = await mimeRendered?.evaluate(el => el.innerHTML);
119
+
if (svgContent?.includes('svg') || svgContent?.includes('circle')) {
120
+
console.log('✓ MIME Output works (SVG rendered)');
121
+
results.passed.push('MIME Output');
122
+
} else {
123
+
console.log(`✗ MIME Output - SVG not rendered. Content: ${svgContent?.substring(0, 100)}`);
124
+
results.failed.push({ name: 'MIME Output', error: 'SVG not rendered' });
125
+
}
126
+
} else {
127
+
console.log(`✗ MIME Output - rendered area hidden. Output: ${mimeOutput}`);
128
+
results.failed.push({ name: 'MIME Output', error: mimeOutput });
129
+
}
130
+
} catch (e) {
131
+
console.log(`✗ MIME Output error: ${e.message}`);
132
+
results.failed.push({ name: 'MIME Output', error: e.message });
133
+
}
134
+
135
+
// Test 4: Autocomplete
136
+
console.log('\nTesting Autocomplete...');
137
+
try {
138
+
await page.click('button:has-text("Complete")');
139
+
await page.waitForFunction(
140
+
() => !document.getElementById('complete-output')?.textContent.includes('Loading...'),
141
+
{ timeout: 10000 }
142
+
);
143
+
144
+
const completions = await page.$eval('#complete-output', el => el.textContent);
145
+
if (completions.includes('map') || completions.includes('mapi')) {
146
+
console.log('✓ Autocomplete works');
147
+
results.passed.push('Autocomplete');
148
+
} else {
149
+
console.log(`✗ Autocomplete failed. Output: ${completions}`);
150
+
results.failed.push({ name: 'Autocomplete', error: completions });
151
+
}
152
+
} catch (e) {
153
+
console.log(`✗ Autocomplete error: ${e.message}`);
154
+
results.failed.push({ name: 'Autocomplete', error: e.message });
155
+
}
156
+
157
+
// Test 5: Type Information
158
+
console.log('\nTesting Type Information...');
159
+
try {
160
+
await page.click('button:has-text("Get Type")');
161
+
await page.waitForFunction(
162
+
() => !document.getElementById('type-output')?.textContent.includes('Loading...'),
163
+
{ timeout: 10000 }
164
+
);
165
+
166
+
const typeOutput = await page.$eval('#type-output', el => el.textContent);
167
+
if (typeOutput.includes('int') || typeOutput.includes('list') || typeOutput.includes('->')) {
168
+
console.log('✓ Type Information works');
169
+
results.passed.push('Type Information');
170
+
} else {
171
+
console.log(`✗ Type Information failed. Output: ${typeOutput}`);
172
+
results.failed.push({ name: 'Type Information', error: typeOutput });
173
+
}
174
+
} catch (e) {
175
+
console.log(`✗ Type Information error: ${e.message}`);
176
+
results.failed.push({ name: 'Type Information', error: e.message });
177
+
}
178
+
179
+
// Test 6: Error Reporting
180
+
console.log('\nTesting Error Reporting...');
181
+
try {
182
+
await page.click('button:has-text("Check Errors")');
183
+
await page.waitForFunction(
184
+
() => !document.getElementById('errors-output')?.textContent.includes('Analyzing...'),
185
+
{ timeout: 10000 }
186
+
);
187
+
188
+
const errorsOutput = await page.$eval('#errors-output', el => el.textContent);
189
+
// Should find type error or unknown identifier
190
+
if (errorsOutput.includes('Line') || errorsOutput.includes('error') || errorsOutput.includes('Error')) {
191
+
console.log('✓ Error Reporting works');
192
+
results.passed.push('Error Reporting');
193
+
} else {
194
+
console.log(`✗ Error Reporting failed. Output: ${errorsOutput}`);
195
+
results.failed.push({ name: 'Error Reporting', error: errorsOutput });
196
+
}
197
+
} catch (e) {
198
+
console.log(`✗ Error Reporting error: ${e.message}`);
199
+
results.failed.push({ name: 'Error Reporting', error: e.message });
200
+
}
201
+
202
+
// Test 7: Directives - #show List
203
+
console.log('\nTesting Directives...');
204
+
try {
205
+
await page.click('button:has-text("show List")');
206
+
await page.waitForFunction(
207
+
() => !document.getElementById('directive-output')?.textContent.includes('Executing...'),
208
+
{ timeout: 10000 }
209
+
);
210
+
211
+
const directiveOutput = await page.$eval('#directive-output', el => el.textContent);
212
+
if (directiveOutput.includes('module') || directiveOutput.includes('List') || directiveOutput.includes('val')) {
213
+
console.log('✓ Directives work');
214
+
results.passed.push('Directives');
215
+
} else {
216
+
console.log(`✗ Directives failed. Output: ${directiveOutput}`);
217
+
results.failed.push({ name: 'Directives', error: directiveOutput });
218
+
}
219
+
} catch (e) {
220
+
console.log(`✗ Directives error: ${e.message}`);
221
+
results.failed.push({ name: 'Directives', error: e.message });
222
+
}
223
+
224
+
// Test 8: Custom Printers
225
+
console.log('\nTesting Custom Printers...');
226
+
try {
227
+
await page.click('button:has-text("Execute"):near(#printer-input)');
228
+
await page.waitForFunction(
229
+
() => !document.getElementById('printer-output')?.textContent.includes('Executing...'),
230
+
{ timeout: 15000 }
231
+
);
232
+
233
+
const printerOutput = await page.$eval('#printer-output', el => el.textContent);
234
+
if (printerOutput.includes('[COLOR:') || printerOutput.includes('pp_color')) {
235
+
console.log('✓ Custom Printers work');
236
+
results.passed.push('Custom Printers');
237
+
} else {
238
+
console.log(`✗ Custom Printers failed. Output: ${printerOutput.substring(0, 200)}`);
239
+
results.failed.push({ name: 'Custom Printers', error: printerOutput.substring(0, 200) });
240
+
}
241
+
} catch (e) {
242
+
console.log(`✗ Custom Printers error: ${e.message}`);
243
+
results.failed.push({ name: 'Custom Printers', error: e.message });
244
+
}
245
+
246
+
// Test 9: Library Loading (#require)
247
+
console.log('\nTesting Library Loading...');
248
+
try {
249
+
await page.click('button:has-text("Execute"):near(#require-input)');
250
+
await page.waitForFunction(
251
+
() => !document.getElementById('require-output')?.textContent.includes('Executing'),
252
+
{ timeout: 30000 }
253
+
);
254
+
255
+
const requireOutput = await page.$eval('#require-output', el => el.textContent);
256
+
// Str.split should return a list
257
+
if (requireOutput.includes('["a"; "b"; "c"]') || requireOutput.includes('string list')) {
258
+
console.log('✓ Library Loading works');
259
+
results.passed.push('Library Loading');
260
+
} else if (requireOutput.includes('Error') || requireOutput.includes('not found')) {
261
+
console.log(`✗ Library Loading failed (library not available). Output: ${requireOutput}`);
262
+
results.failed.push({ name: 'Library Loading', error: requireOutput });
263
+
} else {
264
+
console.log(`? Library Loading unclear. Output: ${requireOutput}`);
265
+
results.failed.push({ name: 'Library Loading', error: requireOutput });
266
+
}
267
+
} catch (e) {
268
+
console.log(`✗ Library Loading error: ${e.message}`);
269
+
results.failed.push({ name: 'Library Loading', error: e.message });
270
+
}
271
+
272
+
// Test 10: Toplevel Script Execution
273
+
console.log('\nTesting Toplevel Script Execution...');
274
+
try {
275
+
await page.click('button:has-text("Execute Script")');
276
+
await page.waitForFunction(
277
+
() => !document.getElementById('toplevel-output')?.textContent.includes('Executing script...'),
278
+
{ timeout: 15000 }
279
+
);
280
+
281
+
const toplevelOutput = await page.$eval('#toplevel-output', el => el.textContent);
282
+
// Should show the squared numbers [1; 4; 9; 16; 25]
283
+
if (toplevelOutput.includes('[1; 4; 9; 16; 25]') || toplevelOutput.includes('square')) {
284
+
console.log('✓ Toplevel Script Execution works');
285
+
results.passed.push('Toplevel Script Execution');
286
+
} else {
287
+
console.log(`✗ Toplevel Script Execution failed. Output: ${toplevelOutput.substring(0, 200)}`);
288
+
results.failed.push({ name: 'Toplevel Script Execution', error: toplevelOutput.substring(0, 200) });
289
+
}
290
+
} catch (e) {
291
+
console.log(`✗ Toplevel Script Execution error: ${e.message}`);
292
+
results.failed.push({ name: 'Toplevel Script Execution', error: e.message });
293
+
}
294
+
295
+
// Summary
296
+
console.log('\n' + '='.repeat(50));
297
+
console.log('SUMMARY');
298
+
console.log('='.repeat(50));
299
+
console.log(`Passed: ${results.passed.length}`);
300
+
console.log(`Failed: ${results.failed.length}`);
301
+
302
+
if (results.failed.length > 0) {
303
+
console.log('\nFailed tests:');
304
+
results.failed.forEach(f => {
305
+
console.log(` - ${f.name}: ${f.error.substring(0, 100)}`);
306
+
});
307
+
}
308
+
309
+
// Print any page errors
310
+
if (pageErrors.length > 0) {
311
+
console.log('\nPage errors encountered:');
312
+
pageErrors.forEach(e => console.log(` ${e}`));
313
+
}
314
+
315
+
await browser.close();
316
+
317
+
process.exit(results.failed.length > 0 ? 1 : 0);
318
+
}
319
+
320
+
runTests().catch(e => {
321
+
console.error('Test runner error:', e);
322
+
process.exit(1);
323
+
});
+99
js_top_worker/test/browser/test_env_isolation.js
+99
js_top_worker/test/browser/test_env_isolation.js
···
1
+
/**
2
+
* Test environment isolation in js_top_worker
3
+
*/
4
+
5
+
const { chromium } = require('playwright');
6
+
7
+
async function testEnvIsolation() {
8
+
console.log('Launching browser...');
9
+
const browser = await chromium.launch({
10
+
headless: true,
11
+
args: ['--no-sandbox', '--disable-setuid-sandbox']
12
+
});
13
+
14
+
const page = await browser.newPage();
15
+
page.on('console', msg => console.log(`[browser ${msg.type()}] ${msg.text()}`));
16
+
17
+
console.log('Navigating to demo page...');
18
+
await page.goto('http://localhost:8000/demo.html', { timeout: 30000 });
19
+
20
+
// Wait for initialization
21
+
console.log('Waiting for toplevel to initialize...');
22
+
await page.waitForFunction(
23
+
() => document.getElementById('status-indicator')?.classList.contains('ready'),
24
+
{ timeout: 60000 }
25
+
);
26
+
console.log('✓ Toplevel initialized');
27
+
28
+
// Test environment isolation
29
+
console.log('\n=== Testing Environment Isolation ===\n');
30
+
31
+
// Step 1: Set env_value = 100 in default environment
32
+
console.log('Step 1: Setting env_value = 100 in default environment...');
33
+
await page.fill('#env-input', 'let env_value = 100;;');
34
+
await page.click('button:has-text("Execute in Selected Env")');
35
+
await page.waitForTimeout(2000);
36
+
37
+
let output = await page.$eval('#env-output', el => el.textContent);
38
+
console.log(` Output: ${output}`);
39
+
40
+
// Step 2: Create a new environment
41
+
console.log('\nStep 2: Creating env1...');
42
+
await page.click('button:has-text("+ New Env")');
43
+
await page.waitForTimeout(2000);
44
+
45
+
// Step 3: Set env_value = 200 in env1
46
+
console.log('Step 3: Setting env_value = 200 in env1...');
47
+
await page.fill('#env-input', 'let env_value = 200;;');
48
+
await page.click('button:has-text("Execute in Selected Env")');
49
+
await page.waitForTimeout(2000);
50
+
51
+
output = await page.$eval('#env-output', el => el.textContent);
52
+
console.log(` Output: ${output}`);
53
+
54
+
// Step 4: Check env_value in env1 (should be 200)
55
+
console.log('\nStep 4: Checking env_value in env1 (should be 200)...');
56
+
await page.fill('#env-input', 'env_value;;');
57
+
await page.click('button:has-text("Execute in Selected Env")');
58
+
await page.waitForTimeout(2000);
59
+
60
+
output = await page.$eval('#env-output', el => el.textContent);
61
+
console.log(` Output: ${output}`);
62
+
const env1Value = output.includes('200') ? 200 : (output.includes('100') ? 100 : 'unknown');
63
+
console.log(` env_value in env1 = ${env1Value}`);
64
+
65
+
// Step 5: Switch back to default environment
66
+
console.log('\nStep 5: Switching to default environment...');
67
+
await page.click('.env-btn[data-env=""]');
68
+
await page.waitForTimeout(500);
69
+
70
+
// Step 6: Check env_value in default (should be 100)
71
+
console.log('Step 6: Checking env_value in default (should be 100)...');
72
+
await page.fill('#env-input', 'env_value;;');
73
+
await page.click('button:has-text("Execute in Selected Env")');
74
+
await page.waitForTimeout(2000);
75
+
76
+
output = await page.$eval('#env-output', el => el.textContent);
77
+
console.log(` Output: ${output}`);
78
+
const defaultValue = output.includes('100') ? 100 : (output.includes('200') ? 200 : 'unknown');
79
+
console.log(` env_value in default = ${defaultValue}`);
80
+
81
+
// Summary
82
+
console.log('\n=== RESULTS ===');
83
+
console.log(`env1 value: ${env1Value} (expected: 200)`);
84
+
console.log(`default value: ${defaultValue} (expected: 100)`);
85
+
86
+
if (env1Value === 200 && defaultValue === 100) {
87
+
console.log('\n✓ Environment isolation WORKS correctly');
88
+
} else {
89
+
console.log('\n✗ Environment isolation BROKEN');
90
+
console.log(' Both environments share the same state!');
91
+
}
92
+
93
+
await browser.close();
94
+
}
95
+
96
+
testEnvIsolation().catch(e => {
97
+
console.error('Test error:', e);
98
+
process.exit(1);
99
+
});
+110
js_top_worker/test/browser/test_features.js
+110
js_top_worker/test/browser/test_features.js
···
1
+
const { chromium } = require('playwright');
2
+
3
+
async function testFeatures() {
4
+
console.log('Launching browser...');
5
+
const browser = await chromium.launch({
6
+
headless: true,
7
+
args: ['--no-sandbox', '--disable-setuid-sandbox']
8
+
});
9
+
10
+
const page = await browser.newPage();
11
+
12
+
// Collect all console messages
13
+
const consoleMessages = [];
14
+
page.on('console', msg => {
15
+
consoleMessages.push(msg.text());
16
+
console.log('[browser] ' + msg.text());
17
+
});
18
+
page.on('pageerror', err => console.log('[page error] ' + err.message));
19
+
20
+
console.log('Navigating to demo page...');
21
+
await page.goto('http://localhost:8091/demo.html');
22
+
23
+
// Wait for ready
24
+
console.log('Waiting for worker to initialize...');
25
+
try {
26
+
await page.waitForFunction(
27
+
() => document.getElementById('status-text')?.textContent === 'Ready',
28
+
{ timeout: 60000 }
29
+
);
30
+
console.log('Worker ready!\n');
31
+
} catch (e) {
32
+
console.log('Worker init failed');
33
+
await browser.close();
34
+
return;
35
+
}
36
+
37
+
// Test 1: MIME Output
38
+
console.log('=== TEST 1: MIME Output ===');
39
+
const mimeCode = `let svg = {|<svg width="100" height="100"><circle cx="50" cy="50" r="40" fill="blue"/></svg>|};;
40
+
Mime_printer.push "image/svg+xml" svg;;`;
41
+
await page.fill('#mime-input', mimeCode);
42
+
await page.evaluate(() => runMime());
43
+
await page.waitForTimeout(5000);
44
+
const mimeOutput = await page.evaluate(() => document.getElementById('mime-output')?.textContent);
45
+
const mimeRendered = await page.evaluate(() => document.getElementById('mime-rendered')?.innerHTML);
46
+
console.log('MIME Output:', mimeOutput?.substring(0, 200));
47
+
console.log('MIME Rendered:', mimeRendered?.substring(0, 200) || '(empty)');
48
+
console.log('');
49
+
50
+
// Test 2: Autocomplete
51
+
console.log('=== TEST 2: Autocomplete ===');
52
+
await page.fill('#complete-input', 'List.m');
53
+
await page.evaluate(() => runComplete());
54
+
await page.waitForTimeout(3000);
55
+
const completeOutput = await page.evaluate(() => document.getElementById('complete-output')?.textContent);
56
+
console.log('Complete Output:', completeOutput?.substring(0, 300));
57
+
console.log('');
58
+
59
+
// Test 3: Type Information
60
+
console.log('=== TEST 3: Type Information ===');
61
+
await page.fill('#type-input', 'let x = List.map');
62
+
await page.fill('#type-pos', '10');
63
+
await page.evaluate(() => runTypeEnclosing());
64
+
await page.waitForTimeout(3000);
65
+
const typeOutput = await page.evaluate(() => document.getElementById('type-output')?.textContent);
66
+
console.log('Type Output:', typeOutput?.substring(0, 300));
67
+
console.log('');
68
+
69
+
// Test 4: Error Reporting
70
+
console.log('=== TEST 4: Error Reporting ===');
71
+
await page.fill('#errors-input', 'let x : string = 42');
72
+
await page.evaluate(() => runQueryErrors());
73
+
await page.waitForTimeout(3000);
74
+
const errorsOutput = await page.evaluate(() => document.getElementById('errors-output')?.textContent);
75
+
console.log('Errors Output:', errorsOutput?.substring(0, 300));
76
+
console.log('');
77
+
78
+
// Test 5: Custom Printers
79
+
console.log('=== TEST 5: Custom Printers ===');
80
+
const printerCode = `type point = { x: int; y: int };;
81
+
let p = { x = 10; y = 20 };;`;
82
+
await page.fill('#printer-input', printerCode);
83
+
await page.evaluate(() => runPrinter());
84
+
await page.waitForTimeout(3000);
85
+
const printerOutput = await page.evaluate(() => document.getElementById('printer-output')?.textContent);
86
+
console.log('Printer Output:', printerOutput?.substring(0, 300));
87
+
console.log('');
88
+
89
+
// Test 6: Library Loading
90
+
console.log('=== TEST 6: Library Loading ===');
91
+
const requireCode = `#require "str";;
92
+
Str.string_match (Str.regexp "hello") "hello world" 0;;`;
93
+
await page.fill('#require-input', requireCode);
94
+
await page.evaluate(() => runRequire());
95
+
await page.waitForTimeout(5000);
96
+
const requireOutput = await page.evaluate(() => document.getElementById('require-output')?.textContent);
97
+
console.log('Require Output:', requireOutput?.substring(0, 300));
98
+
console.log('');
99
+
100
+
// Print any errors from console
101
+
const errors = consoleMessages.filter(m => m.includes('Error') || m.includes('error') || m.includes('Exception'));
102
+
if (errors.length > 0) {
103
+
console.log('=== ERRORS FOUND ===');
104
+
errors.forEach(e => console.log(e));
105
+
}
106
+
107
+
await browser.close();
108
+
}
109
+
110
+
testFeatures().catch(console.error);
+63
js_top_worker/test/browser/test_worker.ml
+63
js_top_worker/test/browser/test_worker.ml
···
1
+
(** Minimal test worker for browser client tests.
2
+
3
+
This is a simplified worker that doesn't require dynamic package loading,
4
+
making it suitable for isolated browser testing. *)
5
+
6
+
open Js_top_worker_rpc
7
+
open Js_top_worker
8
+
module Server = Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
9
+
10
+
let server process e =
11
+
let _, id, call = Jsonrpc.version_id_and_call_of_string e in
12
+
Lwt.bind (process call) (fun response ->
13
+
let rtxt = Jsonrpc.string_of_response ~id response in
14
+
Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string rtxt);
15
+
Lwt.return ())
16
+
17
+
module S : Impl.S = struct
18
+
type findlib_t = unit
19
+
20
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
21
+
fun f () ->
22
+
let stdout_buff = Buffer.create 1024 in
23
+
let stderr_buff = Buffer.create 1024 in
24
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
25
+
Js_of_ocaml.Sys_js.set_channel_flusher stderr (Buffer.add_string stderr_buff);
26
+
let x = f () in
27
+
({ Impl.stdout = Buffer.contents stdout_buff;
28
+
stderr = Buffer.contents stderr_buff }, x)
29
+
30
+
let sync_get _ = None
31
+
let async_get _ = Lwt.return (Error (`Msg "Not implemented"))
32
+
let create_file = Js_of_ocaml.Sys_js.create_file
33
+
let get_stdlib_dcs _ = []
34
+
let import_scripts _ = ()
35
+
let findlib_init _ = Lwt.return ()
36
+
let require _ () _ = []
37
+
let init_function _ () = ()
38
+
let path = "/static/cmis"
39
+
end
40
+
41
+
module M = Impl.Make (S)
42
+
43
+
let run () =
44
+
let open Js_of_ocaml in
45
+
let open M in
46
+
Console.console##log (Js.string "Test worker starting...");
47
+
Server.init (Impl.IdlM.T.lift init);
48
+
Server.create_env (Impl.IdlM.T.lift create_env);
49
+
Server.destroy_env (Impl.IdlM.T.lift destroy_env);
50
+
Server.list_envs (Impl.IdlM.T.lift list_envs);
51
+
Server.setup (Impl.IdlM.T.lift setup);
52
+
Server.exec execute;
53
+
Server.complete_prefix complete_prefix;
54
+
Server.query_errors query_errors;
55
+
Server.type_enclosing type_enclosing;
56
+
Server.exec_toplevel exec_toplevel;
57
+
let rpc_fn = Impl.IdlM.server Server.implementation in
58
+
Worker.set_onmessage (fun x ->
59
+
let s = Js.to_string x in
60
+
ignore (server rpc_fn s));
61
+
Console.console##log (Js.string "Test worker ready")
62
+
63
+
let () = run ()
+875
js_top_worker/test/cram/directives.t/run.t
+875
js_top_worker/test/cram/directives.t/run.t
···
1
+
Comprehensive test suite for OCaml toplevel directives.
2
+
Most tests will initially FAIL - this is TDD!
3
+
4
+
References:
5
+
- OCaml Manual: https://ocaml.org/manual/5.4/toplevel.html
6
+
- Findlib: http://projects.camlcity.org/projects/dl/findlib-1.7.1/doc/ref-html/lib/Topfind.html
7
+
8
+
$ export OCAMLRUNPARAM=b
9
+
$ export JS_TOP_WORKER_SOCK="/tmp/js_top_worker_directives_$$.sock"
10
+
$ WORKER_PID=$(sh ../start_worker.sh)
11
+
$ unix_client init '{ findlib_requires:[], execute: true }'
12
+
N
13
+
$ unix_client setup ''
14
+
{mime_vals:[];stderr:S(error while evaluating #enable "pretty";;
15
+
error while evaluating #disable "shortvar";;);stdout:S(OCaml version 5.4.0
16
+
Unknown directive enable.
17
+
Unknown directive disable.)}
18
+
19
+
==============================================
20
+
SECTION 1: Basic Code Execution (Baseline)
21
+
==============================================
22
+
23
+
$ unix_client exec_toplevel '' '# 1 + 2;;'
24
+
{mime_vals:[];parts:[];script:S(# 1 + 2;;
25
+
- : int = 3)}
26
+
27
+
$ unix_client exec_toplevel '' '# let x = 42;;'
28
+
{mime_vals:[];parts:[];script:S(# let x = 42;;
29
+
val x : int = 42)}
30
+
31
+
==============================================
32
+
SECTION 2: #show Directives (Environment Query)
33
+
==============================================
34
+
35
+
Define some types and values to query:
36
+
37
+
$ unix_client exec_toplevel '' '# type point = { x: float; y: float };;'
38
+
{mime_vals:[];parts:[];script:S(# type point = { x: float; y: float };;
39
+
type point = { x : float; y : float; })}
40
+
41
+
$ unix_client exec_toplevel '' '# let origin = { x = 0.0; y = 0.0 };;'
42
+
{mime_vals:[];parts:[];script:S(# let origin = { x = 0.0; y = 0.0 };;
43
+
val origin : point = {x = 0.; y = 0.})}
44
+
45
+
$ unix_client exec_toplevel '' '# module MyMod = struct type t = int let zero = 0 end;;'
46
+
{mime_vals:[];parts:[];script:S(# module MyMod = struct type t = int let zero = 0 end;;
47
+
module MyMod : sig type t = int val zero : int end)}
48
+
49
+
$ unix_client exec_toplevel '' '# exception My_error of string;;'
50
+
{mime_vals:[];parts:[];script:S(# exception My_error of string;;
51
+
exception My_error of string)}
52
+
53
+
Test #show directive:
54
+
55
+
$ unix_client exec_toplevel '' '# #show point;;'
56
+
{mime_vals:[];parts:[];script:S(# #show point;;
57
+
type point = { x : float; y : float; })}
58
+
59
+
$ unix_client exec_toplevel '' '# #show origin;;'
60
+
{mime_vals:[];parts:[];script:S(# #show origin;;
61
+
val origin : point)}
62
+
63
+
$ unix_client exec_toplevel '' '# #show MyMod;;'
64
+
{mime_vals:[];parts:[];script:S(# #show MyMod;;
65
+
module MyMod : sig type t = int val zero : int end)}
66
+
67
+
$ unix_client exec_toplevel '' '# #show My_error;;'
68
+
{mime_vals:[];parts:[];script:S(# #show My_error;;
69
+
exception My_error of string)}
70
+
71
+
Test #show_type directive:
72
+
73
+
$ unix_client exec_toplevel '' '# #show_type point;;'
74
+
{mime_vals:[];parts:[];script:S(# #show_type point;;
75
+
type point = { x : float; y : float; })}
76
+
77
+
$ unix_client exec_toplevel '' '# #show_type list;;'
78
+
{mime_vals:[];parts:[];script:S(# #show_type list;;
79
+
type 'a list = [] | (::) of 'a * 'a list)}
80
+
81
+
Test #show_val directive:
82
+
83
+
$ unix_client exec_toplevel '' '# #show_val origin;;'
84
+
{mime_vals:[];parts:[];script:S(# #show_val origin;;
85
+
val origin : point)}
86
+
87
+
$ unix_client exec_toplevel '' '# #show_val List.map;;'
88
+
{mime_vals:[];parts:[];script:S(# #show_val List.map;;
89
+
val map : ('a -> 'b) -> 'a list -> 'b list)}
90
+
91
+
Test #show_module directive:
92
+
93
+
$ unix_client exec_toplevel '' '# #show_module List;;'
94
+
{mime_vals:[];parts:[];script:S(# #show_module List;;
95
+
module List :
96
+
sig
97
+
type 'a t = 'a list = [] | (::) of 'a * 'a list
98
+
val length : 'a list -> int
99
+
val compare_lengths : 'a list -> 'b list -> int
100
+
val compare_length_with : 'a list -> int -> int
101
+
val is_empty : 'a list -> bool
102
+
val cons : 'a -> 'a list -> 'a list
103
+
val singleton : 'a -> 'a list
104
+
val hd : 'a list -> 'a
105
+
val tl : 'a list -> 'a list
106
+
val nth : 'a list -> int -> 'a
107
+
val nth_opt : 'a list -> int -> 'a option
108
+
val rev : 'a list -> 'a list
109
+
val init : int -> (int -> 'a) -> 'a list
110
+
val append : 'a list -> 'a list -> 'a list
111
+
val rev_append : 'a list -> 'a list -> 'a list
112
+
val concat : 'a list list -> 'a list
113
+
val flatten : 'a list list -> 'a list
114
+
val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
115
+
val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
116
+
val iter : ('a -> unit) -> 'a list -> unit
117
+
val iteri : (int -> 'a -> unit) -> 'a list -> unit
118
+
val map : ('a -> 'b) -> 'a list -> 'b list
119
+
val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
120
+
val rev_map : ('a -> 'b) -> 'a list -> 'b list
121
+
val filter_map : ('a -> 'b option) -> 'a list -> 'b list
122
+
val concat_map : ('a -> 'b list) -> 'a list -> 'b list
123
+
val fold_left_map :
124
+
('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list
125
+
val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc
126
+
val fold_right : ('a -> 'acc -> 'acc) -> 'a list -> 'acc -> 'acc
127
+
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
128
+
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
129
+
val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
130
+
val fold_left2 :
131
+
('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a list -> 'b list -> 'acc
132
+
val fold_right2 :
133
+
('a -> 'b -> 'acc -> 'acc) -> 'a list -> 'b list -> 'acc -> 'acc
134
+
val for_all : ('a -> bool) -> 'a list -> bool
135
+
val exists : ('a -> bool) -> 'a list -> bool
136
+
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
137
+
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
138
+
val mem : 'a -> 'a list -> bool
139
+
val memq : 'a -> 'a list -> bool
140
+
val find : ('a -> bool) -> 'a list -> 'a
141
+
val find_opt : ('a -> bool) -> 'a list -> 'a option
142
+
val find_index : ('a -> bool) -> 'a list -> int option
143
+
val find_map : ('a -> 'b option) -> 'a list -> 'b option
144
+
val find_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b option
145
+
val filter : ('a -> bool) -> 'a list -> 'a list
146
+
val find_all : ('a -> bool) -> 'a list -> 'a list
147
+
val filteri : (int -> 'a -> bool) -> 'a list -> 'a list
148
+
val take : int -> 'a list -> 'a list
149
+
val drop : int -> 'a list -> 'a list
150
+
val take_while : ('a -> bool) -> 'a list -> 'a list
151
+
val drop_while : ('a -> bool) -> 'a list -> 'a list
152
+
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
153
+
val partition_map :
154
+
('a -> ('b, 'c) Either.t) -> 'a list -> 'b list * 'c list
155
+
val assoc : 'a -> ('a * 'b) list -> 'b
156
+
val assoc_opt : 'a -> ('a * 'b) list -> 'b option
157
+
val assq : 'a -> ('a * 'b) list -> 'b
158
+
val assq_opt : 'a -> ('a * 'b) list -> 'b option
159
+
val mem_assoc : 'a -> ('a * 'b) list -> bool
160
+
val mem_assq : 'a -> ('a * 'b) list -> bool
161
+
val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
162
+
val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
163
+
val split : ('a * 'b) list -> 'a list * 'b list
164
+
val combine : 'a list -> 'b list -> ('a * 'b) list
165
+
val sort : ('a -> 'a -> int) -> 'a list -> 'a list
166
+
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
167
+
val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
168
+
val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list
169
+
val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
170
+
val to_seq : 'a list -> 'a Seq.t
171
+
val of_seq : 'a Seq.t -> 'a list
172
+
end)}
173
+
174
+
Test #show_exception directive:
175
+
176
+
$ unix_client exec_toplevel '' '# #show_exception Not_found;;'
177
+
{mime_vals:[];parts:[];script:S(# #show_exception Not_found;;
178
+
exception Not_found)}
179
+
180
+
$ unix_client exec_toplevel '' '# #show_exception Invalid_argument;;'
181
+
{mime_vals:[];parts:[];script:S(# #show_exception Invalid_argument;;
182
+
exception Invalid_argument of string)}
183
+
184
+
==============================================
185
+
SECTION 3: #print_depth and #print_length
186
+
==============================================
187
+
188
+
$ unix_client exec_toplevel '' '# let nested = [[[[1;2;3]]]];;'
189
+
{mime_vals:[];parts:[];script:S(# let nested = [[[[1;2;3]]]];;
190
+
val nested : int list list list list = [[[[1; 2; 3]]]])}
191
+
192
+
Test #print_depth:
193
+
194
+
$ unix_client exec_toplevel '' '# #print_depth 2;;'
195
+
{mime_vals:[];parts:[];script:S(# #print_depth 2;;)}
196
+
197
+
$ unix_client exec_toplevel '' '# nested;;'
198
+
{mime_vals:[];parts:[];script:S(# nested;;
199
+
- : int list list list list = [[[...]]])}
200
+
201
+
$ unix_client exec_toplevel '' '# #print_depth 100;;'
202
+
{mime_vals:[];parts:[];script:S(# #print_depth 100;;)}
203
+
204
+
$ unix_client exec_toplevel '' '# nested;;'
205
+
{mime_vals:[];parts:[];script:S(# nested;;
206
+
- : int list list list list = [[[[1; 2; 3]]]])}
207
+
208
+
Test #print_length:
209
+
210
+
$ unix_client exec_toplevel '' '# let long_list = [1;2;3;4;5;6;7;8;9;10];;'
211
+
{mime_vals:[];parts:[];script:S(# let long_list = [1;2;3;4;5;6;7;8;9;10];;
212
+
val long_list : int list = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10])}
213
+
214
+
$ unix_client exec_toplevel '' '# #print_length 3;;'
215
+
{mime_vals:[];parts:[];script:S(# #print_length 3;;)}
216
+
217
+
$ unix_client exec_toplevel '' '# long_list;;'
218
+
{mime_vals:[];parts:[];script:S(# long_list;;
219
+
- : int list = [1; 2; ...])}
220
+
221
+
$ unix_client exec_toplevel '' '# #print_length 100;;'
222
+
{mime_vals:[];parts:[];script:S(# #print_length 100;;)}
223
+
224
+
==============================================
225
+
SECTION 4: #install_printer and #remove_printer
226
+
==============================================
227
+
228
+
$ unix_client exec_toplevel '' '# type color = Red | Green | Blue;;'
229
+
{mime_vals:[];parts:[];script:S(# type color = Red | Green | Blue;;
230
+
type color = Red | Green | Blue)}
231
+
232
+
$ unix_client exec_toplevel '' '# let pp_color fmt c = Format.fprintf fmt "<color:%s>" (match c with Red -> "red" | Green -> "green" | Blue -> "blue");;'
233
+
{mime_vals:[];parts:[];script:S(# let pp_color fmt c = Format.fprintf fmt "<color:%s>" (match c with Red -> "red" | Green -> "green" | Blue -> "blue");;
234
+
val pp_color : Format.formatter -> color -> unit = <fun>)}
235
+
236
+
Test #install_printer:
237
+
238
+
$ unix_client exec_toplevel '' '# #install_printer pp_color;;'
239
+
{mime_vals:[];parts:[];script:S(# #install_printer pp_color;;)}
240
+
241
+
$ unix_client exec_toplevel '' '# Red;;'
242
+
{mime_vals:[];parts:[];script:S(# Red;;
243
+
- : color = <color:red>)}
244
+
245
+
$ unix_client exec_toplevel '' '# [Red; Green; Blue];;'
246
+
{mime_vals:[];parts:[];script:S(# [Red; Green; Blue];;
247
+
- : color list = [<color:red>; <color:green>; <color:blue>])}
248
+
249
+
Test #remove_printer:
250
+
251
+
$ unix_client exec_toplevel '' '# #remove_printer pp_color;;'
252
+
{mime_vals:[];parts:[];script:S(# #remove_printer pp_color;;)}
253
+
254
+
$ unix_client exec_toplevel '' '# Red;;'
255
+
{mime_vals:[];parts:[];script:S(# Red;;
256
+
- : color = Red)}
257
+
258
+
==============================================
259
+
SECTION 5: #warnings and #warn_error
260
+
==============================================
261
+
262
+
$ unix_client exec_toplevel '' '# #warnings "-26";;'
263
+
{mime_vals:[];parts:[];script:S(# #warnings "-26";;)}
264
+
265
+
Code with unused variable should not warn:
266
+
267
+
$ unix_client exec_toplevel '' '# let _ = let unused = 1 in 2;;'
268
+
{mime_vals:[];parts:[];script:S(# let _ = let unused = 1 in 2;;
269
+
- : int = 2)}
270
+
271
+
Re-enable warning:
272
+
273
+
$ unix_client exec_toplevel '' '# #warnings "+26";;'
274
+
{mime_vals:[];parts:[];script:S(# #warnings "+26";;)}
275
+
276
+
Now should warn:
277
+
278
+
$ unix_client exec_toplevel '' '# let _ = let unused2 = 1 in 2;;'
279
+
{mime_vals:[];parts:[];script:S(# let _ = let unused2 = 1 in 2;;
280
+
Line 1, characters 12-19:
281
+
Warning 26 [unused-var]: unused variable unused2.
282
+
- : int = 2)}
283
+
284
+
Test #warn_error:
285
+
286
+
$ unix_client exec_toplevel '' '# #warn_error "+26";;'
287
+
{mime_vals:[];parts:[];script:S(# #warn_error "+26";;)}
288
+
289
+
$ unix_client exec_toplevel '' '# let _ = let unused3 = 1 in 2;;'
290
+
{mime_vals:[];parts:[];script:S(# let _ = let unused3 = 1 in 2;;
291
+
Line 1, characters 12-19:
292
+
Error (warning 26 [unused-var]): unused variable unused3.)}
293
+
294
+
Reset:
295
+
296
+
$ unix_client exec_toplevel '' '# #warn_error "-a";;'
297
+
{mime_vals:[];parts:[];script:S(# #warn_error "-a";;)}
298
+
299
+
==============================================
300
+
SECTION 6: #rectypes
301
+
==============================================
302
+
303
+
Without rectypes, recursive type should fail:
304
+
305
+
$ unix_client exec_toplevel '' "# type 'a t = 'a t -> int;;"
306
+
{mime_vals:[];parts:[];script:S(# type 'a t = 'a t -> int;;
307
+
Line 1, characters 0-23:
308
+
Error: The type abbreviation t is cyclic:
309
+
'a t = 'a t -> int,
310
+
'a t -> int contains 'a t)}
311
+
312
+
Enable rectypes:
313
+
314
+
$ unix_client exec_toplevel '' '# #rectypes;;'
315
+
{mime_vals:[];parts:[];script:S(# #rectypes;;)}
316
+
317
+
Now recursive type should work:
318
+
319
+
$ unix_client exec_toplevel '' "# type 'a u = 'a u -> int;;"
320
+
{mime_vals:[];parts:[];script:S(# type 'a u = 'a u -> int;;
321
+
type 'a u = 'a u -> int)}
322
+
323
+
==============================================
324
+
SECTION 7: #directory
325
+
==============================================
326
+
327
+
$ unix_client exec_toplevel '' '# #directory "/tmp";;'
328
+
{mime_vals:[];parts:[];script:S(# #directory "/tmp";;)}
329
+
330
+
$ unix_client exec_toplevel '' '# #remove_directory "/tmp";;'
331
+
{mime_vals:[];parts:[];script:S(# #remove_directory "/tmp";;)}
332
+
333
+
==============================================
334
+
SECTION 8: #help
335
+
==============================================
336
+
337
+
$ unix_client exec_toplevel '' '# #help;;'
338
+
{mime_vals:[];parts:[];script:S(# #help;;
339
+
General
340
+
#help
341
+
Prints a list of all available directives, with corresponding argument type
342
+
if appropriate.
343
+
#quit
344
+
Exit the toplevel.
345
+
346
+
Loading code
347
+
#cd <str>
348
+
Change the current working directory.
349
+
#directory <str>
350
+
Add the given directory to search path for source and compiled files.
351
+
#load <str>
352
+
Load in memory a bytecode object, produced by ocamlc.
353
+
#load_rec <str>
354
+
As #load, but loads dependencies recursively.
355
+
#mod_use <str>
356
+
Usage is identical to #use but #mod_use wraps the contents in a module.
357
+
#remove_directory <str>
358
+
Remove the given directory from the search path.
359
+
#show_dirs
360
+
List directories currently in the search path.
361
+
#use <str>
362
+
Read, compile and execute source phrases from the given file.
363
+
#use_output <str>
364
+
Execute a command and read, compile and execute source phrases from its
365
+
output.
366
+
367
+
Environment queries
368
+
#show <ident>
369
+
Print the signatures of components from any of the categories below.
370
+
#show_class <ident>
371
+
Print the signature of the corresponding class.
372
+
#show_class_type <ident>
373
+
Print the signature of the corresponding class type.
374
+
#show_constructor <ident>
375
+
Print the signature of the corresponding value constructor.
376
+
#show_exception <ident>
377
+
Print the signature of the corresponding exception.
378
+
#show_module <ident>
379
+
Print the signature of the corresponding module.
380
+
#show_module_type <ident>
381
+
Print the signature of the corresponding module type.
382
+
#show_type <ident>
383
+
Print the signature of the corresponding type constructor.
384
+
#show_val <ident>
385
+
Print the signature of the corresponding value.
386
+
387
+
Findlib
388
+
#require <str>
389
+
Load a package (js_top_worker)
390
+
#require <str>
391
+
Load a package (js_top_worker)
392
+
393
+
Pretty-printing
394
+
#install_printer <ident>
395
+
Registers a printer for values of a certain type.
396
+
#print_depth <int>
397
+
Limit the printing of values to a maximal depth of n.
398
+
#print_length <int>
399
+
Limit the number of value nodes printed to at most n.
400
+
#remove_printer <ident>
401
+
Remove the named function from the table of toplevel printers.
402
+
403
+
Tracing
404
+
#trace <ident>
405
+
All calls to the function named function-name will be traced.
406
+
#untrace <ident>
407
+
Stop tracing the given function.
408
+
#untrace_all
409
+
Stop tracing all functions traced so far.
410
+
411
+
Compiler options
412
+
#debug <bool>
413
+
Choose whether to generate debugging events.
414
+
#labels <bool>
415
+
Choose whether to ignore labels in function types.
416
+
#ppx <str>
417
+
After parsing, pipe the abstract syntax tree through the preprocessor
418
+
command.
419
+
#principal <bool>
420
+
Make sure that all types are derived in a principal way.
421
+
#rectypes
422
+
Allow arbitrary recursive types during type-checking.
423
+
#warn_error <str>
424
+
Treat as errors the warnings enabled by the argument.
425
+
#warnings <str>
426
+
Enable or disable warnings according to the argument.
427
+
428
+
Undocumented
429
+
#camlp4o
430
+
#camlp4r
431
+
#list
432
+
#predicates <str>
433
+
#thread)}
434
+
435
+
==============================================
436
+
SECTION 9: #use (File Loading)
437
+
==============================================
438
+
439
+
Create a test file:
440
+
441
+
$ cat > /tmp/test_use.ml << 'EOF'
442
+
> let from_file = "loaded via #use"
443
+
> let add x y = x + y
444
+
> EOF
445
+
446
+
$ unix_client exec_toplevel '' '# #use "/tmp/test_use.ml";;'
447
+
{mime_vals:[];parts:[];script:S(# #use "/tmp/test_use.ml";;
448
+
val from_file : string = "loaded via #use"
449
+
450
+
val add : int -> int -> int = <fun>)}
451
+
452
+
$ unix_client exec_toplevel '' '# from_file;;'
453
+
{mime_vals:[];parts:[];script:S(# from_file;;
454
+
- : string = "loaded via #use")}
455
+
456
+
$ unix_client exec_toplevel '' '# add 1 2;;'
457
+
{mime_vals:[];parts:[];script:S(# add 1 2;;
458
+
- : int = 3)}
459
+
460
+
==============================================
461
+
SECTION 10: #mod_use
462
+
==============================================
463
+
464
+
Create a test file:
465
+
466
+
$ cat > /tmp/test_mod.ml << 'EOF'
467
+
> let value = 42
468
+
> type t = A | B
469
+
> EOF
470
+
471
+
$ unix_client exec_toplevel '' '# #mod_use "/tmp/test_mod.ml";;'
472
+
{mime_vals:[];parts:[];script:S(# #mod_use "/tmp/test_mod.ml";;
473
+
module Test_mod : sig val value : int type t = A | B end)}
474
+
475
+
$ unix_client exec_toplevel '' '# Test_mod.value;;'
476
+
{mime_vals:[];parts:[];script:S(# Test_mod.value;;
477
+
- : int = 42)}
478
+
479
+
==============================================
480
+
SECTION 11: Findlib #require
481
+
==============================================
482
+
483
+
$ unix_client exec_toplevel '' '# #require "str";;'
484
+
{mime_vals:[];parts:[];script:S(# #require "str";;
485
+
/home/jons-agent/.opam/default/lib/ocaml/str: added to search path)}
486
+
487
+
$ unix_client exec_toplevel '' '# Str.regexp "test";;'
488
+
{mime_vals:[];parts:[];script:S(# Str.regexp "test";;
489
+
- : Str.regexp = <abstr>)}
490
+
491
+
==============================================
492
+
SECTION 12: Findlib #list
493
+
==============================================
494
+
495
+
$ unix_client exec_toplevel '' '# #list;;'
496
+
{mime_vals:[];parts:[];script:S(# #list;;
497
+
angstrom (version: 0.16.1)
498
+
angstrom.async (version: n/a)
499
+
angstrom.lwt-unix (version: n/a)
500
+
angstrom.unix (version: n/a)
501
+
astring (version: 0.8.5)
502
+
astring.top (version: 0.8.5)
503
+
base (version: v0.17.3)
504
+
base.base_internalhash_types (version: v0.17.3)
505
+
base.md5 (version: v0.17.3)
506
+
base.shadow_stdlib (version: v0.17.3)
507
+
base64 (version: 3.5.2)
508
+
base64.rfc2045 (version: 3.5.2)
509
+
bigstringaf (version: 0.10.0)
510
+
bos (version: 0.2.1)
511
+
bos.setup (version: 0.2.1)
512
+
bos.top (version: 0.2.1)
513
+
brr (version: 0.0.8)
514
+
brr.ocaml_poke (version: 0.0.8)
515
+
brr.ocaml_poke_ui (version: 0.0.8)
516
+
brr.poke (version: 0.0.8)
517
+
brr.poked (version: 0.0.8)
518
+
bytes (version: [distributed with OCaml 4.02 or above])
519
+
bytesrw (version: 0.3.0)
520
+
bytesrw.sysrandom (version: 0.3.0)
521
+
bytesrw.unix (version: 0.3.0)
522
+
camlp-streams (version: n/a)
523
+
cbort (version: 2b102ae)
524
+
chrome-trace (version: 1.6.2-12057-g12f9ecb)
525
+
cmdliner (version: 2.1.0)
526
+
compiler-libs (version: 5.4.0)
527
+
compiler-libs.bytecomp (version: 5.4.0)
528
+
compiler-libs.common (version: 5.4.0)
529
+
compiler-libs.native-toplevel (version: 5.4.0)
530
+
compiler-libs.optcomp (version: 5.4.0)
531
+
compiler-libs.toplevel (version: 5.4.0)
532
+
cppo (version: n/a)
533
+
csexp (version: 1.5.2)
534
+
cstruct (version: 6.2.0)
535
+
domain-local-await (version: 1.0.1)
536
+
dune (version: n/a)
537
+
dune-action-plugin (version: 1.6.2-12057-g12f9ecb)
538
+
dune-build-info (version: 1.6.2-12057-g12f9ecb)
539
+
dune-configurator (version: 1.6.2-12057-g12f9ecb)
540
+
dune-glob (version: 1.6.2-12057-g12f9ecb)
541
+
dune-private-libs (version: n/a)
542
+
dune-private-libs.dune-section (version: 1.6.2-12057-g12f9ecb)
543
+
dune-private-libs.meta_parser (version: 1.6.2-12057-g12f9ecb)
544
+
dune-rpc (version: 1.6.2-12057-g12f9ecb)
545
+
dune-rpc-lwt (version: 1.6.2-12057-g12f9ecb)
546
+
dune-rpc.private (version: 1.6.2-12057-g12f9ecb)
547
+
dune-site (version: 1.6.2-12057-g12f9ecb)
548
+
dune-site.dynlink (version: 1.6.2-12057-g12f9ecb)
549
+
dune-site.linker (version: 1.6.2-12057-g12f9ecb)
550
+
dune-site.plugins (version: 1.6.2-12057-g12f9ecb)
551
+
dune-site.private (version: 1.6.2-12057-g12f9ecb)
552
+
dune-site.toplevel (version: 1.6.2-12057-g12f9ecb)
553
+
dune.configurator (version: n/a)
554
+
dyn (version: 1.6.2-12057-g12f9ecb)
555
+
dynlink (version: 5.4.0)
556
+
eio (version: n/a)
557
+
eio.core (version: n/a)
558
+
eio.mock (version: n/a)
559
+
eio.runtime_events (version: n/a)
560
+
eio.unix (version: n/a)
561
+
eio.utils (version: n/a)
562
+
eio_linux (version: n/a)
563
+
eio_main (version: n/a)
564
+
eio_posix (version: n/a)
565
+
either (version: 1.0.0)
566
+
findlib (version: 1.9.8)
567
+
findlib.dynload (version: 1.9.8)
568
+
findlib.internal (version: 1.9.8)
569
+
findlib.top (version: 1.9.8)
570
+
fix (version: n/a)
571
+
fmt (version: 0.11.0)
572
+
fmt.cli (version: 0.11.0)
573
+
fmt.top (version: 0.11.0)
574
+
fmt.tty (version: 0.11.0)
575
+
fpath (version: 0.7.3)
576
+
fpath.top (version: 0.7.3)
577
+
fs-io (version: 1.6.2-12057-g12f9ecb)
578
+
gen (version: 1.1)
579
+
hmap (version: 0.8.1)
580
+
iomux (version: v0.4)
581
+
jane-street-headers (version: v0.17.0)
582
+
js_of_ocaml (version: 6.2.0)
583
+
js_of_ocaml-compiler (version: 6.2.0)
584
+
js_of_ocaml-compiler.dynlink (version: 6.2.0)
585
+
js_of_ocaml-compiler.findlib-support (version: 6.2.0)
586
+
js_of_ocaml-compiler.runtime (version: 6.2.0)
587
+
js_of_ocaml-compiler.runtime-files (version: 6.2.0)
588
+
js_of_ocaml-lwt (version: 6.2.0)
589
+
js_of_ocaml-ppx (version: 6.2.0)
590
+
js_of_ocaml-ppx.as-lib (version: 6.2.0)
591
+
js_of_ocaml-toplevel (version: 6.2.0)
592
+
js_of_ocaml.deriving (version: 6.2.0)
593
+
js_top_worker (version: 0.0.1)
594
+
js_top_worker-bin (version: n/a)
595
+
js_top_worker-client (version: 0.0.1)
596
+
js_top_worker-client.msg (version: 0.0.1)
597
+
js_top_worker-client_fut (version: 0.0.1)
598
+
js_top_worker-rpc (version: 0.0.1)
599
+
js_top_worker-rpc.message (version: 0.0.1)
600
+
js_top_worker-unix (version: n/a)
601
+
js_top_worker-web (version: 0.0.1)
602
+
js_top_worker_rpc_def (version: n/a)
603
+
js_top_worker_rpc_def.__private__ (version: n/a)
604
+
js_top_worker_rpc_def.__private__.js_top_worker_rpc_def (version: 0.0.1)
605
+
jsonm (version: 1.0.2)
606
+
jst-config (version: v0.17.0)
607
+
logs (version: 0.10.0)
608
+
logs.browser (version: 0.10.0)
609
+
logs.cli (version: 0.10.0)
610
+
logs.fmt (version: 0.10.0)
611
+
logs.lwt (version: 0.10.0)
612
+
logs.threaded (version: 0.10.0)
613
+
logs.top (version: 0.10.0)
614
+
lwt (version: 6.0.0)
615
+
lwt-dllist (version: 1.1.0)
616
+
lwt.unix (version: 6.0.0)
617
+
menhir (version: n/a)
618
+
menhirCST (version: 20260122)
619
+
menhirGLR (version: 20260122)
620
+
menhirLib (version: 20260122)
621
+
menhirSdk (version: 20260122)
622
+
merlin-lib (version: n/a)
623
+
merlin-lib.analysis (version: 5.6.1-504)
624
+
merlin-lib.commands (version: 5.6.1-504)
625
+
merlin-lib.config (version: 5.6.1-504)
626
+
merlin-lib.dot_protocol (version: 5.6.1-504)
627
+
merlin-lib.extend (version: 5.6.1-504)
628
+
merlin-lib.index_format (version: 5.6.1-504)
629
+
merlin-lib.kernel (version: 5.6.1-504)
630
+
merlin-lib.ocaml_compression (version: 5.6.1-504)
631
+
merlin-lib.ocaml_merlin_specific (version: 5.6.1-504)
632
+
merlin-lib.ocaml_parsing (version: 5.6.1-504)
633
+
merlin-lib.ocaml_preprocess (version: 5.6.1-504)
634
+
merlin-lib.ocaml_typing (version: 5.6.1-504)
635
+
merlin-lib.ocaml_utils (version: 5.6.1-504)
636
+
merlin-lib.os_ipc (version: 5.6.1-504)
637
+
merlin-lib.query_commands (version: 5.6.1-504)
638
+
merlin-lib.query_protocol (version: 5.6.1-504)
639
+
merlin-lib.sherlodoc (version: 5.6.1-504)
640
+
merlin-lib.utils (version: 5.6.1-504)
641
+
mime_printer (version: e46cb08)
642
+
mtime (version: 2.1.0)
643
+
mtime.clock (version: 2.1.0)
644
+
mtime.clock.os (version: 2.1.0)
645
+
mtime.top (version: 2.1.0)
646
+
ocaml-compiler-libs (version: n/a)
647
+
ocaml-compiler-libs.bytecomp (version: v0.17.0)
648
+
ocaml-compiler-libs.common (version: v0.17.0)
649
+
ocaml-compiler-libs.optcomp (version: v0.17.0)
650
+
ocaml-compiler-libs.shadow (version: v0.17.0)
651
+
ocaml-compiler-libs.toplevel (version: v0.17.0)
652
+
ocaml-syntax-shims (version: n/a)
653
+
ocaml-version (version: n/a)
654
+
ocaml_intrinsics_kernel (version: v0.17.1)
655
+
ocamlbuild (version: 0.16.1)
656
+
ocamlc-loc (version: 1.6.2-12057-g12f9ecb)
657
+
ocamldoc (version: 5.4.0)
658
+
ocamlformat-lib (version: 0.28.1)
659
+
ocamlformat-lib.format_ (version: 0.28.1)
660
+
ocamlformat-lib.ocaml_common (version: 0.28.1)
661
+
ocamlformat-lib.ocamlformat_stdlib (version: 0.28.1)
662
+
ocamlformat-lib.odoc_parser (version: 0.28.1)
663
+
ocamlformat-lib.parser_extended (version: 0.28.1)
664
+
ocamlformat-lib.parser_shims (version: 0.28.1)
665
+
ocamlformat-lib.parser_standard (version: 0.28.1)
666
+
ocamlformat-lib.stdlib_shims (version: 0.28.1)
667
+
ocamlgraph (version: 2.2.0)
668
+
ocp-indent (version: n/a)
669
+
ocp-indent.dynlink (version: 1.9.0)
670
+
ocp-indent.lexer (version: 1.9.0)
671
+
ocp-indent.lib (version: 1.9.0)
672
+
ocp-indent.utils (version: 1.9.0)
673
+
ocplib-endian (version: n/a)
674
+
ocplib-endian.bigstring (version: n/a)
675
+
opam-core (version: n/a)
676
+
opam-core.cmdliner (version: n/a)
677
+
opam-file-format (version: 2.2.0)
678
+
opam-format (version: n/a)
679
+
optint (version: 0.3.0)
680
+
ordering (version: 1.6.2-12057-g12f9ecb)
681
+
patch (version: 3.1.0)
682
+
pp (version: 2.0.0)
683
+
ppx_assert (version: v0.17.0)
684
+
ppx_assert.runtime-lib (version: v0.17.0)
685
+
ppx_base (version: v0.17.0)
686
+
ppx_blob (version: 0.9.0)
687
+
ppx_cold (version: v0.17.0)
688
+
ppx_compare (version: v0.17.0)
689
+
ppx_compare.expander (version: v0.17.0)
690
+
ppx_compare.runtime-lib (version: v0.17.0)
691
+
ppx_derivers (version: n/a)
692
+
ppx_deriving (version: n/a)
693
+
ppx_deriving.api (version: 6.1.1)
694
+
ppx_deriving.create (version: 6.1.1)
695
+
ppx_deriving.enum (version: 6.1.1)
696
+
ppx_deriving.eq (version: 6.1.1)
697
+
ppx_deriving.fold (version: 6.1.1)
698
+
ppx_deriving.iter (version: 6.1.1)
699
+
ppx_deriving.make (version: 6.1.1)
700
+
ppx_deriving.map (version: 6.1.1)
701
+
ppx_deriving.ord (version: 6.1.1)
702
+
ppx_deriving.runtime (version: 6.1.1)
703
+
ppx_deriving.show (version: 6.1.1)
704
+
ppx_deriving.std (version: 6.1.1)
705
+
ppx_deriving_rpc (version: 10.0.0)
706
+
ppx_enumerate (version: v0.17.0)
707
+
ppx_enumerate.runtime-lib (version: v0.17.0)
708
+
ppx_expect (version: v0.17.3)
709
+
ppx_expect.config (version: v0.17.3)
710
+
ppx_expect.config_types (version: v0.17.3)
711
+
ppx_expect.evaluator (version: v0.17.3)
712
+
ppx_expect.make_corrected_file (version: v0.17.3)
713
+
ppx_expect.runtime (version: v0.17.3)
714
+
ppx_globalize (version: v0.17.2)
715
+
ppx_hash (version: v0.17.0)
716
+
ppx_hash.expander (version: v0.17.0)
717
+
ppx_hash.runtime-lib (version: v0.17.0)
718
+
ppx_here (version: v0.17.0)
719
+
ppx_here.expander (version: v0.17.0)
720
+
ppx_here.runtime-lib (version: v0.17.0)
721
+
ppx_inline_test (version: v0.17.1)
722
+
ppx_inline_test.config (version: v0.17.1)
723
+
ppx_inline_test.drop (version: v0.17.1)
724
+
ppx_inline_test.libname (version: v0.17.1)
725
+
ppx_inline_test.runner (version: v0.17.1)
726
+
ppx_inline_test.runner.lib (version: v0.17.1)
727
+
ppx_inline_test.runtime-lib (version: v0.17.1)
728
+
ppx_optcomp (version: v0.17.1)
729
+
ppx_sexp_conv (version: v0.17.1)
730
+
ppx_sexp_conv.expander (version: v0.17.1)
731
+
ppx_sexp_conv.runtime-lib (version: v0.17.1)
732
+
ppxlib (version: 0.37.0)
733
+
ppxlib.__private__ (version: n/a)
734
+
ppxlib.__private__.ppx_foo_deriver (version: 0.37.0)
735
+
ppxlib.ast (version: 0.37.0)
736
+
ppxlib.astlib (version: 0.37.0)
737
+
ppxlib.metaquot (version: 0.37.0)
738
+
ppxlib.metaquot_lifters (version: 0.37.0)
739
+
ppxlib.print_diff (version: 0.37.0)
740
+
ppxlib.runner (version: 0.37.0)
741
+
ppxlib.runner_as_ppx (version: 0.37.0)
742
+
ppxlib.stdppx (version: 0.37.0)
743
+
ppxlib.traverse (version: 0.37.0)
744
+
ppxlib.traverse_builtins (version: 0.37.0)
745
+
ppxlib_jane (version: v0.17.4)
746
+
psq (version: 0.2.1)
747
+
re (version: n/a)
748
+
re.emacs (version: n/a)
749
+
re.glob (version: n/a)
750
+
re.pcre (version: n/a)
751
+
re.perl (version: n/a)
752
+
re.posix (version: n/a)
753
+
re.str (version: n/a)
754
+
result (version: 1.5)
755
+
rpclib (version: 10.0.0)
756
+
rpclib-lwt (version: 10.0.0)
757
+
rpclib.cmdliner (version: 10.0.0)
758
+
rpclib.core (version: 10.0.0)
759
+
rpclib.internals (version: 10.0.0)
760
+
rpclib.json (version: 10.0.0)
761
+
rpclib.markdown (version: 10.0.0)
762
+
rpclib.xml (version: 10.0.0)
763
+
rresult (version: 0.7.0)
764
+
rresult.top (version: 0.7.0)
765
+
runtime_events (version: 5.4.0)
766
+
sedlex (version: 3.7)
767
+
sedlex.ppx (version: 3.7)
768
+
sedlex.utils (version: 3.7)
769
+
seq (version: [distributed with OCaml 4.07 or above])
770
+
sexplib0 (version: v0.17.0)
771
+
sha (version: v1.15.4)
772
+
stdio (version: v0.17.0)
773
+
stdlib (version: 5.4.0)
774
+
stdlib-shims (version: 0.3.0)
775
+
stdune (version: 1.6.2-12057-g12f9ecb)
776
+
str (version: 5.4.0)
777
+
stringext (version: 1.6.0)
778
+
swhid_core (version: n/a)
779
+
thread-table (version: 1.0.0)
780
+
threads (version: 5.4.0)
781
+
threads.posix (version: [internal])
782
+
time_now (version: v0.17.0)
783
+
top-closure (version: 1.6.2-12057-g12f9ecb)
784
+
topkg (version: 1.1.1)
785
+
tyxml (version: 4.6.0)
786
+
tyxml.functor (version: 4.6.0)
787
+
unix (version: 5.4.0)
788
+
uri (version: 4.4.0)
789
+
uri.services (version: 4.4.0)
790
+
uri.services_full (version: 4.4.0)
791
+
uring (version: v2.7.0)
792
+
uucp (version: 17.0.0)
793
+
uuseg (version: 17.0.0)
794
+
uuseg.string (version: 17.0.0)
795
+
uutf (version: 1.0.4)
796
+
xdg (version: 1.6.2-12057-g12f9ecb)
797
+
xmlm (version: 1.4.0)
798
+
yojson (version: 3.0.0)
799
+
zarith (version: 1.14)
800
+
zarith.top (version: 1.13)
801
+
zarith_stubs_js (version: v0.17.0))}
802
+
803
+
==============================================
804
+
SECTION 13: #labels and #principal
805
+
==============================================
806
+
807
+
$ unix_client exec_toplevel '' '# #labels true;;'
808
+
{mime_vals:[];parts:[];script:S(# #labels true;;)}
809
+
810
+
$ unix_client exec_toplevel '' '# #labels false;;'
811
+
{mime_vals:[];parts:[];script:S(# #labels false;;)}
812
+
813
+
$ unix_client exec_toplevel '' '# #principal true;;'
814
+
{mime_vals:[];parts:[];script:S(# #principal true;;)}
815
+
816
+
$ unix_client exec_toplevel '' '# #principal false;;'
817
+
{mime_vals:[];parts:[];script:S(# #principal false;;)}
818
+
819
+
==============================================
820
+
SECTION 14: Error Cases
821
+
==============================================
822
+
823
+
Unknown directive:
824
+
825
+
$ unix_client exec_toplevel '' '# #unknown_directive;;'
826
+
{mime_vals:[];parts:[];script:S(# #unknown_directive;;
827
+
Unknown directive unknown_directive.)}
828
+
829
+
#show with non-existent identifier:
830
+
831
+
$ unix_client exec_toplevel '' '# #show nonexistent_value;;'
832
+
{mime_vals:[];parts:[];script:S(# #show nonexistent_value;;
833
+
Unknown element.)}
834
+
835
+
#require non-existent package:
836
+
837
+
$ unix_client exec_toplevel '' '# #require "nonexistent_package_12345";;'
838
+
{mime_vals:[];parts:[];script:S(# #require "nonexistent_package_12345";;
839
+
No such package: nonexistent_package_12345)}
840
+
841
+
#use non-existent file:
842
+
843
+
$ unix_client exec_toplevel '' '# #use "/nonexistent/file.ml";;'
844
+
{mime_vals:[];parts:[];script:S(# #use "/nonexistent/file.ml";;
845
+
Cannot find file /nonexistent/file.ml.)}
846
+
847
+
==============================================
848
+
SECTION 15: #load (bytecode loading)
849
+
==============================================
850
+
851
+
Note: #load may not work in js_of_ocaml context
852
+
853
+
$ unix_client exec_toplevel '' '# #load "str.cma";;'
854
+
{mime_vals:[];parts:[];script:S(# #load "str.cma";;)}
855
+
856
+
==============================================
857
+
SECTION 16: Classes (#show_class)
858
+
==============================================
859
+
860
+
$ unix_client exec_toplevel '' '# class counter = object val mutable n = 0 method incr = n <- n + 1 method get = n end;;'
861
+
{mime_vals:[];parts:[];script:S(# class counter = object val mutable n = 0 method incr = n <- n + 1 method get = n end;;
862
+
class counter :
863
+
object val mutable n : int method get : int method incr : unit end)}
864
+
865
+
$ unix_client exec_toplevel '' '# #show_class counter;;'
866
+
{mime_vals:[];parts:[];script:S(# #show_class counter;;
867
+
class counter :
868
+
object val mutable n : int method get : int method incr : unit end)}
869
+
870
+
==============================================
871
+
Cleanup
872
+
==============================================
873
+
874
+
$ kill $WORKER_PID 2>/dev/null || true
875
+
$ rm -f "$JS_TOP_WORKER_SOCK"
+2
js_top_worker/test/cram/dune
+2
js_top_worker/test/cram/dune
+17
js_top_worker/test/cram/simple.t/run.t
+17
js_top_worker/test/cram/simple.t/run.t
···
1
+
$ ./script.sh
2
+
N
3
+
{mime_vals:[];stderr:S(error while evaluating #enable "pretty";;
4
+
error while evaluating #disable "shortvar";;);stdout:S(OCaml version 5.4.0
5
+
Unknown directive enable.
6
+
Unknown directive disable.)}
7
+
{mime_vals:[];parts:[];script:S(# Printf.printf "Hello, world\n";;
8
+
Hello, world
9
+
- : unit = ())}
10
+
{mime_vals:[];parts:[];script:S(# let x = 1 + 2;;
11
+
val x : int = 3
12
+
# let x = 2+3;;
13
+
val x : int = 5)}
14
+
{mime_vals:[];parts:[];script:S(# let x = 1 + 2;;
15
+
val x : int = 3
16
+
# let x = 2+3;;
17
+
val x : int = 5)}
+4
js_top_worker/test/cram/simple.t/s1
+4
js_top_worker/test/cram/simple.t/s1
+4
js_top_worker/test/cram/simple.t/s2
+4
js_top_worker/test/cram/simple.t/s2
+21
js_top_worker/test/cram/simple.t/script.sh
+21
js_top_worker/test/cram/simple.t/script.sh
···
1
+
#!/bin/bash
2
+
3
+
export OCAMLRUNPARAM=b
4
+
export JS_TOP_WORKER_SOCK="/tmp/js_top_worker_simple_$$.sock"
5
+
6
+
cleanup() {
7
+
[ -n "$WORKER_PID" ] && kill "$WORKER_PID" 2>/dev/null
8
+
rm -f "$JS_TOP_WORKER_SOCK"
9
+
}
10
+
trap cleanup EXIT
11
+
12
+
rm -f "$JS_TOP_WORKER_SOCK"
13
+
14
+
# Worker prints child PID and only returns once ready
15
+
WORKER_PID=$(unix_worker)
16
+
17
+
unix_client init '{ findlib_requires:[], execute: true }'
18
+
unix_client setup ''
19
+
unix_client exec_toplevel '' '# Printf.printf "Hello, world\n";;'
20
+
unix_client exec_toplevel '' "$(cat s1)"
21
+
unix_client exec_toplevel '' "$(cat s2)"
+10
js_top_worker/test/cram/start_worker.sh
+10
js_top_worker/test/cram/start_worker.sh
+7
js_top_worker/test/libtest/dune
+7
js_top_worker/test/libtest/dune
+132
js_top_worker/test/libtest/parse_test.ml
+132
js_top_worker/test/libtest/parse_test.ml
···
1
+
let triple f1 f2 f3 ppf (v1, v2, v3) =
2
+
Format.fprintf ppf "(%a,%a,%a)" f1 v1 f2 v2 f3 v3
3
+
4
+
let fmt = Fmt.Dump.(list (triple string string (list string)))
5
+
let print phr = Format.printf "%a" fmt phr
6
+
7
+
let check phrase =
8
+
let output = snd (Js_top_worker.Impl.mangle_toplevel true phrase []) in
9
+
print_endline "input:";
10
+
Printf.printf "{|%s|}\n" phrase;
11
+
print_endline "output:";
12
+
Printf.printf "{|%s|}\n" output;
13
+
let output_mapped = String.map (fun c -> if c = ' ' then '.' else c) output in
14
+
print_endline "output mapped:";
15
+
Printf.printf "{|%s|}\n" output_mapped
16
+
17
+
let%expect_test _ =
18
+
check "# foo;; junk\n bar\n# baz;;\n moo\n# unterminated;; foo\n";
19
+
[%expect
20
+
{xxx|
21
+
input:
22
+
{|# foo;; junk
23
+
bar
24
+
# baz;;
25
+
moo
26
+
# unterminated;; foo
27
+
|}
28
+
output:
29
+
{| foo;;
30
+
31
+
baz;;
32
+
33
+
unterminated;;
34
+
|}
35
+
output mapped:
36
+
{|..foo;;.....
37
+
.....
38
+
..baz;;
39
+
.....
40
+
..unterminated;;....
41
+
|}
42
+
|xxx}]
43
+
44
+
let%expect_test _ =
45
+
check "# 1+2;;\n- 3 : int\n \n";
46
+
[%expect
47
+
{xxx|
48
+
input:
49
+
{|# 1+2;;
50
+
- 3 : int
51
+
52
+
|}
53
+
output:
54
+
{| 1+2;;
55
+
56
+
57
+
|}
58
+
output mapped:
59
+
{|..1+2;;
60
+
.........
61
+
..
62
+
|}
63
+
|xxx}]
64
+
65
+
let%expect_test _ =
66
+
check "# 1+2;;";
67
+
[%expect
68
+
{xxx|
69
+
input:
70
+
{|# 1+2;;|}
71
+
output:
72
+
{| 1+2;;|}
73
+
output mapped:
74
+
{|..1+2;;|}
75
+
|xxx}]
76
+
77
+
let%expect_test _ =
78
+
check "# 1+2;;\nx\n";
79
+
[%expect
80
+
{xxx|
81
+
input:
82
+
{|# 1+2;;
83
+
x
84
+
|}
85
+
output:
86
+
{| 1+2;;
87
+
88
+
|}
89
+
output mapped:
90
+
{|..1+2;;
91
+
.
92
+
|}
93
+
|xxx}]
94
+
95
+
let%expect_test _ =
96
+
check "# let ;;\n foo";
97
+
[%expect
98
+
" \n\
99
+
\ fallback parser\n\
100
+
\ Got phrase\n\
101
+
\ input:\n\
102
+
\ {|# let ;;\n\
103
+
\ foo|}\n\
104
+
\ output:\n\
105
+
\ {| let ;;\n\
106
+
\ |}\n\
107
+
\ output mapped:\n\
108
+
\ {|..let.;;\n\
109
+
\ .....|}\n\
110
+
\ "]
111
+
112
+
let%expect_test _ =
113
+
check "# let x=1;;\n foo\n\n# let y=2;;\n bar\n\n";
114
+
[%expect
115
+
" \n\
116
+
\ input:\n\
117
+
\ {|# let x=1;;\n\
118
+
\ foo\n\n\
119
+
\ # let y=2;;\n\
120
+
\ bar\n\n\
121
+
\ |}\n\
122
+
\ output:\n\
123
+
\ {| let x=1;;\n\n\n\
124
+
\ let y=2;;\n\n\n\
125
+
\ |}\n\
126
+
\ output mapped:\n\
127
+
\ {|..let.x=1;;\n\
128
+
\ .....\n\n\
129
+
\ ..let.y=2;;\n\
130
+
\ .....\n\n\
131
+
\ |}\n\
132
+
\ "]
+417
js_top_worker/test/node/dune
+417
js_top_worker/test/node/dune
···
1
+
(executable
2
+
(name node_test)
3
+
(modes byte)
4
+
(modules node_test)
5
+
(link_flags (-linkall))
6
+
(libraries
7
+
fpath
8
+
js_of_ocaml
9
+
js_top_worker-web
10
+
js_of_ocaml-toplevel
11
+
js_top_worker
12
+
logs
13
+
logs.fmt
14
+
rpclib.core
15
+
rpclib.json
16
+
findlib.top
17
+
js_of_ocaml-lwt
18
+
zarith_stubs_js))
19
+
20
+
(rule
21
+
(targets node_test.js)
22
+
(action
23
+
(run
24
+
%{bin:js_of_ocaml}
25
+
--toplevel
26
+
--pretty
27
+
--no-cmis
28
+
--effects=cps
29
+
--debuginfo
30
+
--target-env=nodejs
31
+
+toplevel.js
32
+
+dynlink.js
33
+
+bigstringaf/runtime.js
34
+
+zarith_stubs_js/runtime.js
35
+
%{lib:js_top_worker:stubs.js}
36
+
%{dep:node_test.bc}
37
+
-o
38
+
%{targets})))
39
+
40
+
(rule
41
+
(targets
42
+
(dir _opam))
43
+
(action
44
+
(run jtw opam base ppx_deriving.show ppx_deriving.eq ppx_deriving.runtime --no-worker -o _opam)))
45
+
46
+
(rule
47
+
(deps _opam)
48
+
(action
49
+
(with-outputs-to
50
+
node_test.out
51
+
(run
52
+
node
53
+
--stack-size=2000
54
+
-r
55
+
./%{dep:import_scripts.js}
56
+
%{dep:node_test.js}))))
57
+
58
+
(rule
59
+
(alias runtest)
60
+
(deps _opam)
61
+
(action
62
+
(diff node_test.expected node_test.out)))
63
+
64
+
; Directive test executable
65
+
(executable
66
+
(name node_directive_test)
67
+
(modes byte)
68
+
(modules node_directive_test)
69
+
(link_flags (-linkall))
70
+
(libraries
71
+
str
72
+
fpath
73
+
js_of_ocaml
74
+
js_top_worker-web
75
+
js_of_ocaml-toplevel
76
+
js_top_worker
77
+
logs
78
+
logs.fmt
79
+
rpclib.core
80
+
rpclib.json
81
+
findlib.top
82
+
js_of_ocaml-lwt
83
+
zarith_stubs_js))
84
+
85
+
(rule
86
+
(targets node_directive_test.js)
87
+
(action
88
+
(run
89
+
%{bin:js_of_ocaml}
90
+
--toplevel
91
+
--pretty
92
+
--no-cmis
93
+
--effects=cps
94
+
--debuginfo
95
+
--target-env=nodejs
96
+
+toplevel.js
97
+
+dynlink.js
98
+
+bigstringaf/runtime.js
99
+
+zarith_stubs_js/runtime.js
100
+
%{lib:js_top_worker:stubs.js}
101
+
%{dep:node_directive_test.bc}
102
+
-o
103
+
%{targets})))
104
+
105
+
(rule
106
+
(deps _opam)
107
+
(action
108
+
(with-outputs-to
109
+
node_directive_test.out
110
+
(run
111
+
node
112
+
--stack-size=2000
113
+
-r
114
+
./%{dep:import_scripts.js}
115
+
%{dep:node_directive_test.js}))))
116
+
117
+
(rule
118
+
(alias runtest)
119
+
(deps _opam)
120
+
(action
121
+
(diff node_directive_test.expected node_directive_test.out)))
122
+
123
+
; PPX test executable
124
+
; Note: ppx_deriving is NOT statically linked - it's dynamically loaded via #require
125
+
(executable
126
+
(name node_ppx_test)
127
+
(modes byte)
128
+
(modules node_ppx_test)
129
+
(link_flags (-linkall))
130
+
(libraries
131
+
str
132
+
fpath
133
+
js_of_ocaml
134
+
js_top_worker-web
135
+
js_of_ocaml-toplevel
136
+
js_top_worker
137
+
logs
138
+
logs.fmt
139
+
rpclib.core
140
+
rpclib.json
141
+
findlib.top
142
+
js_of_ocaml-lwt
143
+
zarith_stubs_js))
144
+
145
+
(rule
146
+
(targets node_ppx_test.js)
147
+
(action
148
+
(run
149
+
%{bin:js_of_ocaml}
150
+
--toplevel
151
+
--pretty
152
+
--no-cmis
153
+
--effects=cps
154
+
--debuginfo
155
+
--target-env=nodejs
156
+
+toplevel.js
157
+
+dynlink.js
158
+
+bigstringaf/runtime.js
159
+
+zarith_stubs_js/runtime.js
160
+
%{lib:js_top_worker:stubs.js}
161
+
%{dep:node_ppx_test.bc}
162
+
-o
163
+
%{targets})))
164
+
165
+
(rule
166
+
(deps _opam)
167
+
(action
168
+
(with-outputs-to
169
+
node_ppx_test.out
170
+
(run
171
+
node
172
+
--stack-size=2000
173
+
-r
174
+
./%{dep:import_scripts.js}
175
+
%{dep:node_ppx_test.js}))))
176
+
177
+
(rule
178
+
(alias runtest)
179
+
(deps _opam)
180
+
(action
181
+
(diff node_ppx_test.expected node_ppx_test.out)))
182
+
183
+
; Environment test executable
184
+
(executable
185
+
(name node_env_test)
186
+
(modes byte)
187
+
(modules node_env_test)
188
+
(link_flags (-linkall))
189
+
(libraries
190
+
str
191
+
fpath
192
+
js_of_ocaml
193
+
js_top_worker-web
194
+
js_of_ocaml-toplevel
195
+
js_top_worker
196
+
logs
197
+
logs.fmt
198
+
rpclib.core
199
+
rpclib.json
200
+
findlib.top
201
+
js_of_ocaml-lwt
202
+
zarith_stubs_js))
203
+
204
+
(rule
205
+
(targets node_env_test.js)
206
+
(action
207
+
(run
208
+
%{bin:js_of_ocaml}
209
+
--toplevel
210
+
--pretty
211
+
--no-cmis
212
+
--effects=cps
213
+
--debuginfo
214
+
--target-env=nodejs
215
+
+toplevel.js
216
+
+dynlink.js
217
+
+bigstringaf/runtime.js
218
+
+zarith_stubs_js/runtime.js
219
+
%{lib:js_top_worker:stubs.js}
220
+
%{dep:node_env_test.bc}
221
+
-o
222
+
%{targets})))
223
+
224
+
(rule
225
+
(deps _opam)
226
+
(action
227
+
(with-outputs-to
228
+
node_env_test.out
229
+
(run
230
+
node
231
+
--stack-size=2000
232
+
-r
233
+
./%{dep:import_scripts.js}
234
+
%{dep:node_env_test.js}))))
235
+
236
+
(rule
237
+
(alias runtest)
238
+
(deps _opam)
239
+
(action
240
+
(diff node_env_test.expected node_env_test.out)))
241
+
242
+
; MIME output test executable
243
+
(executable
244
+
(name node_mime_test)
245
+
(modes byte)
246
+
(modules node_mime_test)
247
+
(link_flags (-linkall))
248
+
(libraries
249
+
str
250
+
fpath
251
+
js_of_ocaml
252
+
js_top_worker-web
253
+
js_of_ocaml-toplevel
254
+
js_top_worker
255
+
logs
256
+
logs.fmt
257
+
rpclib.core
258
+
rpclib.json
259
+
findlib.top
260
+
js_of_ocaml-lwt
261
+
zarith_stubs_js))
262
+
263
+
(rule
264
+
(targets node_mime_test.js)
265
+
(action
266
+
(run
267
+
%{bin:js_of_ocaml}
268
+
--toplevel
269
+
--pretty
270
+
--no-cmis
271
+
--effects=cps
272
+
--debuginfo
273
+
--target-env=nodejs
274
+
+toplevel.js
275
+
+dynlink.js
276
+
+bigstringaf/runtime.js
277
+
+zarith_stubs_js/runtime.js
278
+
%{lib:js_top_worker:stubs.js}
279
+
%{dep:node_mime_test.bc}
280
+
-o
281
+
%{targets})))
282
+
283
+
(rule
284
+
(deps _opam)
285
+
(action
286
+
(with-outputs-to
287
+
node_mime_test.out
288
+
(run
289
+
node
290
+
--stack-size=2000
291
+
-r
292
+
./%{dep:import_scripts.js}
293
+
%{dep:node_mime_test.js}))))
294
+
295
+
(rule
296
+
(alias runtest)
297
+
(deps _opam)
298
+
(action
299
+
(diff node_mime_test.expected node_mime_test.out)))
300
+
301
+
; Cell dependency test executable
302
+
(executable
303
+
(name node_dependency_test)
304
+
(modes byte)
305
+
(modules node_dependency_test)
306
+
(link_flags (-linkall))
307
+
(libraries
308
+
str
309
+
fpath
310
+
js_of_ocaml
311
+
js_top_worker-web
312
+
js_of_ocaml-toplevel
313
+
js_top_worker
314
+
logs
315
+
logs.fmt
316
+
rpclib.core
317
+
rpclib.json
318
+
findlib.top
319
+
js_of_ocaml-lwt
320
+
zarith_stubs_js))
321
+
322
+
(rule
323
+
(targets node_dependency_test.js)
324
+
(action
325
+
(run
326
+
%{bin:js_of_ocaml}
327
+
--toplevel
328
+
--pretty
329
+
--no-cmis
330
+
--effects=cps
331
+
--debuginfo
332
+
--target-env=nodejs
333
+
+toplevel.js
334
+
+dynlink.js
335
+
+bigstringaf/runtime.js
336
+
+zarith_stubs_js/runtime.js
337
+
%{lib:js_top_worker:stubs.js}
338
+
%{dep:node_dependency_test.bc}
339
+
-o
340
+
%{targets})))
341
+
342
+
(rule
343
+
(deps _opam)
344
+
(action
345
+
(with-outputs-to
346
+
node_dependency_test.out
347
+
(run
348
+
node
349
+
--stack-size=2000
350
+
-r
351
+
./%{dep:import_scripts.js}
352
+
%{dep:node_dependency_test.js}))))
353
+
354
+
(rule
355
+
(alias runtest)
356
+
(deps _opam)
357
+
(action
358
+
(diff node_dependency_test.expected node_dependency_test.out)))
359
+
360
+
; Incremental output test executable
361
+
(executable
362
+
(name node_incremental_test)
363
+
(modes byte)
364
+
(modules node_incremental_test)
365
+
(link_flags (-linkall))
366
+
(libraries
367
+
str
368
+
fpath
369
+
js_of_ocaml
370
+
js_top_worker-web
371
+
js_of_ocaml-toplevel
372
+
js_top_worker
373
+
logs
374
+
logs.fmt
375
+
rpclib.core
376
+
rpclib.json
377
+
findlib.top
378
+
js_of_ocaml-lwt
379
+
zarith_stubs_js))
380
+
381
+
(rule
382
+
(targets node_incremental_test.js)
383
+
(action
384
+
(run
385
+
%{bin:js_of_ocaml}
386
+
--toplevel
387
+
--pretty
388
+
--no-cmis
389
+
--effects=cps
390
+
--debuginfo
391
+
--target-env=nodejs
392
+
+toplevel.js
393
+
+dynlink.js
394
+
+bigstringaf/runtime.js
395
+
+zarith_stubs_js/runtime.js
396
+
%{lib:js_top_worker:stubs.js}
397
+
%{dep:node_incremental_test.bc}
398
+
-o
399
+
%{targets})))
400
+
401
+
(rule
402
+
(deps _opam)
403
+
(action
404
+
(with-outputs-to
405
+
node_incremental_test.out
406
+
(run
407
+
node
408
+
--stack-size=2000
409
+
-r
410
+
./%{dep:import_scripts.js}
411
+
%{dep:node_incremental_test.js}))))
412
+
413
+
(rule
414
+
(alias runtest)
415
+
(deps _opam)
416
+
(action
417
+
(diff node_incremental_test.expected node_incremental_test.out)))
+19
js_top_worker/test/node/import_scripts.js
+19
js_top_worker/test/node/import_scripts.js
···
1
+
2
+
fs=require('fs');
3
+
vm=require('vm');// vm must be in the global context to work properly
4
+
5
+
6
+
function include(filename){
7
+
var code = fs.readFileSync(filename, 'utf-8');
8
+
vm.runInThisContext(code, filename);
9
+
}
10
+
11
+
function importScripts(filename){
12
+
console.log('importScripts: ' + filename);
13
+
filename='./_opam/'+filename;
14
+
include(filename);
15
+
}
16
+
17
+
global.importScripts=importScripts;
18
+
global.include=include;
19
+
+193
js_top_worker/test/node/node_dependency_test.expected
+193
js_top_worker/test/node/node_dependency_test.expected
···
1
+
=== Node.js Cell Dependency Tests ===
2
+
3
+
Initializing findlib
4
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
5
+
Parsed uri: ./lib/stdlib-shims/META
6
+
Reading library: stdlib-shims
7
+
Number of children: 0
8
+
Parsed uri: ./lib/sexplib0/META
9
+
Reading library: sexplib0
10
+
Number of children: 0
11
+
Parsed uri: ./lib/ppxlib/META
12
+
Reading library: ppxlib
13
+
Number of children: 11
14
+
Found child: __private__
15
+
Reading library: ppxlib.__private__
16
+
Number of children: 1
17
+
Found child: ppx_foo_deriver
18
+
Reading library: ppxlib.__private__.ppx_foo_deriver
19
+
Number of children: 0
20
+
Found child: ast
21
+
Reading library: ppxlib.ast
22
+
Number of children: 0
23
+
Found child: astlib
24
+
Reading library: ppxlib.astlib
25
+
Number of children: 0
26
+
Found child: metaquot
27
+
Reading library: ppxlib.metaquot
28
+
Number of children: 0
29
+
Found child: metaquot_lifters
30
+
Reading library: ppxlib.metaquot_lifters
31
+
Number of children: 0
32
+
Found child: print_diff
33
+
Reading library: ppxlib.print_diff
34
+
Number of children: 0
35
+
Found child: runner
36
+
Reading library: ppxlib.runner
37
+
Number of children: 0
38
+
Found child: runner_as_ppx
39
+
Reading library: ppxlib.runner_as_ppx
40
+
Number of children: 0
41
+
Found child: stdppx
42
+
Reading library: ppxlib.stdppx
43
+
Number of children: 0
44
+
Found child: traverse
45
+
Reading library: ppxlib.traverse
46
+
Number of children: 0
47
+
Found child: traverse_builtins
48
+
Reading library: ppxlib.traverse_builtins
49
+
Number of children: 0
50
+
Parsed uri: ./lib/ppx_deriving/META
51
+
Reading library: ppx_deriving
52
+
Number of children: 12
53
+
Found child: api
54
+
Reading library: ppx_deriving.api
55
+
Number of children: 0
56
+
Found child: create
57
+
Reading library: ppx_deriving.create
58
+
Number of children: 0
59
+
Found child: enum
60
+
Reading library: ppx_deriving.enum
61
+
Number of children: 0
62
+
Found child: eq
63
+
Reading library: ppx_deriving.eq
64
+
Number of children: 0
65
+
Found child: fold
66
+
Reading library: ppx_deriving.fold
67
+
Number of children: 0
68
+
Found child: iter
69
+
Reading library: ppx_deriving.iter
70
+
Number of children: 0
71
+
Found child: make
72
+
Reading library: ppx_deriving.make
73
+
Number of children: 0
74
+
Found child: map
75
+
Reading library: ppx_deriving.map
76
+
Number of children: 0
77
+
Found child: ord
78
+
Reading library: ppx_deriving.ord
79
+
Number of children: 0
80
+
Found child: runtime
81
+
Reading library: ppx_deriving.runtime
82
+
Number of children: 0
83
+
Found child: show
84
+
Reading library: ppx_deriving.show
85
+
Number of children: 0
86
+
Found child: std
87
+
Reading library: ppx_deriving.std
88
+
Number of children: 0
89
+
Parsed uri: ./lib/ppx_derivers/META
90
+
Reading library: ppx_derivers
91
+
Number of children: 0
92
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
93
+
Reading library: ocaml_intrinsics_kernel
94
+
Number of children: 0
95
+
Parsed uri: ./lib/ocaml/stdlib/META
96
+
Reading library: stdlib
97
+
Number of children: 0
98
+
Parsed uri: ./lib/ocaml/compiler-libs/META
99
+
Reading library: compiler-libs
100
+
Number of children: 5
101
+
Found child: common
102
+
Reading library: compiler-libs.common
103
+
Number of children: 0
104
+
Found child: bytecomp
105
+
Reading library: compiler-libs.bytecomp
106
+
Number of children: 0
107
+
Found child: optcomp
108
+
Reading library: compiler-libs.optcomp
109
+
Number of children: 0
110
+
Found child: toplevel
111
+
Reading library: compiler-libs.toplevel
112
+
Number of children: 0
113
+
Found child: native-toplevel
114
+
Reading library: compiler-libs.native-toplevel
115
+
Number of children: 0
116
+
Parsed uri: ./lib/ocaml-compiler-libs/META
117
+
Reading library: ocaml-compiler-libs
118
+
Number of children: 5
119
+
Found child: bytecomp
120
+
Reading library: ocaml-compiler-libs.bytecomp
121
+
Number of children: 0
122
+
Found child: common
123
+
Reading library: ocaml-compiler-libs.common
124
+
Number of children: 0
125
+
Found child: optcomp
126
+
Reading library: ocaml-compiler-libs.optcomp
127
+
Number of children: 0
128
+
Found child: shadow
129
+
Reading library: ocaml-compiler-libs.shadow
130
+
Number of children: 0
131
+
Found child: toplevel
132
+
Reading library: ocaml-compiler-libs.toplevel
133
+
Number of children: 0
134
+
Parsed uri: ./lib/base/META
135
+
Reading library: base
136
+
Number of children: 3
137
+
Found child: base_internalhash_types
138
+
Reading library: base.base_internalhash_types
139
+
Number of children: 0
140
+
Found child: md5
141
+
Reading library: base.md5
142
+
Number of children: 0
143
+
Found child: shadow_stdlib
144
+
Reading library: base.shadow_stdlib
145
+
Number of children: 0
146
+
error while evaluating #enable "pretty";;
147
+
error while evaluating #disable "shortvar";;
148
+
[PASS] init: Initialized and setup
149
+
150
+
--- Section 1: Linear Dependencies ---
151
+
[PASS] linear_c1: 0 errors
152
+
[PASS] linear_c2: 0 errors
153
+
[PASS] linear_c3: 0 errors
154
+
[PASS] linear_c4: 0 errors
155
+
156
+
--- Section 2: Diamond Dependencies ---
157
+
[PASS] diamond_d1: 0 errors
158
+
[PASS] diamond_d2: 0 errors
159
+
[PASS] diamond_d3: 0 errors
160
+
[PASS] diamond_d4: 0 errors
161
+
162
+
--- Section 3: Missing Dependencies ---
163
+
[PASS] missing_dep_error: 2 errors (expected > 0)
164
+
node_dependency_test.js: [ERROR] Env.Error: File "_none_", line 1:
165
+
Error: Unbound module Cell__nonexistent
166
+
167
+
[PASS] missing_dep_simple_ok: 0 errors
168
+
169
+
--- Section 4: Dependency Update Propagation ---
170
+
[PASS] update_u1_initial: 0 errors
171
+
[PASS] update_u2_initial: 0 errors
172
+
[PASS] update_u1_changed: 0 errors
173
+
[PASS] update_u2_error: 1 errors (expected > 0)
174
+
[PASS] update_u2_fixed: 0 errors
175
+
176
+
--- Section 5: Type Shadowing ---
177
+
[PASS] shadow_s1: 0 errors
178
+
[PASS] shadow_s2: 0 errors
179
+
[PASS] shadow_s3_string: 0 errors
180
+
[PASS] shadow_s4_int: 0 errors
181
+
182
+
--- Section 6: Complex Dependency Graph ---
183
+
[PASS] graph_g1: 0 errors
184
+
[PASS] graph_g2: 0 errors
185
+
[PASS] graph_g3: 0 errors
186
+
[PASS] graph_g4: 0 errors
187
+
188
+
--- Section 7: Empty and Self Dependencies ---
189
+
[PASS] empty_deps: 0 errors
190
+
[PASS] self_define: 0 errors
191
+
192
+
=== Results: 26/26 tests passed ===
193
+
SUCCESS: All dependency tests passed!
+328
js_top_worker/test/node/node_dependency_test.ml
+328
js_top_worker/test/node/node_dependency_test.ml
···
1
+
(** Node.js test for cell dependency system.
2
+
3
+
This tests that cell dependencies work correctly, including:
4
+
- Linear dependencies (c1 → c2 → c3)
5
+
- Diamond dependencies (c1 → c2, c3 → c4)
6
+
- Missing dependencies (referencing non-existent cell)
7
+
- Dependency update propagation
8
+
- Type shadowing across cells
9
+
*)
10
+
11
+
open Js_top_worker
12
+
open Js_top_worker_rpc.Toplevel_api_gen
13
+
open Impl
14
+
15
+
(* Flusher that writes to process.stdout in Node.js *)
16
+
let console_flusher (s : string) : unit =
17
+
let open Js_of_ocaml in
18
+
let process = Js.Unsafe.get Js.Unsafe.global (Js.string "process") in
19
+
let stdout = Js.Unsafe.get process (Js.string "stdout") in
20
+
let write = Js.Unsafe.get stdout (Js.string "write") in
21
+
ignore (Js.Unsafe.call write stdout [| Js.Unsafe.inject (Js.string s) |])
22
+
23
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
24
+
fun f () ->
25
+
let stdout_buff = Buffer.create 1024 in
26
+
let stderr_buff = Buffer.create 1024 in
27
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
28
+
let x = f () in
29
+
let captured =
30
+
{
31
+
Impl.stdout = Buffer.contents stdout_buff;
32
+
stderr = Buffer.contents stderr_buff;
33
+
}
34
+
in
35
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
36
+
(captured, x)
37
+
38
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
39
+
40
+
module S : Impl.S = struct
41
+
type findlib_t = Js_top_worker_web.Findlibish.t
42
+
43
+
let capture = capture
44
+
45
+
let sync_get f =
46
+
let f = Fpath.v ("_opam/" ^ f) in
47
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
48
+
with _ -> None
49
+
50
+
let async_get f =
51
+
let f = Fpath.v ("_opam/" ^ f) in
52
+
try
53
+
let content =
54
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
55
+
in
56
+
Lwt.return (Ok content)
57
+
with e -> Lwt.return (Error (`Msg (Printexc.to_string e)))
58
+
59
+
let create_file = Js_of_ocaml.Sys_js.create_file
60
+
61
+
let import_scripts urls =
62
+
let open Js_of_ocaml.Js in
63
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
64
+
List.iter
65
+
(fun url ->
66
+
let (_ : 'a) =
67
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
68
+
in
69
+
())
70
+
urls
71
+
72
+
let init_function _ () = failwith "Not implemented"
73
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
74
+
75
+
let get_stdlib_dcs uri =
76
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
77
+
|> Result.to_list
78
+
79
+
let require b v = function
80
+
| [] -> []
81
+
| packages ->
82
+
Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v
83
+
packages
84
+
85
+
let path = "/static/cmis"
86
+
end
87
+
88
+
module U = Impl.Make (S)
89
+
90
+
let start_server () =
91
+
let open U in
92
+
Logs.set_reporter (Logs_fmt.reporter ());
93
+
Logs.set_level (Some Logs.Warning);
94
+
Server.init (IdlM.T.lift init);
95
+
Server.create_env (IdlM.T.lift create_env);
96
+
Server.destroy_env (IdlM.T.lift destroy_env);
97
+
Server.list_envs (IdlM.T.lift list_envs);
98
+
Server.setup (IdlM.T.lift setup);
99
+
Server.exec execute;
100
+
Server.complete_prefix complete_prefix;
101
+
Server.query_errors query_errors;
102
+
Server.type_enclosing type_enclosing;
103
+
Server.exec_toplevel exec_toplevel;
104
+
IdlM.server Server.implementation
105
+
106
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
107
+
108
+
(* Test result tracking *)
109
+
let total_tests = ref 0
110
+
let passed_tests = ref 0
111
+
112
+
let test name check message =
113
+
incr total_tests;
114
+
let passed = check in
115
+
if passed then incr passed_tests;
116
+
let status = if passed then "PASS" else "FAIL" in
117
+
Printf.printf "[%s] %s: %s\n%!" status name message
118
+
119
+
let query_errors rpc env_id cell_id deps source =
120
+
Client.query_errors rpc env_id cell_id deps false source
121
+
122
+
let _ =
123
+
Printf.printf "=== Node.js Cell Dependency Tests ===\n\n%!";
124
+
125
+
let rpc = start_server () in
126
+
let ( let* ) = IdlM.ErrM.bind in
127
+
128
+
let init_config =
129
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
130
+
in
131
+
132
+
let test_sequence =
133
+
(* Initialize and setup *)
134
+
let* _ = Client.init rpc init_config in
135
+
let* _ = Client.setup rpc "" in
136
+
test "init" true "Initialized and setup";
137
+
138
+
Printf.printf "\n--- Section 1: Linear Dependencies ---\n%!";
139
+
140
+
(* c1: base definition *)
141
+
let* errors = query_errors rpc "" (Some "c1") [] "type t = int;;" in
142
+
test "linear_c1" (List.length errors = 0)
143
+
(Printf.sprintf "%d errors" (List.length errors));
144
+
145
+
(* c2 depends on c1 *)
146
+
let* errors = query_errors rpc "" (Some "c2") ["c1"] "let x : t = 42;;" in
147
+
test "linear_c2" (List.length errors = 0)
148
+
(Printf.sprintf "%d errors" (List.length errors));
149
+
150
+
(* c3 depends on c2 (and transitively c1) *)
151
+
let* errors = query_errors rpc "" (Some "c3") ["c2"] "let y = x + 1;;" in
152
+
test "linear_c3" (List.length errors = 0)
153
+
(Printf.sprintf "%d errors" (List.length errors));
154
+
155
+
(* c4 depends on c3 *)
156
+
let* errors = query_errors rpc "" (Some "c4") ["c3"] "let z = y * 2;;" in
157
+
test "linear_c4" (List.length errors = 0)
158
+
(Printf.sprintf "%d errors" (List.length errors));
159
+
160
+
Printf.printf "\n--- Section 2: Diamond Dependencies ---\n%!";
161
+
162
+
(* d1: base type *)
163
+
let* errors = query_errors rpc "" (Some "d1") []
164
+
"type point = { x: int; y: int };;" in
165
+
test "diamond_d1" (List.length errors = 0)
166
+
(Printf.sprintf "%d errors" (List.length errors));
167
+
168
+
(* d2 depends on d1 *)
169
+
let* errors = query_errors rpc "" (Some "d2") ["d1"]
170
+
"let origin : point = { x = 0; y = 0 };;" in
171
+
test "diamond_d2" (List.length errors = 0)
172
+
(Printf.sprintf "%d errors" (List.length errors));
173
+
174
+
(* d3 depends on d1 (parallel to d2) *)
175
+
let* errors = query_errors rpc "" (Some "d3") ["d1"]
176
+
"let unit_x : point = { x = 1; y = 0 };;" in
177
+
test "diamond_d3" (List.length errors = 0)
178
+
(Printf.sprintf "%d errors" (List.length errors));
179
+
180
+
(* d4 depends on d2, d3, and transitively needs d1 for the point type *)
181
+
let* errors = query_errors rpc "" (Some "d4") ["d1"; "d2"; "d3"]
182
+
"let add p1 p2 : point = { x = p1.x + p2.x; y = p1.y + p2.y };;\n\
183
+
let result = add origin unit_x;;" in
184
+
test "diamond_d4" (List.length errors = 0)
185
+
(Printf.sprintf "%d errors" (List.length errors));
186
+
187
+
Printf.printf "\n--- Section 3: Missing Dependencies ---\n%!";
188
+
189
+
(* Try to use a type from a cell that doesn't exist in deps *)
190
+
let* errors = query_errors rpc "" (Some "m1") []
191
+
"let bad : point = { x = 1; y = 2 };;" in
192
+
test "missing_dep_error" (List.length errors > 0)
193
+
(Printf.sprintf "%d errors (expected > 0)" (List.length errors));
194
+
195
+
(* Reference with missing dependency - should fail *)
196
+
let* errors = query_errors rpc "" (Some "m2") ["nonexistent"]
197
+
"let a = 1;;" in
198
+
(* Even with a missing dep in the list, simple code should work *)
199
+
test "missing_dep_simple_ok" (List.length errors = 0)
200
+
(Printf.sprintf "%d errors" (List.length errors));
201
+
202
+
Printf.printf "\n--- Section 4: Dependency Update Propagation ---\n%!";
203
+
204
+
(* u1: initial type *)
205
+
let* errors = query_errors rpc "" (Some "u1") [] "type u = int;;" in
206
+
test "update_u1_initial" (List.length errors = 0)
207
+
(Printf.sprintf "%d errors" (List.length errors));
208
+
209
+
(* u2: depends on u1, uses type u as int *)
210
+
let* errors = query_errors rpc "" (Some "u2") ["u1"] "let val_u : u = 42;;" in
211
+
test "update_u2_initial" (List.length errors = 0)
212
+
(Printf.sprintf "%d errors" (List.length errors));
213
+
214
+
(* Now update u1 to change type u to string *)
215
+
let* errors = query_errors rpc "" (Some "u1") [] "type u = string;;" in
216
+
test "update_u1_changed" (List.length errors = 0)
217
+
(Printf.sprintf "%d errors" (List.length errors));
218
+
219
+
(* u2 with same code should now error (42 is not string) *)
220
+
let* errors = query_errors rpc "" (Some "u2") ["u1"] "let val_u : u = 42;;" in
221
+
test "update_u2_error" (List.length errors > 0)
222
+
(Printf.sprintf "%d errors (expected > 0)" (List.length errors));
223
+
224
+
(* Fix u2 to work with string type *)
225
+
let* errors = query_errors rpc "" (Some "u2") ["u1"]
226
+
"let val_u : u = \"hello\";;" in
227
+
test "update_u2_fixed" (List.length errors = 0)
228
+
(Printf.sprintf "%d errors" (List.length errors));
229
+
230
+
Printf.printf "\n--- Section 5: Type Shadowing ---\n%!";
231
+
232
+
(* s1: defines type t = int *)
233
+
let* errors = query_errors rpc "" (Some "s1") [] "type t = int;;" in
234
+
test "shadow_s1" (List.length errors = 0)
235
+
(Printf.sprintf "%d errors" (List.length errors));
236
+
237
+
(* s2: depends on s1, also defines type t = string (shadows) *)
238
+
let* errors = query_errors rpc "" (Some "s2") ["s1"]
239
+
"type t = string;;" in
240
+
test "shadow_s2" (List.length errors = 0)
241
+
(Printf.sprintf "%d errors" (List.length errors));
242
+
243
+
(* s3: depends on s2 - should see t as string, not int *)
244
+
let* errors = query_errors rpc "" (Some "s3") ["s2"]
245
+
"let shadowed : t = \"works\";;" in
246
+
test "shadow_s3_string" (List.length errors = 0)
247
+
(Printf.sprintf "%d errors" (List.length errors));
248
+
249
+
(* s4: depends only on s1 - should see t as int *)
250
+
let* errors = query_errors rpc "" (Some "s4") ["s1"]
251
+
"let original : t = 123;;" in
252
+
test "shadow_s4_int" (List.length errors = 0)
253
+
(Printf.sprintf "%d errors" (List.length errors));
254
+
255
+
Printf.printf "\n--- Section 6: Complex Dependency Graph ---\n%!";
256
+
257
+
(*
258
+
g1 ─┬─→ g2 ───→ g4
259
+
│ │
260
+
└─→ g3 ─────┘
261
+
262
+
g1 defines base
263
+
g2 and g3 both depend on g1
264
+
g4 depends on g2 and g3
265
+
*)
266
+
267
+
let* errors = query_errors rpc "" (Some "g1") []
268
+
"module Base = struct\n\
269
+
\ type id = int\n\
270
+
\ let make_id x = x\n\
271
+
end;;" in
272
+
test "graph_g1" (List.length errors = 0)
273
+
(Printf.sprintf "%d errors" (List.length errors));
274
+
275
+
let* errors = query_errors rpc "" (Some "g2") ["g1"]
276
+
"module User = struct\n\
277
+
\ type t = { id: Base.id; name: string }\n\
278
+
\ let create id name = { id; name }\n\
279
+
end;;" in
280
+
test "graph_g2" (List.length errors = 0)
281
+
(Printf.sprintf "%d errors" (List.length errors));
282
+
283
+
let* errors = query_errors rpc "" (Some "g3") ["g1"]
284
+
"module Item = struct\n\
285
+
\ type t = { id: Base.id; value: int }\n\
286
+
\ let create id value = { id; value }\n\
287
+
end;;" in
288
+
test "graph_g3" (List.length errors = 0)
289
+
(Printf.sprintf "%d errors" (List.length errors));
290
+
291
+
(* g4 needs g1 for Base module, plus g2 and g3 *)
292
+
let* errors = query_errors rpc "" (Some "g4") ["g1"; "g2"; "g3"]
293
+
"let user = User.create (Base.make_id 1) \"Alice\";;\n\
294
+
let item = Item.create (Base.make_id 100) 42;;" in
295
+
test "graph_g4" (List.length errors = 0)
296
+
(Printf.sprintf "%d errors" (List.length errors));
297
+
298
+
Printf.printf "\n--- Section 7: Empty and Self Dependencies ---\n%!";
299
+
300
+
(* Cell with no deps *)
301
+
let* errors = query_errors rpc "" (Some "e1") []
302
+
"let standalone = 999;;" in
303
+
test "empty_deps" (List.length errors = 0)
304
+
(Printf.sprintf "%d errors" (List.length errors));
305
+
306
+
(* Cell that tries to reference itself should fail or have errors *)
307
+
let* errors = query_errors rpc "" (Some "self") []
308
+
"let self_ref = 1;;" in
309
+
test "self_define" (List.length errors = 0)
310
+
(Printf.sprintf "%d errors" (List.length errors));
311
+
312
+
IdlM.ErrM.return ()
313
+
in
314
+
315
+
let promise = test_sequence |> IdlM.T.get in
316
+
(match Lwt.state promise with
317
+
| Lwt.Return (Ok ()) -> ()
318
+
| Lwt.Return (Error (InternalError s)) ->
319
+
Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
320
+
| Lwt.Fail e ->
321
+
Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
322
+
| Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
323
+
324
+
Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
325
+
!total_tests;
326
+
if !passed_tests = !total_tests then
327
+
Printf.printf "SUCCESS: All dependency tests passed!\n%!"
328
+
else Printf.printf "FAILURE: Some tests failed.\n%!"
+328
js_top_worker/test/node/node_directive_test.expected
+328
js_top_worker/test/node/node_directive_test.expected
···
1
+
=== Node.js Directive Tests ===
2
+
3
+
node_directive_test.js: [INFO] init()
4
+
Initializing findlib
5
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
6
+
Parsed uri: ./lib/stdlib-shims/META
7
+
Reading library: stdlib-shims
8
+
Number of children: 0
9
+
Parsed uri: ./lib/sexplib0/META
10
+
Reading library: sexplib0
11
+
Number of children: 0
12
+
Parsed uri: ./lib/ppxlib/META
13
+
Reading library: ppxlib
14
+
Number of children: 11
15
+
Found child: __private__
16
+
Reading library: ppxlib.__private__
17
+
Number of children: 1
18
+
Found child: ppx_foo_deriver
19
+
Reading library: ppxlib.__private__.ppx_foo_deriver
20
+
Number of children: 0
21
+
Found child: ast
22
+
Reading library: ppxlib.ast
23
+
Number of children: 0
24
+
Found child: astlib
25
+
Reading library: ppxlib.astlib
26
+
Number of children: 0
27
+
Found child: metaquot
28
+
Reading library: ppxlib.metaquot
29
+
Number of children: 0
30
+
Found child: metaquot_lifters
31
+
Reading library: ppxlib.metaquot_lifters
32
+
Number of children: 0
33
+
Found child: print_diff
34
+
Reading library: ppxlib.print_diff
35
+
Number of children: 0
36
+
Found child: runner
37
+
Reading library: ppxlib.runner
38
+
Number of children: 0
39
+
Found child: runner_as_ppx
40
+
Reading library: ppxlib.runner_as_ppx
41
+
Number of children: 0
42
+
Found child: stdppx
43
+
Reading library: ppxlib.stdppx
44
+
Number of children: 0
45
+
Found child: traverse
46
+
Reading library: ppxlib.traverse
47
+
Number of children: 0
48
+
Found child: traverse_builtins
49
+
Reading library: ppxlib.traverse_builtins
50
+
Number of children: 0
51
+
Parsed uri: ./lib/ppx_deriving/META
52
+
Reading library: ppx_deriving
53
+
Number of children: 12
54
+
Found child: api
55
+
Reading library: ppx_deriving.api
56
+
Number of children: 0
57
+
Found child: create
58
+
Reading library: ppx_deriving.create
59
+
Number of children: 0
60
+
Found child: enum
61
+
Reading library: ppx_deriving.enum
62
+
Number of children: 0
63
+
Found child: eq
64
+
Reading library: ppx_deriving.eq
65
+
Number of children: 0
66
+
Found child: fold
67
+
Reading library: ppx_deriving.fold
68
+
Number of children: 0
69
+
Found child: iter
70
+
Reading library: ppx_deriving.iter
71
+
Number of children: 0
72
+
Found child: make
73
+
Reading library: ppx_deriving.make
74
+
Number of children: 0
75
+
Found child: map
76
+
Reading library: ppx_deriving.map
77
+
Number of children: 0
78
+
Found child: ord
79
+
Reading library: ppx_deriving.ord
80
+
Number of children: 0
81
+
Found child: runtime
82
+
Reading library: ppx_deriving.runtime
83
+
Number of children: 0
84
+
Found child: show
85
+
Reading library: ppx_deriving.show
86
+
Number of children: 0
87
+
Found child: std
88
+
Reading library: ppx_deriving.std
89
+
Number of children: 0
90
+
Parsed uri: ./lib/ppx_derivers/META
91
+
Reading library: ppx_derivers
92
+
Number of children: 0
93
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
94
+
Reading library: ocaml_intrinsics_kernel
95
+
Number of children: 0
96
+
Parsed uri: ./lib/ocaml/stdlib/META
97
+
Reading library: stdlib
98
+
Number of children: 0
99
+
Parsed uri: ./lib/ocaml/compiler-libs/META
100
+
Reading library: compiler-libs
101
+
Number of children: 5
102
+
Found child: common
103
+
Reading library: compiler-libs.common
104
+
Number of children: 0
105
+
Found child: bytecomp
106
+
Reading library: compiler-libs.bytecomp
107
+
Number of children: 0
108
+
Found child: optcomp
109
+
Reading library: compiler-libs.optcomp
110
+
Number of children: 0
111
+
Found child: toplevel
112
+
Reading library: compiler-libs.toplevel
113
+
Number of children: 0
114
+
Found child: native-toplevel
115
+
Reading library: compiler-libs.native-toplevel
116
+
Number of children: 0
117
+
Parsed uri: ./lib/ocaml-compiler-libs/META
118
+
Reading library: ocaml-compiler-libs
119
+
Number of children: 5
120
+
Found child: bytecomp
121
+
Reading library: ocaml-compiler-libs.bytecomp
122
+
Number of children: 0
123
+
Found child: common
124
+
Reading library: ocaml-compiler-libs.common
125
+
Number of children: 0
126
+
Found child: optcomp
127
+
Reading library: ocaml-compiler-libs.optcomp
128
+
Number of children: 0
129
+
Found child: shadow
130
+
Reading library: ocaml-compiler-libs.shadow
131
+
Number of children: 0
132
+
Found child: toplevel
133
+
Reading library: ocaml-compiler-libs.toplevel
134
+
Number of children: 0
135
+
Parsed uri: ./lib/base/META
136
+
Reading library: base
137
+
Number of children: 3
138
+
Found child: base_internalhash_types
139
+
Reading library: base.base_internalhash_types
140
+
Number of children: 0
141
+
Found child: md5
142
+
Reading library: base.md5
143
+
Number of children: 0
144
+
Found child: shadow_stdlib
145
+
Reading library: base.shadow_stdlib
146
+
Number of children: 0
147
+
node_directive_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
+
node_directive_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
149
+
node_directive_test.js: [INFO] init() finished
150
+
node_directive_test.js: [INFO] setup() for env default...
151
+
node_directive_test.js: [INFO] Fetching stdlib__Format.cmi
152
+
153
+
node_directive_test.js: [INFO] Fetching stdlib__Sys.cmi
154
+
155
+
error while evaluating #enable "pretty";;
156
+
error while evaluating #disable "shortvar";;
157
+
node_directive_test.js: [INFO] Setup complete
158
+
node_directive_test.js: [INFO] setup() finished for env default
159
+
--- Section 1: Basic Execution ---
160
+
[PASS] basic_eval: # 1 + 2;;
161
+
- : int = 3
162
+
[PASS] let_binding: # let x = 42;;
163
+
val x : int = 42
164
+
165
+
--- Section 2: #show Directives ---
166
+
[PASS] show_type_point: # #show point;;
167
+
type point = { x : float; y : float; }
168
+
[PASS] show_val_origin: # #show origin;;
169
+
val origin : point
170
+
[PASS] show_module: # #show MyMod;;
171
+
module MyMod : sig type t = int val zero : int end
172
+
[PASS] show_exception: # #show My_error;;
173
+
exception My_error of string
174
+
[PASS] show_type_list: # #show_type list;;
175
+
type 'a list = [] | (::) of 'a * 'a list
176
+
node_directive_test.js: [INFO] Fetching stdlib__List.cmi
177
+
178
+
[PASS] show_val_list_map: # #show_val List.map;;
179
+
val map : ('a -> 'b) -> 'a list -> 'b list
180
+
[PASS] show_module_list: # #show_module List;;
181
+
module List :
182
+
sig
183
+
type 'a t = 'a list = [] | (::) of 'a * 'a list
184
+
val length : 'a list -> int
185
+
val compare_lengths : 'a list -> 'b list -> int
186
+
val compare_length_with : 'a list -> int -> int
187
+
val is_empty : 'a list -> bool
188
+
val cons : 'a -> 'a list -> 'a list
189
+
val singleton : 'a -> 'a list
190
+
val hd : 'a list -> 'a
191
+
val tl : 'a list -> 'a list
192
+
val nth : 'a list -> int -> 'a
193
+
val nth_opt : 'a list -> int -> 'a option
194
+
val rev : 'a list -> 'a list
195
+
val init : int -> (int -> 'a) -> 'a list
196
+
val append : 'a list -> 'a list -> 'a list
197
+
val rev_append : 'a list -> 'a list -> 'a list
198
+
val concat : 'a list list -> 'a list
199
+
val flatten : 'a list list -> 'a list
200
+
val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
201
+
val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
202
+
val iter : ('a -> unit) -> 'a list -> unit
203
+
val iteri : (int -> 'a -> unit) -> 'a list -> unit
204
+
val map : ('a -> 'b) -> 'a list -> 'b list
205
+
val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
206
+
val rev_map : ('a -> 'b) -> 'a list -> 'b list
207
+
val filter_map : ('a -> 'b option) -> 'a list -> 'b list
208
+
val concat_map : ('a -> 'b list) -> 'a list -> 'b list
209
+
val fold_left_map :
210
+
('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list
211
+
val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc
212
+
val fold_right : ('a -> 'acc -> 'acc) -> 'a list -> 'acc -> 'acc
213
+
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
214
+
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
215
+
val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
216
+
val fold_left2 :
217
+
('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a list -> 'b list -> 'acc
218
+
val fold_right2 :
219
+
('a -> 'b -> 'acc -> 'acc) -> 'a list -> 'b list -> 'acc -> 'acc
220
+
val for_all : ('a -> bool) -> 'a list -> bool
221
+
val exists : ('a -> bool) -> 'a list -> bool
222
+
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
223
+
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
224
+
val mem : 'a -> 'a list -> bool
225
+
val memq : 'a -> 'a list -> bool
226
+
val find : ('a -> bool) -> 'a list -> 'a
227
+
val find_opt : ('a -> bool) -> 'a list -> 'a option
228
+
val find_index : ('a -> bool) -> 'a list -> int option
229
+
val find_map : ('a -> 'b option) -> 'a list -> 'b option
230
+
val find_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b option
231
+
val filter : ('a -> bool) -> 'a list -> 'a list
232
+
val find_all : ('a -> bool) -> 'a list -> 'a list
233
+
val filteri : (int -> 'a -> bool) -> 'a list -> 'a list
234
+
val take : int -> 'a list -> 'a list
235
+
val drop : int -> 'a list -> 'a list
236
+
val take_while : ('a -> bool) -> 'a list -> 'a list
237
+
val drop_while : ('a -> bool) -> 'a list -> 'a list
238
+
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
239
+
val partition_map :
240
+
('a -> ('b, 'c) Either.t) -> 'a list -> 'b list * 'c list
241
+
val assoc : 'a -> ('a * 'b) list -> 'b
242
+
val assoc_opt : 'a -> ('a * 'b) list -> 'b option
243
+
val assq : 'a -> ('a * 'b) list -> 'b
244
+
val assq_opt : 'a -> ('a * 'b) list -> 'b option
245
+
val mem_assoc : 'a -> ('a * 'b) list -> bool
246
+
val mem_assq : 'a -> ('a * 'b) list -> bool
247
+
val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
248
+
val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
249
+
val split : ('a * 'b) list -> 'a list * 'b list
250
+
val combine : 'a list -> 'b list -> ('a * 'b) list
251
+
val sort : ('a -> 'a -> int) -> 'a list -> 'a list
252
+
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
253
+
val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
254
+
val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list
255
+
val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
256
+
val to_seq : 'a list -> 'a Seq.t
257
+
val of_seq : 'a Seq.t -> 'a list
258
+
end
259
+
[PASS] show_exception_not_found: # #show_exception Not_found;;
260
+
exception Not_found
261
+
262
+
--- Section 3: #print_depth and #print_length ---
263
+
[PASS] print_depth_truncated: # nested;;
264
+
- : int list list list list = [[[...]]]
265
+
[PASS] print_depth_full: # nested;;
266
+
- : int list list list list = [[[[1; 2; 3]]]]
267
+
[PASS] print_length_truncated: # long_list;;
268
+
- : int list = [1; 2; ...]
269
+
[PASS] print_length_full: # long_list;;
270
+
- : int list = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]
271
+
272
+
--- Section 4: #install_printer / #remove_printer ---
273
+
[PASS] install_printer: # Red;;
274
+
- : color = <color:red>
275
+
[PASS] remove_printer: # Red;;
276
+
- : color = Red
277
+
278
+
--- Section 5: #warnings / #warn_error ---
279
+
[PASS] warnings_disabled: # let _ = let unused = 1 in 2;;
280
+
- : int = 2
281
+
Line 1, characters 12-19:
282
+
Warning 26 [unused-var]: unused variable unused2.
283
+
[PASS] warnings_enabled: # let _ = let unused2 = 1 in 2;;
284
+
- : int = 2
285
+
286
+
Line 1, characters 12-19:
287
+
Error (warning 26 [unused-var]): unused variable unused3.
288
+
[FAIL] warn_error: # let _ = let unused3 = 1 in 2;;
289
+
290
+
--- Section 6: #rectypes ---
291
+
292
+
Line 1, characters 0-23:
293
+
Error: The type abbreviation t is cyclic:
294
+
'a t = 'a t -> int,
295
+
'a t -> int contains 'a t
296
+
[FAIL] rectypes_before: # type 'a t = 'a t -> int;;
297
+
[PASS] rectypes_after: # type 'a u = 'a u -> int;;
298
+
type 'a u = 'a u -> int
299
+
300
+
--- Section 7: #directory ---
301
+
[PASS] directory_add: (no error)
302
+
[PASS] directory_remove: (no error)
303
+
304
+
--- Section 8: #help ---
305
+
[PASS] help: # #help;;
306
+
General
307
+
#help
308
+
Prints a list of all available directives, with corresponding argume...
309
+
310
+
--- Section 9: #labels / #principal ---
311
+
[PASS] labels_true: (no error)
312
+
[PASS] labels_false: (no error)
313
+
[PASS] principal_true: (no error)
314
+
[PASS] principal_false: (no error)
315
+
316
+
--- Section 10: Error Cases ---
317
+
[PASS] unknown_directive: # #unknown_directive;;
318
+
Unknown directive unknown_directive.
319
+
[PASS] show_nonexistent: # #show nonexistent_value;;
320
+
Unknown element.
321
+
322
+
--- Section 11: Classes ---
323
+
[PASS] show_class: # #show_class counter;;
324
+
class counter :
325
+
object val mutable n : int method get : int method incr : unit end
326
+
327
+
=== Results: 29/31 tests passed ===
328
+
FAILURE: Some tests failed.
+328
js_top_worker/test/node/node_directive_test.ml
+328
js_top_worker/test/node/node_directive_test.ml
···
1
+
(** Node.js test for OCaml toplevel directives.
2
+
3
+
This tests the js_of_ocaml implementation of the toplevel,
4
+
running in Node.js to verify directives work in the JS context.
5
+
6
+
Directives tested:
7
+
- Environment query: #show, #show_type, #show_val, #show_module, #show_exception
8
+
- Pretty-printing: #print_depth, #print_length
9
+
- Custom printers: #install_printer, #remove_printer
10
+
- Warnings: #warnings, #warn_error
11
+
- Type system: #rectypes
12
+
- Directory: #directory, #remove_directory
13
+
- Help: #help
14
+
- Compiler options: #labels, #principal
15
+
- Error handling: unknown directives, missing identifiers
16
+
17
+
NOT tested (require file system or special setup):
18
+
- #use, #mod_use (file loading)
19
+
- #load (bytecode loading)
20
+
- #require, #list (findlib - tested separately)
21
+
- #trace (excluded per user request)
22
+
*)
23
+
24
+
open Js_top_worker
25
+
open Js_top_worker_rpc.Toplevel_api_gen
26
+
open Impl
27
+
28
+
(* Flusher that writes to process.stdout in Node.js *)
29
+
let console_flusher (s : string) : unit =
30
+
let open Js_of_ocaml in
31
+
let process = Js.Unsafe.get Js.Unsafe.global (Js.string "process") in
32
+
let stdout = Js.Unsafe.get process (Js.string "stdout") in
33
+
let write = Js.Unsafe.get stdout (Js.string "write") in
34
+
ignore (Js.Unsafe.call write stdout [| Js.Unsafe.inject (Js.string s) |])
35
+
36
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
37
+
fun f () ->
38
+
let stdout_buff = Buffer.create 1024 in
39
+
let stderr_buff = Buffer.create 1024 in
40
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
41
+
(* Note: Do NOT set stderr flusher - it causes hangs in js_of_ocaml *)
42
+
let x = f () in
43
+
let captured =
44
+
{
45
+
Impl.stdout = Buffer.contents stdout_buff;
46
+
stderr = Buffer.contents stderr_buff;
47
+
}
48
+
in
49
+
(* Restore flusher that writes to console so Printf.printf works for test output *)
50
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
51
+
(captured, x)
52
+
53
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
54
+
55
+
module S : Impl.S = struct
56
+
type findlib_t = Js_top_worker_web.Findlibish.t
57
+
58
+
let capture = capture
59
+
60
+
let sync_get f =
61
+
let f = Fpath.v ("_opam/" ^ f) in
62
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
63
+
with _ -> None
64
+
65
+
let async_get f =
66
+
let f = Fpath.v ("_opam/" ^ f) in
67
+
try
68
+
let content =
69
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
70
+
in
71
+
Lwt.return (Ok content)
72
+
with e -> Lwt.return (Error (`Msg (Printexc.to_string e)))
73
+
74
+
let create_file = Js_of_ocaml.Sys_js.create_file
75
+
76
+
let import_scripts urls =
77
+
let open Js_of_ocaml.Js in
78
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
79
+
List.iter
80
+
(fun url ->
81
+
let (_ : 'a) =
82
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
83
+
in
84
+
())
85
+
urls
86
+
87
+
let init_function _ () = failwith "Not implemented"
88
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
89
+
90
+
let get_stdlib_dcs uri =
91
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
92
+
|> Result.to_list
93
+
94
+
let require b v = function
95
+
| [] -> []
96
+
| packages ->
97
+
Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v
98
+
packages
99
+
100
+
let path = "/static/cmis"
101
+
end
102
+
103
+
module U = Impl.Make (S)
104
+
105
+
let start_server () =
106
+
let open U in
107
+
Logs.set_reporter (Logs_fmt.reporter ());
108
+
Logs.set_level (Some Logs.Info);
109
+
Server.init (IdlM.T.lift init);
110
+
Server.create_env (IdlM.T.lift create_env);
111
+
Server.destroy_env (IdlM.T.lift destroy_env);
112
+
Server.list_envs (IdlM.T.lift list_envs);
113
+
Server.setup (IdlM.T.lift setup);
114
+
Server.exec execute;
115
+
Server.complete_prefix complete_prefix;
116
+
Server.query_errors query_errors;
117
+
Server.type_enclosing type_enclosing;
118
+
Server.exec_toplevel exec_toplevel;
119
+
IdlM.server Server.implementation
120
+
121
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
122
+
123
+
(* Test result tracking *)
124
+
let total_tests = ref 0
125
+
let passed_tests = ref 0
126
+
127
+
let test name check message =
128
+
incr total_tests;
129
+
let passed = check in
130
+
if passed then incr passed_tests;
131
+
let status = if passed then "PASS" else "FAIL" in
132
+
Printf.printf "[%s] %s: %s\n%!" status name message
133
+
134
+
let contains s substr =
135
+
try
136
+
let _ = Str.search_forward (Str.regexp_string substr) s 0 in
137
+
true
138
+
with Not_found -> false
139
+
140
+
let run_directive rpc code =
141
+
let ( let* ) = IdlM.ErrM.bind in
142
+
let* result = Client.exec_toplevel rpc "" ("# " ^ code) in
143
+
IdlM.ErrM.return result.script
144
+
145
+
let _ =
146
+
Printf.printf "=== Node.js Directive Tests ===\n\n%!";
147
+
148
+
let rpc = start_server () in
149
+
let ( let* ) = IdlM.ErrM.bind in
150
+
151
+
let init_config =
152
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
153
+
in
154
+
155
+
let test_sequence =
156
+
(* Initialize *)
157
+
let* _ = Client.init rpc init_config in
158
+
let* _ = Client.setup rpc "" in
159
+
160
+
Printf.printf "--- Section 1: Basic Execution ---\n%!";
161
+
162
+
let* r = run_directive rpc "1 + 2;;" in
163
+
test "basic_eval" (contains r "- : int = 3") r;
164
+
165
+
let* r = run_directive rpc "let x = 42;;" in
166
+
test "let_binding" (contains r "val x : int = 42") r;
167
+
168
+
Printf.printf "\n--- Section 2: #show Directives ---\n%!";
169
+
170
+
(* Define types/values to query *)
171
+
let* _ = run_directive rpc "type point = { x: float; y: float };;" in
172
+
let* _ = run_directive rpc "let origin = { x = 0.0; y = 0.0 };;" in
173
+
let* _ =
174
+
run_directive rpc
175
+
"module MyMod = struct type t = int let zero = 0 end;;"
176
+
in
177
+
let* _ = run_directive rpc "exception My_error of string;;" in
178
+
179
+
let* r = run_directive rpc "#show point;;" in
180
+
test "show_type_point" (contains r "type point") r;
181
+
182
+
let* r = run_directive rpc "#show origin;;" in
183
+
test "show_val_origin" (contains r "val origin") r;
184
+
185
+
let* r = run_directive rpc "#show MyMod;;" in
186
+
test "show_module" (contains r "module MyMod") r;
187
+
188
+
let* r = run_directive rpc "#show My_error;;" in
189
+
test "show_exception" (contains r "exception My_error") r;
190
+
191
+
let* r = run_directive rpc "#show_type list;;" in
192
+
test "show_type_list" (contains r "type 'a list") r;
193
+
194
+
let* r = run_directive rpc "#show_val List.map;;" in
195
+
test "show_val_list_map" (contains r "val map") r;
196
+
197
+
let* r = run_directive rpc "#show_module List;;" in
198
+
test "show_module_list" (contains r "module List") r;
199
+
200
+
let* r = run_directive rpc "#show_exception Not_found;;" in
201
+
test "show_exception_not_found" (contains r "exception Not_found") r;
202
+
203
+
Printf.printf "\n--- Section 3: #print_depth and #print_length ---\n%!";
204
+
205
+
let* _ = run_directive rpc "let nested = [[[[1;2;3]]]];;" in
206
+
let* _ = run_directive rpc "#print_depth 2;;" in
207
+
let* r = run_directive rpc "nested;;" in
208
+
test "print_depth_truncated" (contains r "...") r;
209
+
210
+
let* _ = run_directive rpc "#print_depth 100;;" in
211
+
let* r = run_directive rpc "nested;;" in
212
+
test "print_depth_full" (contains r "1; 2; 3") r;
213
+
214
+
let* _ = run_directive rpc "let long_list = [1;2;3;4;5;6;7;8;9;10];;" in
215
+
let* _ = run_directive rpc "#print_length 3;;" in
216
+
let* r = run_directive rpc "long_list;;" in
217
+
test "print_length_truncated" (contains r "...") r;
218
+
219
+
let* _ = run_directive rpc "#print_length 100;;" in
220
+
let* r = run_directive rpc "long_list;;" in
221
+
test "print_length_full" (contains r "10") r;
222
+
223
+
Printf.printf "\n--- Section 4: #install_printer / #remove_printer ---\n%!";
224
+
225
+
let* _ = run_directive rpc "type color = Red | Green | Blue;;" in
226
+
let* _ =
227
+
run_directive rpc
228
+
{|let pp_color fmt c = Format.fprintf fmt "<color:%s>" (match c with Red -> "red" | Green -> "green" | Blue -> "blue");;|}
229
+
in
230
+
let* _ = run_directive rpc "#install_printer pp_color;;" in
231
+
let* r = run_directive rpc "Red;;" in
232
+
test "install_printer" (contains r "<color:red>") r;
233
+
234
+
let* _ = run_directive rpc "#remove_printer pp_color;;" in
235
+
let* r = run_directive rpc "Red;;" in
236
+
test "remove_printer" (contains r "Red" && not (contains r "<color:red>")) r;
237
+
238
+
Printf.printf "\n--- Section 5: #warnings / #warn_error ---\n%!";
239
+
240
+
let* _ = run_directive rpc "#warnings \"-26\";;" in
241
+
let* r = run_directive rpc "let _ = let unused = 1 in 2;;" in
242
+
test "warnings_disabled"
243
+
(not (contains r "Warning") || contains r "- : int = 2")
244
+
r;
245
+
246
+
let* _ = run_directive rpc "#warnings \"+26\";;" in
247
+
let* r = run_directive rpc "let _ = let unused2 = 1 in 2;;" in
248
+
test "warnings_enabled" (contains r "Warning" || contains r "unused2") r;
249
+
250
+
let* _ = run_directive rpc "#warn_error \"+26\";;" in
251
+
let* r = run_directive rpc "let _ = let unused3 = 1 in 2;;" in
252
+
test "warn_error" (contains r "Error") r;
253
+
254
+
let* _ = run_directive rpc "#warn_error \"-a\";;" in
255
+
256
+
Printf.printf "\n--- Section 6: #rectypes ---\n%!";
257
+
258
+
let* r = run_directive rpc "type 'a t = 'a t -> int;;" in
259
+
test "rectypes_before" (contains r "Error" || contains r "cyclic") r;
260
+
261
+
let* _ = run_directive rpc "#rectypes;;" in
262
+
let* r = run_directive rpc "type 'a u = 'a u -> int;;" in
263
+
test "rectypes_after" (contains r "type 'a u") r;
264
+
265
+
Printf.printf "\n--- Section 7: #directory ---\n%!";
266
+
267
+
let* r = run_directive rpc "#directory \"/tmp\";;" in
268
+
test "directory_add" (String.length r >= 0) "(no error)";
269
+
270
+
let* r = run_directive rpc "#remove_directory \"/tmp\";;" in
271
+
test "directory_remove" (String.length r >= 0) "(no error)";
272
+
273
+
Printf.printf "\n--- Section 8: #help ---\n%!";
274
+
275
+
let* r = run_directive rpc "#help;;" in
276
+
test "help"
277
+
(contains r "directive" || contains r "Directive" || contains r "#")
278
+
(String.sub r 0 (min 100 (String.length r)) ^ "...");
279
+
280
+
Printf.printf "\n--- Section 9: #labels / #principal ---\n%!";
281
+
282
+
let* r = run_directive rpc "#labels true;;" in
283
+
test "labels_true" (String.length r >= 0) "(no error)";
284
+
285
+
let* r = run_directive rpc "#labels false;;" in
286
+
test "labels_false" (String.length r >= 0) "(no error)";
287
+
288
+
let* r = run_directive rpc "#principal true;;" in
289
+
test "principal_true" (String.length r >= 0) "(no error)";
290
+
291
+
let* r = run_directive rpc "#principal false;;" in
292
+
test "principal_false" (String.length r >= 0) "(no error)";
293
+
294
+
Printf.printf "\n--- Section 10: Error Cases ---\n%!";
295
+
296
+
let* r = run_directive rpc "#unknown_directive;;" in
297
+
test "unknown_directive" (contains r "Unknown") r;
298
+
299
+
let* r = run_directive rpc "#show nonexistent_value;;" in
300
+
test "show_nonexistent" (contains r "Unknown" || contains r "not found") r;
301
+
302
+
Printf.printf "\n--- Section 11: Classes ---\n%!";
303
+
304
+
let* _ =
305
+
run_directive rpc
306
+
"class counter = object val mutable n = 0 method incr = n <- n + 1 \
307
+
method get = n end;;"
308
+
in
309
+
let* r = run_directive rpc "#show_class counter;;" in
310
+
test "show_class" (contains r "class counter") r;
311
+
312
+
IdlM.ErrM.return ()
313
+
in
314
+
315
+
let promise = test_sequence |> IdlM.T.get in
316
+
(match Lwt.state promise with
317
+
| Lwt.Return (Ok ()) -> ()
318
+
| Lwt.Return (Error (InternalError s)) ->
319
+
Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
320
+
| Lwt.Fail e ->
321
+
Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
322
+
| Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
323
+
324
+
Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
325
+
!total_tests;
326
+
if !passed_tests = !total_tests then
327
+
Printf.printf "SUCCESS: All directive tests passed!\n%!"
328
+
else Printf.printf "FAILURE: Some tests failed.\n%!"
+237
js_top_worker/test/node/node_env_test.expected
+237
js_top_worker/test/node/node_env_test.expected
···
1
+
=== Node.js Environment Tests ===
2
+
3
+
node_env_test.js: [INFO] init()
4
+
Initializing findlib
5
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
6
+
Parsed uri: ./lib/stdlib-shims/META
7
+
Reading library: stdlib-shims
8
+
Number of children: 0
9
+
Parsed uri: ./lib/sexplib0/META
10
+
Reading library: sexplib0
11
+
Number of children: 0
12
+
Parsed uri: ./lib/ppxlib/META
13
+
Reading library: ppxlib
14
+
Number of children: 11
15
+
Found child: __private__
16
+
Reading library: ppxlib.__private__
17
+
Number of children: 1
18
+
Found child: ppx_foo_deriver
19
+
Reading library: ppxlib.__private__.ppx_foo_deriver
20
+
Number of children: 0
21
+
Found child: ast
22
+
Reading library: ppxlib.ast
23
+
Number of children: 0
24
+
Found child: astlib
25
+
Reading library: ppxlib.astlib
26
+
Number of children: 0
27
+
Found child: metaquot
28
+
Reading library: ppxlib.metaquot
29
+
Number of children: 0
30
+
Found child: metaquot_lifters
31
+
Reading library: ppxlib.metaquot_lifters
32
+
Number of children: 0
33
+
Found child: print_diff
34
+
Reading library: ppxlib.print_diff
35
+
Number of children: 0
36
+
Found child: runner
37
+
Reading library: ppxlib.runner
38
+
Number of children: 0
39
+
Found child: runner_as_ppx
40
+
Reading library: ppxlib.runner_as_ppx
41
+
Number of children: 0
42
+
Found child: stdppx
43
+
Reading library: ppxlib.stdppx
44
+
Number of children: 0
45
+
Found child: traverse
46
+
Reading library: ppxlib.traverse
47
+
Number of children: 0
48
+
Found child: traverse_builtins
49
+
Reading library: ppxlib.traverse_builtins
50
+
Number of children: 0
51
+
Parsed uri: ./lib/ppx_deriving/META
52
+
Reading library: ppx_deriving
53
+
Number of children: 12
54
+
Found child: api
55
+
Reading library: ppx_deriving.api
56
+
Number of children: 0
57
+
Found child: create
58
+
Reading library: ppx_deriving.create
59
+
Number of children: 0
60
+
Found child: enum
61
+
Reading library: ppx_deriving.enum
62
+
Number of children: 0
63
+
Found child: eq
64
+
Reading library: ppx_deriving.eq
65
+
Number of children: 0
66
+
Found child: fold
67
+
Reading library: ppx_deriving.fold
68
+
Number of children: 0
69
+
Found child: iter
70
+
Reading library: ppx_deriving.iter
71
+
Number of children: 0
72
+
Found child: make
73
+
Reading library: ppx_deriving.make
74
+
Number of children: 0
75
+
Found child: map
76
+
Reading library: ppx_deriving.map
77
+
Number of children: 0
78
+
Found child: ord
79
+
Reading library: ppx_deriving.ord
80
+
Number of children: 0
81
+
Found child: runtime
82
+
Reading library: ppx_deriving.runtime
83
+
Number of children: 0
84
+
Found child: show
85
+
Reading library: ppx_deriving.show
86
+
Number of children: 0
87
+
Found child: std
88
+
Reading library: ppx_deriving.std
89
+
Number of children: 0
90
+
Parsed uri: ./lib/ppx_derivers/META
91
+
Reading library: ppx_derivers
92
+
Number of children: 0
93
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
94
+
Reading library: ocaml_intrinsics_kernel
95
+
Number of children: 0
96
+
Parsed uri: ./lib/ocaml/stdlib/META
97
+
Reading library: stdlib
98
+
Number of children: 0
99
+
Parsed uri: ./lib/ocaml/compiler-libs/META
100
+
Reading library: compiler-libs
101
+
Number of children: 5
102
+
Found child: common
103
+
Reading library: compiler-libs.common
104
+
Number of children: 0
105
+
Found child: bytecomp
106
+
Reading library: compiler-libs.bytecomp
107
+
Number of children: 0
108
+
Found child: optcomp
109
+
Reading library: compiler-libs.optcomp
110
+
Number of children: 0
111
+
Found child: toplevel
112
+
Reading library: compiler-libs.toplevel
113
+
Number of children: 0
114
+
Found child: native-toplevel
115
+
Reading library: compiler-libs.native-toplevel
116
+
Number of children: 0
117
+
Parsed uri: ./lib/ocaml-compiler-libs/META
118
+
Reading library: ocaml-compiler-libs
119
+
Number of children: 5
120
+
Found child: bytecomp
121
+
Reading library: ocaml-compiler-libs.bytecomp
122
+
Number of children: 0
123
+
Found child: common
124
+
Reading library: ocaml-compiler-libs.common
125
+
Number of children: 0
126
+
Found child: optcomp
127
+
Reading library: ocaml-compiler-libs.optcomp
128
+
Number of children: 0
129
+
Found child: shadow
130
+
Reading library: ocaml-compiler-libs.shadow
131
+
Number of children: 0
132
+
Found child: toplevel
133
+
Reading library: ocaml-compiler-libs.toplevel
134
+
Number of children: 0
135
+
Parsed uri: ./lib/base/META
136
+
Reading library: base
137
+
Number of children: 3
138
+
Found child: base_internalhash_types
139
+
Reading library: base.base_internalhash_types
140
+
Number of children: 0
141
+
Found child: md5
142
+
Reading library: base.md5
143
+
Number of children: 0
144
+
Found child: shadow_stdlib
145
+
Reading library: base.shadow_stdlib
146
+
Number of children: 0
147
+
node_env_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
+
node_env_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
149
+
node_env_test.js: [INFO] init() finished
150
+
--- Section 1: Default Environment ---
151
+
node_env_test.js: [INFO] setup() for env default...
152
+
node_env_test.js: [INFO] Fetching stdlib__Format.cmi
153
+
154
+
node_env_test.js: [INFO] Fetching stdlib__Sys.cmi
155
+
156
+
error while evaluating #enable "pretty";;
157
+
error while evaluating #disable "shortvar";;
158
+
node_env_test.js: [INFO] Setup complete
159
+
node_env_test.js: [INFO] setup() finished for env default
160
+
[PASS] default_setup: Default environment setup
161
+
[PASS] default_define: # let default_val = 42;;
162
+
val default_val : int = 42
163
+
164
+
--- Section 2: Creating New Environments ---
165
+
node_env_test.js: [INFO] create_env(env1)
166
+
[PASS] create_env1: Created environment env1
167
+
node_env_test.js: [INFO] setup() for env env1...
168
+
error while evaluating #enable "pretty";;
169
+
error while evaluating #disable "shortvar";;
170
+
node_env_test.js: [INFO] Setup complete
171
+
node_env_test.js: [INFO] setup() finished for env env1
172
+
[PASS] setup_env1: Setup environment env1
173
+
[PASS] env1_define: # let env1_val = 100;;
174
+
val env1_val : int = 100
175
+
176
+
--- Section 3: Environment Isolation ---
177
+
Line 1, characters 0-11:
178
+
Error: Unbound value default_val
179
+
[PASS] isolation_default_from_env1: No leakage: # default_val;;
180
+
181
+
Line 1, characters 0-8:
182
+
Error: Unbound value env1_val
183
+
[PASS] isolation_env1_from_default: No leakage: # env1_val;;
184
+
[PASS] default_still_works: # default_val;;
185
+
- : int = 42
186
+
187
+
--- Section 4: Multiple Environments ---
188
+
node_env_test.js: [INFO] create_env(env2)
189
+
node_env_test.js: [INFO] setup() for env env2...
190
+
error while evaluating #enable "pretty";;
191
+
error while evaluating #disable "shortvar";;
192
+
node_env_test.js: [INFO] Setup complete
193
+
node_env_test.js: [INFO] setup() finished for env env2
194
+
[PASS] create_and_setup_env2: Created and setup env2
195
+
[PASS] env2_define: # let env2_val = 200;;
196
+
val env2_val : int = 200
197
+
198
+
Line 1, characters 0-8:
199
+
Error: Unbound value env1_val
200
+
Hint: Did you mean env2_val?
201
+
[PASS] isolation_env1_from_env2: No leakage: # env1_val;;
202
+
203
+
Line 1, characters 0-8:
204
+
Error: Unbound value env2_val
205
+
Hint: Did you mean env1_val?
206
+
[PASS] isolation_env2_from_env1: No leakage: # env2_val;;
207
+
208
+
--- Section 5: List Environments ---
209
+
node_env_test.js: [INFO] list_envs() -> [env2, default, env1]
210
+
[PASS] list_envs_count: Found 3 environments
211
+
[PASS] list_envs_has_default: env2, default, env1
212
+
[PASS] list_envs_has_env1: env2, default, env1
213
+
[PASS] list_envs_has_env2: env2, default, env1
214
+
215
+
--- Section 6: Destroy Environment ---
216
+
node_env_test.js: [INFO] destroy_env(env2)
217
+
[PASS] destroy_env2: Destroyed env2
218
+
node_env_test.js: [INFO] list_envs() -> [default, env1]
219
+
[PASS] env2_destroyed: default, env1
220
+
[PASS] env1_still_exists: default, env1
221
+
222
+
--- Section 7: Reuse Environment Name ---
223
+
node_env_test.js: [INFO] create_env(env2)
224
+
node_env_test.js: [INFO] setup() for env env2...
225
+
error while evaluating #enable "pretty";;
226
+
error while evaluating #disable "shortvar";;
227
+
node_env_test.js: [INFO] Setup complete
228
+
node_env_test.js: [INFO] setup() finished for env env2
229
+
230
+
Line 1, characters 0-8:
231
+
Error: Unbound value env2_val
232
+
[PASS] new_env2_clean: Old value gone: # env2_val;;
233
+
[PASS] new_env2_define: # let new_env2_val = 999;;
234
+
val new_env2_val : int = 999
235
+
236
+
=== Results: 21/21 tests passed ===
237
+
SUCCESS: All environment tests passed!
+264
js_top_worker/test/node/node_env_test.ml
+264
js_top_worker/test/node/node_env_test.ml
···
1
+
(** Node.js test for multiple environment support.
2
+
3
+
This tests that multiple isolated execution environments work correctly,
4
+
including:
5
+
- Creating and destroying environments
6
+
- Isolation between environments (values defined in one don't leak to another)
7
+
- Using the default environment
8
+
- Listing environments
9
+
*)
10
+
11
+
open Js_top_worker
12
+
open Js_top_worker_rpc.Toplevel_api_gen
13
+
open Impl
14
+
15
+
(* Flusher that writes to process.stdout in Node.js *)
16
+
let console_flusher (s : string) : unit =
17
+
let open Js_of_ocaml in
18
+
let process = Js.Unsafe.get Js.Unsafe.global (Js.string "process") in
19
+
let stdout = Js.Unsafe.get process (Js.string "stdout") in
20
+
let write = Js.Unsafe.get stdout (Js.string "write") in
21
+
ignore (Js.Unsafe.call write stdout [| Js.Unsafe.inject (Js.string s) |])
22
+
23
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
24
+
fun f () ->
25
+
let stdout_buff = Buffer.create 1024 in
26
+
let stderr_buff = Buffer.create 1024 in
27
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
28
+
let x = f () in
29
+
let captured =
30
+
{
31
+
Impl.stdout = Buffer.contents stdout_buff;
32
+
stderr = Buffer.contents stderr_buff;
33
+
}
34
+
in
35
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
36
+
(captured, x)
37
+
38
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
39
+
40
+
module S : Impl.S = struct
41
+
type findlib_t = Js_top_worker_web.Findlibish.t
42
+
43
+
let capture = capture
44
+
45
+
let sync_get f =
46
+
let f = Fpath.v ("_opam/" ^ f) in
47
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
48
+
with _ -> None
49
+
50
+
let async_get f =
51
+
let f = Fpath.v ("_opam/" ^ f) in
52
+
try
53
+
let content =
54
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
55
+
in
56
+
Lwt.return (Ok content)
57
+
with e -> Lwt.return (Error (`Msg (Printexc.to_string e)))
58
+
59
+
let create_file = Js_of_ocaml.Sys_js.create_file
60
+
61
+
let import_scripts urls =
62
+
let open Js_of_ocaml.Js in
63
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
64
+
List.iter
65
+
(fun url ->
66
+
let (_ : 'a) =
67
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
68
+
in
69
+
())
70
+
urls
71
+
72
+
let init_function _ () = failwith "Not implemented"
73
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
74
+
75
+
let get_stdlib_dcs uri =
76
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
77
+
|> Result.to_list
78
+
79
+
let require b v = function
80
+
| [] -> []
81
+
| packages ->
82
+
Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v
83
+
packages
84
+
85
+
let path = "/static/cmis"
86
+
end
87
+
88
+
module U = Impl.Make (S)
89
+
90
+
let start_server () =
91
+
let open U in
92
+
Logs.set_reporter (Logs_fmt.reporter ());
93
+
Logs.set_level (Some Logs.Info);
94
+
Server.init (IdlM.T.lift init);
95
+
Server.create_env (IdlM.T.lift create_env);
96
+
Server.destroy_env (IdlM.T.lift destroy_env);
97
+
Server.list_envs (IdlM.T.lift list_envs);
98
+
Server.setup (IdlM.T.lift setup);
99
+
Server.exec execute;
100
+
Server.complete_prefix complete_prefix;
101
+
Server.query_errors query_errors;
102
+
Server.type_enclosing type_enclosing;
103
+
Server.exec_toplevel exec_toplevel;
104
+
IdlM.server Server.implementation
105
+
106
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
107
+
108
+
(* Test result tracking *)
109
+
let total_tests = ref 0
110
+
let passed_tests = ref 0
111
+
112
+
let test name check message =
113
+
incr total_tests;
114
+
let passed = check in
115
+
if passed then incr passed_tests;
116
+
let status = if passed then "PASS" else "FAIL" in
117
+
Printf.printf "[%s] %s: %s\n%!" status name message
118
+
119
+
let contains s substr =
120
+
try
121
+
let _ = Str.search_forward (Str.regexp_string substr) s 0 in
122
+
true
123
+
with Not_found -> false
124
+
125
+
let run_toplevel rpc env_id code =
126
+
let ( let* ) = IdlM.ErrM.bind in
127
+
let* result = Client.exec_toplevel rpc env_id ("# " ^ code) in
128
+
IdlM.ErrM.return result.script
129
+
130
+
let _ =
131
+
Printf.printf "=== Node.js Environment Tests ===\n\n%!";
132
+
133
+
let rpc = start_server () in
134
+
let ( let* ) = IdlM.ErrM.bind in
135
+
136
+
let init_config =
137
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
138
+
in
139
+
140
+
let test_sequence =
141
+
(* Initialize *)
142
+
let* _ = Client.init rpc init_config in
143
+
144
+
Printf.printf "--- Section 1: Default Environment ---\n%!";
145
+
146
+
(* Setup default environment *)
147
+
let* _ = Client.setup rpc "" in
148
+
test "default_setup" true "Default environment setup";
149
+
150
+
(* Define a value in default environment *)
151
+
let* r = run_toplevel rpc "" "let default_val = 42;;" in
152
+
test "default_define" (contains r "val default_val : int = 42") r;
153
+
154
+
Printf.printf "\n--- Section 2: Creating New Environments ---\n%!";
155
+
156
+
(* Create a new environment "env1" *)
157
+
let* _ = Client.create_env rpc "env1" in
158
+
test "create_env1" true "Created environment env1";
159
+
160
+
(* Setup env1 *)
161
+
let* _ = Client.setup rpc "env1" in
162
+
test "setup_env1" true "Setup environment env1";
163
+
164
+
(* Define a different value in env1 *)
165
+
let* r = run_toplevel rpc "env1" "let env1_val = 100;;" in
166
+
test "env1_define" (contains r "val env1_val : int = 100") r;
167
+
168
+
Printf.printf "\n--- Section 3: Environment Isolation ---\n%!";
169
+
170
+
(* Check that default_val is NOT visible in env1 - the script output
171
+
should NOT contain "val default_val" if there was an error *)
172
+
let* r = run_toplevel rpc "env1" "default_val;;" in
173
+
test "isolation_default_from_env1" (not (contains r "val default_val"))
174
+
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
175
+
176
+
(* Check that env1_val is NOT visible in default env *)
177
+
let* r = run_toplevel rpc "" "env1_val;;" in
178
+
test "isolation_env1_from_default" (not (contains r "val env1_val"))
179
+
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
180
+
181
+
(* Check that default_val IS still visible in default env *)
182
+
let* r = run_toplevel rpc "" "default_val;;" in
183
+
test "default_still_works" (contains r "- : int = 42") r;
184
+
185
+
Printf.printf "\n--- Section 4: Multiple Environments ---\n%!";
186
+
187
+
(* Create a second environment *)
188
+
let* _ = Client.create_env rpc "env2" in
189
+
let* _ = Client.setup rpc "env2" in
190
+
test "create_and_setup_env2" true "Created and setup env2";
191
+
192
+
(* Define value in env2 *)
193
+
let* r = run_toplevel rpc "env2" "let env2_val = 200;;" in
194
+
test "env2_define" (contains r "val env2_val : int = 200") r;
195
+
196
+
(* Verify isolation between all three environments *)
197
+
let* r = run_toplevel rpc "env2" "env1_val;;" in
198
+
test "isolation_env1_from_env2" (not (contains r "val env1_val"))
199
+
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
200
+
201
+
let* r = run_toplevel rpc "env1" "env2_val;;" in
202
+
test "isolation_env2_from_env1" (not (contains r "val env2_val"))
203
+
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
204
+
205
+
Printf.printf "\n--- Section 5: List Environments ---\n%!";
206
+
207
+
(* List all environments *)
208
+
let* envs = Client.list_envs rpc () in
209
+
test "list_envs_count" (List.length envs >= 3)
210
+
(Printf.sprintf "Found %d environments" (List.length envs));
211
+
test "list_envs_has_default" (List.mem "default" envs)
212
+
(String.concat ", " envs);
213
+
test "list_envs_has_env1" (List.mem "env1" envs)
214
+
(String.concat ", " envs);
215
+
test "list_envs_has_env2" (List.mem "env2" envs)
216
+
(String.concat ", " envs);
217
+
218
+
Printf.printf "\n--- Section 6: Destroy Environment ---\n%!";
219
+
220
+
(* Destroy env2 *)
221
+
let* _ = Client.destroy_env rpc "env2" in
222
+
test "destroy_env2" true "Destroyed env2";
223
+
224
+
(* Verify env2 is gone from list *)
225
+
let* envs = Client.list_envs rpc () in
226
+
test "env2_destroyed" (not (List.mem "env2" envs))
227
+
(String.concat ", " envs);
228
+
229
+
(* env1 should still exist *)
230
+
test "env1_still_exists" (List.mem "env1" envs)
231
+
(String.concat ", " envs);
232
+
233
+
Printf.printf "\n--- Section 7: Reuse Environment Name ---\n%!";
234
+
235
+
(* Re-create env2 *)
236
+
let* _ = Client.create_env rpc "env2" in
237
+
let* _ = Client.setup rpc "env2" in
238
+
239
+
(* Old values should not exist - checking that it doesn't find the old value *)
240
+
let* r = run_toplevel rpc "env2" "env2_val;;" in
241
+
test "new_env2_clean" (not (contains r "- : int = 200"))
242
+
("Old value gone: " ^ String.sub r 0 (min 40 (String.length r)));
243
+
244
+
(* Define new value *)
245
+
let* r = run_toplevel rpc "env2" "let new_env2_val = 999;;" in
246
+
test "new_env2_define" (contains r "val new_env2_val : int = 999") r;
247
+
248
+
IdlM.ErrM.return ()
249
+
in
250
+
251
+
let promise = test_sequence |> IdlM.T.get in
252
+
(match Lwt.state promise with
253
+
| Lwt.Return (Ok ()) -> ()
254
+
| Lwt.Return (Error (InternalError s)) ->
255
+
Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
256
+
| Lwt.Fail e ->
257
+
Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
258
+
| Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
259
+
260
+
Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
261
+
!total_tests;
262
+
if !passed_tests = !total_tests then
263
+
Printf.printf "SUCCESS: All environment tests passed!\n%!"
264
+
else Printf.printf "FAILURE: Some tests failed.\n%!"
+190
js_top_worker/test/node/node_incremental_test.expected
+190
js_top_worker/test/node/node_incremental_test.expected
···
1
+
node_incremental_test.js: [INFO] init()
2
+
Initializing findlib
3
+
node_incremental_test.js: [INFO] async_get: _opam/findlib_index
4
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
5
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/stdlib-shims/META
6
+
Parsed uri: ./lib/stdlib-shims/META
7
+
Reading library: stdlib-shims
8
+
Number of children: 0
9
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/sexplib0/META
10
+
Parsed uri: ./lib/sexplib0/META
11
+
Reading library: sexplib0
12
+
Number of children: 0
13
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ppxlib/META
14
+
Parsed uri: ./lib/ppxlib/META
15
+
Reading library: ppxlib
16
+
Number of children: 11
17
+
Found child: __private__
18
+
Reading library: ppxlib.__private__
19
+
Number of children: 1
20
+
Found child: ppx_foo_deriver
21
+
Reading library: ppxlib.__private__.ppx_foo_deriver
22
+
Number of children: 0
23
+
Found child: ast
24
+
Reading library: ppxlib.ast
25
+
Number of children: 0
26
+
Found child: astlib
27
+
Reading library: ppxlib.astlib
28
+
Number of children: 0
29
+
Found child: metaquot
30
+
Reading library: ppxlib.metaquot
31
+
Number of children: 0
32
+
Found child: metaquot_lifters
33
+
Reading library: ppxlib.metaquot_lifters
34
+
Number of children: 0
35
+
Found child: print_diff
36
+
Reading library: ppxlib.print_diff
37
+
Number of children: 0
38
+
Found child: runner
39
+
Reading library: ppxlib.runner
40
+
Number of children: 0
41
+
Found child: runner_as_ppx
42
+
Reading library: ppxlib.runner_as_ppx
43
+
Number of children: 0
44
+
Found child: stdppx
45
+
Reading library: ppxlib.stdppx
46
+
Number of children: 0
47
+
Found child: traverse
48
+
Reading library: ppxlib.traverse
49
+
Number of children: 0
50
+
Found child: traverse_builtins
51
+
Reading library: ppxlib.traverse_builtins
52
+
Number of children: 0
53
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ppx_deriving/META
54
+
Parsed uri: ./lib/ppx_deriving/META
55
+
Reading library: ppx_deriving
56
+
Number of children: 12
57
+
Found child: api
58
+
Reading library: ppx_deriving.api
59
+
Number of children: 0
60
+
Found child: create
61
+
Reading library: ppx_deriving.create
62
+
Number of children: 0
63
+
Found child: enum
64
+
Reading library: ppx_deriving.enum
65
+
Number of children: 0
66
+
Found child: eq
67
+
Reading library: ppx_deriving.eq
68
+
Number of children: 0
69
+
Found child: fold
70
+
Reading library: ppx_deriving.fold
71
+
Number of children: 0
72
+
Found child: iter
73
+
Reading library: ppx_deriving.iter
74
+
Number of children: 0
75
+
Found child: make
76
+
Reading library: ppx_deriving.make
77
+
Number of children: 0
78
+
Found child: map
79
+
Reading library: ppx_deriving.map
80
+
Number of children: 0
81
+
Found child: ord
82
+
Reading library: ppx_deriving.ord
83
+
Number of children: 0
84
+
Found child: runtime
85
+
Reading library: ppx_deriving.runtime
86
+
Number of children: 0
87
+
Found child: show
88
+
Reading library: ppx_deriving.show
89
+
Number of children: 0
90
+
Found child: std
91
+
Reading library: ppx_deriving.std
92
+
Number of children: 0
93
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ppx_derivers/META
94
+
Parsed uri: ./lib/ppx_derivers/META
95
+
Reading library: ppx_derivers
96
+
Number of children: 0
97
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml_intrinsics_kernel/META
98
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
99
+
Reading library: ocaml_intrinsics_kernel
100
+
Number of children: 0
101
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml/stdlib/META
102
+
Parsed uri: ./lib/ocaml/stdlib/META
103
+
Reading library: stdlib
104
+
Number of children: 0
105
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml/compiler-libs/META
106
+
Parsed uri: ./lib/ocaml/compiler-libs/META
107
+
Reading library: compiler-libs
108
+
Number of children: 5
109
+
Found child: common
110
+
Reading library: compiler-libs.common
111
+
Number of children: 0
112
+
Found child: bytecomp
113
+
Reading library: compiler-libs.bytecomp
114
+
Number of children: 0
115
+
Found child: optcomp
116
+
Reading library: compiler-libs.optcomp
117
+
Number of children: 0
118
+
Found child: toplevel
119
+
Reading library: compiler-libs.toplevel
120
+
Number of children: 0
121
+
Found child: native-toplevel
122
+
Reading library: compiler-libs.native-toplevel
123
+
Number of children: 0
124
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml-compiler-libs/META
125
+
Parsed uri: ./lib/ocaml-compiler-libs/META
126
+
Reading library: ocaml-compiler-libs
127
+
Number of children: 5
128
+
Found child: bytecomp
129
+
Reading library: ocaml-compiler-libs.bytecomp
130
+
Number of children: 0
131
+
Found child: common
132
+
Reading library: ocaml-compiler-libs.common
133
+
Number of children: 0
134
+
Found child: optcomp
135
+
Reading library: ocaml-compiler-libs.optcomp
136
+
Number of children: 0
137
+
Found child: shadow
138
+
Reading library: ocaml-compiler-libs.shadow
139
+
Number of children: 0
140
+
Found child: toplevel
141
+
Reading library: ocaml-compiler-libs.toplevel
142
+
Number of children: 0
143
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/base/META
144
+
Parsed uri: ./lib/base/META
145
+
Reading library: base
146
+
Number of children: 3
147
+
Found child: base_internalhash_types
148
+
Reading library: base.base_internalhash_types
149
+
Number of children: 0
150
+
Found child: md5
151
+
Reading library: base.md5
152
+
Number of children: 0
153
+
Found child: shadow_stdlib
154
+
Reading library: base.shadow_stdlib
155
+
Number of children: 0
156
+
node_incremental_test.js: [INFO] sync_get: _opam/lib/ocaml/dynamic_cmis.json
157
+
node_incremental_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
158
+
node_incremental_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
159
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormat.cmi
160
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
161
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
162
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
163
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/std_exit.cmi
164
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
165
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
166
+
node_incremental_test.js: [INFO] init() finished
167
+
node_incremental_test.js: [INFO] setup() for env default...
168
+
node_incremental_test.js: [INFO] Fetching stdlib__Format.cmi
169
+
170
+
node_incremental_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Format.cmi
171
+
node_incremental_test.js: [INFO] Fetching stdlib__Sys.cmi
172
+
173
+
node_incremental_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Sys.cmi
174
+
error while evaluating #enable "pretty";;
175
+
error while evaluating #disable "shortvar";;
176
+
node_incremental_test.js: [INFO] Setup complete
177
+
node_incremental_test.js: [INFO] setup() finished for env default
178
+
node_incremental_test.js: [INFO] Setup complete, testing incremental output...
179
+
node_incremental_test.js: [INFO] Evaluating: let x = 1;; let y = 2;; let z = x + y;;
180
+
node_incremental_test.js: [INFO] execute_incremental() for env_id=
181
+
node_incremental_test.js: [INFO] OutputAt: loc=9 caml_ppf=val x : int = 1
182
+
node_incremental_test.js: [INFO] OutputAt: loc=21 caml_ppf=val y : int = 2
183
+
node_incremental_test.js: [INFO] OutputAt: loc=37 caml_ppf=val z : int = 3
184
+
node_incremental_test.js: [INFO] execute_incremental() done for env_id=
185
+
node_incremental_test.js: [INFO] Number of OutputAt callbacks: 3 (expected 3)
186
+
node_incremental_test.js: [INFO] PASS: Got expected number of callbacks
187
+
node_incremental_test.js: [INFO] PASS: Locations are in increasing order: 9, 21, 37
188
+
node_incremental_test.js: [INFO] Final result caml_ppf: <none>
189
+
node_incremental_test.js: [INFO] Final result stdout: <none>
190
+
node_incremental_test.js: [INFO] Test completed successfully
+140
js_top_worker/test/node/node_incremental_test.ml
+140
js_top_worker/test/node/node_incremental_test.ml
···
1
+
(* Test incremental output *)
2
+
open Js_top_worker
3
+
open Js_top_worker_rpc.Toplevel_api_gen
4
+
open Impl
5
+
6
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
7
+
fun f () ->
8
+
let stdout_buff = Buffer.create 1024 in
9
+
let stderr_buff = Buffer.create 1024 in
10
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
11
+
12
+
let x = f () in
13
+
let captured =
14
+
{
15
+
Impl.stdout = Buffer.contents stdout_buff;
16
+
stderr = Buffer.contents stderr_buff;
17
+
}
18
+
in
19
+
(captured, x)
20
+
21
+
module S : Impl.S = struct
22
+
type findlib_t = Js_top_worker_web.Findlibish.t
23
+
24
+
let capture = capture
25
+
26
+
let sync_get f =
27
+
let f = Fpath.v ("_opam/" ^ f) in
28
+
Logs.info (fun m -> m "sync_get: %a" Fpath.pp f);
29
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
30
+
with e ->
31
+
Logs.err (fun m ->
32
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
33
+
None
34
+
35
+
let async_get f =
36
+
let f = Fpath.v ("_opam/" ^ f) in
37
+
Logs.info (fun m -> m "async_get: %a" Fpath.pp f);
38
+
try
39
+
let content =
40
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
41
+
in
42
+
Lwt.return (Ok content)
43
+
with e ->
44
+
Logs.err (fun m ->
45
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
46
+
Lwt.return (Error (`Msg (Printexc.to_string e)))
47
+
48
+
let create_file = Js_of_ocaml.Sys_js.create_file
49
+
50
+
let import_scripts urls =
51
+
let open Js_of_ocaml.Js in
52
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
53
+
List.iter
54
+
(fun url ->
55
+
let (_ : 'a) =
56
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
57
+
in
58
+
())
59
+
urls
60
+
61
+
let init_function _ () = failwith "Not implemented"
62
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
63
+
64
+
let get_stdlib_dcs uri =
65
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
66
+
|> Result.to_list
67
+
68
+
let require b v = function
69
+
| [] -> []
70
+
| packages -> Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v packages
71
+
72
+
let path = "/static/cmis"
73
+
end
74
+
75
+
module U = Impl.Make (S)
76
+
77
+
let _ =
78
+
Logs.set_reporter (Logs_fmt.reporter ());
79
+
Logs.set_level (Some Logs.Info);
80
+
81
+
let ( let* ) = IdlM.ErrM.bind in
82
+
83
+
let init_config =
84
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
85
+
in
86
+
87
+
let x =
88
+
let* _ = IdlM.T.lift U.init init_config in
89
+
let* _ = IdlM.T.lift U.setup "" in
90
+
Logs.info (fun m -> m "Setup complete, testing incremental output...");
91
+
92
+
(* Test incremental output with multiple phrases *)
93
+
let phrase_outputs = ref [] in
94
+
let on_phrase_output (p : U.phrase_output) =
95
+
Logs.info (fun m -> m " OutputAt: loc=%d caml_ppf=%s"
96
+
p.loc
97
+
(Option.value ~default:"<none>" p.caml_ppf));
98
+
phrase_outputs := p :: !phrase_outputs
99
+
in
100
+
101
+
let code = "let x = 1;; let y = 2;; let z = x + y;;" in
102
+
Logs.info (fun m -> m "Evaluating: %s" code);
103
+
104
+
let* result = U.execute_incremental "" code ~on_phrase_output in
105
+
106
+
let num_callbacks = List.length !phrase_outputs in
107
+
Logs.info (fun m -> m "Number of OutputAt callbacks: %d (expected 3)" num_callbacks);
108
+
109
+
(* Verify we got 3 callbacks (one per phrase) *)
110
+
if num_callbacks <> 3 then
111
+
Logs.err (fun m -> m "FAIL: Expected 3 callbacks, got %d" num_callbacks)
112
+
else
113
+
Logs.info (fun m -> m "PASS: Got expected number of callbacks");
114
+
115
+
(* Verify the locations are increasing *)
116
+
let locs = List.rev_map (fun (p : U.phrase_output) -> p.loc) !phrase_outputs in
117
+
let sorted = List.sort compare locs in
118
+
if locs = sorted then
119
+
Logs.info (fun m -> m "PASS: Locations are in increasing order: %s"
120
+
(String.concat ", " (List.map string_of_int locs)))
121
+
else
122
+
Logs.err (fun m -> m "FAIL: Locations are not in order");
123
+
124
+
(* Verify final result has expected values *)
125
+
Logs.info (fun m -> m "Final result caml_ppf: %s"
126
+
(Option.value ~default:"<none>" result.caml_ppf));
127
+
Logs.info (fun m -> m "Final result stdout: %s"
128
+
(Option.value ~default:"<none>" result.stdout));
129
+
130
+
IdlM.ErrM.return ()
131
+
in
132
+
133
+
let promise = x |> IdlM.T.get in
134
+
match Lwt.state promise with
135
+
| Lwt.Return (Ok ()) -> Logs.info (fun m -> m "Test completed successfully")
136
+
| Lwt.Return (Error (InternalError s)) -> Logs.err (fun m -> m "Error: %s" s)
137
+
| Lwt.Fail e ->
138
+
Logs.err (fun m -> m "Unexpected failure: %s" (Printexc.to_string e))
139
+
| Lwt.Sleep ->
140
+
Logs.err (fun m -> m "Error: Promise is still pending")
+188
js_top_worker/test/node/node_mime_test.expected
+188
js_top_worker/test/node/node_mime_test.expected
···
1
+
=== Node.js MIME Infrastructure Tests ===
2
+
3
+
node_mime_test.js: [INFO] init()
4
+
Initializing findlib
5
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
6
+
Parsed uri: ./lib/stdlib-shims/META
7
+
Reading library: stdlib-shims
8
+
Number of children: 0
9
+
Parsed uri: ./lib/sexplib0/META
10
+
Reading library: sexplib0
11
+
Number of children: 0
12
+
Parsed uri: ./lib/ppxlib/META
13
+
Reading library: ppxlib
14
+
Number of children: 11
15
+
Found child: __private__
16
+
Reading library: ppxlib.__private__
17
+
Number of children: 1
18
+
Found child: ppx_foo_deriver
19
+
Reading library: ppxlib.__private__.ppx_foo_deriver
20
+
Number of children: 0
21
+
Found child: ast
22
+
Reading library: ppxlib.ast
23
+
Number of children: 0
24
+
Found child: astlib
25
+
Reading library: ppxlib.astlib
26
+
Number of children: 0
27
+
Found child: metaquot
28
+
Reading library: ppxlib.metaquot
29
+
Number of children: 0
30
+
Found child: metaquot_lifters
31
+
Reading library: ppxlib.metaquot_lifters
32
+
Number of children: 0
33
+
Found child: print_diff
34
+
Reading library: ppxlib.print_diff
35
+
Number of children: 0
36
+
Found child: runner
37
+
Reading library: ppxlib.runner
38
+
Number of children: 0
39
+
Found child: runner_as_ppx
40
+
Reading library: ppxlib.runner_as_ppx
41
+
Number of children: 0
42
+
Found child: stdppx
43
+
Reading library: ppxlib.stdppx
44
+
Number of children: 0
45
+
Found child: traverse
46
+
Reading library: ppxlib.traverse
47
+
Number of children: 0
48
+
Found child: traverse_builtins
49
+
Reading library: ppxlib.traverse_builtins
50
+
Number of children: 0
51
+
Parsed uri: ./lib/ppx_deriving/META
52
+
Reading library: ppx_deriving
53
+
Number of children: 12
54
+
Found child: api
55
+
Reading library: ppx_deriving.api
56
+
Number of children: 0
57
+
Found child: create
58
+
Reading library: ppx_deriving.create
59
+
Number of children: 0
60
+
Found child: enum
61
+
Reading library: ppx_deriving.enum
62
+
Number of children: 0
63
+
Found child: eq
64
+
Reading library: ppx_deriving.eq
65
+
Number of children: 0
66
+
Found child: fold
67
+
Reading library: ppx_deriving.fold
68
+
Number of children: 0
69
+
Found child: iter
70
+
Reading library: ppx_deriving.iter
71
+
Number of children: 0
72
+
Found child: make
73
+
Reading library: ppx_deriving.make
74
+
Number of children: 0
75
+
Found child: map
76
+
Reading library: ppx_deriving.map
77
+
Number of children: 0
78
+
Found child: ord
79
+
Reading library: ppx_deriving.ord
80
+
Number of children: 0
81
+
Found child: runtime
82
+
Reading library: ppx_deriving.runtime
83
+
Number of children: 0
84
+
Found child: show
85
+
Reading library: ppx_deriving.show
86
+
Number of children: 0
87
+
Found child: std
88
+
Reading library: ppx_deriving.std
89
+
Number of children: 0
90
+
Parsed uri: ./lib/ppx_derivers/META
91
+
Reading library: ppx_derivers
92
+
Number of children: 0
93
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
94
+
Reading library: ocaml_intrinsics_kernel
95
+
Number of children: 0
96
+
Parsed uri: ./lib/ocaml/stdlib/META
97
+
Reading library: stdlib
98
+
Number of children: 0
99
+
Parsed uri: ./lib/ocaml/compiler-libs/META
100
+
Reading library: compiler-libs
101
+
Number of children: 5
102
+
Found child: common
103
+
Reading library: compiler-libs.common
104
+
Number of children: 0
105
+
Found child: bytecomp
106
+
Reading library: compiler-libs.bytecomp
107
+
Number of children: 0
108
+
Found child: optcomp
109
+
Reading library: compiler-libs.optcomp
110
+
Number of children: 0
111
+
Found child: toplevel
112
+
Reading library: compiler-libs.toplevel
113
+
Number of children: 0
114
+
Found child: native-toplevel
115
+
Reading library: compiler-libs.native-toplevel
116
+
Number of children: 0
117
+
Parsed uri: ./lib/ocaml-compiler-libs/META
118
+
Reading library: ocaml-compiler-libs
119
+
Number of children: 5
120
+
Found child: bytecomp
121
+
Reading library: ocaml-compiler-libs.bytecomp
122
+
Number of children: 0
123
+
Found child: common
124
+
Reading library: ocaml-compiler-libs.common
125
+
Number of children: 0
126
+
Found child: optcomp
127
+
Reading library: ocaml-compiler-libs.optcomp
128
+
Number of children: 0
129
+
Found child: shadow
130
+
Reading library: ocaml-compiler-libs.shadow
131
+
Number of children: 0
132
+
Found child: toplevel
133
+
Reading library: ocaml-compiler-libs.toplevel
134
+
Number of children: 0
135
+
Parsed uri: ./lib/base/META
136
+
Reading library: base
137
+
Number of children: 3
138
+
Found child: base_internalhash_types
139
+
Reading library: base.base_internalhash_types
140
+
Number of children: 0
141
+
Found child: md5
142
+
Reading library: base.md5
143
+
Number of children: 0
144
+
Found child: shadow_stdlib
145
+
Reading library: base.shadow_stdlib
146
+
Number of children: 0
147
+
node_mime_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
+
node_mime_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
149
+
node_mime_test.js: [INFO] init() finished
150
+
node_mime_test.js: [INFO] setup() for env default...
151
+
node_mime_test.js: [INFO] Fetching stdlib__Format.cmi
152
+
153
+
node_mime_test.js: [INFO] Fetching stdlib__Sys.cmi
154
+
155
+
error while evaluating #enable "pretty";;
156
+
error while evaluating #disable "shortvar";;
157
+
node_mime_test.js: [INFO] Setup complete
158
+
node_mime_test.js: [INFO] setup() finished for env default
159
+
--- Section 1: exec_result Has mime_vals Field ---
160
+
node_mime_test.js: [INFO] execute() for env_id=
161
+
node_mime_test.js: [INFO] execute() done for env_id=
162
+
[PASS] has_mime_vals_field: exec_result has mime_vals field
163
+
[PASS] mime_vals_is_list: mime_vals is a list (length=0)
164
+
[PASS] mime_vals_empty_no_output: mime_vals is empty when no MIME output
165
+
166
+
--- Section 2: MIME Type Definitions ---
167
+
[PASS] mime_type_field: mime_val has mime_type field
168
+
[PASS] encoding_noencoding: Noencoding variant works
169
+
[PASS] data_field: mime_val has data field
170
+
[PASS] encoding_base64: Base64 variant works
171
+
172
+
--- Section 3: Multiple Executions ---
173
+
node_mime_test.js: [INFO] execute() for env_id=
174
+
node_mime_test.js: [INFO] execute() done for env_id=
175
+
node_mime_test.js: [INFO] execute() for env_id=
176
+
node_mime_test.js: [INFO] execute() done for env_id=
177
+
node_mime_test.js: [INFO] execute() for env_id=
178
+
node_mime_test.js: [INFO] execute() done for env_id=
179
+
[PASS] r1_mime_empty: First exec: mime_vals empty
180
+
[PASS] r2_mime_empty: Second exec: mime_vals empty
181
+
[PASS] r3_mime_empty: Third exec: mime_vals empty
182
+
183
+
--- Section 4: exec_toplevel Has mime_vals ---
184
+
[PASS] toplevel_has_mime_vals: exec_toplevel_result has mime_vals field
185
+
[PASS] toplevel_mime_vals_list: toplevel mime_vals is a list (length=0)
186
+
187
+
=== Results: 12/12 tests passed ===
188
+
SUCCESS: All MIME infrastructure tests passed!
+208
js_top_worker/test/node/node_mime_test.ml
+208
js_top_worker/test/node/node_mime_test.ml
···
1
+
(** Node.js test for MIME output infrastructure.
2
+
3
+
This tests that the MIME output infrastructure is wired up correctly:
4
+
- exec_result.mime_vals field is returned
5
+
- Field is empty when no MIME output occurs
6
+
- API types are correctly defined
7
+
8
+
Note: The mime_printer library is used internally by the worker to
9
+
capture MIME output. User code can call Mime_printer.push to produce
10
+
MIME values when the mime_printer package is loaded in the toplevel.
11
+
*)
12
+
13
+
open Js_top_worker
14
+
open Js_top_worker_rpc.Toplevel_api_gen
15
+
open Impl
16
+
17
+
(* Flusher that writes to process.stdout in Node.js *)
18
+
let console_flusher (s : string) : unit =
19
+
let open Js_of_ocaml in
20
+
let process = Js.Unsafe.get Js.Unsafe.global (Js.string "process") in
21
+
let stdout = Js.Unsafe.get process (Js.string "stdout") in
22
+
let write = Js.Unsafe.get stdout (Js.string "write") in
23
+
ignore (Js.Unsafe.call write stdout [| Js.Unsafe.inject (Js.string s) |])
24
+
25
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
26
+
fun f () ->
27
+
let stdout_buff = Buffer.create 1024 in
28
+
let stderr_buff = Buffer.create 1024 in
29
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
30
+
let x = f () in
31
+
let captured =
32
+
{
33
+
Impl.stdout = Buffer.contents stdout_buff;
34
+
stderr = Buffer.contents stderr_buff;
35
+
}
36
+
in
37
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
38
+
(captured, x)
39
+
40
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
41
+
42
+
module S : Impl.S = struct
43
+
type findlib_t = Js_top_worker_web.Findlibish.t
44
+
45
+
let capture = capture
46
+
47
+
let sync_get f =
48
+
let f = Fpath.v ("_opam/" ^ f) in
49
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
50
+
with _ -> None
51
+
52
+
let async_get f =
53
+
let f = Fpath.v ("_opam/" ^ f) in
54
+
try
55
+
let content =
56
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
57
+
in
58
+
Lwt.return (Ok content)
59
+
with e -> Lwt.return (Error (`Msg (Printexc.to_string e)))
60
+
61
+
let create_file = Js_of_ocaml.Sys_js.create_file
62
+
63
+
let import_scripts urls =
64
+
let open Js_of_ocaml.Js in
65
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
66
+
List.iter
67
+
(fun url ->
68
+
let (_ : 'a) =
69
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
70
+
in
71
+
())
72
+
urls
73
+
74
+
let init_function _ () = failwith "Not implemented"
75
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
76
+
77
+
let get_stdlib_dcs uri =
78
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
79
+
|> Result.to_list
80
+
81
+
let require b v = function
82
+
| [] -> []
83
+
| packages ->
84
+
Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v
85
+
packages
86
+
87
+
let path = "/static/cmis"
88
+
end
89
+
90
+
module U = Impl.Make (S)
91
+
92
+
let start_server () =
93
+
let open U in
94
+
Logs.set_reporter (Logs_fmt.reporter ());
95
+
Logs.set_level (Some Logs.Info);
96
+
Server.init (IdlM.T.lift init);
97
+
Server.create_env (IdlM.T.lift create_env);
98
+
Server.destroy_env (IdlM.T.lift destroy_env);
99
+
Server.list_envs (IdlM.T.lift list_envs);
100
+
Server.setup (IdlM.T.lift setup);
101
+
Server.exec execute;
102
+
Server.complete_prefix complete_prefix;
103
+
Server.query_errors query_errors;
104
+
Server.type_enclosing type_enclosing;
105
+
Server.exec_toplevel exec_toplevel;
106
+
IdlM.server Server.implementation
107
+
108
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
109
+
110
+
(* Test result tracking *)
111
+
let total_tests = ref 0
112
+
let passed_tests = ref 0
113
+
114
+
let test name check message =
115
+
incr total_tests;
116
+
let passed = check in
117
+
if passed then incr passed_tests;
118
+
let status = if passed then "PASS" else "FAIL" in
119
+
Printf.printf "[%s] %s: %s\n%!" status name message
120
+
121
+
let run_exec rpc code =
122
+
let ( let* ) = IdlM.ErrM.bind in
123
+
let* result = Client.exec rpc "" code in
124
+
IdlM.ErrM.return result
125
+
126
+
let _ =
127
+
Printf.printf "=== Node.js MIME Infrastructure Tests ===\n\n%!";
128
+
129
+
let rpc = start_server () in
130
+
let ( let* ) = IdlM.ErrM.bind in
131
+
132
+
let init_config =
133
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
134
+
in
135
+
136
+
let test_sequence =
137
+
(* Initialize *)
138
+
let* _ = Client.init rpc init_config in
139
+
let* _ = Client.setup rpc "" in
140
+
141
+
Printf.printf "--- Section 1: exec_result Has mime_vals Field ---\n%!";
142
+
143
+
(* Basic execution returns a result with mime_vals *)
144
+
let* r = run_exec rpc {|let x = 1 + 2;;|} in
145
+
test "has_mime_vals_field" true "exec_result has mime_vals field";
146
+
test "mime_vals_is_list" (List.length r.mime_vals >= 0)
147
+
(Printf.sprintf "mime_vals is a list (length=%d)" (List.length r.mime_vals));
148
+
test "mime_vals_empty_no_output" (List.length r.mime_vals = 0)
149
+
"mime_vals is empty when no MIME output";
150
+
151
+
Printf.printf "\n--- Section 2: MIME Type Definitions ---\n%!";
152
+
153
+
(* Verify API types are accessible *)
154
+
let mime_val_example : mime_val = {
155
+
mime_type = "text/html";
156
+
encoding = Noencoding;
157
+
data = "<b>test</b>";
158
+
} in
159
+
test "mime_type_field" (mime_val_example.mime_type = "text/html")
160
+
"mime_val has mime_type field";
161
+
test "encoding_noencoding" (mime_val_example.encoding = Noencoding)
162
+
"Noencoding variant works";
163
+
test "data_field" (mime_val_example.data = "<b>test</b>")
164
+
"mime_val has data field";
165
+
166
+
let mime_val_base64 : mime_val = {
167
+
mime_type = "image/png";
168
+
encoding = Base64;
169
+
data = "iVBORw0KGgo=";
170
+
} in
171
+
test "encoding_base64" (mime_val_base64.encoding = Base64)
172
+
"Base64 variant works";
173
+
174
+
Printf.printf "\n--- Section 3: Multiple Executions ---\n%!";
175
+
176
+
(* Verify mime_vals is fresh for each execution *)
177
+
let* r1 = run_exec rpc {|let a = 1;;|} in
178
+
let* r2 = run_exec rpc {|let b = 2;;|} in
179
+
let* r3 = run_exec rpc {|let c = 3;;|} in
180
+
test "r1_mime_empty" (List.length r1.mime_vals = 0) "First exec: mime_vals empty";
181
+
test "r2_mime_empty" (List.length r2.mime_vals = 0) "Second exec: mime_vals empty";
182
+
test "r3_mime_empty" (List.length r3.mime_vals = 0) "Third exec: mime_vals empty";
183
+
184
+
Printf.printf "\n--- Section 4: exec_toplevel Has mime_vals ---\n%!";
185
+
186
+
(* exec_toplevel also returns mime_vals *)
187
+
let* tr = Client.exec_toplevel rpc "" "# let z = 42;;" in
188
+
test "toplevel_has_mime_vals" true "exec_toplevel_result has mime_vals field";
189
+
test "toplevel_mime_vals_list" (List.length tr.mime_vals >= 0)
190
+
(Printf.sprintf "toplevel mime_vals is a list (length=%d)" (List.length tr.mime_vals));
191
+
192
+
IdlM.ErrM.return ()
193
+
in
194
+
195
+
let promise = test_sequence |> IdlM.T.get in
196
+
(match Lwt.state promise with
197
+
| Lwt.Return (Ok ()) -> ()
198
+
| Lwt.Return (Error (InternalError s)) ->
199
+
Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
200
+
| Lwt.Fail e ->
201
+
Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
202
+
| Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
203
+
204
+
Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
205
+
!total_tests;
206
+
if !passed_tests = !total_tests then
207
+
Printf.printf "SUCCESS: All MIME infrastructure tests passed!\n%!"
208
+
else Printf.printf "FAILURE: Some tests failed.\n%!"
+174
js_top_worker/test/node/node_ppx_test.expected
+174
js_top_worker/test/node/node_ppx_test.expected
···
1
+
=== Node.js PPX Tests ===
2
+
3
+
node_ppx_test.js: [INFO] init()
4
+
Initializing findlib
5
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
6
+
Parsed uri: ./lib/stdlib-shims/META
7
+
Reading library: stdlib-shims
8
+
Number of children: 0
9
+
Parsed uri: ./lib/sexplib0/META
10
+
Reading library: sexplib0
11
+
Number of children: 0
12
+
Parsed uri: ./lib/ppxlib/META
13
+
Reading library: ppxlib
14
+
Number of children: 11
15
+
Found child: __private__
16
+
Reading library: ppxlib.__private__
17
+
Number of children: 1
18
+
Found child: ppx_foo_deriver
19
+
Reading library: ppxlib.__private__.ppx_foo_deriver
20
+
Number of children: 0
21
+
Found child: ast
22
+
Reading library: ppxlib.ast
23
+
Number of children: 0
24
+
Found child: astlib
25
+
Reading library: ppxlib.astlib
26
+
Number of children: 0
27
+
Found child: metaquot
28
+
Reading library: ppxlib.metaquot
29
+
Number of children: 0
30
+
Found child: metaquot_lifters
31
+
Reading library: ppxlib.metaquot_lifters
32
+
Number of children: 0
33
+
Found child: print_diff
34
+
Reading library: ppxlib.print_diff
35
+
Number of children: 0
36
+
Found child: runner
37
+
Reading library: ppxlib.runner
38
+
Number of children: 0
39
+
Found child: runner_as_ppx
40
+
Reading library: ppxlib.runner_as_ppx
41
+
Number of children: 0
42
+
Found child: stdppx
43
+
Reading library: ppxlib.stdppx
44
+
Number of children: 0
45
+
Found child: traverse
46
+
Reading library: ppxlib.traverse
47
+
Number of children: 0
48
+
Found child: traverse_builtins
49
+
Reading library: ppxlib.traverse_builtins
50
+
Number of children: 0
51
+
Parsed uri: ./lib/ppx_deriving/META
52
+
Reading library: ppx_deriving
53
+
Number of children: 12
54
+
Found child: api
55
+
Reading library: ppx_deriving.api
56
+
Number of children: 0
57
+
Found child: create
58
+
Reading library: ppx_deriving.create
59
+
Number of children: 0
60
+
Found child: enum
61
+
Reading library: ppx_deriving.enum
62
+
Number of children: 0
63
+
Found child: eq
64
+
Reading library: ppx_deriving.eq
65
+
Number of children: 0
66
+
Found child: fold
67
+
Reading library: ppx_deriving.fold
68
+
Number of children: 0
69
+
Found child: iter
70
+
Reading library: ppx_deriving.iter
71
+
Number of children: 0
72
+
Found child: make
73
+
Reading library: ppx_deriving.make
74
+
Number of children: 0
75
+
Found child: map
76
+
Reading library: ppx_deriving.map
77
+
Number of children: 0
78
+
Found child: ord
79
+
Reading library: ppx_deriving.ord
80
+
Number of children: 0
81
+
Found child: runtime
82
+
Reading library: ppx_deriving.runtime
83
+
Number of children: 0
84
+
Found child: show
85
+
Reading library: ppx_deriving.show
86
+
Number of children: 0
87
+
Found child: std
88
+
Reading library: ppx_deriving.std
89
+
Number of children: 0
90
+
Parsed uri: ./lib/ppx_derivers/META
91
+
Reading library: ppx_derivers
92
+
Number of children: 0
93
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
94
+
Reading library: ocaml_intrinsics_kernel
95
+
Number of children: 0
96
+
Parsed uri: ./lib/ocaml/stdlib/META
97
+
Reading library: stdlib
98
+
Number of children: 0
99
+
Parsed uri: ./lib/ocaml/compiler-libs/META
100
+
Reading library: compiler-libs
101
+
Number of children: 5
102
+
Found child: common
103
+
Reading library: compiler-libs.common
104
+
Number of children: 0
105
+
Found child: bytecomp
106
+
Reading library: compiler-libs.bytecomp
107
+
Number of children: 0
108
+
Found child: optcomp
109
+
Reading library: compiler-libs.optcomp
110
+
Number of children: 0
111
+
Found child: toplevel
112
+
Reading library: compiler-libs.toplevel
113
+
Number of children: 0
114
+
Found child: native-toplevel
115
+
Reading library: compiler-libs.native-toplevel
116
+
Number of children: 0
117
+
Parsed uri: ./lib/ocaml-compiler-libs/META
118
+
Reading library: ocaml-compiler-libs
119
+
Number of children: 5
120
+
Found child: bytecomp
121
+
Reading library: ocaml-compiler-libs.bytecomp
122
+
Number of children: 0
123
+
Found child: common
124
+
Reading library: ocaml-compiler-libs.common
125
+
Number of children: 0
126
+
Found child: optcomp
127
+
Reading library: ocaml-compiler-libs.optcomp
128
+
Number of children: 0
129
+
Found child: shadow
130
+
Reading library: ocaml-compiler-libs.shadow
131
+
Number of children: 0
132
+
Found child: toplevel
133
+
Reading library: ocaml-compiler-libs.toplevel
134
+
Number of children: 0
135
+
Parsed uri: ./lib/base/META
136
+
Reading library: base
137
+
Number of children: 3
138
+
Found child: base_internalhash_types
139
+
Reading library: base.base_internalhash_types
140
+
Number of children: 0
141
+
Found child: md5
142
+
Reading library: base.md5
143
+
Number of children: 0
144
+
Found child: shadow_stdlib
145
+
Reading library: base.shadow_stdlib
146
+
Number of children: 0
147
+
node_ppx_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
+
node_ppx_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
149
+
node_ppx_test.js: [INFO] init() finished
150
+
node_ppx_test.js: [INFO] setup() for env default...
151
+
node_ppx_test.js: [INFO] Fetching stdlib__Format.cmi
152
+
153
+
node_ppx_test.js: [INFO] Fetching stdlib__Sys.cmi
154
+
155
+
error while evaluating #enable "pretty";;
156
+
error while evaluating #disable "shortvar";;
157
+
node_ppx_test.js: [INFO] Setup complete
158
+
node_ppx_test.js: [INFO] setup() finished for env default
159
+
--- Loading PPX dynamically ---
160
+
node_ppx_test.js: [INFO] Custom #require: loading ppx_deriving.show
161
+
Loading package ppx_deriving.show
162
+
lib.dir: show
163
+
Loading package ppx_deriving.runtime
164
+
lib.dir: runtime
165
+
uri: ./lib/ppx_deriving/runtime/dynamic_cmis.json
166
+
importScripts: ./lib/ppx_deriving/runtime/ppx_deriving_runtime.cma.js
167
+
Finished loading package ppx_deriving.runtime
168
+
Loading package ppx_deriving
169
+
lib.dir: None
170
+
uri: ./lib/ppx_deriving/dynamic_cmis.json
171
+
Failed to unmarshal dynamic_cms from url ./lib/ppx_deriving/dynamic_cmis.json: Failed to fetch dynamic cmis
172
+
uri: ./lib/ppx_deriving/show/dynamic_cmis.json
173
+
importScripts: ./lib/ppx_deriving/show/ppx_deriving_show.cma.js
174
+
node_ppx_test.js: [INFO] Error: TypeError: k is not a function
+259
js_top_worker/test/node/node_ppx_test.ml
+259
js_top_worker/test/node/node_ppx_test.ml
···
1
+
(** Node.js test for PPX preprocessing support.
2
+
3
+
This tests that the PPX preprocessing pipeline works correctly with
4
+
ppx_deriving. We verify that:
5
+
1. [@@deriving show] generates working pp and show functions
6
+
2. [@@deriving eq] generates working equal functions
7
+
3. Multiple derivers work together
8
+
4. Basic code still works through the PPX pipeline
9
+
10
+
The PPX pipeline in js_top_worker applies old-style Ast_mapper PPXs
11
+
followed by ppxlib-based PPXs via Ppxlib.Driver.map_structure.
12
+
*)
13
+
14
+
open Js_top_worker
15
+
open Js_top_worker_rpc.Toplevel_api_gen
16
+
open Impl
17
+
18
+
(* Flusher that writes to process.stdout in Node.js *)
19
+
let console_flusher (s : string) : unit =
20
+
let open Js_of_ocaml in
21
+
let process = Js.Unsafe.get Js.Unsafe.global (Js.string "process") in
22
+
let stdout = Js.Unsafe.get process (Js.string "stdout") in
23
+
let write = Js.Unsafe.get stdout (Js.string "write") in
24
+
ignore (Js.Unsafe.call write stdout [| Js.Unsafe.inject (Js.string s) |])
25
+
26
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
27
+
fun f () ->
28
+
let stdout_buff = Buffer.create 1024 in
29
+
let stderr_buff = Buffer.create 1024 in
30
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
31
+
let x = f () in
32
+
let captured =
33
+
{
34
+
Impl.stdout = Buffer.contents stdout_buff;
35
+
stderr = Buffer.contents stderr_buff;
36
+
}
37
+
in
38
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
39
+
(captured, x)
40
+
41
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
42
+
43
+
module S : Impl.S = struct
44
+
type findlib_t = Js_top_worker_web.Findlibish.t
45
+
46
+
let capture = capture
47
+
48
+
let sync_get f =
49
+
let f = Fpath.v ("_opam/" ^ f) in
50
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
51
+
with _ -> None
52
+
53
+
let async_get f =
54
+
let f = Fpath.v ("_opam/" ^ f) in
55
+
try
56
+
let content =
57
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
58
+
in
59
+
Lwt.return (Ok content)
60
+
with e -> Lwt.return (Error (`Msg (Printexc.to_string e)))
61
+
62
+
let create_file = Js_of_ocaml.Sys_js.create_file
63
+
64
+
let import_scripts urls =
65
+
let open Js_of_ocaml.Js in
66
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
67
+
List.iter
68
+
(fun url ->
69
+
let (_ : 'a) =
70
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
71
+
in
72
+
())
73
+
urls
74
+
75
+
let init_function _ () = failwith "Not implemented"
76
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
77
+
78
+
let get_stdlib_dcs uri =
79
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
80
+
|> Result.to_list
81
+
82
+
let require b v = function
83
+
| [] -> []
84
+
| packages -> Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v packages
85
+
86
+
let path = "/static/cmis"
87
+
end
88
+
89
+
module U = Impl.Make (S)
90
+
91
+
let start_server () =
92
+
let open U in
93
+
Logs.set_reporter (Logs_fmt.reporter ());
94
+
Logs.set_level (Some Logs.Info);
95
+
Server.init (IdlM.T.lift init);
96
+
Server.create_env (IdlM.T.lift create_env);
97
+
Server.destroy_env (IdlM.T.lift destroy_env);
98
+
Server.list_envs (IdlM.T.lift list_envs);
99
+
Server.setup (IdlM.T.lift setup);
100
+
Server.exec execute;
101
+
Server.complete_prefix complete_prefix;
102
+
Server.query_errors query_errors;
103
+
Server.type_enclosing type_enclosing;
104
+
Server.exec_toplevel exec_toplevel;
105
+
IdlM.server Server.implementation
106
+
107
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
108
+
109
+
(* Test state *)
110
+
let passed_tests = ref 0
111
+
let total_tests = ref 0
112
+
113
+
let test name condition message =
114
+
incr total_tests;
115
+
let status = if condition then (incr passed_tests; "PASS") else "FAIL" in
116
+
Printf.printf "[%s] %s: %s\n%!" status name message
117
+
118
+
let contains s substr =
119
+
try
120
+
let _ = Str.search_forward (Str.regexp_string substr) s 0 in
121
+
true
122
+
with Not_found -> false
123
+
124
+
let run_toplevel rpc code =
125
+
let ( let* ) = IdlM.ErrM.bind in
126
+
let* result = Client.exec_toplevel rpc "" ("# " ^ code) in
127
+
IdlM.ErrM.return result.script
128
+
129
+
let _ =
130
+
Printf.printf "=== Node.js PPX Tests ===\n\n%!";
131
+
132
+
let rpc = start_server () in
133
+
let ( let* ) = IdlM.ErrM.bind in
134
+
135
+
let init_config =
136
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
137
+
in
138
+
139
+
let test_sequence =
140
+
(* Initialize *)
141
+
let* _ = Client.init rpc init_config in
142
+
let* _ = Client.setup rpc "" in
143
+
144
+
Printf.printf "--- Loading PPX dynamically ---\n%!";
145
+
146
+
(* Dynamically load ppx_deriving.show - this should:
147
+
1. Load the PPX deriver (registers with ppxlib)
148
+
2. Auto-load ppx_deriving.runtime (via findlibish -ppx_driver predicate) *)
149
+
let* r = run_toplevel rpc "#require \"ppx_deriving.show\";;" in
150
+
test "load_ppx_show" (not (contains r "Error"))
151
+
(if contains r "Error" then r else "ppx_deriving.show loaded");
152
+
153
+
(* Also load eq deriver *)
154
+
let* r = run_toplevel rpc "#require \"ppx_deriving.eq\";;" in
155
+
test "load_ppx_eq" (not (contains r "Error"))
156
+
(if contains r "Error" then r else "ppx_deriving.eq loaded");
157
+
158
+
Printf.printf "\n--- Section 1: ppx_deriving.show ---\n%!";
159
+
160
+
(* Test [@@deriving show] generates pp and show functions *)
161
+
let* r = run_toplevel rpc "type color = Red | Green | Blue [@@deriving show];;" in
162
+
test "show_type_defined" (contains r "type color") "type color defined";
163
+
test "show_pp_generated" (contains r "val pp_color")
164
+
(if contains r "val pp_color" then "pp_color generated" else r);
165
+
test "show_fn_generated" (contains r "val show_color")
166
+
(if contains r "val show_color" then "show_color generated" else r);
167
+
168
+
(* Test the generated show function works *)
169
+
let* r = run_toplevel rpc "show_color Red;;" in
170
+
test "show_fn_works" (contains r "Red")
171
+
(String.sub r 0 (min 60 (String.length r)));
172
+
173
+
(* Test with a record type *)
174
+
let* r = run_toplevel rpc "type point = { x: int; y: int } [@@deriving show];;" in
175
+
test "show_record_type" (contains r "type point") "point type defined";
176
+
test "show_record_pp" (contains r "val pp_point")
177
+
(if contains r "val pp_point" then "pp_point generated" else r);
178
+
179
+
let* r = run_toplevel rpc "show_point { x = 10; y = 20 };;" in
180
+
test "show_record_works" (contains r "10" && contains r "20")
181
+
(String.sub r 0 (min 60 (String.length r)));
182
+
183
+
Printf.printf "\n--- Section 2: ppx_deriving.eq ---\n%!";
184
+
185
+
(* Test [@@deriving eq] generates equal function *)
186
+
let* r = run_toplevel rpc "type status = Active | Inactive [@@deriving eq];;" in
187
+
test "eq_type_defined" (contains r "type status") "status type defined";
188
+
test "eq_fn_generated" (contains r "val equal_status")
189
+
(if contains r "val equal_status" then "equal_status generated" else r);
190
+
191
+
(* Test the generated equal function works *)
192
+
let* r = run_toplevel rpc "equal_status Active Active;;" in
193
+
test "eq_same_true" (contains r "true") r;
194
+
195
+
let* r = run_toplevel rpc "equal_status Active Inactive;;" in
196
+
test "eq_diff_false" (contains r "false") r;
197
+
198
+
Printf.printf "\n--- Section 3: Combined Derivers ---\n%!";
199
+
200
+
(* Test multiple derivers on one type *)
201
+
let* r = run_toplevel rpc "type expr = Num of int | Add of expr * expr [@@deriving show, eq];;" in
202
+
test "combined_type" (contains r "type expr") "expr type defined";
203
+
test "combined_pp" (contains r "val pp_expr")
204
+
(if contains r "val pp_expr" then "pp_expr generated" else r);
205
+
test "combined_eq" (contains r "val equal_expr")
206
+
(if contains r "val equal_expr" then "equal_expr generated" else r);
207
+
208
+
(* Test they work together *)
209
+
let* r = run_toplevel rpc "let e1 = Add (Num 1, Num 2);;" in
210
+
test "combined_value" (contains r "val e1") r;
211
+
212
+
let* r = run_toplevel rpc "show_expr e1;;" in
213
+
test "combined_show_works" (contains r "Add" || contains r "Num")
214
+
(String.sub r 0 (min 80 (String.length r)));
215
+
216
+
let* r = run_toplevel rpc "equal_expr e1 e1;;" in
217
+
test "combined_eq_self" (contains r "true") r;
218
+
219
+
let* r = run_toplevel rpc "equal_expr e1 (Num 1);;" in
220
+
test "combined_eq_diff" (contains r "false") r;
221
+
222
+
Printf.printf "\n--- Section 4: Basic Code Still Works ---\n%!";
223
+
224
+
(* Verify normal code without PPX still works *)
225
+
let* r = run_toplevel rpc "let x = 1 + 2;;" in
226
+
test "basic_arithmetic" (contains r "val x : int = 3") r;
227
+
228
+
let* r = run_toplevel rpc "let rec fib n = if n <= 1 then n else fib (n-1) + fib (n-2);;" in
229
+
test "recursive_fn" (contains r "val fib : int -> int") r;
230
+
231
+
let* r = run_toplevel rpc "fib 10;;" in
232
+
test "fib_result" (contains r "55") r;
233
+
234
+
Printf.printf "\n--- Section 5: Module Support ---\n%!";
235
+
236
+
let* r = run_toplevel rpc "module M = struct type t = A | B [@@deriving show] end;;" in
237
+
test "module_with_deriving" (contains r "module M") r;
238
+
239
+
let* r = run_toplevel rpc "M.show_t M.A;;" in
240
+
test "module_show_works" (contains r "A")
241
+
(String.sub r 0 (min 60 (String.length r)));
242
+
243
+
IdlM.ErrM.return ()
244
+
in
245
+
246
+
let promise = test_sequence |> IdlM.T.get in
247
+
(match Lwt.state promise with
248
+
| Lwt.Return (Ok ()) -> ()
249
+
| Lwt.Return (Error (InternalError s)) ->
250
+
Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
251
+
| Lwt.Fail e ->
252
+
Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
253
+
| Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
254
+
255
+
Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
256
+
!total_tests;
257
+
if !passed_tests = !total_tests then
258
+
Printf.printf "SUCCESS: All PPX tests passed!\n%!"
259
+
else Printf.printf "FAILURE: Some tests failed.\n%!"
+202
js_top_worker/test/node/node_test.expected
+202
js_top_worker/test/node/node_test.expected
···
1
+
node_test.js: [INFO] init()
2
+
Initializing findlib
3
+
node_test.js: [INFO] async_get: _opam/findlib_index
4
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
5
+
node_test.js: [INFO] async_get: _opam/./lib/stdlib-shims/META
6
+
Parsed uri: ./lib/stdlib-shims/META
7
+
Reading library: stdlib-shims
8
+
Number of children: 0
9
+
node_test.js: [INFO] async_get: _opam/./lib/sexplib0/META
10
+
Parsed uri: ./lib/sexplib0/META
11
+
Reading library: sexplib0
12
+
Number of children: 0
13
+
node_test.js: [INFO] async_get: _opam/./lib/ppxlib/META
14
+
Parsed uri: ./lib/ppxlib/META
15
+
Reading library: ppxlib
16
+
Number of children: 11
17
+
Found child: __private__
18
+
Reading library: ppxlib.__private__
19
+
Number of children: 1
20
+
Found child: ppx_foo_deriver
21
+
Reading library: ppxlib.__private__.ppx_foo_deriver
22
+
Number of children: 0
23
+
Found child: ast
24
+
Reading library: ppxlib.ast
25
+
Number of children: 0
26
+
Found child: astlib
27
+
Reading library: ppxlib.astlib
28
+
Number of children: 0
29
+
Found child: metaquot
30
+
Reading library: ppxlib.metaquot
31
+
Number of children: 0
32
+
Found child: metaquot_lifters
33
+
Reading library: ppxlib.metaquot_lifters
34
+
Number of children: 0
35
+
Found child: print_diff
36
+
Reading library: ppxlib.print_diff
37
+
Number of children: 0
38
+
Found child: runner
39
+
Reading library: ppxlib.runner
40
+
Number of children: 0
41
+
Found child: runner_as_ppx
42
+
Reading library: ppxlib.runner_as_ppx
43
+
Number of children: 0
44
+
Found child: stdppx
45
+
Reading library: ppxlib.stdppx
46
+
Number of children: 0
47
+
Found child: traverse
48
+
Reading library: ppxlib.traverse
49
+
Number of children: 0
50
+
Found child: traverse_builtins
51
+
Reading library: ppxlib.traverse_builtins
52
+
Number of children: 0
53
+
node_test.js: [INFO] async_get: _opam/./lib/ppx_deriving/META
54
+
Parsed uri: ./lib/ppx_deriving/META
55
+
Reading library: ppx_deriving
56
+
Number of children: 12
57
+
Found child: api
58
+
Reading library: ppx_deriving.api
59
+
Number of children: 0
60
+
Found child: create
61
+
Reading library: ppx_deriving.create
62
+
Number of children: 0
63
+
Found child: enum
64
+
Reading library: ppx_deriving.enum
65
+
Number of children: 0
66
+
Found child: eq
67
+
Reading library: ppx_deriving.eq
68
+
Number of children: 0
69
+
Found child: fold
70
+
Reading library: ppx_deriving.fold
71
+
Number of children: 0
72
+
Found child: iter
73
+
Reading library: ppx_deriving.iter
74
+
Number of children: 0
75
+
Found child: make
76
+
Reading library: ppx_deriving.make
77
+
Number of children: 0
78
+
Found child: map
79
+
Reading library: ppx_deriving.map
80
+
Number of children: 0
81
+
Found child: ord
82
+
Reading library: ppx_deriving.ord
83
+
Number of children: 0
84
+
Found child: runtime
85
+
Reading library: ppx_deriving.runtime
86
+
Number of children: 0
87
+
Found child: show
88
+
Reading library: ppx_deriving.show
89
+
Number of children: 0
90
+
Found child: std
91
+
Reading library: ppx_deriving.std
92
+
Number of children: 0
93
+
node_test.js: [INFO] async_get: _opam/./lib/ppx_derivers/META
94
+
Parsed uri: ./lib/ppx_derivers/META
95
+
Reading library: ppx_derivers
96
+
Number of children: 0
97
+
node_test.js: [INFO] async_get: _opam/./lib/ocaml_intrinsics_kernel/META
98
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
99
+
Reading library: ocaml_intrinsics_kernel
100
+
Number of children: 0
101
+
node_test.js: [INFO] async_get: _opam/./lib/ocaml/stdlib/META
102
+
Parsed uri: ./lib/ocaml/stdlib/META
103
+
Reading library: stdlib
104
+
Number of children: 0
105
+
node_test.js: [INFO] async_get: _opam/./lib/ocaml/compiler-libs/META
106
+
Parsed uri: ./lib/ocaml/compiler-libs/META
107
+
Reading library: compiler-libs
108
+
Number of children: 5
109
+
Found child: common
110
+
Reading library: compiler-libs.common
111
+
Number of children: 0
112
+
Found child: bytecomp
113
+
Reading library: compiler-libs.bytecomp
114
+
Number of children: 0
115
+
Found child: optcomp
116
+
Reading library: compiler-libs.optcomp
117
+
Number of children: 0
118
+
Found child: toplevel
119
+
Reading library: compiler-libs.toplevel
120
+
Number of children: 0
121
+
Found child: native-toplevel
122
+
Reading library: compiler-libs.native-toplevel
123
+
Number of children: 0
124
+
node_test.js: [INFO] async_get: _opam/./lib/ocaml-compiler-libs/META
125
+
Parsed uri: ./lib/ocaml-compiler-libs/META
126
+
Reading library: ocaml-compiler-libs
127
+
Number of children: 5
128
+
Found child: bytecomp
129
+
Reading library: ocaml-compiler-libs.bytecomp
130
+
Number of children: 0
131
+
Found child: common
132
+
Reading library: ocaml-compiler-libs.common
133
+
Number of children: 0
134
+
Found child: optcomp
135
+
Reading library: ocaml-compiler-libs.optcomp
136
+
Number of children: 0
137
+
Found child: shadow
138
+
Reading library: ocaml-compiler-libs.shadow
139
+
Number of children: 0
140
+
Found child: toplevel
141
+
Reading library: ocaml-compiler-libs.toplevel
142
+
Number of children: 0
143
+
node_test.js: [INFO] async_get: _opam/./lib/base/META
144
+
Parsed uri: ./lib/base/META
145
+
Reading library: base
146
+
Number of children: 3
147
+
Found child: base_internalhash_types
148
+
Reading library: base.base_internalhash_types
149
+
Number of children: 0
150
+
Found child: md5
151
+
Reading library: base.md5
152
+
Number of children: 0
153
+
Found child: shadow_stdlib
154
+
Reading library: base.shadow_stdlib
155
+
Number of children: 0
156
+
node_test.js: [INFO] sync_get: _opam/lib/ocaml/dynamic_cmis.json
157
+
node_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
158
+
node_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
159
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormat.cmi
160
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
161
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
162
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
163
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/std_exit.cmi
164
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
165
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
166
+
node_test.js: [INFO] init() finished
167
+
node_test.js: [INFO] setup() for env default...
168
+
node_test.js: [INFO] Fetching stdlib__Format.cmi
169
+
170
+
node_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Format.cmi
171
+
node_test.js: [INFO] Fetching stdlib__Sys.cmi
172
+
173
+
node_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Sys.cmi
174
+
error while evaluating #enable "pretty";;
175
+
error while evaluating #disable "shortvar";;
176
+
node_test.js: [INFO] Setup complete
177
+
Loading package base
178
+
lib.dir: None
179
+
Loading package base.base_internalhash_types
180
+
lib.dir: base_internalhash_types
181
+
uri: ./lib/base/base_internalhash_types/dynamic_cmis.json
182
+
node_test.js: [INFO] sync_get: _opam/./lib/base/base_internalhash_types/dynamic_cmis.json
183
+
importScripts: ./lib/base/base_internalhash_types/base_internalhash_types.cma.js
184
+
Finished loading package base.base_internalhash_types
185
+
Loading package base.shadow_stdlib
186
+
lib.dir: shadow_stdlib
187
+
uri: ./lib/base/shadow_stdlib/dynamic_cmis.json
188
+
node_test.js: [INFO] sync_get: _opam/./lib/base/shadow_stdlib/dynamic_cmis.json
189
+
importScripts: ./lib/base/shadow_stdlib/shadow_stdlib.cma.js
190
+
Finished loading package base.shadow_stdlib
191
+
Loading package ocaml_intrinsics_kernel
192
+
lib.dir: None
193
+
uri: ./lib/ocaml_intrinsics_kernel/dynamic_cmis.json
194
+
node_test.js: [INFO] sync_get: _opam/./lib/ocaml_intrinsics_kernel/dynamic_cmis.json
195
+
importScripts: ./lib/ocaml_intrinsics_kernel/ocaml_intrinsics_kernel.cma.js
196
+
Finished loading package ocaml_intrinsics_kernel
197
+
Loading package sexplib0
198
+
lib.dir: None
199
+
uri: ./lib/sexplib0/dynamic_cmis.json
200
+
node_test.js: [INFO] sync_get: _opam/./lib/sexplib0/dynamic_cmis.json
201
+
importScripts: ./lib/sexplib0/sexplib0.cma.js
202
+
node_test.js: [ERROR] Error: TypeError: k is not a function
+352
js_top_worker/test/node/node_test.ml
+352
js_top_worker/test/node/node_test.ml
···
1
+
(* Unix worker *)
2
+
open Js_top_worker
3
+
open Js_top_worker_rpc.Toplevel_api_gen
4
+
open Impl
5
+
6
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
7
+
fun f () ->
8
+
let stdout_buff = Buffer.create 1024 in
9
+
let stderr_buff = Buffer.create 1024 in
10
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
11
+
12
+
let x = f () in
13
+
let captured =
14
+
{
15
+
Impl.stdout = Buffer.contents stdout_buff;
16
+
stderr = Buffer.contents stderr_buff;
17
+
}
18
+
in
19
+
(captured, x)
20
+
21
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
22
+
23
+
module S : Impl.S = struct
24
+
type findlib_t = Js_top_worker_web.Findlibish.t
25
+
26
+
let capture = capture
27
+
28
+
let sync_get f =
29
+
let f = Fpath.v ("_opam/" ^ f) in
30
+
Logs.info (fun m -> m "sync_get: %a" Fpath.pp f);
31
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
32
+
with e ->
33
+
Logs.err (fun m ->
34
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
35
+
None
36
+
37
+
let async_get f =
38
+
let f = Fpath.v ("_opam/" ^ f) in
39
+
Logs.info (fun m -> m "async_get: %a" Fpath.pp f);
40
+
(* For Node.js, we use synchronous file reading wrapped in Lwt *)
41
+
try
42
+
let content =
43
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
44
+
in
45
+
Lwt.return (Ok content)
46
+
with e ->
47
+
Logs.err (fun m ->
48
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
49
+
Lwt.return (Error (`Msg (Printexc.to_string e)))
50
+
51
+
let create_file = Js_of_ocaml.Sys_js.create_file
52
+
53
+
let import_scripts urls =
54
+
let open Js_of_ocaml.Js in
55
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
56
+
List.iter
57
+
(fun url ->
58
+
let (_ : 'a) =
59
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
60
+
in
61
+
())
62
+
urls
63
+
64
+
let init_function _ () = failwith "Not implemented"
65
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
66
+
67
+
let get_stdlib_dcs uri =
68
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
69
+
|> Result.to_list
70
+
71
+
let require b v = function
72
+
| [] -> []
73
+
| packages -> Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v packages
74
+
75
+
let path = "/static/cmis"
76
+
end
77
+
78
+
module U = Impl.Make (S)
79
+
80
+
let start_server () =
81
+
let open U in
82
+
Logs.set_reporter (Logs_fmt.reporter ());
83
+
Logs.set_level (Some Logs.Info);
84
+
(* let pid = Unix.getpid () in *)
85
+
Server.init (IdlM.T.lift init);
86
+
Server.create_env (IdlM.T.lift create_env);
87
+
Server.destroy_env (IdlM.T.lift destroy_env);
88
+
Server.list_envs (IdlM.T.lift list_envs);
89
+
Server.setup (IdlM.T.lift setup);
90
+
Server.exec execute;
91
+
Server.complete_prefix complete_prefix;
92
+
Server.query_errors query_errors;
93
+
Server.type_enclosing type_enclosing;
94
+
Server.exec_toplevel exec_toplevel;
95
+
IdlM.server Server.implementation
96
+
97
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
98
+
99
+
let _ =
100
+
Logs.info (fun m -> m "Starting server...");
101
+
let rpc = start_server () in
102
+
let ( let* ) = IdlM.ErrM.bind in
103
+
let init_config =
104
+
Js_top_worker_rpc.Toplevel_api_gen.
105
+
{ stdlib_dcs = None; findlib_requires = [ "base" ]; findlib_index = None; execute = true }
106
+
in
107
+
let x =
108
+
let open Client in
109
+
let* _ = init rpc init_config in
110
+
let* o = setup rpc "" in
111
+
Logs.info (fun m ->
112
+
m "setup output: %s" (Option.value ~default:"" o.stdout));
113
+
let* _ = query_errors rpc "" (Some "c1") [] false "type xxxx = int;;\n" in
114
+
let* o1 =
115
+
query_errors rpc "" (Some "c2") [ "c1" ] false "type yyy = xxx;;\n"
116
+
in
117
+
Logs.info (fun m -> m "Number of errors: %d (should be 1)" (List.length o1));
118
+
let* _ = query_errors rpc "" (Some "c1") [] false "type xxx = int;;\n" in
119
+
let* o2 =
120
+
query_errors rpc "" (Some "c2") [ "c1" ] false "type yyy = xxx;;\n"
121
+
in
122
+
Logs.info (fun m ->
123
+
m "Number of errors1: %d (should be 1)" (List.length o1));
124
+
Logs.info (fun m ->
125
+
m "Number of errors2: %d (should be 0)" (List.length o2));
126
+
127
+
(* Test completion for List.leng *)
128
+
let* completions1 =
129
+
let text = "let _ = List.leng" in
130
+
Client.complete_prefix rpc "" (Some "c_comp1") [] false text
131
+
(Offset (String.length text))
132
+
in
133
+
Logs.info (fun m ->
134
+
m "Completions for 'List.leng': %d entries"
135
+
(List.length completions1.entries));
136
+
List.iter
137
+
(fun entry ->
138
+
Logs.info (fun m ->
139
+
m " - %s (%s): %s" entry.name
140
+
(match entry.kind with
141
+
| Constructor -> "Constructor"
142
+
| Keyword -> "Keyword"
143
+
| Label -> "Label"
144
+
| MethodCall -> "MethodCall"
145
+
| Modtype -> "Modtype"
146
+
| Module -> "Module"
147
+
| Type -> "Type"
148
+
| Value -> "Value"
149
+
| Variant -> "Variant")
150
+
entry.desc))
151
+
completions1.entries;
152
+
153
+
(* Test completion for List. (should show all List module functions) *)
154
+
let* completions2 =
155
+
let text = "# let _ = List." in
156
+
Client.complete_prefix rpc "" (Some "c_comp2") [] true text
157
+
(Offset (String.length text))
158
+
in
159
+
Logs.info (fun m ->
160
+
m "Completions for 'List.': %d entries"
161
+
(List.length completions2.entries));
162
+
List.iter
163
+
(fun entry ->
164
+
Logs.info (fun m ->
165
+
m " - %s (%s): %s" entry.name
166
+
(match entry.kind with
167
+
| Constructor -> "Constructor"
168
+
| Keyword -> "Keyword"
169
+
| Label -> "Label"
170
+
| MethodCall -> "MethodCall"
171
+
| Modtype -> "Modtype"
172
+
| Module -> "Module"
173
+
| Type -> "Type"
174
+
| Value -> "Value"
175
+
| Variant -> "Variant")
176
+
entry.desc))
177
+
completions2.entries;
178
+
179
+
(* Test completion for partial identifier *)
180
+
let* completions3 =
181
+
let text = "# let _ = ma" in
182
+
Client.complete_prefix rpc "" (Some "c_comp3") [] true text
183
+
(Offset (String.length text))
184
+
in
185
+
Logs.info (fun m ->
186
+
m "Completions for 'ma': %d entries" (List.length completions3.entries));
187
+
List.iter
188
+
(fun entry ->
189
+
Logs.info (fun m ->
190
+
m " - %s (%s): %s" entry.name
191
+
(match entry.kind with
192
+
| Constructor -> "Constructor"
193
+
| Keyword -> "Keyword"
194
+
| Label -> "Label"
195
+
| MethodCall -> "MethodCall"
196
+
| Modtype -> "Modtype"
197
+
| Module -> "Module"
198
+
| Type -> "Type"
199
+
| Value -> "Value"
200
+
| Variant -> "Variant")
201
+
entry.desc))
202
+
completions3.entries;
203
+
204
+
(* Test completion in non-toplevel context *)
205
+
let* completions4 =
206
+
let text = "let _ = List.leng" in
207
+
Client.complete_prefix rpc "" (Some "c_comp4") [] false text
208
+
(Offset (String.length text))
209
+
in
210
+
Logs.info (fun m ->
211
+
m "Completions for 'List.leng' (non-toplevel): %d entries"
212
+
(List.length completions4.entries));
213
+
List.iter
214
+
(fun entry ->
215
+
Logs.info (fun m ->
216
+
m " - %s (%s): %s" entry.name
217
+
(match entry.kind with
218
+
| Constructor -> "Constructor"
219
+
| Keyword -> "Keyword"
220
+
| Label -> "Label"
221
+
| MethodCall -> "MethodCall"
222
+
| Modtype -> "Modtype"
223
+
| Module -> "Module"
224
+
| Type -> "Type"
225
+
| Value -> "Value"
226
+
| Variant -> "Variant")
227
+
entry.desc))
228
+
completions4.entries;
229
+
230
+
(* Test completion using Logical position constructor *)
231
+
let* completions5 =
232
+
let text = "# let _ = List.leng\n let foo=1.0;;" in
233
+
Client.complete_prefix rpc "" (Some "c_comp5") [] true text
234
+
(Logical (1, 16))
235
+
in
236
+
Logs.info (fun m ->
237
+
m "Completions for 'List.leng' (Logical position): %d entries"
238
+
(List.length completions5.entries));
239
+
List.iter
240
+
(fun entry ->
241
+
Logs.info (fun m ->
242
+
m " - %s (%s): %s" entry.name
243
+
(match entry.kind with
244
+
| Constructor -> "Constructor"
245
+
| Keyword -> "Keyword"
246
+
| Label -> "Label"
247
+
| MethodCall -> "MethodCall"
248
+
| Modtype -> "Modtype"
249
+
| Module -> "Module"
250
+
| Type -> "Type"
251
+
| Value -> "Value"
252
+
| Variant -> "Variant")
253
+
entry.desc))
254
+
completions5.entries;
255
+
256
+
(* Test toplevel completion with variable binding *)
257
+
let* completions6 =
258
+
let s = "# let my_var = 42;;\n# let x = 1 + my_v" in
259
+
Client.complete_prefix rpc "" (Some "c_comp6") [] true
260
+
s
261
+
(Offset (String.length s))
262
+
in
263
+
Logs.info (fun m ->
264
+
m "Completions for 'my_v' (toplevel variable): %d entries"
265
+
(List.length completions6.entries));
266
+
List.iter
267
+
(fun entry ->
268
+
Logs.info (fun m ->
269
+
m " - %s (%s): %s" entry.name
270
+
(match entry.kind with
271
+
| Constructor -> "Constructor"
272
+
| Keyword -> "Keyword"
273
+
| Label -> "Label"
274
+
| MethodCall -> "MethodCall"
275
+
| Modtype -> "Modtype"
276
+
| Module -> "Module"
277
+
| Type -> "Type"
278
+
| Value -> "Value"
279
+
| Variant -> "Variant")
280
+
entry.desc))
281
+
completions6.entries;
282
+
283
+
(* Test toplevel completion with function definition *)
284
+
let* completions7 =
285
+
Client.complete_prefix rpc "" (Some "c_comp7") [] true
286
+
"# let rec factorial n = if n <= 1 then 1 else n * facto"
287
+
(Offset 55)
288
+
in
289
+
Logs.info (fun m ->
290
+
m "Completions for 'facto' (recursive function): %d entries"
291
+
(List.length completions7.entries));
292
+
List.iter
293
+
(fun entry ->
294
+
Logs.info (fun m ->
295
+
m " - %s (%s): %s" entry.name
296
+
(match entry.kind with
297
+
| Constructor -> "Constructor"
298
+
| Keyword -> "Keyword"
299
+
| Label -> "Label"
300
+
| MethodCall -> "MethodCall"
301
+
| Modtype -> "Modtype"
302
+
| Module -> "Module"
303
+
| Type -> "Type"
304
+
| Value -> "Value"
305
+
| Variant -> "Variant")
306
+
entry.desc))
307
+
completions7.entries;
308
+
309
+
(* Test toplevel completion with module paths *)
310
+
let* completions8 =
311
+
Client.complete_prefix rpc "" (Some "c_comp8") [] true
312
+
"# String.lengt"
313
+
(Offset 14)
314
+
in
315
+
Logs.info (fun m ->
316
+
m "Completions for 'String.lengt' (module path): %d entries"
317
+
(List.length completions8.entries));
318
+
List.iter
319
+
(fun entry ->
320
+
Logs.info (fun m ->
321
+
m " - %s (%s): %s" entry.name
322
+
(match entry.kind with
323
+
| Constructor -> "Constructor"
324
+
| Keyword -> "Keyword"
325
+
| Label -> "Label"
326
+
| MethodCall -> "MethodCall"
327
+
| Modtype -> "Modtype"
328
+
| Module -> "Module"
329
+
| Type -> "Type"
330
+
| Value -> "Value"
331
+
| Variant -> "Variant")
332
+
entry.desc))
333
+
completions8.entries;
334
+
335
+
(* let* o3 =
336
+
Client.exec_toplevel rpc
337
+
"# Stringext.of_list ['a';'b';'c'];;\n" in
338
+
Logs.info (fun m -> m "Exec toplevel output: %s" o3.script); *)
339
+
IdlM.ErrM.return ()
340
+
in
341
+
(* The operations are actually synchronous in this test context *)
342
+
let promise = x |> IdlM.T.get in
343
+
match Lwt.state promise with
344
+
| Lwt.Return (Ok ()) -> Logs.info (fun m -> m "Success")
345
+
| Lwt.Return (Error (InternalError s)) -> Logs.err (fun m -> m "Error: %s" s)
346
+
| Lwt.Fail e ->
347
+
Logs.err (fun m -> m "Unexpected failure: %s" (Printexc.to_string e))
348
+
| Lwt.Sleep ->
349
+
Logs.err (fun m ->
350
+
m
351
+
"Error: Promise is still pending (should not happen in sync \
352
+
context)")
+187
js_top_worker/test/ohc-integration/SETUP.md
+187
js_top_worker/test/ohc-integration/SETUP.md
···
1
+
# OHC Integration Demos & Tutorials — Setup Guide
2
+
3
+
## Overview
4
+
5
+
This directory contains browser-based demos that run OCaml code in a web worker,
6
+
loading real opam packages compiled to JavaScript. The tutorials cover 30 versions
7
+
of Daniel Bunzli's OCaml libraries with interactive, step-by-step examples.
8
+
9
+
## Prerequisites
10
+
11
+
- **day10** (formerly ohc) — the build tool that produces JTW artifacts
12
+
- **js_top_worker** — this repo, providing the client library and worker
13
+
- **Python 3** — for serving files over HTTP
14
+
- **Node.js + npm** — for running Playwright tests (optional)
15
+
16
+
## Repositories & Commits
17
+
18
+
| Repo | URL | Branch | Commit |
19
+
|------|-----|--------|--------|
20
+
| **day10** | `git@github.com:jonludlam/ohc` | `feature/jtw-support` | `e6fb848` |
21
+
| **js_top_worker** | `https://github.com/jonnyfiveisonline/js_top_worker` | `enhancements` | `538ab03` |
22
+
23
+
## Step 1: Build js_top_worker
24
+
25
+
```bash
26
+
git clone https://github.com/jonnyfiveisonline/js_top_worker.git
27
+
cd js_top_worker
28
+
git checkout enhancements
29
+
dune build
30
+
```
31
+
32
+
This produces `_build/default/client/ocaml-worker.js` — the browser client library.
33
+
34
+
Create a convenience symlink (if not already present):
35
+
36
+
```bash
37
+
ln -sf _build/default/client client
38
+
```
39
+
40
+
## Step 2: Build JTW Output with day10
41
+
42
+
day10 builds opam packages and compiles them to JavaScript artifacts that the
43
+
browser worker can load.
44
+
45
+
```bash
46
+
git clone git@github.com:jonludlam/ohc day10
47
+
cd day10
48
+
git checkout feature/jtw-support # commit e6fb848
49
+
opam install dockerfile ppx_deriving_yojson opam-0install
50
+
dune build bin/main.exe
51
+
```
52
+
53
+
### Run a health-check for a single package
54
+
55
+
```bash
56
+
./day10 health-check --with-jtw --jtw-output /path/to/jtw-output fmt
57
+
```
58
+
59
+
### Run a batch build for all Bunzli libraries
60
+
61
+
Create a batch file `bunzli.txt` with one package per line:
62
+
63
+
```
64
+
fmt
65
+
cmdliner
66
+
mtime
67
+
logs
68
+
uucp
69
+
uunf
70
+
astring
71
+
jsonm
72
+
xmlm
73
+
ptime
74
+
react
75
+
hmap
76
+
gg
77
+
vg
78
+
note
79
+
otfm
80
+
fpath
81
+
uutf
82
+
b0
83
+
bos
84
+
```
85
+
86
+
Then run:
87
+
88
+
```bash
89
+
./day10 batch --with-jtw --jtw-output /path/to/jtw-output bunzli.txt
90
+
```
91
+
92
+
This produces the JTW output directory with the structure:
93
+
94
+
```
95
+
jtw-output/
96
+
compiler/
97
+
5.4.0/
98
+
worker.js # OCaml toplevel worker (~21MB)
99
+
lib/ocaml/
100
+
dynamic_cmis.json # Stdlib module index
101
+
*.cmi, stdlib.cma.js # Stdlib artifacts
102
+
u/<universe-hash>/ # One per (package, version) universe
103
+
findlib_index # JSON: list of META file paths
104
+
<pkg>/<ver>/lib/<findlib>/ # Package artifacts
105
+
META, *.cmi, *.cma.js, dynamic_cmis.json
106
+
p/<pkg>/<ver>/lib/... # Blessed packages (same structure)
107
+
```
108
+
109
+
## Step 3: Symlink JTW Output into js_top_worker
110
+
111
+
```bash
112
+
cd /path/to/js_top_worker
113
+
ln -sf /path/to/jtw-output jtw-output
114
+
```
115
+
116
+
## Step 4: Start the HTTP Server
117
+
118
+
```bash
119
+
cd /path/to/js_top_worker
120
+
python3 -m http.server 8769
121
+
```
122
+
123
+
## Step 5: Open in Browser
124
+
125
+
| Page | URL |
126
+
|------|-----|
127
+
| **Tutorial index** | http://localhost:8769/test/ohc-integration/tutorials/index.html |
128
+
| **Single tutorial** | http://localhost:8769/test/ohc-integration/tutorials/tutorial.html?pkg=fmt.0.11.0 |
129
+
| **Test runner** | http://localhost:8769/test/ohc-integration/runner.html |
130
+
| **Basic eval test** | http://localhost:8769/test/ohc-integration/test.html?universe=HASH |
131
+
132
+
The tutorial index page lists all 30 library-version tutorials grouped by library.
133
+
Click any version card to open its interactive tutorial.
134
+
135
+
## Step 6: Run Automated Tests (Optional)
136
+
137
+
```bash
138
+
cd /path/to/js_top_worker/test/ohc-integration
139
+
npm install
140
+
npx playwright install chromium
141
+
npx playwright test tutorials/tutorials.spec.js # 31 tutorial tests
142
+
npx playwright test bunzli-libs.spec.js # 37 library tests
143
+
npx playwright test # all tests
144
+
```
145
+
146
+
## Available Tutorials
147
+
148
+
| Library | Versions | Topics |
149
+
|---------|----------|--------|
150
+
| Fmt | 0.9.0, 0.10.0, 0.11.0 | String formatting, typed formatters, collections, combinators |
151
+
| Cmdliner | 1.0.4, 1.3.0, 2.0.0, 2.1.0 | Argument building, Term API (v1), Cmd API (v2), custom converters |
152
+
| Mtime | 1.3.0, 1.4.0, 2.1.0 | Span constants, arithmetic, float conversions, API evolution |
153
+
| Logs | 0.10.0 | Log sources, level management, error tracking |
154
+
| Uucp | 14.0.0, 15.0.0, 16.0.0, 17.0.0 | Unicode properties, general category, script detection |
155
+
| Uunf | 14.0.0, 17.0.0 | Unicode normalization forms (NFC/NFD/NFKC/NFKD) |
156
+
| Astring | 0.8.5 | Splitting, building, testing, trimming, substrings |
157
+
| Jsonm | 1.0.2 | Streaming JSON decode/encode |
158
+
| Xmlm | 1.4.0 | Streaming XML parse/output |
159
+
| Ptime | 1.2.0 | POSIX timestamps, arithmetic, RFC 3339 formatting |
160
+
| React | 1.2.2 | FRP signals, events, derived signals |
161
+
| Hmap | 0.8.1 | Type-safe heterogeneous maps |
162
+
| Gg | 1.0.0 | 2D/3D vectors, colors, arithmetic |
163
+
| Vg | 0.9.5 | Declarative 2D vector graphics |
164
+
| Note | 0.0.3 | Reactive signals, transformations |
165
+
| Otfm | 0.4.0 | OpenType font decoder |
166
+
| Fpath | 0.7.3 | File system path manipulation |
167
+
| Uutf | 1.0.4 | UTF-8 streaming codec |
168
+
| B0 | 0.0.6 | File paths (B0_std.Fpath), command lines (B0_std.Cmd) |
169
+
| Bos | 0.2.1 | OS command construction, conditional args |
170
+
171
+
## Universe Hashes
172
+
173
+
Each (package, version) maps to a universe hash that identifies the exact set of
174
+
dependencies. These are defined in `tutorials/test-defs.js` and `runner.html`.
175
+
The hashes are deterministic — they will be the same on any machine that builds
176
+
the same package version with day10.
177
+
178
+
## Troubleshooting
179
+
180
+
- **"Failed to initialize"**: Check that `jtw-output/compiler/5.4.0/worker.js` exists
181
+
and the HTTP server root is the js_top_worker repo root.
182
+
- **"inconsistent assumptions over interface"**: The package's build universe has
183
+
a cmi mismatch. Rebuild with day10. (Known issue: logs 0.7.0)
184
+
- **Timeout loading packages**: Some large packages (uucp, gg, vg) take several
185
+
seconds to load. The default timeout is 120 seconds.
186
+
- **Port conflict**: Change the port in the `python3 -m http.server` command.
187
+
For Playwright tests, also update `playwright.config.js`.
+71
js_top_worker/test/ohc-integration/eval-test.html
+71
js_top_worker/test/ohc-integration/eval-test.html
···
1
+
<!DOCTYPE html>
2
+
<html>
3
+
<head>
4
+
<meta charset="utf-8">
5
+
<title>JTW Eval Test</title>
6
+
</head>
7
+
<body>
8
+
<h1>JTW Eval Test</h1>
9
+
<div id="status">Loading...</div>
10
+
<pre id="log"></pre>
11
+
<script type="module">
12
+
import { OcamlWorker } from '/client/ocaml-worker.js';
13
+
14
+
const status = document.getElementById('status');
15
+
const logEl = document.getElementById('log');
16
+
17
+
function log(msg) {
18
+
logEl.textContent += msg + '\n';
19
+
console.log(msg);
20
+
}
21
+
22
+
const params = new URLSearchParams(window.location.search);
23
+
const universe = params.get('universe');
24
+
const compilerVersion = params.get('compiler') || '5.4.0';
25
+
26
+
if (!universe) {
27
+
status.textContent = 'Error: ?universe= parameter required';
28
+
status.dataset.error = 'universe parameter required';
29
+
throw new Error('universe parameter required');
30
+
}
31
+
32
+
status.textContent = 'Fetching findlib_index...';
33
+
const indexUrl = `/jtw-output/u/${universe}/findlib_index`;
34
+
const { worker, stdlib_dcs, findlib_index } = await OcamlWorker.fromIndex(
35
+
indexUrl, '/jtw-output', { timeout: 120000 });
36
+
37
+
try {
38
+
status.textContent = 'Initializing...';
39
+
await worker.init({
40
+
findlib_requires: [],
41
+
stdlib_dcs: stdlib_dcs,
42
+
findlib_index: findlib_index,
43
+
});
44
+
45
+
status.textContent = 'Ready';
46
+
status.dataset.ready = 'true';
47
+
48
+
// Expose eval/complete/require on window for Playwright
49
+
window.workerEval = async (code) => {
50
+
const result = await worker.eval(code);
51
+
return {
52
+
caml_ppf: result.caml_ppf || '',
53
+
stdout: result.stdout || '',
54
+
stderr: result.stderr || '',
55
+
};
56
+
};
57
+
58
+
window.workerComplete = async (source, pos) => {
59
+
const result = await worker.complete(source, pos);
60
+
const entries = result.completions?.entries || [];
61
+
return entries.map(e => e.name);
62
+
};
63
+
64
+
} catch (err) {
65
+
status.textContent = 'Error: ' + err.message;
66
+
status.dataset.error = err.message;
67
+
log('ERROR: ' + err.message);
68
+
}
69
+
</script>
70
+
</body>
71
+
</html>
+645
js_top_worker/test/ohc-integration/library-tests.spec.js
+645
js_top_worker/test/ohc-integration/library-tests.spec.js
···
1
+
// @ts-check
2
+
const { test, expect } = require('@playwright/test');
3
+
4
+
// ── Helpers ──────────────────────────────────────────────────────────────────
5
+
6
+
/** Navigate to eval-test.html, wait for worker ready, return page */
7
+
async function initWorker(page, universe, compiler = '5.4.0') {
8
+
const logs = [];
9
+
page.on('console', msg => logs.push(msg.text()));
10
+
11
+
await page.goto(
12
+
`/test/ohc-integration/eval-test.html?universe=${universe}&compiler=${compiler}`
13
+
);
14
+
15
+
// Wait for worker to be ready
16
+
await expect(async () => {
17
+
const ready = await page.locator('#status').getAttribute('data-ready');
18
+
const error = await page.locator('#status').getAttribute('data-error');
19
+
if (error) throw new Error(`Worker init failed: ${error}`);
20
+
expect(ready).toBe('true');
21
+
}).toPass({ timeout: 90000 });
22
+
23
+
return { logs };
24
+
}
25
+
26
+
/** Evaluate OCaml code and return { caml_ppf, stdout, stderr } */
27
+
async function evalCode(page, code) {
28
+
return await page.evaluate(async (c) => await window.workerEval(c), code);
29
+
}
30
+
31
+
/** #require a package, return result */
32
+
async function requirePkg(page, pkg) {
33
+
return await evalCode(page, `#require "${pkg}";;`);
34
+
}
35
+
36
+
/** Evaluate and expect caml_ppf to contain a substring */
37
+
async function evalExpect(page, code, expected) {
38
+
const r = await evalCode(page, code);
39
+
expect(r.caml_ppf).toContain(expected);
40
+
return r;
41
+
}
42
+
43
+
/** Evaluate and expect caml_ppf NOT to contain a substring (error case) */
44
+
async function evalExpectError(page, code) {
45
+
const r = await evalCode(page, code);
46
+
// Errors go to stderr, caml_ppf is usually empty or contains Error
47
+
return r;
48
+
}
49
+
50
+
// ── Universe mapping ─────────────────────────────────────────────────────────
51
+
52
+
const U = {
53
+
// fmt versions
54
+
'fmt.0.9.0': '9901393f978b0a6627c5eab595111f50',
55
+
'fmt.0.10.0': 'd8140118651d08430f933d410a909e3b',
56
+
'fmt.0.11.0': '7663cce356513833b908ae5e4f521106',
57
+
58
+
// cmdliner versions
59
+
'cmdliner.1.0.4': '0dd34259dc0892e543b03b3afb0a77fa',
60
+
'cmdliner.1.3.0': '258e7979b874502ea546e90a0742184a',
61
+
'cmdliner.2.0.0': '91c3d96cea9b89ddd24cf7b78786a5ca',
62
+
'cmdliner.2.1.0': 'f3e665d5388ac380a70c5ed67f465bbb',
63
+
64
+
// mtime versions
65
+
'mtime.1.3.0': 'b6735658fd307bba23a7c5f21519b910',
66
+
'mtime.1.4.0': 'ebccfc43716c6da0ca4a065e60d0f875',
67
+
'mtime.2.1.0': '7db699c334606d6f66e65c8b515d298d',
68
+
69
+
// logs versions
70
+
'logs.0.7.0': '2c014cfbbee1d278b162002eae03eaa8',
71
+
'logs.0.10.0': '07a565e7588ce100ffd7c8eb8b52df07',
72
+
73
+
// uucp versions (Unicode version tracking)
74
+
'uucp.14.0.0': '60e1409eb30c0650c4d4cbcf3c453e65',
75
+
'uucp.15.0.0': '6a96a3f145249f110bf14739c78e758c',
76
+
'uucp.16.0.0': '2bf0fbf12aa05c8f99989a759d2dc8cf',
77
+
'uucp.17.0.0': '58b9c48e9528ce99586b138d8f4778c2',
78
+
79
+
// uunf versions
80
+
'uunf.14.0.0': 'cac36534f1bf353fd2192efd015dd0e6',
81
+
'uunf.17.0.0': '96704cd9810ea1ed504e4ed71cde82b0',
82
+
83
+
// Single-version libraries
84
+
'astring.0.8.5': '1cdbe76f0ec91a6eb12bd0279a394492',
85
+
'jsonm.1.0.2': 'ac28e00ecd46c9464f5575c461b5d48f',
86
+
'xmlm.1.4.0': 'c4c22d0db3ea01343c1a868bab35e1b4',
87
+
'ptime.1.2.0': 'd57c69f3dd88b91454622c1841971354',
88
+
'react.1.2.2': 'f438ba61693a5448718c73116b228f3c',
89
+
'hmap.0.8.1': '753d7c421afb866e7ffe07ddea3b8349',
90
+
'gg.1.0.0': '02a9bababc92d6639cdbaf20233597ba',
91
+
'note.0.0.3': '2545f914c274aa806d29749eb96836fa',
92
+
'otfm.0.4.0': '4f870a70ee71e41dff878af7123b2cd6',
93
+
'vg.0.9.5': '0e2e71cfd8fe2e81bff124849421f662',
94
+
'bos.0.2.1': '0e04faa6cc5527bc124d8625bded34fc',
95
+
'fpath.0.7.3': '6c4fe09a631d871865fd38aa15cd61d4',
96
+
'uutf.1.0.4': 'ac04fa0671533316f94dacbd14ffe0bf',
97
+
'b0.0.0.6': 'bfc34a228f53ac5ced707eed285a6e5c',
98
+
99
+
// Cross-version: packages requiring OCaml < 5.4 (solved with 5.3.0)
100
+
'containers.3.14': 'bc149e85833934caf6ad41a745e35cfd',
101
+
};
102
+
103
+
104
+
// ── Fmt: version comparison ──────────────────────────────────────────────────
105
+
106
+
test.describe('Fmt', () => {
107
+
test.setTimeout(120000);
108
+
109
+
for (const ver of ['0.9.0', '0.10.0', '0.11.0']) {
110
+
const key = `fmt.${ver}`;
111
+
if (!U[key]) continue;
112
+
113
+
test(`fmt ${ver}: Fmt.str and Fmt.pr work`, async ({ page }) => {
114
+
await initWorker(page, U[key]);
115
+
await requirePkg(page, 'fmt');
116
+
117
+
// Fmt.str: format to string (present in all these versions)
118
+
await evalExpect(page, 'Fmt.str "%d" 42;;', '"42"');
119
+
120
+
// Fmt.pr: format to stdout
121
+
const r = await evalCode(page, 'Fmt.pr "hello %s" "world";;');
122
+
expect(r.stdout).toContain('hello world');
123
+
});
124
+
}
125
+
126
+
test('fmt 0.9.0 vs 0.11.0: Fmt.semi available in both', async ({ page }) => {
127
+
// Fmt.semi is a separator formatter present in all versions
128
+
await initWorker(page, U['fmt.0.9.0']);
129
+
await requirePkg(page, 'fmt');
130
+
const r = await evalCode(page,
131
+
'Fmt.str "%a" Fmt.(list ~sep:semi int) [1;2;3];;');
132
+
// The output contains the three numbers separated by semi
133
+
expect(r.caml_ppf).toContain('1');
134
+
expect(r.caml_ppf).toContain('2');
135
+
expect(r.caml_ppf).toContain('3');
136
+
});
137
+
138
+
test('fmt completions work across versions', async ({ page }) => {
139
+
await initWorker(page, U['fmt.0.11.0']);
140
+
await requirePkg(page, 'fmt');
141
+
const names = await page.evaluate(
142
+
async () => await window.workerComplete('Fmt.s', 5)
143
+
);
144
+
expect(names.length).toBeGreaterThan(0);
145
+
expect(names).toContain('str');
146
+
});
147
+
});
148
+
149
+
150
+
// ── Cmdliner: major API change 1.x → 2.x ────────────────────────────────────
151
+
152
+
test.describe('Cmdliner', () => {
153
+
test.setTimeout(120000);
154
+
155
+
test('cmdliner 1.0.4: Term.eval exists (v1 API)', async ({ page }) => {
156
+
await initWorker(page, U['cmdliner.1.0.4']);
157
+
await requirePkg(page, 'cmdliner');
158
+
159
+
// In cmdliner 1.x, Cmdliner.Term.eval is the primary entry point
160
+
await evalExpect(page,
161
+
'Cmdliner.Term.eval;;',
162
+
'Cmdliner.Term');
163
+
});
164
+
165
+
test('cmdliner 2.1.0: Cmd module exists (v2 API)', async ({ page }) => {
166
+
await initWorker(page, U['cmdliner.2.1.0']);
167
+
await requirePkg(page, 'cmdliner');
168
+
169
+
// In cmdliner 2.x, Cmdliner.Cmd is the new entry point
170
+
await evalExpect(page, 'Cmdliner.Cmd.info;;', 'Cmdliner.Cmd');
171
+
172
+
// Cmdliner.Cmd.v is the new way to create commands
173
+
await evalExpect(page, 'Cmdliner.Cmd.v;;', 'Cmdliner.Cmd');
174
+
});
175
+
176
+
test('cmdliner 2.1.0: Arg module works', async ({ page }) => {
177
+
await initWorker(page, U['cmdliner.2.1.0']);
178
+
await requirePkg(page, 'cmdliner');
179
+
180
+
await evalExpect(page,
181
+
'let name = Cmdliner.Arg.(required & pos 0 (some string) None & info []);;',
182
+
'Cmdliner.Term');
183
+
});
184
+
185
+
test('cmdliner 1.3.0: transitional — both Term.eval and Cmd exist', async ({ page }) => {
186
+
await initWorker(page, U['cmdliner.1.3.0']);
187
+
await requirePkg(page, 'cmdliner');
188
+
189
+
// 1.3.0 has both the old and new APIs for migration
190
+
await evalExpect(page, 'Cmdliner.Term.eval;;', 'Cmdliner.Term');
191
+
await evalExpect(page, 'Cmdliner.Cmd.info;;', 'Cmdliner.Cmd');
192
+
});
193
+
});
194
+
195
+
196
+
// ── Mtime: API change 1.x → 2.x ─────────────────────────────────────────────
197
+
198
+
test.describe('Mtime', () => {
199
+
test.setTimeout(120000);
200
+
201
+
test('mtime 1.4.0: Mtime.Span.to_uint64_ns exists', async ({ page }) => {
202
+
await initWorker(page, U['mtime.1.4.0']);
203
+
await requirePkg(page, 'mtime');
204
+
await evalExpect(page, 'Mtime.Span.to_uint64_ns;;', '-> int64');
205
+
});
206
+
207
+
test('mtime 2.1.0: Mtime.Span.to_uint64_ns exists (kept)', async ({ page }) => {
208
+
await initWorker(page, U['mtime.2.1.0']);
209
+
await requirePkg(page, 'mtime');
210
+
await evalExpect(page, 'Mtime.Span.to_uint64_ns;;', '-> int64');
211
+
});
212
+
213
+
test('mtime 2.1.0: Mtime.Span.pp works', async ({ page }) => {
214
+
await initWorker(page, U['mtime.2.1.0']);
215
+
await requirePkg(page, 'mtime');
216
+
// Mtime.Span.pp uses Format directly, not Fmt
217
+
await evalExpect(page,
218
+
'Mtime.Span.of_uint64_ns 1_000_000_000L;;',
219
+
'Mtime.span');
220
+
});
221
+
});
222
+
223
+
224
+
// ── Logs: basic functionality across versions ────────────────────────────────
225
+
226
+
test.describe('Logs', () => {
227
+
test.setTimeout(120000);
228
+
229
+
test('logs 0.7.0: Logs module loads', async ({ page }) => {
230
+
await initWorker(page, U['logs.0.7.0']);
231
+
const reqResult = await requirePkg(page, 'logs');
232
+
233
+
// Verify require succeeded by checking that Logs module is available
234
+
// Use a simple expression: Logs.err is a log level constructor
235
+
const r = await evalCode(page, 'Logs.err;;');
236
+
// Should produce something with "Logs.level" in the type
237
+
// If the module failed to load, we'd get an Unbound module error
238
+
expect(r.caml_ppf + r.stderr).not.toContain('Unbound module');
239
+
});
240
+
241
+
test('logs 0.10.0: Logs.Src module works', async ({ page }) => {
242
+
await initWorker(page, U['logs.0.10.0']);
243
+
await requirePkg(page, 'logs');
244
+
245
+
await evalExpect(page,
246
+
'let src = Logs.Src.create "test" ~doc:"A test source";;',
247
+
'Logs.src');
248
+
249
+
await evalExpect(page, 'Logs.Src.name src;;', '"test"');
250
+
});
251
+
});
252
+
253
+
254
+
// ── Uucp: Unicode version tracking ──────────────────────────────────────────
255
+
256
+
test.describe('Uucp (Unicode versions)', () => {
257
+
test.setTimeout(120000);
258
+
259
+
test('uucp 14.0.0: reports Unicode 14.0.0', async ({ page }) => {
260
+
await initWorker(page, U['uucp.14.0.0']);
261
+
await requirePkg(page, 'uucp');
262
+
await evalExpect(page, 'Uucp.unicode_version;;', '"14.0.0"');
263
+
});
264
+
265
+
test('uucp 15.0.0: reports Unicode 15.0.0', async ({ page }) => {
266
+
await initWorker(page, U['uucp.15.0.0']);
267
+
await requirePkg(page, 'uucp');
268
+
await evalExpect(page, 'Uucp.unicode_version;;', '"15.0.0"');
269
+
});
270
+
271
+
test('uucp 16.0.0: reports Unicode 16.0.0', async ({ page }) => {
272
+
await initWorker(page, U['uucp.16.0.0']);
273
+
await requirePkg(page, 'uucp');
274
+
await evalExpect(page, 'Uucp.unicode_version;;', '"16.0.0"');
275
+
});
276
+
277
+
test('uucp 17.0.0: reports Unicode 17.0.0', async ({ page }) => {
278
+
await initWorker(page, U['uucp.17.0.0']);
279
+
await requirePkg(page, 'uucp');
280
+
await evalExpect(page, 'Uucp.unicode_version;;', '"17.0.0"');
281
+
});
282
+
283
+
test('uucp: general category lookup works', async ({ page }) => {
284
+
await initWorker(page, U['uucp.17.0.0']);
285
+
await requirePkg(page, 'uucp');
286
+
// 'A' is Lu (uppercase letter)
287
+
await evalExpect(page,
288
+
'Uucp.Gc.general_category (Uchar.of_int 0x0041);;',
289
+
'`Lu');
290
+
});
291
+
});
292
+
293
+
294
+
// ── Uunf: Unicode normalization ──────────────────────────────────────────────
295
+
296
+
test.describe('Uunf', () => {
297
+
test.setTimeout(120000);
298
+
299
+
test('uunf 14.0.0: reports Unicode 14.0.0', async ({ page }) => {
300
+
await initWorker(page, U['uunf.14.0.0']);
301
+
await requirePkg(page, 'uunf');
302
+
await evalExpect(page, 'Uunf.unicode_version;;', '"14.0.0"');
303
+
});
304
+
305
+
test('uunf 17.0.0: reports Unicode 17.0.0', async ({ page }) => {
306
+
await initWorker(page, U['uunf.17.0.0']);
307
+
await requirePkg(page, 'uunf');
308
+
await evalExpect(page, 'Uunf.unicode_version;;', '"17.0.0"');
309
+
});
310
+
});
311
+
312
+
313
+
// ── Astring: string processing ───────────────────────────────────────────────
314
+
315
+
test.describe('Astring', () => {
316
+
test.setTimeout(120000);
317
+
318
+
test('astring 0.8.5: String.cuts and String.concat', async ({ page }) => {
319
+
await initWorker(page, U['astring.0.8.5']);
320
+
await requirePkg(page, 'astring');
321
+
322
+
await evalExpect(page,
323
+
'Astring.String.cuts ~sep:"," "a,b,c";;',
324
+
'["a"; "b"; "c"]');
325
+
326
+
await evalExpect(page,
327
+
'Astring.String.concat ~sep:"-" ["x"; "y"; "z"];;',
328
+
'"x-y-z"');
329
+
});
330
+
331
+
test('astring 0.8.5: String.Sub module', async ({ page }) => {
332
+
await initWorker(page, U['astring.0.8.5']);
333
+
await requirePkg(page, 'astring');
334
+
335
+
await evalExpect(page,
336
+
'Astring.String.Sub.(to_string (v "hello world" ~start:6));;',
337
+
'"world"');
338
+
});
339
+
});
340
+
341
+
342
+
// ── Jsonm: streaming JSON ────────────────────────────────────────────────────
343
+
344
+
test.describe('Jsonm', () => {
345
+
test.setTimeout(120000);
346
+
347
+
test('jsonm 1.0.2: encode and decode JSON', async ({ page }) => {
348
+
await initWorker(page, U['jsonm.1.0.2']);
349
+
await requirePkg(page, 'jsonm');
350
+
351
+
// Create a decoder and read from a JSON string
352
+
await evalExpect(page,
353
+
'let d = Jsonm.decoder (`String "42") in Jsonm.decode d;;',
354
+
'`Lexeme');
355
+
});
356
+
});
357
+
358
+
359
+
// ── Xmlm: XML processing ────────────────────────────────────────────────────
360
+
361
+
test.describe('Xmlm', () => {
362
+
test.setTimeout(120000);
363
+
364
+
test('xmlm 1.4.0: parse XML input', async ({ page }) => {
365
+
await initWorker(page, U['xmlm.1.4.0']);
366
+
await requirePkg(page, 'xmlm');
367
+
368
+
await evalExpect(page,
369
+
'let i = Xmlm.make_input (`String (0, "<root/>")) in Xmlm.input i;;',
370
+
'`Dtd');
371
+
});
372
+
});
373
+
374
+
375
+
// ── Ptime: POSIX time ────────────────────────────────────────────────────────
376
+
377
+
test.describe('Ptime', () => {
378
+
test.setTimeout(120000);
379
+
380
+
test('ptime 1.2.0: epoch and time arithmetic', async ({ page }) => {
381
+
await initWorker(page, U['ptime.1.2.0']);
382
+
await requirePkg(page, 'ptime');
383
+
384
+
await evalExpect(page, 'Ptime.epoch;;', 'Ptime.t');
385
+
386
+
// Create a specific date
387
+
await evalExpect(page,
388
+
'Ptime.of_date_time ((2024, 1, 1), ((0, 0, 0), 0));;',
389
+
'Some');
390
+
});
391
+
392
+
test('ptime 1.2.0: Ptime.Span works', async ({ page }) => {
393
+
await initWorker(page, U['ptime.1.2.0']);
394
+
await requirePkg(page, 'ptime');
395
+
396
+
await evalExpect(page,
397
+
'Ptime.Span.of_int_s 3600 |> Ptime.Span.to_int_s;;',
398
+
'3600');
399
+
});
400
+
});
401
+
402
+
403
+
// ── React: functional reactive programming ───────────────────────────────────
404
+
405
+
test.describe('React', () => {
406
+
test.setTimeout(120000);
407
+
408
+
test('react 1.2.2: create signals and events', async ({ page }) => {
409
+
await initWorker(page, U['react.1.2.2']);
410
+
await requirePkg(page, 'react');
411
+
412
+
// Create a signal with initial value
413
+
await evalExpect(page,
414
+
'let s, set_s = React.S.create 0;;',
415
+
'React.signal');
416
+
417
+
// Read signal value
418
+
await evalExpect(page, 'React.S.value s;;', '0');
419
+
420
+
// Update and read
421
+
await evalCode(page, 'set_s 42;;');
422
+
await evalExpect(page, 'React.S.value s;;', '42');
423
+
});
424
+
});
425
+
426
+
427
+
// ── Hmap: heterogeneous maps ─────────────────────────────────────────────────
428
+
429
+
test.describe('Hmap', () => {
430
+
test.setTimeout(120000);
431
+
432
+
test('hmap 0.8.1: create keys and store heterogeneous values', async ({ page }) => {
433
+
await initWorker(page, U['hmap.0.8.1']);
434
+
await requirePkg(page, 'hmap');
435
+
436
+
await evalExpect(page,
437
+
'let k_int : int Hmap.key = Hmap.Key.create ();;',
438
+
'Hmap.key');
439
+
440
+
await evalExpect(page,
441
+
'let k_str : string Hmap.key = Hmap.Key.create ();;',
442
+
'Hmap.key');
443
+
444
+
await evalExpect(page,
445
+
'let m = Hmap.empty |> Hmap.add k_int 42 |> Hmap.add k_str "hello";;',
446
+
'Hmap.t');
447
+
448
+
await evalExpect(page, 'Hmap.find k_int m;;', 'Some 42');
449
+
await evalExpect(page, 'Hmap.find k_str m;;', 'Some "hello"');
450
+
});
451
+
});
452
+
453
+
454
+
// ── Gg: basic graphics geometry ──────────────────────────────────────────────
455
+
456
+
test.describe('Gg', () => {
457
+
test.setTimeout(120000);
458
+
459
+
test('gg 1.0.0: 2D vectors and colors', async ({ page }) => {
460
+
await initWorker(page, U['gg.1.0.0']);
461
+
await requirePkg(page, 'gg');
462
+
463
+
// Create a 2D point
464
+
await evalExpect(page, 'Gg.V2.v 1.0 2.0;;', 'Gg.v2');
465
+
466
+
// Vector addition
467
+
await evalExpect(page,
468
+
'Gg.V2.add (Gg.V2.v 1.0 2.0) (Gg.V2.v 3.0 4.0);;',
469
+
'Gg.v2');
470
+
471
+
// Check the result
472
+
await evalExpect(page,
473
+
'let r = Gg.V2.add (Gg.V2.v 1.0 2.0) (Gg.V2.v 3.0 4.0) in Gg.V2.x r;;',
474
+
'4.');
475
+
476
+
// Colors
477
+
await evalExpect(page, 'Gg.Color.red;;', 'Gg.color');
478
+
});
479
+
});
480
+
481
+
482
+
// ── Vg: vector graphics ─────────────────────────────────────────────────────
483
+
484
+
test.describe('Vg', () => {
485
+
test.setTimeout(120000);
486
+
487
+
test('vg 0.9.5: create paths and images', async ({ page }) => {
488
+
await initWorker(page, U['vg.0.9.5']);
489
+
await requirePkg(page, 'vg');
490
+
await requirePkg(page, 'gg');
491
+
492
+
// Create a simple path
493
+
await evalExpect(page,
494
+
'let p = Vg.P.empty |> Vg.P.line (Gg.V2.v 1.0 1.0);;',
495
+
'Vg.path');
496
+
497
+
// Create an image from path
498
+
await evalExpect(page,
499
+
'let img = Vg.I.cut p (Vg.I.const Gg.Color.red);;',
500
+
'Vg.image');
501
+
});
502
+
503
+
test.skip('vg 0.9.4: also works (older version) — not built', async ({ page }) => {
504
+
// vg 0.9.4 is not included in the current batch build
505
+
});
506
+
});
507
+
508
+
509
+
// ── Note: declarative signals ────────────────────────────────────────────────
510
+
511
+
test.describe('Note', () => {
512
+
test.setTimeout(120000);
513
+
514
+
test('note 0.0.3: create events and signals', async ({ page }) => {
515
+
await initWorker(page, U['note.0.0.3']);
516
+
await requirePkg(page, 'note');
517
+
518
+
// Note.S is the signal module
519
+
await evalExpect(page,
520
+
'let s = Note.S.const 42;;',
521
+
'Note.signal');
522
+
523
+
await evalExpect(page, 'Note.S.value s;;', '42');
524
+
});
525
+
});
526
+
527
+
528
+
// ── Otfm: OpenType font metrics ──────────────────────────────────────────────
529
+
530
+
test.describe('Otfm', () => {
531
+
test.setTimeout(120000);
532
+
533
+
test('otfm 0.4.0: module loads and types available', async ({ page }) => {
534
+
await initWorker(page, U['otfm.0.4.0']);
535
+
await requirePkg(page, 'otfm');
536
+
537
+
// Check that the decoder type exists
538
+
await evalExpect(page, 'Otfm.decoder;;', '-> Otfm.decoder');
539
+
});
540
+
});
541
+
542
+
543
+
// ── Fpath: file system paths ─────────────────────────────────────────────────
544
+
545
+
test.describe('Fpath', () => {
546
+
test.setTimeout(120000);
547
+
548
+
test('fpath 0.7.3: path manipulation', async ({ page }) => {
549
+
await initWorker(page, U['fpath.0.7.3']);
550
+
await requirePkg(page, 'fpath');
551
+
552
+
await evalExpect(page,
553
+
'Fpath.v "/usr/local/bin" |> Fpath.to_string;;',
554
+
'"/usr/local/bin"');
555
+
556
+
await evalExpect(page,
557
+
'Fpath.(v "/usr" / "local" / "bin") |> Fpath.to_string;;',
558
+
'"/usr/local/bin"');
559
+
560
+
await evalExpect(page,
561
+
'Fpath.v "/usr/local/bin" |> Fpath.parent |> Fpath.to_string;;',
562
+
'"/usr/local/"');
563
+
564
+
await evalExpect(page,
565
+
'Fpath.v "/usr/local/bin" |> Fpath.basename;;',
566
+
'"bin"');
567
+
});
568
+
});
569
+
570
+
571
+
// ── Uutf: UTF decoding/encoding ──────────────────────────────────────────────
572
+
573
+
test.describe('Uutf', () => {
574
+
test.setTimeout(120000);
575
+
576
+
test('uutf 1.0.4: decode UTF-8', async ({ page }) => {
577
+
await initWorker(page, U['uutf.1.0.4']);
578
+
await requirePkg(page, 'uutf');
579
+
580
+
// Create a decoder
581
+
await evalExpect(page,
582
+
'let d = Uutf.decoder ~encoding:`UTF_8 (`String "ABC");;',
583
+
'Uutf.decoder');
584
+
585
+
// Decode first character
586
+
await evalExpect(page, 'Uutf.decode d;;', '`Uchar');
587
+
});
588
+
});
589
+
590
+
591
+
// ── B0: build system library ─────────────────────────────────────────────────
592
+
593
+
test.describe('B0', () => {
594
+
test.setTimeout(120000);
595
+
596
+
test('b0 0.0.6: B0_std.Fpath', async ({ page }) => {
597
+
await initWorker(page, U['b0.0.0.6']);
598
+
await requirePkg(page, 'b0.std');
599
+
600
+
await evalExpect(page, 'B0_std.Fpath.v "/tmp";;', 'B0_std.Fpath.t');
601
+
});
602
+
});
603
+
604
+
605
+
// ── Cross-library: Bos (uses fmt + fpath + logs + astring + rresult) ─────────
606
+
607
+
test.describe('Bos (cross-library)', () => {
608
+
test.setTimeout(120000);
609
+
610
+
test('bos 0.2.1: depends on fmt, fpath, logs, astring', async ({ page }) => {
611
+
await initWorker(page, U['bos.0.2.1']);
612
+
await requirePkg(page, 'bos');
613
+
614
+
// Bos.OS.File uses Fpath
615
+
await evalExpect(page, 'Bos.OS.Cmd.run_status;;', 'Bos.Cmd');
616
+
617
+
// Bos.Cmd construction
618
+
await evalExpect(page,
619
+
'Bos.Cmd.(v "echo" % "hello");;',
620
+
'Bos.Cmd');
621
+
});
622
+
});
623
+
624
+
625
+
// ── Containers: OCaml 5.3.0 (< 5.4 constraint) ────────────────────────────
626
+
627
+
test.describe('Containers (OCaml 5.3.0)', () => {
628
+
test.setTimeout(120000);
629
+
630
+
test('containers 3.14: loads with OCaml 5.3.0 compiler', async ({ page }) => {
631
+
// containers.3.14 requires ocaml < 5.4, so it was solved with OCaml 5.3.0
632
+
await initWorker(page, U['containers.3.14'], '5.3.0');
633
+
await requirePkg(page, 'containers');
634
+
635
+
// CCList is a core module in containers
636
+
await evalExpect(page,
637
+
'CCList.filter_map (fun x -> if x > 2 then Some (x * 10) else None) [1;2;3;4];;',
638
+
'[30; 40]');
639
+
640
+
// CCString basic usage
641
+
await evalExpect(page,
642
+
'CCString.prefix ~pre:"hello" "hello world";;',
643
+
'true');
644
+
});
645
+
});
+55
js_top_worker/test/ohc-integration/ohc-jtw.spec.js
+55
js_top_worker/test/ohc-integration/ohc-jtw.spec.js
···
1
+
// @ts-check
2
+
const { test, expect } = require('@playwright/test');
3
+
4
+
// Universe hash is passed via environment or auto-detected
5
+
const UNIVERSE = process.env.JTW_UNIVERSE || '';
6
+
const COMPILER = process.env.JTW_COMPILER || '5.4.0';
7
+
8
+
test.describe('OHC JTW Integration', () => {
9
+
test.setTimeout(120000);
10
+
11
+
test('worker initializes and executes OCaml with fmt', async ({ page }) => {
12
+
// Collect console logs for debugging
13
+
const logs = [];
14
+
page.on('console', msg => logs.push(msg.text()));
15
+
16
+
await page.goto(`/test/ohc-integration/test.html?universe=${UNIVERSE}&compiler=${COMPILER}`);
17
+
18
+
// Wait for tests to complete (or error)
19
+
await expect(async () => {
20
+
const done = await page.locator('#status').getAttribute('data-done');
21
+
const error = await page.locator('#status').getAttribute('data-error');
22
+
expect(done === 'true' || error !== null).toBeTruthy();
23
+
}).toPass({ timeout: 120000 });
24
+
25
+
// Check no error occurred
26
+
const error = await page.locator('#status').getAttribute('data-error');
27
+
if (error) {
28
+
console.log('Console logs:', logs.join('\n'));
29
+
}
30
+
expect(error).toBeNull();
31
+
32
+
// Verify individual test results
33
+
const results = page.locator('#results');
34
+
35
+
// Test 1: Basic arithmetic
36
+
const test1 = await results.getAttribute('data-test1');
37
+
expect(test1).toContain('val x : int = 3');
38
+
39
+
// Test 2: String operations
40
+
const test2 = await results.getAttribute('data-test2');
41
+
expect(test2).toContain('"hello, world"');
42
+
43
+
// Test 3: fmt loaded
44
+
const test3 = await results.getAttribute('data-test3');
45
+
expect(test3).toBe('loaded');
46
+
47
+
// Test 4: Fmt.str works
48
+
const test4 = await results.getAttribute('data-test4');
49
+
expect(test4).toContain('"42"');
50
+
51
+
// Test 5: Completions work
52
+
const test5 = await results.getAttribute('data-test5');
53
+
expect(test5).toBe('ok');
54
+
});
55
+
});
+71
js_top_worker/test/ohc-integration/package-lock.json
+71
js_top_worker/test/ohc-integration/package-lock.json
···
1
+
{
2
+
"name": "ohc-integration",
3
+
"version": "1.0.0",
4
+
"lockfileVersion": 3,
5
+
"requires": true,
6
+
"packages": {
7
+
"": {
8
+
"name": "ohc-integration",
9
+
"version": "1.0.0",
10
+
"license": "ISC",
11
+
"dependencies": {
12
+
"@playwright/test": "^1.58.1"
13
+
}
14
+
},
15
+
"node_modules/@playwright/test": {
16
+
"version": "1.58.1",
17
+
"resolved": "https://registry.npmjs.org/@playwright/test/-/test-1.58.1.tgz",
18
+
"integrity": "sha512-6LdVIUERWxQMmUSSQi0I53GgCBYgM2RpGngCPY7hSeju+VrKjq3lvs7HpJoPbDiY5QM5EYRtRX5fvrinnMAz3w==",
19
+
"dependencies": {
20
+
"playwright": "1.58.1"
21
+
},
22
+
"bin": {
23
+
"playwright": "cli.js"
24
+
},
25
+
"engines": {
26
+
"node": ">=18"
27
+
}
28
+
},
29
+
"node_modules/fsevents": {
30
+
"version": "2.3.2",
31
+
"resolved": "https://registry.npmjs.org/fsevents/-/fsevents-2.3.2.tgz",
32
+
"integrity": "sha512-xiqMQR4xAeHTuB9uWm+fFRcIOgKBMiOBP+eXiyT7jsgVCq1bkVygt00oASowB7EdtpOHaaPgKt812P9ab+DDKA==",
33
+
"hasInstallScript": true,
34
+
"optional": true,
35
+
"os": [
36
+
"darwin"
37
+
],
38
+
"engines": {
39
+
"node": "^8.16.0 || ^10.6.0 || >=11.0.0"
40
+
}
41
+
},
42
+
"node_modules/playwright": {
43
+
"version": "1.58.1",
44
+
"resolved": "https://registry.npmjs.org/playwright/-/playwright-1.58.1.tgz",
45
+
"integrity": "sha512-+2uTZHxSCcxjvGc5C891LrS1/NlxglGxzrC4seZiVjcYVQfUa87wBL6rTDqzGjuoWNjnBzRqKmF6zRYGMvQUaQ==",
46
+
"dependencies": {
47
+
"playwright-core": "1.58.1"
48
+
},
49
+
"bin": {
50
+
"playwright": "cli.js"
51
+
},
52
+
"engines": {
53
+
"node": ">=18"
54
+
},
55
+
"optionalDependencies": {
56
+
"fsevents": "2.3.2"
57
+
}
58
+
},
59
+
"node_modules/playwright-core": {
60
+
"version": "1.58.1",
61
+
"resolved": "https://registry.npmjs.org/playwright-core/-/playwright-core-1.58.1.tgz",
62
+
"integrity": "sha512-bcWzOaTxcW+VOOGBCQgnaKToLJ65d6AqfLVKEWvexyS3AS6rbXl+xdpYRMGSRBClPvyj44njOWoxjNdL/H9UNg==",
63
+
"bin": {
64
+
"playwright-core": "cli.js"
65
+
},
66
+
"engines": {
67
+
"node": ">=18"
68
+
}
69
+
}
70
+
}
71
+
}
+15
js_top_worker/test/ohc-integration/package.json
+15
js_top_worker/test/ohc-integration/package.json
···
1
+
{
2
+
"name": "ohc-integration",
3
+
"version": "1.0.0",
4
+
"description": "",
5
+
"main": "ohc-jtw.spec.js",
6
+
"scripts": {
7
+
"test": "echo \"Error: no test specified\" && exit 1"
8
+
},
9
+
"keywords": [],
10
+
"author": "",
11
+
"license": "ISC",
12
+
"dependencies": {
13
+
"@playwright/test": "^1.58.1"
14
+
}
15
+
}
+19
js_top_worker/test/ohc-integration/playwright.config.js
+19
js_top_worker/test/ohc-integration/playwright.config.js
···
1
+
// @ts-check
2
+
const { defineConfig } = require('@playwright/test');
3
+
4
+
module.exports = defineConfig({
5
+
testDir: '.',
6
+
timeout: 120000,
7
+
retries: 0,
8
+
use: {
9
+
baseURL: 'http://localhost:8769',
10
+
},
11
+
webServer: {
12
+
command: 'python3 -m http.server 8769',
13
+
cwd: process.env.JTW_SERVE_DIR || '/home/jons-agent/js_top_worker',
14
+
port: 8769,
15
+
timeout: 10000,
16
+
reuseExistingServer: true,
17
+
},
18
+
reporter: 'list',
19
+
});
+616
js_top_worker/test/ohc-integration/runner.html
+616
js_top_worker/test/ohc-integration/runner.html
···
1
+
<!DOCTYPE html>
2
+
<html>
3
+
<head>
4
+
<meta charset="utf-8">
5
+
<title>JTW Library Test Runner</title>
6
+
<style>
7
+
* { box-sizing: border-box; margin: 0; padding: 0; }
8
+
body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', system-ui, sans-serif; background: #0d1117; color: #c9d1d9; padding: 24px; line-height: 1.5; }
9
+
h1 { color: #f0f6fc; margin-bottom: 4px; font-size: 24px; }
10
+
.subtitle { color: #8b949e; margin-bottom: 24px; font-size: 14px; }
11
+
.summary { display: flex; gap: 16px; margin-bottom: 24px; padding: 16px; background: #161b22; border: 1px solid #30363d; border-radius: 8px; flex-wrap: wrap; }
12
+
.summary .stat { text-align: center; min-width: 70px; }
13
+
.summary .stat .num { font-size: 32px; font-weight: 700; }
14
+
.summary .stat .label { font-size: 12px; color: #8b949e; text-transform: uppercase; }
15
+
.stat.pass .num { color: #3fb950; }
16
+
.stat.fail .num { color: #f85149; }
17
+
.stat.skip .num { color: #d29922; }
18
+
.stat.run .num { color: #58a6ff; }
19
+
.progress { height: 4px; background: #21262d; border-radius: 2px; margin-bottom: 24px; overflow: hidden; }
20
+
.progress-bar { height: 100%; background: #58a6ff; transition: width 0.3s; }
21
+
22
+
.group { margin-bottom: 16px; }
23
+
.group-header { font-size: 14px; font-weight: 600; color: #f0f6fc; padding: 8px 12px; background: #161b22; border: 1px solid #30363d; border-radius: 8px 8px 0 0; cursor: pointer; display: flex; justify-content: space-between; align-items: center; }
24
+
.group-header:hover { background: #1c2128; }
25
+
.group-header .arrow { transition: transform 0.2s; }
26
+
.group-header.collapsed .arrow { transform: rotate(-90deg); }
27
+
.group-badge { font-size: 11px; padding: 1px 6px; border-radius: 10px; margin-left: 8px; font-weight: 400; }
28
+
.group-badge.cross { background: #30363d; color: #d2a8ff; }
29
+
.group-body { border: 1px solid #30363d; border-top: none; border-radius: 0 0 8px 8px; overflow: hidden; }
30
+
.group-body.hidden { display: none; }
31
+
32
+
.code-banner { padding: 6px 12px; background: #0d1117; border-bottom: 1px solid #21262d; font-family: 'SF Mono', 'Fira Code', monospace; font-size: 13px; color: #d2a8ff; }
33
+
.code-banner code { color: #f0f6fc; }
34
+
35
+
.test-row { display: flex; align-items: flex-start; padding: 8px 12px; border-bottom: 1px solid #21262d; font-size: 13px; gap: 8px; }
36
+
.test-row:last-child { border-bottom: none; }
37
+
.test-row:hover { background: #161b22; }
38
+
.test-icon { flex-shrink: 0; width: 20px; text-align: center; font-size: 14px; }
39
+
.test-name { flex: 1; }
40
+
.test-name .label { font-family: 'SF Mono', 'Fira Code', monospace; }
41
+
.test-detail { font-size: 12px; color: #8b949e; margin-top: 2px; }
42
+
.test-time { color: #8b949e; font-size: 12px; flex-shrink: 0; }
43
+
44
+
.test-row.pass .test-icon { color: #3fb950; }
45
+
.test-row.fail .test-icon { color: #f85149; }
46
+
.test-row.skip .test-icon { color: #d29922; }
47
+
.test-row.running .test-icon { color: #58a6ff; }
48
+
.test-row.pending .test-icon { color: #484f58; }
49
+
/* "Expected error" pass: still green check but with a visual indicator */
50
+
.test-row.pass-neg .test-icon { color: #3fb950; }
51
+
52
+
.expect-badge { font-size: 10px; padding: 1px 5px; border-radius: 3px; margin-left: 6px; vertical-align: middle; }
53
+
.expect-badge.should-pass { background: #23862633; color: #3fb950; }
54
+
.expect-badge.should-error { background: #f8514933; color: #f85149; }
55
+
56
+
.error-detail { background: #1c1215; border: 1px solid #f8514933; border-radius: 4px; padding: 8px; margin-top: 6px; font-family: 'SF Mono', monospace; font-size: 12px; color: #f85149; white-space: pre-wrap; word-break: break-all; }
57
+
.output-detail { background: #121a16; border: 1px solid #3fb95033; border-radius: 4px; padding: 8px; margin-top: 6px; font-family: 'SF Mono', monospace; font-size: 12px; color: #3fb950; white-space: pre-wrap; word-break: break-all; }
58
+
.neg-output-detail { background: #1a1520; border: 1px solid #d2a8ff33; border-radius: 4px; padding: 8px; margin-top: 6px; font-family: 'SF Mono', monospace; font-size: 12px; color: #d2a8ff; white-space: pre-wrap; word-break: break-all; }
59
+
60
+
.step-transcript { margin-top: 6px; border-radius: 4px; overflow: hidden; border: 1px solid #30363d; }
61
+
.step-transcript + .step-transcript { margin-top: 4px; }
62
+
.step-input { padding: 4px 8px; background: #161b22; font-family: 'SF Mono', 'Fira Code', monospace; font-size: 12px; color: #d2a8ff; border-bottom: 1px solid #21262d; }
63
+
.step-input::before { content: '# '; color: #484f58; }
64
+
.step-output { padding: 4px 8px; font-family: 'SF Mono', 'Fira Code', monospace; font-size: 12px; white-space: pre-wrap; word-break: break-all; }
65
+
.step-output.out-pass { background: #121a16; color: #3fb950; }
66
+
.step-output.out-fail { background: #1c1215; color: #f85149; }
67
+
.step-output.out-neg { background: #1a1520; color: #d2a8ff; }
68
+
.step-output.out-stdout { background: #161b22; color: #c9d1d9; }
69
+
70
+
@keyframes spin { to { transform: rotate(360deg); } }
71
+
.spinner { display: inline-block; animation: spin 1s linear infinite; }
72
+
</style>
73
+
</head>
74
+
<body>
75
+
<h1>JTW Library Test Runner</h1>
76
+
<p class="subtitle">Testing OCaml libraries across versions via ohc-built JTW output — including cross-version negative tests</p>
77
+
78
+
<div class="summary">
79
+
<div class="stat pass"><div class="num" id="pass-count">0</div><div class="label">Passed</div></div>
80
+
<div class="stat fail"><div class="num" id="fail-count">0</div><div class="label">Unexpected</div></div>
81
+
<div class="stat skip"><div class="num" id="skip-count">0</div><div class="label">Skipped</div></div>
82
+
<div class="stat run"><div class="num" id="run-count">0</div><div class="label">Running</div></div>
83
+
</div>
84
+
<div class="progress"><div class="progress-bar" id="progress-bar"></div></div>
85
+
86
+
<div id="groups"></div>
87
+
88
+
<script type="module">
89
+
import { OcamlWorker } from '/client/ocaml-worker.js';
90
+
91
+
// ── Universe mapping ──────────────────────────────────────────────────
92
+
const U = {
93
+
'fmt.0.9.0': '9901393f978b0a6627c5eab595111f50',
94
+
'fmt.0.10.0': 'd8140118651d08430f933d410a909e3b',
95
+
'fmt.0.11.0': '2fc1d989047b6476399007c9b8b69af9',
96
+
'cmdliner.1.0.4': '0dd34259dc0892e543b03b3afb0a77fa',
97
+
'cmdliner.1.3.0': '258e7979b874502ea546e90a0742184a',
98
+
'cmdliner.2.0.0': '91c3d96cea9b89ddd24cf7b78786a5ca',
99
+
'cmdliner.2.1.0': 'bfc34a228f53ac5ced707eed285a6e5c',
100
+
'mtime.1.3.0': 'b6735658fd307bba23a7c5f21519b910',
101
+
'mtime.1.4.0': 'ebccfc43716c6da0ca4a065e60d0f875',
102
+
'mtime.2.1.0': '7db699c334606d6f66e65c8b515d298d',
103
+
'logs.0.7.0': '2c014cfbbee1d278b162002eae03eaa8',
104
+
'logs.0.10.0': '07a565e7588ce100ffd7c8eb8b52df07',
105
+
'uucp.14.0.0': '60e1409eb30c0650c4d4cbcf3c453e65',
106
+
'uucp.15.0.0': '6a96a3f145249f110bf14739c78e758c',
107
+
'uucp.16.0.0': '2bf0fbf12aa05c8f99989a759d2dc8cf',
108
+
'uucp.17.0.0': '58b9c48e9528ce99586b138d8f4778c2',
109
+
'uunf.14.0.0': 'cac36534f1bf353fd2192efd015dd0e6',
110
+
'uunf.17.0.0': '96704cd9810ea1ed504e4ed71cde82b0',
111
+
'astring.0.8.5': '1cdbe76f0ec91a6eb12bd0279a394492',
112
+
'jsonm.1.0.2': 'ac28e00ecd46c9464f5575c461b5d48f',
113
+
'xmlm.1.4.0': 'c4c22d0db3ea01343c1a868bab35e1b4',
114
+
'ptime.1.2.0': 'd57c69f3dd88b91454622c1841971354',
115
+
'react.1.2.2': 'f438ba61693a5448718c73116b228f3c',
116
+
'hmap.0.8.1': '753d7c421afb866e7ffe07ddea3b8349',
117
+
'gg.1.0.0': '02a9bababc92d6639cdbaf20233597ba',
118
+
'note.0.0.3': '2545f914c274aa806d29749eb96836fa',
119
+
'otfm.0.4.0': '4f870a70ee71e41dff878af7123b2cd6',
120
+
'vg.0.9.5': '0e2e71cfd8fe2e81bff124849421f662',
121
+
'bos.0.2.1': '2fc1d989047b6476399007c9b8b69af9',
122
+
'fpath.0.7.3': '2fc1d989047b6476399007c9b8b69af9',
123
+
'uutf.1.0.4': '4f870a70ee71e41dff878af7123b2cd6',
124
+
'b0.0.0.6': 'bfc34a228f53ac5ced707eed285a6e5c',
125
+
};
126
+
127
+
// ── Test definitions ──────────────────────────────────────────────────
128
+
//
129
+
// Regular tests:
130
+
// { group, name, universe, require, steps: [{code, expect}] }
131
+
//
132
+
// Cross-version (negative) tests:
133
+
// { group, crossVersion: true, code: "...",
134
+
// cases: [{ label, universe, require,
135
+
// shouldPass: true/false, expect?, expectError? }] }
136
+
137
+
const tests = [
138
+
139
+
// ══════════════════════════════════════════════════════════════════
140
+
// CROSS-VERSION NEGATIVE TESTS
141
+
// ══════════════════════════════════════════════════════════════════
142
+
143
+
// ── Cmdliner.Cmd module: introduced in ~1.1, absent in 1.0.4 ──
144
+
{ group: 'Cmdliner: Cmd module boundary', crossVersion: true,
145
+
code: 'Cmdliner.Cmd.info;;',
146
+
description: 'Cmdliner.Cmd was introduced after 1.0.x. Same code errors in 1.0.4 but works in 1.3.0+.',
147
+
cases: [
148
+
{ label: 'cmdliner 1.0.4', universe: U['cmdliner.1.0.4'], require: ['cmdliner'],
149
+
shouldPass: false, expectError: 'Unbound module' },
150
+
{ label: 'cmdliner 1.3.0', universe: U['cmdliner.1.3.0'], require: ['cmdliner'],
151
+
shouldPass: true, expect: 'Cmdliner.Cmd' },
152
+
{ label: 'cmdliner 2.1.0', universe: U['cmdliner.2.1.0'], require: ['cmdliner'],
153
+
shouldPass: true, expect: 'Cmdliner.Cmd' },
154
+
] },
155
+
156
+
// ── Cmdliner.Term.eval: removed in 2.0 ──
157
+
{ group: 'Cmdliner: Term.eval removal', crossVersion: true,
158
+
code: 'Cmdliner.Term.eval;;',
159
+
description: 'Cmdliner.Term.eval was removed in 2.0. Present in 1.0.4 and 1.3.0 (transitional), gone in 2.x.',
160
+
cases: [
161
+
{ label: 'cmdliner 1.0.4', universe: U['cmdliner.1.0.4'], require: ['cmdliner'],
162
+
shouldPass: true, expect: 'Cmdliner.Term' },
163
+
{ label: 'cmdliner 1.3.0', universe: U['cmdliner.1.3.0'], require: ['cmdliner'],
164
+
shouldPass: true, expect: 'Cmdliner.Term' },
165
+
{ label: 'cmdliner 2.0.0', universe: U['cmdliner.2.0.0'], require: ['cmdliner'],
166
+
shouldPass: false, expectError: 'Unbound' },
167
+
{ label: 'cmdliner 2.1.0', universe: U['cmdliner.2.1.0'], require: ['cmdliner'],
168
+
shouldPass: false, expectError: 'Unbound' },
169
+
] },
170
+
171
+
// ── Uucp.unicode_version value changes ──
172
+
{ group: 'Uucp: unicode_version value', crossVersion: true,
173
+
code: 'Uucp.unicode_version;;',
174
+
description: 'Each Uucp release tracks a specific Unicode version. The returned string differs per version.',
175
+
cases: [
176
+
{ label: 'uucp 14.0.0', universe: U['uucp.14.0.0'], require: ['uucp'],
177
+
shouldPass: true, expect: '"14.0.0"' },
178
+
{ label: 'uucp 15.0.0', universe: U['uucp.15.0.0'], require: ['uucp'],
179
+
shouldPass: true, expect: '"15.0.0"' },
180
+
{ label: 'uucp 16.0.0', universe: U['uucp.16.0.0'], require: ['uucp'],
181
+
shouldPass: true, expect: '"16.0.0"' },
182
+
{ label: 'uucp 17.0.0', universe: U['uucp.17.0.0'], require: ['uucp'],
183
+
shouldPass: true, expect: '"17.0.0"' },
184
+
] },
185
+
186
+
// ── Uucp: "17.0.0" only in uucp 17 ──
187
+
{ group: 'Uucp: version string mismatch', crossVersion: true,
188
+
code: 'assert (Uucp.unicode_version = "17.0.0");;',
189
+
description: 'Asserting unicode_version = "17.0.0" passes only in uucp 17, fails in 14.',
190
+
cases: [
191
+
{ label: 'uucp 14.0.0', universe: U['uucp.14.0.0'], require: ['uucp'],
192
+
shouldPass: false, expectError: 'Assert_failure' },
193
+
{ label: 'uucp 17.0.0', universe: U['uucp.17.0.0'], require: ['uucp'],
194
+
shouldPass: true, expect: '' },
195
+
] },
196
+
197
+
// ── Uunf version boundary ──
198
+
{ group: 'Uunf: version boundary', crossVersion: true,
199
+
code: 'assert (Uunf.unicode_version = "17.0.0");;',
200
+
description: 'Uunf 14.0.0 reports Unicode 14, so asserting "17.0.0" fails. Passes in uunf 17.',
201
+
cases: [
202
+
{ label: 'uunf 14.0.0', universe: U['uunf.14.0.0'], require: ['uunf'],
203
+
shouldPass: false, expectError: 'Assert_failure' },
204
+
{ label: 'uunf 17.0.0', universe: U['uunf.17.0.0'], require: ['uunf'],
205
+
shouldPass: true, expect: '' },
206
+
] },
207
+
208
+
// ── Mtime.Span.of_float_ns: added in 2.x ──
209
+
{ group: 'Mtime: Span.of_float_ns boundary', crossVersion: true,
210
+
code: 'Mtime.Span.of_float_ns;;',
211
+
description: 'Mtime.Span.of_float_ns was added in mtime 2.0. Not present in 1.x.',
212
+
cases: [
213
+
{ label: 'mtime 1.3.0', universe: U['mtime.1.3.0'], require: ['mtime'],
214
+
shouldPass: false, expectError: 'Unbound' },
215
+
{ label: 'mtime 1.4.0', universe: U['mtime.1.4.0'], require: ['mtime'],
216
+
shouldPass: false, expectError: 'Unbound' },
217
+
{ label: 'mtime 2.1.0', universe: U['mtime.2.1.0'], require: ['mtime'],
218
+
shouldPass: true, expect: 'Mtime.span option' },
219
+
] },
220
+
221
+
// ══════════════════════════════════════════════════════════════════
222
+
// POSITIVE TESTS (functionality verification)
223
+
// ══════════════════════════════════════════════════════════════════
224
+
225
+
// ── Fmt ──
226
+
...['0.9.0', '0.10.0', '0.11.0'].map(v => ({
227
+
group: 'Fmt',
228
+
name: `${v}: Fmt.str formats integers`,
229
+
universe: U[`fmt.${v}`],
230
+
require: ['fmt'],
231
+
steps: [{ code: 'Fmt.str "%d" 42;;', expect: '"42"' }],
232
+
})),
233
+
...['0.9.0', '0.10.0', '0.11.0'].map(v => ({
234
+
group: 'Fmt',
235
+
name: `${v}: Fmt.pr writes to stdout`,
236
+
universe: U[`fmt.${v}`],
237
+
require: ['fmt'],
238
+
steps: [{ code: 'Fmt.pr "hello %s" "world";;', expectStdout: 'hello world' }],
239
+
})),
240
+
{ group: 'Fmt', name: '0.11.0: completions for Fmt.s*', universe: U['fmt.0.11.0'], require: ['fmt'],
241
+
steps: [{ complete: { source: 'Fmt.s', pos: 5 }, expectEntries: ['str'] }] },
242
+
243
+
// ── Cmdliner (positive) ──
244
+
{ group: 'Cmdliner', name: '2.1.0: Arg combinators', universe: U['cmdliner.2.1.0'], require: ['cmdliner'],
245
+
steps: [{ code: 'let name = Cmdliner.Arg.(required & pos 0 (some string) None & info []);;', expect: 'Cmdliner.Term' }] },
246
+
247
+
// ── Uucp (positive) ──
248
+
{ group: 'Uucp', name: '17.0.0: general category A = Lu', universe: U['uucp.17.0.0'], require: ['uucp'],
249
+
steps: [{ code: 'Uucp.Gc.general_category (Uchar.of_int 0x0041);;', expect: '`Lu' }] },
250
+
251
+
// ── Mtime (positive) ──
252
+
{ group: 'Mtime', name: '1.4.0: Span.to_uint64_ns', universe: U['mtime.1.4.0'], require: ['mtime'],
253
+
steps: [{ code: 'Mtime.Span.to_uint64_ns;;', expect: '-> int64' }] },
254
+
{ group: 'Mtime', name: '2.1.0: Span.of_uint64_ns', universe: U['mtime.2.1.0'], require: ['mtime'],
255
+
steps: [{ code: 'Mtime.Span.of_uint64_ns 1_000_000_000L;;', expect: 'Mtime.span' }] },
256
+
257
+
// ── Logs ──
258
+
{ group: 'Logs', name: '0.10.0: Src.create and Src.name', universe: U['logs.0.10.0'], require: ['logs'],
259
+
steps: [
260
+
{ code: 'let src = Logs.Src.create "test" ~doc:"A test source";;', expect: 'Logs.src' },
261
+
{ code: 'Logs.Src.name src;;', expect: '"test"' },
262
+
] },
263
+
264
+
// ── Astring ──
265
+
{ group: 'Astring', name: '0.8.5: String.cuts', universe: U['astring.0.8.5'], require: ['astring'],
266
+
steps: [{ code: 'Astring.String.cuts ~sep:"," "a,b,c";;', expect: '["a"; "b"; "c"]' }] },
267
+
{ group: 'Astring', name: '0.8.5: String.concat', universe: U['astring.0.8.5'], require: ['astring'],
268
+
steps: [{ code: 'Astring.String.concat ~sep:"-" ["x"; "y"; "z"];;', expect: '"x-y-z"' }] },
269
+
{ group: 'Astring', name: '0.8.5: String.Sub', universe: U['astring.0.8.5'], require: ['astring'],
270
+
steps: [{ code: 'Astring.String.Sub.(to_string (v "hello world" ~start:6));;', expect: '"world"' }] },
271
+
272
+
// ── Jsonm ──
273
+
{ group: 'Jsonm', name: '1.0.2: decode JSON', universe: U['jsonm.1.0.2'], require: ['jsonm'],
274
+
steps: [{ code: 'let d = Jsonm.decoder (`String "42") in Jsonm.decode d;;', expect: '`Lexeme' }] },
275
+
276
+
// ── Xmlm ──
277
+
{ group: 'Xmlm', name: '1.4.0: parse XML', universe: U['xmlm.1.4.0'], require: ['xmlm'],
278
+
steps: [{ code: 'let i = Xmlm.make_input (`String (0, "<root/>")) in Xmlm.input i;;', expect: '`Dtd' }] },
279
+
280
+
// ── Ptime ──
281
+
{ group: 'Ptime', name: '1.2.0: epoch', universe: U['ptime.1.2.0'], require: ['ptime'],
282
+
steps: [{ code: 'Ptime.epoch;;', expect: 'Ptime.t' }] },
283
+
{ group: 'Ptime', name: '1.2.0: date creation', universe: U['ptime.1.2.0'], require: ['ptime'],
284
+
steps: [{ code: 'Ptime.of_date_time ((2024, 1, 1), ((0, 0, 0), 0));;', expect: 'Some' }] },
285
+
{ group: 'Ptime', name: '1.2.0: Span round-trip', universe: U['ptime.1.2.0'], require: ['ptime'],
286
+
steps: [{ code: 'Ptime.Span.of_int_s 3600 |> Ptime.Span.to_int_s;;', expect: '3600' }] },
287
+
288
+
// ── React ──
289
+
{ group: 'React', name: '1.2.2: signal create/read/update', universe: U['react.1.2.2'], require: ['react'],
290
+
steps: [
291
+
{ code: 'let s, set_s = React.S.create 0;;', expect: 'React.signal' },
292
+
{ code: 'React.S.value s;;', expect: '0' },
293
+
{ code: 'set_s 42;;', expect: '' },
294
+
{ code: 'React.S.value s;;', expect: '42' },
295
+
] },
296
+
297
+
// ── Hmap ──
298
+
{ group: 'Hmap', name: '0.8.1: heterogeneous keys + lookup', universe: U['hmap.0.8.1'], require: ['hmap'],
299
+
steps: [
300
+
{ code: 'let k_int : int Hmap.key = Hmap.Key.create ();;', expect: 'Hmap.key' },
301
+
{ code: 'let k_str : string Hmap.key = Hmap.Key.create ();;', expect: 'Hmap.key' },
302
+
{ code: 'let m = Hmap.empty |> Hmap.add k_int 42 |> Hmap.add k_str "hello";;', expect: 'Hmap.t' },
303
+
{ code: 'Hmap.find k_int m;;', expect: 'Some 42' },
304
+
{ code: 'Hmap.find k_str m;;', expect: 'Some "hello"' },
305
+
] },
306
+
307
+
// ── Gg ──
308
+
{ group: 'Gg', name: '1.0.0: V2 vectors + addition', universe: U['gg.1.0.0'], require: ['gg'],
309
+
steps: [
310
+
{ code: 'Gg.V2.v 1.0 2.0;;', expect: 'Gg.v2' },
311
+
{ code: 'let r = Gg.V2.add (Gg.V2.v 1.0 2.0) (Gg.V2.v 3.0 4.0) in Gg.V2.x r;;', expect: '4.' },
312
+
] },
313
+
{ group: 'Gg', name: '1.0.0: colors', universe: U['gg.1.0.0'], require: ['gg'],
314
+
steps: [{ code: 'Gg.Color.red;;', expect: 'Gg.color' }] },
315
+
316
+
// ── Vg ──
317
+
{ group: 'Vg', name: '0.9.5: paths and images', universe: U['vg.0.9.5'], require: ['vg', 'gg'],
318
+
steps: [
319
+
{ code: 'let p = Vg.P.empty |> Vg.P.line (Gg.V2.v 1.0 1.0);;', expect: 'Vg.path' },
320
+
{ code: 'let img = Vg.I.cut p (Vg.I.const Gg.Color.red);;', expect: 'Vg.image' },
321
+
] },
322
+
323
+
// ── Note ──
324
+
{ group: 'Note', name: '0.0.3: const signal', universe: U['note.0.0.3'], require: ['note'],
325
+
steps: [
326
+
{ code: 'let s = Note.S.const 42;;', expect: 'Note.signal' },
327
+
{ code: 'Note.S.value s;;', expect: '42' },
328
+
] },
329
+
330
+
// ── Otfm ──
331
+
{ group: 'Otfm', name: '0.4.0: decoder type', universe: U['otfm.0.4.0'], require: ['otfm'],
332
+
steps: [{ code: 'Otfm.decoder;;', expect: '-> Otfm.decoder' }] },
333
+
334
+
// ── Fpath ──
335
+
{ group: 'Fpath', name: '0.7.3: path ops', universe: U['fpath.0.7.3'], require: ['fpath'],
336
+
steps: [
337
+
{ code: 'Fpath.v "/usr/local/bin" |> Fpath.to_string;;', expect: '"/usr/local/bin"' },
338
+
{ code: 'Fpath.(v "/usr" / "local" / "bin") |> Fpath.to_string;;', expect: '"/usr/local/bin"' },
339
+
{ code: 'Fpath.v "/usr/local/bin" |> Fpath.parent |> Fpath.to_string;;', expect: '"/usr/local/"' },
340
+
{ code: 'Fpath.v "/usr/local/bin" |> Fpath.basename;;', expect: '"bin"' },
341
+
] },
342
+
343
+
// ── Uutf ──
344
+
{ group: 'Uutf', name: '1.0.4: UTF-8 decoder', universe: U['uutf.1.0.4'], require: ['uutf'],
345
+
steps: [
346
+
{ code: 'let d = Uutf.decoder ~encoding:`UTF_8 (`String "ABC");;', expect: 'Uutf.decoder' },
347
+
{ code: 'Uutf.decode d;;', expect: '`Uchar' },
348
+
] },
349
+
350
+
// ── B0 ──
351
+
{ group: 'B0', name: '0.0.6: B0_std.Fpath', universe: U['b0.0.0.6'], require: ['b0.std'],
352
+
steps: [{ code: 'B0_std.Fpath.v "/tmp";;', expect: 'B0_std.Fpath.t' }] },
353
+
354
+
// ── Bos ──
355
+
{ group: 'Bos (cross-library)', name: '0.2.1: Cmd construction', universe: U['bos.0.2.1'], require: ['bos'],
356
+
steps: [{ code: 'Bos.Cmd.(v "echo" % "hello");;', expect: 'Bos.Cmd' }] },
357
+
];
358
+
359
+
// ── Flatten cross-version tests into individual test items ─────────
360
+
const flatTests = [];
361
+
for (const t of tests) {
362
+
if (t.crossVersion) {
363
+
for (const c of t.cases) {
364
+
flatTests.push({
365
+
group: t.group,
366
+
name: c.label,
367
+
universe: c.universe,
368
+
require: c.require || [],
369
+
crossVersion: true,
370
+
crossCode: t.code,
371
+
crossDescription: t.description,
372
+
shouldPass: c.shouldPass,
373
+
steps: c.shouldPass
374
+
? [{ code: t.code, expect: c.expect || '' }]
375
+
: [{ code: t.code, expectError: c.expectError || 'Error' }],
376
+
});
377
+
}
378
+
} else {
379
+
flatTests.push(t);
380
+
}
381
+
}
382
+
383
+
// ── Runner ────────────────────────────────────────────────────────────
384
+
385
+
let passed = 0, failed = 0, skipped = 0, running = 0;
386
+
const total = flatTests.length;
387
+
const groupsEl = document.getElementById('groups');
388
+
const groupEls = {};
389
+
const testEls = [];
390
+
391
+
function updateSummary() {
392
+
document.getElementById('pass-count').textContent = passed;
393
+
document.getElementById('fail-count').textContent = failed;
394
+
document.getElementById('skip-count').textContent = skipped;
395
+
document.getElementById('run-count').textContent = running;
396
+
const done = passed + failed + skipped;
397
+
document.getElementById('progress-bar').style.width = `${(done / total) * 100}%`;
398
+
}
399
+
400
+
function escHtml(s) {
401
+
return s.replace(/&/g,'&').replace(/</g,'<').replace(/>/g,'>');
402
+
}
403
+
404
+
// Track which cross-version code banners we've shown per group
405
+
const shownBanners = {};
406
+
407
+
// Build DOM
408
+
for (let i = 0; i < flatTests.length; i++) {
409
+
const t = flatTests[i];
410
+
if (!groupEls[t.group]) {
411
+
const g = document.createElement('div');
412
+
g.className = 'group';
413
+
const header = document.createElement('div');
414
+
header.className = 'group-header';
415
+
const isCross = t.crossVersion;
416
+
header.innerHTML = `<span>${t.group}${isCross ? '<span class="group-badge cross">cross-version</span>' : ''}</span><span class="arrow">\u25BC</span>`;
417
+
const body = document.createElement('div');
418
+
body.className = 'group-body';
419
+
header.onclick = () => {
420
+
header.classList.toggle('collapsed');
421
+
body.classList.toggle('hidden');
422
+
};
423
+
g.appendChild(header);
424
+
g.appendChild(body);
425
+
groupsEl.appendChild(g);
426
+
groupEls[t.group] = { el: g, header, body, tests: [] };
427
+
}
428
+
429
+
// For cross-version tests, show the code banner once per group
430
+
if (t.crossVersion && !shownBanners[t.group]) {
431
+
shownBanners[t.group] = true;
432
+
const banner = document.createElement('div');
433
+
banner.className = 'code-banner';
434
+
banner.innerHTML = `<code>${escHtml(t.crossCode)}</code>${t.crossDescription ? ` — <em>${escHtml(t.crossDescription)}</em>` : ''}`;
435
+
groupEls[t.group].body.appendChild(banner);
436
+
}
437
+
438
+
const badgeHtml = t.crossVersion
439
+
? (t.shouldPass
440
+
? '<span class="expect-badge should-pass">expect: pass</span>'
441
+
: '<span class="expect-badge should-error">expect: error</span>')
442
+
: '';
443
+
444
+
const row = document.createElement('div');
445
+
row.className = 'test-row pending';
446
+
row.innerHTML = `
447
+
<span class="test-icon">\u25CB</span>
448
+
<div class="test-name"><span class="label">${escHtml(t.name)}</span>${badgeHtml}<div class="test-detail"></div></div>
449
+
<span class="test-time"></span>
450
+
`;
451
+
groupEls[t.group].body.appendChild(row);
452
+
groupEls[t.group].tests.push(row);
453
+
testEls.push(row);
454
+
}
455
+
456
+
// transcript: array of { code, output, outputClass }
457
+
function setTestState(row, state, transcript, time) {
458
+
row.className = `test-row ${state}`;
459
+
const icons = { pass: '\u2714', 'pass-neg': '\u2714', fail: '\u2718', skip: '\u25CB', running: '<span class="spinner">\u25E0</span>', pending: '\u25CB' };
460
+
row.querySelector('.test-icon').innerHTML = icons[state] || '\u25CB';
461
+
if (transcript && transcript.length > 0) {
462
+
const detailEl = row.querySelector('.test-detail');
463
+
let html = '';
464
+
for (const step of transcript) {
465
+
html += '<div class="step-transcript">';
466
+
if (step.code) {
467
+
html += `<div class="step-input">${escHtml(step.code)}</div>`;
468
+
}
469
+
if (step.output) {
470
+
const cls = step.outputClass || 'out-pass';
471
+
html += `<div class="step-output ${cls}">${escHtml(step.output)}</div>`;
472
+
}
473
+
html += '</div>';
474
+
}
475
+
detailEl.innerHTML = html;
476
+
}
477
+
if (time !== undefined) {
478
+
row.querySelector('.test-time').textContent = `${time}ms`;
479
+
}
480
+
}
481
+
482
+
// Worker cache
483
+
const workerCache = new Map();
484
+
485
+
async function getWorker(universe) {
486
+
if (workerCache.has(universe)) return workerCache.get(universe);
487
+
const indexUrl = `/jtw-output/u/${universe}/findlib_index`;
488
+
const { worker: w, stdlib_dcs, findlib_index } = await OcamlWorker.fromIndex(
489
+
indexUrl, '/jtw-output', { timeout: 120000 });
490
+
await w.init({
491
+
findlib_requires: [],
492
+
stdlib_dcs: stdlib_dcs,
493
+
findlib_index: findlib_index,
494
+
});
495
+
workerCache.set(universe, w);
496
+
return w;
497
+
}
498
+
499
+
async function runTest(t, idx) {
500
+
const row = testEls[idx];
501
+
setTestState(row, 'running');
502
+
running++;
503
+
updateSummary();
504
+
const start = performance.now();
505
+
506
+
try {
507
+
const worker = await getWorker(t.universe);
508
+
509
+
for (const pkg of (t.require || [])) {
510
+
await worker.eval(`#require "${pkg}";;`);
511
+
}
512
+
513
+
const transcript = [];
514
+
for (const step of t.steps) {
515
+
if (step.complete) {
516
+
const result = await worker.complete(step.complete.source, step.complete.pos);
517
+
const entries = result.completions?.entries?.map(e => e.name) || [];
518
+
if (step.expectEntries) {
519
+
for (const exp of step.expectEntries) {
520
+
if (!entries.includes(exp))
521
+
throw new Error(`Expected completion "${exp}" not found in [${entries.join(', ')}]`);
522
+
}
523
+
}
524
+
transcript.push({ code: step.complete.source, output: `completions: [${entries.slice(0, 5).join(', ')}...]`, outputClass: 'out-pass' });
525
+
526
+
} else if (step.expectError) {
527
+
// NEGATIVE TEST: we expect this to produce an error
528
+
const r = await worker.eval(step.code);
529
+
const ppf = r.caml_ppf || '';
530
+
const stderr = r.stderr || '';
531
+
const combined = ppf + stderr;
532
+
if (combined.includes(step.expectError)) {
533
+
transcript.push({ code: step.code, output: combined.trim(), outputClass: 'out-neg' });
534
+
} else if (combined === '' && ppf === '') {
535
+
transcript.push({ code: step.code, output: '(empty output — error swallowed)', outputClass: 'out-neg' });
536
+
} else {
537
+
transcript.push({ code: step.code, output: `Expected error "${step.expectError}" but got:\n${ppf}${stderr}`, outputClass: 'out-fail' });
538
+
throw new Error(`Expected error containing "${step.expectError}" but got success:\nppf: "${ppf}"\nstderr: "${stderr}"`);
539
+
}
540
+
541
+
} else {
542
+
const r = await worker.eval(step.code);
543
+
const ppf = r.caml_ppf || '';
544
+
const stdout = r.stdout || '';
545
+
const stderr = r.stderr || '';
546
+
547
+
if (step.expect && step.expect !== '') {
548
+
if (!ppf.includes(step.expect)) {
549
+
transcript.push({ code: step.code, output: ppf || stderr || '(no output)', outputClass: 'out-fail' });
550
+
throw new Error(`Expected caml_ppf to contain "${step.expect}"\nGot: "${ppf}"\nstderr: "${stderr}"`);
551
+
}
552
+
}
553
+
if (step.expectStdout) {
554
+
if (!stdout.includes(step.expectStdout)) {
555
+
transcript.push({ code: step.code, output: `stdout: "${stdout}"`, outputClass: 'out-fail' });
556
+
throw new Error(`Expected stdout to contain "${step.expectStdout}"\nGot: "${stdout}"`);
557
+
}
558
+
}
559
+
if (step.expectNotError) {
560
+
if ((ppf + stderr).includes(step.expectNotError)) {
561
+
transcript.push({ code: step.code, output: ppf + stderr, outputClass: 'out-fail' });
562
+
throw new Error(`Output contains unexpected "${step.expectNotError}"\nppf: "${ppf}"\nstderr: "${stderr}"`);
563
+
}
564
+
}
565
+
// Build output line: ppf first, then stdout if present
566
+
let out = ppf ? ppf.trim() : '';
567
+
if (stdout) out += (out ? '\n' : '') + '(stdout) ' + stdout.trim();
568
+
transcript.push({ code: step.code, output: out || '(unit)', outputClass: 'out-pass' });
569
+
}
570
+
}
571
+
572
+
const elapsed = Math.round(performance.now() - start);
573
+
running--;
574
+
passed++;
575
+
576
+
// Use pass-neg state for negative tests that correctly errored
577
+
const isNegPass = t.crossVersion && !t.shouldPass;
578
+
setTestState(row, isNegPass ? 'pass-neg' : 'pass', transcript, elapsed);
579
+
580
+
} catch (e) {
581
+
const elapsed = Math.round(performance.now() - start);
582
+
running--;
583
+
failed++;
584
+
// If transcript has partial results from before the error, show them
585
+
if (transcript.length === 0) {
586
+
transcript.push({ code: '', output: e.message, outputClass: 'out-fail' });
587
+
}
588
+
setTestState(row, 'fail', transcript, elapsed);
589
+
}
590
+
updateSummary();
591
+
}
592
+
593
+
// Run tests: parallel across universes, sequential within each universe
594
+
async function runAll() {
595
+
const byUniverse = new Map();
596
+
flatTests.forEach((t, i) => {
597
+
if (!byUniverse.has(t.universe)) byUniverse.set(t.universe, []);
598
+
byUniverse.get(t.universe).push({ test: t, idx: i });
599
+
});
600
+
601
+
const promises = [];
602
+
for (const [, items] of byUniverse) {
603
+
promises.push((async () => {
604
+
for (const { test, idx } of items) {
605
+
await runTest(test, idx);
606
+
}
607
+
})());
608
+
}
609
+
await Promise.all(promises);
610
+
}
611
+
612
+
updateSummary();
613
+
runAll();
614
+
</script>
615
+
</body>
616
+
</html>
+98
js_top_worker/test/ohc-integration/test.html
+98
js_top_worker/test/ohc-integration/test.html
···
1
+
<!DOCTYPE html>
2
+
<html>
3
+
<head>
4
+
<meta charset="utf-8">
5
+
<title>OHC JTW Integration Test</title>
6
+
</head>
7
+
<body>
8
+
<h1>OHC JTW Integration Test</h1>
9
+
<div id="status">Loading...</div>
10
+
<div id="results"></div>
11
+
<script type="module">
12
+
import { OcamlWorker } from '/client/ocaml-worker.js';
13
+
14
+
const status = document.getElementById('status');
15
+
const results = document.getElementById('results');
16
+
17
+
function log(msg) {
18
+
const p = document.createElement('pre');
19
+
p.textContent = msg;
20
+
results.appendChild(p);
21
+
console.log(msg);
22
+
}
23
+
24
+
// Read config from URL params
25
+
const params = new URLSearchParams(window.location.search);
26
+
const universe = params.get('universe');
27
+
const compilerVersion = params.get('compiler') || '5.4.0';
28
+
29
+
if (!universe) {
30
+
status.textContent = 'Error: ?universe= parameter required';
31
+
throw new Error('universe parameter required');
32
+
}
33
+
34
+
status.textContent = 'Fetching findlib_index...';
35
+
const indexUrl = `/jtw-output/u/${universe}/findlib_index`;
36
+
const { worker, stdlib_dcs, findlib_index } = await OcamlWorker.fromIndex(
37
+
indexUrl, '/jtw-output', { timeout: 120000 });
38
+
39
+
try {
40
+
status.textContent = 'Initializing (loading stdlib)...';
41
+
await worker.init({
42
+
findlib_requires: [],
43
+
stdlib_dcs: stdlib_dcs,
44
+
findlib_index: findlib_index,
45
+
});
46
+
47
+
status.textContent = 'Worker ready';
48
+
document.getElementById('status').dataset.ready = 'true';
49
+
50
+
// Test 1: Basic arithmetic
51
+
log('--- Test 1: Basic arithmetic ---');
52
+
const r1 = await worker.eval('let x = 1 + 2;;');
53
+
log('eval: let x = 1 + 2;;');
54
+
log('caml_ppf: ' + r1.caml_ppf);
55
+
document.getElementById('results').dataset.test1 = r1.caml_ppf;
56
+
57
+
// Test 2: String operations
58
+
log('--- Test 2: String operations ---');
59
+
const r2 = await worker.eval('String.concat ", " ["hello"; "world"];;');
60
+
log('eval: String.concat ", " ["hello"; "world"];;');
61
+
log('caml_ppf: ' + r2.caml_ppf);
62
+
document.getElementById('results').dataset.test2 = r2.caml_ppf;
63
+
64
+
// Test 3: Load fmt via #require
65
+
log('--- Test 3: Load fmt ---');
66
+
const r3 = await worker.eval('#require "fmt";;');
67
+
log('eval: #require "fmt";;');
68
+
log('caml_ppf: ' + r3.caml_ppf);
69
+
log('stderr: ' + r3.stderr);
70
+
document.getElementById('results').dataset.test3 = 'loaded';
71
+
72
+
// Test 4: Use fmt
73
+
log('--- Test 4: Use Fmt ---');
74
+
const r4 = await worker.eval('Fmt.str "%a" Fmt.int 42;;');
75
+
log('eval: Fmt.str "%a" Fmt.int 42;;');
76
+
log('caml_ppf: ' + r4.caml_ppf);
77
+
document.getElementById('results').dataset.test4 = r4.caml_ppf;
78
+
79
+
// Test 5: Completions
80
+
log('--- Test 5: Completions ---');
81
+
const r5 = await worker.complete('Fmt.i', 5);
82
+
log('complete: Fmt.i at pos 5');
83
+
const entries = r5.completions?.entries || [];
84
+
log('entries: ' + entries.map(e => e.name).join(', '));
85
+
document.getElementById('results').dataset.test5 = entries.length > 0 ? 'ok' : 'empty';
86
+
87
+
status.textContent = 'All tests complete';
88
+
document.getElementById('status').dataset.done = 'true';
89
+
90
+
} catch (err) {
91
+
status.textContent = 'Error: ' + err.message;
92
+
log('ERROR: ' + err.message);
93
+
log('Stack: ' + err.stack);
94
+
document.getElementById('status').dataset.error = err.message;
95
+
}
96
+
</script>
97
+
</body>
98
+
</html>
+69
js_top_worker/test/ohc-integration/tutorials/index.html
+69
js_top_worker/test/ohc-integration/tutorials/index.html
···
1
+
<!DOCTYPE html>
2
+
<html>
3
+
<head>
4
+
<meta charset="utf-8">
5
+
<title>JTW Library Tutorials</title>
6
+
<style>
7
+
* { box-sizing: border-box; margin: 0; padding: 0; }
8
+
body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', system-ui, sans-serif; background: #0d1117; color: #c9d1d9; padding: 40px 24px; line-height: 1.5; }
9
+
.container { max-width: 960px; margin: 0 auto; }
10
+
h1 { color: #f0f6fc; font-size: 28px; margin-bottom: 4px; }
11
+
.subtitle { color: #8b949e; font-size: 15px; margin-bottom: 32px; }
12
+
.subtitle a { color: #58a6ff; text-decoration: none; }
13
+
.subtitle a:hover { text-decoration: underline; }
14
+
15
+
.lib-group { margin-bottom: 32px; }
16
+
.lib-group h2 { font-size: 16px; color: #f0f6fc; margin-bottom: 10px; padding-bottom: 6px; border-bottom: 1px solid #21262d; }
17
+
.lib-group .desc { font-size: 13px; color: #8b949e; margin-bottom: 10px; }
18
+
19
+
.version-cards { display: flex; flex-wrap: wrap; gap: 8px; }
20
+
.version-card { display: block; padding: 8px 14px; background: #161b22; border: 1px solid #30363d; border-radius: 8px; text-decoration: none; color: #c9d1d9; font-size: 14px; transition: border-color 0.2s, background 0.2s; }
21
+
.version-card:hover { border-color: #58a6ff; background: #1c2128; }
22
+
.version-card .ver { font-family: 'SF Mono', 'Fira Code', monospace; color: #d2a8ff; font-weight: 600; }
23
+
.version-card .steps { font-size: 11px; color: #8b949e; margin-top: 2px; }
24
+
</style>
25
+
</head>
26
+
<body>
27
+
<div class="container">
28
+
<h1>JTW Library Tutorials</h1>
29
+
<p class="subtitle">Interactive OCaml tutorials built from ohc JTW output — <a href="../runner.html">test runner</a></p>
30
+
<div id="groups"></div>
31
+
</div>
32
+
33
+
<script type="module">
34
+
import { TUTORIALS } from './test-defs.js';
35
+
36
+
// Group tutorials by library name
37
+
const libs = {};
38
+
for (const [key, t] of Object.entries(TUTORIALS)) {
39
+
if (!libs[t.name]) libs[t.name] = { name: t.name, description: t.description, versions: [] };
40
+
const stepCount = t.sections.reduce((n, s) => n + s.steps.length, 0);
41
+
libs[t.name].versions.push({ key, version: t.version, steps: stepCount });
42
+
}
43
+
44
+
// Sort libraries alphabetically, versions by semver
45
+
const sorted = Object.values(libs).sort((a, b) => a.name.localeCompare(b.name));
46
+
for (const lib of sorted) {
47
+
lib.versions.sort((a, b) => a.version.localeCompare(b.version, undefined, { numeric: true }));
48
+
}
49
+
50
+
const container = document.getElementById('groups');
51
+
for (const lib of sorted) {
52
+
const g = document.createElement('div');
53
+
g.className = 'lib-group';
54
+
let html = `<h2>${lib.name}</h2>`;
55
+
html += `<div class="desc">${lib.description}</div>`;
56
+
html += '<div class="version-cards">';
57
+
for (const v of lib.versions) {
58
+
html += `<a class="version-card" href="tutorial.html?pkg=${encodeURIComponent(v.key)}">`;
59
+
html += `<div class="ver">${v.version}</div>`;
60
+
html += `<div class="steps">${v.steps} steps</div>`;
61
+
html += `</a>`;
62
+
}
63
+
html += '</div>';
64
+
g.innerHTML = html;
65
+
container.appendChild(g);
66
+
}
67
+
</script>
68
+
</body>
69
+
</html>
+2785
js_top_worker/test/ohc-integration/tutorials/test-defs.js
+2785
js_top_worker/test/ohc-integration/tutorials/test-defs.js
···
1
+
// Tutorial test definitions for OCaml libraries
2
+
// Each entry is a self-contained interactive tutorial
3
+
4
+
const U = {
5
+
// ── Bunzli libraries ──
6
+
'fmt.0.9.0': '9901393f978b0a6627c5eab595111f50',
7
+
'fmt.0.10.0': 'd8140118651d08430f933d410a909e3b',
8
+
'fmt.0.11.0': '7663cce356513833b908ae5e4f521106',
9
+
'cmdliner.1.0.4': '0dd34259dc0892e543b03b3afb0a77fa',
10
+
'cmdliner.1.3.0': '258e7979b874502ea546e90a0742184a',
11
+
'cmdliner.2.0.0': '91c3d96cea9b89ddd24cf7b78786a5ca',
12
+
'cmdliner.2.1.0': 'f3e665d5388ac380a70c5ed67f465bbb',
13
+
'mtime.1.3.0': 'b6735658fd307bba23a7c5f21519b910',
14
+
'mtime.1.4.0': 'ebccfc43716c6da0ca4a065e60d0f875',
15
+
'mtime.2.1.0': '7db699c334606d6f66e65c8b515d298d',
16
+
'logs.0.7.0': '2c014cfbbee1d278b162002eae03eaa8',
17
+
'logs.0.10.0': '07a565e7588ce100ffd7c8eb8b52df07',
18
+
'uucp.14.0.0': '60e1409eb30c0650c4d4cbcf3c453e65',
19
+
'uucp.15.0.0': '6a96a3f145249f110bf14739c78e758c',
20
+
'uucp.16.0.0': '2bf0fbf12aa05c8f99989a759d2dc8cf',
21
+
'uucp.17.0.0': '58b9c48e9528ce99586b138d8f4778c2',
22
+
'uunf.14.0.0': 'cac36534f1bf353fd2192efd015dd0e6',
23
+
'uunf.17.0.0': '96704cd9810ea1ed504e4ed71cde82b0',
24
+
'astring.0.8.5': '1cdbe76f0ec91a6eb12bd0279a394492',
25
+
'jsonm.1.0.2': 'ac28e00ecd46c9464f5575c461b5d48f',
26
+
'xmlm.1.4.0': 'c4c22d0db3ea01343c1a868bab35e1b4',
27
+
'ptime.1.2.0': 'd57c69f3dd88b91454622c1841971354',
28
+
'react.1.2.2': 'f438ba61693a5448718c73116b228f3c',
29
+
'hmap.0.8.1': '753d7c421afb866e7ffe07ddea3b8349',
30
+
'gg.1.0.0': '02a9bababc92d6639cdbaf20233597ba',
31
+
'note.0.0.3': '2545f914c274aa806d29749eb96836fa',
32
+
'otfm.0.4.0': '4f870a70ee71e41dff878af7123b2cd6',
33
+
'vg.0.9.5': '0e2e71cfd8fe2e81bff124849421f662',
34
+
'bos.0.2.1': '0e04faa6cc5527bc124d8625bded34fc',
35
+
'fpath.0.7.3': '6c4fe09a631d871865fd38aa15cd61d4',
36
+
'uutf.1.0.4': 'ac04fa0671533316f94dacbd14ffe0bf',
37
+
'uuseg.14.0.0': '406ca4903030ee122ff6c61b61446ddc',
38
+
'uuseg.15.0.0': '62ea8502ec4e6c386a070cc75ec8377a',
39
+
'uuseg.16.0.0': '3a191102f91addba06efdd712ba037b2',
40
+
'uuseg.17.0.0': '7d9b8800252a9bec2a9be496e02eb9da',
41
+
'b0.0.0.6': 'bfc34a228f53ac5ced707eed285a6e5c',
42
+
43
+
// ── Serialization ──
44
+
'yojson.1.7.0': '0273d3484c1256a463fc6b5d822ba4ae',
45
+
'yojson.2.0.2': 'b02baa519ba5bedf95d1b42b5e66381a',
46
+
'yojson.2.1.2': '5efcef16114ee98834c3f4cf9a7f45b4',
47
+
'yojson.2.2.2': '739ca5bed6c1201d906f0f3132274687',
48
+
'yojson.3.0.0': 'e52f084da1b654e881d2dba81775b440',
49
+
'ezjsonm.1.1.0': '899976ac0dc15192e669f652bf29f29e',
50
+
'ezjsonm.1.2.0': 'b93294aee1f9361bfe1916f4127fa56c',
51
+
'ezjsonm.1.3.0': '98ee39eafcb78d7c102a291c7faa302e',
52
+
'sexplib0.v0.15.1':'f6fb7feeb446b4a67adb486a2392bf3e',
53
+
'sexplib0.v0.16.0':'8ec78baf83bdc6a0a181b58efb909869',
54
+
'sexplib0.v0.17.0':'08fe6d134ac413075564220297b2554f',
55
+
'csexp.1.5.2': '8443eb56f5227050537a4eb47b26fd10',
56
+
'base64.3.4.0': '9befb8850a0bcfb0556f8a7d2de8d3bd',
57
+
'base64.3.5.2': 'dee9a00f3ec355e7dab15121d7cb5a3c',
58
+
59
+
// ── Text / Parsing ──
60
+
're.1.10.4': '4697515ef0ed56df99029cfa8b6a4c1a',
61
+
're.1.11.0': '87fd99e341a1468e36de4973044ba1cb',
62
+
're.1.12.0': '3bc6cdc9f1fd39cd5ee61b89f423f51a',
63
+
're.1.13.2': 'e080307b8290a25f41d4ad87427c3cc0',
64
+
're.1.14.0': '7f3c1f0452e7156dea56c1a52e2096a4',
65
+
'angstrom.0.15.0':'12fe7a4d575b34f30551cf6eaaed4a0b',
66
+
'angstrom.0.16.1':'f46aa50b81b7e6a0dd7ee69d247920c0',
67
+
'tyre.0.5': 'ffdb349acdd211cf2699a689ed1491d3',
68
+
'tyre.1.0': 'e413ed92802108a275144c27e0f9efa8',
69
+
70
+
// ── Data structures ──
71
+
'containers.3.17': '62a1dfab4e79dda21e6775fc35bac90b',
72
+
'iter.1.7': '4aca16dd3c74db420f49a18cc54fd66f',
73
+
'iter.1.8': '7724b461d742c869a4abfaa870879763',
74
+
'iter.1.9': '73e7b9c9b638abf269affd1967509ce6',
75
+
'ocamlgraph.2.0.0':'bcfe5c830a54c4fc55121d6bc69d52d4',
76
+
'ocamlgraph.2.1.0':'e867dbcc2de571de4cb84d9a45e554bd',
77
+
'ocamlgraph.2.2.0':'ab9aa04f9746bf7c5b275cfddfc9dc20',
78
+
79
+
// ── Crypto / Encoding ──
80
+
'digestif.1.1.2': '33d25472185fc31bd41d277d488478f2',
81
+
'digestif.1.3.0': 'c3664212cf01a38aa9af7c54123056cf',
82
+
'hex.1.4.0': '0bff54cafa851851e4ddb617126d4ce6',
83
+
'hex.1.5.0': 'a46b45c6915570ff2966d96d9101258c',
84
+
'eqaf.0.9': '39499417427d1d35a028fc9101ecbfb2',
85
+
'eqaf.0.10': 'eed017d4f8c09e4fcabf2f9320361e64',
86
+
87
+
// ── Networking types ──
88
+
'uri.4.2.0': '473a4aaa6884b7d04af481a4bcf573e6',
89
+
'uri.4.4.0': '3f9567317844352b63256b5d7075e595',
90
+
'ipaddr.5.6.0': 'ca33bd0287b9b4cd9f67a4c6464b0bd9',
91
+
'ipaddr.5.6.1': '516728912d49b2b8b007b762f0cd985f',
92
+
'domain-name.0.4.1':'55bf622c2e1dacb9e5c7da2cf9195e95',
93
+
'domain-name.0.5.0':'e069e9e37be7c2d8264f41a661136c60',
94
+
95
+
// ── Math ──
96
+
'zarith.1.13': '5b98616ce2f37ecfbefd3d8c7c1f45a9',
97
+
'zarith.1.14': '3abb9b1ae0690526d21d9630f3f27153',
98
+
99
+
// ── Testing ──
100
+
'qcheck-core.0.25':'c338cf74d7ad14da542181619f55fbda',
101
+
'qcheck-core.0.27':'eb7a98de039353471656e141c6107fc3',
102
+
'qcheck-core.0.91':'c1307fa49614dc884aa0fec68b55c832',
103
+
};
104
+
105
+
// ── Factory: Fmt (same API across 0.9–0.11) ────────────────────────────
106
+
function fmtTutorial(version, universe) {
107
+
return {
108
+
name: 'Fmt', version, opam: 'fmt',
109
+
description: 'OCaml Format pretty-printer combinators',
110
+
universe, require: ['fmt'],
111
+
sections: [
112
+
{ title: 'String Formatting',
113
+
description: 'Fmt.str works like Printf.sprintf, building a string from a format string.',
114
+
steps: [
115
+
{ code: 'Fmt.str "%d" 42;;', expect: '"42"',
116
+
description: 'Format an integer into a string' },
117
+
{ code: 'Fmt.str "Hello, %s!" "world";;', expect: '"Hello, world!"',
118
+
description: 'Interpolate a string value' },
119
+
{ code: 'Fmt.str "%d + %d = %d" 1 2 3;;', expect: '"1 + 2 = 3"',
120
+
description: 'Multiple format arguments' },
121
+
{ code: 'Fmt.str "%a" Fmt.int 42;;', expect: '"42"',
122
+
description: 'Use a typed formatter with %a' },
123
+
] },
124
+
{ title: 'Typed Formatters',
125
+
description: 'Fmt provides typed formatter values (type \'a Fmt.t = Format.formatter -> \'a -> unit) for common types.',
126
+
steps: [
127
+
{ code: 'Fmt.str "%a" Fmt.bool true;;', expect: '"true"',
128
+
description: 'Format a boolean' },
129
+
{ code: 'Fmt.str "%a" Fmt.float 3.14;;', expect: '3.14',
130
+
description: 'Format a float' },
131
+
{ code: 'Fmt.str "%a" Fmt.string "hi";;', expect: '"hi"',
132
+
description: 'Format a string with the string formatter' },
133
+
] },
134
+
{ title: 'Collection Formatters',
135
+
description: 'Fmt can format lists, options, pairs, and results with configurable separators.',
136
+
steps: [
137
+
{ code: 'Fmt.str "%a" Fmt.(list int) [1; 2; 3];;', expect: '1',
138
+
description: 'Format a list of ints (default separator)' },
139
+
{ code: 'Fmt.str "%a" Fmt.(list ~sep:comma int) [1; 2; 3];;', expect: '1, 2',
140
+
description: 'Format a list with comma separators' },
141
+
{ code: 'Fmt.str "%a" Fmt.(list ~sep:(any " ") int) [10; 20];;', expect: '"10 20"',
142
+
description: 'Format with space separators using Fmt.any' },
143
+
{ code: 'Fmt.str "%a" Fmt.(option int) (Some 5);;', expect: '5',
144
+
description: 'Format an option value' },
145
+
{ code: 'Fmt.str "%a" Fmt.(option int) None;;', expect: '',
146
+
description: 'Format None (empty output by default)' },
147
+
{ code: 'Fmt.str "%a" Fmt.(pair ~sep:comma int string) (42, "hi");;', expect: '42',
148
+
description: 'Format a pair' },
149
+
] },
150
+
{ title: 'Output to stdout',
151
+
description: 'Fmt.pr prints directly to stdout. Use @. for a newline flush.',
152
+
steps: [
153
+
{ code: 'Fmt.pr "value: %d@." 42;;', expectStdout: 'value: 42',
154
+
description: 'Print formatted output to stdout' },
155
+
{ code: 'Fmt.pr "%a@." Fmt.(list ~sep:sp int) [1; 2; 3];;', expectStdout: '1',
156
+
description: 'Print a list to stdout' },
157
+
] },
158
+
{ title: 'Combinators',
159
+
description: 'Higher-order combinators transform formatters.',
160
+
steps: [
161
+
{ code: 'let pp_len = Fmt.using String.length Fmt.int;;', expect: 'Fmt.t',
162
+
description: 'Fmt.using transforms input before formatting' },
163
+
{ code: 'Fmt.str "%a" pp_len "hello";;', expect: '"5"',
164
+
description: 'pp_len formats the length of a string' },
165
+
{ code: 'Fmt.str "%a" (Fmt.Dump.list Fmt.int) [1; 2; 3];;', expect: '[1; 2; 3]',
166
+
description: 'Fmt.Dump formats with OCaml syntax (brackets)' },
167
+
] },
168
+
],
169
+
};
170
+
}
171
+
172
+
// ── Factory: Uucp (same API across 14–17, different Unicode version) ───
173
+
function uucpTutorial(version, universe, unicodeVer) {
174
+
return {
175
+
name: 'Uucp', version, opam: 'uucp',
176
+
description: `Unicode character properties (Unicode ${unicodeVer})`,
177
+
universe, require: ['uucp'],
178
+
sections: [
179
+
{ title: 'Unicode Version',
180
+
description: 'Each Uucp release tracks a specific Unicode standard version.',
181
+
steps: [
182
+
{ code: 'Uucp.unicode_version;;', expect: `"${unicodeVer}"`,
183
+
description: 'Check which Unicode version this release implements' },
184
+
] },
185
+
{ title: 'General Category',
186
+
description: 'Uucp.Gc.general_category returns the Unicode General Category of a character as a polymorphic variant.',
187
+
steps: [
188
+
{ code: 'Uucp.Gc.general_category (Uchar.of_int 0x0041);;', expect: '`Lu',
189
+
description: "'A' (U+0041) is an uppercase letter (Lu)" },
190
+
{ code: 'Uucp.Gc.general_category (Uchar.of_int 0x0061);;', expect: '`Ll',
191
+
description: "'a' (U+0061) is a lowercase letter (Ll)" },
192
+
{ code: 'Uucp.Gc.general_category (Uchar.of_int 0x0030);;', expect: '`Nd',
193
+
description: "'0' (U+0030) is a decimal digit (Nd)" },
194
+
{ code: 'Uucp.Gc.general_category (Uchar.of_int 0x0020);;', expect: '`Zs',
195
+
description: "Space (U+0020) is a space separator (Zs)" },
196
+
] },
197
+
{ title: 'Script Detection',
198
+
description: 'Uucp.Script.script identifies which writing system a character belongs to.',
199
+
steps: [
200
+
{ code: 'Uucp.Script.script (Uchar.of_int 0x03B1);;', expect: '`Grek',
201
+
description: "Greek alpha (U+03B1) is in the Greek script" },
202
+
{ code: 'Uucp.Script.script (Uchar.of_int 0x4E16);;', expect: '`Hani',
203
+
description: "CJK character (U+4E16) is in the Han script" },
204
+
{ code: 'Uucp.Script.script (Uchar.of_int 0x0041);;', expect: '`Latn',
205
+
description: "'A' is in the Latin script" },
206
+
] },
207
+
{ title: 'Character Properties',
208
+
description: 'Uucp provides boolean property lookups for whitespace, alphabetic characters, and more.',
209
+
steps: [
210
+
{ code: 'Uucp.White.is_white_space (Uchar.of_int 0x0020);;', expect: 'true',
211
+
description: 'Space is whitespace' },
212
+
{ code: 'Uucp.White.is_white_space (Uchar.of_int 0x0041);;', expect: 'false',
213
+
description: "'A' is not whitespace" },
214
+
{ code: 'Uucp.White.is_white_space (Uchar.of_int 0x00A0);;', expect: 'true',
215
+
description: 'Non-breaking space (U+00A0) is whitespace' },
216
+
] },
217
+
],
218
+
};
219
+
}
220
+
221
+
// ── Factory: Uunf (same API, different Unicode version) ────────────────
222
+
function uunfTutorial(version, universe, unicodeVer) {
223
+
return {
224
+
name: 'Uunf', version, opam: 'uunf',
225
+
description: `Unicode text normalization (Unicode ${unicodeVer})`,
226
+
universe, require: ['uunf'],
227
+
sections: [
228
+
{ title: 'Unicode Version',
229
+
description: 'Each Uunf release implements normalization according to a specific Unicode version.',
230
+
steps: [
231
+
{ code: 'Uunf.unicode_version;;', expect: `"${unicodeVer}"`,
232
+
description: 'Check the Unicode version' },
233
+
] },
234
+
{ title: 'Normalization Forms',
235
+
description: 'Unicode defines four normalization forms: NFC, NFD, NFKC, and NFKD. Uunf.create selects which form to use.',
236
+
steps: [
237
+
{ code: 'let nfc = Uunf.create `NFC;;', expect: 'Uunf.t',
238
+
description: 'Create an NFC normalizer' },
239
+
{ code: 'let nfd = Uunf.create `NFD;;', expect: 'Uunf.t',
240
+
description: 'Create an NFD normalizer (canonical decomposition)' },
241
+
{ code: 'let nfkc = Uunf.create `NFKC;;', expect: 'Uunf.t',
242
+
description: 'Create an NFKC normalizer (compatibility composition)' },
243
+
{ code: 'let nfkd = Uunf.create `NFKD;;', expect: 'Uunf.t',
244
+
description: 'Create an NFKD normalizer (compatibility decomposition)' },
245
+
] },
246
+
{ title: 'Adding Characters',
247
+
description: 'Feed characters to the normalizer with Uunf.add. It returns `Uchar for output characters and `Await when ready for more input.',
248
+
steps: [
249
+
{ code: 'let n = Uunf.create `NFC;;', expect: 'Uunf.t',
250
+
description: 'Create a fresh NFC normalizer' },
251
+
{ code: 'Uunf.add n (`Uchar (Uchar.of_int 0x0041));;', expect: '',
252
+
description: "Add 'A' to the normalizer" },
253
+
{ code: 'Uunf.add n `End;;', expect: '',
254
+
description: 'Signal end of input' },
255
+
] },
256
+
],
257
+
};
258
+
}
259
+
260
+
// ── Factory: Mtime 1.x (1.3 and 1.4 share the same API) ───────────────
261
+
function mtime1_3Tutorial(version, universe) {
262
+
// Mtime 1.3.0: no named constants (ns/ms/s), uses float conversion functions
263
+
return {
264
+
name: 'Mtime', version, opam: 'mtime',
265
+
description: 'Monotonic wall-clock time for OCaml',
266
+
universe, require: ['mtime'],
267
+
sections: [
268
+
{ title: 'Time Span Basics',
269
+
description: 'Mtime.Span represents monotonic time durations in nanoseconds.',
270
+
steps: [
271
+
{ code: 'Mtime.Span.zero;;', expect: 'Mtime.span',
272
+
description: 'The zero-length span' },
273
+
{ code: 'Mtime.Span.one;;', expect: 'Mtime.span',
274
+
description: 'One nanosecond' },
275
+
{ code: 'Mtime.Span.max_span;;', expect: 'Mtime.span',
276
+
description: 'The maximum representable span' },
277
+
{ code: 'Mtime.Span.of_uint64_ns 1_000_000_000L;;', expect: 'Mtime.span',
278
+
description: 'Create a 1-second span from nanoseconds' },
279
+
] },
280
+
{ title: 'Span Arithmetic',
281
+
description: 'Spans support addition, comparison, and absolute difference.',
282
+
steps: [
283
+
{ code: 'let one_sec = Mtime.Span.of_uint64_ns 1_000_000_000L;;', expect: 'Mtime.span',
284
+
description: 'One second' },
285
+
{ code: 'let two_sec = Mtime.Span.add one_sec one_sec;;', expect: 'Mtime.span',
286
+
description: 'Add two spans: 1s + 1s = 2s' },
287
+
{ code: 'Mtime.Span.to_uint64_ns two_sec;;', expect: '2000000000L',
288
+
description: '2 seconds in nanoseconds' },
289
+
{ code: 'Mtime.Span.equal Mtime.Span.zero Mtime.Span.zero;;', expect: 'true',
290
+
description: 'Zero equals zero' },
291
+
{ code: 'Mtime.Span.compare one_sec Mtime.Span.zero;;', expect: '1',
292
+
description: '1 second is greater than zero' },
293
+
] },
294
+
{ title: 'Float Conversions',
295
+
description: 'Convert spans to floating-point representations in various units.',
296
+
steps: [
297
+
{ code: 'Mtime.Span.to_ns one_sec;;', expect: '1000000000.',
298
+
description: '1 second = 1e9 nanoseconds' },
299
+
{ code: 'Mtime.Span.to_ms one_sec;;', expect: '1000.',
300
+
description: '1 second = 1000 milliseconds' },
301
+
{ code: 'Mtime.Span.to_s one_sec;;', expect: '1.',
302
+
description: '1 second as a float' },
303
+
{ code: 'Mtime.Span.to_us one_sec;;', expect: '1000000.',
304
+
description: '1 second = 1e6 microseconds' },
305
+
] },
306
+
],
307
+
};
308
+
}
309
+
310
+
function mtime1_4Tutorial(version, universe) {
311
+
// Mtime 1.4.0: has named constants (ns/ms/s) and is_shorter/is_longer
312
+
return {
313
+
name: 'Mtime', version, opam: 'mtime',
314
+
description: 'Monotonic wall-clock time for OCaml',
315
+
universe, require: ['mtime'],
316
+
sections: [
317
+
{ title: 'Time Span Constants',
318
+
description: 'Mtime 1.4 added named constants for common time durations.',
319
+
steps: [
320
+
{ code: 'Mtime.Span.zero;;', expect: 'Mtime.span',
321
+
description: 'The zero-length span' },
322
+
{ code: 'Mtime.Span.ns;;', expect: 'Mtime.span',
323
+
description: '1 nanosecond' },
324
+
{ code: 'Mtime.Span.ms;;', expect: 'Mtime.span',
325
+
description: '1 millisecond' },
326
+
{ code: 'Mtime.Span.s;;', expect: 'Mtime.span',
327
+
description: '1 second' },
328
+
{ code: 'Mtime.Span.min;;', expect: 'Mtime.span',
329
+
description: '1 minute' },
330
+
] },
331
+
{ title: 'Span Arithmetic',
332
+
description: 'Spans support addition, scaling, and comparison.',
333
+
steps: [
334
+
{ code: 'let two_sec = Mtime.Span.add Mtime.Span.s Mtime.Span.s;;', expect: 'Mtime.span',
335
+
description: '1s + 1s = 2s' },
336
+
{ code: 'Mtime.Span.to_uint64_ns two_sec;;', expect: '2000000000L',
337
+
description: '2 seconds in nanoseconds' },
338
+
{ code: 'Mtime.Span.compare Mtime.Span.ms Mtime.Span.s;;', expect: '-1',
339
+
description: '1ms is less than 1s' },
340
+
{ code: 'Mtime.Span.equal Mtime.Span.zero Mtime.Span.zero;;', expect: 'true',
341
+
description: 'Zero equals zero' },
342
+
] },
343
+
{ title: 'Conversions',
344
+
description: 'Convert spans to floating-point representations in various units.',
345
+
steps: [
346
+
{ code: 'Mtime.Span.to_ms Mtime.Span.s;;', expect: '1000.',
347
+
description: '1 second = 1000 milliseconds' },
348
+
{ code: 'Mtime.Span.to_s Mtime.Span.s;;', expect: '1.',
349
+
description: '1 second as a float' },
350
+
{ code: 'Mtime.Span.of_uint64_ns 500_000_000L |> Mtime.Span.to_ms;;', expect: '500.',
351
+
description: '500ms round-trip through nanoseconds' },
352
+
] },
353
+
],
354
+
};
355
+
}
356
+
357
+
export const TUTORIALS = {
358
+
// ═══════════════════════════════════════════════════════════════════════
359
+
// Fmt
360
+
// ═══════════════════════════════════════════════════════════════════════
361
+
'fmt.0.9.0': fmtTutorial('0.9.0', U['fmt.0.9.0']),
362
+
'fmt.0.10.0': fmtTutorial('0.10.0', U['fmt.0.10.0']),
363
+
'fmt.0.11.0': fmtTutorial('0.11.0', U['fmt.0.11.0']),
364
+
365
+
// ═══════════════════════════════════════════════════════════════════════
366
+
// Cmdliner
367
+
// ═══════════════════════════════════════════════════════════════════════
368
+
'cmdliner.1.0.4': {
369
+
name: 'Cmdliner', version: '1.0.4', opam: 'cmdliner',
370
+
description: 'Declarative definition of command line interfaces (v1 API)',
371
+
universe: U['cmdliner.1.0.4'], require: ['cmdliner'],
372
+
sections: [
373
+
{ title: 'Argument Info',
374
+
description: 'Cmdliner.Arg.info describes command-line arguments with names, docs, and metadata.',
375
+
steps: [
376
+
{ code: 'let verbose_info = Cmdliner.Arg.info ["v"; "verbose"] ~doc:"Be verbose";;',
377
+
expect: 'Cmdliner.Arg.info', description: 'Create info for a --verbose/-v flag' },
378
+
{ code: 'let name_info = Cmdliner.Arg.info [] ~docv:"NAME" ~doc:"The name";;',
379
+
expect: 'Cmdliner.Arg.info', description: 'Create info for a positional argument' },
380
+
] },
381
+
{ title: 'Argument Definitions',
382
+
description: 'Arguments are built from converters + info, then lifted into terms with Arg.value.',
383
+
steps: [
384
+
{ code: 'Cmdliner.Arg.string;;', expect: 'string Cmdliner.Arg.conv',
385
+
description: 'Built-in string converter' },
386
+
{ code: 'Cmdliner.Arg.int;;', expect: 'int Cmdliner.Arg.conv',
387
+
description: 'Built-in int converter' },
388
+
{ code: 'let verbose = Cmdliner.Arg.(value (flag (info ["v";"verbose"])));;',
389
+
expect: 'bool Cmdliner.Term.t', description: 'Define a boolean flag term' },
390
+
{ code: 'let count = Cmdliner.Arg.(value (opt int 0 (info ["c";"count"])));;',
391
+
expect: 'int Cmdliner.Term.t', description: 'Define an optional int argument with default 0' },
392
+
] },
393
+
{ title: 'Terms (v1 API)',
394
+
description: 'In Cmdliner 1.0.x, Term.const and Term.($) combine argument terms into a program term.',
395
+
steps: [
396
+
{ code: 'let greet = Cmdliner.Term.const (fun v n -> Printf.sprintf "%s%s" (if v then "HI " else "hi ") n);;',
397
+
expect: 'Cmdliner.Term.t', description: 'A constant function lifted into a term' },
398
+
{ code: 'Cmdliner.Term.info "greet" ~doc:"A greeting program";;',
399
+
expect: 'Cmdliner.Term.info', description: 'Term.info describes the command (v1 API)' },
400
+
{ code: 'Cmdliner.Term.eval;;', expect: 'Term.result',
401
+
description: 'Term.eval runs a term — available in 1.0.x' },
402
+
] },
403
+
],
404
+
},
405
+
406
+
'cmdliner.1.3.0': {
407
+
name: 'Cmdliner', version: '1.3.0', opam: 'cmdliner',
408
+
description: 'Declarative definition of command line interfaces (transitional)',
409
+
universe: U['cmdliner.1.3.0'], require: ['cmdliner'],
410
+
sections: [
411
+
{ title: 'Argument Building',
412
+
description: 'Cmdliner 1.3 is a transitional release supporting both the old Term API and the new Cmd API.',
413
+
steps: [
414
+
{ code: 'let verbose = Cmdliner.Arg.(value (flag (info ["v";"verbose"] ~doc:"Be verbose")));;',
415
+
expect: 'bool Cmdliner.Term.t', description: 'Define a verbose flag' },
416
+
{ code: 'let greeting = Cmdliner.Arg.(value (pos 0 string "world" (info [] ~docv:"NAME")));;',
417
+
expect: 'string Cmdliner.Term.t', description: 'Define a positional name argument' },
418
+
] },
419
+
{ title: 'New Cmd API (introduced in 1.1+)',
420
+
description: 'The Cmd module provides a structured way to define commands, replacing Term.info + Term.eval.',
421
+
steps: [
422
+
{ code: 'Cmdliner.Cmd.info "hello" ~doc:"Say hello";;',
423
+
expect: 'Cmdliner.Cmd.info', description: 'Cmd.info creates command metadata' },
424
+
{ code: 'let hello_t = Cmdliner.Term.(const (fun v n -> ()) $ verbose $ greeting);;',
425
+
expect: 'Cmdliner.Term.t', description: 'Combine arguments with Term.const and ($)' },
426
+
{ code: 'Cmdliner.Cmd.v (Cmdliner.Cmd.info "hello") hello_t;;',
427
+
expect: 'Cmdliner.Cmd.t', description: 'Create a command from info + term' },
428
+
] },
429
+
{ title: 'Backward Compatibility',
430
+
description: 'The old Term.eval API still works in 1.3 for migration.',
431
+
steps: [
432
+
{ code: 'Cmdliner.Term.eval;;', expect: 'Term.result',
433
+
description: 'Term.eval is still available (deprecated but functional)' },
434
+
{ code: 'Cmdliner.Term.info "test";;', expect: 'Cmdliner.Term.info',
435
+
description: 'Term.info still works for backward compat' },
436
+
] },
437
+
],
438
+
},
439
+
440
+
'cmdliner.2.0.0': {
441
+
name: 'Cmdliner', version: '2.0.0', opam: 'cmdliner',
442
+
description: 'Declarative definition of command line interfaces (v2 API)',
443
+
universe: U['cmdliner.2.0.0'], require: ['cmdliner'],
444
+
sections: [
445
+
{ title: 'Arguments',
446
+
description: 'Arguments are defined the same way as in earlier versions.',
447
+
steps: [
448
+
{ code: 'let verbose = Cmdliner.Arg.(value (flag (info ["v";"verbose"])));;',
449
+
expect: 'bool Cmdliner.Term.t', description: 'A boolean flag term' },
450
+
{ code: 'let name = Cmdliner.Arg.(value (pos 0 string "world" (info [])));;',
451
+
expect: 'string Cmdliner.Term.t', description: 'A positional string argument' },
452
+
] },
453
+
{ title: 'Cmd Module (v2 API)',
454
+
description: 'In Cmdliner 2.x, Cmd replaces Term.info/Term.eval entirely.',
455
+
steps: [
456
+
{ code: 'Cmdliner.Cmd.info "greet" ~doc:"Greet someone";;',
457
+
expect: 'Cmdliner.Cmd.info', description: 'Create command info' },
458
+
{ code: 'let t = Cmdliner.Term.(const (fun _ _ -> ()) $ verbose $ name);;',
459
+
expect: 'Cmdliner.Term.t', description: 'Build the term' },
460
+
{ code: 'let cmd = Cmdliner.Cmd.v (Cmdliner.Cmd.info "greet") t;;',
461
+
expect: 'Cmdliner.Cmd.t', description: 'Package into a command' },
462
+
{ code: 'Cmdliner.Cmd.name cmd;;', expect: '"greet"',
463
+
description: 'Extract the command name' },
464
+
] },
465
+
{ title: 'Removed APIs',
466
+
description: 'Term.eval was removed in 2.0. Use Cmd.eval_value instead.',
467
+
steps: [
468
+
{ code: 'Cmdliner.Cmd.eval_value;;', expect: 'eval_ok',
469
+
description: 'Cmd.eval_value is the new entry point' },
470
+
] },
471
+
],
472
+
},
473
+
474
+
'cmdliner.2.1.0': {
475
+
name: 'Cmdliner', version: '2.1.0', opam: 'cmdliner',
476
+
description: 'Declarative definition of command line interfaces (v2 API)',
477
+
universe: U['cmdliner.2.1.0'], require: ['cmdliner'],
478
+
sections: [
479
+
{ title: 'Arguments',
480
+
description: 'Define typed command-line arguments with converters and info.',
481
+
steps: [
482
+
{ code: 'let verbose = Cmdliner.Arg.(value (flag (info ["v";"verbose"] ~doc:"Increase verbosity")));;',
483
+
expect: 'bool Cmdliner.Term.t', description: 'A verbose flag' },
484
+
{ code: 'let file = Cmdliner.Arg.(required (pos 0 (some string) None (info [] ~docv:"FILE")));;',
485
+
expect: 'string Cmdliner.Term.t', description: 'A required positional file argument' },
486
+
{ code: 'let count = Cmdliner.Arg.(value (opt int 1 (info ["n";"count"] ~doc:"Repeat count")));;',
487
+
expect: 'int Cmdliner.Term.t', description: 'An optional integer with default' },
488
+
] },
489
+
{ title: 'Commands',
490
+
description: 'Commands combine a term with metadata. Groups can nest subcommands.',
491
+
steps: [
492
+
{ code: 'let info = Cmdliner.Cmd.info "process" ~version:"1.0" ~doc:"Process files";;',
493
+
expect: 'Cmdliner.Cmd.info', description: 'Command info with version' },
494
+
{ code: 'let t = Cmdliner.Term.(const (fun _ _ _ -> ()) $ verbose $ file $ count);;',
495
+
expect: 'Cmdliner.Term.t', description: 'Combine all arguments' },
496
+
{ code: 'let cmd = Cmdliner.Cmd.v info t;;',
497
+
expect: 'Cmdliner.Cmd.t', description: 'Create the command' },
498
+
{ code: 'Cmdliner.Cmd.name cmd;;', expect: '"process"',
499
+
description: 'Retrieve the command name' },
500
+
] },
501
+
{ title: 'Custom Converters',
502
+
description: 'Arg.conv creates custom argument converters from a parser/printer pair.',
503
+
steps: [
504
+
{ code: 'let color_parser s = match s with "red" -> Ok `Red | "blue" -> Ok `Blue | _ -> Error (`Msg "unknown color");;',
505
+
expect: 'val color_parser', description: 'Define a parser function' },
506
+
{ code: 'let color_pp ppf c = Format.pp_print_string ppf (match c with `Red -> "red" | `Blue -> "blue");;',
507
+
expect: 'val color_pp', description: 'Define a printer' },
508
+
{ code: 'let color_conv = Cmdliner.Arg.conv (color_parser, color_pp);;',
509
+
expect: 'Cmdliner.Arg.conv', description: 'Build a custom converter' },
510
+
] },
511
+
],
512
+
},
513
+
514
+
// ═══════════════════════════════════════════════════════════════════════
515
+
// Mtime
516
+
// ═══════════════════════════════════════════════════════════════════════
517
+
'mtime.1.3.0': mtime1_3Tutorial('1.3.0', U['mtime.1.3.0']),
518
+
'mtime.1.4.0': mtime1_4Tutorial('1.4.0', U['mtime.1.4.0']),
519
+
520
+
'mtime.2.1.0': {
521
+
name: 'Mtime', version: '2.1.0', opam: 'mtime',
522
+
description: 'Monotonic wall-clock time for OCaml',
523
+
universe: U['mtime.2.1.0'], require: ['mtime'],
524
+
sections: [
525
+
{ title: 'Time Span Constants',
526
+
description: 'Mtime.Span provides named constants for common durations.',
527
+
steps: [
528
+
{ code: 'Mtime.Span.zero;;', expect: 'Mtime.span',
529
+
description: 'Zero-length span' },
530
+
{ code: 'Mtime.Span.s;;', expect: 'Mtime.span',
531
+
description: '1 second' },
532
+
{ code: 'Mtime.Span.min;;', expect: 'Mtime.span',
533
+
description: '1 minute' },
534
+
{ code: 'Mtime.Span.hour;;', expect: 'Mtime.span',
535
+
description: '1 hour' },
536
+
] },
537
+
{ title: 'Span Arithmetic',
538
+
description: 'Spans support addition, comparison, and predicate-based comparisons (new in 2.x).',
539
+
steps: [
540
+
{ code: 'let two_sec = Mtime.Span.add Mtime.Span.s Mtime.Span.s;;', expect: 'Mtime.span',
541
+
description: '1s + 1s' },
542
+
{ code: 'Mtime.Span.to_uint64_ns two_sec;;', expect: '2000000000L',
543
+
description: '2 seconds in nanoseconds' },
544
+
{ code: 'Mtime.Span.is_shorter Mtime.Span.ms ~than:Mtime.Span.s;;', expect: 'true',
545
+
description: '1ms is shorter than 1s (new in 2.x)' },
546
+
{ code: 'Mtime.Span.is_longer Mtime.Span.hour ~than:Mtime.Span.min;;', expect: 'true',
547
+
description: '1 hour is longer than 1 minute (new in 2.x)' },
548
+
] },
549
+
{ title: 'New in 2.x: Float Conversions',
550
+
description: 'Mtime 2.x adds Span.of_float_ns for creating spans from floating-point nanoseconds.',
551
+
steps: [
552
+
{ code: 'Mtime.Span.of_float_ns 1e9;;', expect: 'Some',
553
+
description: '1e9 ns = 1 second' },
554
+
{ code: 'Mtime.Span.of_float_ns (-1.);;', expect: 'None',
555
+
description: 'Negative values return None' },
556
+
{ code: 'Mtime.Span.of_float_ns infinity;;', expect: 'None',
557
+
description: 'Non-finite values return None' },
558
+
{ code: 'Mtime.Span.to_float_ns Mtime.Span.s;;', expect: '1000000000.',
559
+
description: 'Convert 1 second to float nanoseconds' },
560
+
] },
561
+
],
562
+
},
563
+
564
+
// ═══════════════════════════════════════════════════════════════════════
565
+
// Logs
566
+
// ═══════════════════════════════════════════════════════════════════════
567
+
'logs.0.7.0': {
568
+
name: 'Logs', version: '0.7.0', opam: 'logs',
569
+
description: 'Logging infrastructure for OCaml',
570
+
universe: U['logs.0.7.0'], require: ['logs'],
571
+
sections: [
572
+
{ title: 'Log Sources',
573
+
description: 'A Logs.Src.t identifies a log source with a name and optional documentation.',
574
+
steps: [
575
+
{ code: 'let src = Logs.Src.create "myapp" ~doc:"My application";;', expect: 'Logs.src',
576
+
description: 'Create a named log source' },
577
+
{ code: 'Logs.Src.name src;;', expect: '"myapp"',
578
+
description: 'Retrieve the source name' },
579
+
{ code: 'Logs.Src.doc src;;', expect: '"My application"',
580
+
description: 'Retrieve the source documentation' },
581
+
] },
582
+
{ title: 'Log Levels',
583
+
description: 'Logs has five levels: App, Error, Warning, Info, Debug. The global level controls what gets logged.',
584
+
steps: [
585
+
{ code: 'Logs.level ();;', expect: 'option',
586
+
description: 'Get the current global log level' },
587
+
{ code: 'Logs.set_level (Some Logs.Debug);;', expect: 'unit',
588
+
description: 'Set the global level to Debug (most verbose)' },
589
+
{ code: 'Logs.level ();;', expect: 'Some',
590
+
description: 'Verify the level was set' },
591
+
] },
592
+
{ title: 'Error Counting',
593
+
description: 'Logs tracks error and warning counts globally.',
594
+
steps: [
595
+
{ code: 'Logs.err_count ();;', expect: 'int',
596
+
description: 'Count of errors logged so far' },
597
+
{ code: 'Logs.warn_count ();;', expect: 'int',
598
+
description: 'Count of warnings logged so far' },
599
+
] },
600
+
],
601
+
},
602
+
603
+
'logs.0.10.0': {
604
+
name: 'Logs', version: '0.10.0', opam: 'logs',
605
+
description: 'Logging infrastructure for OCaml',
606
+
universe: U['logs.0.10.0'], require: ['logs'],
607
+
sections: [
608
+
{ title: 'Log Sources',
609
+
description: 'Create and inspect named log sources.',
610
+
steps: [
611
+
{ code: 'let src = Logs.Src.create "test" ~doc:"A test source";;', expect: 'Logs.src',
612
+
description: 'Create a log source' },
613
+
{ code: 'Logs.Src.name src;;', expect: '"test"',
614
+
description: 'Get the source name' },
615
+
{ code: 'Logs.Src.doc src;;', expect: '"A test source"',
616
+
description: 'Get the documentation string' },
617
+
{ code: 'Logs.Src.list ();;', expect: 'Logs.src list',
618
+
description: 'List all registered sources' },
619
+
] },
620
+
{ title: 'Level Management',
621
+
description: 'Control log verbosity at the global and per-source levels.',
622
+
steps: [
623
+
{ code: 'Logs.set_level (Some Logs.Info);;', expect: 'unit',
624
+
description: 'Set global level to Info' },
625
+
{ code: 'Logs.level ();;', expect: 'Some',
626
+
description: 'Check the global level' },
627
+
{ code: 'Logs.Src.set_level src (Some Logs.Debug);;', expect: 'unit',
628
+
description: 'Override the level for a specific source' },
629
+
{ code: 'Logs.Src.level src;;', expect: 'Some',
630
+
description: 'Check the per-source level' },
631
+
] },
632
+
{ title: 'Error Tracking',
633
+
description: 'Logs maintains error and warning counters.',
634
+
steps: [
635
+
{ code: 'Logs.err_count ();;', expect: 'int',
636
+
description: 'Number of errors logged' },
637
+
{ code: 'Logs.warn_count ();;', expect: 'int',
638
+
description: 'Number of warnings logged' },
639
+
] },
640
+
],
641
+
},
642
+
643
+
// ═══════════════════════════════════════════════════════════════════════
644
+
// Uucp
645
+
// ═══════════════════════════════════════════════════════════════════════
646
+
'uucp.14.0.0': uucpTutorial('14.0.0', U['uucp.14.0.0'], '14.0.0'),
647
+
'uucp.15.0.0': uucpTutorial('15.0.0', U['uucp.15.0.0'], '15.0.0'),
648
+
'uucp.16.0.0': uucpTutorial('16.0.0', U['uucp.16.0.0'], '16.0.0'),
649
+
'uucp.17.0.0': uucpTutorial('17.0.0', U['uucp.17.0.0'], '17.0.0'),
650
+
651
+
// ═══════════════════════════════════════════════════════════════════════
652
+
// Uunf
653
+
// ═══════════════════════════════════════════════════════════════════════
654
+
'uunf.14.0.0': uunfTutorial('14.0.0', U['uunf.14.0.0'], '14.0.0'),
655
+
'uunf.17.0.0': uunfTutorial('17.0.0', U['uunf.17.0.0'], '17.0.0'),
656
+
657
+
// ═══════════════════════════════════════════════════════════════════════
658
+
// Astring
659
+
// ═══════════════════════════════════════════════════════════════════════
660
+
'astring.0.8.5': {
661
+
name: 'Astring', version: '0.8.5', opam: 'astring',
662
+
description: 'Alternative String module for OCaml',
663
+
universe: U['astring.0.8.5'], require: ['astring'],
664
+
sections: [
665
+
{ title: 'String Splitting',
666
+
description: 'Astring.String provides powerful splitting functions that work with string separators.',
667
+
steps: [
668
+
{ code: 'Astring.String.cuts ~sep:"," "a,b,c";;', expect: '["a"; "b"; "c"]',
669
+
description: 'Split on comma' },
670
+
{ code: 'Astring.String.cuts ~sep:"::" "a::b::c";;', expect: '["a"; "b"; "c"]',
671
+
description: 'Split on multi-char separator' },
672
+
{ code: 'Astring.String.cut ~sep:"=" "key=value";;', expect: 'Some ("key", "value")',
673
+
description: 'Cut at first separator occurrence' },
674
+
{ code: 'Astring.String.cut ~rev:true ~sep:"." "a.b.c";;', expect: 'Some ("a.b", "c")',
675
+
description: 'Cut at last separator with ~rev:true' },
676
+
] },
677
+
{ title: 'String Building',
678
+
description: 'Concatenation and transformation functions.',
679
+
steps: [
680
+
{ code: 'Astring.String.concat ~sep:"-" ["x"; "y"; "z"];;', expect: '"x-y-z"',
681
+
description: 'Join strings with separator' },
682
+
{ code: 'Astring.String.concat ~sep:", " ["hello"; "world"];;', expect: '"hello, world"',
683
+
description: 'Join with comma-space' },
684
+
] },
685
+
{ title: 'String Testing',
686
+
description: 'Predicate functions for string content.',
687
+
steps: [
688
+
{ code: 'Astring.String.is_prefix ~affix:"http" "http://example.com";;', expect: 'true',
689
+
description: 'Check for a prefix' },
690
+
{ code: 'Astring.String.is_suffix ~affix:".ml" "main.ml";;', expect: 'true',
691
+
description: 'Check for a suffix' },
692
+
{ code: 'Astring.String.is_prefix ~affix:"ftp" "http://example.com";;', expect: 'false',
693
+
description: 'Prefix not found' },
694
+
{ code: 'Astring.String.find_sub ~sub:"world" "hello world";;', expect: 'Some 6',
695
+
description: 'Find substring position' },
696
+
] },
697
+
{ title: 'String Trimming',
698
+
description: 'Remove whitespace or specific characters from strings.',
699
+
steps: [
700
+
{ code: 'Astring.String.trim " hello ";;', expect: '"hello"',
701
+
description: 'Trim whitespace from both ends' },
702
+
{ code: 'Astring.String.trim ~drop:(fun c -> c = \'/\') "/path/to/";;', expect: '"path/to"',
703
+
description: 'Trim custom characters' },
704
+
] },
705
+
{ title: 'Substrings',
706
+
description: 'Astring.String.Sub provides zero-copy substring operations.',
707
+
steps: [
708
+
{ code: 'Astring.String.Sub.(to_string (v "hello world" ~start:6));;', expect: '"world"',
709
+
description: 'Extract a substring from position 6' },
710
+
{ code: 'Astring.String.Sub.(to_string (v "hello world" ~stop:5));;', expect: '"hello"',
711
+
description: 'Extract first 5 characters' },
712
+
] },
713
+
],
714
+
},
715
+
716
+
// ═══════════════════════════════════════════════════════════════════════
717
+
// Jsonm
718
+
// ═══════════════════════════════════════════════════════════════════════
719
+
'jsonm.1.0.2': {
720
+
name: 'Jsonm', version: '1.0.2', opam: 'jsonm',
721
+
description: 'Non-blocking streaming JSON codec for OCaml',
722
+
universe: U['jsonm.1.0.2'], require: ['jsonm'],
723
+
sections: [
724
+
{ title: 'Decoding JSON Values',
725
+
description: 'Jsonm.decoder creates a streaming decoder. Each Jsonm.decode call returns one lexeme.',
726
+
steps: [
727
+
{ code: 'let d = Jsonm.decoder (`String "42");;', expect: 'Jsonm.decoder',
728
+
description: 'Create a decoder from a JSON string' },
729
+
{ code: 'Jsonm.decode d;;', expect: '`Lexeme (`Float 42.)',
730
+
description: 'Decode the number 42 (JSON numbers are floats)' },
731
+
{ code: 'Jsonm.decode d;;', expect: '`End',
732
+
description: 'End of input' },
733
+
] },
734
+
{ title: 'Decoding Strings and Booleans',
735
+
description: 'JSON strings, booleans, and null each produce a single lexeme.',
736
+
steps: [
737
+
{ code: 'let d2 = Jsonm.decoder (`String {|"hello"|});;', expect: 'Jsonm.decoder',
738
+
description: 'Decode a JSON string' },
739
+
{ code: 'Jsonm.decode d2;;', expect: '`Lexeme (`String "hello")',
740
+
description: 'String lexeme' },
741
+
{ code: 'let d3 = Jsonm.decoder (`String "true");;', expect: 'Jsonm.decoder',
742
+
description: 'Decode a JSON boolean' },
743
+
{ code: 'Jsonm.decode d3;;', expect: '`Lexeme (`Bool true)',
744
+
description: 'Boolean lexeme' },
745
+
{ code: 'let dn = Jsonm.decoder (`String "null");;', expect: 'Jsonm.decoder',
746
+
description: 'Decode null' },
747
+
{ code: 'Jsonm.decode dn;;', expect: '`Lexeme `Null',
748
+
description: 'Null lexeme' },
749
+
] },
750
+
{ title: 'Decoding Arrays',
751
+
description: 'Arrays produce `As (array start) and `Ae (array end) lexemes around their elements.',
752
+
steps: [
753
+
{ code: 'let da = Jsonm.decoder (`String "[1, 2, 3]");;', expect: 'Jsonm.decoder',
754
+
description: 'Create decoder for a JSON array' },
755
+
{ code: 'Jsonm.decode da;;', expect: '`Lexeme `As',
756
+
description: 'Array start' },
757
+
{ code: 'Jsonm.decode da;;', expect: '`Lexeme (`Float 1.)',
758
+
description: 'First element' },
759
+
{ code: 'Jsonm.decode da;;', expect: '`Lexeme (`Float 2.)',
760
+
description: 'Second element' },
761
+
] },
762
+
{ title: 'Encoding JSON',
763
+
description: 'Jsonm.encoder creates an encoder that writes lexemes to a buffer.',
764
+
steps: [
765
+
{ code: 'let buf = Buffer.create 64;;', expect: 'Buffer.t',
766
+
description: 'Create an output buffer' },
767
+
{ code: 'let e = Jsonm.encoder (`Buffer buf);;', expect: 'Jsonm.encoder',
768
+
description: 'Create an encoder' },
769
+
{ code: 'Jsonm.encode e (`Lexeme (`Float 42.));;', expect: '`Ok',
770
+
description: 'Encode a number' },
771
+
{ code: 'Jsonm.encode e `End;;', expect: '`Ok',
772
+
description: 'End encoding' },
773
+
{ code: 'Buffer.contents buf;;', expect: '42',
774
+
description: 'The buffer contains the JSON output' },
775
+
] },
776
+
],
777
+
},
778
+
779
+
// ═══════════════════════════════════════════════════════════════════════
780
+
// Xmlm
781
+
// ═══════════════════════════════════════════════════════════════════════
782
+
'xmlm.1.4.0': {
783
+
name: 'Xmlm', version: '1.4.0', opam: 'xmlm',
784
+
description: 'Streaming XML codec for OCaml',
785
+
universe: U['xmlm.1.4.0'], require: ['xmlm'],
786
+
sections: [
787
+
{ title: 'Parsing XML Input',
788
+
description: 'Xmlm.make_input creates a streaming parser. Each Xmlm.input call returns one signal.',
789
+
steps: [
790
+
{ code: 'let i = Xmlm.make_input (`String (0, "<root/>"));;', expect: 'Xmlm.input',
791
+
description: 'Create an input from a string' },
792
+
{ code: 'Xmlm.input i;;', expect: '`Dtd',
793
+
description: 'First signal is the DTD (None for no doctype)' },
794
+
{ code: 'Xmlm.input i;;', expect: '`El_start',
795
+
description: 'Element start: <root>' },
796
+
{ code: 'Xmlm.input i;;', expect: '`El_end',
797
+
description: 'Element end: </root> (self-closing)' },
798
+
] },
799
+
{ title: 'Parsing with Attributes',
800
+
description: 'Element start signals include the tag name and attributes.',
801
+
steps: [
802
+
{ code: 'let i2 = Xmlm.make_input (`String (0, {|<div class="main">text</div>|}));;',
803
+
expect: 'Xmlm.input', description: 'Parse XML with attributes' },
804
+
{ code: 'Xmlm.input i2;;', expect: '`Dtd',
805
+
description: 'DTD signal' },
806
+
{ code: 'Xmlm.input i2;;', expect: '`El_start',
807
+
description: 'Element start with attributes' },
808
+
{ code: 'Xmlm.input i2;;', expect: '`Data "text"',
809
+
description: 'Text content' },
810
+
{ code: 'Xmlm.input i2;;', expect: '`El_end',
811
+
description: 'Element end' },
812
+
] },
813
+
{ title: 'XML Output',
814
+
description: 'Xmlm can also write XML to a buffer.',
815
+
steps: [
816
+
{ code: 'let buf = Buffer.create 64;;', expect: 'Buffer.t',
817
+
description: 'Create output buffer' },
818
+
{ code: 'let o = Xmlm.make_output (`Buffer buf);;', expect: 'Xmlm.output',
819
+
description: 'Create an XML output' },
820
+
{ code: 'Xmlm.output o (`Dtd None);;', expect: 'unit',
821
+
description: 'Write empty DTD' },
822
+
{ code: 'Xmlm.output o (`El_start (("", "item"), []));;', expect: 'unit',
823
+
description: 'Start <item> element' },
824
+
{ code: 'Xmlm.output o (`Data "hello");;', expect: 'unit',
825
+
description: 'Write text content' },
826
+
{ code: 'Xmlm.output o `El_end;;', expect: 'unit',
827
+
description: 'Close the element' },
828
+
{ code: 'Buffer.contents buf;;', expect: '<item>hello</item>',
829
+
description: 'The output XML' },
830
+
] },
831
+
],
832
+
},
833
+
834
+
// ═══════════════════════════════════════════════════════════════════════
835
+
// Ptime
836
+
// ═══════════════════════════════════════════════════════════════════════
837
+
'ptime.1.2.0': {
838
+
name: 'Ptime', version: '1.2.0', opam: 'ptime',
839
+
description: 'POSIX time for OCaml',
840
+
universe: U['ptime.1.2.0'], require: ['ptime'],
841
+
sections: [
842
+
{ title: 'The Epoch',
843
+
description: 'Ptime.epoch represents 1970-01-01 00:00:00 UTC, the Unix epoch.',
844
+
steps: [
845
+
{ code: 'Ptime.epoch;;', expect: 'Ptime.t',
846
+
description: 'The epoch timestamp' },
847
+
{ code: 'Ptime.to_float_s Ptime.epoch;;', expect: '0.',
848
+
description: 'Epoch as float seconds = 0' },
849
+
] },
850
+
{ title: 'Creating Timestamps',
851
+
description: 'Ptime.of_date_time creates a timestamp from a date-time tuple.',
852
+
steps: [
853
+
{ code: 'let t = Ptime.of_date_time ((2024, 1, 1), ((12, 0, 0), 0));;', expect: 'Some',
854
+
description: 'January 1, 2024, noon UTC' },
855
+
{ code: 'let t = match t with Some t -> t | None -> assert false;;', expect: 'Ptime.t',
856
+
description: 'Unwrap the option' },
857
+
{ code: 'Ptime.to_date_time t;;', expect: '(2024, 1, 1)',
858
+
description: 'Convert back to date-time tuple' },
859
+
{ code: 'Ptime.to_rfc3339 t;;', expect: '2024-01-01',
860
+
description: 'Format as RFC 3339 string' },
861
+
] },
862
+
{ title: 'Time Arithmetic',
863
+
description: 'Add and subtract time spans from timestamps.',
864
+
steps: [
865
+
{ code: 'let one_day = Ptime.Span.of_int_s (24 * 3600);;', expect: 'Ptime.span',
866
+
description: 'A span of one day (86400 seconds)' },
867
+
{ code: 'let tomorrow = Ptime.add_span t one_day;;', expect: 'Some',
868
+
description: 'Add one day to our timestamp' },
869
+
{ code: 'Ptime.to_rfc3339 (Option.get tomorrow);;', expect: '2024-01-02',
870
+
description: 'January 2nd' },
871
+
{ code: 'Ptime.Span.to_int_s (Ptime.diff (Option.get tomorrow) t);;', expect: 'Some 86400',
872
+
description: 'Difference is exactly 86400 seconds' },
873
+
] },
874
+
{ title: 'Time Spans',
875
+
description: 'Ptime.Span represents durations in days and picoseconds.',
876
+
steps: [
877
+
{ code: 'Ptime.Span.zero;;', expect: 'Ptime.span',
878
+
description: 'Zero duration' },
879
+
{ code: 'Ptime.Span.of_int_s 3600;;', expect: 'Ptime.span',
880
+
description: 'One hour in seconds' },
881
+
{ code: 'Ptime.Span.to_int_s (Ptime.Span.of_int_s 3600);;', expect: 'Some 3600',
882
+
description: 'Round-trip: int -> span -> int' },
883
+
{ code: 'Ptime.Span.to_float_s (Ptime.Span.of_int_s 90);;', expect: '90.',
884
+
description: '90 seconds as a float' },
885
+
] },
886
+
],
887
+
},
888
+
889
+
// ═══════════════════════════════════════════════════════════════════════
890
+
// React
891
+
// ═══════════════════════════════════════════════════════════════════════
892
+
'react.1.2.2': {
893
+
name: 'React', version: '1.2.2', opam: 'react',
894
+
description: 'Declarative events and signals for OCaml (FRP)',
895
+
universe: U['react.1.2.2'], require: ['react'],
896
+
sections: [
897
+
{ title: 'Creating Signals',
898
+
description: 'React.S.create returns a signal and a setter function. Signals always have a current value.',
899
+
steps: [
900
+
{ code: 'let counter, set_counter = React.S.create 0;;', expect: 'React.signal',
901
+
description: 'Create a signal with initial value 0' },
902
+
{ code: 'React.S.value counter;;', expect: '0',
903
+
description: 'Read the current value' },
904
+
{ code: 'set_counter 42;;', expect: 'unit',
905
+
description: 'Update the signal value' },
906
+
{ code: 'React.S.value counter;;', expect: '42',
907
+
description: 'The value has changed' },
908
+
] },
909
+
{ title: 'Derived Signals',
910
+
description: 'React.S.map creates a signal that automatically updates when its source changes.',
911
+
steps: [
912
+
{ code: 'let doubled = React.S.map (fun x -> x * 2) counter;;', expect: 'React.signal',
913
+
description: 'A signal that is always 2x the counter' },
914
+
{ code: 'React.S.value doubled;;', expect: '84',
915
+
description: '42 * 2 = 84' },
916
+
{ code: 'set_counter 10;;', expect: 'unit',
917
+
description: 'Update the counter' },
918
+
{ code: 'React.S.value doubled;;', expect: '20',
919
+
description: 'Doubled automatically updates: 10 * 2 = 20' },
920
+
] },
921
+
{ title: 'Combining Signals',
922
+
description: 'React.S.l2 combines two signals with a function. React.S.pair creates a signal of pairs.',
923
+
steps: [
924
+
{ code: 'let name, set_name = React.S.create "world";;', expect: 'React.signal',
925
+
description: 'A name signal' },
926
+
{ code: 'let greeting = React.S.l2 (fun n c -> Printf.sprintf "Hello %s (count=%d)" n c) name counter;;',
927
+
expect: 'React.signal', description: 'Combine name and counter' },
928
+
{ code: 'React.S.value greeting;;', expect: '"Hello world (count=10)"',
929
+
description: 'The combined value' },
930
+
{ code: 'set_name "OCaml";;', expect: 'unit',
931
+
description: 'Update the name' },
932
+
{ code: 'React.S.value greeting;;', expect: '"Hello OCaml (count=10)"',
933
+
description: 'Greeting updates automatically' },
934
+
] },
935
+
{ title: 'Events',
936
+
description: 'React.E.create returns an event and a trigger. Unlike signals, events are discrete occurrences.',
937
+
steps: [
938
+
{ code: 'let clicks, send_click = React.E.create ();;', expect: 'React.event',
939
+
description: 'Create a click event' },
940
+
{ code: 'let click_count = React.S.hold 0 (React.E.map (fun _ -> React.S.value counter) clicks);;',
941
+
expect: 'React.signal', description: 'Hold the counter value at each click' },
942
+
] },
943
+
],
944
+
},
945
+
946
+
// ═══════════════════════════════════════════════════════════════════════
947
+
// Hmap
948
+
// ═══════════════════════════════════════════════════════════════════════
949
+
'hmap.0.8.1': {
950
+
name: 'Hmap', version: '0.8.1', opam: 'hmap',
951
+
description: 'Heterogeneous value maps for OCaml',
952
+
universe: U['hmap.0.8.1'], require: ['hmap'],
953
+
sections: [
954
+
{ title: 'Creating Keys',
955
+
description: 'Hmap keys are created with Key.create. Each key carries a type witness, allowing the map to hold values of different types.',
956
+
steps: [
957
+
{ code: 'let k_int : int Hmap.key = Hmap.Key.create ();;', expect: 'Hmap.key',
958
+
description: 'A key for int values' },
959
+
{ code: 'let k_str : string Hmap.key = Hmap.Key.create ();;', expect: 'Hmap.key',
960
+
description: 'A key for string values' },
961
+
{ code: 'let k_list : int list Hmap.key = Hmap.Key.create ();;', expect: 'Hmap.key',
962
+
description: 'A key for int list values' },
963
+
] },
964
+
{ title: 'Building Maps',
965
+
description: 'Start from Hmap.empty and add values with Hmap.add. Each key-value pair is type-safe.',
966
+
steps: [
967
+
{ code: 'let m = Hmap.empty;;', expect: 'Hmap.t',
968
+
description: 'An empty heterogeneous map' },
969
+
{ code: 'Hmap.is_empty m;;', expect: 'true',
970
+
description: 'Verify it is empty' },
971
+
{ code: 'let m = m |> Hmap.add k_int 42 |> Hmap.add k_str "hello" |> Hmap.add k_list [1;2;3];;',
972
+
expect: 'Hmap.t', description: 'Add values of different types' },
973
+
{ code: 'Hmap.cardinal m;;', expect: '3',
974
+
description: 'Three bindings in the map' },
975
+
] },
976
+
{ title: 'Querying Maps',
977
+
description: 'Hmap.find returns an option. The return type matches the key\'s type parameter.',
978
+
steps: [
979
+
{ code: 'Hmap.find k_int m;;', expect: 'Some 42',
980
+
description: 'Find the int value — type-safe!' },
981
+
{ code: 'Hmap.find k_str m;;', expect: 'Some "hello"',
982
+
description: 'Find the string value' },
983
+
{ code: 'Hmap.find k_list m;;', expect: 'Some [1; 2; 3]',
984
+
description: 'Find the int list value' },
985
+
{ code: 'Hmap.mem k_int m;;', expect: 'true',
986
+
description: 'Check membership' },
987
+
{ code: 'let m2 = Hmap.rem k_int m;;', expect: 'Hmap.t',
988
+
description: 'Remove a binding' },
989
+
{ code: 'Hmap.find k_int m2;;', expect: 'None',
990
+
description: 'Key is no longer bound' },
991
+
] },
992
+
],
993
+
},
994
+
995
+
// ═══════════════════════════════════════════════════════════════════════
996
+
// Gg
997
+
// ═══════════════════════════════════════════════════════════════════════
998
+
'gg.1.0.0': {
999
+
name: 'Gg', version: '1.0.0', opam: 'gg',
1000
+
description: 'Basic types for computer graphics in OCaml',
1001
+
universe: U['gg.1.0.0'], require: ['gg'],
1002
+
sections: [
1003
+
{ title: '2D Vectors',
1004
+
description: 'Gg.V2 provides 2D vector operations. Vectors are immutable float pairs.',
1005
+
steps: [
1006
+
{ code: 'let v = Gg.V2.v 3.0 4.0;;', expect: 'Gg.v2',
1007
+
description: 'Create a 2D vector (3, 4)' },
1008
+
{ code: 'Gg.V2.x v;;', expect: '3.',
1009
+
description: 'X component' },
1010
+
{ code: 'Gg.V2.y v;;', expect: '4.',
1011
+
description: 'Y component' },
1012
+
{ code: 'Gg.V2.norm v;;', expect: '5.',
1013
+
description: 'Vector magnitude: sqrt(9 + 16) = 5' },
1014
+
] },
1015
+
{ title: 'Vector Arithmetic',
1016
+
description: 'Vectors support addition, subtraction, scalar multiplication, and dot products.',
1017
+
steps: [
1018
+
{ code: 'let a = Gg.V2.v 1.0 0.0;;', expect: 'Gg.v2',
1019
+
description: 'Unit vector along x-axis' },
1020
+
{ code: 'let b = Gg.V2.v 0.0 1.0;;', expect: 'Gg.v2',
1021
+
description: 'Unit vector along y-axis' },
1022
+
{ code: 'Gg.V2.add a b |> Gg.V2.x;;', expect: '1.',
1023
+
description: 'Addition: (1,0) + (0,1) → x = 1' },
1024
+
{ code: 'Gg.V2.dot a b;;', expect: '0.',
1025
+
description: 'Dot product of perpendicular vectors = 0' },
1026
+
{ code: 'Gg.V2.smul 3.0 a |> Gg.V2.x;;', expect: '3.',
1027
+
description: 'Scalar multiply: 3 * (1,0) → x = 3' },
1028
+
] },
1029
+
{ title: '3D Vectors and Cross Product',
1030
+
description: 'Gg.V3 adds a third dimension and the cross product operation.',
1031
+
steps: [
1032
+
{ code: 'let i = Gg.V3.v 1.0 0.0 0.0;;', expect: 'Gg.v3',
1033
+
description: 'X-axis unit vector' },
1034
+
{ code: 'let j = Gg.V3.v 0.0 1.0 0.0;;', expect: 'Gg.v3',
1035
+
description: 'Y-axis unit vector' },
1036
+
{ code: 'let k = Gg.V3.cross i j;;', expect: 'Gg.v3',
1037
+
description: 'Cross product i × j = k (z-axis)' },
1038
+
{ code: 'Gg.V3.z k;;', expect: '1.',
1039
+
description: 'Z component is 1 (right-hand rule)' },
1040
+
] },
1041
+
{ title: 'Colors',
1042
+
description: 'Gg.Color represents colors in linear sRGB with alpha.',
1043
+
steps: [
1044
+
{ code: 'Gg.Color.red;;', expect: 'Gg.color',
1045
+
description: 'Predefined red color' },
1046
+
{ code: 'Gg.Color.r Gg.Color.red;;', expect: '1.',
1047
+
description: 'Red component = 1.0' },
1048
+
{ code: 'Gg.Color.g Gg.Color.red;;', expect: '0.',
1049
+
description: 'Green component = 0.0' },
1050
+
{ code: 'let c = Gg.Color.v 0.5 0.8 0.2 1.0;;', expect: 'Gg.color',
1051
+
description: 'Create a custom RGBA color' },
1052
+
{ code: 'Gg.Color.a c;;', expect: '1.',
1053
+
description: 'Alpha component' },
1054
+
] },
1055
+
],
1056
+
},
1057
+
1058
+
// ═══════════════════════════════════════════════════════════════════════
1059
+
// Vg
1060
+
// ═══════════════════════════════════════════════════════════════════════
1061
+
'vg.0.9.5': {
1062
+
name: 'Vg', version: '0.9.5', opam: 'vg',
1063
+
description: 'Declarative 2D vector graphics for OCaml',
1064
+
universe: U['vg.0.9.5'], require: ['vg', 'gg'],
1065
+
sections: [
1066
+
{ title: 'Building Paths',
1067
+
description: 'Vg.P builds immutable path values by chaining operations on P.empty.',
1068
+
steps: [
1069
+
{ code: 'let p = Vg.P.empty;;', expect: 'Vg.path',
1070
+
description: 'Start with an empty path' },
1071
+
{ code: 'let p = Vg.P.empty |> Vg.P.sub (Gg.P2.v 0. 0.) |> Vg.P.line (Gg.P2.v 1. 1.);;',
1072
+
expect: 'Vg.path', description: 'A line from (0,0) to (1,1)' },
1073
+
{ code: 'let circ = Vg.P.empty |> Vg.P.circle (Gg.P2.v 0.5 0.5) 0.3;;',
1074
+
expect: 'Vg.path', description: 'A circle centered at (0.5, 0.5) with radius 0.3' },
1075
+
{ code: 'let rect = Vg.P.empty |> Vg.P.rect (Gg.Box2.v (Gg.P2.v 0. 0.) (Gg.Size2.v 1. 1.));;',
1076
+
expect: 'Vg.path', description: 'A unit rectangle' },
1077
+
] },
1078
+
{ title: 'Creating Images',
1079
+
description: 'Vg.I constructs images from colors, paths, and compositing operations.',
1080
+
steps: [
1081
+
{ code: 'let red_fill = Vg.I.const Gg.Color.red;;', expect: 'Vg.image',
1082
+
description: 'A solid red infinite image' },
1083
+
{ code: 'let red_circle = Vg.I.cut circ red_fill;;', expect: 'Vg.image',
1084
+
description: 'Cut the red fill to the circle path' },
1085
+
{ code: 'let blue_rect = Vg.I.cut rect (Vg.I.const Gg.Color.blue);;', expect: 'Vg.image',
1086
+
description: 'A blue rectangle' },
1087
+
] },
1088
+
{ title: 'Compositing Images',
1089
+
description: 'Vg.I.blend composites images. I.tr applies affine transforms via Gg.M3 matrices.',
1090
+
steps: [
1091
+
{ code: 'let scene = Vg.I.blend red_circle blue_rect;;', expect: 'Vg.image',
1092
+
description: 'Blend circle over rectangle' },
1093
+
{ code: 'Vg.I.void;;', expect: 'Vg.image',
1094
+
description: 'The empty (transparent) image' },
1095
+
{ code: 'let moved = Vg.I.move (Gg.V2.v 0.5 0.5) red_circle;;', expect: 'Vg.image',
1096
+
description: 'Translate the circle by (0.5, 0.5)' },
1097
+
] },
1098
+
],
1099
+
},
1100
+
1101
+
// ═══════════════════════════════════════════════════════════════════════
1102
+
// Note
1103
+
// ═══════════════════════════════════════════════════════════════════════
1104
+
'note.0.0.3': {
1105
+
name: 'Note', version: '0.0.3', opam: 'note',
1106
+
description: 'Declarative events and signals for OCaml',
1107
+
universe: U['note.0.0.3'], require: ['note'],
1108
+
sections: [
1109
+
{ title: 'Constant Signals',
1110
+
description: 'Note.S.const creates a signal with a fixed value. Signals always have a current value.',
1111
+
steps: [
1112
+
{ code: 'let s = Note.S.const 42;;', expect: 'Note.signal',
1113
+
description: 'A constant signal with value 42' },
1114
+
{ code: 'Note.S.value s;;', expect: '42',
1115
+
description: 'Read the signal value' },
1116
+
] },
1117
+
{ title: 'Mutable Signals',
1118
+
description: 'Note.S.create returns a signal and a setter function for updating the value.',
1119
+
steps: [
1120
+
{ code: 'let counter, set_counter = Note.S.create 0;;', expect: 'Note.signal',
1121
+
description: 'Create a mutable signal starting at 0' },
1122
+
{ code: 'Note.S.value counter;;', expect: '0',
1123
+
description: 'Initial value' },
1124
+
{ code: 'set_counter 10;;', expect: 'unit',
1125
+
description: 'Update the value to 10' },
1126
+
{ code: 'Note.S.value counter;;', expect: '10',
1127
+
description: 'Value has changed' },
1128
+
] },
1129
+
{ title: 'Signal Transformations',
1130
+
description: 'Note.S.map and Note.S.l2 derive new signals from existing ones.',
1131
+
steps: [
1132
+
{ code: 'let doubled = Note.S.map (( * ) 2) counter;;', expect: 'Note.signal',
1133
+
description: 'A derived signal: always 2x the counter' },
1134
+
{ code: 'Note.S.value doubled;;', expect: '20',
1135
+
description: '10 * 2 = 20' },
1136
+
{ code: 'let label = Note.S.map (fun n -> Printf.sprintf "count=%d" n) counter;;',
1137
+
expect: 'Note.signal', description: 'Map counter to a string label' },
1138
+
{ code: 'Note.S.value label;;', expect: '"count=10"',
1139
+
description: 'Label reflects the current counter value' },
1140
+
{ code: 'let sum = Note.S.l2 ( + ) counter doubled;;', expect: 'Note.signal',
1141
+
description: 'Combine two signals with l2' },
1142
+
{ code: 'Note.S.value sum;;', expect: '30',
1143
+
description: '10 + 20 = 30' },
1144
+
] },
1145
+
],
1146
+
},
1147
+
1148
+
// ═══════════════════════════════════════════════════════════════════════
1149
+
// Otfm
1150
+
// ═══════════════════════════════════════════════════════════════════════
1151
+
'otfm.0.4.0': {
1152
+
name: 'Otfm', version: '0.4.0', opam: 'otfm',
1153
+
description: 'OpenType font decoder for OCaml',
1154
+
universe: U['otfm.0.4.0'], require: ['otfm'],
1155
+
sections: [
1156
+
{ title: 'Decoder Creation',
1157
+
description: 'Otfm.decoder creates a decoder from font byte data. Most operations require valid font data.',
1158
+
steps: [
1159
+
{ code: 'Otfm.decoder;;', expect: '-> Otfm.decoder',
1160
+
description: 'The decoder constructor (takes a `String source)' },
1161
+
{ code: 'let d = Otfm.decoder (`String "");;', expect: 'Otfm.decoder',
1162
+
description: 'Create a decoder (with empty data for exploration)' },
1163
+
] },
1164
+
{ title: 'Querying Font Data',
1165
+
description: 'With valid font data, you can query tables, glyph counts, and PostScript names.',
1166
+
steps: [
1167
+
{ code: 'Otfm.flavour d;;', expect: 'Error',
1168
+
description: 'Flavour fails on empty data (expected)' },
1169
+
{ code: 'Otfm.postscript_name d;;', expect: '',
1170
+
description: 'PostScript name query (fails gracefully on empty data)' },
1171
+
{ code: 'Otfm.glyph_count d;;', expect: '',
1172
+
description: 'Glyph count query' },
1173
+
] },
1174
+
],
1175
+
},
1176
+
1177
+
// ═══════════════════════════════════════════════════════════════════════
1178
+
// Fpath
1179
+
// ═══════════════════════════════════════════════════════════════════════
1180
+
'fpath.0.7.3': {
1181
+
name: 'Fpath', version: '0.7.3', opam: 'fpath',
1182
+
description: 'File system paths for OCaml',
1183
+
universe: U['fpath.0.7.3'], require: ['fpath'],
1184
+
sections: [
1185
+
{ title: 'Creating Paths',
1186
+
description: 'Fpath.v creates a path from a string. Paths are validated on creation.',
1187
+
steps: [
1188
+
{ code: 'Fpath.v "/usr/local/bin";;', expect: 'Fpath.t',
1189
+
description: 'Create an absolute path' },
1190
+
{ code: 'Fpath.v "/usr/local/bin" |> Fpath.to_string;;', expect: '"/usr/local/bin"',
1191
+
description: 'Convert back to string' },
1192
+
{ code: 'Fpath.v "src/main.ml";;', expect: 'Fpath.t',
1193
+
description: 'A relative path' },
1194
+
] },
1195
+
{ title: 'Path Composition',
1196
+
description: 'Fpath.(/) appends a segment. Paths compose naturally.',
1197
+
steps: [
1198
+
{ code: 'Fpath.(v "/usr" / "local" / "bin") |> Fpath.to_string;;', expect: '"/usr/local/bin"',
1199
+
description: 'Build paths by appending segments' },
1200
+
{ code: 'Fpath.(v "src" / "lib" / "main.ml") |> Fpath.to_string;;', expect: '"src/lib/main.ml"',
1201
+
description: 'Relative path composition' },
1202
+
] },
1203
+
{ title: 'Path Components',
1204
+
description: 'Extract parts of a path: parent directory, basename, filename.',
1205
+
steps: [
1206
+
{ code: 'Fpath.v "/usr/local/bin" |> Fpath.parent |> Fpath.to_string;;', expect: '"/usr/local/"',
1207
+
description: 'Parent directory' },
1208
+
{ code: 'Fpath.v "/usr/local/bin" |> Fpath.basename;;', expect: '"bin"',
1209
+
description: 'Basename (last segment)' },
1210
+
{ code: 'Fpath.v "/usr/local/bin" |> Fpath.filename;;', expect: '"bin"',
1211
+
description: 'Filename (last non-empty segment)' },
1212
+
{ code: 'Fpath.v "/a/b/" |> Fpath.basename;;', expect: '"b"',
1213
+
description: 'Basename of a directory path' },
1214
+
{ code: 'Fpath.segs (Fpath.v "/a/b/c");;', expect: '[""; "a"; "b"; "c"]',
1215
+
description: 'All segments (empty first = absolute)' },
1216
+
] },
1217
+
{ title: 'File Extensions',
1218
+
description: 'Query and manipulate file extensions.',
1219
+
steps: [
1220
+
{ code: 'Fpath.has_ext ".ml" (Fpath.v "main.ml");;', expect: 'true',
1221
+
description: 'Check for .ml extension' },
1222
+
{ code: 'Fpath.get_ext (Fpath.v "archive.tar.gz");;', expect: '".gz"',
1223
+
description: 'Get the last extension' },
1224
+
{ code: 'Fpath.get_ext ~multi:true (Fpath.v "archive.tar.gz");;', expect: '".tar.gz"',
1225
+
description: 'Get the full multi-extension' },
1226
+
{ code: 'Fpath.rem_ext (Fpath.v "main.ml") |> Fpath.to_string;;', expect: '"main"',
1227
+
description: 'Remove the extension' },
1228
+
] },
1229
+
{ title: 'Path Properties',
1230
+
description: 'Test whether paths are absolute, relative, file paths, or directory paths.',
1231
+
steps: [
1232
+
{ code: 'Fpath.is_abs (Fpath.v "/usr/bin");;', expect: 'true',
1233
+
description: 'Absolute path check' },
1234
+
{ code: 'Fpath.is_rel (Fpath.v "src/main.ml");;', expect: 'true',
1235
+
description: 'Relative path check' },
1236
+
{ code: 'Fpath.is_dir_path (Fpath.v "/usr/bin/");;', expect: 'true',
1237
+
description: 'Directory path (ends with /)' },
1238
+
{ code: 'Fpath.is_file_path (Fpath.v "/usr/bin");;', expect: 'true',
1239
+
description: 'File path (does not end with /)' },
1240
+
{ code: 'Fpath.normalize (Fpath.v "/a/b/../c") |> Fpath.to_string;;', expect: '"/a/c"',
1241
+
description: 'Normalize resolves .. components' },
1242
+
] },
1243
+
],
1244
+
},
1245
+
1246
+
// ═══════════════════════════════════════════════════════════════════════
1247
+
// Uutf
1248
+
// ═══════════════════════════════════════════════════════════════════════
1249
+
'uutf.1.0.4': {
1250
+
name: 'Uutf', version: '1.0.4', opam: 'uutf',
1251
+
description: 'Non-blocking streaming Unicode codec for OCaml',
1252
+
universe: U['uutf.1.0.4'], require: ['uutf'],
1253
+
sections: [
1254
+
{ title: 'UTF-8 Decoding',
1255
+
description: 'Uutf.decoder creates a streaming decoder. Each Uutf.decode call returns one character or a signal.',
1256
+
steps: [
1257
+
{ code: 'let d = Uutf.decoder ~encoding:`UTF_8 (`String "ABC");;', expect: 'Uutf.decoder',
1258
+
description: 'Create a UTF-8 decoder for "ABC"' },
1259
+
{ code: 'Uutf.decode d;;', expect: '`Uchar',
1260
+
description: 'Decode first character: A' },
1261
+
{ code: 'Uutf.decode d;;', expect: '`Uchar',
1262
+
description: 'Decode second character: B' },
1263
+
{ code: 'Uutf.decode d;;', expect: '`Uchar',
1264
+
description: 'Decode third character: C' },
1265
+
{ code: 'Uutf.decode d;;', expect: '`End',
1266
+
description: 'End of input' },
1267
+
] },
1268
+
{ title: 'Multi-byte Characters',
1269
+
description: 'UTF-8 encodes non-ASCII characters in multiple bytes. Uutf handles this transparently.',
1270
+
steps: [
1271
+
{ code: 'let d2 = Uutf.decoder ~encoding:`UTF_8 (`String "caf\\xC3\\xA9");;',
1272
+
expect: 'Uutf.decoder', description: 'Decode "cafe" with e-acute (U+00E9)' },
1273
+
{ code: 'Uutf.decode d2;;', expect: '`Uchar',
1274
+
description: 'c' },
1275
+
{ code: 'Uutf.decode d2;;', expect: '`Uchar',
1276
+
description: 'a' },
1277
+
{ code: 'Uutf.decode d2;;', expect: '`Uchar',
1278
+
description: 'f' },
1279
+
{ code: 'Uutf.decode d2;;', expect: '`Uchar',
1280
+
description: 'e-acute (U+00E9, decoded from 2 bytes)' },
1281
+
] },
1282
+
{ title: 'UTF-8 Encoding',
1283
+
description: 'Uutf.encoder writes Unicode characters to a buffer in a specified encoding.',
1284
+
steps: [
1285
+
{ code: 'let buf = Buffer.create 16;;', expect: 'Buffer.t',
1286
+
description: 'Create an output buffer' },
1287
+
{ code: 'let e = Uutf.encoder `UTF_8 (`Buffer buf);;', expect: 'Uutf.encoder',
1288
+
description: 'Create a UTF-8 encoder' },
1289
+
{ code: 'Uutf.encode e (`Uchar (Uchar.of_int 0x41));;', expect: '`Ok',
1290
+
description: "Encode 'A'" },
1291
+
{ code: 'Uutf.encode e (`Uchar (Uchar.of_int 0xE9));;', expect: '`Ok',
1292
+
description: "Encode e-acute" },
1293
+
{ code: 'Uutf.encode e `End;;', expect: '`Ok',
1294
+
description: 'Flush the encoder' },
1295
+
{ code: 'Buffer.length buf;;', expect: '3',
1296
+
description: "A (1 byte) + e-acute (2 bytes) = 3 bytes" },
1297
+
] },
1298
+
],
1299
+
},
1300
+
1301
+
// ═══════════════════════════════════════════════════════════════════════
1302
+
// B0
1303
+
// ═══════════════════════════════════════════════════════════════════════
1304
+
'b0.0.0.6': {
1305
+
name: 'B0', version: '0.0.6', opam: 'b0',
1306
+
description: 'Software construction and deployment kit',
1307
+
universe: U['b0.0.0.6'], require: ['b0.std'],
1308
+
sections: [
1309
+
{ title: 'File Paths (B0_std.Fpath)',
1310
+
description: 'B0_std provides its own Fpath module for file path manipulation.',
1311
+
steps: [
1312
+
{ code: 'B0_std.Fpath.v "/usr/bin";;', expect: 'B0_std.Fpath.t',
1313
+
description: 'Create a path' },
1314
+
{ code: 'B0_std.Fpath.(v "/usr" / "local" / "bin") |> B0_std.Fpath.to_string;;',
1315
+
expect: '"/usr/local/bin"', description: 'Path composition with (/)' },
1316
+
{ code: 'B0_std.Fpath.basename (B0_std.Fpath.v "/usr/local/bin");;', expect: '"bin"',
1317
+
description: 'Get the basename' },
1318
+
{ code: 'B0_std.Fpath.parent (B0_std.Fpath.v "/usr/local/bin") |> B0_std.Fpath.to_string;;',
1319
+
expect: '"/usr/local/"', description: 'Get parent directory' },
1320
+
] },
1321
+
{ title: 'Command Lines (B0_std.Cmd)',
1322
+
description: 'B0_std.Cmd builds command-line invocations declaratively.',
1323
+
steps: [
1324
+
{ code: 'let cmd = B0_std.Cmd.(tool "ocamlfind" % "query" % "-format" % "%d" % "fmt");;',
1325
+
expect: 'B0_std.Cmd.t', description: 'Build a command line' },
1326
+
{ code: 'B0_std.Cmd.to_list cmd;;', expect: '["ocamlfind"',
1327
+
description: 'Convert to a list of strings' },
1328
+
{ code: 'B0_std.Cmd.is_empty B0_std.Cmd.empty;;', expect: 'true',
1329
+
description: 'Check for empty command' },
1330
+
] },
1331
+
],
1332
+
},
1333
+
1334
+
// ═══════════════════════════════════════════════════════════════════════
1335
+
// Bos
1336
+
// ═══════════════════════════════════════════════════════════════════════
1337
+
// ═══════════════════════════════════════════════════════════════════════
1338
+
// Yojson
1339
+
// ═══════════════════════════════════════════════════════════════════════
1340
+
'yojson.1.7.0': {
1341
+
name: 'Yojson', version: '1.7.0', opam: 'yojson',
1342
+
description: 'JSON parsing and printing for OCaml (1.x API)',
1343
+
universe: U['yojson.1.7.0'], require: ['yojson'],
1344
+
sections: [
1345
+
{ title: 'Parsing JSON',
1346
+
description: 'Yojson.Safe.from_string parses a JSON string into an algebraic type.',
1347
+
steps: [
1348
+
{ code: 'Yojson.Safe.from_string {|{"name": "Alice", "age": 30}|};;',
1349
+
expect: '`Assoc', description: 'Parse a JSON object' },
1350
+
{ code: 'Yojson.Safe.from_string "[1, 2, 3]";;',
1351
+
expect: '`List', description: 'Parse a JSON array' },
1352
+
{ code: 'Yojson.Safe.from_string "42";;',
1353
+
expect: '`Int 42', description: 'Parse a JSON number' },
1354
+
] },
1355
+
{ title: 'Building JSON',
1356
+
description: 'JSON values are polymorphic variants: `Null, `Bool, `Int, `Float, `String, `List, `Assoc.',
1357
+
steps: [
1358
+
{ code: 'Yojson.Safe.to_string (`Assoc [("x", `Int 1); ("y", `Int 2)]);;',
1359
+
expect: '"x"', description: 'Serialize an object to string' },
1360
+
{ code: 'Yojson.Safe.to_string (`List [`String "a"; `Bool true]);;',
1361
+
expect: '"a"', description: 'Serialize a list' },
1362
+
] },
1363
+
{ title: 'Util Module',
1364
+
description: 'Yojson.Safe.Util provides accessor functions for extracting values from JSON.',
1365
+
steps: [
1366
+
{ code: 'let j = Yojson.Safe.from_string {|{"name": "Bob"}|};;', expect: '`Assoc',
1367
+
description: 'Parse a JSON object' },
1368
+
{ code: 'Yojson.Safe.Util.member "name" j;;', expect: '`String "Bob"',
1369
+
description: 'Extract a field by name' },
1370
+
{ code: 'Yojson.Safe.Util.member "name" j |> Yojson.Safe.Util.to_string;;',
1371
+
expect: '"Bob"', description: 'Extract as an OCaml string' },
1372
+
{ code: 'Yojson.Safe.Util.keys (`Assoc [("a", `Int 1); ("b", `Int 2)]);;',
1373
+
expect: '["a"; "b"]', description: 'Get all keys of an object' },
1374
+
] },
1375
+
],
1376
+
},
1377
+
1378
+
'yojson.2.0.2': {
1379
+
name: 'Yojson', version: '2.0.2', opam: 'yojson',
1380
+
description: 'JSON parsing and printing for OCaml (2.x API)',
1381
+
universe: U['yojson.2.0.2'], require: ['yojson'],
1382
+
sections: [
1383
+
{ title: 'Parsing JSON',
1384
+
description: 'Yojson 2.x removed biniou dependency. The core API is the same.',
1385
+
steps: [
1386
+
{ code: 'Yojson.Safe.from_string {|{"key": "value"}|};;',
1387
+
expect: '`Assoc', description: 'Parse a JSON object' },
1388
+
{ code: 'Yojson.Safe.from_string "true";;',
1389
+
expect: '`Bool true', description: 'Parse a boolean' },
1390
+
] },
1391
+
{ title: 'Building and Serializing',
1392
+
steps: [
1393
+
{ code: 'Yojson.Safe.to_string (`Assoc [("n", `Int 42)]);;',
1394
+
expect: '"n"', description: 'Serialize to compact JSON' },
1395
+
{ code: 'Yojson.Safe.pretty_to_string (`Assoc [("n", `Int 42)]);;',
1396
+
expect: '"n"', description: 'Pretty-print with indentation' },
1397
+
] },
1398
+
{ title: 'Util Accessors',
1399
+
description: 'Extract typed values from JSON trees.',
1400
+
steps: [
1401
+
{ code: 'Yojson.Safe.Util.to_int (`Int 42);;', expect: '42',
1402
+
description: 'Extract an int' },
1403
+
{ code: 'Yojson.Safe.Util.to_list (`List [`Int 1; `Int 2]);;',
1404
+
expect: '[`Int 1', description: 'Extract a list' },
1405
+
{ code: 'Yojson.Safe.Util.to_bool (`Bool true);;', expect: 'true',
1406
+
description: 'Extract a bool' },
1407
+
{ code: 'Yojson.Safe.Util.member "x" (`Assoc [("x", `Float 3.14)]);;',
1408
+
expect: '`Float 3.14', description: 'Navigate into an object' },
1409
+
] },
1410
+
],
1411
+
},
1412
+
1413
+
'yojson.2.1.2': {
1414
+
name: 'Yojson', version: '2.1.2', opam: 'yojson',
1415
+
description: 'JSON parsing and printing for OCaml',
1416
+
universe: U['yojson.2.1.2'], require: ['yojson'],
1417
+
sections: [
1418
+
{ title: 'Parsing and Serializing',
1419
+
steps: [
1420
+
{ code: 'Yojson.Safe.from_string {|[1, "two", true]|};;',
1421
+
expect: '`List', description: 'Parse a heterogeneous array' },
1422
+
{ code: 'Yojson.Safe.to_string (`List [`Int 1; `String "two"; `Bool true]);;',
1423
+
expect: '1', description: 'Serialize back to JSON' },
1424
+
] },
1425
+
{ title: 'Util Navigation',
1426
+
steps: [
1427
+
{ code: 'let data = Yojson.Safe.from_string {|{"users": [{"name": "A"}, {"name": "B"}]}|};;',
1428
+
expect: '`Assoc', description: 'Parse nested JSON' },
1429
+
{ code: 'Yojson.Safe.Util.(member "users" data |> to_list |> List.map (member "name"));;',
1430
+
expect: '[`String "A"', description: 'Navigate and extract nested values' },
1431
+
{ code: 'Yojson.Safe.Util.(member "users" data |> index 0 |> member "name" |> to_string);;',
1432
+
expect: '"A"', description: 'Index into arrays' },
1433
+
] },
1434
+
],
1435
+
},
1436
+
1437
+
'yojson.2.2.2': {
1438
+
name: 'Yojson', version: '2.2.2', opam: 'yojson',
1439
+
description: 'JSON parsing and printing for OCaml',
1440
+
universe: U['yojson.2.2.2'], require: ['yojson'],
1441
+
sections: [
1442
+
{ title: 'Round-Trip JSON',
1443
+
steps: [
1444
+
{ code: 'let j = `Assoc [("list", `List [`Int 1; `Int 2; `Int 3])];;',
1445
+
expect: '`Assoc', description: 'Build a JSON value' },
1446
+
{ code: 'let s = Yojson.Safe.to_string j;;', expect: 'string',
1447
+
description: 'Serialize to string' },
1448
+
{ code: 'Yojson.Safe.from_string s = j;;', expect: 'true',
1449
+
description: 'Round-trip preserves structure' },
1450
+
] },
1451
+
{ title: 'Util Combinators',
1452
+
steps: [
1453
+
{ code: 'Yojson.Safe.Util.combine (`Assoc [("a", `Int 1)]) (`Assoc [("b", `Int 2)]);;',
1454
+
expect: '`Assoc', description: 'Merge two objects' },
1455
+
{ code: 'Yojson.Safe.Util.to_assoc (`Assoc [("x", `Int 1)]);;',
1456
+
expect: '[("x"', description: 'Convert to association list' },
1457
+
{ code: 'Yojson.Safe.Util.filter_member "name" [`Assoc [("name", `String "A")]; `Assoc []];;',
1458
+
expect: '[`String "A"', description: 'Filter objects by field presence' },
1459
+
] },
1460
+
],
1461
+
},
1462
+
1463
+
'yojson.3.0.0': {
1464
+
name: 'Yojson', version: '3.0.0', opam: 'yojson',
1465
+
description: 'JSON parsing and printing for OCaml (3.x, strict types)',
1466
+
universe: U['yojson.3.0.0'], require: ['yojson'],
1467
+
sections: [
1468
+
{ title: 'Strict JSON Types',
1469
+
description: 'Yojson 3.0 removed non-standard Tuple and Variant constructors from Safe.t.',
1470
+
steps: [
1471
+
{ code: 'Yojson.Safe.from_string {|{"clean": true}|};;',
1472
+
expect: '`Assoc', description: 'Parse standard JSON' },
1473
+
{ code: 'Yojson.Safe.to_string (`Assoc [("v", `Intlit "999999999999999")]);;',
1474
+
expect: '999999999999999', description: 'Intlit preserves large integers as strings' },
1475
+
] },
1476
+
{ title: 'Util Module',
1477
+
steps: [
1478
+
{ code: 'Yojson.Safe.Util.member "x" (`Assoc [("x", `Null)]);;',
1479
+
expect: '`Null', description: 'Access a null field' },
1480
+
{ code: 'Yojson.Safe.Util.values (`Assoc [("a", `Int 1); ("b", `Int 2)]);;',
1481
+
expect: '[`Int 1', description: 'Extract all values' },
1482
+
{ code: 'Yojson.Safe.Util.to_string_option (`Null);;', expect: 'None',
1483
+
description: 'Safe accessor returns None for wrong type' },
1484
+
{ code: 'Yojson.Safe.Util.to_string_option (`String "hi");;', expect: 'Some "hi"',
1485
+
description: 'Safe accessor returns Some for correct type' },
1486
+
] },
1487
+
],
1488
+
},
1489
+
1490
+
// ═══════════════════════════════════════════════════════════════════════
1491
+
// Ezjsonm
1492
+
// ═══════════════════════════════════════════════════════════════════════
1493
+
'ezjsonm.1.1.0': {
1494
+
name: 'Ezjsonm', version: '1.1.0', opam: 'ezjsonm',
1495
+
description: 'Easy JSON manipulation for OCaml',
1496
+
universe: U['ezjsonm.1.1.0'], require: ['ezjsonm'],
1497
+
sections: [
1498
+
{ title: 'Building Values',
1499
+
description: 'Ezjsonm provides typed constructors for JSON values.',
1500
+
steps: [
1501
+
{ code: 'Ezjsonm.string "hello";;', expect: '`String "hello"',
1502
+
description: 'Create a JSON string' },
1503
+
{ code: 'Ezjsonm.int 42;;', expect: '`Float 42.',
1504
+
description: 'Create a JSON number (stored as float internally)' },
1505
+
{ code: 'Ezjsonm.bool true;;', expect: '`Bool true',
1506
+
description: 'Create a JSON boolean' },
1507
+
{ code: 'Ezjsonm.list Ezjsonm.int [1; 2; 3];;', expect: '`A',
1508
+
description: 'Create a JSON array from a list' },
1509
+
] },
1510
+
{ title: 'Serialization',
1511
+
description: 'Convert values to and from strings.',
1512
+
steps: [
1513
+
{ code: 'Ezjsonm.value_to_string (Ezjsonm.string "hi");;', expect: 'string',
1514
+
description: 'Serialize a value (JSON-encoded string with quotes)' },
1515
+
{ code: 'Ezjsonm.value_to_string (Ezjsonm.list Ezjsonm.int [1;2;3]);;',
1516
+
expect: '[1', description: 'Serialize an array' },
1517
+
{ code: 'Ezjsonm.value_from_string "42";;', expect: '`Float 42.',
1518
+
description: 'Parse a JSON value from string' },
1519
+
] },
1520
+
{ title: 'Extracting Values',
1521
+
description: 'get_* functions extract OCaml values from JSON.',
1522
+
steps: [
1523
+
{ code: 'Ezjsonm.get_string (Ezjsonm.string "test");;', expect: '"test"',
1524
+
description: 'Extract a string' },
1525
+
{ code: 'Ezjsonm.get_int (Ezjsonm.int 42);;', expect: '42',
1526
+
description: 'Extract an int' },
1527
+
{ code: 'Ezjsonm.get_list Ezjsonm.get_int (Ezjsonm.list Ezjsonm.int [1;2;3]);;',
1528
+
expect: '[1; 2; 3]', description: 'Extract a list of ints' },
1529
+
] },
1530
+
],
1531
+
},
1532
+
1533
+
'ezjsonm.1.2.0': {
1534
+
name: 'Ezjsonm', version: '1.2.0', opam: 'ezjsonm',
1535
+
description: 'Easy JSON manipulation for OCaml',
1536
+
universe: U['ezjsonm.1.2.0'], require: ['ezjsonm'],
1537
+
sections: [
1538
+
{ title: 'Building and Querying',
1539
+
steps: [
1540
+
{ code: 'let doc = Ezjsonm.dict [("name", Ezjsonm.string "Alice"); ("age", Ezjsonm.int 30)];;',
1541
+
expect: '`O', description: 'Build a JSON object with dict' },
1542
+
{ code: 'Ezjsonm.value_to_string doc;;', expect: 'string',
1543
+
description: 'Serialize the object to JSON' },
1544
+
{ code: 'Ezjsonm.get_dict doc;;', expect: '[("name"',
1545
+
description: 'Extract as association list' },
1546
+
] },
1547
+
{ title: 'Navigating Documents',
1548
+
description: 'Ezjsonm.find navigates into nested JSON using a path of string keys.',
1549
+
steps: [
1550
+
{ code: 'let j = Ezjsonm.from_string {|{"user": {"name": "Bob"}}|};;',
1551
+
expect: '`O', description: 'Parse a nested document' },
1552
+
{ code: 'Ezjsonm.find j ["user"; "name"];;', expect: '`String "Bob"',
1553
+
description: 'Navigate by key path' },
1554
+
{ code: 'Ezjsonm.mem j ["user"; "name"];;', expect: 'true',
1555
+
description: 'Check if a path exists' },
1556
+
{ code: 'Ezjsonm.find_opt j ["user"; "email"];;', expect: 'None',
1557
+
description: 'Safe navigation returns None for missing paths' },
1558
+
] },
1559
+
],
1560
+
},
1561
+
1562
+
'ezjsonm.1.3.0': {
1563
+
name: 'Ezjsonm', version: '1.3.0', opam: 'ezjsonm',
1564
+
description: 'Easy JSON manipulation for OCaml',
1565
+
universe: U['ezjsonm.1.3.0'], require: ['ezjsonm'],
1566
+
sections: [
1567
+
{ title: 'Value Constructors',
1568
+
steps: [
1569
+
{ code: 'Ezjsonm.string "hello";;', expect: '`String',
1570
+
description: 'A JSON string value' },
1571
+
{ code: 'Ezjsonm.unit ();;', expect: '`Null',
1572
+
description: 'JSON null' },
1573
+
{ code: 'Ezjsonm.list Ezjsonm.string ["a"; "b"];;', expect: '`A',
1574
+
description: 'Array of strings' },
1575
+
] },
1576
+
{ title: 'Documents',
1577
+
description: 'Documents (Ezjsonm.t) must be arrays or objects at the top level.',
1578
+
steps: [
1579
+
{ code: 'let doc = Ezjsonm.from_string {|{"x": [1, 2, 3]}|};;', expect: '`O',
1580
+
description: 'Parse a document' },
1581
+
{ code: 'Ezjsonm.find doc ["x"] |> Ezjsonm.get_list Ezjsonm.get_int;;',
1582
+
expect: '[1; 2; 3]', description: 'Navigate and extract typed values' },
1583
+
{ code: 'Ezjsonm.to_string ~minify:false doc;;', expect: 'string',
1584
+
description: 'Pretty-print a document' },
1585
+
] },
1586
+
],
1587
+
},
1588
+
1589
+
// ═══════════════════════════════════════════════════════════════════════
1590
+
// Sexplib0
1591
+
// ═══════════════════════════════════════════════════════════════════════
1592
+
'sexplib0.v0.15.1': {
1593
+
name: 'Sexplib0', version: 'v0.15.1', opam: 'sexplib0',
1594
+
description: 'S-expression type and printing (minimal, no parsing)',
1595
+
universe: U['sexplib0.v0.15.1'], require: ['sexplib0'],
1596
+
sections: [
1597
+
{ title: 'S-expression Type',
1598
+
description: 'Sexplib0.Sexp.t has two constructors: Atom of string and List of t list.',
1599
+
steps: [
1600
+
{ code: 'Sexplib0.Sexp.Atom "hello";;', expect: 'Sexplib0.Sexp.t',
1601
+
description: 'An atomic S-expression' },
1602
+
{ code: 'Sexplib0.Sexp.List [Atom "add"; Atom "1"; Atom "2"];;',
1603
+
expect: 'Sexplib0.Sexp.t', description: 'A list S-expression' },
1604
+
] },
1605
+
{ title: 'Printing',
1606
+
description: 'to_string produces compact output, to_string_hum produces indented output.',
1607
+
steps: [
1608
+
{ code: 'Sexplib0.Sexp.to_string (List [Atom "name"; Atom "Alice"]);;',
1609
+
expect: '"(name Alice)"', description: 'Compact string representation' },
1610
+
{ code: 'Sexplib0.Sexp.to_string_hum (List [Atom "config"; List [Atom "port"; Atom "8080"]]);;',
1611
+
expect: '(config', description: 'Human-readable indented output' },
1612
+
] },
1613
+
{ title: 'Comparison',
1614
+
steps: [
1615
+
{ code: 'Sexplib0.Sexp.equal (Atom "x") (Atom "x");;', expect: 'true',
1616
+
description: 'Structural equality' },
1617
+
{ code: 'Sexplib0.Sexp.equal (Atom "x") (Atom "y");;', expect: 'false',
1618
+
description: 'Different atoms are not equal' },
1619
+
] },
1620
+
],
1621
+
},
1622
+
1623
+
'sexplib0.v0.16.0': {
1624
+
name: 'Sexplib0', version: 'v0.16.0', opam: 'sexplib0',
1625
+
description: 'S-expression type and printing (minimal, no parsing)',
1626
+
universe: U['sexplib0.v0.16.0'], require: ['sexplib0'],
1627
+
sections: [
1628
+
{ title: 'Building S-expressions',
1629
+
steps: [
1630
+
{ code: 'open Sexplib0.Sexp;; let s = List [Atom "person"; List [Atom "name"; Atom "Bob"]; List [Atom "age"; Atom "25"]];;',
1631
+
expect: 'Sexplib0.Sexp.t', description: 'Build a nested S-expression' },
1632
+
{ code: 'Sexplib0.Sexp.to_string s;;', expect: '"(person (name Bob) (age 25))"',
1633
+
description: 'Serialize to compact string' },
1634
+
{ code: 'Sexplib0.Sexp.to_string_hum s;;', expect: '(person',
1635
+
description: 'Pretty-print with indentation' },
1636
+
] },
1637
+
{ title: 'Error Messages',
1638
+
description: 'Sexp.message builds structured error S-expressions.',
1639
+
steps: [
1640
+
{ code: 'Sexplib0.Sexp.message "invalid input" ["value", Atom "42"; "expected", Atom "string"];;',
1641
+
expect: 'Sexplib0.Sexp.t', description: 'Build a structured error message' },
1642
+
] },
1643
+
],
1644
+
},
1645
+
1646
+
'sexplib0.v0.17.0': {
1647
+
name: 'Sexplib0', version: 'v0.17.0', opam: 'sexplib0',
1648
+
description: 'S-expression type and printing (minimal, no parsing)',
1649
+
universe: U['sexplib0.v0.17.0'], require: ['sexplib0'],
1650
+
sections: [
1651
+
{ title: 'S-expression Basics',
1652
+
steps: [
1653
+
{ code: 'let open Sexplib0.Sexp in Atom "hello";;', expect: 'Sexplib0.Sexp.t',
1654
+
description: 'An atom' },
1655
+
{ code: 'let open Sexplib0.Sexp in List [Atom "list"; List [Atom "1"; Atom "2"; Atom "3"]];;',
1656
+
expect: 'Sexplib0.Sexp.t', description: 'Nested S-expression' },
1657
+
{ code: 'Sexplib0.Sexp.(to_string (List [Atom "a"; Atom "b"; Atom "c"]));;',
1658
+
expect: '"(a b c)"', description: 'Serialize to string' },
1659
+
] },
1660
+
{ title: 'Comparison and Equality',
1661
+
steps: [
1662
+
{ code: 'Sexplib0.Sexp.compare (Atom "a") (Atom "b");;', expect: '-1',
1663
+
description: 'Lexicographic comparison' },
1664
+
{ code: 'Sexplib0.Sexp.equal (List [Atom "x"]) (List [Atom "x"]);;', expect: 'true',
1665
+
description: 'Deep structural equality' },
1666
+
] },
1667
+
],
1668
+
},
1669
+
1670
+
// ═══════════════════════════════════════════════════════════════════════
1671
+
// Csexp
1672
+
// ═══════════════════════════════════════════════════════════════════════
1673
+
'csexp.1.5.2': {
1674
+
name: 'Csexp', version: '1.5.2', opam: 'csexp',
1675
+
description: 'Canonical S-expressions (length-prefixed binary format)',
1676
+
universe: U['csexp.1.5.2'], require: ['csexp'],
1677
+
sections: [
1678
+
{ title: 'Encoding',
1679
+
description: 'Canonical S-expressions use length-prefixed format: "5:hello" instead of "hello".',
1680
+
steps: [
1681
+
{ code: 'Csexp.to_string (Csexp.Atom "hello");;', expect: '"5:hello"',
1682
+
description: 'Encode an atom (5 bytes, colon, data)' },
1683
+
{ code: 'Csexp.to_string (Csexp.List [Csexp.Atom "a"; Csexp.Atom "bc"]);;',
1684
+
expect: '"(1:a2:bc)"', description: 'Encode a list' },
1685
+
{ code: 'Csexp.serialised_length (Csexp.Atom "test");;', expect: '6',
1686
+
description: '"1:test" would be wrong; "4:test" = 6 bytes' },
1687
+
] },
1688
+
{ title: 'Decoding',
1689
+
description: 'parse_string decodes canonical S-expressions.',
1690
+
steps: [
1691
+
{ code: 'Csexp.parse_string "5:hello";;', expect: 'Ok',
1692
+
description: 'Parse a single atom' },
1693
+
{ code: 'Csexp.parse_string "(1:a2:bc)";;', expect: 'Ok',
1694
+
description: 'Parse a list' },
1695
+
{ code: 'Csexp.parse_string_many "1:a1:b";;', expect: 'Ok',
1696
+
description: 'Parse multiple S-expressions' },
1697
+
{ code: 'Csexp.parse_string "bad";;', expect: 'Error',
1698
+
description: 'Invalid input returns Error' },
1699
+
] },
1700
+
],
1701
+
},
1702
+
1703
+
// ═══════════════════════════════════════════════════════════════════════
1704
+
// Base64
1705
+
// ═══════════════════════════════════════════════════════════════════════
1706
+
'base64.3.4.0': {
1707
+
name: 'Base64', version: '3.4.0', opam: 'base64',
1708
+
description: 'Base64 encoding and decoding for OCaml',
1709
+
universe: U['base64.3.4.0'], require: ['base64'],
1710
+
sections: [
1711
+
{ title: 'Encoding',
1712
+
steps: [
1713
+
{ code: 'Base64.encode_string "Hello, World!";;', expect: 'SGVsbG8sIFdvcmxkIQ==',
1714
+
description: 'Encode a string to base64' },
1715
+
{ code: 'Base64.encode_string "";;', expect: '""',
1716
+
description: 'Empty string encodes to empty' },
1717
+
{ code: 'Base64.encode_string "a";;', expect: 'YQ==',
1718
+
description: 'Single character with padding' },
1719
+
] },
1720
+
{ title: 'Decoding',
1721
+
steps: [
1722
+
{ code: 'Base64.decode_exn "SGVsbG8sIFdvcmxkIQ==";;', expect: '"Hello, World!"',
1723
+
description: 'Decode base64 back to string' },
1724
+
{ code: 'Base64.decode "YQ==";;', expect: 'Ok "a"',
1725
+
description: 'Safe decode returns result' },
1726
+
{ code: 'Base64.decode "!!invalid!!";;', expect: 'Error',
1727
+
description: 'Invalid base64 returns Error' },
1728
+
] },
1729
+
],
1730
+
},
1731
+
1732
+
'base64.3.5.2': {
1733
+
name: 'Base64', version: '3.5.2', opam: 'base64',
1734
+
description: 'Base64 encoding and decoding for OCaml',
1735
+
universe: U['base64.3.5.2'], require: ['base64'],
1736
+
sections: [
1737
+
{ title: 'Standard Encoding',
1738
+
steps: [
1739
+
{ code: 'Base64.encode_string "OCaml";;', expect: 'T0NhbWw=',
1740
+
description: 'Encode "OCaml" to base64' },
1741
+
{ code: 'Base64.decode_exn "T0NhbWw=";;', expect: '"OCaml"',
1742
+
description: 'Decode back to original' },
1743
+
] },
1744
+
{ title: 'Round-Trip',
1745
+
steps: [
1746
+
{ code: 'let test s = Base64.decode_exn (Base64.encode_string s) = s;;',
1747
+
expect: 'val test', description: 'Define a round-trip test function' },
1748
+
{ code: 'test "hello world";;', expect: 'true',
1749
+
description: 'Round-trip preserves data' },
1750
+
{ code: 'test "";;', expect: 'true',
1751
+
description: 'Empty string round-trips' },
1752
+
{ code: 'test "\\x00\\xff";;', expect: 'true',
1753
+
description: 'Binary data round-trips' },
1754
+
] },
1755
+
],
1756
+
},
1757
+
1758
+
'bos.0.2.1': {
1759
+
name: 'Bos', version: '0.2.1', opam: 'bos',
1760
+
description: 'Basic OS interaction for OCaml',
1761
+
universe: U['bos.0.2.1'], require: ['bos'],
1762
+
sections: [
1763
+
{ title: 'Command Construction',
1764
+
description: 'Bos.Cmd builds shell commands declaratively with type-safe combinators.',
1765
+
steps: [
1766
+
{ code: 'let cmd = Bos.Cmd.(v "echo" % "hello" % "world");;', expect: 'Bos.Cmd.t',
1767
+
description: 'Build: echo hello world' },
1768
+
{ code: 'Bos.Cmd.to_string cmd;;', expect: 'echo',
1769
+
description: 'Convert to shell string' },
1770
+
{ code: 'Bos.Cmd.to_list cmd;;', expect: '["echo"; "hello"; "world"]',
1771
+
description: 'Convert to argument list' },
1772
+
] },
1773
+
{ title: 'Command Combinators',
1774
+
description: 'Commands support appending, conditional inclusion, and inspection.',
1775
+
steps: [
1776
+
{ code: 'let base = Bos.Cmd.(v "gcc" % "-O2");;', expect: 'Bos.Cmd.t',
1777
+
description: 'Base compiler command' },
1778
+
{ code: 'let full = Bos.Cmd.(base % "-o" % "main" %% v "main.c");;', expect: 'Bos.Cmd.t',
1779
+
description: 'Append arguments and a sub-command' },
1780
+
{ code: 'Bos.Cmd.to_list full;;', expect: '["gcc"',
1781
+
description: 'Full argument list' },
1782
+
{ code: 'Bos.Cmd.line_tool full;;', expect: 'Some "gcc"',
1783
+
description: 'Extract the tool name' },
1784
+
{ code: 'Bos.Cmd.is_empty Bos.Cmd.empty;;', expect: 'true',
1785
+
description: 'Empty command check' },
1786
+
] },
1787
+
{ title: 'Conditional Arguments',
1788
+
description: 'Bos.Cmd.on conditionally includes arguments.',
1789
+
steps: [
1790
+
{ code: 'let debug = true;;', expect: 'true',
1791
+
description: 'A debug flag' },
1792
+
{ code: 'Bos.Cmd.(v "gcc" %% on debug (v "-g") % "main.c") |> Bos.Cmd.to_list;;',
1793
+
expect: '["gcc"; "-g"; "main.c"]', description: 'Debug flag is included when true' },
1794
+
{ code: 'Bos.Cmd.(v "gcc" %% on false (v "-g") % "main.c") |> Bos.Cmd.to_list;;',
1795
+
expect: '["gcc"; "main.c"]', description: 'Debug flag is omitted when false' },
1796
+
] },
1797
+
],
1798
+
},
1799
+
1800
+
// ═══════════════════════════════════════════════════════════════════════
1801
+
// Re (regular expressions)
1802
+
// ═══════════════════════════════════════════════════════════════════════
1803
+
're.1.10.4': {
1804
+
name: 'Re', version: '1.10.4', opam: 're',
1805
+
description: 'Regular expression library for OCaml',
1806
+
universe: U['re.1.10.4'], require: ['re'],
1807
+
sections: [
1808
+
{ title: 'Compiling and Matching',
1809
+
description: 'Re works in two steps: build a regex value, then compile it before matching.',
1810
+
steps: [
1811
+
{ code: 'let re = Re.Pcre.re "\\\\d+" |> Re.compile;;', expect: 'Re.re',
1812
+
description: 'Compile a PCRE-style regex for digits' },
1813
+
{ code: 'Re.execp re "abc123";;', expect: 'true',
1814
+
description: 'Test if the string matches anywhere' },
1815
+
{ code: 'Re.execp re "no digits";;', expect: 'false',
1816
+
description: 'No match returns false' },
1817
+
] },
1818
+
{ title: 'Extracting Matches',
1819
+
description: 'Re.exec returns a group object, and Re.Group.get extracts matched substrings.',
1820
+
steps: [
1821
+
{ code: 'let g = Re.exec re "abc123def";;', expect: 'Re.Group.t',
1822
+
description: 'Execute and get the match group' },
1823
+
{ code: 'Re.Group.get g 0;;', expect: '"123"',
1824
+
description: 'Group 0 is the whole match' },
1825
+
] },
1826
+
{ title: 'Finding All Matches',
1827
+
steps: [
1828
+
{ code: 'Re.all re "a1b22c333" |> List.map (fun g -> Re.Group.get g 0);;',
1829
+
expect: '["1"; "22"; "333"]', description: 'Find all digit sequences' },
1830
+
{ code: 'Re.split (Re.compile (Re.Pcre.re ",")) "a,b,c";;',
1831
+
expect: '["a"; "b"; "c"]', description: 'Split on comma' },
1832
+
] },
1833
+
],
1834
+
},
1835
+
1836
+
're.1.11.0': {
1837
+
name: 'Re', version: '1.11.0', opam: 're',
1838
+
description: 'Regular expression library for OCaml',
1839
+
universe: U['re.1.11.0'], require: ['re'],
1840
+
sections: [
1841
+
{ title: 'PCRE Syntax',
1842
+
steps: [
1843
+
{ code: 'let word = Re.Pcre.re "[a-zA-Z]+" |> Re.compile;;', expect: 'Re.re',
1844
+
description: 'Compile a word pattern' },
1845
+
{ code: 'Re.all word "hello world" |> List.map (fun g -> Re.Group.get g 0);;',
1846
+
expect: '["hello"; "world"]', description: 'Find all words' },
1847
+
] },
1848
+
{ title: 'Replacement',
1849
+
steps: [
1850
+
{ code: 'Re.replace_string (Re.compile (Re.Pcre.re "\\\\d+")) ~by:"N" "abc123def456";;',
1851
+
expect: '"abcNdefN"', description: 'Replace all digit sequences' },
1852
+
] },
1853
+
{ title: 'Combinatorial API',
1854
+
description: 'Re also has a combinator API for building regexes without string syntax.',
1855
+
steps: [
1856
+
{ code: 'let re = Re.(seq [bos; rep1 digit; eos]) |> Re.compile;;', expect: 'Re.re',
1857
+
description: 'Match strings that are all digits' },
1858
+
{ code: 'Re.execp re "12345";;', expect: 'true',
1859
+
description: 'All digits matches' },
1860
+
{ code: 'Re.execp re "123abc";;', expect: 'false',
1861
+
description: 'Mixed string does not match' },
1862
+
] },
1863
+
],
1864
+
},
1865
+
1866
+
're.1.12.0': {
1867
+
name: 'Re', version: '1.12.0', opam: 're',
1868
+
description: 'Regular expression library for OCaml',
1869
+
universe: U['re.1.12.0'], require: ['re'],
1870
+
sections: [
1871
+
{ title: 'Pattern Matching',
1872
+
steps: [
1873
+
{ code: 'let email_re = Re.Pcre.re "[^@]+@[^@]+" |> Re.compile;;', expect: 'Re.re',
1874
+
description: 'Simple email pattern' },
1875
+
{ code: 'Re.execp email_re "user@example.com";;', expect: 'true',
1876
+
description: 'Matches an email-like string' },
1877
+
{ code: 'Re.execp email_re "not-an-email";;', expect: 'false',
1878
+
description: 'No @ sign means no match' },
1879
+
] },
1880
+
{ title: 'Groups',
1881
+
description: 'Capture groups extract sub-matches.',
1882
+
steps: [
1883
+
{ code: 'let kv = Re.Pcre.re "(\\\\w+)=(\\\\w+)" |> Re.compile;;', expect: 'Re.re',
1884
+
description: 'Key=value pattern with groups' },
1885
+
{ code: 'let g = Re.exec kv "name=Alice";;', expect: 'Re.Group.t',
1886
+
description: 'Execute the match' },
1887
+
{ code: 'Re.Group.get g 1;;', expect: '"name"',
1888
+
description: 'Group 1: the key' },
1889
+
{ code: 'Re.Group.get g 2;;', expect: '"Alice"',
1890
+
description: 'Group 2: the value' },
1891
+
] },
1892
+
],
1893
+
},
1894
+
1895
+
're.1.13.2': {
1896
+
name: 'Re', version: '1.13.2', opam: 're',
1897
+
description: 'Regular expression library for OCaml',
1898
+
universe: U['re.1.13.2'], require: ['re'],
1899
+
sections: [
1900
+
{ title: 'Splitting and Replacing',
1901
+
steps: [
1902
+
{ code: 'Re.split (Re.compile (Re.Pcre.re "\\\\s+")) "hello world foo";;',
1903
+
expect: '["hello"; "world"; "foo"]', description: 'Split on whitespace' },
1904
+
{ code: 'Re.replace_string (Re.compile (Re.Pcre.re "[aeiou]")) ~by:"*" "hello";;',
1905
+
expect: '"h*ll*"', description: 'Replace vowels' },
1906
+
] },
1907
+
{ title: 'Posix Character Classes',
1908
+
steps: [
1909
+
{ code: 'let re = Re.(rep1 alpha |> compile);;', expect: 'Re.re',
1910
+
description: 'Match alphabetic characters' },
1911
+
{ code: 'Re.execp re "hello";;', expect: 'true',
1912
+
description: 'All alpha matches' },
1913
+
{ code: 'Re.all re "abc123def" |> List.map (fun g -> Re.Group.get g 0);;',
1914
+
expect: '["abc"; "def"]', description: 'Find all alphabetic runs' },
1915
+
] },
1916
+
],
1917
+
},
1918
+
1919
+
're.1.14.0': {
1920
+
name: 'Re', version: '1.14.0', opam: 're',
1921
+
description: 'Regular expression library for OCaml',
1922
+
universe: U['re.1.14.0'], require: ['re'],
1923
+
sections: [
1924
+
{ title: 'Combinatorial API',
1925
+
steps: [
1926
+
{ code: 'let hex = Re.(alt [rg \'0\' \'9\'; rg \'a\' \'f\'; rg \'A\' \'F\']) |> Re.rep1 |> Re.compile;;',
1927
+
expect: 'Re.re', description: 'Match hex strings' },
1928
+
{ code: 'Re.execp hex "deadBEEF";;', expect: 'true',
1929
+
description: 'Valid hex matches' },
1930
+
{ code: 'Re.all hex "ff0099" |> List.map (fun g -> Re.Group.get g 0);;',
1931
+
expect: '["ff0099"]', description: 'Extract hex values' },
1932
+
] },
1933
+
{ title: 'Capture Groups',
1934
+
steps: [
1935
+
{ code: 'let re = Re.Pcre.re "(\\\\d{4})-(\\\\d{2})" |> Re.compile;;',
1936
+
expect: 'Re.re', description: 'Date pattern with capture groups' },
1937
+
{ code: 'let g = Re.exec re "date: 2024-01";;', expect: 'Re.Group.t',
1938
+
description: 'Execute match' },
1939
+
{ code: 'Re.Group.get g 1;;', expect: '"2024"',
1940
+
description: 'First capture group (year)' },
1941
+
{ code: 'Re.Group.get g 2;;', expect: '"01"',
1942
+
description: 'Second capture group (month)' },
1943
+
] },
1944
+
],
1945
+
},
1946
+
1947
+
// ═══════════════════════════════════════════════════════════════════════
1948
+
// Angstrom
1949
+
// ═══════════════════════════════════════════════════════════════════════
1950
+
'angstrom.0.15.0': {
1951
+
name: 'Angstrom', version: '0.15.0', opam: 'angstrom',
1952
+
description: 'Parser combinators for OCaml',
1953
+
universe: U['angstrom.0.15.0'], require: ['angstrom'],
1954
+
sections: [
1955
+
{ title: 'Basic Parsers',
1956
+
description: 'Angstrom provides primitive parsers and combinators for building complex parsers.',
1957
+
steps: [
1958
+
{ code: 'Angstrom.parse_string ~consume:Prefix (Angstrom.string "hello") "hello world";;',
1959
+
expect: 'Ok "hello"', description: 'Match a literal string' },
1960
+
{ code: 'Angstrom.parse_string ~consume:All (Angstrom.string "hello") "hello";;',
1961
+
expect: 'Ok "hello"', description: 'Consume:All requires full input match' },
1962
+
{ code: 'Angstrom.parse_string ~consume:All (Angstrom.string "hello") "hello world";;',
1963
+
expect: 'Error', description: 'Consume:All fails with leftover input' },
1964
+
] },
1965
+
{ title: 'Character Parsers',
1966
+
steps: [
1967
+
{ code: 'let digits = Angstrom.take_while1 (function \'0\'..\'9\' -> true | _ -> false);;',
1968
+
expect: 'Angstrom.t', description: 'Parser for one or more digits' },
1969
+
{ code: 'Angstrom.parse_string ~consume:Prefix digits "123abc";;',
1970
+
expect: 'Ok "123"', description: 'Consume digits, stop at letters' },
1971
+
] },
1972
+
{ title: 'Combinators',
1973
+
description: 'Combine parsers with sep_by, many, choice, and operators.',
1974
+
steps: [
1975
+
{ code: 'let word = Angstrom.take_while1 (function \'a\'..\'z\' | \'A\'..\'Z\' -> true | _ -> false);;',
1976
+
expect: 'Angstrom.t', description: 'Parser for words' },
1977
+
{ code: 'let csv = Angstrom.sep_by (Angstrom.char \',\') word;;', expect: 'Angstrom.t',
1978
+
description: 'Comma-separated words parser' },
1979
+
{ code: 'Angstrom.parse_string ~consume:All csv "foo,bar,baz";;',
1980
+
expect: 'Ok ["foo"; "bar"; "baz"]', description: 'Parse CSV into a list' },
1981
+
{ code: 'Angstrom.parse_string ~consume:Prefix (Angstrom.many (Angstrom.char \'a\')) "aaab";;',
1982
+
expect: 'Ok', description: 'many matches zero or more' },
1983
+
] },
1984
+
],
1985
+
},
1986
+
1987
+
'angstrom.0.16.1': {
1988
+
name: 'Angstrom', version: '0.16.1', opam: 'angstrom',
1989
+
description: 'Parser combinators for OCaml',
1990
+
universe: U['angstrom.0.16.1'], require: ['angstrom'],
1991
+
sections: [
1992
+
{ title: 'Parsing Structured Data',
1993
+
steps: [
1994
+
{ code: 'let is_digit c = c >= \'0\' && c <= \'9\';;', expect: 'val is_digit',
1995
+
description: 'Helper: digit predicate' },
1996
+
{ code: 'let integer = Angstrom.(take_while1 is_digit >>| int_of_string);;',
1997
+
expect: 'Angstrom.t', description: 'Integer parser using >>| (map)' },
1998
+
{ code: 'Angstrom.parse_string ~consume:Prefix integer "42rest";;',
1999
+
expect: 'Ok 42', description: 'Parse and convert to int' },
2000
+
] },
2001
+
{ title: 'Sequencing and Alternatives',
2002
+
description: 'Use *> to discard left, <* to discard right, <|> for alternatives.',
2003
+
steps: [
2004
+
{ code: 'let bool_p = Angstrom.((string "true" >>| fun _ -> true) <|> (string "false" >>| fun _ -> false));;',
2005
+
expect: 'Angstrom.t', description: 'Boolean parser with alternatives' },
2006
+
{ code: 'Angstrom.parse_string ~consume:All bool_p "true";;',
2007
+
expect: 'Ok true', description: 'Parse "true"' },
2008
+
{ code: 'Angstrom.parse_string ~consume:All bool_p "false";;',
2009
+
expect: 'Ok false', description: 'Parse "false"' },
2010
+
] },
2011
+
],
2012
+
},
2013
+
2014
+
// ═══════════════════════════════════════════════════════════════════════
2015
+
// Tyre
2016
+
// ═══════════════════════════════════════════════════════════════════════
2017
+
'tyre.0.5': {
2018
+
name: 'Tyre', version: '0.5', opam: 'tyre',
2019
+
description: 'Typed regular expressions for OCaml',
2020
+
universe: U['tyre.0.5'], require: ['tyre'],
2021
+
sections: [
2022
+
{ title: 'Basic Typed Matching',
2023
+
description: 'Tyre combines regex matching with type extraction.',
2024
+
steps: [
2025
+
{ code: 'let re = Tyre.compile Tyre.int;;', expect: 'Tyre.re',
2026
+
description: 'Compile a typed regex for integers' },
2027
+
{ code: 'Tyre.exec re "42";;', expect: 'Ok 42',
2028
+
description: 'Match and extract an int' },
2029
+
{ code: 'Tyre.exec re "abc";;', expect: 'Error',
2030
+
description: 'Non-matching input returns Error' },
2031
+
] },
2032
+
{ title: 'Combining Patterns',
2033
+
description: 'Use <&> to sequence patterns (returns tuples) and *> or <* to discard parts.',
2034
+
steps: [
2035
+
{ code: 'let re = Tyre.compile Tyre.(str "v" *> int);;', expect: 'Tyre.re',
2036
+
description: 'Match "v" prefix then extract an int' },
2037
+
{ code: 'Tyre.exec re "v42";;', expect: 'Ok 42',
2038
+
description: 'Extract version number' },
2039
+
{ code: 'let dim = Tyre.compile Tyre.(int <&> str "x" *> int);;', expect: 'Tyre.re',
2040
+
description: 'Match WxH dimension pattern' },
2041
+
{ code: 'Tyre.exec dim "800x600";;', expect: 'Ok (800, 600)',
2042
+
description: 'Extract both dimensions as a tuple' },
2043
+
] },
2044
+
],
2045
+
},
2046
+
2047
+
'tyre.1.0': {
2048
+
name: 'Tyre', version: '1.0', opam: 'tyre',
2049
+
description: 'Typed regular expressions for OCaml',
2050
+
universe: U['tyre.1.0'], require: ['tyre'],
2051
+
sections: [
2052
+
{ title: 'Typed Extraction',
2053
+
steps: [
2054
+
{ code: 'Tyre.exec (Tyre.compile Tyre.int) "123";;', expect: 'Ok 123',
2055
+
description: 'Extract an integer' },
2056
+
{ code: 'Tyre.exec (Tyre.compile Tyre.float) "3.14";;', expect: 'Ok 3.14',
2057
+
description: 'Extract a float' },
2058
+
{ code: 'Tyre.exec (Tyre.compile Tyre.bool) "true";;', expect: 'Ok true',
2059
+
description: 'Extract a boolean' },
2060
+
] },
2061
+
{ title: 'Optional and Repeated',
2062
+
steps: [
2063
+
{ code: 'let re = Tyre.compile Tyre.(opt int);;', expect: 'Tyre.re',
2064
+
description: 'Optional integer pattern' },
2065
+
{ code: 'Tyre.exec re "42";;', expect: 'Ok (Some 42)',
2066
+
description: 'Present value gives Some' },
2067
+
{ code: 'Tyre.exec re "";;', expect: 'Ok None',
2068
+
description: 'Empty input gives None' },
2069
+
] },
2070
+
{ title: 'Bidirectional: Eval',
2071
+
description: 'Tyre.eval converts values back to strings (unparse).',
2072
+
steps: [
2073
+
{ code: 'Tyre.eval Tyre.int 42;;', expect: '"42"',
2074
+
description: 'Unparse an integer' },
2075
+
{ code: 'Tyre.eval Tyre.(str "v" *> int) 3;;', expect: '"v3"',
2076
+
description: 'Unparse with literal prefix' },
2077
+
] },
2078
+
],
2079
+
},
2080
+
2081
+
// ═══════════════════════════════════════════════════════════════════════
2082
+
// Uuseg
2083
+
// ═══════════════════════════════════════════════════════════════════════
2084
+
'uuseg.14.0.0': {
2085
+
name: 'Uuseg', version: '14.0.0', opam: 'uuseg',
2086
+
description: 'Unicode text segmentation (Unicode 14.0.0)',
2087
+
universe: U['uuseg.14.0.0'], require: ['uuseg'],
2088
+
sections: [
2089
+
{ title: 'Unicode Version',
2090
+
steps: [
2091
+
{ code: 'Uuseg.unicode_version;;', expect: '"14.0.0"',
2092
+
description: 'Check the Unicode version' },
2093
+
] },
2094
+
{ title: 'Segmenter Creation',
2095
+
description: 'Uuseg.create makes a segmenter for grapheme clusters, words, or sentences.',
2096
+
steps: [
2097
+
{ code: 'let seg = Uuseg.create `Grapheme_cluster;;', expect: 'Uuseg.t',
2098
+
description: 'Create a grapheme cluster segmenter' },
2099
+
{ code: 'let wseg = Uuseg.create `Word;;', expect: 'Uuseg.t',
2100
+
description: 'Create a word segmenter' },
2101
+
] },
2102
+
],
2103
+
},
2104
+
2105
+
'uuseg.15.0.0': {
2106
+
name: 'Uuseg', version: '15.0.0', opam: 'uuseg',
2107
+
description: 'Unicode text segmentation (Unicode 15.0.0)',
2108
+
universe: U['uuseg.15.0.0'], require: ['uuseg'],
2109
+
sections: [
2110
+
{ title: 'Unicode Version',
2111
+
steps: [
2112
+
{ code: 'Uuseg.unicode_version;;', expect: '"15.0.0"',
2113
+
description: 'Check the Unicode version' },
2114
+
] },
2115
+
{ title: 'Segmenter Types',
2116
+
steps: [
2117
+
{ code: 'let _ = Uuseg.create `Grapheme_cluster;;', expect: 'Uuseg.t',
2118
+
description: 'Grapheme cluster segmentation' },
2119
+
{ code: 'let _ = Uuseg.create `Word;;', expect: 'Uuseg.t',
2120
+
description: 'Word segmentation' },
2121
+
{ code: 'let _ = Uuseg.create `Sentence;;', expect: 'Uuseg.t',
2122
+
description: 'Sentence segmentation' },
2123
+
{ code: 'let _ = Uuseg.create `Line_break;;', expect: 'Uuseg.t',
2124
+
description: 'Line break opportunity segmentation' },
2125
+
] },
2126
+
],
2127
+
},
2128
+
2129
+
'uuseg.16.0.0': {
2130
+
name: 'Uuseg', version: '16.0.0', opam: 'uuseg',
2131
+
description: 'Unicode text segmentation (Unicode 16.0.0)',
2132
+
universe: U['uuseg.16.0.0'], require: ['uuseg'],
2133
+
sections: [
2134
+
{ title: 'Unicode Version',
2135
+
steps: [
2136
+
{ code: 'Uuseg.unicode_version;;', expect: '"16.0.0"',
2137
+
description: 'Check the Unicode version' },
2138
+
] },
2139
+
{ title: 'Segmenter API',
2140
+
description: 'Feed Uchars to a segmenter and it reports segment boundaries.',
2141
+
steps: [
2142
+
{ code: 'let seg = Uuseg.create `Grapheme_cluster;;', expect: 'Uuseg.t',
2143
+
description: 'Create a grapheme cluster segmenter' },
2144
+
{ code: 'Uuseg.add seg (`Uchar (Uchar.of_int 0x0041));;', expect: '',
2145
+
description: "Add 'A' to the segmenter" },
2146
+
{ code: 'Uuseg.add seg `End;;', expect: '',
2147
+
description: 'Signal end of input' },
2148
+
] },
2149
+
],
2150
+
},
2151
+
2152
+
'uuseg.17.0.0': {
2153
+
name: 'Uuseg', version: '17.0.0', opam: 'uuseg',
2154
+
description: 'Unicode text segmentation (Unicode 17.0.0)',
2155
+
universe: U['uuseg.17.0.0'], require: ['uuseg'],
2156
+
sections: [
2157
+
{ title: 'Unicode Version',
2158
+
steps: [
2159
+
{ code: 'Uuseg.unicode_version;;', expect: '"17.0.0"',
2160
+
description: 'Check the Unicode version' },
2161
+
] },
2162
+
{ title: 'Segmenter Types',
2163
+
steps: [
2164
+
{ code: 'let _ = Uuseg.create `Grapheme_cluster;;', expect: 'Uuseg.t',
2165
+
description: 'Grapheme cluster boundaries' },
2166
+
{ code: 'let _ = Uuseg.create `Word;;', expect: 'Uuseg.t',
2167
+
description: 'Word boundaries' },
2168
+
{ code: 'let _ = Uuseg.create `Sentence;;', expect: 'Uuseg.t',
2169
+
description: 'Sentence boundaries' },
2170
+
] },
2171
+
],
2172
+
},
2173
+
2174
+
// ═══════════════════════════════════════════════════════════════════════
2175
+
// Containers
2176
+
// ═══════════════════════════════════════════════════════════════════════
2177
+
'containers.3.17': {
2178
+
name: 'Containers', version: '3.17', opam: 'containers',
2179
+
description: 'A modular extension of the OCaml standard library',
2180
+
universe: U['containers.3.17'], require: ['containers'],
2181
+
sections: [
2182
+
{ title: 'CCList Advanced',
2183
+
steps: [
2184
+
{ code: 'CCList.product (fun a b -> (a, b)) [1; 2] ["a"; "b"];;',
2185
+
expect: '[(1, "a")', description: 'Cartesian product' },
2186
+
{ code: 'CCList.pure 42;;', expect: '[42]',
2187
+
description: 'Wrap a value in a singleton list' },
2188
+
] },
2189
+
{ title: 'CCString',
2190
+
steps: [
2191
+
{ code: 'CCString.take 5 "hello world";;', expect: '"hello"',
2192
+
description: 'Take first 5 characters' },
2193
+
{ code: 'CCString.drop 6 "hello world";;', expect: '"world"',
2194
+
description: 'Drop first 6 characters' },
2195
+
{ code: 'CCString.chop_prefix ~pre:"http://" "http://example.com";;',
2196
+
expect: 'Some "example.com"', description: 'Remove prefix if present' },
2197
+
{ code: 'CCString.chop_suffix ~suf:".ml" "main.ml";;',
2198
+
expect: 'Some "main"', description: 'Remove suffix if present' },
2199
+
] },
2200
+
],
2201
+
},
2202
+
2203
+
// ═══════════════════════════════════════════════════════════════════════
2204
+
// Iter
2205
+
// ═══════════════════════════════════════════════════════════════════════
2206
+
'iter.1.7': {
2207
+
name: 'Iter', version: '1.7', opam: 'iter',
2208
+
description: 'Simple, efficient iterators for OCaml',
2209
+
universe: U['iter.1.7'], require: ['iter'],
2210
+
sections: [
2211
+
{ title: 'Creating Iterators',
2212
+
description: 'Iter.t is (\'a -> unit) -> unit — a continuation-based iterator.',
2213
+
steps: [
2214
+
{ code: 'Iter.of_list [1; 2; 3] |> Iter.to_list;;', expect: '[1; 2; 3]',
2215
+
description: 'Round-trip through Iter' },
2216
+
{ code: 'Iter.(1 -- 5) |> Iter.to_list;;', expect: '[1; 2; 3; 4; 5]',
2217
+
description: 'Integer range (inclusive)' },
2218
+
{ code: 'Iter.init (fun i -> i * i) |> Iter.take 5 |> Iter.to_list;;',
2219
+
expect: '[0; 1; 4; 9; 16]', description: 'Infinite sequence, take first 5' },
2220
+
] },
2221
+
{ title: 'Transformations',
2222
+
steps: [
2223
+
{ code: 'Iter.(1 -- 10) |> Iter.filter (fun x -> x mod 2 = 0) |> Iter.to_list;;',
2224
+
expect: '[2; 4; 6; 8; 10]', description: 'Filter even numbers' },
2225
+
{ code: 'Iter.(1 -- 5) |> Iter.map (fun x -> x * 2) |> Iter.to_list;;',
2226
+
expect: '[2; 4; 6; 8; 10]', description: 'Map doubling' },
2227
+
{ code: 'Iter.(1 -- 5) |> Iter.fold (+) 0;;', expect: '15',
2228
+
description: 'Fold to compute sum' },
2229
+
] },
2230
+
],
2231
+
},
2232
+
2233
+
'iter.1.8': {
2234
+
name: 'Iter', version: '1.8', opam: 'iter',
2235
+
description: 'Simple, efficient iterators for OCaml',
2236
+
universe: U['iter.1.8'], require: ['iter'],
2237
+
sections: [
2238
+
{ title: 'Iterator Basics',
2239
+
steps: [
2240
+
{ code: 'Iter.empty |> Iter.to_list;;', expect: '[]',
2241
+
description: 'Empty iterator' },
2242
+
{ code: 'Iter.singleton 42 |> Iter.to_list;;', expect: '[42]',
2243
+
description: 'Single-element iterator' },
2244
+
{ code: 'Iter.repeat 3 |> Iter.take 4 |> Iter.to_list;;', expect: '[3; 3; 3; 3]',
2245
+
description: 'Infinite repetition, take 4' },
2246
+
] },
2247
+
{ title: 'Flat Map and Product',
2248
+
steps: [
2249
+
{ code: 'Iter.(1 -- 3) |> Iter.flat_map (fun x -> Iter.of_list [x; x*10]) |> Iter.to_list;;',
2250
+
expect: '[1; 10; 2; 20; 3; 30]', description: 'Flat map' },
2251
+
{ code: 'Iter.product (Iter.of_list [1;2]) (Iter.of_list ["a";"b"]) |> Iter.to_list;;',
2252
+
expect: '[(1, "a")', description: 'Cartesian product' },
2253
+
] },
2254
+
],
2255
+
},
2256
+
2257
+
'iter.1.9': {
2258
+
name: 'Iter', version: '1.9', opam: 'iter',
2259
+
description: 'Simple, efficient iterators for OCaml',
2260
+
universe: U['iter.1.9'], require: ['iter'],
2261
+
sections: [
2262
+
{ title: 'Aggregation',
2263
+
steps: [
2264
+
{ code: 'Iter.(1 -- 100) |> Iter.fold (+) 0;;', expect: '5050',
2265
+
description: 'Sum 1 to 100' },
2266
+
{ code: 'Iter.(1 -- 10) |> Iter.length;;', expect: '10',
2267
+
description: 'Count elements' },
2268
+
{ code: 'Iter.of_list ["hello"; "world"] |> Iter.for_all (fun s -> String.length s > 3);;',
2269
+
expect: 'true', description: 'Check a predicate for all elements' },
2270
+
{ code: 'Iter.of_list [1; 2; 3] |> Iter.exists (fun x -> x > 2);;',
2271
+
expect: 'true', description: 'Check if any element matches' },
2272
+
] },
2273
+
{ title: 'Conversion',
2274
+
steps: [
2275
+
{ code: 'Iter.of_list [1; 2; 3] |> Iter.to_rev_list;;', expect: '[3; 2; 1]',
2276
+
description: 'Convert to reversed list' },
2277
+
{ code: 'Iter.of_list [("a",1); ("b",2)] |> Iter.to_hashtbl;;', expect: 'Hashtbl',
2278
+
description: 'Convert to hashtable' },
2279
+
] },
2280
+
],
2281
+
},
2282
+
2283
+
// ═══════════════════════════════════════════════════════════════════════
2284
+
// OCamlgraph
2285
+
// ═══════════════════════════════════════════════════════════════════════
2286
+
'ocamlgraph.2.0.0': {
2287
+
name: 'OCamlgraph', version: '2.0.0', opam: 'ocamlgraph',
2288
+
description: 'Graph library for OCaml',
2289
+
universe: U['ocamlgraph.2.0.0'], require: ['ocamlgraph'],
2290
+
sections: [
2291
+
{ title: 'Building Graphs',
2292
+
description: 'Graph.Pack.Digraph provides an easy-to-use imperative directed graph. Vertices must be reused (not re-created).',
2293
+
steps: [
2294
+
{ code: 'let module G = Graph.Pack.Digraph in let g = G.create () in let v1 = G.V.create 1 in let v2 = G.V.create 2 in let v3 = G.V.create 3 in G.add_edge g v1 v2; G.add_edge g v2 v3; G.nb_vertex g;;',
2295
+
expect: '3', description: 'Create a graph with 3 vertices' },
2296
+
{ code: 'let module G = Graph.Pack.Digraph in let g = G.create () in let v1 = G.V.create 1 in let v2 = G.V.create 2 in let v3 = G.V.create 3 in G.add_edge g v1 v2; G.add_edge g v1 v3; G.nb_edges g;;',
2297
+
expect: '2', description: '2 edges from vertex 1' },
2298
+
] },
2299
+
],
2300
+
},
2301
+
2302
+
'ocamlgraph.2.1.0': {
2303
+
name: 'OCamlgraph', version: '2.1.0', opam: 'ocamlgraph',
2304
+
description: 'Graph library for OCaml',
2305
+
universe: U['ocamlgraph.2.1.0'], require: ['ocamlgraph'],
2306
+
sections: [
2307
+
{ title: 'Imperative Graphs',
2308
+
steps: [
2309
+
{ code: 'let module G = Graph.Pack.Digraph in let g = G.create () in let v1 = G.V.create 10 in let v2 = G.V.create 20 in G.add_edge g v1 v2; G.mem_edge g v1 v2;;',
2310
+
expect: 'true', description: 'Check edge existence' },
2311
+
{ code: 'let module G = Graph.Pack.Digraph in let g = G.create () in G.add_edge g (G.V.create 1) (G.V.create 2); G.add_edge g (G.V.create 2) (G.V.create 3); G.add_edge g (G.V.create 3) (G.V.create 1); G.nb_edges g;;',
2312
+
expect: '3', description: 'A cycle with 3 edges' },
2313
+
] },
2314
+
],
2315
+
},
2316
+
2317
+
'ocamlgraph.2.2.0': {
2318
+
name: 'OCamlgraph', version: '2.2.0', opam: 'ocamlgraph',
2319
+
description: 'Graph library for OCaml',
2320
+
universe: U['ocamlgraph.2.2.0'], require: ['ocamlgraph'],
2321
+
sections: [
2322
+
{ title: 'Graph Operations',
2323
+
steps: [
2324
+
{ code: 'let module G = Graph.Pack.Digraph in let g = G.create () in let vs = Array.init 6 G.V.create in for i = 0 to 4 do G.add_edge g vs.(i) vs.(i+1) done; G.nb_vertex g;;',
2325
+
expect: '6', description: 'A chain of 6 vertices' },
2326
+
{ code: 'let module G = Graph.Pack.Digraph in let g = G.create () in let vs = Array.init 6 G.V.create in for i = 0 to 4 do G.add_edge g vs.(i) vs.(i+1) done; G.nb_edges g;;',
2327
+
expect: '5', description: '5 edges in the chain' },
2328
+
{ code: 'let module G = Graph.Pack.Digraph in let g = G.create () in let v0 = G.V.create 0 in let v1 = G.V.create 1 in let v2 = G.V.create 2 in G.add_edge g v0 v1; G.add_edge g v0 v2; G.out_degree g v0;;',
2329
+
expect: '2', description: 'Out-degree of vertex 0' },
2330
+
] },
2331
+
],
2332
+
},
2333
+
2334
+
// ═══════════════════════════════════════════════════════════════════════
2335
+
// Digestif
2336
+
// ═══════════════════════════════════════════════════════════════════════
2337
+
'digestif.1.1.2': {
2338
+
name: 'Digestif', version: '1.1.2', opam: 'digestif',
2339
+
description: 'Cryptographic hash functions for OCaml',
2340
+
universe: U['digestif.1.1.2'], require: ['digestif'],
2341
+
sections: [
2342
+
{ title: 'SHA-256',
2343
+
description: 'Digestif.SHA256 provides SHA-256 hashing with hex encoding.',
2344
+
steps: [
2345
+
{ code: 'Digestif.SHA256.digest_string "hello" |> Digestif.SHA256.to_hex;;',
2346
+
expect: '2cf24dba', description: 'SHA-256 of "hello"' },
2347
+
{ code: 'Digestif.SHA256.digest_string "" |> Digestif.SHA256.to_hex;;',
2348
+
expect: 'e3b0c442', description: 'SHA-256 of empty string' },
2349
+
{ code: 'let h1 = Digestif.SHA256.digest_string "test" in let h2 = Digestif.SHA256.digest_string "test" in Digestif.SHA256.equal h1 h2;;',
2350
+
expect: 'true', description: 'Same input produces same hash (constant-time equal)' },
2351
+
] },
2352
+
{ title: 'MD5',
2353
+
steps: [
2354
+
{ code: 'Digestif.MD5.digest_string "hello" |> Digestif.MD5.to_hex;;',
2355
+
expect: '5d41402a', description: 'MD5 of "hello"' },
2356
+
] },
2357
+
],
2358
+
},
2359
+
2360
+
'digestif.1.3.0': {
2361
+
name: 'Digestif', version: '1.3.0', opam: 'digestif',
2362
+
description: 'Cryptographic hash functions for OCaml',
2363
+
universe: U['digestif.1.3.0'], require: ['digestif'],
2364
+
sections: [
2365
+
{ title: 'Multiple Algorithms',
2366
+
steps: [
2367
+
{ code: 'Digestif.SHA256.digest_string "OCaml" |> Digestif.SHA256.to_hex;;',
2368
+
expect: 'string', description: 'SHA-256 hash' },
2369
+
{ code: 'Digestif.SHA512.digest_string "OCaml" |> Digestif.SHA512.to_hex;;',
2370
+
expect: 'string', description: 'SHA-512 hash' },
2371
+
{ code: 'Digestif.SHA1.digest_string "OCaml" |> Digestif.SHA1.to_hex;;',
2372
+
expect: 'string', description: 'SHA-1 hash' },
2373
+
] },
2374
+
{ title: 'HMAC',
2375
+
description: 'HMAC provides keyed hashing for authentication.',
2376
+
steps: [
2377
+
{ code: 'Digestif.SHA256.hmac_string ~key:"secret" "message" |> Digestif.SHA256.to_hex;;',
2378
+
expect: 'string', description: 'HMAC-SHA256 with a key' },
2379
+
{ code: 'let h1 = Digestif.SHA256.hmac_string ~key:"k" "m" in let h2 = Digestif.SHA256.hmac_string ~key:"k" "m" in Digestif.SHA256.equal h1 h2;;',
2380
+
expect: 'true', description: 'Same key+message = same HMAC' },
2381
+
] },
2382
+
],
2383
+
},
2384
+
2385
+
// ═══════════════════════════════════════════════════════════════════════
2386
+
// Hex
2387
+
// ═══════════════════════════════════════════════════════════════════════
2388
+
'hex.1.4.0': {
2389
+
name: 'Hex', version: '1.4.0', opam: 'hex',
2390
+
description: 'Hex encoding and decoding for OCaml',
2391
+
universe: U['hex.1.4.0'], require: ['hex'],
2392
+
sections: [
2393
+
{ title: 'Encoding and Decoding',
2394
+
steps: [
2395
+
{ code: 'Hex.of_string "Hello";;', expect: '`Hex',
2396
+
description: 'Encode string to hex' },
2397
+
{ code: 'Hex.to_string (`Hex "48656c6c6f");;', expect: '"Hello"',
2398
+
description: 'Decode hex to string' },
2399
+
{ code: 'Hex.hexdump_s (Hex.of_string "Hello, World!");;', expect: '4865',
2400
+
description: 'Hexdump for debugging' },
2401
+
] },
2402
+
],
2403
+
},
2404
+
2405
+
'hex.1.5.0': {
2406
+
name: 'Hex', version: '1.5.0', opam: 'hex',
2407
+
description: 'Hex encoding and decoding for OCaml',
2408
+
universe: U['hex.1.5.0'], require: ['hex'],
2409
+
sections: [
2410
+
{ title: 'Hex Encoding',
2411
+
steps: [
2412
+
{ code: 'Hex.of_string "\\x00\\xff";;', expect: '`Hex "00ff"',
2413
+
description: 'Binary data to hex' },
2414
+
{ code: 'Hex.to_string (`Hex "00ff");;', expect: 'string',
2415
+
description: 'Hex back to binary' },
2416
+
{ code: 'Hex.show (Hex.of_string "AB");;', expect: '"4142"',
2417
+
description: 'Show hex representation' },
2418
+
] },
2419
+
],
2420
+
},
2421
+
2422
+
// ═══════════════════════════════════════════════════════════════════════
2423
+
// Eqaf
2424
+
// ═══════════════════════════════════════════════════════════════════════
2425
+
'eqaf.0.9': {
2426
+
name: 'Eqaf', version: '0.9', opam: 'eqaf',
2427
+
description: 'Constant-time string comparison for OCaml',
2428
+
universe: U['eqaf.0.9'], require: ['eqaf'],
2429
+
sections: [
2430
+
{ title: 'Constant-Time Comparison',
2431
+
description: 'Eqaf.equal compares strings in constant time, preventing timing attacks.',
2432
+
steps: [
2433
+
{ code: 'Eqaf.equal "secret" "secret";;', expect: 'true',
2434
+
description: 'Equal strings' },
2435
+
{ code: 'Eqaf.equal "secret" "wrong!";;', expect: 'false',
2436
+
description: 'Different strings' },
2437
+
{ code: 'Eqaf.equal "" "";;', expect: 'true',
2438
+
description: 'Empty strings are equal' },
2439
+
] },
2440
+
],
2441
+
},
2442
+
2443
+
'eqaf.0.10': {
2444
+
name: 'Eqaf', version: '0.10', opam: 'eqaf',
2445
+
description: 'Constant-time string comparison for OCaml',
2446
+
universe: U['eqaf.0.10'], require: ['eqaf'],
2447
+
sections: [
2448
+
{ title: 'Constant-Time Operations',
2449
+
steps: [
2450
+
{ code: 'Eqaf.equal "abc" "abc";;', expect: 'true',
2451
+
description: 'Same strings (constant time)' },
2452
+
{ code: 'Eqaf.equal "abc" "xyz";;', expect: 'false',
2453
+
description: 'Different strings (same timing as equal case)' },
2454
+
{ code: 'Eqaf.compare_be "a" "b";;', expect: '-1',
2455
+
description: 'Constant-time big-endian comparison' },
2456
+
] },
2457
+
],
2458
+
},
2459
+
2460
+
// ═══════════════════════════════════════════════════════════════════════
2461
+
// Uri
2462
+
// ═══════════════════════════════════════════════════════════════════════
2463
+
'uri.4.2.0': {
2464
+
name: 'Uri', version: '4.2.0', opam: 'uri',
2465
+
description: 'URI parsing and manipulation for OCaml',
2466
+
universe: U['uri.4.2.0'], require: ['uri'],
2467
+
sections: [
2468
+
{ title: 'Parsing URIs',
2469
+
steps: [
2470
+
{ code: 'let u = Uri.of_string "https://example.com:8080/path?q=1#frag";;', expect: 'Uri.t',
2471
+
description: 'Parse a full URI' },
2472
+
{ code: 'Uri.scheme u;;', expect: 'Some "https"',
2473
+
description: 'Extract the scheme' },
2474
+
{ code: 'Uri.host u;;', expect: 'Some "example.com"',
2475
+
description: 'Extract the host' },
2476
+
{ code: 'Uri.port u;;', expect: 'Some 8080',
2477
+
description: 'Extract the port' },
2478
+
{ code: 'Uri.path u;;', expect: '"/path"',
2479
+
description: 'Extract the path' },
2480
+
{ code: 'Uri.fragment u;;', expect: 'Some "frag"',
2481
+
description: 'Extract the fragment' },
2482
+
] },
2483
+
{ title: 'Query Parameters',
2484
+
steps: [
2485
+
{ code: 'let u = Uri.of_string "http://example.com?a=1&b=2";;', expect: 'Uri.t',
2486
+
description: 'URI with query params' },
2487
+
{ code: 'Uri.get_query_param u "a";;', expect: 'Some "1"',
2488
+
description: 'Get a single query parameter' },
2489
+
{ code: 'Uri.query u;;', expect: '[("a"', description: 'Get all query parameters' },
2490
+
] },
2491
+
{ title: 'Building URIs',
2492
+
steps: [
2493
+
{ code: 'Uri.make ~scheme:"https" ~host:"example.com" ~path:"/api" () |> Uri.to_string;;',
2494
+
expect: 'https://example.com/api', description: 'Build a URI from components' },
2495
+
{ code: 'Uri.with_query\' (Uri.of_string "http://x.com") [("key", "val")] |> Uri.to_string;;',
2496
+
expect: 'key=val', description: 'Add query parameters' },
2497
+
] },
2498
+
],
2499
+
},
2500
+
2501
+
'uri.4.4.0': {
2502
+
name: 'Uri', version: '4.4.0', opam: 'uri',
2503
+
description: 'URI parsing and manipulation for OCaml',
2504
+
universe: U['uri.4.4.0'], require: ['uri'],
2505
+
sections: [
2506
+
{ title: 'URI Components',
2507
+
steps: [
2508
+
{ code: 'let u = Uri.of_string "ftp://user@host/file.txt";;', expect: 'Uri.t',
2509
+
description: 'Parse an FTP URI' },
2510
+
{ code: 'Uri.scheme u;;', expect: 'Some "ftp"',
2511
+
description: 'FTP scheme' },
2512
+
{ code: 'Uri.userinfo u;;', expect: 'Some "user"',
2513
+
description: 'Extract userinfo' },
2514
+
{ code: 'Uri.host u;;', expect: 'Some "host"',
2515
+
description: 'Extract host' },
2516
+
{ code: 'Uri.path u;;', expect: '"/file.txt"',
2517
+
description: 'Extract path' },
2518
+
] },
2519
+
{ title: 'URI Manipulation',
2520
+
steps: [
2521
+
{ code: 'let u = Uri.of_string "http://example.com/old" in Uri.with_path u "/new" |> Uri.to_string;;',
2522
+
expect: 'http://example.com/new', description: 'Replace the path' },
2523
+
{ code: 'Uri.resolve "http" (Uri.of_string "http://example.com/a/b") (Uri.of_string "../c") |> Uri.to_string;;',
2524
+
expect: 'example.com', description: 'Resolve a relative reference' },
2525
+
] },
2526
+
],
2527
+
},
2528
+
2529
+
// ═══════════════════════════════════════════════════════════════════════
2530
+
// Ipaddr
2531
+
// ═══════════════════════════════════════════════════════════════════════
2532
+
'ipaddr.5.6.0': {
2533
+
name: 'Ipaddr', version: '5.6.0', opam: 'ipaddr',
2534
+
description: 'IP address parsing and manipulation for OCaml',
2535
+
universe: U['ipaddr.5.6.0'], require: ['ipaddr'],
2536
+
sections: [
2537
+
{ title: 'IPv4 Addresses',
2538
+
steps: [
2539
+
{ code: 'Ipaddr.V4.of_string_exn "192.168.1.1";;', expect: 'Ipaddr.V4.t',
2540
+
description: 'Parse an IPv4 address' },
2541
+
{ code: 'Ipaddr.V4.to_string (Ipaddr.V4.of_string_exn "10.0.0.1");;',
2542
+
expect: '"10.0.0.1"', description: 'Convert back to string' },
2543
+
{ code: 'Ipaddr.V4.localhost |> Ipaddr.V4.to_string;;', expect: '"127.0.0.1"',
2544
+
description: 'Localhost constant' },
2545
+
] },
2546
+
{ title: 'IPv6 Addresses',
2547
+
steps: [
2548
+
{ code: 'Ipaddr.V6.of_string_exn "::1" |> Ipaddr.V6.to_string;;', expect: '"::1"',
2549
+
description: 'IPv6 loopback' },
2550
+
{ code: 'Ipaddr.V6.localhost |> Ipaddr.V6.to_string;;', expect: '"::1"',
2551
+
description: 'IPv6 localhost constant' },
2552
+
] },
2553
+
{ title: 'Generic IP',
2554
+
steps: [
2555
+
{ code: 'Ipaddr.of_string_exn "192.168.1.1" |> Ipaddr.to_string;;',
2556
+
expect: '"192.168.1.1"', description: 'Parse any IP address' },
2557
+
{ code: 'Ipaddr.of_string_exn "::1" |> Ipaddr.to_string;;',
2558
+
expect: '"::1"', description: 'Parse IPv6 through generic interface' },
2559
+
] },
2560
+
],
2561
+
},
2562
+
2563
+
'ipaddr.5.6.1': {
2564
+
name: 'Ipaddr', version: '5.6.1', opam: 'ipaddr',
2565
+
description: 'IP address parsing and manipulation for OCaml',
2566
+
universe: U['ipaddr.5.6.1'], require: ['ipaddr'],
2567
+
sections: [
2568
+
{ title: 'Address Operations',
2569
+
steps: [
2570
+
{ code: 'Ipaddr.V4.of_string "invalid";;', expect: 'Error',
2571
+
description: 'Invalid address returns Error' },
2572
+
{ code: 'Ipaddr.V4.of_string "10.0.0.1";;', expect: 'Ok',
2573
+
description: 'Valid address returns Ok' },
2574
+
{ code: 'Ipaddr.V4.(compare localhost (of_string_exn "127.0.0.1"));;', expect: '0',
2575
+
description: 'Localhost equals 127.0.0.1' },
2576
+
] },
2577
+
{ title: 'CIDR Prefixes',
2578
+
steps: [
2579
+
{ code: 'let prefix = Ipaddr.V4.Prefix.of_string_exn "192.168.0.0/24";;',
2580
+
expect: 'Ipaddr.V4.Prefix.t', description: 'Parse a CIDR prefix' },
2581
+
{ code: 'Ipaddr.V4.Prefix.mem (Ipaddr.V4.of_string_exn "192.168.0.42") prefix;;',
2582
+
expect: 'true', description: 'Address is in the prefix' },
2583
+
{ code: 'Ipaddr.V4.Prefix.mem (Ipaddr.V4.of_string_exn "192.168.1.1") prefix;;',
2584
+
expect: 'false', description: 'Address is not in the prefix' },
2585
+
] },
2586
+
],
2587
+
},
2588
+
2589
+
// ═══════════════════════════════════════════════════════════════════════
2590
+
// Domain_name
2591
+
// ═══════════════════════════════════════════════════════════════════════
2592
+
'domain-name.0.4.1': {
2593
+
name: 'Domain_name', version: '0.4.1', opam: 'domain-name',
2594
+
description: 'Domain name parsing and validation for OCaml',
2595
+
universe: U['domain-name.0.4.1'], require: ['domain-name'],
2596
+
sections: [
2597
+
{ title: 'Parsing Domain Names',
2598
+
steps: [
2599
+
{ code: 'Domain_name.of_string_exn "example.com";;', expect: 'Domain_name.t',
2600
+
description: 'Parse a domain name' },
2601
+
{ code: 'Domain_name.to_string (Domain_name.of_string_exn "www.example.com");;',
2602
+
expect: '"www.example.com"', description: 'Convert back to string' },
2603
+
{ code: 'Domain_name.of_string "invalid..domain";;', expect: 'Error',
2604
+
description: 'Double dots are invalid' },
2605
+
] },
2606
+
{ title: 'Domain Name Operations',
2607
+
steps: [
2608
+
{ code: 'Domain_name.of_string_exn "sub.example.com" |> Domain_name.count_labels;;',
2609
+
expect: '3', description: 'Count labels (sub, example, com)' },
2610
+
{ code: 'Domain_name.equal (Domain_name.of_string_exn "A.COM") (Domain_name.of_string_exn "a.com");;',
2611
+
expect: 'true', description: 'Domain names are case-insensitive' },
2612
+
] },
2613
+
],
2614
+
},
2615
+
2616
+
'domain-name.0.5.0': {
2617
+
name: 'Domain_name', version: '0.5.0', opam: 'domain-name',
2618
+
description: 'Domain name parsing and validation for OCaml',
2619
+
universe: U['domain-name.0.5.0'], require: ['domain-name'],
2620
+
sections: [
2621
+
{ title: 'Domain Names',
2622
+
steps: [
2623
+
{ code: 'Domain_name.of_string_exn "mail.example.org";;', expect: 'Domain_name.t',
2624
+
description: 'Parse a domain name' },
2625
+
{ code: 'Domain_name.of_string_exn "example.com" |> Domain_name.count_labels;;',
2626
+
expect: '2', description: 'Two labels' },
2627
+
{ code: 'Domain_name.is_subdomain ~subdomain:(Domain_name.of_string_exn "sub.example.com") ~domain:(Domain_name.of_string_exn "example.com");;',
2628
+
expect: 'true', description: 'Check subdomain relationship' },
2629
+
] },
2630
+
{ title: 'Host Names',
2631
+
description: 'Domain_name.host_exn validates a domain name as a valid hostname.',
2632
+
steps: [
2633
+
{ code: 'Domain_name.host_exn (Domain_name.of_string_exn "example.com");;',
2634
+
expect: 'Domain_name.t', description: 'Valid hostname' },
2635
+
{ code: 'Domain_name.to_string (Domain_name.of_string_exn "example.com");;',
2636
+
expect: '"example.com"', description: 'Convert back to string' },
2637
+
] },
2638
+
],
2639
+
},
2640
+
2641
+
// ═══════════════════════════════════════════════════════════════════════
2642
+
// Zarith
2643
+
// ═══════════════════════════════════════════════════════════════════════
2644
+
'zarith.1.13': {
2645
+
name: 'Zarith', version: '1.13', opam: 'zarith',
2646
+
description: 'Arbitrary-precision integers and rationals for OCaml',
2647
+
universe: U['zarith.1.13'], require: ['zarith'],
2648
+
sections: [
2649
+
{ title: 'Big Integers',
2650
+
description: 'Z.t represents arbitrary-precision integers.',
2651
+
steps: [
2652
+
{ code: 'Z.of_int 42;;', expect: '42', description: 'Create from int' },
2653
+
{ code: 'Z.of_string "999999999999999999999";;', expect: '999999999999999999999',
2654
+
description: 'Create from string (exceeds int range)' },
2655
+
{ code: 'Z.add (Z.of_int 1) (Z.of_string "999999999999999999999");;',
2656
+
expect: '1000000000000000000000', description: 'Arbitrary-precision addition' },
2657
+
] },
2658
+
{ title: 'Arithmetic',
2659
+
steps: [
2660
+
{ code: 'Z.mul (Z.of_int 1000000) (Z.of_int 1000000);;', expect: '1000000000000',
2661
+
description: 'Multiplication' },
2662
+
{ code: 'Z.pow (Z.of_int 2) 100 |> Z.to_string;;', expect: '1267650600228229401496703205376',
2663
+
description: '2^100 as a string' },
2664
+
{ code: 'Z.rem (Z.of_int 17) (Z.of_int 5);;', expect: '2',
2665
+
description: 'Remainder' },
2666
+
{ code: 'Z.gcd (Z.of_int 12) (Z.of_int 18);;', expect: '6',
2667
+
description: 'Greatest common divisor' },
2668
+
] },
2669
+
{ title: 'Comparison',
2670
+
steps: [
2671
+
{ code: 'Z.compare (Z.of_int 10) (Z.of_int 20);;', expect: '-1',
2672
+
description: '10 < 20' },
2673
+
{ code: 'Z.equal Z.zero Z.zero;;', expect: 'true',
2674
+
description: 'Zero equals zero' },
2675
+
{ code: 'Z.sign (Z.of_int (-5));;', expect: '-1',
2676
+
description: 'Sign of negative number' },
2677
+
] },
2678
+
],
2679
+
},
2680
+
2681
+
'zarith.1.14': {
2682
+
name: 'Zarith', version: '1.14', opam: 'zarith',
2683
+
description: 'Arbitrary-precision integers and rationals for OCaml',
2684
+
universe: U['zarith.1.14'], require: ['zarith'],
2685
+
sections: [
2686
+
{ title: 'Big Integer Arithmetic',
2687
+
steps: [
2688
+
{ code: 'Z.(of_int 2 ** 256) |> Z.to_string |> String.length;;',
2689
+
expect: '78', description: '2^256 has 78 digits' },
2690
+
{ code: 'Z.probab_prime (Z.of_int 97) 25;;', expect: '2',
2691
+
description: '97 is prime (2 = definitely prime)' },
2692
+
{ code: 'Z.probab_prime (Z.of_int 100) 25;;', expect: '0',
2693
+
description: '100 is composite (0 = definitely not prime)' },
2694
+
] },
2695
+
{ title: 'Rationals (Q module)',
2696
+
description: 'Q.t represents exact rational numbers.',
2697
+
steps: [
2698
+
{ code: 'Q.of_ints 1 3;;', expect: '1/3',
2699
+
description: 'Create the fraction 1/3' },
2700
+
{ code: 'Q.add (Q.of_ints 1 3) (Q.of_ints 1 6);;', expect: '1/2',
2701
+
description: '1/3 + 1/6 = 1/2 (auto-simplified)' },
2702
+
{ code: 'Q.mul (Q.of_ints 2 3) (Q.of_ints 3 4);;', expect: '1/2',
2703
+
description: '2/3 * 3/4 = 1/2' },
2704
+
{ code: 'Q.to_float (Q.of_ints 1 3);;', expect: '0.333333',
2705
+
description: 'Convert to float (approximate)' },
2706
+
] },
2707
+
],
2708
+
},
2709
+
2710
+
// ═══════════════════════════════════════════════════════════════════════
2711
+
// QCheck
2712
+
// ═══════════════════════════════════════════════════════════════════════
2713
+
'qcheck-core.0.25': {
2714
+
name: 'QCheck', version: '0.25', opam: 'qcheck-core',
2715
+
description: 'Property-based testing for OCaml',
2716
+
universe: U['qcheck-core.0.25'], require: ['qcheck-core'],
2717
+
sections: [
2718
+
{ title: 'Generators',
2719
+
description: 'QCheck2.Gen provides random value generators with integrated shrinking.',
2720
+
steps: [
2721
+
{ code: 'QCheck2.Gen.generate1 QCheck2.Gen.int;;', expect: 'int',
2722
+
description: 'Generate a random integer' },
2723
+
{ code: 'QCheck2.Gen.generate1 (QCheck2.Gen.return 42);;', expect: '42',
2724
+
description: 'Constant generator always returns 42' },
2725
+
{ code: 'QCheck2.Gen.generate1 (QCheck2.Gen.list QCheck2.Gen.small_int) |> List.length >= 0;;',
2726
+
expect: 'true', description: 'Generate a random list of small ints' },
2727
+
] },
2728
+
{ title: 'Property Tests',
2729
+
description: 'QCheck2.Test.make creates a test, check_exn runs it.',
2730
+
steps: [
2731
+
{ code: 'let t = QCheck2.Test.make ~name:"commutative" QCheck2.Gen.(pair int int) (fun (a, b) -> a + b = b + a);;',
2732
+
expect: 'QCheck2.Test.t', description: 'Addition is commutative' },
2733
+
{ code: 'QCheck2.Test.check_exn t;;', expect: 'unit',
2734
+
description: 'Test passes (no exception)' },
2735
+
{ code: 'let t2 = QCheck2.Test.make ~name:"rev rev" QCheck2.Gen.(list small_int) (fun l -> List.rev (List.rev l) = l);;',
2736
+
expect: 'QCheck2.Test.t', description: 'Double reverse is identity' },
2737
+
{ code: 'QCheck2.Test.check_exn t2;;', expect: 'unit',
2738
+
description: 'Test passes' },
2739
+
] },
2740
+
],
2741
+
},
2742
+
2743
+
'qcheck-core.0.27': {
2744
+
name: 'QCheck', version: '0.27', opam: 'qcheck-core',
2745
+
description: 'Property-based testing for OCaml',
2746
+
universe: U['qcheck-core.0.27'], require: ['qcheck-core'],
2747
+
sections: [
2748
+
{ title: 'Generators',
2749
+
steps: [
2750
+
{ code: 'QCheck2.Gen.generate1 (QCheck2.Gen.oneof [QCheck2.Gen.return 1; QCheck2.Gen.return 2]);;',
2751
+
expect: 'int', description: 'Choose between generators randomly' },
2752
+
{ code: 'QCheck2.Gen.generate1 (QCheck2.Gen.map (fun x -> x * 2) QCheck2.Gen.small_int);;',
2753
+
expect: 'int', description: 'Map over a generator' },
2754
+
] },
2755
+
{ title: 'Testing Properties',
2756
+
steps: [
2757
+
{ code: 'let t = QCheck2.Test.make ~name:"sort idempotent" QCheck2.Gen.(list small_int) (fun l -> let s = List.sort compare l in List.sort compare s = s);;',
2758
+
expect: 'QCheck2.Test.t', description: 'Sorting is idempotent' },
2759
+
{ code: 'QCheck2.Test.check_exn t;;', expect: 'unit',
2760
+
description: 'Property holds' },
2761
+
{ code: 'let t = QCheck2.Test.make ~count:1000 ~name:"length" QCheck2.Gen.(list small_int) (fun l -> List.length (List.rev l) = List.length l);;',
2762
+
expect: 'QCheck2.Test.t', description: 'Rev preserves length (1000 tests)' },
2763
+
{ code: 'QCheck2.Test.check_exn t;;', expect: 'unit',
2764
+
description: 'Passes all 1000 tests' },
2765
+
] },
2766
+
],
2767
+
},
2768
+
2769
+
'qcheck-core.0.91': {
2770
+
name: 'QCheck', version: '0.91', opam: 'qcheck-core',
2771
+
description: 'Property-based testing for OCaml',
2772
+
universe: U['qcheck-core.0.91'], require: ['qcheck-core'],
2773
+
sections: [
2774
+
{ title: 'Generators and Tests',
2775
+
steps: [
2776
+
{ code: 'QCheck2.Gen.generate1 (QCheck2.Gen.pair QCheck2.Gen.nat QCheck2.Gen.bool);;',
2777
+
expect: 'int * bool', description: 'Generate a pair of int and bool' },
2778
+
{ code: 'let t = QCheck2.Test.make ~name:"assoc" QCheck2.Gen.(triple int int int) (fun (a, b, c) -> (a + b) + c = a + (b + c));;',
2779
+
expect: 'QCheck2.Test.t', description: 'Addition is associative' },
2780
+
{ code: 'QCheck2.Test.check_exn t;;', expect: 'unit',
2781
+
description: 'Property holds' },
2782
+
] },
2783
+
],
2784
+
},
2785
+
};
+268
js_top_worker/test/ohc-integration/tutorials/tutorial.html
+268
js_top_worker/test/ohc-integration/tutorials/tutorial.html
···
1
+
<!DOCTYPE html>
2
+
<html>
3
+
<head>
4
+
<meta charset="utf-8">
5
+
<title>Loading tutorial...</title>
6
+
<style>
7
+
* { box-sizing: border-box; margin: 0; padding: 0; }
8
+
body { font-family: 'SF Mono', 'Fira Code', 'Cascadia Code', 'JetBrains Mono', monospace; background: #0d1117; color: #c9d1d9; line-height: 1.6; }
9
+
10
+
.top-bar { background: #161b22; border-bottom: 1px solid #30363d; padding: 12px 24px; display: flex; align-items: center; gap: 16px; position: sticky; top: 0; z-index: 10; }
11
+
.top-bar a { color: #58a6ff; text-decoration: none; font-size: 13px; }
12
+
.top-bar a:hover { text-decoration: underline; }
13
+
.top-bar .status { margin-left: auto; font-size: 13px; }
14
+
.top-bar .status .pass { color: #3fb950; }
15
+
.top-bar .status .fail { color: #f85149; }
16
+
.top-bar .status .total { color: #8b949e; }
17
+
.progress { height: 3px; background: #21262d; }
18
+
.progress-bar { height: 100%; background: #58a6ff; transition: width 0.3s; width: 0%; }
19
+
.progress-bar.done { background: #3fb950; }
20
+
.progress-bar.has-fail { background: #f85149; }
21
+
22
+
.hero { padding: 40px 24px 32px; max-width: 900px; margin: 0 auto; }
23
+
.hero h1 { font-size: 28px; color: #f0f6fc; font-weight: 700; }
24
+
.hero h1 .version { color: #8b949e; font-weight: 400; }
25
+
.hero .desc { color: #8b949e; font-size: 15px; margin-top: 8px; font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif; }
26
+
.hero .meta { margin-top: 12px; display: flex; gap: 16px; flex-wrap: wrap; }
27
+
.hero .meta .tag { font-size: 12px; padding: 2px 8px; border-radius: 12px; background: #21262d; color: #8b949e; }
28
+
.hero .meta .tag code { color: #d2a8ff; }
29
+
30
+
main { max-width: 900px; margin: 0 auto; padding: 0 24px 60px; }
31
+
32
+
.section { margin-bottom: 40px; }
33
+
.section h2 { font-size: 16px; color: #f0f6fc; font-weight: 600; margin-bottom: 6px; font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif; }
34
+
.section .section-desc { color: #8b949e; font-size: 14px; margin-bottom: 16px; font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif; }
35
+
36
+
.step { margin-bottom: 12px; border: 1px solid #21262d; border-radius: 8px; overflow: hidden; transition: border-color 0.3s; }
37
+
.step.pass { border-color: #238636; }
38
+
.step.fail { border-color: #da3633; }
39
+
.step.running { border-color: #1f6feb; }
40
+
41
+
.step-desc { padding: 6px 12px; font-size: 13px; color: #8b949e; background: #161b22; border-bottom: 1px solid #21262d; font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif; }
42
+
43
+
.step-code { padding: 8px 12px; background: #0d1117; display: flex; align-items: baseline; gap: 8px; }
44
+
.step-code .prompt { color: #484f58; user-select: none; }
45
+
.step-code code { color: #d2a8ff; white-space: pre-wrap; word-break: break-all; flex: 1; }
46
+
.step-code .step-time { color: #484f58; font-size: 11px; flex-shrink: 0; }
47
+
.step-code .step-icon { flex-shrink: 0; width: 16px; text-align: center; font-size: 13px; }
48
+
.step-code .step-icon.pass { color: #3fb950; }
49
+
.step-code .step-icon.fail { color: #f85149; }
50
+
.step-code .step-icon.running { color: #58a6ff; }
51
+
52
+
.step-output { padding: 8px 12px; background: #161b22; border-top: 1px solid #21262d; font-size: 13px; white-space: pre-wrap; word-break: break-all; color: #3fb950; min-height: 20px; }
53
+
.step-output.empty { color: #484f58; font-style: italic; }
54
+
.step-output .stderr { color: #f85149; }
55
+
.step-output .stdout-line { color: #c9d1d9; }
56
+
57
+
.step-error { padding: 6px 12px; background: #1c1215; border-top: 1px solid #f8514933; font-size: 12px; color: #f85149; }
58
+
59
+
@keyframes spin { to { transform: rotate(360deg); } }
60
+
.spinner { display: inline-block; animation: spin 1s linear infinite; }
61
+
62
+
.init-status { text-align: center; padding: 40px; color: #8b949e; font-size: 14px; }
63
+
.init-status.error { color: #f85149; }
64
+
65
+
.error-page { text-align: center; padding: 80px 24px; }
66
+
.error-page h1 { color: #f85149; font-size: 20px; margin-bottom: 8px; }
67
+
.error-page p { color: #8b949e; }
68
+
</style>
69
+
</head>
70
+
<body>
71
+
<div class="top-bar">
72
+
<a href="index.html">← All tutorials</a>
73
+
<span id="pkg-label" style="color:#8b949e; font-size: 13px;"></span>
74
+
<div class="status" id="status-bar"></div>
75
+
</div>
76
+
<div class="progress"><div class="progress-bar" id="progress-bar"></div></div>
77
+
78
+
<div class="hero" id="hero" style="display:none;">
79
+
<h1 id="title"></h1>
80
+
<p class="desc" id="description"></p>
81
+
<div class="meta" id="meta"></div>
82
+
</div>
83
+
84
+
<div class="init-status" id="init-status"><span class="spinner">◠</span> Loading tutorial...</div>
85
+
86
+
<main id="content" style="display:none;"></main>
87
+
88
+
<script type="module">
89
+
import { TUTORIALS } from './test-defs.js';
90
+
import { OcamlWorker } from '/client/ocaml-worker.js';
91
+
92
+
const esc = s => s.replace(/&/g,'&').replace(/</g,'<').replace(/>/g,'>');
93
+
94
+
const pkg = new URLSearchParams(window.location.search).get('pkg');
95
+
const tutorial = TUTORIALS[pkg];
96
+
const initEl = document.getElementById('init-status');
97
+
98
+
if (!tutorial) {
99
+
initEl.innerHTML = '';
100
+
document.getElementById('hero').style.display = 'none';
101
+
const err = document.createElement('div');
102
+
err.className = 'error-page';
103
+
err.innerHTML = `<h1>Tutorial not found</h1><p>No tutorial for <code>${esc(pkg || '(none)')}</code>.</p><p style="margin-top:12px"><a href="index.html" style="color:#58a6ff">Back to index</a></p>`;
104
+
document.body.appendChild(err);
105
+
throw new Error('Unknown package: ' + pkg);
106
+
}
107
+
108
+
document.title = `${tutorial.name} ${tutorial.version} \u2014 Tutorial`;
109
+
document.getElementById('pkg-label').textContent = `${tutorial.name} ${tutorial.version}`;
110
+
document.getElementById('title').innerHTML = `${esc(tutorial.name)} <span class="version">${esc(tutorial.version)}</span>`;
111
+
document.getElementById('description').textContent = tutorial.description;
112
+
document.getElementById('meta').innerHTML = [
113
+
`<span class="tag">require: <code>${tutorial.require.join(', ')}</code></span>`,
114
+
`<span class="tag">universe: <code>${tutorial.universe.slice(0,12)}…</code></span>`,
115
+
`<span class="tag">compiler: <code>${tutorial.compiler || '5.4.0'}</code></span>`,
116
+
].join('');
117
+
document.getElementById('hero').style.display = 'block';
118
+
119
+
// Count total steps
120
+
const totalSteps = tutorial.sections.reduce((n, s) => n + s.steps.length, 0);
121
+
let passed = 0, failed = 0, completed = 0;
122
+
123
+
function updateStatus() {
124
+
const bar = document.getElementById('progress-bar');
125
+
bar.style.width = `${(completed / totalSteps) * 100}%`;
126
+
if (completed === totalSteps) {
127
+
bar.classList.add('done');
128
+
if (failed > 0) bar.classList.add('has-fail');
129
+
}
130
+
const parts = [];
131
+
if (passed > 0) parts.push(`<span class="pass">${passed} passed</span>`);
132
+
if (failed > 0) parts.push(`<span class="fail">${failed} failed</span>`);
133
+
parts.push(`<span class="total">${completed}/${totalSteps}</span>`);
134
+
document.getElementById('status-bar').innerHTML = parts.join(' · ');
135
+
}
136
+
updateStatus();
137
+
138
+
// Build DOM
139
+
const content = document.getElementById('content');
140
+
const stepRecords = [];
141
+
142
+
for (const section of tutorial.sections) {
143
+
const sEl = document.createElement('div');
144
+
sEl.className = 'section';
145
+
let html = `<h2>${esc(section.title)}</h2>`;
146
+
if (section.description) html += `<p class="section-desc">${esc(section.description)}</p>`;
147
+
sEl.innerHTML = html;
148
+
149
+
for (const step of section.steps) {
150
+
const div = document.createElement('div');
151
+
div.className = 'step pending';
152
+
let inner = '';
153
+
if (step.description) inner += `<div class="step-desc">${esc(step.description)}</div>`;
154
+
inner += `<div class="step-code"><span class="step-icon pending">\u25CB</span><span class="prompt">#</span> <code>${esc(step.code || step.complete?.source || '')}</code><span class="step-time"></span></div>`;
155
+
inner += `<div class="step-output empty">…</div>`;
156
+
div.innerHTML = inner;
157
+
sEl.appendChild(div);
158
+
stepRecords.push({ el: div, step });
159
+
}
160
+
content.appendChild(sEl);
161
+
}
162
+
163
+
// Init worker via findlib_index for content-hashed URLs
164
+
initEl.innerHTML = '<span class="spinner">◠</span> Initializing OCaml worker...';
165
+
let worker;
166
+
try {
167
+
const indexUrl = `/jtw-output/u/${tutorial.universe}/findlib_index`;
168
+
const { worker: w, stdlib_dcs, findlib_index } = await OcamlWorker.fromIndex(
169
+
indexUrl, '/jtw-output', { timeout: 120000 });
170
+
worker = w;
171
+
await worker.init({
172
+
findlib_requires: [],
173
+
stdlib_dcs: stdlib_dcs,
174
+
findlib_index: findlib_index,
175
+
});
176
+
177
+
initEl.innerHTML = '<span class="spinner">◠</span> Loading packages...';
178
+
for (const req of tutorial.require) {
179
+
await worker.eval(`#require "${req}";;`);
180
+
}
181
+
182
+
initEl.style.display = 'none';
183
+
content.style.display = 'block';
184
+
} catch (e) {
185
+
initEl.className = 'init-status error';
186
+
initEl.textContent = 'Failed to initialize: ' + e.message;
187
+
throw e;
188
+
}
189
+
190
+
// Run steps sequentially
191
+
for (const { el, step } of stepRecords) {
192
+
el.className = 'step running';
193
+
const iconEl = el.querySelector('.step-icon');
194
+
iconEl.className = 'step-icon running';
195
+
iconEl.innerHTML = '<span class="spinner">◠</span>';
196
+
const outEl = el.querySelector('.step-output');
197
+
const timeEl = el.querySelector('.step-time');
198
+
const start = performance.now();
199
+
200
+
try {
201
+
if (step.complete) {
202
+
const result = await worker.complete(step.complete.source, step.complete.pos);
203
+
const entries = result.completions?.entries?.map(e => e.name) || [];
204
+
const elapsed = Math.round(performance.now() - start);
205
+
outEl.className = 'step-output';
206
+
outEl.textContent = `Completions: ${entries.join(', ')}`;
207
+
if (step.expectEntries) {
208
+
for (const exp of step.expectEntries) {
209
+
if (!entries.includes(exp)) throw new Error(`Expected completion "${exp}" not in [${entries.join(', ')}]`);
210
+
}
211
+
}
212
+
timeEl.textContent = elapsed + 'ms';
213
+
passed++;
214
+
} else {
215
+
const r = await worker.eval(step.code);
216
+
const ppf = r.caml_ppf || '';
217
+
const stdout = r.stdout || '';
218
+
const stderr = r.stderr || '';
219
+
const elapsed = Math.round(performance.now() - start);
220
+
timeEl.textContent = elapsed + 'ms';
221
+
222
+
// Render output
223
+
outEl.className = 'step-output';
224
+
let html = '';
225
+
if (ppf) html += esc(ppf.trimEnd());
226
+
if (stdout) html += (html ? '\n' : '') + `<span class="stdout-line">${esc(stdout.trimEnd())}</span>`;
227
+
if (stderr && !step.expectError) html += (html ? '\n' : '') + `<span class="stderr">${esc(stderr.trimEnd())}</span>`;
228
+
if (step.expectError) {
229
+
// Negative test
230
+
html += (html ? '\n' : '') + `<span class="stderr">${esc(stderr.trimEnd())}</span>`;
231
+
}
232
+
if (!html) { outEl.className = 'step-output empty'; html = 'unit'; }
233
+
outEl.innerHTML = html;
234
+
235
+
// Check expectations
236
+
if (step.expectError) {
237
+
const combined = ppf + stderr;
238
+
if (!combined.includes(step.expectError))
239
+
throw new Error(`Expected error containing "${step.expectError}" but got: ${ppf || stderr || '(empty)'}`);
240
+
} else if (step.expect !== undefined && step.expect !== '') {
241
+
if (!ppf.includes(step.expect))
242
+
throw new Error(`Expected output containing "${step.expect}", got: "${ppf}"`);
243
+
}
244
+
if (step.expectStdout && !stdout.includes(step.expectStdout))
245
+
throw new Error(`Expected stdout containing "${step.expectStdout}", got: "${stdout}"`);
246
+
247
+
passed++;
248
+
}
249
+
el.className = 'step pass';
250
+
iconEl.className = 'step-icon pass';
251
+
iconEl.textContent = '\u2714';
252
+
} catch (e) {
253
+
failed++;
254
+
el.className = 'step fail';
255
+
iconEl.className = 'step-icon fail';
256
+
iconEl.textContent = '\u2718';
257
+
const errDiv = document.createElement('div');
258
+
errDiv.className = 'step-error';
259
+
errDiv.textContent = e.message;
260
+
el.appendChild(errDiv);
261
+
}
262
+
263
+
completed++;
264
+
updateStatus();
265
+
}
266
+
</script>
267
+
</body>
268
+
</html>
+289
js_top_worker/test/ohc-integration/tutorials/tutorials.spec.js
+289
js_top_worker/test/ohc-integration/tutorials/tutorials.spec.js
···
1
+
// @ts-check
2
+
const { test, expect } = require('@playwright/test');
3
+
4
+
const BASE = 'http://localhost:8769/test/ohc-integration/tutorials';
5
+
6
+
// Generous timeout for worker init + package loading + step execution
7
+
test.describe.configure({ timeout: 180_000 });
8
+
9
+
/**
10
+
* Helper: load a tutorial page, wait for all steps to finish,
11
+
* return { passed, failed, total, failures[] }.
12
+
*/
13
+
async function runTutorial(page, pkg) {
14
+
await page.goto(`${BASE}/tutorial.html?pkg=${encodeURIComponent(pkg)}`);
15
+
16
+
// Wait for init status to disappear (worker loaded, packages loaded)
17
+
await page.waitForSelector('#init-status', { state: 'hidden', timeout: 120_000 });
18
+
19
+
// Wait for all steps to finish: progress bar gets class 'done'
20
+
await page.waitForSelector('.progress-bar.done', { timeout: 120_000 });
21
+
22
+
// Gather results
23
+
const results = await page.evaluate(() => {
24
+
const steps = document.querySelectorAll('.step');
25
+
const failures = [];
26
+
let passed = 0, failed = 0;
27
+
for (const step of steps) {
28
+
if (step.classList.contains('pass')) {
29
+
passed++;
30
+
} else if (step.classList.contains('fail')) {
31
+
failed++;
32
+
const code = step.querySelector('.step-code code')?.textContent || '';
33
+
const output = step.querySelector('.step-output')?.textContent || '';
34
+
const error = step.querySelector('.step-error')?.textContent || '';
35
+
failures.push({ code, output, error });
36
+
}
37
+
}
38
+
return { passed, failed, total: steps.length, failures };
39
+
});
40
+
41
+
return results;
42
+
}
43
+
44
+
// ── Test a representative sample across all library types ──────────────
45
+
46
+
test('fmt.0.11.0 tutorial', async ({ page }) => {
47
+
const r = await runTutorial(page, 'fmt.0.11.0');
48
+
if (r.failures.length > 0) {
49
+
console.log('Failures:', JSON.stringify(r.failures, null, 2));
50
+
}
51
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
52
+
expect(r.passed).toBe(r.total);
53
+
});
54
+
55
+
test('cmdliner.1.0.4 tutorial', async ({ page }) => {
56
+
const r = await runTutorial(page, 'cmdliner.1.0.4');
57
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
58
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
59
+
});
60
+
61
+
test('cmdliner.2.1.0 tutorial', async ({ page }) => {
62
+
const r = await runTutorial(page, 'cmdliner.2.1.0');
63
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
64
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
65
+
});
66
+
67
+
test('mtime.1.3.0 tutorial', async ({ page }) => {
68
+
const r = await runTutorial(page, 'mtime.1.3.0');
69
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
70
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
71
+
});
72
+
73
+
test('mtime.2.1.0 tutorial', async ({ page }) => {
74
+
const r = await runTutorial(page, 'mtime.2.1.0');
75
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
76
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
77
+
});
78
+
79
+
test('astring.0.8.5 tutorial', async ({ page }) => {
80
+
const r = await runTutorial(page, 'astring.0.8.5');
81
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
82
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
83
+
});
84
+
85
+
test('jsonm.1.0.2 tutorial', async ({ page }) => {
86
+
const r = await runTutorial(page, 'jsonm.1.0.2');
87
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
88
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
89
+
});
90
+
91
+
test('ptime.1.2.0 tutorial', async ({ page }) => {
92
+
const r = await runTutorial(page, 'ptime.1.2.0');
93
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
94
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
95
+
});
96
+
97
+
test('hmap.0.8.1 tutorial', async ({ page }) => {
98
+
const r = await runTutorial(page, 'hmap.0.8.1');
99
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
100
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
101
+
});
102
+
103
+
test('react.1.2.2 tutorial', async ({ page }) => {
104
+
const r = await runTutorial(page, 'react.1.2.2');
105
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
106
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
107
+
});
108
+
109
+
test('gg.1.0.0 tutorial', async ({ page }) => {
110
+
const r = await runTutorial(page, 'gg.1.0.0');
111
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
112
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
113
+
});
114
+
115
+
test('fpath.0.7.3 tutorial', async ({ page }) => {
116
+
const r = await runTutorial(page, 'fpath.0.7.3');
117
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
118
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
119
+
});
120
+
121
+
test('uutf.1.0.4 tutorial', async ({ page }) => {
122
+
const r = await runTutorial(page, 'uutf.1.0.4');
123
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
124
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
125
+
});
126
+
127
+
test('bos.0.2.1 tutorial', async ({ page }) => {
128
+
const r = await runTutorial(page, 'bos.0.2.1');
129
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
130
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
131
+
});
132
+
133
+
test('uucp.14.0.0 tutorial', async ({ page }) => {
134
+
const r = await runTutorial(page, 'uucp.14.0.0');
135
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
136
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
137
+
});
138
+
139
+
test('note.0.0.3 tutorial', async ({ page }) => {
140
+
const r = await runTutorial(page, 'note.0.0.3');
141
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
142
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
143
+
});
144
+
145
+
test('vg.0.9.5 tutorial', async ({ page }) => {
146
+
const r = await runTutorial(page, 'vg.0.9.5');
147
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
148
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
149
+
});
150
+
151
+
test('b0.0.0.6 tutorial', async ({ page }) => {
152
+
const r = await runTutorial(page, 'b0.0.0.6');
153
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
154
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
155
+
});
156
+
157
+
test('logs.0.10.0 tutorial', async ({ page }) => {
158
+
const r = await runTutorial(page, 'logs.0.10.0');
159
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
160
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
161
+
});
162
+
163
+
test('xmlm.1.4.0 tutorial', async ({ page }) => {
164
+
const r = await runTutorial(page, 'xmlm.1.4.0');
165
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
166
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
167
+
});
168
+
169
+
// ── Remaining versions ────────────────────────────────────────────────
170
+
171
+
test('fmt.0.9.0 tutorial', async ({ page }) => {
172
+
const r = await runTutorial(page, 'fmt.0.9.0');
173
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
174
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
175
+
});
176
+
177
+
test('fmt.0.10.0 tutorial', async ({ page }) => {
178
+
const r = await runTutorial(page, 'fmt.0.10.0');
179
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
180
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
181
+
});
182
+
183
+
test('cmdliner.1.3.0 tutorial', async ({ page }) => {
184
+
const r = await runTutorial(page, 'cmdliner.1.3.0');
185
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
186
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
187
+
});
188
+
189
+
test('cmdliner.2.0.0 tutorial', async ({ page }) => {
190
+
const r = await runTutorial(page, 'cmdliner.2.0.0');
191
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
192
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
193
+
});
194
+
195
+
test('mtime.1.4.0 tutorial', async ({ page }) => {
196
+
const r = await runTutorial(page, 'mtime.1.4.0');
197
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
198
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
199
+
});
200
+
201
+
test.skip('logs.0.7.0 tutorial — broken universe (inconsistent assumptions)', async ({ page }) => {
202
+
const r = await runTutorial(page, 'logs.0.7.0');
203
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
204
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
205
+
});
206
+
207
+
test('uucp.15.0.0 tutorial', async ({ page }) => {
208
+
const r = await runTutorial(page, 'uucp.15.0.0');
209
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
210
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
211
+
});
212
+
213
+
test('uucp.16.0.0 tutorial', async ({ page }) => {
214
+
const r = await runTutorial(page, 'uucp.16.0.0');
215
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
216
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
217
+
});
218
+
219
+
test('uucp.17.0.0 tutorial', async ({ page }) => {
220
+
const r = await runTutorial(page, 'uucp.17.0.0');
221
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
222
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
223
+
});
224
+
225
+
test('uunf.14.0.0 tutorial', async ({ page }) => {
226
+
const r = await runTutorial(page, 'uunf.14.0.0');
227
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
228
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
229
+
});
230
+
231
+
test('uunf.17.0.0 tutorial', async ({ page }) => {
232
+
const r = await runTutorial(page, 'uunf.17.0.0');
233
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
234
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
235
+
});
236
+
237
+
test('otfm.0.4.0 tutorial', async ({ page }) => {
238
+
const r = await runTutorial(page, 'otfm.0.4.0');
239
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
240
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
241
+
});
242
+
243
+
// ── New library tutorials (added packages) ────────────────────────────
244
+
245
+
const newTutorials = [
246
+
'yojson.3.0.0',
247
+
'ezjsonm.1.1.0', 'ezjsonm.1.2.0', 'ezjsonm.1.3.0',
248
+
'sexplib0.v0.17.0',
249
+
'base64.3.5.2',
250
+
're.1.10.4', 're.1.11.0', 're.1.12.0', 're.1.13.2', 're.1.14.0',
251
+
'angstrom.0.16.1',
252
+
'tyre.0.5', 'tyre.1.0',
253
+
'uuseg.14.0.0', 'uuseg.15.0.0', 'uuseg.16.0.0', 'uuseg.17.0.0',
254
+
'containers.3.17',
255
+
'iter.1.7', 'iter.1.8', 'iter.1.9',
256
+
'ocamlgraph.2.0.0', 'ocamlgraph.2.1.0', 'ocamlgraph.2.2.0',
257
+
'hex.1.4.0', 'hex.1.5.0',
258
+
'eqaf.0.9', 'eqaf.0.10',
259
+
'uri.4.4.0',
260
+
'ipaddr.5.6.0', 'ipaddr.5.6.1',
261
+
'domain-name.0.4.1', 'domain-name.0.5.0',
262
+
'qcheck-core.0.25', 'qcheck-core.0.27', 'qcheck-core.0.91',
263
+
];
264
+
265
+
// These packages have broken jtw layers (inconsistent .cmi assumptions,
266
+
// wrong OCaml version, undefined compilation units, or missing JS stubs)
267
+
const skippedTutorials = [
268
+
'yojson.1.7.0', 'yojson.2.0.2', 'yojson.2.1.2', 'yojson.2.2.2',
269
+
'angstrom.0.15.0',
270
+
'base64.3.4.0',
271
+
'sexplib0.v0.15.1', 'sexplib0.v0.16.0',
272
+
'csexp.1.5.2',
273
+
'containers.3.12', 'containers.3.14',
274
+
'digestif.1.1.2', 'digestif.1.3.0',
275
+
'uri.4.2.0',
276
+
'zarith.1.13', 'zarith.1.14',
277
+
];
278
+
279
+
for (const pkg of skippedTutorials) {
280
+
test.skip(`${pkg} tutorial — needs combined universe`, () => {});
281
+
}
282
+
283
+
for (const pkg of newTutorials) {
284
+
test(`${pkg} tutorial`, async ({ page }) => {
285
+
const r = await runTutorial(page, pkg);
286
+
if (r.failures.length > 0) console.log('Failures:', JSON.stringify(r.failures, null, 2));
287
+
expect(r.failed, `${r.failed} failures: ${JSON.stringify(r.failures)}`).toBe(0);
288
+
});
289
+
}
+15
js_top_worker/test/unix/dune
+15
js_top_worker/test/unix/dune
+149
js_top_worker/test/unix/unix_test.ml
+149
js_top_worker/test/unix/unix_test.ml
···
1
+
(* Unix worker *)
2
+
open Js_top_worker
3
+
open Impl
4
+
5
+
let capture f () =
6
+
let stdout_backup = Unix.dup ~cloexec:true Unix.stdout in
7
+
let stderr_backup = Unix.dup ~cloexec:true Unix.stderr in
8
+
let filename_out = Filename.temp_file "ocaml-mdx-" ".stdout" in
9
+
let filename_err = Filename.temp_file "ocaml-mdx-" ".stderr" in
10
+
let fd_out =
11
+
Unix.openfile filename_out
12
+
Unix.[ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ]
13
+
0o600
14
+
in
15
+
let fd_err =
16
+
Unix.openfile filename_err
17
+
Unix.[ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ]
18
+
0o600
19
+
in
20
+
Unix.dup2 ~cloexec:false fd_out Unix.stdout;
21
+
Unix.dup2 ~cloexec:false fd_err Unix.stderr;
22
+
let ic_out = open_in filename_out in
23
+
let ic_err = open_in filename_err in
24
+
let capture oc ic fd buf =
25
+
flush oc;
26
+
let len = Unix.lseek fd 0 Unix.SEEK_CUR in
27
+
Buffer.add_channel buf ic len
28
+
in
29
+
Fun.protect
30
+
(fun () ->
31
+
let x = f () in
32
+
let buf_out = Buffer.create 1024 in
33
+
let buf_err = Buffer.create 1024 in
34
+
capture stdout ic_out fd_out buf_out;
35
+
capture stderr ic_err fd_err buf_err;
36
+
( {
37
+
Impl.stdout = Buffer.contents buf_out;
38
+
stderr = Buffer.contents buf_err;
39
+
},
40
+
x ))
41
+
~finally:(fun () ->
42
+
close_in_noerr ic_out;
43
+
close_in_noerr ic_out;
44
+
Unix.close fd_out;
45
+
Unix.close fd_err;
46
+
Unix.dup2 ~cloexec:false stdout_backup Unix.stdout;
47
+
Unix.dup2 ~cloexec:false stderr_backup Unix.stderr;
48
+
Unix.close stdout_backup;
49
+
Unix.close stderr_backup;
50
+
Sys.remove filename_out;
51
+
Sys.remove filename_err)
52
+
53
+
let handle_findlib_error = function
54
+
| Failure msg -> Printf.fprintf stderr "%s" msg
55
+
| Fl_package_base.No_such_package (pkg, reason) ->
56
+
Printf.fprintf stderr "No such package: %s%s\n" pkg
57
+
(if reason <> "" then " - " ^ reason else "")
58
+
| Fl_package_base.Package_loop pkg ->
59
+
Printf.fprintf stderr "Package requires itself: %s\n" pkg
60
+
| exn -> raise exn
61
+
62
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (IdlM.GenServer ())
63
+
64
+
module S : Impl.S = struct
65
+
type findlib_t = unit
66
+
67
+
let capture = capture
68
+
let sync_get _ = None
69
+
let async_get _ = Lwt.return (Error (`Msg "Not implemented"))
70
+
let create_file ~name:_ ~content:_ = failwith "Not implemented"
71
+
72
+
let import_scripts urls =
73
+
if List.length urls > 0 then failwith "Not implemented" else ()
74
+
75
+
let init_function _ () = failwith "Not implemented"
76
+
let findlib_init _ = Lwt.return ()
77
+
let get_stdlib_dcs _uri = []
78
+
79
+
let require _ () packages =
80
+
try
81
+
let eff_packages =
82
+
Findlib.package_deep_ancestors !Topfind.predicates packages
83
+
in
84
+
Topfind.load eff_packages;
85
+
[]
86
+
with exn ->
87
+
handle_findlib_error exn;
88
+
[]
89
+
90
+
let path = "/tmp/cmis"
91
+
end
92
+
93
+
module U = Impl.Make (S)
94
+
95
+
let start_server () =
96
+
(try Unix.mkdir S.path 0o777 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
97
+
let open U in
98
+
Logs.set_reporter (Logs_fmt.reporter ());
99
+
Logs.set_level (Some Logs.Info);
100
+
(* let pid = Unix.getpid () in *)
101
+
Server.init (IdlM.T.lift init);
102
+
Server.create_env (IdlM.T.lift create_env);
103
+
Server.destroy_env (IdlM.T.lift destroy_env);
104
+
Server.list_envs (IdlM.T.lift list_envs);
105
+
Server.setup (IdlM.T.lift setup);
106
+
Server.exec execute;
107
+
Server.complete_prefix complete_prefix;
108
+
Server.query_errors query_errors;
109
+
Server.type_enclosing type_enclosing;
110
+
Server.exec_toplevel exec_toplevel;
111
+
IdlM.server Server.implementation
112
+
113
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (IdlM.GenClient ())
114
+
115
+
let c1, c2, c3, c4 = ("c1", "c2", "c3", "c4")
116
+
117
+
let notebook =
118
+
[
119
+
(c1, [], "typ xxxx = int;;\n");
120
+
(c2, [ c1 ], "type yyy=xxx;;\n");
121
+
(c3, [ c1; c2 ], "type xxx = int;;\n");
122
+
(c4, [ c1; c2; c3 ], "type yyy = xxx;;\n");
123
+
]
124
+
125
+
let _ =
126
+
let rpc = start_server () in
127
+
Printf.printf "Starting worker...\n%!";
128
+
let ( let* ) = IdlM.ErrM.bind in
129
+
let init =
130
+
Js_top_worker_rpc.Toplevel_api_gen.
131
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
132
+
in
133
+
let x =
134
+
let rec run notebook =
135
+
match notebook with
136
+
| (id, deps, cell) :: cells ->
137
+
let* errs = Client.query_errors rpc "" (Some id) deps false cell in
138
+
Printf.printf "Cell %s: %d errors\n%!" id (List.length errs);
139
+
run cells
140
+
| [] -> IdlM.ErrM.return ()
141
+
in
142
+
let* _ = Client.init rpc init in
143
+
let* _ = Client.setup rpc "" in
144
+
let* _ = run notebook in
145
+
IdlM.ErrM.return ()
146
+
in
147
+
match x |> IdlM.T.get |> Lwt_main.run with
148
+
| Ok () -> Printf.printf "Success\n%!"
149
+
| Error (InternalError s) -> Printf.printf "Error: %s\n%!" s