jon.recoil.org
this repo has no description
prototype
+15
.gitignore
+15
.gitignore
+6
.gitmodules
+6
.gitmodules
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.27.0
+20
README.md
+20
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@1/x-ocaml.js"
6
+
src-worker="https://cdn.jsdelivr.net/gh/art-w/x-ocaml.js@1/x-ocaml.worker+effects.js"
7
+
></script>
8
+
```
9
+
10
+
This will introduce a new html tag `<x-ocaml>` to present OCaml code, for example:
11
+
12
+
```html
13
+
<x-ocaml>let x = 42</x-ocaml>
14
+
```
15
+
16
+
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.
17
+
18
+
## Acknowledgments
19
+
20
+
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
bin/dune
+5
bin/dune
+161
bin/x_ocaml.ml
+161
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 = { name : string; incl : Cmd.t; cma : string; ppx : bool }
33
+
34
+
let jsoo_compile ~effects t temp_file =
35
+
let toplevel = if t.ppx then Cmd.empty else Cmd.v "--toplevel" in
36
+
let cmd =
37
+
Cmd.(
38
+
v "js_of_ocaml" %% toplevel %% effects %% t.incl % t.cma % "-o"
39
+
% p temp_file)
40
+
in
41
+
let r = get_result @@ OS.Cmd.run_out cmd in
42
+
Format.printf "%s%!" r;
43
+
Result.get_ok @@ Bos.OS.File.read temp_file
44
+
45
+
let jsoo_export_cma ~effects t =
46
+
or_fail
47
+
@@ Bos.OS.File.with_tmp_output "x-ocaml.%s.js"
48
+
(fun temp_file _ () -> jsoo_compile ~effects t temp_file)
49
+
()
50
+
51
+
let ocamlfind_includes lib =
52
+
get_result
53
+
@@ OS.Cmd.run_out
54
+
Cmd.(
55
+
v "ocamlfind" % "query" % lib % "-i-format" % "-predicates" % "byte")
56
+
57
+
let ocamlfind_cma ~predicate lib =
58
+
get_result
59
+
@@ OS.Cmd.run_out
60
+
Cmd.(
61
+
v "ocamlfind" % "query" % lib % "-a-format" % "-predicates" % predicate)
62
+
63
+
let ocamlfind_deps ~predicate lib =
64
+
lines @@ get_result
65
+
@@ OS.Cmd.run_out
66
+
Cmd.(
67
+
v "ocamlfind" % "query" % lib % "-r" % "-p-format" % "-predicates"
68
+
% predicate)
69
+
70
+
module Env = Set.Make (String)
71
+
72
+
let make ~ppx ~predicate lib =
73
+
let cma = ocamlfind_cma ~predicate lib in
74
+
match lines cma with
75
+
| [] | [ "" ] ->
76
+
Format.printf "skip %s@." lib;
77
+
None
78
+
| [ cma ] ->
79
+
let incl = ocamlfind_includes lib in
80
+
let incl = or_fail @@ Cmd.of_string incl in
81
+
Some { incl; cma; ppx; name = lib }
82
+
| cmas ->
83
+
fatal
84
+
(Format.asprintf "expected one cma for %s, got %i" lib
85
+
(List.length cmas))
86
+
87
+
let dependencies ~ppx targets env =
88
+
let predicate = if ppx then "ppx_driver,byte" else "byte" in
89
+
let add =
90
+
List.fold_left (fun (env, all) lib ->
91
+
if Env.mem lib env then (env, all)
92
+
else
93
+
let env = Env.add lib env in
94
+
match make ~ppx ~predicate lib with
95
+
| None -> (env, all)
96
+
| Some t -> (env, t :: all))
97
+
in
98
+
let env, selection =
99
+
List.fold_left
100
+
(fun env target ->
101
+
let libs = ocamlfind_deps ~predicate target in
102
+
add env libs)
103
+
(env, []) targets
104
+
in
105
+
(env, List.rev selection)
106
+
107
+
let output_string output str =
108
+
output (Some (Bytes.of_string str, 0, String.length str))
109
+
110
+
let main effects targets ppxs output =
111
+
let effects =
112
+
if effects then Cmd.(v "--effects=cps" % "--enable=effect") else Cmd.empty
113
+
in
114
+
let targets =
115
+
match ppxs with
116
+
| [] -> targets
117
+
| _ -> targets @ ppxs @ [ "ppxlib_register" ]
118
+
in
119
+
let env = Env.empty in
120
+
let env, all_ppxs = dependencies ~ppx:true ppxs env in
121
+
let _env, all_libs = dependencies ~ppx:false targets env in
122
+
let all = all_ppxs @ all_libs in
123
+
or_fail @@ or_fail
124
+
@@ (fun f -> f ())
125
+
@@ Bos.OS.File.with_output (Fpath.v output)
126
+
@@ fun output () ->
127
+
let output = output_string output in
128
+
output jsoo_safe_import;
129
+
try
130
+
List.iter
131
+
(fun t ->
132
+
Format.printf "%s@." t.name;
133
+
let js = jsoo_export_cma ~effects t in
134
+
output js)
135
+
all;
136
+
Ok ()
137
+
with _ -> Error (`Msg "export failed")
138
+
139
+
open Cmdliner
140
+
141
+
let arg_output =
142
+
let open Arg in
143
+
required
144
+
& opt (some string) None
145
+
& info [ "o"; "output" ] ~docv:"OUTPUT" ~doc:"Output filename"
146
+
147
+
let with_effects =
148
+
let open Arg in
149
+
value & flag & info [ "effects" ] ~doc:"Enable effects"
150
+
151
+
let targets =
152
+
let open Arg in
153
+
non_empty & pos_all string [] & info []
154
+
155
+
let ppxs =
156
+
let open Arg in
157
+
value & opt_all string [] & info [ "p"; "ppx" ] ~docv:"PPX" ~doc:"PPX"
158
+
159
+
let main_term = Term.(const main $ with_effects $ targets $ ppxs $ arg_output)
160
+
let cmd_main = Cmd.v (Cmd.info "x-ocaml") main_term
161
+
let () = exit @@ Cmd.eval cmd_main
+22
dune
+22
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})))
+11
dune-project
+11
dune-project
+21
ppxlib_register.opam
+21
ppxlib_register.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
depends: [
4
+
"dune" {>= "3.10"}
5
+
"ppxlib"
6
+
"odoc" {with-doc}
7
+
]
8
+
build: [
9
+
["dune" "subst"] {dev}
10
+
[
11
+
"dune"
12
+
"build"
13
+
"-p"
14
+
name
15
+
"-j"
16
+
jobs
17
+
"@install"
18
+
"@runtest" {with-test}
19
+
"@doc" {with-doc}
20
+
]
21
+
]
+18
ppxlib_register/ppxlib_register.ml
+18
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
+22
protocol/x_protocol.ml
+22
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 * string
8
+
| Format of id * string
9
+
| Setup
10
+
11
+
type output = Stdout of string | Stderr of string | Meta of string
12
+
13
+
type response =
14
+
| Merlin_response of id * Merlin_protocol.answer
15
+
| Top_response of id * output list
16
+
| Top_response_at of id * int * output list
17
+
| Formatted_source of id * string
18
+
19
+
let req_to_bytes (req : request) = Marshal.to_bytes req []
20
+
let resp_to_bytes (req : response) = Marshal.to_bytes req []
21
+
let req_of_bytes req : request = Marshal.from_bytes req 0
22
+
let resp_of_string resp : response = Marshal.from_string resp 0
+154
src/cell.ml
+154
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
+
}
14
+
15
+
let id t = t.id
16
+
17
+
let pre_source t =
18
+
let rec go acc t =
19
+
match t.prev with
20
+
| None -> String.concat "\n" (List.rev acc)
21
+
| Some e -> go (Editor.source e.cm :: acc) e
22
+
in
23
+
let s = go [] t in
24
+
if s = "" then s else s ^ " ;;\n"
25
+
26
+
let rec invalidate_from ~editor =
27
+
editor.status <- Not_run;
28
+
Editor.clear editor.cm;
29
+
let count = Editor.nb_lines editor.cm in
30
+
match editor.next with
31
+
| None -> ()
32
+
| Some editor ->
33
+
Editor.set_previous_lines editor.cm count;
34
+
invalidate_from ~editor
35
+
36
+
let invalidate_after ~editor =
37
+
editor.status <- Not_run;
38
+
let count = Editor.nb_lines editor.cm in
39
+
match editor.next with
40
+
| None -> ()
41
+
| Some editor ->
42
+
Editor.set_previous_lines editor.cm count;
43
+
invalidate_from ~editor
44
+
45
+
let rec refresh_lines_from ~editor =
46
+
let count = Editor.nb_lines editor.cm in
47
+
match editor.next with
48
+
| None -> ()
49
+
| Some editor ->
50
+
Editor.set_previous_lines editor.cm count;
51
+
refresh_lines_from ~editor
52
+
53
+
let rec run editor =
54
+
if editor.status = Running then ()
55
+
else (
56
+
editor.status <- Request_run;
57
+
Editor.clear_messages editor.cm;
58
+
match editor.prev with
59
+
| Some e when e.status <> Run_ok -> run e
60
+
| _ ->
61
+
editor.status <- Running;
62
+
let code_txt = Editor.source editor.cm in
63
+
Client.eval ~id:editor.id editor.worker code_txt)
64
+
65
+
let set_prev ~prev t =
66
+
let () = match t.prev with None -> () | Some prev -> prev.next <- None in
67
+
t.prev <- prev;
68
+
match prev with
69
+
| None ->
70
+
Editor.set_previous_lines t.cm 0;
71
+
refresh_lines_from ~editor:t;
72
+
run t
73
+
| Some p ->
74
+
assert (p.next = None);
75
+
p.next <- Some t;
76
+
refresh_lines_from ~editor:p;
77
+
run t
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 ~id worker this =
87
+
let shadow = Webcomponent.attach_shadow this in
88
+
89
+
El.append_children shadow
90
+
[ El.style [ El.txt @@ Jstr.of_string [%blob "style.css"] ] ];
91
+
let run_btn = El.button [ El.txt (Jstr.of_string "Run") ] in
92
+
El.append_children shadow
93
+
[ El.div ~at:[ At.class' (Jstr.of_string "run_btn") ] [ run_btn ] ];
94
+
95
+
let cm = Editor.make shadow in
96
+
97
+
let merlin = Merlin_ext.make ~id worker in
98
+
let merlin_worker = Merlin_ext.Client.make_worker merlin in
99
+
let editor =
100
+
{
101
+
id;
102
+
status = Not_run;
103
+
cm;
104
+
prev = None;
105
+
next = None;
106
+
worker;
107
+
merlin_worker;
108
+
}
109
+
in
110
+
Editor.on_change cm (fun () -> invalidate_after ~editor);
111
+
set_source_from_html editor this;
112
+
113
+
Merlin_ext.set_context merlin (fun () -> pre_source editor);
114
+
Editor.configure_merlin cm (Merlin_ext.extensions merlin_worker);
115
+
116
+
let () =
117
+
Mutation_observer.observe ~target:(Webcomponent.as_target this)
118
+
@@ Mutation_observer.create (fun _ _ -> set_source_from_html editor this)
119
+
in
120
+
121
+
let _ : Ev.listener =
122
+
Ev.listen Ev.click (fun _ev -> run editor) (El.as_target run_btn)
123
+
in
124
+
125
+
editor
126
+
127
+
let set_source editor doc =
128
+
Editor.set_source editor.cm doc;
129
+
refresh_lines_from ~editor
130
+
131
+
let render_message msg =
132
+
let kind, text =
133
+
match msg with
134
+
| X_protocol.Stdout str -> ("stdout", str)
135
+
| Stderr str -> ("stderr", str)
136
+
| Meta str -> ("meta", str)
137
+
in
138
+
El.pre
139
+
~at:[ At.class' (Jstr.of_string ("caml_" ^ kind)) ]
140
+
[ El.txt (Jstr.of_string text) ]
141
+
142
+
let add_message t loc msg =
143
+
Editor.add_message t.cm loc (List.map render_message msg)
144
+
145
+
let completed_run ed msg =
146
+
(if msg <> [] then
147
+
let loc = String.length (Editor.source ed.cm) in
148
+
add_message ed loc msg);
149
+
ed.status <- Run_ok;
150
+
match ed.next with Some e when e.status = Request_run -> run e | _ -> ()
151
+
152
+
let receive_merlin t msg =
153
+
Merlin_ext.Client.on_message t.merlin_worker
154
+
(Merlin_ext.fix_answer (pre_source t) msg)
+9
src/cell.mli
+9
src/cell.mli
···
1
+
type t
2
+
3
+
val init : id:int -> Client.t -> Webcomponent.t -> t
4
+
val id : t -> int
5
+
val set_source : t -> string -> unit
6
+
val add_message : t -> int -> X_protocol.output list -> unit
7
+
val completed_run : t -> X_protocol.output list -> unit
8
+
val set_prev : prev:t option -> t -> unit
9
+
val receive_merlin : t -> Protocol.answer -> unit
+60
src/client.ml
+60
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
+
let eval ~id worker code = post worker (Eval (id, code))
60
+
let fmt ~id worker code = post worker (Format (id, code))
+7
src/client.mli
+7
src/client.mli
+13
src/dune
+13
src/dune
+151
src/editor.ml
+151
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
+
changes : Code_mirror.Compartment.t;
7
+
mutable previous_lines : int;
8
+
mutable current_doc : string;
9
+
mutable messages : (int * Brr.El.t list) list;
10
+
}
11
+
12
+
let find_line_ends at doc =
13
+
let rec go i =
14
+
if i >= String.length doc || doc.[i] = '\n' then i else go (i + 1)
15
+
in
16
+
go at
17
+
18
+
let render_messages cm =
19
+
let open Code_mirror.Editor in
20
+
let open Code_mirror.Decoration in
21
+
let (State.Facet ((module F), it)) = View.decorations () in
22
+
let doc = cm.current_doc in
23
+
let ranges =
24
+
Array.of_list
25
+
@@ List.map (fun (at, msg) ->
26
+
let at = find_line_ends at doc in
27
+
range ~from:at ~to_:at
28
+
@@ widget ~block:true ~side:99
29
+
@@ Widget.make (fun () -> msg))
30
+
@@ List.concat
31
+
@@ List.map (fun (loc, lst) -> List.map (fun m -> (loc, m)) lst)
32
+
@@ List.sort (fun (a, _) (b, _) -> Int.compare a b) cm.messages
33
+
in
34
+
F.of_ it (Range_set.of' ranges)
35
+
36
+
let refresh_messages ed =
37
+
Code_mirror.Editor.View.dispatch ed.view
38
+
(Code_mirror.Compartment.reconfigure ed.messages_comp
39
+
[ render_messages ed ]);
40
+
Code_mirror.Editor.View.request_measure ed.view
41
+
42
+
let custom_ln editor =
43
+
Code_mirror.Editor.View.line_numbers (fun x ->
44
+
string_of_int (editor.previous_lines + x))
45
+
46
+
let refresh_lines ed =
47
+
Code_mirror.Editor.View.dispatch ed.view
48
+
@@ Code_mirror.Compartment.reconfigure ed.lines_comp [ custom_ln ed ]
49
+
50
+
let configure_merlin ed extensions =
51
+
Code_mirror.Editor.View.dispatch ed.view
52
+
@@ Code_mirror.Compartment.reconfigure ed.merlin_comp extensions
53
+
54
+
let clear x =
55
+
x.messages <- [];
56
+
refresh_lines x;
57
+
refresh_messages x
58
+
59
+
let source_of_state s =
60
+
String.concat "\n" @@ Array.to_list @@ Array.map Jstr.to_string
61
+
@@ Code_mirror.Text.to_jstr_array
62
+
@@ Code_mirror.Editor.State.doc s
63
+
64
+
let source t = source_of_state @@ Code_mirror.Editor.View.state t.view
65
+
66
+
let prefix_length a b =
67
+
let rec go i =
68
+
if i >= String.length a || i >= String.length b || a.[i] <> b.[i] then i
69
+
else go (i + 1)
70
+
in
71
+
go 0
72
+
73
+
let basic_setup =
74
+
Jv.get Jv.global "__CM__basic_setup" |> Code_mirror.Extension.of_jv
75
+
76
+
let make parent =
77
+
let open Code_mirror.Editor in
78
+
let changes = Code_mirror.Compartment.make () in
79
+
let messages = Code_mirror.Compartment.make () in
80
+
let lines = Code_mirror.Compartment.make () in
81
+
let merlin = Code_mirror.Compartment.make () in
82
+
let extensions =
83
+
[|
84
+
basic_setup;
85
+
Code_mirror.Editor.View.line_wrapping ();
86
+
Code_mirror.Compartment.of' lines [];
87
+
Code_mirror.Compartment.of' messages [];
88
+
Code_mirror.Compartment.of' changes [];
89
+
Code_mirror.Compartment.of' merlin [];
90
+
|]
91
+
in
92
+
let config = State.Config.create ~doc:Jstr.empty ~extensions () in
93
+
let state = State.create ~config () in
94
+
let opts = View.opts ~state ~parent () in
95
+
let view = View.create ~opts () in
96
+
{
97
+
previous_lines = 0;
98
+
current_doc = "";
99
+
messages = [];
100
+
view;
101
+
messages_comp = messages;
102
+
lines_comp = lines;
103
+
merlin_comp = merlin;
104
+
changes;
105
+
}
106
+
107
+
let set_current_doc t new_doc =
108
+
let at = prefix_length t.current_doc new_doc in
109
+
t.current_doc <- new_doc;
110
+
t.messages <- List.filter (fun (loc, _) -> loc < at) t.messages;
111
+
refresh_messages t
112
+
113
+
let on_change cm fn =
114
+
let has_changed =
115
+
let open Code_mirror.Editor in
116
+
let (State.Facet ((module F), it)) = View.update_listener () in
117
+
F.of_ it (fun ev ->
118
+
if View.Update.doc_changed ev then
119
+
let new_doc = source_of_state (View.Update.state ev) in
120
+
if not (String.equal cm.current_doc new_doc) then (
121
+
set_current_doc cm new_doc;
122
+
fn ()))
123
+
in
124
+
Code_mirror.Editor.View.dispatch cm.view
125
+
@@ Code_mirror.Compartment.reconfigure cm.changes [ has_changed ]
126
+
127
+
let count_lines str =
128
+
if str = "" then 0
129
+
else
130
+
let nb = ref 1 in
131
+
for i = 0 to String.length str - 1 do
132
+
if str.[i] = '\n' then incr nb
133
+
done;
134
+
!nb
135
+
136
+
let nb_lines t = t.previous_lines + count_lines t.current_doc
137
+
138
+
let set_previous_lines t nb =
139
+
t.previous_lines <- nb;
140
+
refresh_lines t
141
+
142
+
let set_messages t msg =
143
+
t.messages <- msg;
144
+
refresh_messages t
145
+
146
+
let clear_messages t = set_messages t []
147
+
let add_message t loc msg = set_messages t ((loc, msg) :: t.messages)
148
+
149
+
let set_source t doc =
150
+
set_current_doc t doc;
151
+
Code_mirror.Editor.View.set_doc t.view (Jstr.of_string doc)
+12
src/editor.mli
+12
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 set_previous_lines : t -> int -> unit
9
+
val clear_messages : t -> unit
10
+
val add_message : t -> int -> Brr.El.t list -> unit
11
+
val on_change : t -> (unit -> unit) -> unit
12
+
val configure_merlin : t -> Code_mirror.Extension.t list -> unit
+72
src/merlin_ext.ml
+72
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 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_ < 0 then None else Some { e with loc })
45
+
errors)
46
+
| Protocol.Completions completions ->
47
+
Completions
48
+
{
49
+
completions with
50
+
from = completions.from - pre_len;
51
+
to_ = completions.to_ - pre_len;
52
+
}
53
+
| Protocol.Typed_enclosings typed_enclosings ->
54
+
Typed_enclosings
55
+
(List.map
56
+
(fun (loc, a, b) -> (fix_loc pre_len loc, a, b))
57
+
typed_enclosings)
58
+
| Protocol.Added_cmis -> msg
59
+
60
+
module Merlin_send = struct
61
+
type nonrec t = t
62
+
63
+
let post t msg =
64
+
let msg = fix_request t msg in
65
+
Client.post t.client (Merlin (t.id, msg))
66
+
end
67
+
68
+
module Client = Merlin_client.Make (Merlin_send)
69
+
module Ed = Merlin_codemirror.Extensions (Merlin_send)
70
+
71
+
let extensions t =
72
+
Merlin_codemirror.ocaml :: Array.to_list (Ed.all_extensions t)
+21
src/mutation_observer.ml
+21
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
src/mutation_observer.mli
+7
src/mutation_observer.mli
+76
src/style.css
+76
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
+
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
+
button:hover { background-color: #6D6D6D; color: #F5F5F5; }
38
+
button:hover::after { border-color: transparent transparent transparent #F5F5F5; }
39
+
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
+
}
+31
src/webcomponent.ml
+31
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 "(function() { return __xocaml_exported(this) })");
22
+
let _ : Jv.t = Jv.call custom_elements "define" [| Jv.of_jstr name; test |] in
23
+
()
24
+
25
+
let text_content t = Jstr.to_string @@ Jv.to_jstr @@ Jv.get t "textContent"
26
+
let as_target t = Brr.El.of_jv t
27
+
28
+
let attach_shadow t =
29
+
Brr.El.of_jv
30
+
@@ Jv.call t "attachShadow"
31
+
[| Jv.obj [| ("mode", Jv.of_jstr @@ Jstr.of_string "open") |] |]
+6
src/webcomponent.mli
+6
src/webcomponent.mli
+42
src/x_ocaml.ml
+42
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 elt_name =
31
+
match current_attribute "elt-name" with
32
+
| None -> Jstr.of_string "x-ocaml"
33
+
| Some name -> name
34
+
35
+
let _ =
36
+
Webcomponent.define elt_name @@ fun this ->
37
+
let prev = match !all with [] -> None | e :: _ -> Some e in
38
+
let id = List.length !all in
39
+
let editor = Cell.init ~id worker this in
40
+
all := editor :: !all;
41
+
Cell.set_prev ~prev editor;
42
+
()
+26
worker/dune
+26
worker/dune
···
1
+
(library
2
+
(name x_worker)
3
+
(libraries
4
+
brr
5
+
js_of_ocaml
6
+
js_of_ocaml-toplevel
7
+
x_protocol
8
+
merlin-js.worker
9
+
ocamlformat-lib
10
+
ocamlformat-lib.parser_extended
11
+
ocamlformat-lib.format_))
12
+
13
+
(rule
14
+
(targets export.txt)
15
+
(deps export-stdlib.txt)
16
+
(action
17
+
(with-stdout-to
18
+
%{targets}
19
+
(progn
20
+
(cat %{deps})
21
+
(echo "Ast_mapper\n")))))
22
+
23
+
(rule
24
+
(target export-stdlib.txt)
25
+
(action
26
+
(run jsoo_listunits -o %{target} stdlib)))
+10
worker/effects/dune
+10
worker/effects/dune
+5
worker/effects/x_worker.ml
+5
worker/effects/x_worker.ml
+103
worker/eval.ml
+103
worker/eval.ml
···
1
+
open Js_of_ocaml_toplevel
2
+
open X_protocol
3
+
4
+
let environments = ref []
5
+
6
+
let setup_toplevel () =
7
+
let _ = JsooTop.initialize () in
8
+
Sys.interactive := false;
9
+
environments := [ (0, !Toploop.toplevel_env) ]
10
+
11
+
let reset id =
12
+
let rec go id = function
13
+
| [] -> failwith ("no environment " ^ string_of_int id)
14
+
| [ (_, x) ] as rest ->
15
+
Toploop.toplevel_env := x;
16
+
rest
17
+
| (id', _) :: xs when id' >= id -> go id xs
18
+
| x :: xs ->
19
+
Toploop.toplevel_env := snd x;
20
+
x :: xs
21
+
in
22
+
environments := go id !environments
23
+
24
+
let rec parse_use_file ~caml_ppf lex =
25
+
let _at = lex.Lexing.lex_curr_pos in
26
+
match !Toploop.parse_toplevel_phrase lex with
27
+
| ok -> ok :: parse_use_file ~caml_ppf lex
28
+
| exception End_of_file -> []
29
+
| exception err ->
30
+
Errors.report_error caml_ppf err;
31
+
[]
32
+
33
+
let ppx_rewriters = ref []
34
+
35
+
let preprocess_structure str =
36
+
let open Ast_mapper in
37
+
List.fold_right
38
+
(fun ppx_rewriter str ->
39
+
let mapper = ppx_rewriter [] in
40
+
mapper.structure mapper str)
41
+
!ppx_rewriters str
42
+
43
+
let preprocess_phrase phrase =
44
+
let open Parsetree in
45
+
match phrase with
46
+
| Ptop_def str -> Ptop_def (preprocess_structure str)
47
+
| Ptop_dir _ as x -> x
48
+
49
+
let execute ~id ~output code_text =
50
+
reset id;
51
+
let outputs = ref [] in
52
+
let buf = Buffer.create 64 in
53
+
let caml_ppf = Format.formatter_of_buffer buf in
54
+
let content = code_text ^ " ;;" in
55
+
let phrases = parse_use_file ~caml_ppf (Lexing.from_string content) in
56
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (fun str ->
57
+
outputs := Stdout str :: !outputs);
58
+
Js_of_ocaml.Sys_js.set_channel_flusher stderr (fun str ->
59
+
outputs := Stderr str :: !outputs);
60
+
let get_out () =
61
+
Format.pp_print_flush caml_ppf ();
62
+
let meta = Buffer.contents buf in
63
+
Buffer.clear buf;
64
+
let out = if meta = "" then !outputs else Meta meta :: !outputs in
65
+
outputs := [];
66
+
List.rev out
67
+
in
68
+
let respond ~(at_loc : Location.t) =
69
+
let loc = at_loc.loc_end.pos_cnum in
70
+
let out = get_out () in
71
+
output ~loc out
72
+
in
73
+
List.iter
74
+
(fun phrase ->
75
+
let sub_phrases =
76
+
match phrase with
77
+
| Parsetree.Ptop_def s -> List.map (fun s -> Parsetree.Ptop_def [ s ]) s
78
+
| Ptop_dir _ -> [ phrase ]
79
+
in
80
+
List.iter
81
+
(fun phrase ->
82
+
let at_loc =
83
+
match phrase with
84
+
| Parsetree.Ptop_def ({ pstr_loc = loc; _ } :: _) -> loc
85
+
| Ptop_dir { pdir_loc = loc; _ } -> loc
86
+
| _ -> assert false
87
+
in
88
+
try
89
+
Location.reset ();
90
+
let phrase = preprocess_phrase phrase in
91
+
let _r = Toploop.execute_phrase true caml_ppf phrase in
92
+
respond ~at_loc
93
+
with _exn ->
94
+
Errors.report_error caml_ppf _exn;
95
+
respond ~at_loc)
96
+
sub_phrases)
97
+
phrases;
98
+
environments := (id, !Toploop.toplevel_env) :: !environments;
99
+
get_out ()
100
+
101
+
let () =
102
+
Ast_mapper.register_function :=
103
+
fun _ f -> ppx_rewriters := f :: !ppx_rewriters
+7
worker/eval.mli
+7
worker/eval.mli
+6
worker/no-effects/dune
+6
worker/no-effects/dune
+1
worker/no-effects/x_worker.ml
+1
worker/no-effects/x_worker.ml
···
1
+
let () = X_worker.run ()
+43
worker/ocamlfmt.ml
+43
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 conf = Ocamlformat_lib.Conf.default
7
+
8
+
let ast source =
9
+
Ocamlformat_lib.Parse_with_comments.parse
10
+
(Ocamlformat_lib.Parse_with_comments.parse_ast conf)
11
+
Structure conf ~input_name:"source" ~source
12
+
13
+
let fmt source =
14
+
let ast = ast source in
15
+
let ast =
16
+
let ghostify =
17
+
{
18
+
Parser_extended.Ast_mapper.default_mapper with
19
+
location = (fun _ loc -> { loc with loc_ghost = true });
20
+
}
21
+
in
22
+
{ ast with ast = ghostify.structure ghostify ast.ast }
23
+
in
24
+
let with_buffer_formatter ~buffer_size k =
25
+
let buffer = Buffer.create buffer_size in
26
+
let fs = Format_.formatter_of_buffer buffer in
27
+
Fmt.eval fs k;
28
+
Format_.pp_print_flush fs ();
29
+
if Buffer.length buffer > 0 then Format_.pp_print_newline fs ();
30
+
Buffer.contents buffer
31
+
in
32
+
let print (ast : _ Parse_with_comments.with_comments) =
33
+
let open Fmt in
34
+
let debug = conf.opr_opts.debug.v in
35
+
with_buffer_formatter ~buffer_size:1000
36
+
(set_margin conf.fmt_opts.margin.v
37
+
$ set_max_indent conf.fmt_opts.max_indent.v
38
+
$ Fmt_ast.fmt_ast Structure ~debug ast.source
39
+
(Ocamlformat_lib.Cmts.init Structure ~debug ast.source ast.ast
40
+
ast.comments)
41
+
conf ast.ast)
42
+
in
43
+
String.strip (print ast)
+26
worker/x_worker.ml
+26
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.log [ "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 (id, code) -> ignore (reformat ~id code : string)
21
+
| Eval (id, code) ->
22
+
let code = reformat ~id code in
23
+
let output ~loc out = respond (Top_response_at (id, loc, out)) in
24
+
let result = Eval.execute ~output ~id code in
25
+
respond (Top_response (id, result))
26
+
| Setup -> Eval.setup_toplevel ()
+26
x-ocaml.opam
+26
x-ocaml.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
depends: [
4
+
"dune" {>= "3.10"}
5
+
"bos"
6
+
"cmdliner"
7
+
"ocamlfind"
8
+
"js_of_ocaml"
9
+
"ppx_blob"
10
+
"brr"
11
+
"odoc" {with-doc}
12
+
]
13
+
build: [
14
+
["dune" "subst"] {dev}
15
+
[
16
+
"dune"
17
+
"build"
18
+
"-p"
19
+
name
20
+
"-j"
21
+
jobs
22
+
"@install"
23
+
"@runtest" {with-test}
24
+
"@doc" {with-doc}
25
+
]
26
+
]