Skip to content

Commit 1f8a38f

Browse files
author
Nathan Rebours
committed
Add support for 5.4 labeled tuples types
Signed-off-by: Nathan Rebours <nathan.rebours@ocamlpro.com>
1 parent 541aa7a commit 1f8a38f

File tree

9 files changed

+266
-19
lines changed

9 files changed

+266
-19
lines changed

‎astlib/encoding_504.ml‎

Lines changed: 152 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,152 @@
1+
module Ext_name = struct
2+
let ptyp_labeled_tuple = "ppxlib.migration.ptyp_labeled_tuple_504"
3+
end
4+
5+
module type AST = sig
6+
type payload
7+
type core_type
8+
type core_type_desc
9+
10+
module Construct : sig
11+
val ptyp_extension_desc : string Location.loc -> payload -> core_type_desc
12+
val ptyp_tuple : loc:Location.t -> core_type list -> core_type
13+
val ptyp_var : loc:Location.t -> string -> core_type
14+
val ptyp_any : loc:Location.t -> core_type
15+
val ptyp : core_type -> payload
16+
end
17+
18+
module Destruct : sig
19+
val ptyp : payload -> core_type option
20+
val ptyp_tuple : core_type -> core_type list option
21+
val ptyp_var : core_type -> string option
22+
val ptyp_any : core_type -> unit option
23+
end
24+
end
25+
26+
module type S = sig
27+
type payload
28+
type core_type
29+
type core_type_desc
30+
31+
val encode_ptyp_labeled_tuple :
32+
loc:Location.t -> (string option * core_type) list -> core_type_desc
33+
34+
val decode_ptyp_labeled_tuple :
35+
loc:Location.t -> payload -> (string option * core_type) list
36+
end
37+
38+
module Make (X : AST) :
39+
S
40+
with type core_type = X.core_type
41+
and type core_type_desc = X.core_type_desc
42+
and type payload = X.payload = struct
43+
type payload = X.payload
44+
type core_type = X.core_type
45+
type core_type_desc = X.core_type_desc
46+
47+
let encode_ptyp_labeled_tuple ~loc args =
48+
let payload =
49+
let l =
50+
List.map
51+
(fun (label_opt, typ) ->
52+
let label =
53+
match label_opt with
54+
| None -> X.Construct.ptyp_any ~loc
55+
| Some s -> X.Construct.ptyp_var ~loc s
56+
in
57+
X.Construct.ptyp_tuple ~loc [ label; typ ])
58+
args
59+
in
60+
X.Construct.ptyp_tuple ~loc l
61+
in
62+
X.Construct.ptyp_extension_desc
63+
{ txt = Ext_name.ptyp_labeled_tuple; loc }
64+
(X.Construct.ptyp payload)
65+
66+
let decode_ptyp_labeled_tuple ~loc payload =
67+
let open Stdlib0.Option.Op in
68+
let res =
69+
let* typ = X.Destruct.ptyp payload in
70+
let* typ_list = X.Destruct.ptyp_tuple typ in
71+
Stdlib0.Option.List.map typ_list ~f:(fun typ ->
72+
let* typ_pair = X.Destruct.ptyp_tuple typ in
73+
match typ_pair with
74+
| [ label; typ ] -> (
75+
match (X.Destruct.ptyp_var label, X.Destruct.ptyp_any label) with
76+
| Some s, _ -> Some (Some s, typ)
77+
| _, Some () -> Some (None, typ)
78+
| None, None -> None)
79+
| _ -> None)
80+
in
81+
match res with
82+
| Some res -> res
83+
| None ->
84+
Location.raise_errorf ~loc "Invalid %s encoding"
85+
Ext_name.ptyp_labeled_tuple
86+
end
87+
88+
module Ast_503 = struct
89+
include Ast_503.Parsetree
90+
91+
module Construct = struct
92+
let core_type ~loc ptyp_desc =
93+
{ ptyp_desc; ptyp_loc = loc; ptyp_attributes = []; ptyp_loc_stack = [] }
94+
95+
let ptyp_extension_desc name payload = Ptyp_extension (name, payload)
96+
let ptyp_tuple ~loc typs = core_type ~loc (Ptyp_tuple typs)
97+
let ptyp_var ~loc s = core_type ~loc (Ptyp_var s)
98+
let ptyp_any ~loc = core_type ~loc Ptyp_any
99+
let ptyp typ = PTyp typ
100+
end
101+
102+
module Destruct = struct
103+
let ptyp = function PTyp typ -> Some typ | _ -> None
104+
105+
let ptyp_tuple = function
106+
| { ptyp_desc = Ptyp_tuple typs; _ } -> Some typs
107+
| _ -> None
108+
109+
let ptyp_var = function
110+
| { ptyp_desc = Ptyp_var s; _ } -> Some s
111+
| _ -> None
112+
113+
let ptyp_any = function { ptyp_desc = Ptyp_any; _ } -> Some () | _ -> None
114+
end
115+
end
116+
117+
module Ast_502 = struct
118+
include Ast_502.Parsetree
119+
120+
module Construct = struct
121+
let core_type ~loc ptyp_desc =
122+
{ ptyp_desc; ptyp_loc = loc; ptyp_attributes = []; ptyp_loc_stack = [] }
123+
124+
let ptyp_extension_desc name payload = Ptyp_extension (name, payload)
125+
let ptyp_tuple ~loc typs = core_type ~loc (Ptyp_tuple typs)
126+
let ptyp_var ~loc s = core_type ~loc (Ptyp_var s)
127+
let ptyp_any ~loc = core_type ~loc Ptyp_any
128+
let ptyp typ = PTyp typ
129+
end
130+
131+
module Destruct = struct
132+
let ptyp = function PTyp typ -> Some typ | _ -> None
133+
134+
let ptyp_tuple = function
135+
| { ptyp_desc = Ptyp_tuple typs; _ } -> Some typs
136+
| _ -> None
137+
138+
let ptyp_var = function
139+
| { ptyp_desc = Ptyp_var s; _ } -> Some s
140+
| _ -> None
141+
142+
let ptyp_any = function { ptyp_desc = Ptyp_any; _ } -> Some () | _ -> None
143+
end
144+
end
145+
146+
module To_503 = struct
147+
include Make (Ast_503)
148+
end
149+
150+
module To_502 = struct
151+
include Make (Ast_502)
152+
end

‎astlib/encoding_504.mli‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
module Ext_name : sig
2+
val ptyp_labeled_tuple : string
3+
end
4+
5+
module To_503 : sig
6+
open Ast_503.Parsetree
7+
8+
val encode_ptyp_labeled_tuple :
9+
loc:Location.t -> (string option * core_type) list -> core_type_desc
10+
11+
val decode_ptyp_labeled_tuple :
12+
loc:Location.t -> payload -> (string option * core_type) list
13+
end
14+
15+
module To_502 : sig
16+
open Ast_502.Parsetree
17+
18+
val encode_ptyp_labeled_tuple :
19+
loc:Location.t -> (string option * core_type) list -> core_type_desc
20+
21+
val decode_ptyp_labeled_tuple :
22+
loc:Location.t -> payload -> (string option * core_type) list
23+
end

‎astlib/migrate_503_504.ml‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -433,6 +433,11 @@ and copy_core_type_desc :
433433
| Ast_503.Parsetree.Ptyp_open (x0, ty) ->
434434
Ast_504.Parsetree.Ptyp_open
435435
(copy_loc copy_Longident_t x0, copy_core_type ty)
436+
| Ast_503.Parsetree.Ptyp_extension ({ txt; loc }, payload)
437+
when String.equal txt Encoding_504.Ext_name.ptyp_labeled_tuple ->
438+
let xs = Encoding_504.To_503.decode_ptyp_labeled_tuple ~loc payload in
439+
Ast_504.Parsetree.Ptyp_tuple
440+
(List.map (fun (lbl, typ) -> (lbl, copy_core_type typ)) xs)
436441
| Ast_503.Parsetree.Ptyp_extension x0 ->
437442
Ast_504.Parsetree.Ptyp_extension (copy_extension x0)
438443

‎astlib/migrate_504_503.ml‎

Lines changed: 10 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -406,9 +406,10 @@ and copy_core_type : Ast_504.Parsetree.core_type -> Ast_503.Parsetree.core_type
406406
Ast_504.Parsetree.ptyp_loc_stack;
407407
Ast_504.Parsetree.ptyp_attributes;
408408
} ->
409+
let loc = copy_location ptyp_loc in
409410
{
410-
Ast_503.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc;
411-
Ast_503.Parsetree.ptyp_loc = copy_location ptyp_loc;
411+
Ast_503.Parsetree.ptyp_desc = copy_core_type_desc ~loc ptyp_desc;
412+
Ast_503.Parsetree.ptyp_loc = loc;
412413
Ast_503.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack;
413414
Ast_503.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes;
414415
}
@@ -417,7 +418,7 @@ and copy_location_stack :
417418
Ast_504.Parsetree.location_stack -> Ast_503.Parsetree.location_stack =
418419
fun x -> List.map copy_location x
419420

420-
and copy_core_type_desc :
421+
and copy_core_type_desc ~loc :
421422
Ast_504.Parsetree.core_type_desc -> Ast_503.Parsetree.core_type_desc =
422423
function
423424
| Ast_504.Parsetree.Ptyp_any -> Ast_503.Parsetree.Ptyp_any
@@ -426,15 +427,13 @@ and copy_core_type_desc :
426427
Ast_503.Parsetree.Ptyp_arrow
427428
(copy_arg_label x0, copy_core_type x1, copy_core_type x2)
428429
| Ast_504.Parsetree.Ptyp_tuple x0 ->
429-
let args =
430-
List.map
431-
(function
432-
| None, arg -> arg
433-
| Some l, (arg : Ast_504.Parsetree.core_type) ->
434-
migration_error arg.ptyp_loc "labelled tuples")
435-
x0 (* TODO: Proper migration error *)
430+
let typs =
431+
List.map (fun (label, typ) -> (label, copy_core_type typ)) x0
436432
in
437-
Ast_503.Parsetree.Ptyp_tuple (List.map copy_core_type args)
433+
if List.exists (function Some _, _ -> true | _ -> false) typs then
434+
(* At least one element of the tuple is labeled *)
435+
Encoding_504.To_503.encode_ptyp_labeled_tuple ~loc typs
436+
else Ast_503.Parsetree.Ptyp_tuple (List.map snd typs)
438437
| Ast_504.Parsetree.Ptyp_constr (x0, x1) ->
439438
Ast_503.Parsetree.Ptyp_constr
440439
(copy_loc copy_Longident_t x0, List.map copy_core_type x1)

‎astlib/stdlib0.ml‎

Lines changed: 22 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,6 @@
1-
module Int = struct
2-
let to_string = string_of_int
3-
end
4-
5-
module Option = struct
6-
let map f o = match o with None -> None | Some v -> Some (f v)
7-
end
8-
91
module String = struct
2+
include String
3+
104
let is_prefix t ~prefix =
115
let rec is_prefix_from t ~prefix ~pos ~len =
126
pos >= len
@@ -16,3 +10,23 @@ module String = struct
1610
String.length t >= String.length prefix
1711
&& is_prefix_from t ~prefix ~pos:0 ~len:(String.length prefix)
1812
end
13+
14+
module Option = struct
15+
include Option
16+
17+
module Op = struct
18+
let ( let* ) = Option.bind
19+
let ( let+ ) o f = Option.map f o
20+
end
21+
22+
module List = struct
23+
let map ~f l =
24+
let rec aux acc l =
25+
match l with
26+
| [] -> Some (List.rev acc)
27+
| hd :: tl -> (
28+
match f hd with None -> None | Some x -> aux (x :: acc) tl)
29+
in
30+
aux [] l
31+
end
32+
end

‎src/ast_builder.ml‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -264,6 +264,12 @@ module Default = struct
264264
let ppat_tuple ~loc l = match l with [ x ] -> x | _ -> ppat_tuple ~loc l
265265
let ptyp_tuple ~loc l = match l with [ x ] -> x | _ -> ptyp_tuple ~loc l
266266

267+
let ptyp_labeled_tuple ~loc l =
268+
let ptyp_desc =
269+
Astlib__.Encoding_504.To_502.encode_ptyp_labeled_tuple ~loc l
270+
in
271+
{ ptyp_desc; ptyp_loc = loc; ptyp_attributes = []; ptyp_loc_stack = [] }
272+
267273
let pexp_tuple_opt ~loc l =
268274
match l with [] -> None | _ :: _ -> Some (pexp_tuple ~loc l)
269275

@@ -555,6 +561,7 @@ end) : S = struct
555561
let pexp_tuple l = Default.pexp_tuple ~loc l
556562
let ppat_tuple l = Default.ppat_tuple ~loc l
557563
let ptyp_tuple l = Default.ptyp_tuple ~loc l
564+
let ptyp_labeled_tuple l = Default.ptyp_labeled_tuple ~loc l
558565
let pexp_tuple_opt l = Default.pexp_tuple_opt ~loc l
559566
let ppat_tuple_opt l = Default.ppat_tuple_opt ~loc l
560567
let ptyp_poly vars ty = Default.ptyp_poly ~loc vars ty

‎src/ast_builder_intf.ml‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -153,6 +153,23 @@ module type Additional_helpers = sig
153153

154154
val eta_reduce_if_possible_and_nonrec :
155155
expression -> rec_flag:rec_flag -> expression
156+
157+
(** {2:future-asts Compat functions for future AST nodes}
158+
159+
The functions in this section provide a safe interface to generate AST
160+
nodes that cannot be represented with Ppxlib's own AST but are available
161+
with more recent versions of the compiler.
162+
163+
Note that producing such nodes will make the generated code incompatible
164+
with compilers older than the feature you are trying to represent. Those
165+
nodes also won't play nicely with the driver's default source output or if
166+
printed as source using [Ppxlib.Pprintast]. You can use the
167+
--use-compiler-pp flag of the driver to use your current compiler's AST to
168+
source printers. *)
169+
170+
val ptyp_labeled_tuple :
171+
((string option * core_type) list -> core_type) with_loc
172+
(** Returns an encoded labeled tuple type as introduced in OCaml 5.4. *)
156173
end
157174

158175
module type Located = sig

‎src/ast_pattern.ml‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -275,3 +275,20 @@ let esequence (T f) =
275275

276276
let of_func f = T f
277277
let to_func (T f) = f
278+
279+
let ptyp_labeled_tuple (T f0) =
280+
T
281+
(fun ctx _loc x k ->
282+
let loc = x.ptyp_loc in
283+
let x = x.ptyp_desc in
284+
match x with
285+
| Ptyp_extension ({ txt; _ }, payload)
286+
when String.equal txt Astlib__.Encoding_504.Ext_name.ptyp_labeled_tuple
287+
->
288+
let x0 =
289+
Astlib__.Encoding_504.To_502.decode_ptyp_labeled_tuple ~loc payload
290+
in
291+
ctx.matched <- ctx.matched + 1;
292+
let k = f0 ctx loc x0 k in
293+
k
294+
| _ -> fail loc "labeled tuple")

‎src/ast_pattern.mli‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -214,3 +214,16 @@ val to_func : ('a, 'b, 'c) t -> context -> Location.t -> 'a -> 'b -> 'c
214214
val fail : Location.t -> string -> _
215215
(** Call from [of_func]'s argument when the pattern does not match. The string
216216
should describe the expected shape of the AST where the match failed. *)
217+
218+
(** {2:future-asts Compat functions for future AST nodes}
219+
220+
The functions in this section provide a safe interface to match over AST
221+
nodes that cannot be represented with Ppxlib's own AST but are available
222+
with more recent versions of the compiler. *)
223+
224+
val ptyp_labeled_tuple :
225+
((string option * core_type) list, 'a, 'b) t -> (core_type, 'a, 'b) t
226+
(** Match over an encoded OCaml 5.4 labeled tuple type.
227+
228+
It will fail on a regular tuple type and as a consequence, if it matches, at
229+
least one type in the tuple is guaranteed to be labeled. *)

0 commit comments

Comments
 (0)