Skip to content

Commit afd927c

Browse files
azzsalazzsal
authored
Add support for extension constructors (#146)
* Update sig_item map to have ext. cstrs * Update sig item map * Add support for extcstr and handle exceptions * Add tests for exceptions * Add change log * Minor fixes * Format * Fix ext cstrs params
1 parent 39f7be4 commit afd927c

File tree

10 files changed

+380
-41
lines changed

10 files changed

+380
-41
lines changed

‎CHANGES.md‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,8 @@
1515
- Add fine-grained diff of tuple types (#139, @azzsal)
1616
- Add fine-grained diff of arrow types (#140, @azzsal)
1717
- Add fine-grained diff of type constructors (#148, @azzsal)
18+
- Add detection of addition, removal and modifications of extensible variant
19+
constructors (#146, @azzsal)
1820

1921
### Changed
2022

‎lib/diff.ml‎

Lines changed: 97 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,24 @@ type cltype = {
8989
ctdiff : Types.class_type_declaration Stddiff.atomic_entry;
9090
}
9191

92+
type extcstr = {
93+
ecname : string;
94+
ectname : string;
95+
ecexn : bool;
96+
ecdiff : (Types.extension_constructor, extcstr_modification) Stddiff.entry;
97+
}
98+
99+
and extcstr_modification = {
100+
extcstr_params :
101+
( Types.type_expr list,
102+
( Types.type_expr list,
103+
(Types.type_expr, type_expr) Stddiff.List.t )
104+
Stddiff.entry )
105+
Stddiff.maybe_changed;
106+
extcstr_private : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed;
107+
extcstr_args : (Types.constructor_arguments, cstr_args) Stddiff.maybe_changed;
108+
}
109+
92110
type module_ = {
93111
mname : string;
94112
mdiff : (Types.module_declaration, signature_modification) Stddiff.entry;
@@ -108,6 +126,7 @@ and sig_item =
108126
| Modtype of modtype
109127
| Class of class_
110128
| Classtype of cltype
129+
| Extcstr of extcstr
111130

112131
let extract_items items =
113132
List.fold_left
@@ -137,6 +156,12 @@ let extract_items items =
137156
else
138157
Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Classtype
139158
class_type_decl tbl
159+
| Sig_typext (id, typext, status, Exported) ->
160+
let exn = match status with Text_exception -> true | _ -> false in
161+
Sig_item_map.add
162+
~name:(Path.name typext.ext_type_path)
163+
(Sig_item_map.Extcstr (Ident.name id))
164+
(typext, exn) tbl
140165
| _ -> tbl)
141166
Sig_item_map.empty items
142167

@@ -443,7 +468,16 @@ and variant_type ~typing_env ~ref_params ~cur_params ~ref_constructor_lst
443468
~reference:ref_cstrs ~current:cur_cstrs
444469

445470
and cstr ~typing_env ~ref_params ~cur_params reference current =
446-
match (reference.cd_args, current.cd_args) with
471+
let diff =
472+
cstr_args ~typing_env ~ref_params ~cur_params ~reference:reference.cd_args
473+
~current:current.cd_args
474+
in
475+
match diff with
476+
| Stddiff.Same _ -> Same reference
477+
| Changed change -> Changed change
478+
479+
and cstr_args ~typing_env ~ref_params ~cur_params ~reference ~current =
480+
match (reference, current) with
447481
| Cstr_tuple ref_type_exprs, Cstr_tuple cur_type_exprs -> (
448482
let type_exprs =
449483
type_exprs ~typing_env ~ref_params ~cur_params ~reference:ref_type_exprs
@@ -459,10 +493,7 @@ and cstr ~typing_env ~ref_params ~cur_params reference current =
459493
in
460494
if String_map.is_empty label_map.changed_map then Same reference
461495
else Changed (Record_cstr label_map)
462-
| _ ->
463-
Changed
464-
(Atomic_cstr
465-
{ reference = reference.cd_args; current = current.cd_args })
496+
| _ -> Changed (Atomic_cstr { reference; current })
466497

467498
and type_params ~reference ~current =
468499
let open Stddiff in
@@ -553,6 +584,64 @@ let class_type_item ~typing_env ~name
553584
{ reference = ref_class_type; current = curr_class_type };
554585
}))
555586

587+
let extension_constructors ~typing_env ~type_name ~name ~reference ~current =
588+
let ref_exn, ref_extcstr = reference in
589+
let cur_exn, cur_extcstr = current in
590+
let ecexn =
591+
match (ref_exn, cur_exn) with
592+
| true, true | false, false -> ref_exn
593+
| _ -> false
594+
in
595+
let extcstr_params =
596+
type_params ~reference:ref_extcstr.Types.ext_type_params
597+
~current:cur_extcstr.Types.ext_type_params
598+
in
599+
let extcstr_private =
600+
type_privacy ~reference:ref_extcstr.ext_private
601+
~current:cur_extcstr.ext_private
602+
in
603+
let extcstr_args =
604+
cstr_args ~typing_env ~ref_params:ref_extcstr.ext_type_params
605+
~cur_params:cur_extcstr.ext_type_params ~reference:ref_extcstr.ext_args
606+
~current:cur_extcstr.ext_args
607+
in
608+
match { extcstr_params; extcstr_private; extcstr_args } with
609+
| {
610+
extcstr_params = Same _ | Changed _;
611+
extcstr_private = Same _;
612+
extcstr_args = Same _;
613+
} ->
614+
None
615+
| diff ->
616+
Some
617+
(Extcstr
618+
{ ecname = name; ectname = type_name; ecexn; ecdiff = Modified diff })
619+
620+
let extcstr_item ~typing_env ~type_name ~name ~reference ~current =
621+
match (reference, current) with
622+
| None, None -> None
623+
| None, Some (curr_extcstr, curr_exn) ->
624+
Some
625+
(Extcstr
626+
{
627+
ecname = name;
628+
ectname = type_name;
629+
ecexn = curr_exn;
630+
ecdiff = Added curr_extcstr;
631+
})
632+
| Some (ref_extcstr, ref_exn), None ->
633+
Some
634+
(Extcstr
635+
{
636+
ecname = name;
637+
ectname = type_name;
638+
ecexn = ref_exn;
639+
ecdiff = Removed ref_extcstr;
640+
})
641+
| Some (ref_extcstr, ref_exn), Some (cur_extcstr, cur_exn) ->
642+
extension_constructors ~typing_env ~type_name ~name
643+
~reference:(ref_exn, ref_extcstr) ~current:(cur_exn, cur_extcstr)
644+
556645
let rec items ~reference ~current ~typing_env =
557646
let ref_items = extract_items reference in
558647
let curr_items = extract_items current in
@@ -565,6 +654,9 @@ let rec items ~reference ~current ~typing_env =
565654
| Type -> type_item ~typing_env ~name ~reference ~current
566655
| Class -> class_item ~typing_env ~name ~reference ~current
567656
| Classtype -> class_type_item ~typing_env ~name ~reference ~current
657+
| Extcstr extcstr_name ->
658+
extcstr_item ~typing_env ~name:extcstr_name ~type_name:name ~reference
659+
~current
568660
in
569661
Sig_item_map.diff ~diff_item:{ diff_item } ref_items curr_items
570662

‎lib/diff.mli‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,24 @@ type cltype = {
8989
ctdiff : Types.class_type_declaration Stddiff.atomic_entry;
9090
}
9191

92+
type extcstr = {
93+
ecname : string;
94+
ectname : string;
95+
ecexn : bool;
96+
ecdiff : (Types.extension_constructor, extcstr_modification) Stddiff.entry;
97+
}
98+
99+
and extcstr_modification = {
100+
extcstr_params :
101+
( Types.type_expr list,
102+
( Types.type_expr list,
103+
(Types.type_expr, type_expr) Stddiff.List.t )
104+
Stddiff.entry )
105+
Stddiff.maybe_changed;
106+
extcstr_private : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed;
107+
extcstr_args : (Types.constructor_arguments, cstr_args) Stddiff.maybe_changed;
108+
}
109+
92110
type module_ = {
93111
mname : string;
94112
mdiff : (Types.module_declaration, signature_modification) Stddiff.entry;
@@ -108,6 +126,7 @@ and sig_item =
108126
| Modtype of modtype
109127
| Class of class_
110128
| Classtype of cltype
129+
| Extcstr of extcstr
111130

112131
val interface :
113132
module_name:string ->

‎lib/sig_item_map.ml‎

Lines changed: 28 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ type t = {
77
types_map : (type_declaration * Ident.t) String_map.t;
88
class_map : class_declaration String_map.t;
99
class_type_map : class_type_declaration String_map.t;
10+
ext_cstr_map : (extension_constructor * bool) String_map.t;
1011
}
1112

1213
type _ item_type =
@@ -16,6 +17,7 @@ type _ item_type =
1617
| Type : (type_declaration * Ident.t) item_type
1718
| Class : class_declaration item_type
1819
| Classtype : class_type_declaration item_type
20+
| Extcstr : string -> (extension_constructor * bool) item_type
1921

2022
let empty : t =
2123
{
@@ -25,8 +27,11 @@ let empty : t =
2527
types_map = String_map.empty;
2628
class_map = String_map.empty;
2729
class_type_map = String_map.empty;
30+
ext_cstr_map = String_map.empty;
2831
}
2932

33+
let ext_cstr_full_name ~type_name ~name = Printf.sprintf "%s-%s" type_name name
34+
3035
let add (type a) ~name (item_type : a item_type) (item : a) maps : t =
3136
match item_type with
3237
| Value -> { maps with values_map = String_map.add name item maps.values_map }
@@ -41,6 +46,14 @@ let add (type a) ~name (item_type : a item_type) (item : a) maps : t =
4146
maps with
4247
class_type_map = String_map.add name item maps.class_type_map;
4348
}
49+
| Extcstr extcstr_name ->
50+
{
51+
maps with
52+
ext_cstr_map =
53+
String_map.add
54+
(ext_cstr_full_name ~type_name:name ~name:extcstr_name)
55+
item maps.ext_cstr_map;
56+
}
4457

4558
let has (type a) ~name (item_type : a item_type) maps : bool =
4659
match item_type with
@@ -50,6 +63,10 @@ let has (type a) ~name (item_type : a item_type) maps : bool =
5063
| Type -> String_map.mem name maps.types_map
5164
| Class -> String_map.mem name maps.class_map
5265
| Classtype -> String_map.mem name maps.class_type_map
66+
| Extcstr extcstr_name ->
67+
String_map.mem
68+
(ext_cstr_full_name ~type_name:name ~name:extcstr_name)
69+
maps.ext_cstr_map
5370

5471
type ('a, 'diff) diff_item =
5572
'a item_type -> string -> 'a option -> 'a option -> 'diff option
@@ -93,5 +110,15 @@ let diff ~diff_item:{ diff_item } ref_maps curr_maps : 'diff list =
93110
ref_maps.class_type_map curr_maps.class_type_map
94111
|> String_map.bindings |> List.map snd
95112
in
113+
let ext_cstr_diffs =
114+
String_map.merge
115+
(fun full_name ref_opt curr_opt ->
116+
let names = String.split_on_char '-' full_name in
117+
let type_name = List.hd names in
118+
let cstr_name = List.hd (List.tl names) in
119+
diff_item (Extcstr cstr_name) type_name ref_opt curr_opt)
120+
ref_maps.ext_cstr_map curr_maps.ext_cstr_map
121+
|> String_map.bindings |> List.map snd
122+
in
96123
value_diffs @ module_diffs @ modtype_diffs @ type_diffs @ class_diffs
97-
@ class_type_diffs
124+
@ class_type_diffs @ ext_cstr_diffs

‎lib/sig_item_map.mli‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ type _ item_type =
99
| Type : (type_declaration * Ident.t) item_type
1010
| Class : class_declaration item_type
1111
| Classtype : class_type_declaration item_type
12+
| Extcstr : string -> (extension_constructor * bool) item_type
1213

1314
val empty : t
1415
val add : name:string -> 'a item_type -> 'a -> t -> t

‎lib/text_diff.ml‎

Lines changed: 72 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -112,6 +112,16 @@ let mtd_to_lines name mtd =
112112
let abstract_module_type_str = "module type " ^ name in
113113
CCString.lines abstract_module_type_str
114114

115+
let extcstr_to_lines name ~exn ec =
116+
let buf = Buffer.create 256 in
117+
let formatter = Format.formatter_of_buffer buf in
118+
if exn then (
119+
Format.pp_print_string formatter "exception ";
120+
Printtyp.extension_only_constructor (Ident.create_local name) formatter ec)
121+
else Printtyp.extension_constructor (Ident.create_local name) formatter ec;
122+
Format.pp_print_flush formatter ();
123+
CCString.lines (Buffer.contents buf)
124+
115125
let cd_to_lines name cd =
116126
let buf = Buffer.create 256 in
117127
let formatter = Format.formatter_of_buffer buf in
@@ -454,25 +464,25 @@ and process_cstr_diff name cstr_diff =
454464
match cstr_diff with
455465
| Added cstr -> Line_conflict { orig = []; new_ = cstr_to_lines cstr }
456466
| Removed cstr -> Line_conflict { orig = cstr_to_lines cstr; new_ = [] }
457-
| Modified diff -> (
458-
match diff with
459-
| Atomic_cstr { reference; current } ->
460-
Inline_hunks
461-
[
462-
Icommon (Printf.sprintf "| %s of " name);
463-
Iconflict
464-
{
465-
iorig = Some (cstr_args_to_line reference);
466-
inew = Some (cstr_args_to_line current);
467-
};
468-
]
469-
| Record_cstr record_diff ->
470-
let record_hunks = process_record_type_diff record_diff in
471-
Inline_hunks (Icommon (Printf.sprintf "| %s of " name) :: record_hunks)
472-
| Tuple_cstr tuple_diff ->
473-
let tuple_hunks = process_tuple_type_diff ~context:`None tuple_diff in
474-
Inline_hunks (Icommon (Printf.sprintf "| %s of " name) :: tuple_hunks)
475-
)
467+
| Modified diff ->
468+
Inline_hunks
469+
(Icommon (Printf.sprintf "| %s of " name)
470+
:: process_cstr_args_diff (Stddiff.Changed diff))
471+
472+
and process_cstr_args_diff diff =
473+
match diff with
474+
| Stddiff.Same cstr_args -> [ Icommon (cstr_args_to_line cstr_args) ]
475+
| Changed (Atomic_cstr { reference; current }) ->
476+
[
477+
Iconflict
478+
{
479+
iorig = Some (cstr_args_to_line reference);
480+
inew = Some (cstr_args_to_line current);
481+
};
482+
]
483+
| Changed (Record_cstr record_diff) -> process_record_type_diff record_diff
484+
| Changed (Tuple_cstr tuple_diff) ->
485+
process_tuple_type_diff ~context:`None tuple_diff
476486

477487
and process_tuple_type_diff ~context diff =
478488
let module S = Stddiff in
@@ -646,6 +656,42 @@ let process_class_diff (class_diff : Diff.class_) =
646656
let process_class_type_diff (class_type_diff : Diff.cltype) =
647657
process_atomic_diff class_type_diff.ctdiff class_type_diff.ctname ctd_to_lines
648658

659+
let process_modified_exception name args =
660+
let head = Icommon (Format.sprintf "exception %s of " name) in
661+
let args = process_cstr_args_diff args in
662+
[ Inline_hunks (head :: args) ]
663+
664+
let process_modified_extcstr_diff ~type_name ~exn name
665+
{ Diff.extcstr_params; extcstr_private; extcstr_args } =
666+
if exn then process_modified_exception name extcstr_args
667+
else
668+
let type_hunk = Icommon "type" in
669+
let params_hunks = process_type_params_diff extcstr_params in
670+
let type_name_hunk = Icommon (Format.sprintf " %s +=" type_name) in
671+
let private_hunks = process_privacy_diff extcstr_private in
672+
let name_hunk = Icommon (Format.sprintf " %s of " name) in
673+
let args_hunks = process_cstr_args_diff extcstr_args in
674+
[
675+
Inline_hunks
676+
(List.concat
677+
[
678+
[ type_hunk ];
679+
params_hunks;
680+
[ type_name_hunk ];
681+
private_hunks;
682+
[ name_hunk ];
683+
args_hunks;
684+
]);
685+
]
686+
687+
let process_extcstr_diff (extcstr_diff : Diff.extcstr) =
688+
process_entry
689+
~entry_to_string:(extcstr_to_lines ~exn:extcstr_diff.ecexn)
690+
~process_modification:
691+
(process_modified_extcstr_diff ~type_name:extcstr_diff.ectname
692+
~exn:extcstr_diff.ecexn)
693+
~name:extcstr_diff.ecname extcstr_diff.ecdiff
694+
649695
let rec process_sig_diff :
650696
type a.
651697
_ -> (string -> a -> string list) -> (a, _) Stddiff.entry * _ -> _ -> _ =
@@ -722,7 +768,13 @@ and signature_changes module_path items acc =
722768
| Modified _ -> module_path ^ "." ^ sub_module_type_diff.mtname
723769
| Added _ | Removed _ -> module_path
724770
in
725-
process_module_type_diff sub_module_path sub_module_type_diff acc')
771+
process_module_type_diff sub_module_path sub_module_type_diff acc'
772+
| Extcstr extcstr_diff ->
773+
let diff = process_extcstr_diff extcstr_diff in
774+
String_map.update module_path
775+
(function
776+
| None -> Some diff | Some existing -> Some (existing @ diff))
777+
acc')
726778
acc items
727779

728780
and from_diff (diff : Diff.module_) : t =

0 commit comments

Comments
 (0)