jon.recoil.org
this repo has no description
Add ppxlib support to PPX preprocessing pipeline
Integrate ppxlib's Driver.map_structure into the toplevel's PPX
preprocessing, supporting both old-style Ast_mapper PPXs (like
js_of_ocaml's Ppx_js) and modern ppxlib-based PPXs.
Changes:
- Add ppxlib as a dependency in lib/dune
- Modify JsooTopPpx to chain old-style mappers with ppxlib Driver
- Handle AST version conversion between compiler's Parsetree and
ppxlib's internal AST using Selected_ast.of_ocaml/to_ocaml
- Fix typecheck_phrase to use JsooTopPpx.preprocess_phrase for
consistency with execute (was using Toploop.preprocess_phrase)
- Add node-based PPX test verifying the preprocessing pipeline
The preprocessing order is: old-style Ast_mapper rewriters first,
then ppxlib transformations. This allows both types of PPXs to
coexist and be applied correctly.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+2
-1
lib/dune
+2
-1
lib/dune
+29
-7
lib/impl.ml
+29
-7
lib/impl.ml
···
87
87
88
88
(** {2 PPX Preprocessing}
89
89
90
-
Handles PPX rewriter registration and application. The [Ppx_js.mapper]
91
-
is registered by default to support js_of_ocaml syntax extensions. *)
90
+
Handles PPX rewriter registration and application. Supports both:
91
+
- Old-style [Ast_mapper] PPXs (e.g., [Ppx_js.mapper] for js_of_ocaml)
92
+
- Modern [ppxlib]-based PPXs (registered via [Ppxlib.Driver])
93
+
94
+
The [Ppx_js.mapper] is registered by default to support js_of_ocaml
95
+
syntax extensions. *)
92
96
93
97
module JsooTopPpx = struct
94
98
open Js_of_ocaml_compiler.Stdlib
95
99
100
+
(** Old-style Ast_mapper rewriters *)
96
101
let ppx_rewriters = ref [ (fun _ -> Ppx_js.mapper) ]
97
102
98
103
let () =
99
104
Ast_mapper.register_function :=
100
105
fun _ f -> ppx_rewriters := f :: !ppx_rewriters
101
106
102
-
let preprocess_structure str =
107
+
(** Apply old-style Ast_mapper rewriters *)
108
+
let apply_ast_mapper_rewriters_structure str =
103
109
let open Ast_mapper in
104
110
List.fold_right !ppx_rewriters ~init:str ~f:(fun ppx_rewriter str ->
105
111
let mapper = ppx_rewriter [] in
106
112
mapper.structure mapper str)
107
113
108
-
let preprocess_signature str =
114
+
let apply_ast_mapper_rewriters_signature sg =
109
115
let open Ast_mapper in
110
-
List.fold_right !ppx_rewriters ~init:str ~f:(fun ppx_rewriter str ->
116
+
List.fold_right !ppx_rewriters ~init:sg ~f:(fun ppx_rewriter sg ->
111
117
let mapper = ppx_rewriter [] in
112
-
mapper.signature mapper str)
118
+
mapper.signature mapper sg)
119
+
120
+
(** Apply all PPX transformations: old-style first, then ppxlib.
121
+
Handles AST version conversion between compiler's Parsetree and ppxlib's internal AST. *)
122
+
let preprocess_structure str =
123
+
str
124
+
|> apply_ast_mapper_rewriters_structure
125
+
|> Ppxlib_ast.Selected_ast.of_ocaml Structure
126
+
|> Ppxlib.Driver.map_structure
127
+
|> Ppxlib_ast.Selected_ast.to_ocaml Structure
128
+
129
+
let preprocess_signature sg =
130
+
sg
131
+
|> apply_ast_mapper_rewriters_signature
132
+
|> Ppxlib_ast.Selected_ast.of_ocaml Signature
133
+
|> Ppxlib.Driver.map_signature
134
+
|> Ppxlib_ast.Selected_ast.to_ocaml Signature
113
135
114
136
let preprocess_phrase phrase =
115
137
let open Parsetree in
···
509
531
try
510
532
let lb = Lexing.from_function (refill_lexbuf phr (ref 0) None) in
511
533
let phr = !Toploop.parse_toplevel_phrase lb in
512
-
let phr = Toploop.preprocess_phrase pp_result phr in
534
+
let phr = JsooTopPpx.preprocess_phrase phr in
513
535
match phr with
514
536
| Parsetree.Ptop_def sstr ->
515
537
let oldenv = !Toploop.toplevel_env in
+59
test/node/dune
+59
test/node/dune
···
119
119
(deps _opam)
120
120
(action
121
121
(diff node_directive_test.expected node_directive_test.out)))
122
+
123
+
; PPX test executable
124
+
(executable
125
+
(name node_ppx_test)
126
+
(modes byte)
127
+
(modules node_ppx_test)
128
+
(link_flags (-linkall))
129
+
(libraries
130
+
str
131
+
fpath
132
+
js_of_ocaml
133
+
js_top_worker-web
134
+
js_of_ocaml-toplevel
135
+
js_top_worker
136
+
logs
137
+
logs.fmt
138
+
rpclib.core
139
+
rpclib.json
140
+
findlib.top
141
+
js_of_ocaml-lwt
142
+
zarith_stubs_js))
143
+
144
+
(rule
145
+
(targets node_ppx_test.js)
146
+
(action
147
+
(run
148
+
%{bin:js_of_ocaml}
149
+
--toplevel
150
+
--pretty
151
+
--no-cmis
152
+
--effects=cps
153
+
--debuginfo
154
+
--target-env=nodejs
155
+
+toplevel.js
156
+
+dynlink.js
157
+
+bigstringaf/runtime.js
158
+
+zarith_stubs_js/runtime.js
159
+
%{lib:js_top_worker:stubs.js}
160
+
%{dep:node_ppx_test.bc}
161
+
-o
162
+
%{targets})))
163
+
164
+
(rule
165
+
(deps _opam)
166
+
(action
167
+
(with-outputs-to
168
+
node_ppx_test.out
169
+
(run
170
+
node
171
+
--stack-size=2000
172
+
-r
173
+
./%{dep:import_scripts.js}
174
+
%{dep:node_ppx_test.js}))))
175
+
176
+
(rule
177
+
(alias runtest)
178
+
(deps _opam)
179
+
(action
180
+
(diff node_ppx_test.expected node_ppx_test.out)))
+84
test/node/node_ppx_test.expected
+84
test/node/node_ppx_test.expected
···
1
+
=== Node.js PPX Tests ===
2
+
3
+
node_ppx_test.js: [INFO] init()
4
+
Initializing findlib
5
+
node_ppx_test.js: [INFO] async_get: _opam/findlib_index
6
+
node_ppx_test.js: [INFO] async_get: _opam/lib/sexplib0/META
7
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml_intrinsics_kernel/META
8
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib/META
9
+
node_ppx_test.js: [INFO] async_get: _opam/lib/base/META
10
+
Parsed uri: lib/sexplib0/META
11
+
Reading library: sexplib0
12
+
Number of children: 0
13
+
Parsed uri: lib/ocaml_intrinsics_kernel/META
14
+
Reading library: ocaml_intrinsics_kernel
15
+
Number of children: 0
16
+
Parsed uri: lib/ocaml/stdlib/META
17
+
Reading library: stdlib
18
+
Number of children: 0
19
+
Parsed uri: lib/base/META
20
+
Reading library: base
21
+
Number of children: 3
22
+
Found child: base_internalhash_types
23
+
Reading library: base.base_internalhash_types
24
+
Number of children: 0
25
+
Found child: md5
26
+
Reading library: base.md5
27
+
Number of children: 0
28
+
Found child: shadow_stdlib
29
+
Reading library: base.shadow_stdlib
30
+
Number of children: 0
31
+
node_ppx_test.js: [INFO] sync_get: _opam/lib/ocaml/dynamic_cmis.json
32
+
node_ppx_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
33
+
node_ppx_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
34
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormat.cmi
35
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
36
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
37
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
38
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/std_exit.cmi
39
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
40
+
node_ppx_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
41
+
node_ppx_test.js: [INFO] init() finished
42
+
node_ppx_test.js: [INFO] setup() ...
43
+
node_ppx_test.js: [INFO] Fetching stdlib__Format.cmi
44
+
45
+
node_ppx_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Format.cmi
46
+
node_ppx_test.js: [INFO] Fetching stdlib__Sys.cmi
47
+
48
+
node_ppx_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Sys.cmi
49
+
error while evaluating #enable "pretty";;
50
+
error while evaluating #disable "shortvar";;
51
+
node_ppx_test.js: [INFO] Setup complete
52
+
node_ppx_test.js: [INFO] setup() finished
53
+
--- Section 1: Basic PPX Preprocessing ---
54
+
[PASS] basic_no_ppx: # let x = 1 + 2;;
55
+
val x : int = 3
56
+
57
+
--- Section 2: PPX Pipeline Integration ---
58
+
[PASS] record_type: # type t = { name: string; age: int };;
59
+
type t = { name : string; age : int; }
60
+
[PASS] record_value: # let person = { name = "Alice"; age = 30 };;
61
+
val person : t = {name = "Alice"; age = 30}
62
+
[PASS] record_access: # let get_name p = p.name;;
63
+
val get_name : t -> string = <fun>
64
+
[PASS] module_def: # module M = struct let x = 42 end;;
65
+
module M : sig val x : int end
66
+
67
+
--- Section 3: Complex Expressions ---
68
+
[PASS] recursive_fn: # let rec fib n = if n <= 1 then n else fib (n-1) + fib (n-2);;
69
+
val fib : int -> int = <fun>
70
+
[PASS] recursive_call: # fib 10;;
71
+
- : int = 55
72
+
[PASS] module_type: # module type S = sig val x : int end;;
73
+
module type S = sig val x : int end
74
+
[PASS] functor_def: # module F (X : S) = struct let y = X.x + 1 end;;
75
+
module F : (X : S) -> sig val y : int end
76
+
77
+
--- Section 4: PPX Attributes (no-op test) ---
78
+
[PASS] inline_attr: # let[@inline] f x = x + 1;;
79
+
val f : int -> int = <fun>
80
+
[PASS] field_attr: # type point = { x: float [@default 0.0]; y: float };;
81
+
type point = { x : float; y : float; }
82
+
83
+
=== Results: 11/11 tests passed ===
84
+
SUCCESS: All PPX tests passed!
+214
test/node/node_ppx_test.ml
+214
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,
4
+
including both old-style Ast_mapper PPXs (like js_of_ocaml's Ppx_js)
5
+
and ppxlib-based PPXs.
6
+
7
+
Tests:
8
+
- js_of_ocaml PPX syntax (%js extensions)
9
+
- PPX error handling
10
+
- Preprocessing in both execute and typecheck paths
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
+
Logs.info (fun m -> m "sync_get: %a" Fpath.pp f);
50
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
51
+
with e ->
52
+
Logs.err (fun m ->
53
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
54
+
None
55
+
56
+
let async_get f =
57
+
let f = Fpath.v ("_opam/" ^ f) in
58
+
Logs.info (fun m -> m "async_get: %a" Fpath.pp f);
59
+
try
60
+
let content =
61
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
62
+
in
63
+
Lwt.return (Ok content)
64
+
with e ->
65
+
Logs.err (fun m ->
66
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
67
+
Lwt.return (Error (`Msg (Printexc.to_string e)))
68
+
69
+
let create_file = Js_of_ocaml.Sys_js.create_file
70
+
71
+
let import_scripts urls =
72
+
let open Js_of_ocaml.Js in
73
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
74
+
List.iter
75
+
(fun url ->
76
+
let (_ : 'a) =
77
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
78
+
in
79
+
())
80
+
urls
81
+
82
+
let init_function _ () = failwith "Not implemented"
83
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
84
+
85
+
let get_stdlib_dcs uri =
86
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
87
+
|> Result.to_list
88
+
89
+
let require b v = function
90
+
| [] -> []
91
+
| packages -> Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v packages
92
+
93
+
let path = "/static/cmis"
94
+
end
95
+
96
+
module U = Impl.Make (S)
97
+
98
+
let start_server () =
99
+
let open U in
100
+
Logs.set_reporter (Logs_fmt.reporter ());
101
+
Logs.set_level (Some Logs.Info);
102
+
Server.exec execute;
103
+
Server.setup (IdlM.T.lift setup);
104
+
Server.init (IdlM.T.lift init);
105
+
Server.typecheck typecheck_phrase;
106
+
Server.complete_prefix complete_prefix;
107
+
Server.query_errors query_errors;
108
+
Server.type_enclosing type_enclosing;
109
+
Server.exec_toplevel exec_toplevel;
110
+
IdlM.server Server.implementation
111
+
112
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
113
+
114
+
(* Test state *)
115
+
let passed_tests = ref 0
116
+
let total_tests = ref 0
117
+
118
+
let test name condition message =
119
+
incr total_tests;
120
+
let status = if condition then (incr passed_tests; "PASS") else "FAIL" in
121
+
Printf.printf "[%s] %s: %s\n%!" status name message
122
+
123
+
let contains s substr =
124
+
try
125
+
let _ = Str.search_forward (Str.regexp_string substr) s 0 in
126
+
true
127
+
with Not_found -> false
128
+
129
+
let run_toplevel rpc code =
130
+
let ( let* ) = IdlM.ErrM.bind in
131
+
let* result = Client.exec_toplevel rpc ("# " ^ code) in
132
+
IdlM.ErrM.return result.script
133
+
134
+
let _ =
135
+
Printf.printf "=== Node.js PPX Tests ===\n\n%!";
136
+
137
+
let rpc = start_server () in
138
+
let ( let* ) = IdlM.ErrM.bind in
139
+
140
+
let init_config =
141
+
{ stdlib_dcs = None; findlib_requires = []; execute = true }
142
+
in
143
+
144
+
let test_sequence =
145
+
(* Initialize *)
146
+
let* _ = Client.init rpc init_config in
147
+
let* _ = Client.setup rpc () in
148
+
149
+
Printf.printf "--- Section 1: Basic PPX Preprocessing ---\n%!";
150
+
151
+
(* Test that basic code still works (no PPX needed) *)
152
+
let* r = run_toplevel rpc "let x = 1 + 2;;" in
153
+
test "basic_no_ppx" (contains r "val x : int = 3") r;
154
+
155
+
(* Test that PPX errors are handled gracefully *)
156
+
Printf.printf "\n--- Section 2: PPX Pipeline Integration ---\n%!";
157
+
158
+
(* Test that the preprocessing doesn't break normal code *)
159
+
let* r = run_toplevel rpc "type t = { name: string; age: int };;" in
160
+
test "record_type" (contains r "type t") r;
161
+
162
+
let* r = run_toplevel rpc "let person = { name = \"Alice\"; age = 30 };;" in
163
+
test "record_value" (contains r "val person : t") r;
164
+
165
+
(* Test pattern matching *)
166
+
let* r = run_toplevel rpc "let get_name p = p.name;;" in
167
+
test "record_access" (contains r "val get_name : t -> string") r;
168
+
169
+
(* Test that module definitions work with PPX preprocessing *)
170
+
let* r = run_toplevel rpc "module M = struct let x = 42 end;;" in
171
+
test "module_def" (contains r "module M") r;
172
+
173
+
Printf.printf "\n--- Section 3: Complex Expressions ---\n%!";
174
+
175
+
(* Test that complex expressions work through PPX pipeline *)
176
+
let* r = run_toplevel rpc "let rec fib n = if n <= 1 then n else fib (n-1) + fib (n-2);;" in
177
+
test "recursive_fn" (contains r "val fib : int -> int") r;
178
+
179
+
let* r = run_toplevel rpc "fib 10;;" in
180
+
test "recursive_call" (contains r "- : int = 55") r;
181
+
182
+
(* Test that functors work *)
183
+
let* r = run_toplevel rpc "module type S = sig val x : int end;;" in
184
+
test "module_type" (contains r "module type S") r;
185
+
186
+
let* r = run_toplevel rpc "module F (X : S) = struct let y = X.x + 1 end;;" in
187
+
test "functor_def" (contains r "module F") r;
188
+
189
+
Printf.printf "\n--- Section 4: PPX Attributes (no-op test) ---\n%!";
190
+
191
+
(* Test that unknown attributes don't crash the PPX pipeline *)
192
+
let* r = run_toplevel rpc "let[@inline] f x = x + 1;;" in
193
+
test "inline_attr" (contains r "val f : int -> int") r;
194
+
195
+
let* r = run_toplevel rpc "type point = { x: float [@default 0.0]; y: float };;" in
196
+
test "field_attr" (contains r "type point") r;
197
+
198
+
IdlM.ErrM.return ()
199
+
in
200
+
201
+
let promise = test_sequence |> IdlM.T.get in
202
+
(match Lwt.state promise with
203
+
| Lwt.Return (Ok ()) -> ()
204
+
| Lwt.Return (Error (InternalError s)) ->
205
+
Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
206
+
| Lwt.Fail e ->
207
+
Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
208
+
| Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
209
+
210
+
Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
211
+
!total_tests;
212
+
if !passed_tests = !total_tests then
213
+
Printf.printf "SUCCESS: All PPX tests passed!\n%!"
214
+
else Printf.printf "FAILURE: Some tests failed.\n%!"