Skip to content

Commit 5c110dd

Browse files
azzsalazzsal
authored
Fix stack overflow (#134)
* Update diff representation * Update diff types * Update inline tests * Fix variant diff type * Update textual diff output to have highlighting of exact changes in type declarations * Add debug printers for type exprs * Fix stackoverflow bug, but introduce a newbug with type params * Fix type params bug * Format * Minor fixes * Fix everything * Minor fixes * Update doc comment for initializing the env * Minor fixes * Add doc comment * Minor fixes
1 parent 65f4c72 commit 5c110dd

18 files changed

+741
-138
lines changed

‎CHANGES.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,8 @@
2222
- Improve the diff representation of type declarations to have type parameters diff (#113,@azzsal)
2323
- Improve the textual diff representation output to have highlighting of exact
2424
changes in a line (#126,@azzsal)
25+
- Improve handling of type equalities across the reference and current
26+
versions of the interface. (#134, @azzsal)
2527

2628
### Deprecated
2729

@@ -31,6 +33,9 @@
3133
- Remove duplicate items in class and class types (#105, @azzsal)
3234
- Fixed loading of modules whose signature is given by a path to a module type:
3335
`module X : Y` (#128, @panglesd)
36+
- Fixed initialization of the typing enviorment (#134, @azzsal)
37+
- Fix a bug the was causing the tool to stack overflow when dealing with
38+
some instances of parametrized types (#134, @azzsal)
3439

3540
### Removed
3641

‎api-watch.opam‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ depends: [
1111
"ocaml" {>= "5.2.0" & < "5.3.0"}
1212
"ppx_expect" {with-test}
1313
"ppx_deriving"
14+
"ppxlib"
1415
"logs"
1516
"containers"
1617
"fmt"

‎dev-tools/print_api.ml‎

Lines changed: 13 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,24 +1,27 @@
1-
let print_cmi path =
1+
let print_raw = new Api_watch.Ocaml_types.print
2+
3+
let print_cmi ~raw path =
24
let cmi_infos = Cmi_format.read_cmi path in
35
Format.printf "cmi_name: %s\n" cmi_infos.cmi_name;
46
Format.printf "cmi_sign:\n";
5-
Printtyp.signature Format.std_formatter cmi_infos.cmi_sign;
7+
if raw then print_raw#signature cmi_infos.cmi_sign
8+
else Printtyp.signature Format.std_formatter cmi_infos.cmi_sign;
69
Format.printf "\n"
710

811
let all_cmi_files path =
912
Sys.readdir path |> Array.to_list
1013
|> List.filter (fun p -> Filename.check_suffix p ".cmi")
1114
|> List.map (Filename.concat path)
1215

13-
let run (`Main_module main_module) (`Input fn) =
16+
let run (`Raw raw) (`Main_module main_module) (`Input fn) =
1417
let open CCResult.Infix in
1518
match (Sys.is_directory fn, main_module) with
1619
| false, _ ->
17-
print_cmi fn;
20+
print_cmi ~raw fn;
1821
Ok ()
1922
| true, None ->
2023
let cmi_files = all_cmi_files fn in
21-
List.iter print_cmi cmi_files;
24+
List.iter (print_cmi ~raw) cmi_files;
2225
Ok ()
2326
| true, Some main_module ->
2427
let+ sig_map = Api_watch.Library.load ~main_module fn in
@@ -28,6 +31,10 @@ let run (`Main_module main_module) (`Input fn) =
2831

2932
let named f = Cmdliner.Term.(app (const f))
3033

34+
let raw =
35+
let doc = "Prints the IDs of different signature items." in
36+
named (fun x -> `Raw x) Cmdliner.Arg.(value & flag & info ~doc [ "raw" ])
37+
3138
let main_module =
3239
let docv = "MAIN_MODULE_NAME" in
3340
let doc =
@@ -57,7 +64,7 @@ let info =
5764
Cmd.info "print_api" ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults
5865
~doc:"Pretty prints the API of a $(b,.cmi) file or a whole library"
5966

60-
let term = Cmdliner.Term.(const run $ main_module $ input_file)
67+
let term = Cmdliner.Term.(const run $ raw $ main_module $ input_file)
6168

6269
let () =
6370
let exit_code = Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v info term) in

‎dune-project‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@
1818
(ocaml (and (>= 5.2.0) (< 5.3.0)))
1919
(ppx_expect :with-test)
2020
ppx_deriving
21+
ppxlib
2122
logs
2223
containers
2324
fmt

‎lib/api_watch.ml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,3 +4,4 @@ module Text_diff = Text_diff
44
module Library = Library
55
module Normalize = Normalize
66
module Stddiff = Stddiff
7+
module Ocaml_types = Ocaml_types

‎lib/diff.ml‎

Lines changed: 49 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -4,8 +4,8 @@ open Stddiff
44
type type_modification = {
55
type_kind : (type_decl_kind, type_kind) maybe_changed;
66
type_privacy : (Asttypes.private_flag, type_privacy) maybe_changed;
7-
type_manifest : type_expr atomic_option;
8-
type_params : (type_expr, type_param) list_;
7+
type_manifest : type_expr Stddiff.atomic_option;
8+
type_params : (type_expr, type_param) Stddiff.list_;
99
}
1010

1111
and type_kind =
@@ -14,7 +14,7 @@ and type_kind =
1414
| Atomic_tk of type_decl_kind atomic_modification
1515

1616
and label = {
17-
label_type : type_expr maybe_changed_atomic;
17+
label_type : type_expr Stddiff.maybe_changed_atomic;
1818
label_mutable : (Asttypes.mutable_flag, field_mutability) maybe_changed;
1919
}
2020

@@ -34,9 +34,17 @@ type type_ = {
3434
tdiff : (type_declaration, type_modification) entry;
3535
}
3636

37-
type value = { vname : string; vdiff : value_description atomic_entry }
38-
type class_ = { cname : string; cdiff : class_declaration atomic_entry }
39-
type cltype = { ctname : string; ctdiff : class_type_declaration atomic_entry }
37+
type value = {
38+
vname : string;
39+
vdiff : (value_description, type_expr atomic_modification) entry;
40+
}
41+
42+
type class_ = { cname : string; cdiff : class_declaration Stddiff.atomic_entry }
43+
44+
type cltype = {
45+
ctname : string;
46+
ctdiff : class_type_declaration Stddiff.atomic_entry;
47+
}
4048

4149
type module_ = {
4250
mname : string;
@@ -112,6 +120,9 @@ let module_type_fallback ~loc ~typing_env ~name ~reference ~current =
112120
| exception Includemod.Error _ ->
113121
Some (Module { mname = name; mdiff = Modified Unsupported })
114122

123+
let expand_alias_types ~typing_env ~type_expr =
124+
Ctype.full_expand ~may_forget_scope:false typing_env type_expr
125+
115126
let type_expr ~typing_env ?(ref_params = []) ?(cur_params = []) reference
116127
current =
117128
let normed_ref, normed_cur =
@@ -122,7 +133,12 @@ let type_expr ~typing_env ?(ref_params = []) ?(cur_params = []) reference
122133
(normed_ref @ [ reference ])
123134
(normed_cur @ [ current ])
124135
then None
125-
else Some { reference; current }
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+
}
126142

127143
let rec type_item ~typing_env ~name ~reference ~current =
128144
match (reference, current) with
@@ -285,28 +301,21 @@ and type_manifest ~typing_env ~ref_params ~cur_params ~reference ~current =
285301
| None -> Same (Some t1)
286302
| Some diff -> Changed (Modified diff))
287303

304+
let value_descripiton ~typing_env reference current =
305+
type_expr ~typing_env reference.val_type current.val_type
306+
288307
let value_item ~typing_env ~name ~reference ~current =
289308
match (reference, current) with
290309
| None, None -> None
291310
| Some reference, None ->
292311
Some (Value { vname = name; vdiff = Removed reference })
293312
| None, Some current -> Some (Value { vname = name; vdiff = Added current })
294313
| Some reference, Some current -> (
295-
let val_coercion1 () =
296-
Includecore.value_descriptions ~loc:current.val_loc typing_env name
297-
current reference
298-
in
299-
let val_coercion2 () =
300-
Includecore.value_descriptions ~loc:reference.val_loc typing_env name
301-
reference current
302-
in
303-
match (val_coercion1 (), val_coercion2 ()) with
304-
| Tcoerce_none, Tcoerce_none -> None
305-
| _, _ ->
306-
Some (Value { vname = name; vdiff = Modified { reference; current } })
307-
| exception Includecore.Dont_match _ ->
308-
Some (Value { vname = name; vdiff = Modified { reference; current } })
309-
)
314+
let val_type_diff = value_descripiton ~typing_env reference current in
315+
match val_type_diff with
316+
| None -> None
317+
| Some type_expr_diff ->
318+
Some (Value { vname = name; vdiff = Modified type_expr_diff }))
310319

311320
let class_item ~typing_env ~name ~(reference : class_declaration option)
312321
~(current : class_declaration option) =
@@ -354,19 +363,18 @@ let class_type_item ~typing_env ~name
354363
{ reference = ref_class_type; current = curr_class_type };
355364
}))
356365

357-
let rec items ~reference ~current =
358-
let env = Typing_env.for_diff ~reference ~current in
366+
let rec items ~reference ~current ~typing_env =
359367
let ref_items = extract_items reference in
360368
let curr_items = extract_items current in
361369
let diff_item : type a. (a, 'diff) Sig_item_map.diff_item =
362370
fun item_type name reference current ->
363371
match item_type with
364-
| Value -> value_item ~typing_env:env ~name ~reference ~current
365-
| Module -> module_item ~typing_env:env ~name ~reference ~current
366-
| Modtype -> module_type_item ~typing_env:env ~name ~reference ~current
367-
| Type -> type_item ~typing_env:env ~name ~reference ~current
368-
| Class -> class_item ~typing_env:env ~name ~reference ~current
369-
| Classtype -> class_type_item ~typing_env:env ~name ~reference ~current
372+
| Value -> value_item ~typing_env ~name ~reference ~current
373+
| Module -> module_item ~typing_env ~name ~reference ~current
374+
| Modtype -> module_type_item ~typing_env ~name ~reference ~current
375+
| Type -> type_item ~typing_env ~name ~reference ~current
376+
| Class -> class_item ~typing_env ~name ~reference ~current
377+
| Classtype -> class_type_item ~typing_env ~name ~reference ~current
370378
in
371379
Sig_item_map.diff ~diff_item:{ diff_item } ref_items curr_items
372380

@@ -407,20 +415,25 @@ and module_type ~typing_env ~name ~ref_module_type ~current_module_type
407415
~reference_location =
408416
match (ref_module_type, current_module_type) with
409417
| Mty_signature ref_submod, Mty_signature curr_submod ->
410-
signatures ~typing_env ~reference:ref_submod ~current:curr_submod
418+
signatures ~reference:ref_submod ~current:curr_submod
411419
|> Option.map (fun mdiff -> Module { mname = name; mdiff })
412420
| ref_modtype, curr_modtype ->
413421
module_type_fallback ~loc:reference_location ~typing_env ~name
414422
~reference:ref_modtype ~current:curr_modtype
415423

416-
and signatures ~typing_env ~reference ~current =
417-
match items ~reference ~current with
424+
and signatures ~reference ~current =
425+
let modified_reference, modified_current, typing_env =
426+
Typing_env.for_diff ~reference ~current
427+
in
428+
match
429+
items ~reference:modified_reference ~current:modified_current ~typing_env
430+
with
418431
| [] -> (
419432
let coercion1 () =
420-
Includemod.signatures typing_env ~mark:Mark_both reference current
433+
Includemod.signatures Env.empty ~mark:Mark_both reference current
421434
in
422435
let coercion2 () =
423-
Includemod.signatures typing_env ~mark:Mark_both current reference
436+
Includemod.signatures Env.empty ~mark:Mark_both current reference
424437
in
425438
match (coercion1 (), coercion2 ()) with
426439
| Tcoerce_none, Tcoerce_none -> None
@@ -429,8 +442,7 @@ and signatures ~typing_env ~reference ~current =
429442
| item_changes -> Some (Modified (Supported item_changes))
430443

431444
let interface ~module_name ~reference ~current =
432-
let typing_env = Env.empty in
433-
let sig_out = signatures ~typing_env ~reference ~current in
445+
let sig_out = signatures ~reference ~current in
434446
Option.map (fun mdiff -> { mname = module_name; mdiff }) sig_out
435447

436448
let library ~reference ~current =

‎lib/diff.mli‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -37,7 +37,10 @@ type type_ = {
3737

3838
type value = {
3939
vname : string;
40-
vdiff : Types.value_description Stddiff.atomic_entry;
40+
vdiff :
41+
( Types.value_description,
42+
Types.type_expr Stddiff.atomic_modification )
43+
Stddiff.entry;
4144
}
4245

4346
type class_ = {

‎lib/dune‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,5 +2,5 @@
22
(name api_watch)
33
(public_name api-watch)
44
(preprocess
5-
(pps ppx_deriving.std))
6-
(libraries compiler-libs.common unix containers fmt))
5+
(pps ppx_deriving.std ppxlib.traverse))
6+
(libraries compiler-libs.common ppxlib.traverse_builtins unix containers fmt))

0 commit comments

Comments
 (0)