Skip to content

Commit 39f7be4

Browse files
azzsalazzsal
authored
Add fine grained diffing of type constructors (#148)
* First implementation of type constrs diffing * Add unit tests * Remove env initilization * Alias to unchanged types should not expand * Add text diff * Fix spacing * Format * Minor fix * Minor fix * Update cram tests * Format * Fully expand tconstrs before diffing * Expand before diffing type exprs * Format * Update doc comments * Minor fix * Expand on diffing type constrs * Minor fixes
1 parent 2dbdb4d commit 39f7be4

File tree

13 files changed

+555
-31
lines changed

13 files changed

+555
-31
lines changed

‎CHANGES.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@
1414
Can be used when the output doesn't support colors (#136, @azzsal)
1515
- Add fine-grained diff of tuple types (#139, @azzsal)
1616
- Add fine-grained diff of arrow types (#140, @azzsal)
17+
- Add fine-grained diff of type constructors (#148, @azzsal)
1718

1819
### Changed
1920

‎lib/diff.ml‎

Lines changed: 84 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
type type_expr =
22
| Tuple of tuple
33
| Arrow of arrow
4+
| Constr of constr
45
| Atomic of Types.type_expr Stddiff.atomic_modification
56

67
and tuple = (Types.type_expr, type_expr) Stddiff.List.t
@@ -23,6 +24,16 @@ and arg_label_diff = {
2324

2425
and arg_optional = Added_opt_arg | Removed_opt_arg
2526

27+
and constr = {
28+
path : (Path.t, Path.t Stddiff.atomic_modification) Stddiff.maybe_changed;
29+
args :
30+
( Types.type_expr list,
31+
( Types.type_expr list,
32+
(Types.type_expr, type_expr) Stddiff.List.t )
33+
Stddiff.entry )
34+
Stddiff.maybe_changed;
35+
}
36+
2637
type type_modification = {
2738
type_kind : (Types.type_decl_kind, type_kind) Stddiff.maybe_changed;
2839
type_privacy : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed;
@@ -32,7 +43,9 @@ type type_modification = {
3243
Stddiff.maybe_changed;
3344
type_params :
3445
( Types.type_expr list,
35-
(Types.type_expr, type_expr) Stddiff.List.t )
46+
( Types.type_expr list,
47+
(Types.type_expr, type_expr) Stddiff.List.t )
48+
Stddiff.entry )
3649
Stddiff.maybe_changed;
3750
}
3851

@@ -174,6 +187,10 @@ let rec type_expr ~typing_env ?(ref_params = []) ?(cur_params = []) reference
174187
match arrow with
175188
| Stddiff.Same _ -> Stddiff.Same reference
176189
| Changed change -> Changed (Arrow change))
190+
| Tconstr (ref_path, ref_args, _), Tconstr (cur_path, cur_args, _) ->
191+
expand_and_diff_tconstr ~typing_env ~ref_params ~cur_params
192+
~reference:(reference, ref_path, ref_args)
193+
~current:(current, cur_path, cur_args)
177194
| _ ->
178195
let normed_ref, normed_cur =
179196
Normalize.type_params_arity ~reference:ref_params ~current:cur_params
@@ -191,6 +208,62 @@ let rec type_expr ~typing_env ?(ref_params = []) ?(cur_params = []) reference
191208
current = expand_alias_types ~typing_env ~type_expr:current;
192209
})
193210

211+
and expand_and_diff_tconstr ~typing_env ~ref_params ~cur_params ~reference
212+
~current =
213+
let ref_expr, ref_path, ref_args = reference in
214+
let cur_expr, cur_path, cur_args = current in
215+
let expanded_ref =
216+
Option.value
217+
(Typing_env.fully_expand_tconstr ~typing_env ~path:ref_path ~args:ref_args)
218+
~default:ref_expr
219+
in
220+
let expanded_cur =
221+
Option.value
222+
(Typing_env.fully_expand_tconstr ~typing_env ~path:cur_path ~args:cur_args)
223+
~default:cur_expr
224+
in
225+
match (Types.get_desc expanded_ref, Types.get_desc expanded_cur) with
226+
| Tconstr (ref_path, ref_args, _), Tconstr (cur_path, cur_args, _) -> (
227+
let constr =
228+
constr ~typing_env ~ref_params ~cur_params
229+
~reference:(ref_path, ref_args) ~current:(cur_path, cur_args)
230+
in
231+
match constr with
232+
| Stddiff.Same _ -> Stddiff.Same cur_expr
233+
| Changed change -> Changed change)
234+
| _, _ -> (
235+
let diff =
236+
type_expr ~typing_env ~ref_params ~cur_params expanded_ref expanded_cur
237+
in
238+
match diff with
239+
| Same _ -> Same cur_expr
240+
| Changed change -> Changed change)
241+
242+
and constr ~typing_env ~ref_params ~cur_params ~reference ~current =
243+
let open Stddiff in
244+
let ref_path, ref_args = reference in
245+
let cur_path, cur_args = current in
246+
let path =
247+
if String.equal (Path.name ref_path) (Path.name cur_path) then Same ref_path
248+
else Changed { reference = ref_path; current = cur_path }
249+
in
250+
let args =
251+
match (ref_args, cur_args) with
252+
| [], _ :: _ -> Changed (Added cur_args)
253+
| _ :: _, [] -> Changed (Removed ref_args)
254+
| _ -> (
255+
let type_exprs =
256+
type_exprs ~typing_env ~ref_params ~cur_params ~reference:ref_args
257+
~current:cur_args
258+
in
259+
match type_exprs with
260+
| Same same_params -> Same same_params
261+
| Changed change -> Changed (Modified change))
262+
in
263+
match (path, args) with
264+
| Same _, Same _ -> Same current
265+
| _ -> Changed (Constr { path; args })
266+
194267
and type_exprs ~typing_env ~ref_params ~cur_params ~reference ~current =
195268
Stddiff.List.diff
196269
~diff_one:(fun ref cur ->
@@ -393,7 +466,16 @@ and cstr ~typing_env ~ref_params ~cur_params reference current =
393466

394467
and type_params ~reference ~current =
395468
let open Stddiff in
396-
List.diff ~diff_one:(fun t1 _ -> Same t1) ~reference ~current
469+
match (reference, current) with
470+
| [], _ :: _ -> Changed (Added current)
471+
| _ :: _, [] -> Changed (Removed reference)
472+
| _ -> (
473+
let params_diff =
474+
List.diff ~diff_one:(fun t1 _ -> Same t1) ~reference ~current
475+
in
476+
match params_diff with
477+
| Same same_params -> Same same_params
478+
| Changed change -> Changed (Modified change))
397479

398480
and type_privacy ~reference ~current =
399481
match (reference, current) with

‎lib/diff.mli‎

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
type type_expr =
22
| Tuple of tuple
33
| Arrow of arrow
4+
| Constr of constr
45
| Atomic of Types.type_expr Stddiff.atomic_modification
56

67
and tuple = (Types.type_expr, type_expr) Stddiff.List.t
@@ -23,6 +24,16 @@ and arg_label_diff = {
2324

2425
and arg_optional = Added_opt_arg | Removed_opt_arg
2526

27+
and constr = {
28+
path : (Path.t, Path.t Stddiff.atomic_modification) Stddiff.maybe_changed;
29+
args :
30+
( Types.type_expr list,
31+
( Types.type_expr list,
32+
(Types.type_expr, type_expr) Stddiff.List.t )
33+
Stddiff.entry )
34+
Stddiff.maybe_changed;
35+
}
36+
2637
type type_modification = {
2738
type_kind : (Types.type_decl_kind, type_kind) Stddiff.maybe_changed;
2839
type_privacy : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed;
@@ -32,7 +43,9 @@ type type_modification = {
3243
Stddiff.maybe_changed;
3344
type_params :
3445
( Types.type_expr list,
35-
(Types.type_expr, type_expr) Stddiff.List.t )
46+
( Types.type_expr list,
47+
(Types.type_expr, type_expr) Stddiff.List.t )
48+
Stddiff.entry )
3649
Stddiff.maybe_changed;
3750
}
3851

‎lib/text_diff.ml‎

Lines changed: 71 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -128,6 +128,15 @@ let ctd_to_lines name cd =
128128
let class_str = Buffer.contents buf in
129129
CCString.lines class_str
130130

131+
let params_to_string params =
132+
match params with
133+
| [] -> ""
134+
| param :: [] -> type_expr_to_string param
135+
| _ ->
136+
Printf.sprintf "(%s)"
137+
(List.map (fun param -> type_expr_to_string param) params
138+
|> String.concat ", ")
139+
131140
let process_atomic_diff
132141
(diff : (_, _ Stddiff.atomic_modification) Stddiff.entry) name to_lines =
133142
match diff with
@@ -191,6 +200,9 @@ and process_type_header_diff name type_privacy_diff type_manifest_diff
191200
type_params_diff type_kind_diff =
192201
let type_hunk = Icommon "type" in
193202
let type_params_hunks = process_type_params_diff type_params_diff in
203+
let space =
204+
match type_params_hunks with [] -> Icommon "" | _ -> Icommon " "
205+
in
194206
let type_name_hunk = Icommon (" " ^ name) in
195207
let equal_hunks = process_equal_sign_diff type_manifest_diff type_kind_diff in
196208
let type_privacy_hunks = process_privacy_diff type_privacy_diff in
@@ -200,6 +212,7 @@ and process_type_header_diff name type_privacy_diff type_manifest_diff
200212
List.concat
201213
[
202214
[ type_hunk ];
215+
[ space ];
203216
type_params_hunks;
204217
[ type_name_hunk ];
205218
[ List.hd equal_hunks ];
@@ -211,6 +224,7 @@ and process_type_header_diff name type_privacy_diff type_manifest_diff
211224
List.concat
212225
[
213226
[ type_hunk ];
227+
[ space ];
214228
type_params_hunks;
215229
[ type_name_hunk ];
216230
equal_hunks;
@@ -240,37 +254,49 @@ and process_privacy_diff privacy_diff =
240254

241255
and process_type_params_diff params_diff =
242256
let module S = Stddiff in
243-
let params_hunks =
244-
match params_diff with
245-
| Same params ->
246-
List.mapi
247-
(fun i p ->
248-
let comma = if i > 0 then ", " else "" in
249-
Icommon (Printf.sprintf "%s%s" comma (type_expr_to_string p)))
250-
params
251-
| Changed changed_params ->
257+
match params_diff with
258+
| Same params -> (
259+
match params with [] -> [] | _ -> [ Icommon (params_to_string params) ])
260+
| Changed (Removed params) ->
261+
[ Iconflict { iorig = Some (params_to_string params); inew = None } ]
262+
| Changed (Added params) ->
263+
[ Iconflict { iorig = None; inew = Some (params_to_string params) } ]
264+
| Changed (Modified changed_params) -> (
265+
let params_hunks =
252266
List.mapi
253267
(fun i p ->
254268
let comma = if i > 0 then ", " else "" in
255269
match p with
256270
| S.Same same_param ->
257-
Icommon
258-
(Printf.sprintf "%s%s" comma (type_expr_to_string same_param))
271+
[
272+
Icommon
273+
(Printf.sprintf "%s%s" comma
274+
(type_expr_to_string same_param));
275+
]
259276
| Changed (S.Added p) ->
260-
Iconflict
261-
{ iorig = None; inew = Some (comma ^ type_expr_to_string p) }
277+
[
278+
Iconflict
279+
{
280+
iorig = None;
281+
inew = Some (comma ^ type_expr_to_string p);
282+
};
283+
]
262284
| Changed (Removed p) ->
263-
Iconflict
264-
{ iorig = Some (comma ^ type_expr_to_string p); inew = None }
265-
| Changed (Modified _) -> assert false)
285+
[
286+
Iconflict
287+
{
288+
iorig = Some (comma ^ type_expr_to_string p);
289+
inew = None;
290+
};
291+
]
292+
| Changed (Modified te) ->
293+
Icommon comma :: process_type_expr_diff te)
266294
changed_params
267-
in
268-
let open_paren = Icommon " (" in
269-
let close_paren = Icommon ")" in
270-
match params_hunks with
271-
| [] -> []
272-
| _ :: [] -> Icommon " " :: params_hunks
273-
| _ -> (open_paren :: params_hunks) @ [ close_paren ]
295+
|> List.concat
296+
in
297+
match changed_params with
298+
| [ _ ] -> params_hunks
299+
| _ -> parenthesize params_hunks)
274300

275301
and concrete = function
276302
| Stddiff.Same
@@ -549,6 +575,27 @@ and process_arrow_type_diff ~context arrow_diff =
549575

550576
and parenthesize hunks = (Icommon "(" :: hunks) @ [ Icommon ")" ]
551577

578+
and process_constr_type_diff constr_diff =
579+
let open Diff in
580+
let path_ihunks = process_path_diff constr_diff.path in
581+
let args_ihunks = process_type_params_diff constr_diff.args in
582+
match args_ihunks with
583+
| [] -> path_ihunks
584+
| _ -> args_ihunks @ (Icommon " " :: path_ihunks)
585+
586+
and process_path_diff diff =
587+
let open Stddiff in
588+
match diff with
589+
| Same path -> [ Icommon (Path.name path) ]
590+
| Changed { reference; current } ->
591+
[
592+
Iconflict
593+
{
594+
iorig = Some (Path.name reference);
595+
inew = Some (Path.name current);
596+
};
597+
]
598+
552599
and process_type_expr_diff ?(context = `None) (diff : Diff.type_expr) :
553600
inline_hunk list =
554601
match diff with
@@ -562,6 +609,7 @@ and process_type_expr_diff ?(context = `None) (diff : Diff.type_expr) :
562609
]
563610
| Tuple tuple_diff -> process_tuple_type_diff ~context tuple_diff
564611
| Arrow arrow_diff -> process_arrow_type_diff ~context arrow_diff
612+
| Constr constr_diff -> process_constr_type_diff constr_diff
565613

566614
and cstr_args_to_line cstr_args =
567615
match cstr_args with

‎lib/typing_env.ml‎

Lines changed: 24 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -139,15 +139,38 @@ let initialized_env =
139139

140140
let for_diff ~reference ~current =
141141
let current = replace_matching_ids ~reference ~current in
142-
let reference = replace_matching_ids ~reference:current ~current:reference in
143142
let env =
144143
Env.add_signature reference (Env.in_signature true (initialized_env ()))
145144
in
145+
let env = Env.add_signature reference (Env.in_signature true env) in
146146
let env = Env.add_signature current env in
147147
let subst = pair_items ~reference ~current in
148148
let modified_current = apply_subst subst current in
149149
(reference, modified_current, env)
150150

151+
let expand_tconstr ~typing_env ~path ~args =
152+
let type_decl =
153+
try Some (Env.find_type path typing_env) with Not_found -> None
154+
in
155+
match type_decl with
156+
| None -> None
157+
| Some td -> (
158+
match td.Types.type_manifest with
159+
| None -> None
160+
| Some type_expr ->
161+
Some (Ctype.apply typing_env td.Types.type_params type_expr args))
162+
163+
let fully_expand_tconstr ~typing_env ~path ~args =
164+
let rec aux last path args =
165+
match expand_tconstr ~typing_env ~path ~args with
166+
| None -> last
167+
| Some expr -> (
168+
match Types.get_desc expr with
169+
| Tconstr (path, args, _) -> aux (Some expr) path args
170+
| _ -> Some expr)
171+
in
172+
aux None path args
173+
151174
let pp fmt t =
152175
let summary = Env.summary t in
153176
Format.fprintf fmt "@[<hv 2>[@;";

‎lib/typing_env.mli‎

Lines changed: 24 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,30 @@ val for_diff :
1919
so that these items appearing in the [current] signature are treated
2020
equally across the two signatures by the compiler.
2121
We then run the subst aganist the signature items in the [current]
22-
signature before diffing it with signature item in the [reference] signature.
22+
signature before diffing them with signature items in the [reference] signature.
23+
*)
24+
25+
val expand_tconstr :
26+
typing_env:t ->
27+
path:Path.t ->
28+
args:Types.type_expr list ->
29+
Types.type_expr option
30+
(** Expand the given [Tconstr] once, looking up the environment for an existing
31+
alias and applying the type parameters as needed.
32+
33+
Returns [None] if the given [Tconstr] cannot be expanded further, i.e. if
34+
it points to reocrd, variant or abstract type or if is not present in
35+
the typing environment
36+
*)
37+
38+
val fully_expand_tconstr :
39+
typing_env:t ->
40+
path:Path.t ->
41+
args:Types.type_expr list ->
42+
Types.type_expr option
43+
(** Recursively expand the given path and args, looking up the environment for
44+
an existing
45+
alias and applying the type parameters as needed at each step, until expanded to anything but a [Tconstr ...].
2346
*)
2447

2548
val pp : Format.formatter -> Env.t -> unit

0 commit comments

Comments
 (0)