Skip to content

Commit b60d4ec

Browse files
author
Nathan Rebours
committed
Add support for 5.4 bivariant type parameters in type declaration
Signed-off-by: Nathan Rebours <nathan.rebours@ocamlpro.com>
1 parent 07c686a commit b60d4ec

File tree

6 files changed

+184
-47
lines changed

6 files changed

+184
-47
lines changed

‎astlib/encoding_504.ml‎

Lines changed: 46 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,11 @@
1+
open Stdlib0
2+
13
module Ext_name = struct
24
let ptyp_labeled_tuple = "ppxlib.migration.ptyp_labeled_tuple_504"
35
let pexp_labeled_tuple = "ppxlib.migration.pexp_labeled_tuple_504"
46
let ppat_labeled_tuple = "ppxlib.migration.ppat_labeled_tuple_504"
7+
let bivariant_param = "ppxlib.migration.bivariant_param_504"
8+
let bivariant_pstr = "ppxlib.migration.bivariant_str_item_504"
59
end
610

711
let invalid_encoding ~loc name =
@@ -197,7 +201,7 @@ module Make (X : AST) = struct
197201
| None -> invalid_encoding ~loc Ext_name.ppat_labeled_tuple
198202
end
199203

200-
module Ast_503 = struct
204+
module Ast_503_arg = struct
201205
include Ast_503.Asttypes
202206
include Ast_503.Parsetree
203207

@@ -277,7 +281,7 @@ module Ast_503 = struct
277281
end
278282
end
279283

280-
module Ast_502 = struct
284+
module Ast_502_arg = struct
281285
include Ast_502.Asttypes
282286
include Ast_502.Parsetree
283287

@@ -358,9 +362,47 @@ module Ast_502 = struct
358362
end
359363

360364
module To_503 = struct
361-
include Make (Ast_503)
365+
include Make (Ast_503_arg)
366+
open Ast_503.Asttypes
367+
open Ast_503.Parsetree
368+
369+
let encode_bivariant_param typ inj =
370+
let loc = { typ.ptyp_loc with Location.loc_ghost = true } in
371+
let attr =
372+
{
373+
attr_name = { txt = Ext_name.bivariant_param; loc };
374+
attr_payload = PStr [];
375+
attr_loc = loc;
376+
}
377+
in
378+
( { typ with ptyp_attributes = attr :: typ.ptyp_attributes },
379+
(NoVariance, inj) )
380+
381+
let decode_bivariant_param (typ, (var, inj)) =
382+
let ptyp_attributes =
383+
List.without_first typ.ptyp_attributes ~pred:(fun attr ->
384+
String.equal attr.attr_name.txt Ext_name.bivariant_param)
385+
in
386+
match (ptyp_attributes, var) with
387+
| Some ptyp_attributes, NoVariance ->
388+
Some ({ typ with ptyp_attributes }, inj)
389+
| None, _ -> None
390+
| Some _, _ -> invalid_encoding ~loc:typ.ptyp_loc "bivariant type parameter"
391+
392+
let encode_bivariant_pstr_type ~loc rec_flag tds =
393+
let loc = { loc with Location.loc_ghost = true } in
394+
let ext =
395+
( { txt = Ext_name.bivariant_pstr; loc },
396+
PStr [ { pstr_loc = loc; pstr_desc = Pstr_type (rec_flag, tds) } ] )
397+
in
398+
Pstr_extension (ext, [])
399+
400+
let decode_bivariant_pstr ~loc payload =
401+
match payload with
402+
| PStr [ { pstr_desc = Pstr_type _ as x; _ } ] -> x
403+
| _ -> invalid_encoding ~loc "bivariant structure_item"
362404
end
363405

364406
module To_502 = struct
365-
include Make (Ast_502)
407+
include Make (Ast_502_arg)
366408
end

‎astlib/encoding_504.mli‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module Ext_name : sig
22
val ptyp_labeled_tuple : string
33
val pexp_labeled_tuple : string
44
val ppat_labeled_tuple : string
5+
val bivariant_pstr : string
56
end
67

78
module To_503 : sig
@@ -28,6 +29,17 @@ module To_503 : sig
2829

2930
val decode_ppat_labeled_tuple :
3031
loc:Location.t -> payload -> (string option * pattern) list * closed_flag
32+
33+
val encode_bivariant_param :
34+
core_type -> injectivity -> core_type * (variance * injectivity)
35+
36+
val decode_bivariant_param :
37+
core_type * (variance * injectivity) -> (core_type * injectivity) option
38+
39+
val encode_bivariant_pstr_type :
40+
loc:Location.t -> rec_flag -> type_declaration list -> structure_item_desc
41+
42+
val decode_bivariant_pstr : loc:Location.t -> payload -> structure_item_desc
3143
end
3244

3345
module To_502 : sig

‎astlib/migrate_503_504.ml‎

Lines changed: 23 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -544,12 +544,14 @@ and copy_structure : Ast_503.Parsetree.structure -> Ast_504.Parsetree.structure
544544
and copy_structure_item :
545545
Ast_503.Parsetree.structure_item -> Ast_504.Parsetree.structure_item =
546546
fun { Ast_503.Parsetree.pstr_desc; Ast_503.Parsetree.pstr_loc } ->
547+
let loc = copy_location pstr_loc in
547548
{
548-
Ast_504.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc;
549-
Ast_504.Parsetree.pstr_loc = copy_location pstr_loc;
549+
Ast_504.Parsetree.pstr_desc =
550+
copy_structure_item_desc_with_loc ~loc pstr_desc;
551+
Ast_504.Parsetree.pstr_loc = loc;
550552
}
551553

552-
and copy_structure_item_desc :
554+
and copy_structure_item_desc_with_loc ~loc :
553555
Ast_503.Parsetree.structure_item_desc ->
554556
Ast_504.Parsetree.structure_item_desc = function
555557
| Ast_503.Parsetree.Pstr_eval (x0, x1) ->
@@ -583,9 +585,16 @@ and copy_structure_item_desc :
583585
Ast_504.Parsetree.Pstr_include (copy_include_declaration x0)
584586
| Ast_503.Parsetree.Pstr_attribute x0 ->
585587
Ast_504.Parsetree.Pstr_attribute (copy_attribute x0)
588+
| Ast_503.Parsetree.Pstr_extension (({ txt; _ }, payload), [])
589+
when String.equal txt Encoding_504.Ext_name.bivariant_pstr ->
590+
let desc = Encoding_504.To_503.decode_bivariant_pstr ~loc payload in
591+
copy_structure_item_desc_with_loc ~loc desc
586592
| Ast_503.Parsetree.Pstr_extension (x0, x1) ->
587593
Ast_504.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1)
588594

595+
and copy_structure_item_desc stri_desc =
596+
copy_structure_item_desc_with_loc ~loc:Location.none stri_desc
597+
589598
and copy_include_declaration :
590599
Ast_503.Parsetree.include_declaration ->
591600
Ast_504.Parsetree.include_declaration =
@@ -1164,6 +1173,16 @@ and copy_extension_constructor_kind :
11641173
| Ast_503.Parsetree.Pext_rebind x0 ->
11651174
Ast_504.Parsetree.Pext_rebind (copy_loc (copy_Longident_t ~loc:x0.loc) x0)
11661175

1176+
and copy_type_params params =
1177+
List.map
1178+
(fun ((typ, (var, inj)) as param) ->
1179+
match Encoding_504.To_503.decode_bivariant_param param with
1180+
| Some (typ, inj) ->
1181+
( copy_core_type typ,
1182+
(Ast_504.Asttypes.Bivariant, copy_injectivity inj) )
1183+
| None -> (copy_core_type typ, (copy_variance var, copy_injectivity inj)))
1184+
params
1185+
11671186
and copy_type_declaration :
11681187
Ast_503.Parsetree.type_declaration -> Ast_504.Parsetree.type_declaration =
11691188
fun {
@@ -1178,14 +1197,7 @@ and copy_type_declaration :
11781197
} ->
11791198
{
11801199
Ast_504.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
1181-
Ast_504.Parsetree.ptype_params =
1182-
List.map
1183-
(fun x ->
1184-
let x0, x1 = x in
1185-
( copy_core_type x0,
1186-
let x0, x1 = x1 in
1187-
(copy_variance x0, copy_injectivity x1) ))
1188-
ptype_params;
1200+
Ast_504.Parsetree.ptype_params = copy_type_params ptype_params;
11891201
Ast_504.Parsetree.ptype_cstrs =
11901202
List.map
11911203
(fun x ->

‎astlib/migrate_504_503.ml‎

Lines changed: 77 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,16 @@ open Stdlib0
22
module From = Ast_504
33
module To = Ast_503
44

5-
let migration_error loc missing_feature =
6-
Location.raise_errorf ~loc
7-
"migration error: %s are not supported before OCaml 5.4" missing_feature
5+
module Bivariant_param = struct
6+
type exn +=
7+
| T
8+
| Type_decl of Ast_503.Parsetree.type_declaration
9+
| Type_decl_list of Ast_503.Parsetree.type_declaration list
10+
11+
(* TODO: register exception printers to display those as location errors
12+
pointing to the right AST element and displaying a clear migration error
13+
message *)
14+
end
815

916
let rec copy_toplevel_phrase :
1017
Ast_504.Parsetree.toplevel_phrase -> Ast_503.Parsetree.toplevel_phrase =
@@ -528,12 +535,14 @@ and copy_structure : Ast_504.Parsetree.structure -> Ast_503.Parsetree.structure
528535
and copy_structure_item :
529536
Ast_504.Parsetree.structure_item -> Ast_503.Parsetree.structure_item =
530537
fun { Ast_504.Parsetree.pstr_desc; Ast_504.Parsetree.pstr_loc } ->
538+
let loc = copy_location pstr_loc in
531539
{
532-
Ast_503.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc;
533-
Ast_503.Parsetree.pstr_loc = copy_location pstr_loc;
540+
Ast_503.Parsetree.pstr_desc =
541+
copy_structure_item_desc_with_loc ~loc pstr_desc;
542+
Ast_503.Parsetree.pstr_loc = loc;
534543
}
535544

536-
and copy_structure_item_desc :
545+
and copy_structure_item_desc_with_loc ~loc :
537546
Ast_504.Parsetree.structure_item_desc ->
538547
Ast_503.Parsetree.structure_item_desc = function
539548
| Ast_504.Parsetree.Pstr_eval (x0, x1) ->
@@ -543,9 +552,12 @@ and copy_structure_item_desc :
543552
(copy_rec_flag x0, List.map copy_value_binding x1)
544553
| Ast_504.Parsetree.Pstr_primitive x0 ->
545554
Ast_503.Parsetree.Pstr_primitive (copy_value_description x0)
546-
| Ast_504.Parsetree.Pstr_type (x0, x1) ->
547-
Ast_503.Parsetree.Pstr_type
548-
(copy_rec_flag x0, List.map copy_type_declaration x1)
555+
| Ast_504.Parsetree.Pstr_type (x0, x1) -> (
556+
let rec_flag = copy_rec_flag x0 in
557+
match copy_type_declaration_list x1 with
558+
| tds -> Ast_503.Parsetree.Pstr_type (rec_flag, tds)
559+
| exception Bivariant_param.Type_decl_list tds ->
560+
Encoding_504.To_503.encode_bivariant_pstr_type ~loc rec_flag tds)
549561
| Ast_504.Parsetree.Pstr_typext x0 ->
550562
Ast_503.Parsetree.Pstr_typext (copy_type_extension x0)
551563
| Ast_504.Parsetree.Pstr_exception x0 ->
@@ -570,6 +582,9 @@ and copy_structure_item_desc :
570582
| Ast_504.Parsetree.Pstr_extension (x0, x1) ->
571583
Ast_503.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1)
572584

585+
and copy_structure_item_desc stri_d =
586+
copy_structure_item_desc_with_loc ~loc:Location.none stri_d
587+
573588
and copy_include_declaration :
574589
Ast_504.Parsetree.include_declaration ->
575590
Ast_503.Parsetree.include_declaration =
@@ -1143,6 +1158,21 @@ and copy_extension_constructor_kind :
11431158
| Ast_504.Parsetree.Pext_rebind x0 ->
11441159
Ast_503.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0)
11451160

1161+
and copy_type_params params =
1162+
let contains_bivariant_param = ref false in
1163+
let params' =
1164+
List.map
1165+
(fun (typ, (variance, injectivity)) ->
1166+
let typ' = copy_core_type typ in
1167+
let injectivity' = copy_injectivity injectivity in
1168+
try (typ', (copy_variance variance, injectivity'))
1169+
with Bivariant_param.T ->
1170+
contains_bivariant_param := true;
1171+
Encoding_504.To_503.encode_bivariant_param typ' injectivity')
1172+
params
1173+
in
1174+
(params', !contains_bivariant_param)
1175+
11461176
and copy_type_declaration :
11471177
Ast_504.Parsetree.type_declaration -> Ast_503.Parsetree.type_declaration =
11481178
fun {
@@ -1155,28 +1185,43 @@ and copy_type_declaration :
11551185
Ast_504.Parsetree.ptype_attributes;
11561186
Ast_504.Parsetree.ptype_loc;
11571187
} ->
1158-
{
1159-
Ast_503.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
1160-
Ast_503.Parsetree.ptype_params =
1161-
List.map
1162-
(fun x ->
1163-
let x0, x1 = x in
1164-
( copy_core_type x0,
1165-
let x0, x1 = x1 in
1166-
(copy_variance x0, copy_injectivity x1) ))
1167-
ptype_params;
1168-
Ast_503.Parsetree.ptype_cstrs =
1169-
List.map
1170-
(fun x ->
1171-
let x0, x1, x2 = x in
1172-
(copy_core_type x0, copy_core_type x1, copy_location x2))
1173-
ptype_cstrs;
1174-
Ast_503.Parsetree.ptype_kind = copy_type_kind ptype_kind;
1175-
Ast_503.Parsetree.ptype_private = copy_private_flag ptype_private;
1176-
Ast_503.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest;
1177-
Ast_503.Parsetree.ptype_attributes = copy_attributes ptype_attributes;
1178-
Ast_503.Parsetree.ptype_loc = copy_location ptype_loc;
1179-
}
1188+
let params, contains_bivariant = copy_type_params ptype_params in
1189+
let td =
1190+
{
1191+
Ast_503.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
1192+
Ast_503.Parsetree.ptype_params = params;
1193+
Ast_503.Parsetree.ptype_cstrs =
1194+
List.map
1195+
(fun x ->
1196+
let x0, x1, x2 = x in
1197+
(copy_core_type x0, copy_core_type x1, copy_location x2))
1198+
ptype_cstrs;
1199+
Ast_503.Parsetree.ptype_kind = copy_type_kind ptype_kind;
1200+
Ast_503.Parsetree.ptype_private = copy_private_flag ptype_private;
1201+
Ast_503.Parsetree.ptype_manifest =
1202+
Option.map copy_core_type ptype_manifest;
1203+
Ast_503.Parsetree.ptype_attributes = copy_attributes ptype_attributes;
1204+
Ast_503.Parsetree.ptype_loc = copy_location ptype_loc;
1205+
}
1206+
in
1207+
if contains_bivariant then raise (Bivariant_param.Type_decl td) else td
1208+
1209+
and copy_type_declaration_list :
1210+
Ast_504.Parsetree.type_declaration list ->
1211+
Ast_503.Parsetree.type_declaration list =
1212+
fun l ->
1213+
let contains_bivariant_param = ref false in
1214+
let tds =
1215+
List.map
1216+
(fun td ->
1217+
try copy_type_declaration td
1218+
with Bivariant_param.Type_decl td' ->
1219+
contains_bivariant_param := true;
1220+
td')
1221+
l
1222+
in
1223+
if !contains_bivariant_param then raise (Bivariant_param.Type_decl_list tds)
1224+
else tds
11801225

11811226
and copy_private_flag :
11821227
Ast_504.Asttypes.private_flag -> Ast_503.Asttypes.private_flag = function
@@ -1253,7 +1298,7 @@ and copy_variance : Ast_504.Asttypes.variance -> Ast_503.Asttypes.variance =
12531298
| Ast_504.Asttypes.Covariant -> Ast_503.Asttypes.Covariant
12541299
| Ast_504.Asttypes.Contravariant -> Ast_503.Asttypes.Contravariant
12551300
| Ast_504.Asttypes.NoVariance -> Ast_503.Asttypes.NoVariance
1256-
| Ast_504.Asttypes.Bivariant -> migration_error Location.none "bivariance"
1301+
| Ast_504.Asttypes.Bivariant -> raise Bivariant_param.T
12571302

12581303
and copy_value_description :
12591304
Ast_504.Parsetree.value_description -> Ast_503.Parsetree.value_description =

‎astlib/stdlib0.ml‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,3 +30,15 @@ module Option = struct
3030
aux [] l
3131
end
3232
end
33+
34+
module List = struct
35+
include List
36+
37+
let without_first l ~pred =
38+
let rec aux seen = function
39+
| [] -> None
40+
| hd :: tl when pred hd -> Some (List.rev_append seen tl)
41+
| hd :: tl -> aux (hd :: seen) tl
42+
in
43+
aux [] l
44+
end

‎test/encoding/504/migrations/run.t‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,3 +42,17 @@ And same for patterns:
4242

4343
$ ./id_driver.exe pattern.ml --use-compiler-pp
4444
let (~a, ~b:_, c, ..) = x
45+
46+
We also check that bivariant type parameters are correctly encoded and migrated:
47+
48+
$ cat > bivariant.ml << EOF
49+
> type +-'a t = A
50+
> EOF
51+
52+
$ ./id_driver.exe bivariant.ml
53+
[%%ppxlib.migration.bivariant_str_item_504 type 'a t =
54+
| A ]
55+
56+
$ ./id_driver.exe bivariant.ml --use-compiler-pp
57+
type +-'a t =
58+
| A

0 commit comments

Comments
 (0)