Skip to content

Commit 4d73a03

Browse files
azzsalazzsal
authored
Add fine grained diff of tuple type exprs (#139)
* Add test * Update standard diff types, and type expr diff type * Fix types in diff module * Update text diff to handle printing of tuple type exprs diffs * Add change log entry * Format * Minor fixes * Minor fixes * Minor fix
1 parent 5c110dd commit 4d73a03

File tree

8 files changed

+344
-245
lines changed

8 files changed

+344
-245
lines changed

‎CHANGES.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@
1212
`--word-diff` flag (#131, #136, @azzsal)
1313
- Add `--plain` flag to `api-diff` to use text markers for inline highlighting.
1414
Can be used when the output doesn't support colors (#136, @azzsal)
15+
- Add fine-grained diff of tuple types (#139, @azzsal)
1516

1617
### Changed
1718

‎lib/diff.ml‎

Lines changed: 109 additions & 95 deletions
Original file line numberDiff line numberDiff line change
@@ -1,59 +1,70 @@
1-
open Types
2-
open Stddiff
1+
type type_expr =
2+
| Tuple of tuple
3+
| Atomic of Types.type_expr Stddiff.atomic_modification
4+
5+
and tuple = (Types.type_expr, type_expr) Stddiff.List.t
36

47
type type_modification = {
5-
type_kind : (type_decl_kind, type_kind) maybe_changed;
6-
type_privacy : (Asttypes.private_flag, type_privacy) maybe_changed;
7-
type_manifest : type_expr Stddiff.atomic_option;
8-
type_params : (type_expr, type_param) Stddiff.list_;
8+
type_kind : (Types.type_decl_kind, type_kind) Stddiff.maybe_changed;
9+
type_privacy : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed;
10+
type_manifest :
11+
( Types.type_expr option,
12+
(Types.type_expr, type_expr) Stddiff.Option.t )
13+
Stddiff.maybe_changed;
14+
type_params :
15+
( Types.type_expr list,
16+
(Types.type_expr, type_expr) Stddiff.List.t )
17+
Stddiff.maybe_changed;
918
}
1019

1120
and type_kind =
12-
| Record_tk of (label_declaration, label) map
13-
| Variant_tk of (Types.constructor_declaration, cstr_args) map
14-
| Atomic_tk of type_decl_kind atomic_modification
21+
| Record_tk of (Types.label_declaration, label) Stddiff.Map.t
22+
| Variant_tk of (Types.constructor_declaration, cstr_args) Stddiff.Map.t
23+
| Atomic_tk of Types.type_decl_kind Stddiff.atomic_modification
1524

1625
and label = {
17-
label_type : type_expr Stddiff.maybe_changed_atomic;
18-
label_mutable : (Asttypes.mutable_flag, field_mutability) maybe_changed;
26+
label_type : (Types.type_expr, type_expr) Stddiff.maybe_changed;
27+
label_mutable :
28+
(Asttypes.mutable_flag, field_mutability) Stddiff.maybe_changed;
1929
}
2030

2131
and field_mutability = Added_m | Removed_m
2232

2333
and cstr_args =
24-
| Record_cstr of (label_declaration, label) map
25-
| Tuple_cstr of type_expr maybe_changed_atomic_entry list
34+
| Record_cstr of (Types.label_declaration, label) Stddiff.Map.t
35+
| Tuple_cstr of tuple
2636
| Atomic_cstr of Types.constructor_arguments Stddiff.atomic_modification
2737

2838
and type_privacy = Added_p | Removed_p
29-
and type_param = (type_expr, type_param_diff) maybe_changed
30-
and type_param_diff = Added_tp of type_expr | Removed_tp of type_expr
3139

3240
type type_ = {
3341
tname : string;
34-
tdiff : (type_declaration, type_modification) entry;
42+
tdiff : (Types.type_declaration, type_modification) Stddiff.entry;
3543
}
3644

3745
type value = {
3846
vname : string;
39-
vdiff : (value_description, type_expr atomic_modification) entry;
47+
vdiff : (Types.value_description, type_expr) Stddiff.entry;
4048
}
4149

42-
type class_ = { cname : string; cdiff : class_declaration Stddiff.atomic_entry }
50+
type class_ = {
51+
cname : string;
52+
cdiff : Types.class_declaration Stddiff.atomic_entry;
53+
}
4354

4455
type cltype = {
4556
ctname : string;
46-
ctdiff : class_type_declaration Stddiff.atomic_entry;
57+
ctdiff : Types.class_type_declaration Stddiff.atomic_entry;
4758
}
4859

4960
type module_ = {
5061
mname : string;
51-
mdiff : (module_declaration, signature_modification) entry;
62+
mdiff : (Types.module_declaration, signature_modification) Stddiff.entry;
5263
}
5364

5465
and modtype = {
5566
mtname : string;
56-
mtdiff : (modtype_declaration, signature_modification) entry;
67+
mtdiff : (Types.modtype_declaration, signature_modification) Stddiff.entry;
5768
}
5869

5970
and signature_modification = Unsupported | Supported of sig_item list
@@ -69,7 +80,7 @@ and sig_item =
6980
let extract_items items =
7081
List.fold_left
7182
(fun tbl item ->
72-
match item with
83+
match (item : Types.signature_item) with
7384
| Sig_module (id, _, mod_decl, _, Exported) ->
7485
Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Module mod_decl
7586
tbl
@@ -99,12 +110,12 @@ let extract_items items =
99110

100111
let extract_lbls lbls =
101112
List.fold_left
102-
(fun map lbl -> String_map.add (Ident.name lbl.ld_id) lbl map)
113+
(fun map lbl -> String_map.add (Ident.name lbl.Types.ld_id) lbl map)
103114
String_map.empty lbls
104115

105116
let extract_cstrs cstrs =
106117
List.fold_left
107-
(fun map cstr -> String_map.add (Ident.name cstr.cd_id) cstr map)
118+
(fun map cstr -> String_map.add (Ident.name cstr.Types.cd_id) cstr map)
108119
String_map.empty cstrs
109120

110121
let module_type_fallback ~loc ~typing_env ~name ~reference ~current =
@@ -123,22 +134,39 @@ let module_type_fallback ~loc ~typing_env ~name ~reference ~current =
123134
let expand_alias_types ~typing_env ~type_expr =
124135
Ctype.full_expand ~may_forget_scope:false typing_env type_expr
125136

126-
let type_expr ~typing_env ?(ref_params = []) ?(cur_params = []) reference
137+
let rec type_expr ~typing_env ?(ref_params = []) ?(cur_params = []) reference
127138
current =
128-
let normed_ref, normed_cur =
129-
Normalize.type_params_arity ~reference:ref_params ~current:cur_params
130-
in
131-
if
132-
Ctype.is_equal typing_env true
133-
(normed_ref @ [ reference ])
134-
(normed_cur @ [ current ])
135-
then None
136-
else
137-
Some
138-
{
139-
reference = expand_alias_types ~typing_env ~type_expr:reference;
140-
current = expand_alias_types ~typing_env ~type_expr:current;
141-
}
139+
match (Types.get_desc reference, Types.get_desc current) with
140+
| Ttuple ref_exps, Ttuple cur_exps -> (
141+
let type_exprs =
142+
type_exprs ~typing_env ~ref_params ~cur_params ~reference:ref_exps
143+
~current:cur_exps
144+
in
145+
match type_exprs with
146+
| Stddiff.Same _ -> Stddiff.Same reference
147+
| Changed change -> Changed (Tuple change))
148+
| _ ->
149+
let normed_ref, normed_cur =
150+
Normalize.type_params_arity ~reference:ref_params ~current:cur_params
151+
in
152+
if
153+
Ctype.is_equal typing_env true
154+
(normed_ref @ [ reference ])
155+
(normed_cur @ [ current ])
156+
then Same reference
157+
else
158+
Changed
159+
(Atomic
160+
{
161+
reference = expand_alias_types ~typing_env ~type_expr:reference;
162+
current = expand_alias_types ~typing_env ~type_expr:current;
163+
})
164+
165+
and type_exprs ~typing_env ~ref_params ~cur_params ~reference ~current =
166+
Stddiff.List.diff
167+
~diff_one:(fun ref cur ->
168+
type_expr ~typing_env ~ref_params ~cur_params ref cur)
169+
~reference ~current
142170

143171
let rec type_item ~typing_env ~name ~reference ~current =
144172
match (reference, current) with
@@ -181,6 +209,7 @@ and type_declarations ~typing_env ~name ~reference ~current =
181209
| diff -> Some (Type { tname = name; tdiff = Modified diff })
182210

183211
and type_kind ~typing_env ~ref_params ~cur_params ~reference ~current =
212+
let open Stddiff.Map in
184213
match (reference, current) with
185214
| Type_record (ref_label_lst, _), Type_record (cur_label_lst, _) ->
186215
let label_map =
@@ -204,13 +233,15 @@ and type_kind ~typing_env ~ref_params ~cur_params ~reference ~current =
204233

205234
and record_type ~typing_env ~ref_params ~cur_params ~ref_label_lst
206235
~cur_label_lst =
236+
let open Stddiff in
207237
let ref_lbls = extract_lbls ref_label_lst in
208238
let cur_lbls = extract_lbls cur_label_lst in
209-
diff_map
239+
Map.diff
210240
~diff_one:(label ~typing_env ~ref_params ~cur_params)
211-
~ref_map:ref_lbls ~cur_map:cur_lbls
241+
~reference:ref_lbls ~current:cur_lbls
212242

213243
and label ~typing_env ~ref_params ~cur_params reference current =
244+
let open Stddiff in
214245
let label_type =
215246
type_expr ~typing_env ~ref_params ~cur_params reference.ld_type
216247
current.ld_type
@@ -219,11 +250,11 @@ and label ~typing_env ~ref_params ~cur_params reference current =
219250
label_mutable ~reference:reference.ld_mutable ~current:current.ld_mutable
220251
in
221252
match (label_type, label_mutable) with
222-
| None, Same _ -> None
223-
| None, label_mutable ->
224-
Some { label_type = Same reference.ld_type; label_mutable }
225-
| Some type_diff, label_mutable ->
226-
Some { label_type = Changed type_diff; label_mutable }
253+
| Same _, Same _ -> Same reference
254+
| Same _, label_mutable ->
255+
Changed { label_type = Same reference.ld_type; label_mutable }
256+
| Changed type_diff, label_mutable ->
257+
Changed { label_type = Changed type_diff; label_mutable }
227258

228259
and label_mutable ~reference ~current =
229260
match (reference, current) with
@@ -235,54 +266,38 @@ and label_mutable ~reference ~current =
235266

236267
and variant_type ~typing_env ~ref_params ~cur_params ~ref_constructor_lst
237268
~cur_constructor_lst =
269+
let open Stddiff in
238270
let ref_cstrs = extract_cstrs ref_constructor_lst in
239271
let cur_cstrs = extract_cstrs cur_constructor_lst in
240-
diff_map
272+
Map.diff
241273
~diff_one:(cstr ~typing_env ~ref_params ~cur_params)
242-
~ref_map:ref_cstrs ~cur_map:cur_cstrs
274+
~reference:ref_cstrs ~current:cur_cstrs
243275

244276
and cstr ~typing_env ~ref_params ~cur_params reference current =
245277
match (reference.cd_args, current.cd_args) with
246-
| Cstr_tuple ref_tuple, Cstr_tuple cur_tuple -> (
247-
let tuple =
248-
tuple_type ~typing_env ~ref_params ~cur_params ~reference:ref_tuple
249-
~current:cur_tuple
278+
| Cstr_tuple ref_type_exprs, Cstr_tuple cur_type_exprs -> (
279+
let type_exprs =
280+
type_exprs ~typing_env ~ref_params ~cur_params ~reference:ref_type_exprs
281+
~current:cur_type_exprs
250282
in
251-
match tuple with Same _ -> None | Changed diff -> Some (Tuple_cstr diff))
283+
match type_exprs with
284+
| Same _ -> Same reference
285+
| Changed change -> Changed (Tuple_cstr change))
252286
| Cstr_record ref_record, Cstr_record cur_record ->
253287
let label_map =
254288
record_type ~typing_env ~ref_params ~cur_params
255289
~ref_label_lst:ref_record ~cur_label_lst:cur_record
256290
in
257-
if String_map.is_empty label_map.changed_map then None
258-
else Some (Record_cstr label_map)
291+
if String_map.is_empty label_map.changed_map then Same reference
292+
else Changed (Record_cstr label_map)
259293
| _ ->
260-
Some
294+
Changed
261295
(Atomic_cstr
262296
{ reference = reference.cd_args; current = current.cd_args })
263297

264-
and tuple_type ~typing_env ~ref_params ~cur_params ~reference ~current =
265-
diff_list
266-
~diff_one:(fun t1 t2 ->
267-
match (t1, t2) with
268-
| None, None -> assert false
269-
| Some t1, None -> Changed (Removed t1)
270-
| None, Some t2 -> Changed (Added t2)
271-
| Some t1, Some t2 -> (
272-
match type_expr ~typing_env ~ref_params ~cur_params t1 t2 with
273-
| None -> Same t1
274-
| Some diff -> Changed (Modified diff)))
275-
~ref_list:reference ~cur_list:current
276-
277298
and type_params ~reference ~current =
278-
diff_list
279-
~diff_one:(fun t1 t2 ->
280-
match (t1, t2) with
281-
| None, None -> assert false
282-
| Some t1, None -> Changed (Removed_tp t1)
283-
| None, Some t2 -> Changed (Added_tp t2)
284-
| Some t1, Some _ -> Same t1)
285-
~ref_list:reference ~cur_list:current
299+
let open Stddiff in
300+
List.diff ~diff_one:(fun t1 _ -> Same t1) ~reference ~current
286301

287302
and type_privacy ~reference ~current =
288303
match (reference, current) with
@@ -292,16 +307,13 @@ and type_privacy ~reference ~current =
292307
| Asttypes.Private, Asttypes.Private -> Same Asttypes.Private
293308

294309
and type_manifest ~typing_env ~ref_params ~cur_params ~reference ~current =
295-
match (reference, current) with
296-
| None, None -> Same None
297-
| Some t1, None -> Changed (Removed t1)
298-
| None, Some t2 -> Changed (Added t2)
299-
| Some t1, Some t2 -> (
300-
match type_expr ~typing_env ~ref_params ~cur_params t1 t2 with
301-
| None -> Same (Some t1)
302-
| Some diff -> Changed (Modified diff))
310+
let open Stddiff in
311+
Option.diff
312+
~diff_one:(type_expr ~typing_env ~ref_params ~cur_params)
313+
~reference ~current
303314

304315
let value_descripiton ~typing_env reference current =
316+
let open Types in
305317
type_expr ~typing_env reference.val_type current.val_type
306318

307319
let value_item ~typing_env ~name ~reference ~current =
@@ -313,12 +325,12 @@ let value_item ~typing_env ~name ~reference ~current =
313325
| Some reference, Some current -> (
314326
let val_type_diff = value_descripiton ~typing_env reference current in
315327
match val_type_diff with
316-
| None -> None
317-
| Some type_expr_diff ->
328+
| Same _ -> None
329+
| Changed type_expr_diff ->
318330
Some (Value { vname = name; vdiff = Modified type_expr_diff }))
319331

320-
let class_item ~typing_env ~name ~(reference : class_declaration option)
321-
~(current : class_declaration option) =
332+
let class_item ~typing_env ~name ~(reference : Types.class_declaration option)
333+
~(current : Types.class_declaration option) =
322334
match (reference, current) with
323335
| None, None -> None
324336
| None, Some curr_cls -> Some (Class { cname = name; cdiff = Added curr_cls })
@@ -338,8 +350,8 @@ let class_item ~typing_env ~name ~(reference : class_declaration option)
338350
}))
339351

340352
let class_type_item ~typing_env ~name
341-
~(reference : class_type_declaration option)
342-
~(current : class_type_declaration option) =
353+
~(reference : Types.class_type_declaration option)
354+
~(current : Types.class_type_declaration option) =
343355
match (reference, current) with
344356
| None, None -> None
345357
| None, Some curr_class_type ->
@@ -378,17 +390,18 @@ let rec items ~reference ~current ~typing_env =
378390
in
379391
Sig_item_map.diff ~diff_item:{ diff_item } ref_items curr_items
380392

381-
and module_item ~typing_env ~name ~(reference : module_declaration option)
382-
~(current : module_declaration option) =
393+
and module_item ~typing_env ~name ~(reference : Types.module_declaration option)
394+
~(current : Types.module_declaration option) =
383395
match (reference, current) with
384396
| None, None -> None
385397
| None, Some curr_md -> Some (Module { mname = name; mdiff = Added curr_md })
386398
| Some ref_md, None -> Some (Module { mname = name; mdiff = Removed ref_md })
387399
| Some reference, Some current ->
388400
module_declaration ~typing_env ~name ~reference ~current
389401

390-
and module_type_item ~typing_env ~name ~(reference : modtype_declaration option)
391-
~(current : modtype_declaration option) =
402+
and module_type_item ~typing_env ~name
403+
~(reference : Types.modtype_declaration option)
404+
~(current : Types.modtype_declaration option) =
392405
match (reference, current) with
393406
| None, None -> None
394407
| None, Some curr_mtd ->
@@ -446,6 +459,7 @@ let interface ~module_name ~reference ~current =
446459
Option.map (fun mdiff -> { mname = module_name; mdiff }) sig_out
447460

448461
let library ~reference ~current =
462+
let open Types in
449463
let mod_dec_of_sig sign =
450464
{
451465
md_type = Mty_signature sign;

0 commit comments

Comments
 (0)