xote 7.0.0 → 7.1.0-beta.2

This diff represents the content of publicly available package versions that have been released to one of the supported registries. The information contained in this diff is provided for informational purposes only and reflects changes between package versions as they appear in their respective public registries.
package/ppx/ppx.ml ADDED
@@ -0,0 +1,1363 @@
1
+ (* Vendored OCaml 4.06 AST (ReScript 12's ppx parsetree is Caml1999M022 = 4.06).
2
+ Types are copied verbatim from ocaml/ocaml@4.06 so Marshal round-trips exactly. *)
3
+ module Location = struct
4
+ type t = { loc_start : Lexing.position; loc_end : Lexing.position; loc_ghost : bool }
5
+ type 'a loc = { txt : 'a; loc : t }
6
+ end
7
+ module Longident = struct
8
+ type t = Lident of string | Ldot of t * string | Lapply of t * t
9
+ end
10
+ module Asttypes = struct
11
+ (**************************************************************************)
12
+ (* *)
13
+ (* OCaml *)
14
+ (* *)
15
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
16
+ (* *)
17
+ (* Copyright 1996 Institut National de Recherche en Informatique et *)
18
+ (* en Automatique. *)
19
+ (* *)
20
+ (* All rights reserved. This file is distributed under the terms of *)
21
+ (* the GNU Lesser General Public License version 2.1, with the *)
22
+ (* special exception on linking described in the file LICENSE. *)
23
+ (* *)
24
+ (**************************************************************************)
25
+
26
+ (** Auxiliary AST types used by parsetree and typedtree. *)
27
+
28
+ type constant =
29
+ Const_int of int
30
+ | Const_char of char
31
+ | Const_string of string * string option
32
+ | Const_float of string
33
+ | Const_int32 of int32
34
+ | Const_int64 of int64
35
+ | Const_nativeint of nativeint
36
+
37
+ type rec_flag = Nonrecursive | Recursive
38
+
39
+ type direction_flag = Upto | Downto
40
+
41
+ (* Order matters, used in polymorphic comparison *)
42
+ type private_flag = Private | Public
43
+
44
+ type mutable_flag = Immutable | Mutable
45
+
46
+ type virtual_flag = Virtual | Concrete
47
+
48
+ type override_flag = Override | Fresh
49
+
50
+ type closed_flag = Closed | Open
51
+
52
+ type label = string
53
+
54
+ type arg_label =
55
+ Nolabel
56
+ | Labelled of string (* label:T -> ... *)
57
+ | Optional of string (* ?label:T -> ... *)
58
+
59
+ type 'a loc = 'a Location.loc = {
60
+ txt : 'a;
61
+ loc : Location.t;
62
+ }
63
+
64
+
65
+ type variance =
66
+ | Covariant
67
+ | Contravariant
68
+ | Invariant
69
+ end
70
+ module Parsetree = struct
71
+ (**************************************************************************)
72
+ (* *)
73
+ (* OCaml *)
74
+ (* *)
75
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
76
+ (* *)
77
+ (* Copyright 1996 Institut National de Recherche en Informatique et *)
78
+ (* en Automatique. *)
79
+ (* *)
80
+ (* All rights reserved. This file is distributed under the terms of *)
81
+ (* the GNU Lesser General Public License version 2.1, with the *)
82
+ (* special exception on linking described in the file LICENSE. *)
83
+ (* *)
84
+ (**************************************************************************)
85
+
86
+ (** Abstract syntax tree produced by parsing *)
87
+
88
+ open Asttypes
89
+
90
+ type constant =
91
+ Pconst_integer of string * char option
92
+ (* 3 3l 3L 3n
93
+
94
+ Suffixes [g-z][G-Z] are accepted by the parser.
95
+ Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
96
+ *)
97
+ | Pconst_char of char
98
+ (* 'c' *)
99
+ | Pconst_string of string * string option
100
+ (* "constant"
101
+ {delim|other constant|delim}
102
+ *)
103
+ | Pconst_float of string * char option
104
+ (* 3.4 2e5 1.4e-4
105
+
106
+ Suffixes [g-z][G-Z] are accepted by the parser.
107
+ Suffixes are rejected by the typechecker.
108
+ *)
109
+
110
+ (** {1 Extension points} *)
111
+
112
+ type attribute = string loc * payload
113
+ (* [@id ARG]
114
+ [@@id ARG]
115
+
116
+ Metadata containers passed around within the AST.
117
+ The compiler ignores unknown attributes.
118
+ *)
119
+
120
+ and extension = string loc * payload
121
+ (* [%id ARG]
122
+ [%%id ARG]
123
+
124
+ Sub-language placeholder -- rejected by the typechecker.
125
+ *)
126
+
127
+ and attributes = attribute list
128
+
129
+ and payload =
130
+ | PStr of structure
131
+ | PSig of signature (* : SIG *)
132
+ | PTyp of core_type (* : T *)
133
+ | PPat of pattern * expression option (* ? P or ? P when E *)
134
+
135
+ (** {1 Core language} *)
136
+
137
+ (* Type expressions *)
138
+
139
+ and core_type =
140
+ {
141
+ ptyp_desc: core_type_desc;
142
+ ptyp_loc: Location.t;
143
+ ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
144
+ }
145
+
146
+ and core_type_desc =
147
+ | Ptyp_any
148
+ (* _ *)
149
+ | Ptyp_var of string
150
+ (* 'a *)
151
+ | Ptyp_arrow of arg_label * core_type * core_type
152
+ (* T1 -> T2 Simple
153
+ ~l:T1 -> T2 Labelled
154
+ ?l:T1 -> T2 Optional
155
+ *)
156
+ | Ptyp_tuple of core_type list
157
+ (* T1 * ... * Tn
158
+
159
+ Invariant: n >= 2
160
+ *)
161
+ | Ptyp_constr of Longident.t loc * core_type list
162
+ (* tconstr
163
+ T tconstr
164
+ (T1, ..., Tn) tconstr
165
+ *)
166
+ | Ptyp_object of object_field list * closed_flag
167
+ (* < l1:T1; ...; ln:Tn > (flag = Closed)
168
+ < l1:T1; ...; ln:Tn; .. > (flag = Open)
169
+ *)
170
+ | Ptyp_class of Longident.t loc * core_type list
171
+ (* #tconstr
172
+ T #tconstr
173
+ (T1, ..., Tn) #tconstr
174
+ *)
175
+ | Ptyp_alias of core_type * string
176
+ (* T as 'a *)
177
+ | Ptyp_variant of row_field list * closed_flag * label list option
178
+ (* [ `A|`B ] (flag = Closed; labels = None)
179
+ [> `A|`B ] (flag = Open; labels = None)
180
+ [< `A|`B ] (flag = Closed; labels = Some [])
181
+ [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
182
+ *)
183
+ | Ptyp_poly of string loc list * core_type
184
+ (* 'a1 ... 'an. T
185
+
186
+ Can only appear in the following context:
187
+
188
+ - As the core_type of a Ppat_constraint node corresponding
189
+ to a constraint on a let-binding: let x : 'a1 ... 'an. T
190
+ = e ...
191
+
192
+ - Under Cfk_virtual for methods (not values).
193
+
194
+ - As the core_type of a Pctf_method node.
195
+
196
+ - As the core_type of a Pexp_poly node.
197
+
198
+ - As the pld_type field of a label_declaration.
199
+
200
+ - As a core_type of a Ptyp_object node.
201
+ *)
202
+
203
+ | Ptyp_package of package_type
204
+ (* (module S) *)
205
+ | Ptyp_extension of extension
206
+ (* [%id] *)
207
+
208
+ and package_type = Longident.t loc * (Longident.t loc * core_type) list
209
+ (*
210
+ (module S)
211
+ (module S with type t1 = T1 and ... and tn = Tn)
212
+ *)
213
+
214
+ and row_field =
215
+ | Rtag of label loc * attributes * bool * core_type list
216
+ (* [`A] ( true, [] )
217
+ [`A of T] ( false, [T] )
218
+ [`A of T1 & .. & Tn] ( false, [T1;...Tn] )
219
+ [`A of & T1 & .. & Tn] ( true, [T1;...Tn] )
220
+
221
+ - The 2nd field is true if the tag contains a
222
+ constant (empty) constructor.
223
+ - '&' occurs when several types are used for the same constructor
224
+ (see 4.2 in the manual)
225
+
226
+ - TODO: switch to a record representation, and keep location
227
+ *)
228
+ | Rinherit of core_type
229
+ (* [ T ] *)
230
+
231
+ and object_field =
232
+ | Otag of label loc * attributes * core_type
233
+ | Oinherit of core_type
234
+
235
+ (* Patterns *)
236
+
237
+ and pattern =
238
+ {
239
+ ppat_desc: pattern_desc;
240
+ ppat_loc: Location.t;
241
+ ppat_attributes: attributes; (* ... [@id1] [@id2] *)
242
+ }
243
+
244
+ and pattern_desc =
245
+ | Ppat_any
246
+ (* _ *)
247
+ | Ppat_var of string loc
248
+ (* x *)
249
+ | Ppat_alias of pattern * string loc
250
+ (* P as 'a *)
251
+ | Ppat_constant of constant
252
+ (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
253
+ | Ppat_interval of constant * constant
254
+ (* 'a'..'z'
255
+
256
+ Other forms of interval are recognized by the parser
257
+ but rejected by the type-checker. *)
258
+ | Ppat_tuple of pattern list
259
+ (* (P1, ..., Pn)
260
+
261
+ Invariant: n >= 2
262
+ *)
263
+ | Ppat_construct of Longident.t loc * pattern option
264
+ (* C None
265
+ C P Some P
266
+ C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn])
267
+ *)
268
+ | Ppat_variant of label * pattern option
269
+ (* `A (None)
270
+ `A P (Some P)
271
+ *)
272
+ | Ppat_record of (Longident.t loc * pattern) list * closed_flag
273
+ (* { l1=P1; ...; ln=Pn } (flag = Closed)
274
+ { l1=P1; ...; ln=Pn; _} (flag = Open)
275
+
276
+ Invariant: n > 0
277
+ *)
278
+ | Ppat_array of pattern list
279
+ (* [| P1; ...; Pn |] *)
280
+ | Ppat_or of pattern * pattern
281
+ (* P1 | P2 *)
282
+ | Ppat_constraint of pattern * core_type
283
+ (* (P : T) *)
284
+ | Ppat_type of Longident.t loc
285
+ (* #tconst *)
286
+ | Ppat_lazy of pattern
287
+ (* lazy P *)
288
+ | Ppat_unpack of string loc
289
+ (* (module P)
290
+ Note: (module P : S) is represented as
291
+ Ppat_constraint(Ppat_unpack, Ptyp_package)
292
+ *)
293
+ | Ppat_exception of pattern
294
+ (* exception P *)
295
+ | Ppat_extension of extension
296
+ (* [%id] *)
297
+ | Ppat_open of Longident.t loc * pattern
298
+ (* M.(P) *)
299
+
300
+ (* Value expressions *)
301
+
302
+ and expression =
303
+ {
304
+ pexp_desc: expression_desc;
305
+ pexp_loc: Location.t;
306
+ pexp_attributes: attributes; (* ... [@id1] [@id2] *)
307
+ }
308
+
309
+ and expression_desc =
310
+ | Pexp_ident of Longident.t loc
311
+ (* x
312
+ M.x
313
+ *)
314
+ | Pexp_constant of constant
315
+ (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
316
+ | Pexp_let of rec_flag * value_binding list * expression
317
+ (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive)
318
+ let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive)
319
+ *)
320
+ | Pexp_function of case list
321
+ (* function P1 -> E1 | ... | Pn -> En *)
322
+ | Pexp_fun of arg_label * expression option * pattern * expression
323
+ (* fun P -> E1 (Simple, None)
324
+ fun ~l:P -> E1 (Labelled l, None)
325
+ fun ?l:P -> E1 (Optional l, None)
326
+ fun ?l:(P = E0) -> E1 (Optional l, Some E0)
327
+
328
+ Notes:
329
+ - If E0 is provided, only Optional is allowed.
330
+ - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
331
+ - "let f P = E" is represented using Pexp_fun.
332
+ *)
333
+ | Pexp_apply of expression * (arg_label * expression) list
334
+ (* E0 ~l1:E1 ... ~ln:En
335
+ li can be empty (non labeled argument) or start with '?'
336
+ (optional argument).
337
+
338
+ Invariant: n > 0
339
+ *)
340
+ | Pexp_match of expression * case list
341
+ (* match E0 with P1 -> E1 | ... | Pn -> En *)
342
+ | Pexp_try of expression * case list
343
+ (* try E0 with P1 -> E1 | ... | Pn -> En *)
344
+ | Pexp_tuple of expression list
345
+ (* (E1, ..., En)
346
+
347
+ Invariant: n >= 2
348
+ *)
349
+ | Pexp_construct of Longident.t loc * expression option
350
+ (* C None
351
+ C E Some E
352
+ C (E1, ..., En) Some (Pexp_tuple[E1;...;En])
353
+ *)
354
+ | Pexp_variant of label * expression option
355
+ (* `A (None)
356
+ `A E (Some E)
357
+ *)
358
+ | Pexp_record of (Longident.t loc * expression) list * expression option
359
+ (* { l1=P1; ...; ln=Pn } (None)
360
+ { E0 with l1=P1; ...; ln=Pn } (Some E0)
361
+
362
+ Invariant: n > 0
363
+ *)
364
+ | Pexp_field of expression * Longident.t loc
365
+ (* E.l *)
366
+ | Pexp_setfield of expression * Longident.t loc * expression
367
+ (* E1.l <- E2 *)
368
+ | Pexp_array of expression list
369
+ (* [| E1; ...; En |] *)
370
+ | Pexp_ifthenelse of expression * expression * expression option
371
+ (* if E1 then E2 else E3 *)
372
+ | Pexp_sequence of expression * expression
373
+ (* E1; E2 *)
374
+ | Pexp_while of expression * expression
375
+ (* while E1 do E2 done *)
376
+ | Pexp_for of
377
+ pattern * expression * expression * direction_flag * expression
378
+ (* for i = E1 to E2 do E3 done (flag = Upto)
379
+ for i = E1 downto E2 do E3 done (flag = Downto)
380
+ *)
381
+ | Pexp_constraint of expression * core_type
382
+ (* (E : T) *)
383
+ | Pexp_coerce of expression * core_type option * core_type
384
+ (* (E :> T) (None, T)
385
+ (E : T0 :> T) (Some T0, T)
386
+ *)
387
+ | Pexp_send of expression * label loc
388
+ (* E # m *)
389
+ | Pexp_new of Longident.t loc
390
+ (* new M.c *)
391
+ | Pexp_setinstvar of label loc * expression
392
+ (* x <- 2 *)
393
+ | Pexp_override of (label loc * expression) list
394
+ (* {< x1 = E1; ...; Xn = En >} *)
395
+ | Pexp_letmodule of string loc * module_expr * expression
396
+ (* let module M = ME in E *)
397
+ | Pexp_letexception of extension_constructor * expression
398
+ (* let exception C in E *)
399
+ | Pexp_assert of expression
400
+ (* assert E
401
+ Note: "assert false" is treated in a special way by the
402
+ type-checker. *)
403
+ | Pexp_lazy of expression
404
+ (* lazy E *)
405
+ | Pexp_poly of expression * core_type option
406
+ (* Used for method bodies.
407
+
408
+ Can only be used as the expression under Cfk_concrete
409
+ for methods (not values). *)
410
+ | Pexp_object of class_structure
411
+ (* object ... end *)
412
+ | Pexp_newtype of string loc * expression
413
+ (* fun (type t) -> E *)
414
+ | Pexp_pack of module_expr
415
+ (* (module ME)
416
+
417
+ (module ME : S) is represented as
418
+ Pexp_constraint(Pexp_pack, Ptyp_package S) *)
419
+ | Pexp_open of override_flag * Longident.t loc * expression
420
+ (* M.(E)
421
+ let open M in E
422
+ let! open M in E *)
423
+ | Pexp_extension of extension
424
+ (* [%id] *)
425
+ | Pexp_unreachable
426
+ (* . *)
427
+
428
+ and case = (* (P -> E) or (P when E0 -> E) *)
429
+ {
430
+ pc_lhs: pattern;
431
+ pc_guard: expression option;
432
+ pc_rhs: expression;
433
+ }
434
+
435
+ (* Value descriptions *)
436
+
437
+ and value_description =
438
+ {
439
+ pval_name: string loc;
440
+ pval_type: core_type;
441
+ pval_prim: string list;
442
+ pval_attributes: attributes; (* ... [@@id1] [@@id2] *)
443
+ pval_loc: Location.t;
444
+ }
445
+
446
+ (*
447
+ val x: T (prim = [])
448
+ external x: T = "s1" ... "sn" (prim = ["s1";..."sn"])
449
+ *)
450
+
451
+ (* Type declarations *)
452
+
453
+ and type_declaration =
454
+ {
455
+ ptype_name: string loc;
456
+ ptype_params: (core_type * variance) list;
457
+ (* ('a1,...'an) t; None represents _*)
458
+ ptype_cstrs: (core_type * core_type * Location.t) list;
459
+ (* ... constraint T1=T1' ... constraint Tn=Tn' *)
460
+ ptype_kind: type_kind;
461
+ ptype_private: private_flag; (* = private ... *)
462
+ ptype_manifest: core_type option; (* = T *)
463
+ ptype_attributes: attributes; (* ... [@@id1] [@@id2] *)
464
+ ptype_loc: Location.t;
465
+ }
466
+
467
+ (*
468
+ type t (abstract, no manifest)
469
+ type t = T0 (abstract, manifest=T0)
470
+ type t = C of T | ... (variant, no manifest)
471
+ type t = T0 = C of T | ... (variant, manifest=T0)
472
+ type t = {l: T; ...} (record, no manifest)
473
+ type t = T0 = {l : T; ...} (record, manifest=T0)
474
+ type t = .. (open, no manifest)
475
+ *)
476
+
477
+ and type_kind =
478
+ | Ptype_abstract
479
+ | Ptype_variant of constructor_declaration list
480
+ (* Invariant: non-empty list *)
481
+ | Ptype_record of label_declaration list
482
+ (* Invariant: non-empty list *)
483
+ | Ptype_open
484
+
485
+ and label_declaration =
486
+ {
487
+ pld_name: string loc;
488
+ pld_mutable: mutable_flag;
489
+ pld_type: core_type;
490
+ pld_loc: Location.t;
491
+ pld_attributes: attributes; (* l : T [@id1] [@id2] *)
492
+ }
493
+
494
+ (* { ...; l: T; ... } (mutable=Immutable)
495
+ { ...; mutable l: T; ... } (mutable=Mutable)
496
+
497
+ Note: T can be a Ptyp_poly.
498
+ *)
499
+
500
+ and constructor_declaration =
501
+ {
502
+ pcd_name: string loc;
503
+ pcd_args: constructor_arguments;
504
+ pcd_res: core_type option;
505
+ pcd_loc: Location.t;
506
+ pcd_attributes: attributes; (* C of ... [@id1] [@id2] *)
507
+ }
508
+
509
+ and constructor_arguments =
510
+ | Pcstr_tuple of core_type list
511
+ | Pcstr_record of label_declaration list
512
+
513
+ (*
514
+ | C of T1 * ... * Tn (res = None, args = Pcstr_tuple [])
515
+ | C: T0 (res = Some T0, args = [])
516
+ | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple)
517
+ | C of {...} (res = None, args = Pcstr_record)
518
+ | C: {...} -> T0 (res = Some T0, args = Pcstr_record)
519
+ | C of {...} as t (res = None, args = Pcstr_record)
520
+ *)
521
+
522
+ and type_extension =
523
+ {
524
+ ptyext_path: Longident.t loc;
525
+ ptyext_params: (core_type * variance) list;
526
+ ptyext_constructors: extension_constructor list;
527
+ ptyext_private: private_flag;
528
+ ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *)
529
+ }
530
+ (*
531
+ type t += ...
532
+ *)
533
+
534
+ and extension_constructor =
535
+ {
536
+ pext_name: string loc;
537
+ pext_kind : extension_constructor_kind;
538
+ pext_loc : Location.t;
539
+ pext_attributes: attributes; (* C of ... [@id1] [@id2] *)
540
+ }
541
+
542
+ and extension_constructor_kind =
543
+ Pext_decl of constructor_arguments * core_type option
544
+ (*
545
+ | C of T1 * ... * Tn ([T1; ...; Tn], None)
546
+ | C: T0 ([], Some T0)
547
+ | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0)
548
+ *)
549
+ | Pext_rebind of Longident.t loc
550
+ (*
551
+ | C = D
552
+ *)
553
+
554
+ (** {1 Class language} *)
555
+
556
+ (* Type expressions for the class language *)
557
+
558
+ and class_type =
559
+ {
560
+ pcty_desc: class_type_desc;
561
+ pcty_loc: Location.t;
562
+ pcty_attributes: attributes; (* ... [@id1] [@id2] *)
563
+ }
564
+
565
+ and class_type_desc =
566
+ | Pcty_constr of Longident.t loc * core_type list
567
+ (* c
568
+ ['a1, ..., 'an] c *)
569
+ | Pcty_signature of class_signature
570
+ (* object ... end *)
571
+ | Pcty_arrow of arg_label * core_type * class_type
572
+ (* T -> CT Simple
573
+ ~l:T -> CT Labelled l
574
+ ?l:T -> CT Optional l
575
+ *)
576
+ | Pcty_extension of extension
577
+ (* [%id] *)
578
+ | Pcty_open of override_flag * Longident.t loc * class_type
579
+ (* let open M in CT *)
580
+
581
+ and class_signature =
582
+ {
583
+ pcsig_self: core_type;
584
+ pcsig_fields: class_type_field list;
585
+ }
586
+ (* object('selfpat) ... end
587
+ object ... end (self = Ptyp_any)
588
+ *)
589
+
590
+ and class_type_field =
591
+ {
592
+ pctf_desc: class_type_field_desc;
593
+ pctf_loc: Location.t;
594
+ pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
595
+ }
596
+
597
+ and class_type_field_desc =
598
+ | Pctf_inherit of class_type
599
+ (* inherit CT *)
600
+ | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type)
601
+ (* val x: T *)
602
+ | Pctf_method of (label loc * private_flag * virtual_flag * core_type)
603
+ (* method x: T
604
+
605
+ Note: T can be a Ptyp_poly.
606
+ *)
607
+ | Pctf_constraint of (core_type * core_type)
608
+ (* constraint T1 = T2 *)
609
+ | Pctf_attribute of attribute
610
+ (* [@@@id] *)
611
+ | Pctf_extension of extension
612
+ (* [%%id] *)
613
+
614
+ and 'a class_infos =
615
+ {
616
+ pci_virt: virtual_flag;
617
+ pci_params: (core_type * variance) list;
618
+ pci_name: string loc;
619
+ pci_expr: 'a;
620
+ pci_loc: Location.t;
621
+ pci_attributes: attributes; (* ... [@@id1] [@@id2] *)
622
+ }
623
+ (* class c = ...
624
+ class ['a1,...,'an] c = ...
625
+ class virtual c = ...
626
+
627
+ Also used for "class type" declaration.
628
+ *)
629
+
630
+ and class_description = class_type class_infos
631
+
632
+ and class_type_declaration = class_type class_infos
633
+
634
+ (* Value expressions for the class language *)
635
+
636
+ and class_expr =
637
+ {
638
+ pcl_desc: class_expr_desc;
639
+ pcl_loc: Location.t;
640
+ pcl_attributes: attributes; (* ... [@id1] [@id2] *)
641
+ }
642
+
643
+ and class_expr_desc =
644
+ | Pcl_constr of Longident.t loc * core_type list
645
+ (* c
646
+ ['a1, ..., 'an] c *)
647
+ | Pcl_structure of class_structure
648
+ (* object ... end *)
649
+ | Pcl_fun of arg_label * expression option * pattern * class_expr
650
+ (* fun P -> CE (Simple, None)
651
+ fun ~l:P -> CE (Labelled l, None)
652
+ fun ?l:P -> CE (Optional l, None)
653
+ fun ?l:(P = E0) -> CE (Optional l, Some E0)
654
+ *)
655
+ | Pcl_apply of class_expr * (arg_label * expression) list
656
+ (* CE ~l1:E1 ... ~ln:En
657
+ li can be empty (non labeled argument) or start with '?'
658
+ (optional argument).
659
+
660
+ Invariant: n > 0
661
+ *)
662
+ | Pcl_let of rec_flag * value_binding list * class_expr
663
+ (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive)
664
+ let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive)
665
+ *)
666
+ | Pcl_constraint of class_expr * class_type
667
+ (* (CE : CT) *)
668
+ | Pcl_extension of extension
669
+ (* [%id] *)
670
+ | Pcl_open of override_flag * Longident.t loc * class_expr
671
+ (* let open M in CE *)
672
+
673
+
674
+ and class_structure =
675
+ {
676
+ pcstr_self: pattern;
677
+ pcstr_fields: class_field list;
678
+ }
679
+ (* object(selfpat) ... end
680
+ object ... end (self = Ppat_any)
681
+ *)
682
+
683
+ and class_field =
684
+ {
685
+ pcf_desc: class_field_desc;
686
+ pcf_loc: Location.t;
687
+ pcf_attributes: attributes; (* ... [@@id1] [@@id2] *)
688
+ }
689
+
690
+ and class_field_desc =
691
+ | Pcf_inherit of override_flag * class_expr * string loc option
692
+ (* inherit CE
693
+ inherit CE as x
694
+ inherit! CE
695
+ inherit! CE as x
696
+ *)
697
+ | Pcf_val of (label loc * mutable_flag * class_field_kind)
698
+ (* val x = E
699
+ val virtual x: T
700
+ *)
701
+ | Pcf_method of (label loc * private_flag * class_field_kind)
702
+ (* method x = E (E can be a Pexp_poly)
703
+ method virtual x: T (T can be a Ptyp_poly)
704
+ *)
705
+ | Pcf_constraint of (core_type * core_type)
706
+ (* constraint T1 = T2 *)
707
+ | Pcf_initializer of expression
708
+ (* initializer E *)
709
+ | Pcf_attribute of attribute
710
+ (* [@@@id] *)
711
+ | Pcf_extension of extension
712
+ (* [%%id] *)
713
+
714
+ and class_field_kind =
715
+ | Cfk_virtual of core_type
716
+ | Cfk_concrete of override_flag * expression
717
+
718
+ and class_declaration = class_expr class_infos
719
+
720
+ (** {1 Module language} *)
721
+
722
+ (* Type expressions for the module language *)
723
+
724
+ and module_type =
725
+ {
726
+ pmty_desc: module_type_desc;
727
+ pmty_loc: Location.t;
728
+ pmty_attributes: attributes; (* ... [@id1] [@id2] *)
729
+ }
730
+
731
+ and module_type_desc =
732
+ | Pmty_ident of Longident.t loc
733
+ (* S *)
734
+ | Pmty_signature of signature
735
+ (* sig ... end *)
736
+ | Pmty_functor of string loc * module_type option * module_type
737
+ (* functor(X : MT1) -> MT2 *)
738
+ | Pmty_with of module_type * with_constraint list
739
+ (* MT with ... *)
740
+ | Pmty_typeof of module_expr
741
+ (* module type of ME *)
742
+ | Pmty_extension of extension
743
+ (* [%id] *)
744
+ | Pmty_alias of Longident.t loc
745
+ (* (module M) *)
746
+
747
+ and signature = signature_item list
748
+
749
+ and signature_item =
750
+ {
751
+ psig_desc: signature_item_desc;
752
+ psig_loc: Location.t;
753
+ }
754
+
755
+ and signature_item_desc =
756
+ | Psig_value of value_description
757
+ (*
758
+ val x: T
759
+ external x: T = "s1" ... "sn"
760
+ *)
761
+ | Psig_type of rec_flag * type_declaration list
762
+ (* type t1 = ... and ... and tn = ... *)
763
+ | Psig_typext of type_extension
764
+ (* type t1 += ... *)
765
+ | Psig_exception of extension_constructor
766
+ (* exception C of T *)
767
+ | Psig_module of module_declaration
768
+ (* module X : MT *)
769
+ | Psig_recmodule of module_declaration list
770
+ (* module rec X1 : MT1 and ... and Xn : MTn *)
771
+ | Psig_modtype of module_type_declaration
772
+ (* module type S = MT
773
+ module type S *)
774
+ | Psig_open of open_description
775
+ (* open X *)
776
+ | Psig_include of include_description
777
+ (* include MT *)
778
+ | Psig_class of class_description list
779
+ (* class c1 : ... and ... and cn : ... *)
780
+ | Psig_class_type of class_type_declaration list
781
+ (* class type ct1 = ... and ... and ctn = ... *)
782
+ | Psig_attribute of attribute
783
+ (* [@@@id] *)
784
+ | Psig_extension of extension * attributes
785
+ (* [%%id] *)
786
+
787
+ and module_declaration =
788
+ {
789
+ pmd_name: string loc;
790
+ pmd_type: module_type;
791
+ pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
792
+ pmd_loc: Location.t;
793
+ }
794
+ (* S : MT *)
795
+
796
+ and module_type_declaration =
797
+ {
798
+ pmtd_name: string loc;
799
+ pmtd_type: module_type option;
800
+ pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
801
+ pmtd_loc: Location.t;
802
+ }
803
+ (* S = MT
804
+ S (abstract module type declaration, pmtd_type = None)
805
+ *)
806
+
807
+ and open_description =
808
+ {
809
+ popen_lid: Longident.t loc;
810
+ popen_override: override_flag;
811
+ popen_loc: Location.t;
812
+ popen_attributes: attributes;
813
+ }
814
+ (* open! X - popen_override = Override (silences the 'used identifier
815
+ shadowing' warning)
816
+ open X - popen_override = Fresh
817
+ *)
818
+
819
+ and 'a include_infos =
820
+ {
821
+ pincl_mod: 'a;
822
+ pincl_loc: Location.t;
823
+ pincl_attributes: attributes;
824
+ }
825
+
826
+ and include_description = module_type include_infos
827
+ (* include MT *)
828
+
829
+ and include_declaration = module_expr include_infos
830
+ (* include ME *)
831
+
832
+ and with_constraint =
833
+ | Pwith_type of Longident.t loc * type_declaration
834
+ (* with type X.t = ...
835
+
836
+ Note: the last component of the longident must match
837
+ the name of the type_declaration. *)
838
+ | Pwith_module of Longident.t loc * Longident.t loc
839
+ (* with module X.Y = Z *)
840
+ | Pwith_typesubst of Longident.t loc * type_declaration
841
+ (* with type X.t := ..., same format as [Pwith_type] *)
842
+ | Pwith_modsubst of Longident.t loc * Longident.t loc
843
+ (* with module X.Y := Z *)
844
+
845
+ (* Value expressions for the module language *)
846
+
847
+ and module_expr =
848
+ {
849
+ pmod_desc: module_expr_desc;
850
+ pmod_loc: Location.t;
851
+ pmod_attributes: attributes; (* ... [@id1] [@id2] *)
852
+ }
853
+
854
+ and module_expr_desc =
855
+ | Pmod_ident of Longident.t loc
856
+ (* X *)
857
+ | Pmod_structure of structure
858
+ (* struct ... end *)
859
+ | Pmod_functor of string loc * module_type option * module_expr
860
+ (* functor(X : MT1) -> ME *)
861
+ | Pmod_apply of module_expr * module_expr
862
+ (* ME1(ME2) *)
863
+ | Pmod_constraint of module_expr * module_type
864
+ (* (ME : MT) *)
865
+ | Pmod_unpack of expression
866
+ (* (val E) *)
867
+ | Pmod_extension of extension
868
+ (* [%id] *)
869
+
870
+ and structure = structure_item list
871
+
872
+ and structure_item =
873
+ {
874
+ pstr_desc: structure_item_desc;
875
+ pstr_loc: Location.t;
876
+ }
877
+
878
+ and structure_item_desc =
879
+ | Pstr_eval of expression * attributes
880
+ (* E *)
881
+ | Pstr_value of rec_flag * value_binding list
882
+ (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive)
883
+ let rec P1 = E1 and ... and Pn = EN (flag = Recursive)
884
+ *)
885
+ | Pstr_primitive of value_description
886
+ (* val x: T
887
+ external x: T = "s1" ... "sn" *)
888
+ | Pstr_type of rec_flag * type_declaration list
889
+ (* type t1 = ... and ... and tn = ... *)
890
+ | Pstr_typext of type_extension
891
+ (* type t1 += ... *)
892
+ | Pstr_exception of extension_constructor
893
+ (* exception C of T
894
+ exception C = M.X *)
895
+ | Pstr_module of module_binding
896
+ (* module X = ME *)
897
+ | Pstr_recmodule of module_binding list
898
+ (* module rec X1 = ME1 and ... and Xn = MEn *)
899
+ | Pstr_modtype of module_type_declaration
900
+ (* module type S = MT *)
901
+ | Pstr_open of open_description
902
+ (* open X *)
903
+ | Pstr_class of class_declaration list
904
+ (* class c1 = ... and ... and cn = ... *)
905
+ | Pstr_class_type of class_type_declaration list
906
+ (* class type ct1 = ... and ... and ctn = ... *)
907
+ | Pstr_include of include_declaration
908
+ (* include ME *)
909
+ | Pstr_attribute of attribute
910
+ (* [@@@id] *)
911
+ | Pstr_extension of extension * attributes
912
+ (* [%%id] *)
913
+
914
+ and value_binding =
915
+ {
916
+ pvb_pat: pattern;
917
+ pvb_expr: expression;
918
+ pvb_attributes: attributes;
919
+ pvb_loc: Location.t;
920
+ }
921
+
922
+ and module_binding =
923
+ {
924
+ pmb_name: string loc;
925
+ pmb_expr: module_expr;
926
+ pmb_attributes: attributes;
927
+ pmb_loc: Location.t;
928
+ }
929
+ (* X = ME *)
930
+
931
+ (** {1 Toplevel} *)
932
+
933
+ (* Toplevel phrases *)
934
+
935
+ type toplevel_phrase =
936
+ | Ptop_def of structure
937
+ | Ptop_dir of string * directive_argument
938
+ (* #use, #load ... *)
939
+
940
+ and directive_argument =
941
+ | Pdir_none
942
+ | Pdir_string of string
943
+ | Pdir_int of string * char option
944
+ | Pdir_ident of Longident.t
945
+ | Pdir_bool of bool
946
+ end
947
+
948
+
949
+ (* ---- @xote.component fine-grained rewriter ------------------------------
950
+ Decomposes the JSX returned by an @xote.component into fine-grained reactive
951
+ leaves instead of wrapping the whole block in one computed:
952
+
953
+ - an attribute value that reads a Signal -> thunked, so JSX lowers it
954
+ to `View.computedAttr` (only that attribute re-runs);
955
+ - a <View.Text>/<View.Int>/<View.Float>/<View.Bool> child that reads a
956
+ Signal -> thunked, so it lowers to a reactive text node (only that
957
+ text node re-runs);
958
+ - genuine control flow in *node position* (an `if`/`switch` producing
959
+ nodes) whose result varies -> wrapped in `View.tracked`, the one
960
+ place a structural swap is unavoidable.
961
+
962
+ The element structure itself (tags, nesting) is emitted once and never
963
+ rebuilt. Only the leaves that actually read signals become reactive. *)
964
+ open Asttypes
965
+ open Parsetree
966
+
967
+ let none : Location.t =
968
+ { Location.loc_start = Lexing.dummy_pos; loc_end = Lexing.dummy_pos; loc_ghost = true }
969
+ let mkloc (txt : 'a) : 'a Location.loc = { Location.txt; loc = none }
970
+ let mkexp d = { pexp_desc = d; pexp_loc = none; pexp_attributes = [] }
971
+ let ident lid = mkexp (Pexp_ident (mkloc lid))
972
+ let apply f args = mkexp (Pexp_apply (f, List.map (fun a -> (Nolabel, a)) args))
973
+
974
+ (* Uncurried unit thunk: `Function$(fun () -> body)` with `res.arity 1`, the
975
+ 4.06-ppx encoding ReScript uses for uncurried funcs (see PR #34). A bare
976
+ Pexp_fun would import as curried and be rejected in uncurried-by-default. *)
977
+ let res_arity n : attribute =
978
+ let e = mkexp (Pexp_constant (Pconst_integer (string_of_int n, None))) in
979
+ (mkloc "res.arity", PStr [ { pstr_desc = Pstr_eval (e, []); pstr_loc = none } ])
980
+ let unit_pat =
981
+ { ppat_desc = Ppat_construct (mkloc (Longident.Lident "()"), None);
982
+ ppat_loc = none; ppat_attributes = [] }
983
+ let thunk body =
984
+ let fn = mkexp (Pexp_fun (Nolabel, None, unit_pat, body)) in
985
+ { pexp_desc = Pexp_construct (mkloc (Longident.Lident "Function$"), Some fn);
986
+ pexp_loc = none; pexp_attributes = [ res_arity 1 ] }
987
+
988
+ let view_tracked = Longident.Ldot (Longident.Lident "View", "tracked")
989
+ let wrap_tracked e = apply (ident view_tracked) [ thunk e ]
990
+
991
+ let view_child = Longident.Ldot (Longident.Lident "View", "child")
992
+ let wrap_child e = apply (ident view_child) [ e ]
993
+
994
+ (* ---- signal-read detection ----------------------------------------------
995
+ A read is any occurrence of `Signal.get` (applied or not). Beyond the
996
+ literal `Signal.get` / `X.Signal.get`, an alias environment threaded through
997
+ the traversal also recognises indirect reads:
998
+ - a value alias: `let g = Signal.get` then `g(sig)`
999
+ - a module alias: `module S = Signal` then `S.get(sig)`
1000
+ - an open: `open Signal` then a bare `get(sig)`
1001
+ - a reactive helper: `let cls = () => Signal.get(x) ? …` then `cls()` —
1002
+ a local function whose body eagerly reads a signal; calling it is a read.
1003
+ The environment is scoped by the traversal (bindings visible only after they
1004
+ appear); shadowing a name with a non-reactive binding removes it. *)
1005
+ type env = { vals : string list; mods : string list; funcs : string list; open_signal : bool }
1006
+ let empty_env = { vals = []; mods = []; funcs = []; open_signal = false }
1007
+
1008
+ let is_signal_get (env : env) (e : expression) : bool =
1009
+ match e.pexp_desc with
1010
+ | Pexp_ident { txt = Longident.Ldot (m, "get"); _ } ->
1011
+ (match m with
1012
+ | Longident.Lident "Signal" -> true
1013
+ | Longident.Ldot (_, "Signal") -> true
1014
+ | Longident.Lident name -> List.mem name env.mods
1015
+ | _ -> false)
1016
+ | Pexp_ident { txt = Longident.Lident name; _ } ->
1017
+ List.mem name env.vals || (env.open_signal && name = "get")
1018
+ | _ -> false
1019
+
1020
+ let sub_exprs (e : expression) : expression list =
1021
+ match e.pexp_desc with
1022
+ | Pexp_apply (f, args) -> f :: List.map snd args
1023
+ | Pexp_ifthenelse (c, t, eo) -> c :: t :: (match eo with Some x -> [ x ] | None -> [])
1024
+ | Pexp_match (x, cases) | Pexp_try (x, cases) -> x :: List.map (fun c -> c.pc_rhs) cases
1025
+ | Pexp_construct (_, Some x) -> [ x ]
1026
+ | Pexp_tuple xs | Pexp_array xs -> xs
1027
+ | Pexp_field (x, _) -> [ x ]
1028
+ | Pexp_record (fields, base) ->
1029
+ List.map snd fields @ (match base with Some b -> [ b ] | None -> [])
1030
+ | Pexp_constraint (x, _) -> [ x ]
1031
+ | Pexp_coerce (x, _, _) -> [ x ]
1032
+ | Pexp_sequence (a, b) -> [ a; b ]
1033
+ | Pexp_let (_, vbs, body) -> List.map (fun vb -> vb.pvb_expr) vbs @ [ body ]
1034
+ | Pexp_fun (_, def, _, body) -> (match def with Some d -> [ d ] | None -> []) @ [ body ]
1035
+ | Pexp_open (_, _, x) -> [ x ]
1036
+ | Pexp_assert x | Pexp_lazy x -> [ x ]
1037
+ | _ -> []
1038
+
1039
+ (* A reactive-helper *call*: `f(...)` where `f` is a local function whose body
1040
+ eagerly reads a signal (tracked in env.funcs). A *bare* `f` (passed, not
1041
+ called) is left alone — the runtime already treats a function attribute/child
1042
+ as a computed. *)
1043
+ let is_reactive_call (env : env) (e : expression) : bool =
1044
+ match e.pexp_desc with
1045
+ | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Longident.Lident f; _ }; _ }, _) ->
1046
+ List.mem f env.funcs
1047
+ | _ -> false
1048
+
1049
+ (* An *eager* read: a `Signal.get` (or reactive-helper call) that runs when this
1050
+ expression is evaluated, not one deferred inside a nested lambda. Reads inside
1051
+ `() => …`, `Computed.make(() => …)`, `Prop.reactive(Computed.make(() => …))`,
1052
+ etc. are already reactive on their own, so a value that only reads inside a
1053
+ lambda must NOT be re-wrapped in a thunk. Stops descending at fn boundaries. *)
1054
+ let rec reads_signal_eager (env : env) (e : expression) : bool =
1055
+ match e.pexp_desc with
1056
+ | Pexp_fun _ -> false
1057
+ | Pexp_construct ({ txt = Longident.Lident "Function$"; _ }, Some _) -> false
1058
+ | _ ->
1059
+ is_reactive_call env e || is_signal_get env e
1060
+ || List.exists (reads_signal_eager env) (sub_exprs e)
1061
+
1062
+ (* Does `e` denote a function whose body eagerly reads a signal? Strip the
1063
+ function's own parameters (its uncurried `Function$` wrapper and `fun`s),
1064
+ then check the immediate body — reads_signal_eager stops at any further nested
1065
+ lambda, so a helper that merely *returns* a thunk is correctly not counted. *)
1066
+ let func_reads (env : env) (e : expression) : bool =
1067
+ let rec strip_params b =
1068
+ match b.pexp_desc with Pexp_fun (_, _, _, body) -> strip_params body | _ -> b
1069
+ in
1070
+ match e.pexp_desc with
1071
+ | Pexp_construct ({ txt = Longident.Lident "Function$"; _ }, Some fn) ->
1072
+ reads_signal_eager env (strip_params fn)
1073
+ | Pexp_fun _ -> reads_signal_eager env (strip_params e)
1074
+ | _ -> false
1075
+
1076
+ (* ---- binding collectors ------------------------------------------------- *)
1077
+ (* `let g = Signal.get` binds `g` as a value alias; `let cls = () => …Signal.get…`
1078
+ binds `cls` as a reactive helper; anything else shadows away a prior binding
1079
+ of that name. *)
1080
+ let collect_val_aliases (env : env) (vbs : value_binding list) : env =
1081
+ List.fold_left
1082
+ (fun env vb ->
1083
+ match vb.pvb_pat.ppat_desc with
1084
+ | Ppat_var { txt = name; _ } ->
1085
+ let drop = List.filter (fun n -> n <> name) in
1086
+ if is_signal_get env vb.pvb_expr then
1087
+ { env with vals = name :: env.vals; funcs = drop env.funcs }
1088
+ else if func_reads env vb.pvb_expr then
1089
+ { env with funcs = name :: env.funcs; vals = drop env.vals }
1090
+ else { env with vals = drop env.vals; funcs = drop env.funcs }
1091
+ | _ -> env)
1092
+ env vbs
1093
+
1094
+ let is_signal_module (me : module_expr) : bool =
1095
+ match me.pmod_desc with
1096
+ | Pmod_ident { txt = Longident.Lident "Signal"; _ } -> true
1097
+ | Pmod_ident { txt = Longident.Ldot (_, "Signal"); _ } -> true
1098
+ | _ -> false
1099
+
1100
+ let collect_mod_alias (env : env) (name : string Location.loc) (me : module_expr) : env =
1101
+ if is_signal_module me then { env with mods = name.Location.txt :: env.mods } else env
1102
+
1103
+ let is_signal_lid = function
1104
+ | Longident.Lident "Signal" -> true
1105
+ | Longident.Ldot (_, "Signal") -> true
1106
+ | _ -> false
1107
+
1108
+ let collect_open (env : env) (lid : Longident.t) : env =
1109
+ if is_signal_lid lid then { env with open_signal = true } else env
1110
+
1111
+ (* ---- JSX shape helpers -------------------------------------------------- *)
1112
+ let has_jsx (e : expression) : bool =
1113
+ List.exists (fun ((n : string Location.loc), _) -> n.Location.txt = "JSX") e.pexp_attributes
1114
+
1115
+ let jsx_parts (e : expression) =
1116
+ match e.pexp_desc with
1117
+ | Pexp_apply (f, args) when has_jsx e -> Some (f, args)
1118
+ | _ -> None
1119
+
1120
+ (* A JSX fragment `<>…</>` is a `::`/`[]` list carrying the JSX attribute (not a
1121
+ Pexp_apply, so jsx_parts misses it). Its children are node position. *)
1122
+ let is_jsx_fragment (e : expression) : bool =
1123
+ has_jsx e
1124
+ && (match e.pexp_desc with
1125
+ | Pexp_construct ({ txt = Longident.Lident ("::" | "[]"); _ }, _) -> true
1126
+ | _ -> false)
1127
+
1128
+ (* Lowercase leading char => intrinsic HTML/SVG element (children are nodes). *)
1129
+ let is_element (f : expression) : bool =
1130
+ match f.pexp_desc with
1131
+ | Pexp_ident { txt = Longident.Lident s; _ } ->
1132
+ String.length s > 0 && s.[0] >= 'a' && s.[0] <= 'z'
1133
+ | _ -> false
1134
+
1135
+ (* View.Text / View.Int / View.Float / View.Bool: children are *values*. *)
1136
+ let is_value_component (f : expression) : bool =
1137
+ match f.pexp_desc with
1138
+ | Pexp_ident { txt = Longident.Ldot (Longident.Lident "View", ("Text" | "Int" | "Float" | "Bool")); _ } ->
1139
+ true
1140
+ | _ -> false
1141
+
1142
+ let is_children_label = function
1143
+ | Labelled "children" | Optional "children" -> true
1144
+ | _ -> false
1145
+
1146
+ (* A value-position expression should be thunked iff it *eagerly* reads a signal
1147
+ and isn't already JSX. Using the eager check means values that are already
1148
+ reactive on their own — a `() => …` thunk, a `Computed`, a `Prop.reactive(…)`
1149
+ — are left untouched (their reads are deferred inside a lambda), so
1150
+ @xote.component is a safe drop-in on components already written that way. *)
1151
+ let should_thunk (env : env) (v : expression) : bool =
1152
+ reads_signal_eager env v && jsx_parts v = None
1153
+
1154
+ (* ---- decomposition ------------------------------------------------------ *)
1155
+ let rec fine_node (env : env) (e : expression) : expression =
1156
+ match jsx_parts e with
1157
+ | Some (f, args) when is_value_component f ->
1158
+ { e with pexp_desc = Pexp_apply (f, List.map (value_arg env) args) }
1159
+ | Some (f, args) ->
1160
+ (* element or user component: attrs are value position, children nodes *)
1161
+ { e with pexp_desc = Pexp_apply (f, List.map (element_arg env) args) }
1162
+ | None when is_jsx_fragment e ->
1163
+ (* A fragment `<>…</>` is a JSX-tagged `::`/`[]` list, not a Pexp_apply, so
1164
+ jsx_parts misses it. Recurse fine_node into each child exactly like an
1165
+ element's children (map_children preserves the outer @JSX attribute), so
1166
+ nested reactive regions stay *independent*. Without this the whole fragment
1167
+ would be wrapped in one coarse thunk and any nested `if`/`switch` inside it
1168
+ would collapse into that single tracked scope — rebuilding every sibling on
1169
+ one signal change. *)
1170
+ map_children (fine_node env) e
1171
+ | None ->
1172
+ (match e.pexp_desc with
1173
+ | Pexp_ifthenelse _ | Pexp_match _ ->
1174
+ (* Control flow in node position: the *node structure* varies, which needs
1175
+ View.tracked. First recurse fine-grained into each branch body: that
1176
+ turns the branches' leaves into thunks, so when the tracked scope runs
1177
+ a branch to build its nodes the thunks are not invoked — the scope ends
1178
+ up tracking only the condition/scrutinee (the eager reads), while a leaf
1179
+ inside a branch keeps its own reactive scope. Net effect: changing a
1180
+ signal that only a branch leaf reads updates just that leaf and does NOT
1181
+ re-run the switch or rebuild the branch.
1182
+
1183
+ The *eager* read check matters here too: a control-flow child that is
1184
+ already reactive on its own reads only inside a lambda, so it is left
1185
+ as-is rather than redundantly wrapped. *)
1186
+ if reads_signal_eager env e then wrap_tracked (decompose_branches env e) else e
1187
+ | _ ->
1188
+ (* A bare value child — `<div>{Signal.get(count)}</div>` — with no explicit
1189
+ <View.Int>/<View.Text> wrapper. Coerce it to a node with View.child:
1190
+ an eager signal read is thunked so it re-runs as reactive text; a static
1191
+ scalar becomes static text; a value that is already a node passes through
1192
+ untouched (View.child detects nodes at runtime). This removes the value-
1193
+ primitive ceremony under the annotation. *)
1194
+ wrap_child (if should_thunk env e then thunk e else e))
1195
+
1196
+ (* Recurse fine_node into the *node-position* bodies of control flow (the
1197
+ condition/scrutinee and any guards stay untouched — they are value position
1198
+ and should drive the structural swap). *)
1199
+ and decompose_branches (env : env) (e : expression) : expression =
1200
+ match e.pexp_desc with
1201
+ | Pexp_ifthenelse (c, t, eo) ->
1202
+ { e with pexp_desc = Pexp_ifthenelse (c, fine_node env t, Option.map (fine_node env) eo) }
1203
+ | Pexp_match (s, cases) ->
1204
+ { e with pexp_desc = Pexp_match (s, List.map (fun cs -> { cs with pc_rhs = fine_node env cs.pc_rhs }) cases) }
1205
+ | _ -> e
1206
+
1207
+ and element_arg (env : env) ((lbl, v) : arg_label * expression) : arg_label * expression =
1208
+ if is_children_label lbl then (lbl, map_children (fine_node env) v)
1209
+ else
1210
+ match lbl with
1211
+ | Labelled _ | Optional _ ->
1212
+ (* attribute: value position. Thunk it if reactive so it lowers to a
1213
+ computed attribute; leave plain JSX/static/already-function values. *)
1214
+ if should_thunk env v then (lbl, thunk v) else (lbl, v)
1215
+ | Nolabel -> (lbl, v)
1216
+
1217
+ and value_arg (env : env) ((lbl, v) : arg_label * expression) : arg_label * expression =
1218
+ if is_children_label lbl then (lbl, map_children (value_leaf env) v)
1219
+ else
1220
+ match lbl with
1221
+ | Labelled "value" -> (lbl, if should_thunk env v then thunk v else v)
1222
+ | _ -> (lbl, v)
1223
+
1224
+ (* child of a value component (View.Text ...): value position -> thunk. *)
1225
+ and value_leaf (env : env) (v : expression) : expression =
1226
+ if should_thunk env v then thunk v else v
1227
+
1228
+ (* Map [f] over a JSX children list (a `::`/`[]` spine); tolerate a bare
1229
+ single child that is not wrapped in a list. *)
1230
+ and map_children f (v : expression) : expression =
1231
+ match v.pexp_desc with
1232
+ | Pexp_construct
1233
+ ( ({ txt = Longident.Lident "::"; _ } as c),
1234
+ Some ({ pexp_desc = Pexp_tuple [ hd; tl ]; _ } as tup) ) ->
1235
+ let hd' = f hd in
1236
+ let tl' = map_children f tl in
1237
+ { v with pexp_desc = Pexp_construct (c, Some { tup with pexp_desc = Pexp_tuple [ hd'; tl' ] }) }
1238
+ | Pexp_construct ({ txt = Longident.Lident "[]"; _ }, None) -> v
1239
+ | _ -> f v
1240
+
1241
+ (* ---- traversal: find @xote.component and decompose ----------------------- *)
1242
+ (* `@xote.component` is the single annotation: it derives props exactly like
1243
+ `@jsx.component` (which we emit for the JSX transform to expand) *and*
1244
+ fine-grained-decomposes the returned JSX. One attribute replaces
1245
+ `@jsx.component` and makes the whole component tracked. *)
1246
+ let is_xote_component ((name, _) : attribute) = name.Location.txt = "xote.component"
1247
+ let strip_xote_component = List.filter (fun a -> not (is_xote_component a))
1248
+ let jsx_component_attr : attribute = (mkloc "jsx.component", PStr [])
1249
+
1250
+ let rec map_expr (env : env) (e : expression) : expression = map_children_expr env e
1251
+
1252
+ and map_children_expr (env : env) (e : expression) : expression =
1253
+ let d =
1254
+ match e.pexp_desc with
1255
+ | Pexp_fun (l, def, p, body) -> Pexp_fun (l, def, p, map_expr env body)
1256
+ | Pexp_let (r, vbs, body) ->
1257
+ (* aliases bound here are visible in the body, not in the RHSs *)
1258
+ let vbs' = List.map (map_vb env) vbs in
1259
+ let env' = collect_val_aliases env vbs in
1260
+ Pexp_let (r, vbs', map_expr env' body)
1261
+ | Pexp_letmodule (name, me, body) ->
1262
+ let env' = collect_mod_alias env name me in
1263
+ Pexp_letmodule (name, me, map_expr env' body)
1264
+ | Pexp_open (o, l, x) ->
1265
+ let env' = collect_open env l.Location.txt in
1266
+ Pexp_open (o, l, map_expr env' x)
1267
+ | Pexp_sequence (a, b) -> Pexp_sequence (map_expr env a, map_expr env b)
1268
+ | Pexp_apply (f, args) ->
1269
+ Pexp_apply (map_expr env f, List.map (fun (l, a) -> (l, map_expr env a)) args)
1270
+ | Pexp_ifthenelse (c, t, eo) ->
1271
+ Pexp_ifthenelse (map_expr env c, map_expr env t, Option.map (map_expr env) eo)
1272
+ | Pexp_match (x, cases) ->
1273
+ Pexp_match (map_expr env x, List.map (fun cs -> { cs with pc_rhs = map_expr env cs.pc_rhs }) cases)
1274
+ | Pexp_constraint (x, t) -> Pexp_constraint (map_expr env x, t)
1275
+ | Pexp_tuple xs -> Pexp_tuple (List.map (map_expr env) xs)
1276
+ | Pexp_array xs -> Pexp_array (List.map (map_expr env) xs)
1277
+ | Pexp_construct (l, eo) -> Pexp_construct (l, Option.map (map_expr env) eo)
1278
+ | other -> other
1279
+ in
1280
+ { e with pexp_desc = d }
1281
+
1282
+ and map_vb (env : env) (vb : value_binding) : value_binding =
1283
+ match List.find_opt is_xote_component vb.pvb_attributes with
1284
+ | Some _ ->
1285
+ (* swap @xote.component -> @jsx.component and decompose the returned JSX *)
1286
+ { vb with
1287
+ pvb_attributes = jsx_component_attr :: strip_xote_component vb.pvb_attributes;
1288
+ pvb_expr = decompose_component_body env vb.pvb_expr }
1289
+ | None -> { vb with pvb_expr = map_expr env vb.pvb_expr }
1290
+
1291
+ (* Walk to the component's tail (return) expression, threading the alias env
1292
+ through lets/opens and running the normal traversal on non-tail parts (so a
1293
+ nested reactive leaves still work), then fine-grain the returned JSX. *)
1294
+ and decompose_component_body (env : env) (e : expression) : expression =
1295
+ match e.pexp_desc with
1296
+ (* Uncurried function encoding: `Function$(fun … -> body)` (with res.arity on
1297
+ the construct, preserved by the record-with). Unwrap to reach the fun. *)
1298
+ | Pexp_construct (({ txt = Longident.Lident "Function$"; _ } as c), Some fn) ->
1299
+ { e with pexp_desc = Pexp_construct (c, Some (decompose_component_body env fn)) }
1300
+ | Pexp_fun (l, def, p, body) ->
1301
+ { e with pexp_desc = Pexp_fun (l, def, p, decompose_component_body env body) }
1302
+ | Pexp_let (r, vbs, body) ->
1303
+ let vbs' = List.map (map_vb env) vbs in
1304
+ let env' = collect_val_aliases env vbs in
1305
+ { e with pexp_desc = Pexp_let (r, vbs', decompose_component_body env' body) }
1306
+ | Pexp_letmodule (name, me, body) ->
1307
+ let env' = collect_mod_alias env name me in
1308
+ { e with pexp_desc = Pexp_letmodule (name, me, decompose_component_body env' body) }
1309
+ | Pexp_open (o, l, x) ->
1310
+ let env' = collect_open env l.Location.txt in
1311
+ { e with pexp_desc = Pexp_open (o, l, decompose_component_body env' x) }
1312
+ | Pexp_sequence (a, b) ->
1313
+ { e with pexp_desc = Pexp_sequence (map_expr env a, decompose_component_body env b) }
1314
+ | Pexp_constraint (x, t) ->
1315
+ { e with pexp_desc = Pexp_constraint (decompose_component_body env x, t) }
1316
+ | _ -> fine_node env e
1317
+
1318
+ (* Structure items are threaded left-to-right so a top-level `let g = Signal.get`,
1319
+ `module S = Signal`, or `open Signal` is visible to later items. *)
1320
+ let rec map_structure (env : env) (s : structure) : structure =
1321
+ let _, rev =
1322
+ List.fold_left
1323
+ (fun (env, acc) si -> (update_env_si env si, map_si env si :: acc))
1324
+ (env, []) s
1325
+ in
1326
+ List.rev rev
1327
+
1328
+ and update_env_si (env : env) si =
1329
+ match si.pstr_desc with
1330
+ | Pstr_value (_, vbs) -> collect_val_aliases env vbs
1331
+ | Pstr_module mb -> collect_mod_alias env mb.pmb_name mb.pmb_expr
1332
+ | Pstr_open od -> collect_open env od.popen_lid.Location.txt
1333
+ | _ -> env
1334
+
1335
+ and map_si (env : env) si =
1336
+ match si.pstr_desc with
1337
+ | Pstr_value (r, vbs) -> { si with pstr_desc = Pstr_value (r, List.map (map_vb env) vbs) }
1338
+ | Pstr_module mb -> { si with pstr_desc = Pstr_module (map_mb env mb) }
1339
+ | Pstr_eval (e, attrs) -> { si with pstr_desc = Pstr_eval (map_expr env e, attrs) }
1340
+ | _ -> si
1341
+
1342
+ and map_mb (env : env) mb = { mb with pmb_expr = map_mod env mb.pmb_expr }
1343
+ and map_mod (env : env) me =
1344
+ match me.pmod_desc with
1345
+ | Pmod_structure s -> { me with pmod_desc = Pmod_structure (map_structure env s) }
1346
+ | _ -> me
1347
+
1348
+ (* ---- ReScript -ppx binary protocol: `ppx <infile> <outfile>` ------------ *)
1349
+ let impl_magic = "Caml1999M022"
1350
+ let () =
1351
+ let n = Array.length Sys.argv in
1352
+ let infile = Sys.argv.(n - 2) and outfile = Sys.argv.(n - 1) in
1353
+ let ic = open_in_bin infile in
1354
+ let magic = really_input_string ic (String.length impl_magic) in
1355
+ let name : string = input_value ic in
1356
+ let payload : Obj.t = input_value ic in
1357
+ close_in ic;
1358
+ let oc = open_out_bin outfile in
1359
+ output_string oc magic;
1360
+ output_value oc name;
1361
+ (if magic = impl_magic then output_value oc (map_structure empty_env (Obj.magic payload : structure))
1362
+ else output_value oc payload);
1363
+ close_out oc