jon.recoil.org
Testing of the @doc-json output
Merge commit '70884b826ea6a5f53e5944ed19ca6e9d5d30848d' as 'x-ocaml'
+39
x-ocaml/.github/workflows/build.yml
+39
x-ocaml/.github/workflows/build.yml
···
···
1
+
name: CI
2
+
3
+
on:
4
+
push:
5
+
branches:
6
+
- "master"
7
+
pull_request:
8
+
branches:
9
+
- "master"
10
+
11
+
jobs:
12
+
build:
13
+
strategy:
14
+
fail-fast: false
15
+
matrix:
16
+
os:
17
+
- ubuntu-latest
18
+
ocaml-compiler:
19
+
- 5.2.x
20
+
runs-on: ${{ matrix.os }}
21
+
22
+
steps:
23
+
- uses: actions/checkout@v4
24
+
with:
25
+
submodules: recursive
26
+
27
+
- name: Set up OCaml ${{ matrix.ocaml-compiler }}
28
+
uses: ocaml/setup-ocaml@v3
29
+
with:
30
+
ocaml-compiler: ${{ matrix.ocaml-compiler }}
31
+
32
+
- name: Install dependencies
33
+
run: opam install . --deps-only --with-test
34
+
35
+
- name: Build
36
+
run: opam exec -- dune build --profile=release
37
+
38
+
- name: Test export
39
+
run: opam exec -- dune exec -- x-ocaml fmt yojson --ppx ppx_blob -o test_export.js
+15
x-ocaml/.gitignore
+15
x-ocaml/.gitignore
+6
x-ocaml/.gitmodules
+6
x-ocaml/.gitmodules
+1
x-ocaml/.ocamlformat
+1
x-ocaml/.ocamlformat
···
···
1
+
version=0.27.0
+21
x-ocaml/LICENSE
+21
x-ocaml/LICENSE
···
···
1
+
MIT License
2
+
3
+
Copyright (c) 2025 Arthur Wendling, Tarides
4
+
5
+
Permission is hereby granted, free of charge, to any person obtaining a copy
6
+
of this software and associated documentation files (the "Software"), to deal
7
+
in the Software without restriction, including without limitation the rights
8
+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9
+
copies of the Software, and to permit persons to whom the Software is
10
+
furnished to do so, subject to the following conditions:
11
+
12
+
The above copyright notice and this permission notice shall be included in all
13
+
copies or substantial portions of the Software.
14
+
15
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16
+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17
+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18
+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19
+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20
+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21
+
SOFTWARE.
+44
x-ocaml/README.md
+44
x-ocaml/README.md
···
···
1
+
Embed OCaml notebooks in any web page thanks to WebComponents! Just copy and paste the following script in your html page source to load the integration:
2
+
3
+
```html
4
+
<script async
5
+
src="https://cdn.jsdelivr.net/gh/art-w/x-ocaml.js@6/x-ocaml.js"
6
+
src-worker="https://cdn.jsdelivr.net/gh/art-w/x-ocaml.js@6/x-ocaml.worker+effects.js"
7
+
integrity="sha256-3ITn2LRgP/8Rz6oqP5ZQTysesNaSi6/iEdbDvBfyCSE="
8
+
crossorigin="anonymous"
9
+
></script>
10
+
```
11
+
12
+
This will introduce a new html tag `<x-ocaml>` to present OCaml code, for example:
13
+
14
+
```html
15
+
<x-ocaml>let x = 42</x-ocaml>
16
+
```
17
+
18
+
The script will initialize a CodeMirror editor integrated with the OCaml interpreter, Merlin and OCamlformat (all running in a web worker). [**Check out the online demo**](https://art-w.github.io/x-ocaml/) for more details, including how to load additional OCaml libraries and ppx in your page.
19
+
20
+
For an even easier integration, @patricoferris made a command-line tool [`xocmd`](https://github.com/patricoferris/xocmd) to convert markdown files to use `<x-ocaml>`!
21
+
22
+
## Compilation
23
+
24
+
To avoid relying on a public CDN and host your own copy of the `x-ocaml` scripts, you can reproduce the javascript files with:
25
+
26
+
```shell
27
+
$ git clone --recursive https://github.com/art-w/x-ocaml
28
+
$ cd x-ocaml
29
+
30
+
# Install the dependencies with either dune:
31
+
x-ocaml/ $ dune pkg lock
32
+
# Or with opam:
33
+
x-ocaml/ $ opam update && opam install . --deps-only
34
+
35
+
# Make sure to use the release profile to optimize the js file size
36
+
x-ocaml/ $ dune build --profile=release
37
+
38
+
x-ocaml/ $ ls *.js
39
+
x-ocaml.js x-ocaml.worker+effects.js x-ocaml.worker.js
40
+
```
41
+
42
+
## Acknowledgments
43
+
44
+
This project was heavily inspired by the amazing [`sketch.sh`](https://sketch.sh), [@jonludlam's notebooks in Odoc](https://jon.recoil.org/notebooks/foundations/foundations1.html#a-first-session-with-ocaml), [`blogaml` by @panglesd](https://github.com/panglesd/blogaml), and all the wonderful people who made [Try OCaml](https://try.ocamlpro.com/) and other online playgrounds! It was made possible thanks to the invaluable [`js_of_ocaml-toplevel`](https://github.com/ocsigen/js_of_ocaml) library, the magical [`merlin-js` by @voodoos](https://github.com/voodoos/merlin-js), the excellent [CodeMirror bindings by @patricoferris](https://github.com/patricoferris/jsoo-code-mirror/), the guidance of @Julow on `ocamlformat` and the javascript expertise of @xvw.
+5
x-ocaml/bin/dune
+5
x-ocaml/bin/dune
+197
x-ocaml/bin/x_ocaml.ml
+197
x-ocaml/bin/x_ocaml.ml
···
···
1
+
open Bos
2
+
3
+
let fatal err =
4
+
Format.printf "ERROR: %s@." err;
5
+
exit 1
6
+
7
+
let or_fail = function Ok x -> x | Error (`Msg m) -> fatal m
8
+
let get_result r = fst @@ or_fail @@ OS.Cmd.out_string r
9
+
let lines = String.split_on_char '\n'
10
+
11
+
let jsoo_safe_import =
12
+
{|(function(globalThis){
13
+
"use strict";
14
+
var runtime = globalThis.jsoo_runtime;
15
+
var register_global = runtime.caml_register_global;
16
+
runtime.caml_register_global = function (a,b,c) {
17
+
if (c !== 'Ast_mapper') {
18
+
return register_global(a,b,c);
19
+
}
20
+
};
21
+
var create_file = runtime.jsoo_create_file;
22
+
runtime.jsoo_create_file = function(a,b) {
23
+
try {
24
+
return create_file(a,b);
25
+
} catch(_err) {
26
+
// console.log('jsoo_create_file', a, err);
27
+
}
28
+
};
29
+
}
30
+
(globalThis));|}
31
+
32
+
type t = {
33
+
name : string;
34
+
incl : Cmd.t;
35
+
runtime : string option;
36
+
cma : string;
37
+
ppx : bool;
38
+
}
39
+
40
+
let jsoo_compile ~effects t temp_file =
41
+
let toplevel = if t.ppx then Cmd.empty else Cmd.v "--toplevel" in
42
+
let cmd =
43
+
Cmd.(
44
+
v "js_of_ocaml" %% toplevel %% effects %% t.incl % t.cma % "-o"
45
+
% p temp_file)
46
+
in
47
+
let r = get_result @@ OS.Cmd.run_out cmd in
48
+
Format.printf "%s%!" r;
49
+
let jsoo_runtime =
50
+
match t.runtime with
51
+
| None -> ""
52
+
| Some runtime_file ->
53
+
let contents =
54
+
Result.get_ok
55
+
@@ Bos.OS.File.read (Result.get_ok @@ Fpath.of_string runtime_file)
56
+
in
57
+
"(function(joo_global_object){" ^ contents ^ "}(globalThis));\n"
58
+
in
59
+
let temp = Result.get_ok @@ Bos.OS.File.read temp_file in
60
+
jsoo_runtime ^ temp
61
+
62
+
let jsoo_export_cma ~effects t =
63
+
or_fail
64
+
@@ Bos.OS.File.with_tmp_output "x-ocaml.%s.js"
65
+
(fun temp_file _ () -> jsoo_compile ~effects t temp_file)
66
+
()
67
+
68
+
let ocamlfind_path lib =
69
+
get_result @@ OS.Cmd.run_out Cmd.(v "ocamlfind" % "query" % lib)
70
+
71
+
let ocamlfind_includes lib =
72
+
get_result
73
+
@@ OS.Cmd.run_out
74
+
Cmd.(
75
+
v "ocamlfind" % "query" % lib % "-i-format" % "-predicates" % "byte")
76
+
77
+
let ocamlfind_jsoo_runtime lib =
78
+
get_result
79
+
@@ OS.Cmd.run_out
80
+
Cmd.(
81
+
v "ocamlfind" % "query" % lib % "-format" % "%(jsoo_runtime)"
82
+
% "-predicates" % "byte")
83
+
84
+
let ocamlfind_cma ~predicate lib =
85
+
get_result
86
+
@@ OS.Cmd.run_out
87
+
Cmd.(
88
+
v "ocamlfind" % "query" % lib % "-a-format" % "-predicates" % predicate)
89
+
90
+
let ocamlfind_deps ~predicate lib =
91
+
lines @@ get_result
92
+
@@ OS.Cmd.run_out
93
+
Cmd.(
94
+
v "ocamlfind" % "query" % lib % "-r" % "-p-format" % "-predicates"
95
+
% predicate)
96
+
97
+
module Env = Set.Make (String)
98
+
99
+
let make ~ppx ~predicate lib =
100
+
let cma = ocamlfind_cma ~predicate lib in
101
+
match lines cma with
102
+
| [] | [ "" ] ->
103
+
Format.printf "skip %s@." lib;
104
+
None
105
+
| [ cma ] ->
106
+
let incl = ocamlfind_includes lib in
107
+
let incl = or_fail @@ Cmd.of_string incl in
108
+
let runtime =
109
+
match ocamlfind_jsoo_runtime lib with
110
+
| "" -> None
111
+
| runtime ->
112
+
let path = ocamlfind_path lib in
113
+
let runtime = path ^ "/" ^ runtime in
114
+
Format.printf "jsoo_runtime(%s) = %S@." lib runtime;
115
+
Some runtime
116
+
in
117
+
Some { incl; runtime; cma; ppx; name = lib }
118
+
| cmas ->
119
+
fatal
120
+
(Format.asprintf "expected one cma for %s, got %i" lib
121
+
(List.length cmas))
122
+
123
+
let dependencies ~ppx targets env =
124
+
let predicate = if ppx then "ppx_driver,byte" else "byte" in
125
+
let add =
126
+
List.fold_left (fun (env, all) lib ->
127
+
if Env.mem lib env then (env, all)
128
+
else
129
+
let env = Env.add lib env in
130
+
match make ~ppx ~predicate lib with
131
+
| None -> (env, all)
132
+
| Some t -> (env, t :: all))
133
+
in
134
+
let env, selection =
135
+
List.fold_left
136
+
(fun env target ->
137
+
let libs = ocamlfind_deps ~predicate target in
138
+
add env libs)
139
+
(env, []) targets
140
+
in
141
+
(env, List.rev selection)
142
+
143
+
let output_string output str =
144
+
output (Some (Bytes.of_string str, 0, String.length str))
145
+
146
+
let main effects targets ppxs output =
147
+
let effects =
148
+
if effects then Cmd.(v "--effects=cps" % "--enable=effect") else Cmd.empty
149
+
in
150
+
let targets =
151
+
match ppxs with
152
+
| [] -> targets
153
+
| _ -> targets @ ppxs @ [ "ppxlib_register" ]
154
+
in
155
+
let env = Env.singleton "x-ocaml.lib" in
156
+
let env, all_ppxs = dependencies ~ppx:true ppxs env in
157
+
let _env, all_libs = dependencies ~ppx:false targets env in
158
+
let all = all_ppxs @ all_libs in
159
+
or_fail @@ or_fail
160
+
@@ (fun f -> f ())
161
+
@@ Bos.OS.File.with_output (Fpath.v output)
162
+
@@ fun output () ->
163
+
let output = output_string output in
164
+
output jsoo_safe_import;
165
+
try
166
+
List.iter
167
+
(fun t ->
168
+
Format.printf "export %s@." t.name;
169
+
let js = jsoo_export_cma ~effects t in
170
+
output js)
171
+
all;
172
+
Ok ()
173
+
with _ -> Error (`Msg "export failed")
174
+
175
+
open Cmdliner
176
+
177
+
let arg_output =
178
+
let open Arg in
179
+
required
180
+
& opt (some string) None
181
+
& info [ "o"; "output" ] ~docv:"OUTPUT" ~doc:"Output filename"
182
+
183
+
let with_effects =
184
+
let open Arg in
185
+
value & flag & info [ "effects" ] ~doc:"Enable effects"
186
+
187
+
let targets =
188
+
let open Arg in
189
+
non_empty & pos_all string [] & info []
190
+
191
+
let ppxs =
192
+
let open Arg in
193
+
value & opt_all string [] & info [ "p"; "ppx" ] ~docv:"PPX" ~doc:"PPX"
194
+
195
+
let main_term = Term.(const main $ with_effects $ targets $ ppxs $ arg_output)
196
+
let cmd_main = Cmd.v (Cmd.info "x-ocaml") main_term
197
+
let () = exit @@ Cmd.eval cmd_main
+39
x-ocaml/dune
+39
x-ocaml/dune
···
···
1
+
(vendored_dirs jsoo-code-mirror merlin-js)
2
+
3
+
(rule
4
+
(mode promote)
5
+
(target x-ocaml.js)
6
+
(deps src/x_ocaml.bc.js)
7
+
(action
8
+
(copy %{deps} %{target})))
9
+
10
+
(rule
11
+
(mode promote)
12
+
(target x-ocaml.worker+effects.js)
13
+
(deps worker/effects/x_worker.bc.js)
14
+
(action
15
+
(copy %{deps} %{target})))
16
+
17
+
(rule
18
+
(mode promote)
19
+
(target x-ocaml.worker.js)
20
+
(deps worker/no-effects/x_worker.bc.js)
21
+
(action
22
+
(copy %{deps} %{target})))
23
+
24
+
(rule
25
+
(target README.md.expected)
26
+
(enabled_if
27
+
(= %{profile} release))
28
+
(action
29
+
(progn
30
+
(with-stdout-to
31
+
%{target}
32
+
(pipe-stdout
33
+
(run sha256sum %{dep:x-ocaml.js})
34
+
(run grep -o "^[^ ]\\+")
35
+
(run xxd -r -p)
36
+
(run base64)
37
+
(bash
38
+
"read hash; sed -E \"s| integrity=.*$| integrity=\\\"sha256-$hash\\\"|\" ../../README.md")))
39
+
(diff %{dep:README.md} %{target}))))
+46
x-ocaml/dune-project
+46
x-ocaml/dune-project
···
···
1
+
(lang dune 3.10)
2
+
3
+
(generate_opam_files true)
4
+
5
+
(name x-ocaml)
6
+
7
+
(source
8
+
(github art-w/x-ocaml))
9
+
10
+
(authors "Arthur Wendling")
11
+
12
+
(maintainers "art.wendling@gmail.com")
13
+
14
+
(license MIT)
15
+
16
+
(package
17
+
(name x-ocaml)
18
+
(synopsis "OCaml notebooks as a WebComponent")
19
+
(depends
20
+
(bos
21
+
(>= 0.2.1))
22
+
(brr
23
+
(>= 0.0.7))
24
+
(cmdliner
25
+
(>= 1.3.0))
26
+
(js_of_ocaml
27
+
(>= 6.0.1))
28
+
(js_of_ocaml-ppx
29
+
(>= 6.0.1))
30
+
(js_of_ocaml-toplevel
31
+
(>= 6.0.1))
32
+
(merlin-lib
33
+
(>= 5.2.1-502))
34
+
(ocamlformat-lib
35
+
(>= 0.27.0))
36
+
(ocamlfind
37
+
(>= 1.9.8))
38
+
(ppx_blob
39
+
(>= 0.9.0))))
40
+
41
+
(package
42
+
(name ppxlib_register)
43
+
(synopsis "Register PPX for js_of_ocaml-toplevel")
44
+
(depends
45
+
(ppxlib
46
+
(>= 0.33.0))))
+28
x-ocaml/ppxlib_register.opam
+28
x-ocaml/ppxlib_register.opam
···
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Register PPX for js_of_ocaml-toplevel"
4
+
maintainer: ["art.wendling@gmail.com"]
5
+
authors: ["Arthur Wendling"]
6
+
license: "MIT"
7
+
homepage: "https://github.com/art-w/x-ocaml"
8
+
bug-reports: "https://github.com/art-w/x-ocaml/issues"
9
+
depends: [
10
+
"dune" {>= "3.10"}
11
+
"ppxlib" {>= "0.33.0"}
12
+
"odoc" {with-doc}
13
+
]
14
+
build: [
15
+
["dune" "subst"] {dev}
16
+
[
17
+
"dune"
18
+
"build"
19
+
"-p"
20
+
name
21
+
"-j"
22
+
jobs
23
+
"@install"
24
+
"@runtest" {with-test}
25
+
"@doc" {with-doc}
26
+
]
27
+
]
28
+
dev-repo: "git+https://github.com/art-w/x-ocaml.git"
+3
x-ocaml/ppxlib_register/dune
+3
x-ocaml/ppxlib_register/dune
+18
x-ocaml/ppxlib_register/ppxlib_register.ml
+18
x-ocaml/ppxlib_register/ppxlib_register.ml
···
···
1
+
let mapper _argv =
2
+
let module Current_ast = Ppxlib_ast.Selected_ast in
3
+
let structure s =
4
+
match s with [] -> [] | _ -> Ppxlib.Driver.map_structure s
5
+
in
6
+
let structure _ st =
7
+
Current_ast.of_ocaml Structure st
8
+
|> structure
9
+
|> Current_ast.to_ocaml Structure
10
+
in
11
+
let signature _ si =
12
+
Current_ast.of_ocaml Signature si
13
+
|> Ppxlib.Driver.map_signature
14
+
|> Current_ast.to_ocaml Signature
15
+
in
16
+
{ Ast_mapper.default_mapper with structure; signature }
17
+
18
+
let () = Ast_mapper.register "ppxlib" mapper
+4
x-ocaml/protocol/dune
+4
x-ocaml/protocol/dune
+27
x-ocaml/protocol/x_protocol.ml
+27
x-ocaml/protocol/x_protocol.ml
···
···
1
+
module Merlin_protocol = Protocol
2
+
3
+
type id = int
4
+
5
+
type request =
6
+
| Merlin of id * Merlin_protocol.action
7
+
| Eval of id * int * string
8
+
| Format of id * string
9
+
| Format_config of string
10
+
| Setup
11
+
12
+
type output =
13
+
| Stdout of string
14
+
| Stderr of string
15
+
| Meta of string
16
+
| Html of string
17
+
18
+
type response =
19
+
| Merlin_response of id * Merlin_protocol.answer
20
+
| Top_response of id * output list
21
+
| Top_response_at of id * int * output list
22
+
| Formatted_source of id * string
23
+
24
+
let req_to_bytes (req : request) = Marshal.to_bytes req []
25
+
let resp_to_bytes (req : response) = Marshal.to_bytes req []
26
+
let req_of_bytes req : request = Marshal.from_bytes req 0
27
+
let resp_of_string resp : response = Marshal.from_string resp 0
+190
x-ocaml/src/cell.ml
+190
x-ocaml/src/cell.ml
···
···
1
+
open Brr
2
+
3
+
type status = Not_run | Running | Run_ok | Request_run
4
+
5
+
type t = {
6
+
id : int;
7
+
mutable prev : t option;
8
+
mutable next : t option;
9
+
mutable status : status;
10
+
cm : Editor.t;
11
+
worker : Client.t;
12
+
merlin_worker : Merlin_ext.Client.worker;
13
+
run_on : [ `Click | `Load ];
14
+
}
15
+
16
+
let id t = t.id
17
+
18
+
let pre_source t =
19
+
let rec go acc t =
20
+
match t.prev with
21
+
| None -> String.concat "\n" acc
22
+
| Some e -> go (Editor.source e.cm :: acc) e
23
+
in
24
+
let s = go [] t in
25
+
if s = "" then s else s ^ " ;;\n"
26
+
27
+
let rec invalidate_from ~editor =
28
+
editor.status <- Not_run;
29
+
Editor.clear editor.cm;
30
+
let count = Editor.nb_lines editor.cm in
31
+
match editor.next with
32
+
| None -> ()
33
+
| Some editor ->
34
+
Editor.set_previous_lines editor.cm count;
35
+
invalidate_from ~editor
36
+
37
+
let invalidate_after ~editor =
38
+
editor.status <- Not_run;
39
+
let count = Editor.nb_lines editor.cm in
40
+
match editor.next with
41
+
| None -> ()
42
+
| Some editor ->
43
+
Editor.set_previous_lines editor.cm count;
44
+
invalidate_from ~editor
45
+
46
+
let rec refresh_lines_from ~editor =
47
+
let count = Editor.nb_lines editor.cm in
48
+
match editor.next with
49
+
| None -> ()
50
+
| Some editor ->
51
+
Editor.set_previous_lines editor.cm count;
52
+
refresh_lines_from ~editor
53
+
54
+
let rec run editor =
55
+
if editor.status = Running then ()
56
+
else (
57
+
editor.status <- Request_run;
58
+
Editor.clear_messages editor.cm;
59
+
match editor.prev with
60
+
| Some e when e.status <> Run_ok -> run e
61
+
| _ ->
62
+
editor.status <- Running;
63
+
let code_txt = Editor.source editor.cm in
64
+
let line_number = 1 + Editor.get_previous_lines editor.cm in
65
+
Client.eval ~id:editor.id ~line_number editor.worker code_txt)
66
+
67
+
let set_prev ~prev t =
68
+
let () = match t.prev with None -> () | Some prev -> prev.next <- None in
69
+
t.prev <- prev;
70
+
match prev with
71
+
| None ->
72
+
Editor.set_previous_lines t.cm 0;
73
+
refresh_lines_from ~editor:t
74
+
| Some p ->
75
+
assert (p.next = None);
76
+
p.next <- Some t;
77
+
refresh_lines_from ~editor:p
78
+
79
+
let set_source_from_html editor this =
80
+
let doc = Webcomponent.text_content this in
81
+
let doc = String.trim doc in
82
+
Editor.set_source editor.cm doc;
83
+
invalidate_from ~editor;
84
+
Client.fmt ~id:editor.id editor.worker doc
85
+
86
+
let init_css shadow ~extra_style ~inline_style =
87
+
El.append_children shadow
88
+
[
89
+
El.style
90
+
(El.txt (Jstr.of_string [%blob "style.css"])
91
+
::
92
+
(match inline_style with
93
+
| None -> []
94
+
| Some inline_style ->
95
+
[
96
+
El.txt
97
+
@@ Jstr.of_string (":host{" ^ Jstr.to_string inline_style ^ "}");
98
+
]));
99
+
];
100
+
match extra_style with
101
+
| None -> ()
102
+
| Some src_style ->
103
+
El.append_children shadow
104
+
[
105
+
El.link
106
+
~at:
107
+
[
108
+
At.href src_style;
109
+
At.rel (Jstr.of_string "stylesheet");
110
+
At.type' (Jstr.of_string "text/css");
111
+
]
112
+
();
113
+
]
114
+
115
+
let init ~id ~run_on ?extra_style ?inline_style worker this =
116
+
let shadow = Webcomponent.attach_shadow this in
117
+
init_css shadow ~extra_style ~inline_style;
118
+
119
+
let run_btn = El.button [ El.txt (Jstr.of_string "Run") ] in
120
+
El.append_children shadow
121
+
[ El.div ~at:[ At.class' (Jstr.of_string "run_btn") ] [ run_btn ] ];
122
+
123
+
let cm = Editor.make shadow in
124
+
125
+
let merlin = Merlin_ext.make ~id worker in
126
+
let merlin_worker = Merlin_ext.Client.make_worker merlin in
127
+
let editor =
128
+
{
129
+
id;
130
+
status = Not_run;
131
+
cm;
132
+
prev = None;
133
+
next = None;
134
+
worker;
135
+
merlin_worker;
136
+
run_on;
137
+
}
138
+
in
139
+
Editor.on_change cm (fun () -> invalidate_after ~editor);
140
+
set_source_from_html editor this;
141
+
142
+
Merlin_ext.set_context merlin (fun () -> pre_source editor);
143
+
Editor.configure_merlin cm (fun () -> Merlin_ext.extensions merlin_worker);
144
+
145
+
let () =
146
+
Mutation_observer.observe ~target:(Webcomponent.as_target this)
147
+
@@ Mutation_observer.create (fun _ _ -> set_source_from_html editor this)
148
+
in
149
+
150
+
let _ : Ev.listener =
151
+
Ev.listen Ev.click (fun _ev -> run editor) (El.as_target run_btn)
152
+
in
153
+
154
+
editor
155
+
156
+
let set_source editor doc =
157
+
Editor.set_source editor.cm doc;
158
+
refresh_lines_from ~editor
159
+
160
+
let render_message msg =
161
+
let raw_html s =
162
+
let el = El.div [] in
163
+
let el_t = El.to_jv el in
164
+
Jv.set el_t "innerHTML" (Jv.of_jstr @@ Jstr.of_string s);
165
+
el
166
+
in
167
+
let kind, text =
168
+
match msg with
169
+
| X_protocol.Stdout str -> ("stdout", El.txt' str)
170
+
| Stderr str -> ("stderr", El.txt' str)
171
+
| Meta str -> ("meta", El.txt' str)
172
+
| Html str -> ("html", raw_html str)
173
+
in
174
+
El.pre ~at:[ At.class' (Jstr.of_string ("caml_" ^ kind)) ] [ text ]
175
+
176
+
let add_message t loc msg =
177
+
Editor.add_message t.cm loc (List.map render_message msg)
178
+
179
+
let completed_run ed msg =
180
+
(if msg <> [] then
181
+
let loc = String.length (Editor.source ed.cm) in
182
+
add_message ed loc msg);
183
+
ed.status <- Run_ok;
184
+
match ed.next with Some e when e.status = Request_run -> run e | _ -> ()
185
+
186
+
let receive_merlin t msg =
187
+
Merlin_ext.Client.on_message t.merlin_worker
188
+
(Merlin_ext.fix_answer ~pre:(pre_source t) ~doc:(Editor.source t.cm) msg)
189
+
190
+
let loadable t = t.run_on = `Load
+19
x-ocaml/src/cell.mli
+19
x-ocaml/src/cell.mli
···
···
1
+
type t
2
+
3
+
val init :
4
+
id:int ->
5
+
run_on:[ `Click | `Load ] ->
6
+
?extra_style:Jstr.t ->
7
+
?inline_style:Jstr.t ->
8
+
Client.t ->
9
+
Webcomponent.t ->
10
+
t
11
+
12
+
val id : t -> int
13
+
val set_source : t -> string -> unit
14
+
val add_message : t -> int -> X_protocol.output list -> unit
15
+
val completed_run : t -> X_protocol.output list -> unit
16
+
val set_prev : prev:t option -> t -> unit
17
+
val receive_merlin : t -> Protocol.answer -> unit
18
+
val loadable : t -> bool
19
+
val run : t -> unit
+63
x-ocaml/src/client.ml
+63
x-ocaml/src/client.ml
···
···
1
+
module Worker = Brr_webworkers.Worker
2
+
open Brr
3
+
4
+
type t = Worker.t
5
+
6
+
let current_url =
7
+
let url = Window.location G.window in
8
+
let path = Jstr.to_string (Uri.path url) in
9
+
let url =
10
+
match List.rev (String.split_on_char '/' path) with
11
+
| [] | "" :: _ -> url
12
+
| _ :: rev_path -> (
13
+
let path = Jstr.of_string @@ String.concat "/" @@ List.rev rev_path in
14
+
match Uri.with_uri ~path ~query:Jstr.empty ~fragment:Jstr.empty url with
15
+
| Ok url -> url
16
+
| Error _ -> url)
17
+
in
18
+
Jstr.to_string (Uri.to_jstr url)
19
+
20
+
let absolute_url url =
21
+
if
22
+
not
23
+
(String.starts_with ~prefix:"http:" url
24
+
|| String.starts_with ~prefix:"https:" url)
25
+
then current_url ^ url
26
+
else url
27
+
28
+
let wrap_url ?extra_load url =
29
+
let url = absolute_url url in
30
+
let extra =
31
+
match extra_load with
32
+
| None -> ""
33
+
| Some extra -> "','" ^ absolute_url extra
34
+
in
35
+
let script = "importScripts('" ^ url ^ extra ^ "');" in
36
+
let script = Jstr.of_string script in
37
+
let url =
38
+
match Base64.(encode (data_of_binary_jstr script)) with
39
+
| Ok data -> Jstr.to_string data
40
+
| Error _ -> assert false
41
+
in
42
+
"data:text/javascript;base64," ^ url
43
+
44
+
let make ?extra_load url =
45
+
Worker.create @@ Jstr.of_string @@ wrap_url ?extra_load url
46
+
47
+
let on_message t fn =
48
+
let fn m =
49
+
let m = Ev.as_type m in
50
+
let msg = Bytes.to_string @@ Brr_io.Message.Ev.data m in
51
+
fn (X_protocol.resp_of_string msg)
52
+
in
53
+
let _listener =
54
+
Ev.listen Brr_io.Message.Ev.message fn @@ Worker.as_target t
55
+
in
56
+
()
57
+
58
+
let post worker msg = Worker.post worker (X_protocol.req_to_bytes msg)
59
+
60
+
let eval ~id ~line_number worker code =
61
+
post worker (Eval (id, line_number, code))
62
+
63
+
let fmt ~id worker code = post worker (Format (id, code))
+7
x-ocaml/src/client.mli
+7
x-ocaml/src/client.mli
+13
x-ocaml/src/dune
+13
x-ocaml/src/dune
+161
x-ocaml/src/editor.ml
+161
x-ocaml/src/editor.ml
···
···
1
+
type t = {
2
+
view : Code_mirror.Editor.View.t;
3
+
messages_comp : Code_mirror.Compartment.t;
4
+
lines_comp : Code_mirror.Compartment.t;
5
+
merlin_comp : Code_mirror.Compartment.t;
6
+
mutable merlin_extension : unit -> Code_mirror.Extension.t list;
7
+
changes : Code_mirror.Compartment.t;
8
+
mutable previous_lines : int;
9
+
mutable current_doc : string;
10
+
mutable messages : (int * Brr.El.t list) list;
11
+
}
12
+
13
+
let find_line_ends at doc =
14
+
let rec go i =
15
+
if i >= String.length doc || doc.[i] = '\n' then i else go (i + 1)
16
+
in
17
+
go at
18
+
19
+
let render_messages cm =
20
+
let open Code_mirror.Editor in
21
+
let open Code_mirror.Decoration in
22
+
let (State.Facet ((module F), it)) = View.decorations () in
23
+
let doc = cm.current_doc in
24
+
let ranges =
25
+
Array.of_list
26
+
@@ List.map (fun (at, msg) ->
27
+
range ~from:at ~to_:at
28
+
@@ widget ~block:true ~side:99
29
+
@@ Widget.make (fun () -> msg))
30
+
@@ List.filter (fun (at, _) -> at <= String.length doc)
31
+
@@ List.map (fun (at, msg) ->
32
+
let at = find_line_ends at doc in
33
+
(at, msg))
34
+
@@ List.concat
35
+
@@ List.map (fun (loc, lst) -> List.map (fun m -> (loc, m)) lst)
36
+
@@ List.sort (fun (a, _) (b, _) -> Int.compare a b) cm.messages
37
+
in
38
+
F.of_ it (Range_set.of' ranges)
39
+
40
+
let refresh_messages ed =
41
+
Code_mirror.Editor.View.dispatch ed.view
42
+
(Code_mirror.Compartment.reconfigure ed.messages_comp
43
+
[ render_messages ed ])
44
+
45
+
let custom_ln editor =
46
+
Code_mirror.Editor.View.line_numbers (fun x ->
47
+
string_of_int (editor.previous_lines + x))
48
+
49
+
let refresh_lines ed =
50
+
Code_mirror.Editor.View.dispatch ed.view
51
+
@@ Code_mirror.Compartment.reconfigure ed.lines_comp [ custom_ln ed ]
52
+
53
+
let refresh_merlin ed =
54
+
Code_mirror.Editor.View.dispatch ed.view
55
+
@@ Code_mirror.Compartment.reconfigure ed.merlin_comp (ed.merlin_extension ())
56
+
57
+
let configure_merlin ed extension =
58
+
ed.merlin_extension <- extension;
59
+
refresh_merlin ed
60
+
61
+
let clear x =
62
+
x.messages <- [];
63
+
refresh_lines x;
64
+
refresh_messages x;
65
+
refresh_merlin x
66
+
67
+
let source_of_state s =
68
+
String.concat "\n" @@ Array.to_list @@ Array.map Jstr.to_string
69
+
@@ Code_mirror.Text.to_jstr_array
70
+
@@ Code_mirror.Editor.State.doc s
71
+
72
+
let source t = source_of_state @@ Code_mirror.Editor.View.state t.view
73
+
74
+
let prefix_length a b =
75
+
let rec go i =
76
+
if i >= String.length a || i >= String.length b || a.[i] <> b.[i] then i
77
+
else go (i + 1)
78
+
in
79
+
go 0
80
+
81
+
let basic_setup =
82
+
Jv.get Jv.global "__CM__basic_setup" |> Code_mirror.Extension.of_jv
83
+
84
+
let make parent =
85
+
let open Code_mirror.Editor in
86
+
let changes = Code_mirror.Compartment.make () in
87
+
let messages = Code_mirror.Compartment.make () in
88
+
let lines = Code_mirror.Compartment.make () in
89
+
let merlin = Code_mirror.Compartment.make () in
90
+
let extensions =
91
+
[|
92
+
basic_setup;
93
+
Code_mirror.Editor.View.line_wrapping ();
94
+
Code_mirror.Compartment.of' lines [];
95
+
Code_mirror.Compartment.of' messages [];
96
+
Code_mirror.Compartment.of' changes [];
97
+
Code_mirror.Compartment.of' merlin [];
98
+
|]
99
+
in
100
+
let config = State.Config.create ~doc:Jstr.empty ~extensions () in
101
+
let state = State.create ~config () in
102
+
let opts = View.opts ~state ~parent () in
103
+
let view = View.create ~opts () in
104
+
{
105
+
previous_lines = 0;
106
+
current_doc = "";
107
+
messages = [];
108
+
view;
109
+
messages_comp = messages;
110
+
lines_comp = lines;
111
+
merlin_comp = merlin;
112
+
merlin_extension = (fun () -> []);
113
+
changes;
114
+
}
115
+
116
+
let set_current_doc t new_doc =
117
+
let at = prefix_length t.current_doc new_doc in
118
+
t.current_doc <- new_doc;
119
+
t.messages <- List.filter (fun (loc, _) -> loc < at) t.messages;
120
+
refresh_messages t
121
+
122
+
let on_change cm fn =
123
+
let has_changed =
124
+
let open Code_mirror.Editor in
125
+
let (State.Facet ((module F), it)) = View.update_listener () in
126
+
F.of_ it (fun ev ->
127
+
if View.Update.doc_changed ev then
128
+
let new_doc = source_of_state (View.Update.state ev) in
129
+
if not (String.equal cm.current_doc new_doc) then (
130
+
set_current_doc cm new_doc;
131
+
fn ()))
132
+
in
133
+
Code_mirror.Editor.View.dispatch cm.view
134
+
@@ Code_mirror.Compartment.reconfigure cm.changes [ has_changed ]
135
+
136
+
let count_lines str =
137
+
if str = "" then 0
138
+
else
139
+
let nb = ref 1 in
140
+
for i = 0 to String.length str - 1 do
141
+
if str.[i] = '\n' then incr nb
142
+
done;
143
+
!nb
144
+
145
+
let nb_lines t = t.previous_lines + count_lines t.current_doc
146
+
let get_previous_lines t = t.previous_lines
147
+
148
+
let set_previous_lines t nb =
149
+
t.previous_lines <- nb;
150
+
refresh_lines t
151
+
152
+
let set_messages t msg =
153
+
t.messages <- msg;
154
+
refresh_messages t
155
+
156
+
let clear_messages t = set_messages t []
157
+
let add_message t loc msg = set_messages t ((loc, msg) :: t.messages)
158
+
159
+
let set_source t doc =
160
+
set_current_doc t doc;
161
+
Code_mirror.Editor.View.set_doc t.view (Jstr.of_string doc)
+13
x-ocaml/src/editor.mli
+13
x-ocaml/src/editor.mli
···
···
1
+
type t
2
+
3
+
val make : Brr.El.t -> t
4
+
val source : t -> string
5
+
val set_source : t -> string -> unit
6
+
val clear : t -> unit
7
+
val nb_lines : t -> int
8
+
val get_previous_lines : t -> int
9
+
val set_previous_lines : t -> int -> unit
10
+
val clear_messages : t -> unit
11
+
val add_message : t -> int -> Brr.El.t list -> unit
12
+
val on_change : t -> (unit -> unit) -> unit
13
+
val configure_merlin : t -> (unit -> Code_mirror.Extension.t list) -> unit
+73
x-ocaml/src/merlin_ext.ml
+73
x-ocaml/src/merlin_ext.ml
···
···
1
+
module Worker = Brr_webworkers.Worker
2
+
3
+
type t = { id : int; mutable context : unit -> string; client : Client.t }
4
+
5
+
let set_context t fn = t.context <- fn
6
+
7
+
let make ~id client =
8
+
{ id; context = (fun () -> failwith "Merlin_ext.context"); client }
9
+
10
+
let fix_position pre_len = function
11
+
| `Offset at -> `Offset (at + pre_len)
12
+
| other -> other
13
+
14
+
let fix_loc pre_len ({ loc_start; loc_end; _ } as loc : Protocol.Location.t) =
15
+
{
16
+
loc with
17
+
loc_start = { loc_start with pos_cnum = loc_start.pos_cnum - pre_len };
18
+
loc_end = { loc_end with pos_cnum = loc_end.pos_cnum - pre_len };
19
+
}
20
+
21
+
let fix_request t msg =
22
+
let pre = t.context () in
23
+
let pre_len = String.length pre in
24
+
match msg with
25
+
| Protocol.Complete_prefix (src, position) ->
26
+
let position = fix_position pre_len position in
27
+
Protocol.Complete_prefix (pre ^ src, position)
28
+
| Protocol.Type_enclosing (src, position) ->
29
+
let position = fix_position pre_len position in
30
+
Protocol.Type_enclosing (pre ^ src, position)
31
+
| Protocol.All_errors src -> Protocol.All_errors (pre ^ src)
32
+
| Protocol.Add_cmis _ as other -> other
33
+
34
+
let fix_answer ~pre ~doc msg =
35
+
let pre_len = String.length pre in
36
+
match (msg : Protocol.answer) with
37
+
| Protocol.Errors errors ->
38
+
Protocol.Errors
39
+
(List.filter_map
40
+
(fun (e : Protocol.error) ->
41
+
let loc = fix_loc pre_len e.loc in
42
+
let from = loc.loc_start.pos_cnum in
43
+
let to_ = loc.loc_end.pos_cnum in
44
+
if from < 0 || to_ > String.length doc then None
45
+
else Some { e with loc })
46
+
errors)
47
+
| Protocol.Completions completions ->
48
+
Completions
49
+
{
50
+
completions with
51
+
from = completions.from - pre_len;
52
+
to_ = completions.to_ - pre_len;
53
+
}
54
+
| Protocol.Typed_enclosings typed_enclosings ->
55
+
Typed_enclosings
56
+
(List.map
57
+
(fun (loc, a, b) -> (fix_loc pre_len loc, a, b))
58
+
typed_enclosings)
59
+
| Protocol.Added_cmis -> msg
60
+
61
+
module Merlin_send = struct
62
+
type nonrec t = t
63
+
64
+
let post t msg =
65
+
let msg = fix_request t msg in
66
+
Client.post t.client (Merlin (t.id, msg))
67
+
end
68
+
69
+
module Client = Merlin_client.Make (Merlin_send)
70
+
module Ed = Merlin_codemirror.Extensions (Merlin_send)
71
+
72
+
let extensions t =
73
+
Merlin_codemirror.ocaml :: Array.to_list (Ed.all_extensions t)
+21
x-ocaml/src/mutation_observer.ml
+21
x-ocaml/src/mutation_observer.ml
···
···
1
+
open Brr
2
+
3
+
type t = Jv.t
4
+
5
+
let mutation_observer = Jv.get Jv.global "MutationObserver"
6
+
7
+
let create callback =
8
+
let callback = Jv.callback ~arity:2 callback in
9
+
Jv.new' mutation_observer [| callback |]
10
+
11
+
let disconnect t =
12
+
let _ : Jv.t = Jv.call t "disconnect" [||] in
13
+
()
14
+
15
+
let observe t ~target =
16
+
let config =
17
+
Jv.obj
18
+
Jv.[| ("attributes", true'); ("childList", true'); ("subtree", true') |]
19
+
in
20
+
let _ : Jv.t = Jv.call t "observe" [| El.to_jv target; config |] in
21
+
()
+7
x-ocaml/src/mutation_observer.mli
+7
x-ocaml/src/mutation_observer.mli
+89
x-ocaml/src/style.css
+89
x-ocaml/src/style.css
···
···
1
+
:host { display: block; position: relative; font-family: monospace; font-size: 1.2em }
2
+
.cm-editor.cm-focused { outline: 1px dotted #AAA !important }
3
+
.cm-tooltip-section {
4
+
max-width: 400px;
5
+
height: 1lh;
6
+
text-overflow: ellipsis; /* not working, because width/height must be px(?) */
7
+
padding: 0.3em 0.5em;
8
+
overflow: hidden;
9
+
}
10
+
.cm-lineNumbers { min-width: 30px }
11
+
.cm-activeLine, .cm-activeLineGutter { background: transparent !important }
12
+
.cm-focused .cm-activeLine,
13
+
.cm-focused .cm-activeLineGutter
14
+
{
15
+
background: #AAA2 !important;
16
+
}
17
+
18
+
.run_btn {
19
+
position: absolute; width: 100%; height: 100%; z-index: 999; pointer-events: none
20
+
}
21
+
.run_btn button {
22
+
pointer-events: auto;
23
+
position: absolute; right: 0; top: 0;
24
+
display: block;
25
+
cursor: pointer;
26
+
display: inline-block;
27
+
--radius: calc(0.5rem + 4px);
28
+
box-sizing: border-box;
29
+
min-width: calc(2 * var(--radius));
30
+
height: calc(2 * var(--radius));
31
+
padding-left: 0.4rem;
32
+
padding-right: 0.4rem;
33
+
background-color: #F5F5F5;
34
+
border: 1px solid #6D6D6D;
35
+
color: #6D6D6D;
36
+
}
37
+
.run_btn button:hover { background-color: #6D6D6D; color: #F5F5F5; }
38
+
.run_btn button:hover::after { border-color: transparent transparent transparent #F5F5F5; }
39
+
.run_btn button::after {
40
+
content: "";
41
+
display: inline-block;
42
+
position: relative;
43
+
left: 0;
44
+
top: 1px;
45
+
margin-left: 0.4rem;
46
+
box-sizing: border-box;
47
+
--radius: 0.35rem;
48
+
width: calc(2 * var(--radius));
49
+
height: calc(2 * var(--radius));
50
+
border-color: transparent transparent transparent #6D6D6D;
51
+
border-style: solid;
52
+
border-width: var(--radius) 0 var(--radius) calc(2 * var(--radius));
53
+
}
54
+
55
+
.caml_stdout {
56
+
background: #E8F6FF;
57
+
color: #141A6A;
58
+
margin: 0;
59
+
padding: 0.2em 0.2em;
60
+
padding-left: 0.7em;
61
+
}
62
+
.caml_stderr {
63
+
background: #FDEEEE;
64
+
color: #EB5656;
65
+
margin: 0;
66
+
padding: 0.2em 0.2em;
67
+
padding-left: 0.7em;
68
+
}
69
+
.caml_meta {
70
+
margin: 0;
71
+
padding: 0.2em 0.5em;
72
+
font-style: italic;
73
+
color: #444;
74
+
padding-bottom: 0.5em;
75
+
background: #eee;
76
+
}
77
+
.caml_html {
78
+
margin: 0;
79
+
padding: 0.2em 0.5em;
80
+
color: black;
81
+
border: 1px solid transparent;
82
+
white-space: collapse;
83
+
}
84
+
85
+
table, tr, td, th {
86
+
border: 1px solid black;
87
+
border-collapse: collapse;
88
+
padding: 0.2em;
89
+
}
+36
x-ocaml/src/webcomponent.ml
+36
x-ocaml/src/webcomponent.ml
···
···
1
+
let reflect = Jv.get Jv.global "Reflect"
2
+
let html_element = Jv.get Jv.global "HTMLElement"
3
+
4
+
external jv_pure_js_expr : string -> 'a = "caml_pure_js_expr"
5
+
6
+
let custom_elements = Jv.get Jv.global "customElements"
7
+
8
+
type t = Jv.t
9
+
10
+
let define name fn =
11
+
let rec test =
12
+
lazy
13
+
(Jv.callback ~arity:1 (fun () ->
14
+
Jv.call reflect "construct"
15
+
[| html_element; Jv.Jarray.create 0; Lazy.force test |]))
16
+
in
17
+
let test = Lazy.force test in
18
+
Jv.set test "prototype" (Jv.get html_element "prototype");
19
+
Jv.set Jv.global "__xocaml_exported" (Jv.callback ~arity:1 fn);
20
+
Jv.set (Jv.get test "prototype") "connectedCallback"
21
+
(jv_pure_js_expr
22
+
"(function() { setTimeout(() => __xocaml_exported(this), 0) })");
23
+
let _ : Jv.t = Jv.call custom_elements "define" [| Jv.of_jstr name; test |] in
24
+
()
25
+
26
+
let text_content t = Jstr.to_string @@ Jv.to_jstr @@ Jv.get t "textContent"
27
+
let as_target t = Brr.El.of_jv t
28
+
29
+
let get_attribute t name =
30
+
let attr = Jv.call t "getAttribute" [| Jv.of_string name |] in
31
+
Jv.to_option Jv.to_string attr
32
+
33
+
let attach_shadow t =
34
+
Brr.El.of_jv
35
+
@@ Jv.call t "attachShadow"
36
+
[| Jv.obj [| ("mode", Jv.of_jstr @@ Jstr.of_string "open") |] |]
+7
x-ocaml/src/webcomponent.mli
+7
x-ocaml/src/webcomponent.mli
+60
x-ocaml/src/x_ocaml.ml
+60
x-ocaml/src/x_ocaml.ml
···
···
1
+
let all : Cell.t list ref = ref []
2
+
let find_by_id id = List.find (fun t -> Cell.id t = id) !all
3
+
4
+
let current_script =
5
+
Brr.El.of_jv (Jv.get (Brr.Document.to_jv Brr.G.document) "currentScript")
6
+
7
+
let current_attribute attr = Brr.El.at (Jstr.of_string attr) current_script
8
+
9
+
let extra_load =
10
+
match current_attribute "src-load" with
11
+
| None -> None
12
+
| Some url -> Some (Jstr.to_string url)
13
+
14
+
let worker_url =
15
+
match current_attribute "src-worker" with
16
+
| None -> failwith "x-ocaml script missing src-worker attribute"
17
+
| Some url -> Jstr.to_string url
18
+
19
+
let worker = Client.make ?extra_load worker_url
20
+
21
+
let () =
22
+
Client.on_message worker @@ function
23
+
| Formatted_source (id, code_fmt) -> Cell.set_source (find_by_id id) code_fmt
24
+
| Top_response_at (id, loc, msg) -> Cell.add_message (find_by_id id) loc msg
25
+
| Top_response (id, msg) -> Cell.completed_run (find_by_id id) msg
26
+
| Merlin_response (id, msg) -> Cell.receive_merlin (find_by_id id) msg
27
+
28
+
let () = Client.post worker Setup
29
+
30
+
let () =
31
+
match current_attribute "x-ocamlformat" with
32
+
| None -> ()
33
+
| Some conf -> Client.post worker (Format_config (Jstr.to_string conf))
34
+
35
+
let elt_name =
36
+
match current_attribute "elt-name" with
37
+
| None -> Jstr.of_string "x-ocaml"
38
+
| Some name -> name
39
+
40
+
let extra_style = current_attribute "src-style"
41
+
let inline_style = current_attribute "inline-style"
42
+
let run_on = current_attribute "run-on" |> Option.map Jstr.to_string
43
+
let run_on_of_string = function "click" -> `Click | "load" | _ -> `Load
44
+
45
+
let _ =
46
+
Webcomponent.define elt_name @@ fun this ->
47
+
let prev = match !all with [] -> None | e :: _ -> Some e in
48
+
let run_on =
49
+
run_on_of_string
50
+
@@
51
+
match Webcomponent.get_attribute this "run-on" with
52
+
| Some s -> s
53
+
| None -> Option.value ~default:"load" run_on
54
+
in
55
+
let id = List.length !all in
56
+
let editor = Cell.init ~id ~run_on ?extra_style ?inline_style worker this in
57
+
all := editor :: !all;
58
+
Cell.set_prev ~prev editor;
59
+
if List.for_all Cell.loadable !all then Cell.run editor;
60
+
()
+4
x-ocaml/worker-lib/dune
+4
x-ocaml/worker-lib/dune
+8
x-ocaml/worker-lib/x_ocaml_lib.ml
+8
x-ocaml/worker-lib/x_ocaml_lib.ml
+5
x-ocaml/worker-lib/x_ocaml_lib.mli
+5
x-ocaml/worker-lib/x_ocaml_lib.mli
+33
x-ocaml/worker/dune
+33
x-ocaml/worker/dune
···
···
1
+
(library
2
+
(name x_worker)
3
+
(libraries
4
+
brr
5
+
js_of_ocaml
6
+
js_of_ocaml-toplevel
7
+
x-ocaml.protocol
8
+
x-ocaml.lib
9
+
merlin-js.worker
10
+
ocamlformat-lib
11
+
ocamlformat-lib.parser_extended
12
+
ocamlformat-lib.format_))
13
+
14
+
(rule
15
+
(targets export.txt)
16
+
(deps export-stdlib.txt)
17
+
(action
18
+
(with-stdout-to
19
+
%{targets}
20
+
(progn
21
+
(cat %{deps})
22
+
(echo "Ast_mapper\n")
23
+
(echo "X_ocaml_lib\n")))))
24
+
25
+
(rule
26
+
(target export-stdlib.txt)
27
+
(action
28
+
(run
29
+
jsoo_listunits
30
+
-o
31
+
%{target}
32
+
stdlib
33
+
%{dep:../worker-lib/x_ocaml_lib.cma})))
+10
x-ocaml/worker/effects/dune
+10
x-ocaml/worker/effects/dune
+5
x-ocaml/worker/effects/x_worker.ml
+5
x-ocaml/worker/effects/x_worker.ml
+143
x-ocaml/worker/eval.ml
+143
x-ocaml/worker/eval.ml
···
···
1
+
open Js_of_ocaml_toplevel
2
+
open X_protocol
3
+
4
+
module Value_env : sig
5
+
type t
6
+
7
+
val empty : t
8
+
val capture : t -> Ident.t list -> t
9
+
val restore : t -> unit
10
+
end = struct
11
+
module String_map = Map.Make (String)
12
+
13
+
type t = Obj.t String_map.t
14
+
15
+
let empty = String_map.empty
16
+
17
+
let capture t idents =
18
+
List.fold_left
19
+
(fun t ident ->
20
+
let name = Translmod.toplevel_name ident in
21
+
let v = Topeval.getvalue name in
22
+
String_map.add name v t)
23
+
t idents
24
+
25
+
let restore t = String_map.iter (fun name v -> Topeval.setvalue name v) t
26
+
end
27
+
28
+
module Environment = struct
29
+
let environments = ref []
30
+
let init () = environments := [ (0, !Toploop.toplevel_env, Value_env.empty) ]
31
+
32
+
let reset id =
33
+
let rec go id = function
34
+
| [] -> failwith ("no environment " ^ string_of_int id)
35
+
| (id', _, _) :: xs when id' >= id && xs <> [] -> go id xs
36
+
| ((_, typing_env, value_env) as x) :: xs ->
37
+
Toploop.toplevel_env := typing_env;
38
+
Value_env.restore value_env;
39
+
x :: xs
40
+
in
41
+
environments := go id !environments
42
+
43
+
let capture id =
44
+
let values =
45
+
match !environments with
46
+
| [] -> invalid_arg "empty environment"
47
+
| (_, previous_env, previous_values) :: _ ->
48
+
let idents = Env.diff previous_env !Toploop.toplevel_env in
49
+
Value_env.capture previous_values idents
50
+
in
51
+
environments := (id, !Toploop.toplevel_env, values) :: !environments
52
+
end
53
+
54
+
let setup_toplevel () =
55
+
let _ = JsooTop.initialize () in
56
+
Sys.interactive := false;
57
+
Environment.init ()
58
+
59
+
let rec parse_use_file ~caml_ppf lex =
60
+
let _at = lex.Lexing.lex_curr_pos in
61
+
match !Toploop.parse_toplevel_phrase lex with
62
+
| ok -> Ok ok :: parse_use_file ~caml_ppf lex
63
+
| exception End_of_file -> []
64
+
| exception err -> [ Error err ]
65
+
66
+
let ppx_rewriters = ref []
67
+
68
+
let preprocess_structure str =
69
+
let open Ast_mapper in
70
+
List.fold_right
71
+
(fun ppx_rewriter str ->
72
+
let mapper = ppx_rewriter [] in
73
+
mapper.structure mapper str)
74
+
!ppx_rewriters str
75
+
76
+
let preprocess_phrase phrase =
77
+
let open Parsetree in
78
+
match phrase with
79
+
| Ptop_def str -> Ptop_def (preprocess_structure str)
80
+
| Ptop_dir _ as x -> x
81
+
82
+
let execute ~id ~line_number ~output code_text =
83
+
Environment.reset id;
84
+
let outputs = ref [] in
85
+
let buf = Buffer.create 64 in
86
+
let caml_ppf = Format.formatter_of_buffer buf in
87
+
let content = code_text ^ " ;;" in
88
+
let lexer = Lexing.from_string content in
89
+
Lexing.set_position lexer
90
+
{ pos_fname = ""; pos_lnum = line_number; pos_bol = 0; pos_cnum = 0 };
91
+
let phrases = parse_use_file ~caml_ppf lexer in
92
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (fun str ->
93
+
outputs := Stdout str :: !outputs);
94
+
Js_of_ocaml.Sys_js.set_channel_flusher stderr (fun str ->
95
+
outputs := Stderr str :: !outputs);
96
+
let get_out () =
97
+
Format.pp_print_flush caml_ppf ();
98
+
let meta = Buffer.contents buf in
99
+
Buffer.clear buf;
100
+
let out = if meta = "" then !outputs else Meta meta :: !outputs in
101
+
outputs := [];
102
+
List.rev out
103
+
in
104
+
let respond ~(at_loc : Location.t) =
105
+
let loc = at_loc.loc_end.pos_cnum in
106
+
let out = get_out () in
107
+
output ~loc out
108
+
in
109
+
List.iter
110
+
(function
111
+
| Error err -> Errors.report_error caml_ppf err
112
+
| Ok phrase ->
113
+
let sub_phrases =
114
+
match phrase with
115
+
| Parsetree.Ptop_def s ->
116
+
List.map (fun s -> Parsetree.Ptop_def [ s ]) s
117
+
| Ptop_dir _ -> [ phrase ]
118
+
in
119
+
List.iter
120
+
(fun phrase ->
121
+
let at_loc =
122
+
match phrase with
123
+
| Parsetree.Ptop_def ({ pstr_loc = loc; _ } :: _) -> loc
124
+
| Ptop_dir { pdir_loc = loc; _ } -> loc
125
+
| _ -> assert false
126
+
in
127
+
X_ocaml_lib.id := (id, at_loc.loc_end.pos_cnum);
128
+
try
129
+
Location.reset ();
130
+
let phrase = preprocess_phrase phrase in
131
+
let _r = Toploop.execute_phrase true caml_ppf phrase in
132
+
respond ~at_loc
133
+
with _exn ->
134
+
Errors.report_error caml_ppf _exn;
135
+
respond ~at_loc)
136
+
sub_phrases)
137
+
phrases;
138
+
Environment.capture id;
139
+
get_out ()
140
+
141
+
let () =
142
+
Ast_mapper.register_function :=
143
+
fun _ f -> ppx_rewriters := f :: !ppx_rewriters
+8
x-ocaml/worker/eval.mli
+8
x-ocaml/worker/eval.mli
+6
x-ocaml/worker/no-effects/dune
+6
x-ocaml/worker/no-effects/dune
+1
x-ocaml/worker/no-effects/x_worker.ml
+1
x-ocaml/worker/no-effects/x_worker.ml
···
···
1
+
let () = X_worker.run ()
+68
x-ocaml/worker/ocamlfmt.ml
+68
x-ocaml/worker/ocamlfmt.ml
···
···
1
+
open Ocamlformat_stdlib
2
+
open Ocamlformat_lib
3
+
module Format_ = Ocamlformat_format.Format_
4
+
module Parser_extended = Ocamlformat_parser_extended
5
+
6
+
let default_conf = Ocamlformat_lib.Conf.default
7
+
8
+
let default_conf =
9
+
{
10
+
default_conf with
11
+
opr_opts =
12
+
{
13
+
default_conf.opr_opts with
14
+
ocaml_version = Conf.Elt.make (Ocaml_version.v 5 3) `Default;
15
+
};
16
+
}
17
+
18
+
let ghost_loc =
19
+
Ocamlformat_ocaml_common.Warnings.ghost_loc_in_file ".ocamlformat"
20
+
21
+
let parse_conf str =
22
+
List.fold_left
23
+
~f:(fun conf line ->
24
+
match Conf.parse_line conf ~from:(`File ghost_loc) line with
25
+
| Ok conf -> conf
26
+
| Error err ->
27
+
Brr.Console.error
28
+
[ "OCamlformat config error:"; line; Conf.Error.to_string err ];
29
+
conf)
30
+
~init:default_conf
31
+
(String.split_on_chars ~on:[ '\n' ] str)
32
+
33
+
let conf = ref (`Conf default_conf)
34
+
35
+
let configure = function
36
+
| "disable" -> conf := `Disable
37
+
| str -> conf := `Conf (parse_conf str)
38
+
39
+
let ast ~conf source =
40
+
Ocamlformat_lib.Parse_with_comments.parse
41
+
(Ocamlformat_lib.Parse_with_comments.parse_ast conf)
42
+
Structure conf ~input_name:"source" ~source
43
+
44
+
let fmt ~conf source =
45
+
let ast = ast ~conf source in
46
+
let with_buffer_formatter ~buffer_size k =
47
+
let buffer = Buffer.create buffer_size in
48
+
let fs = Format_.formatter_of_buffer buffer in
49
+
Fmt.eval fs k;
50
+
Format_.pp_print_flush fs ();
51
+
if Buffer.length buffer > 0 then Format_.pp_print_newline fs ();
52
+
Buffer.contents buffer
53
+
in
54
+
let print (ast : _ Parse_with_comments.with_comments) =
55
+
let open Fmt in
56
+
let debug = conf.opr_opts.debug.v in
57
+
with_buffer_formatter ~buffer_size:1000
58
+
(set_margin conf.fmt_opts.margin.v
59
+
$ set_max_indent conf.fmt_opts.max_indent.v
60
+
$ Fmt_ast.fmt_ast Structure ~debug ast.source
61
+
(Ocamlformat_lib.Cmts.init Structure ~debug ast.source ast.ast
62
+
ast.comments)
63
+
conf ast.ast)
64
+
in
65
+
String.strip (print ast)
66
+
67
+
let fmt source =
68
+
match !conf with `Disable -> source | `Conf conf -> fmt ~conf source
+27
x-ocaml/worker/x_worker.ml
+27
x-ocaml/worker/x_worker.ml
···
···
1
+
module Merlin_worker = Worker
2
+
3
+
let respond m = Js_of_ocaml.Worker.post_message (X_protocol.resp_to_bytes m)
4
+
5
+
let reformat ~id code =
6
+
let code' =
7
+
try Ocamlfmt.fmt code
8
+
with err ->
9
+
Brr.Console.error [ "OCamlformat error:"; Printexc.to_string err ];
10
+
code
11
+
in
12
+
if code <> code' then respond (Formatted_source (id, code'));
13
+
code'
14
+
15
+
let run () =
16
+
Js_of_ocaml.Worker.set_onmessage @@ fun marshaled_message ->
17
+
match X_protocol.req_of_bytes marshaled_message with
18
+
| Merlin (id, action) ->
19
+
respond (Merlin_response (id, Merlin_worker.on_message action))
20
+
| Format_config conf -> Ocamlfmt.configure conf
21
+
| Format (id, code) -> ignore (reformat ~id code : string)
22
+
| Eval (id, line_number, code) ->
23
+
let code = reformat ~id code in
24
+
let output ~loc out = respond (Top_response_at (id, loc, out)) in
25
+
let result = Eval.execute ~output ~id ~line_number code in
26
+
respond (Top_response (id, result))
27
+
| Setup -> Eval.setup_toplevel ()
+37
x-ocaml/x-ocaml.opam
+37
x-ocaml/x-ocaml.opam
···
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "OCaml notebooks as a WebComponent"
4
+
maintainer: ["art.wendling@gmail.com"]
5
+
authors: ["Arthur Wendling"]
6
+
license: "MIT"
7
+
homepage: "https://github.com/art-w/x-ocaml"
8
+
bug-reports: "https://github.com/art-w/x-ocaml/issues"
9
+
depends: [
10
+
"dune" {>= "3.10"}
11
+
"bos" {>= "0.2.1"}
12
+
"brr" {>= "0.0.7"}
13
+
"cmdliner" {>= "1.3.0"}
14
+
"js_of_ocaml" {>= "6.0.1"}
15
+
"js_of_ocaml-ppx" {>= "6.0.1"}
16
+
"js_of_ocaml-toplevel" {>= "6.0.1"}
17
+
"merlin-lib" {>= "5.2.1-502"}
18
+
"ocamlformat-lib" {>= "0.27.0"}
19
+
"ocamlfind" {>= "1.9.8"}
20
+
"ppx_blob" {>= "0.9.0"}
21
+
"odoc" {with-doc}
22
+
]
23
+
build: [
24
+
["dune" "subst"] {dev}
25
+
[
26
+
"dune"
27
+
"build"
28
+
"-p"
29
+
name
30
+
"-j"
31
+
jobs
32
+
"@install"
33
+
"@runtest" {with-test}
34
+
"@doc" {with-doc}
35
+
]
36
+
]
37
+
dev-repo: "git+https://github.com/art-w/x-ocaml.git"