The unpac monorepo manager self-hosting as a monorepo using unpac
Merge pull request #13308 from voodoos/link-declarations
[tooling] Remember linked declarations
authored by
Florian Angeletti
and committed by
GitHub
b9512076
08551811
+370
-158
+5
Changes
+5
Changes
···
495
495
- #13289: Use C99 for loop to reduce the scope of the for loop iterator.
496
496
(Antonin Décimo, review by Miod Vallat and Gabriel Scherer)
497
497
498
+
- #13308: keep track of relations between declaration in the cmt files. This is
499
+
useful information for external tools for navigation and analysis purposis.
500
+
(Ulysse Gérard, Florian Angeletti, review by Florian Angeletti and Gabriel
501
+
Scherer)
502
+
498
503
- #13336: compiler-libs, split the `Printtyp` in three to only keep
499
504
"user-friendly" functions in the `Printtyp` module.
500
505
(Florian Angeletti, review by Gabriel Scherer)
+1
-1
driver/compile_common.ml
+1
-1
driver/compile_common.ml
···
58
58
Format.(fprintf std_formatter) "%a@."
59
59
(Printtyp.printed_signature (Unit_info.source_file info.target))
60
60
sg);
61
-
ignore (Includemod.signatures info.env ~mark:Mark_both sg sg);
61
+
ignore (Includemod.signatures info.env ~mark:true sg sg);
62
62
Typecore.force_delayed_checks ();
63
63
Builtin_attributes.warn_unused ();
64
64
Warnings.check_fatal ();
+8
-8
file_formats/cmt_format.ml
+8
-8
file_formats/cmt_format.ml
···
45
45
| Partial_signature_item of signature_item
46
46
| Partial_module_type of module_type
47
47
48
+
type dependency_kind = Definition_to_declaration | Declaration_to_declaration
48
49
type cmt_infos = {
49
50
cmt_modname : string;
50
51
cmt_annots : binary_annots;
51
-
cmt_value_dependencies :
52
-
(Types.value_description * Types.value_description) list;
52
+
cmt_declaration_dependencies : (dependency_kind * Uid.t * Uid.t) list;
53
53
cmt_comments : (string * Location.t) list;
54
54
cmt_args : string array;
55
55
cmt_sourcefile : string option;
···
425
425
| Some cmi, _ -> cmi
426
426
427
427
let saved_types = ref []
428
-
let value_deps = ref []
428
+
let uids_deps : (dependency_kind * Uid.t * Uid.t) list ref = ref []
429
429
430
430
let clear () =
431
431
saved_types := [];
432
-
value_deps := []
432
+
uids_deps := []
433
433
434
434
let add_saved_type b = saved_types := b :: !saved_types
435
435
let get_saved_types () = !saved_types
436
436
let set_saved_types l = saved_types := l
437
437
438
-
let record_value_dependency vd1 vd2 =
439
-
if vd1.Types.val_loc <> vd2.Types.val_loc then
440
-
value_deps := (vd1, vd2) :: !value_deps
438
+
let record_declaration_dependency (rk, uid1, uid2) =
439
+
if not (Uid.equal uid1 uid2) then
440
+
uids_deps := (rk, uid1, uid2) :: !uids_deps
441
441
442
442
let save_cmt target binary_annots initial_env cmi shape =
443
443
if !Clflags.binary_annotations && not !Clflags.print_types then begin
···
462
462
let cmt = {
463
463
cmt_modname = Unit_info.Artifact.modname target;
464
464
cmt_annots;
465
-
cmt_value_dependencies = !value_deps;
465
+
cmt_declaration_dependencies = !uids_deps;
466
466
cmt_comments = Lexer.comments ();
467
467
cmt_args = Sys.argv;
468
468
cmt_sourcefile = sourcefile;
+3
-4
file_formats/cmt_format.mli
+3
-4
file_formats/cmt_format.mli
···
50
50
| Partial_signature_item of signature_item
51
51
| Partial_module_type of module_type
52
52
53
+
type dependency_kind = Definition_to_declaration | Declaration_to_declaration
53
54
type cmt_infos = {
54
55
cmt_modname : modname;
55
56
cmt_annots : binary_annots;
56
-
cmt_value_dependencies :
57
-
(Types.value_description * Types.value_description) list;
57
+
cmt_declaration_dependencies : (dependency_kind * Uid.t * Uid.t) list;
58
58
cmt_comments : (string * Location.t) list;
59
59
cmt_args : string array;
60
60
cmt_sourcefile : string option;
···
109
109
val get_saved_types : unit -> binary_part list
110
110
val set_saved_types : binary_part list -> unit
111
111
112
-
val record_value_dependency:
113
-
Types.value_description -> Types.value_description -> unit
112
+
val record_declaration_dependency: dependency_kind * Uid.t * Uid.t -> unit
114
113
115
114
(*
116
115
+59
testsuite/tests/uid-deps/link_intf_impl.ml
+59
testsuite/tests/uid-deps/link_intf_impl.ml
···
1
+
(* TEST
2
+
3
+
flags = "-bin-annot -bin-annot-occurrences";
4
+
compile_only = "true";
5
+
setup-ocamlc.byte-build-env;
6
+
all_modules = "link_intf_impl.mli link_intf_impl.ml";
7
+
ocamlc.byte;
8
+
check-ocamlc.byte-output;
9
+
10
+
program = "-quiet -uid-deps link_intf_impl.cmt";
11
+
output = "out_objinfo";
12
+
ocamlobjinfo;
13
+
14
+
check-program-output;
15
+
*)
16
+
17
+
let x (* 0 *) = 42
18
+
19
+
type t (* 1 *) = int
20
+
21
+
module type S (* 3 *) = sig
22
+
val y (* 2 *) : t
23
+
end
24
+
25
+
module M (* 5 *) : S = struct
26
+
let y (* 4 *) = 36
27
+
end
28
+
29
+
module N (* 8 *) : sig
30
+
val y (* 7 *) : int
31
+
end = struct
32
+
let y (* 6 *) = 2
33
+
end
34
+
35
+
let _ = (module N : S)
36
+
37
+
module P (* 10 *)= struct
38
+
let y (* 9 *) = 12
39
+
end
40
+
41
+
module F (* 12 *) (X (* 11 *) : S) = X
42
+
43
+
module G (* 13 *) = F(P)
44
+
45
+
module type Initial (* 16 *) = sig
46
+
module type Nested (* 15 *) = sig
47
+
type t (* 14 *)
48
+
end
49
+
end
50
+
51
+
module MF (* 23 *) : sig
52
+
module F (* 22 *) (X (* 21 *) : sig val x (* 20 *) : int end) : sig end
53
+
end = struct
54
+
module F (* 19 *) (X (* 18 *) : sig val x (* 17 *) : int end) = struct end
55
+
end
56
+
57
+
module FMT (* 27 *) (X (* 26 *) : sig
58
+
module type MT (* 25 *) = sig val x (* 24 *) : int end
59
+
end) : sig end = struct end
+19
testsuite/tests/uid-deps/link_intf_impl.mli
+19
testsuite/tests/uid-deps/link_intf_impl.mli
···
1
+
type t (* 0 *)
2
+
3
+
val x (* 1 *) : t
4
+
5
+
module type S (* 3 *) = sig
6
+
val y (* 2 *) : t
7
+
end
8
+
9
+
module M (* 4 *) : S
10
+
11
+
module type Initial (* 7 *) = sig
12
+
module type Nested (* 6 *) = sig
13
+
type t (* 5 *)
14
+
end
15
+
end
16
+
17
+
module FMT (* 11 *) (X (* 10 *) : sig
18
+
module type MT (* 9 *) = sig val x (* 8 *) : int end
19
+
end) : sig end
+19
testsuite/tests/uid-deps/link_intf_impl.reference
+19
testsuite/tests/uid-deps/link_intf_impl.reference
···
1
+
2
+
Uid dependencies:
3
+
Link_intf_impl.0 <- [intf]Link_intf_impl.1
4
+
Link_intf_impl.1 <- [intf]Link_intf_impl.0
5
+
Link_intf_impl.2 <-> [intf]Link_intf_impl.2
6
+
Link_intf_impl.3 <- [intf]Link_intf_impl.3
7
+
Link_intf_impl.4 <- Link_intf_impl.2
8
+
Link_intf_impl.5 <- [intf]Link_intf_impl.4
9
+
Link_intf_impl.6 <- Link_intf_impl.7
10
+
Link_intf_impl.7 <-> Link_intf_impl.2
11
+
Link_intf_impl.9 <-> Link_intf_impl.2
12
+
Link_intf_impl.14 <-> [intf]Link_intf_impl.5
13
+
Link_intf_impl.15 <-> [intf]Link_intf_impl.6
14
+
Link_intf_impl.16 <- [intf]Link_intf_impl.7
15
+
Link_intf_impl.17 <-> Link_intf_impl.20
16
+
Link_intf_impl.19 <- Link_intf_impl.22
17
+
Link_intf_impl.24 <-> [intf]Link_intf_impl.8
18
+
Link_intf_impl.25 <-> [intf]Link_intf_impl.9
19
+
Link_intf_impl.27 <- [intf]Link_intf_impl.11
+24
tools/objinfo.ml
+24
tools/objinfo.ml
···
31
31
let shape = ref false
32
32
let index = ref false
33
33
let decls = ref false
34
+
let uid_deps = ref false
34
35
35
36
module Magic_number = Misc.Magic_number
36
37
···
128
129
Shape_reduce.print_result item pp_loc loc)
129
130
cmt.cmt_ident_occurrences;
130
131
Format.print_flush ()
132
+
end;
133
+
if !uid_deps then begin
134
+
printf "\nUid dependencies:\n";
135
+
let arr = Array.of_list cmt.cmt_declaration_dependencies in
136
+
let () =
137
+
Array.sort (fun (_tr, u1, u2) (_tr', u1', u2') ->
138
+
match Shape.Uid.compare u1 u1' with
139
+
| 0 -> Shape.Uid.compare u2 u2'
140
+
| n -> n) arr
141
+
in
142
+
Format.printf "@[<v>";
143
+
Array.iter (fun (rk, u1, u2) ->
144
+
let rk = match rk with
145
+
| Definition_to_declaration -> "<-"
146
+
| Declaration_to_declaration -> "<->"
147
+
in
148
+
Format.printf "@[<h>%a %s %a@]@;"
149
+
Shape.Uid.print u1
150
+
rk
151
+
Shape.Uid.print u2) arr;
152
+
Format.printf "@]";
131
153
end;
132
154
if !decls then begin
133
155
printf "\nUid of decls:\n";
···
456
478
" Print a list of all usages of values, types, etc. in the module";
457
479
"-decls", Arg.Set decls,
458
480
" Print a list of all declarations in the module";
481
+
"-uid-deps", Arg.Set uid_deps,
482
+
" Print the declarations' uids dependencies of the module";
459
483
"-null-crc", Arg.Set no_crc, " Print a null CRC for imported interfaces";
460
484
"-version", Arg.Unit print_version, " Print version and exit";
461
485
"-vnum", Arg.Unit print_version_num, " Print version number and exit";
+1
-1
toplevel/topcommon.ml
+1
-1
toplevel/topcommon.ml
···
216
216
in
217
217
if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
218
218
let sg' = Typemod.Signature_names.simplify newenv sn sg in
219
-
ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
219
+
Includemod.check_implementation oldenv sg sg';
220
220
Typecore.force_delayed_checks ();
221
221
let shape = Shape_reduce.local_reduce Env.empty shape in
222
222
if !Clflags.dump_shape then Shape.print ppf shape;
+210
-110
typing/includemod.ml
+210
-110
typing/includemod.ml
···
134
134
135
135
end
136
136
137
-
type mark =
137
+
module Directionality = struct
138
+
139
+
140
+
type mark =
138
141
| Mark_both
139
142
| Mark_positive
140
-
| Mark_negative
141
143
| Mark_neither
142
144
143
-
let negate_mark = function
144
-
| Mark_both -> Mark_both
145
-
| Mark_positive -> Mark_negative
146
-
| Mark_negative -> Mark_positive
147
-
| Mark_neither -> Mark_neither
145
+
type pos =
146
+
| Strictly_positive
147
+
(** Strictly positive positions are notable for tools since they are the
148
+
the case where we match a implementation definition with an interface
149
+
declaration. Oherwise in the positive case we are matching
150
+
declatations inside functor arguments at even level of nesting.*)
151
+
| Positive
152
+
| Negative
148
153
149
-
let mark_positive = function
150
-
| Mark_both | Mark_positive -> true
151
-
| Mark_negative | Mark_neither -> false
154
+
155
+
(**
156
+
When checking inclusion, the [Directionality.t] type tracks the
157
+
subtyping direction at the syntactic level.
158
+
159
+
The [posivity] field is used in the [cmt_declaration_dependencies] to
160
+
distinguish between directed and undirected edges, and to avoid recording
161
+
matched declarations twice.
162
+
163
+
The [mark_as_used] field describes if we should record only positive use,
164
+
any use (because there is no clear implementation side), or none (because we
165
+
are inside an auxiliary check function.)
166
+
167
+
The [in_eq] field is [true] when we are checking both directions inside of
168
+
module types which allows optimizing module type equality checks. The module
169
+
subtyping relation [A <: B] checks that [A.T = B.T] when [A] and [B] define a
170
+
module type [T]. The relation [A.T = B.T] is equivalent to [(A.T <: B.T) and
171
+
(B.T <: A.T)], but checking both recursively would lead to an exponential
172
+
slowdown (see #10598 and #10616). To avoid this issue, when [in_eq] is
173
+
[true], we compute a coarser relation [A << B] which is the same as [A <: B]
174
+
except that module types [T] are checked only for [A.T << B.T] and not the
175
+
reverse. Thus, we can implement a cheap module type equality check [A.T =
176
+
B.T] by computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential
177
+
slowdown described above.
178
+
*)
179
+
type t = {
180
+
in_eq:bool;
181
+
mark_as_used:mark;
182
+
pos:pos;
183
+
}
184
+
185
+
let strictly_positive ~mark =
186
+
let mark_as_used = if mark then Mark_positive else Mark_neither in
187
+
{ in_eq=false; pos=Strictly_positive; mark_as_used }
188
+
189
+
let unknown ~mark =
190
+
let mark_as_used = if mark then Mark_both else Mark_neither in
191
+
{ in_eq=false; pos=Positive; mark_as_used }
192
+
193
+
let negate_pos = function
194
+
| Positive | Strictly_positive -> Negative
195
+
| Negative -> Positive
196
+
197
+
let negate d = { d with pos = negate_pos d.pos }
198
+
199
+
let at_most_positive = function
200
+
| Strictly_positive -> Positive
201
+
| Positive | Negative as non_strict -> non_strict
202
+
203
+
let enter_eq d =
204
+
{
205
+
in_eq = true;
206
+
pos = at_most_positive d.pos;
207
+
mark_as_used = d.mark_as_used
208
+
}
209
+
210
+
let mark_as_used d = match d.mark_as_used with
211
+
| Mark_neither -> false
212
+
| Mark_both -> true
213
+
| Mark_positive ->
214
+
match d.pos with
215
+
| Positive | Strictly_positive -> true
216
+
| Negative -> false
217
+
218
+
end
152
219
153
220
module Core_inclusion = struct
154
221
(* All functions "blah env x1 x2" check that x1 is included in x2,
···
157
224
158
225
(* Inclusion between value descriptions *)
159
226
160
-
let value_descriptions ~loc env ~mark subst id vd1 vd2 =
161
-
Cmt_format.record_value_dependency vd1 vd2;
162
-
if mark_positive mark then
227
+
let value_descriptions ~loc env ~direction subst id vd1 vd2 =
228
+
if Directionality.mark_as_used direction then
163
229
Env.mark_value_used vd1.val_uid;
164
230
let vd2 = Subst.value_description subst vd2 in
165
231
try
···
169
235
170
236
(* Inclusion between type declarations *)
171
237
172
-
let type_declarations ~loc env ~mark subst id decl1 decl2 =
173
-
let mark = mark_positive mark in
238
+
let type_declarations ~loc env ~direction subst id decl1 decl2 =
239
+
let mark = Directionality.mark_as_used direction in
174
240
if mark then
175
241
Env.mark_type_used decl1.type_uid;
176
242
let decl2 = Subst.type_declaration subst decl2 in
···
184
250
185
251
(* Inclusion between extension constructors *)
186
252
187
-
let extension_constructors ~loc env ~mark subst id ext1 ext2 =
188
-
let mark = mark_positive mark in
253
+
let extension_constructors ~loc env ~direction subst id ext1 ext2 =
254
+
let mark = Directionality.mark_as_used direction in
189
255
let ext2 = Subst.extension_constructor subst ext2 in
190
256
match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with
191
257
| None -> Ok Tcoerce_none
···
194
260
195
261
(* Inclusion between class declarations *)
196
262
197
-
let class_type_declarations ~loc env ~mark:_ subst _id decl1 decl2 =
263
+
let class_type_declarations ~loc env ~direction:_ subst _id decl1 decl2 =
198
264
let decl2 = Subst.cltype_declaration subst decl2 in
199
265
match Includeclass.class_type_declarations ~loc env decl1 decl2 with
200
266
[] -> Ok Tcoerce_none
201
267
| reason ->
202
268
Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason)))
203
269
204
-
let class_declarations ~loc:_ env ~mark:_ subst _id decl1 decl2 =
270
+
let class_declarations ~loc:_ env ~direction:_ subst _id decl1 decl2 =
205
271
let decl2 = Subst.class_declaration subst decl2 in
206
272
match Includeclass.class_declarations env decl1 decl2 with
207
273
[] -> Ok Tcoerce_none
···
415
481
- the coarse-grain consistency relation [C], which is defined by
416
482
[d1 C d2] if there is an environment [E] such that [E |- d1 <: d2]. *)
417
483
type 'a core_incl =
418
-
loc:Location.t -> Env.t -> mark:mark -> Subst.t -> Ident.t ->
484
+
loc:Location.t -> Env.t -> direction:Directionality.t -> Subst.t -> Ident.t ->
419
485
'a -> 'a -> (module_coercion, Error.sigitem_symptom) result
420
486
421
487
type core_relation = {
···
426
492
class_type_declarations: Types.class_type_declaration core_incl;
427
493
}
428
494
429
-
(**
430
-
In the group of mutual functions below, the [~in_eq] argument is [true] when
431
-
we are in fact checking equality of module types.
432
495
433
-
The module subtyping relation [A <: B] checks that [A.T = B.T] when [A]
434
-
and [B] define a module type [T]. The relation [A.T = B.T] is equivalent
435
-
to [(A.T <: B.T) and (B.T <: A.T)], but checking both recursively would lead
436
-
to an exponential slowdown (see #10598 and #10616).
437
-
To avoid this issue, when [~in_eq] is [true], we compute a coarser relation
438
-
[A << B] which is the same as [A <: B] except that module types [T] are
439
-
checked only for [A.T << B.T] and not the reverse.
440
-
Thus, we can implement a cheap module type equality check [A.T = B.T] by
441
-
computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential slowdown
442
-
described above.
443
-
*)
444
-
445
-
let rec modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape =
446
-
match try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape with
496
+
let rec modtypes ~core ~direction ~loc env subst mty1 mty2 shape =
497
+
match try_modtypes ~core ~direction ~loc env subst mty1 mty2 shape with
447
498
| Ok _ as ok -> ok
448
499
| Error reason ->
449
500
let mty2 = Subst.modtype Make_local subst mty2 in
450
501
Error Error.(diff mty1 mty2 reason)
451
502
452
-
and try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape =
503
+
and try_modtypes ~core ~direction ~loc env subst mty1 mty2 orig_shape =
453
504
match mty1, mty2 with
454
505
| (Mty_alias p1, Mty_alias p2) ->
455
506
if Env.is_functor_arg p2 env then
···
467
518
begin match expand_module_alias ~strengthen:false env p1 with
468
519
| Error e -> Error (Error.Mt_core e)
469
520
| Ok mty1 ->
470
-
match strengthened_modtypes ~core ~in_eq ~loc ~aliasable:true env
471
-
~mark subst mty1 p1 mty2 orig_shape
521
+
match strengthened_modtypes ~core ~direction ~loc ~aliasable:true
522
+
env subst mty1 p1 mty2 orig_shape
472
523
with
473
524
| Ok _ as x -> x
474
525
| Error reason -> Error (Error.After_alias_expansion reason)
···
481
532
else
482
533
begin match expand_modtype_path env p1, expand_modtype_path env p2 with
483
534
| Some mty1, Some mty2 ->
484
-
try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape
535
+
try_modtypes ~core ~direction ~loc env subst mty1 mty2 orig_shape
485
536
| None, _ | _, None -> Error (Error.Mt_core Abstract_module_type)
486
537
end
487
538
| (Mty_ident p1, _) ->
488
539
let p1 = Env.normalize_modtype_path env p1 in
489
540
begin match expand_modtype_path env p1 with
490
541
| Some p1 ->
491
-
try_modtypes ~core ~in_eq ~loc env ~mark subst p1 mty2 orig_shape
542
+
try_modtypes ~core ~direction ~loc env subst p1 mty2 orig_shape
492
543
| None -> Error (Error.Mt_core Abstract_module_type)
493
544
end
494
545
| (_, Mty_ident p2) ->
495
546
let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
496
547
begin match expand_modtype_path env p2 with
497
548
| Some p2 ->
498
-
try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 p2 orig_shape
549
+
try_modtypes ~core ~direction ~loc env subst mty1 p2 orig_shape
499
550
| None ->
500
551
begin match mty1 with
501
552
| Mty_functor _ ->
···
507
558
end
508
559
| (Mty_signature sig1, Mty_signature sig2) ->
509
560
begin match
510
-
signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape
561
+
signatures ~core ~direction ~loc env subst sig1 sig2 orig_shape
511
562
with
512
563
| Ok _ as ok -> ok
513
564
| Error e -> Error (Error.Signature e)
514
565
end
515
566
| Mty_functor (param1, res1), Mty_functor (param2, res2) ->
516
567
let cc_arg, env, subst =
517
-
functor_param ~core ~in_eq ~loc env ~mark:(negate_mark mark)
568
+
let direction = Directionality.negate direction in
569
+
functor_param ~core ~direction ~loc env
518
570
subst param1 param2
519
571
in
520
572
let var, res_shape =
···
532
584
var, Shape.app orig_shape ~arg:shape_var
533
585
in
534
586
let cc_res =
535
-
modtypes ~core ~in_eq ~loc env ~mark subst res1 res2 res_shape
587
+
modtypes ~core ~direction ~loc env subst res1 res2 res_shape
536
588
in
537
589
begin match cc_arg, cc_res with
538
590
| Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) ->
···
575
627
576
628
(* Functor parameters *)
577
629
578
-
and functor_param ~core ~in_eq ~loc env ~mark subst param1 param2 =
630
+
and functor_param ~core ~direction ~loc env subst param1 param2 =
579
631
match param1, param2 with
580
632
| Unit, Unit ->
581
633
Ok Tcoerce_none, env, subst
···
583
635
let arg2' = Subst.modtype Keep subst arg2 in
584
636
let cc_arg =
585
637
match
586
-
modtypes ~core ~in_eq ~loc env ~mark Subst.identity arg2' arg1
638
+
modtypes ~core ~direction ~loc env Subst.identity arg2' arg1
587
639
Shape.dummy_mod
588
640
with
589
641
| Ok (cc, _) -> Ok cc
···
611
663
| None, None ->
612
664
env, subst
613
665
614
-
and strengthened_modtypes ~core ~in_eq ~loc ~aliasable env ~mark
666
+
and strengthened_modtypes ~core ~direction ~loc ~aliasable env
615
667
subst mty1 path1 mty2 shape =
616
668
match mty1, mty2 with
617
669
| Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
618
670
Ok (Tcoerce_none, shape)
619
671
| _, _ ->
620
672
let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in
621
-
modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape
673
+
modtypes ~core ~direction ~loc env subst mty1 mty2 shape
622
674
623
-
and strengthened_module_decl ~core ~loc ~aliasable env ~mark
675
+
and strengthened_module_decl ~core ~loc ~aliasable ~direction env
624
676
subst md1 path1 md2 shape =
625
677
match md1.md_type, md2.md_type with
626
678
| Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
627
679
Ok (Tcoerce_none, shape)
628
680
| _, _ ->
629
681
let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in
630
-
modtypes ~core ~in_eq:false ~loc env ~mark subst
631
-
md1.md_type md2.md_type shape
682
+
modtypes ~core ~direction ~loc env subst md1.md_type md2.md_type shape
632
683
633
684
(* Inclusion between signatures *)
634
685
635
-
and signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape =
686
+
and signatures ~core ~direction ~loc env subst sig1 sig2 mod_shape =
636
687
(* Environment used to check inclusion of components *)
637
688
let new_env =
638
689
Env.add_signature sig1 (Env.in_signature true env) in
···
681
732
[] ->
682
733
let open Sign_diff in
683
734
let d =
684
-
signature_components ~core ~in_eq ~loc env ~mark new_env subst
735
+
signature_components ~core ~direction ~loc env new_env subst
685
736
mod_shape Shape.Map.empty
686
737
(List.rev paired)
687
738
in
···
745
796
746
797
(* Inclusion between signature components *)
747
798
748
-
and signature_components ~core ~in_eq ~loc old_env ~mark env subst
799
+
and signature_components ~core ~direction ~loc old_env env subst
749
800
orig_shape shape_map paired =
750
801
match paired with
751
802
| [] -> Sign_diff.{ empty with shape_map }
752
803
| (sigi1, sigi2, pos) :: rem ->
753
804
let shape_modified = ref false in
754
-
let id, item, shape_map, present_at_runtime =
805
+
let id, item, paired_uids, shape_map, present_at_runtime =
755
806
match sigi1, sigi2 with
756
807
| Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) ->
757
808
let item =
758
-
core.value_descriptions ~loc env ~mark subst id1
809
+
core.value_descriptions ~loc ~direction env subst id1
759
810
valdecl1 valdecl2
760
811
in
761
812
let item = mark_error_as_recoverable item in
···
764
815
| _ -> true
765
816
in
766
817
let shape_map = Shape.Map.add_value_proj shape_map id1 orig_shape in
767
-
id1, item, shape_map, present_at_runtime
818
+
let paired_uids = (valdecl1.val_uid, valdecl2.val_uid) in
819
+
id1, item, paired_uids, shape_map, present_at_runtime
768
820
| Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) ->
769
821
let item =
770
-
core.type_declarations ~loc env ~mark subst id1 tydec1 tydec2
822
+
core.type_declarations ~loc ~direction env subst id1 tydec1 tydec2
771
823
in
772
824
let item = mark_error_as_unrecoverable item in
773
825
(* Right now we don't filter hidden constructors / labels from the
774
826
shape. *)
775
827
let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in
776
-
id1, item, shape_map, false
828
+
id1, item, (tydec1.type_uid, tydec2.type_uid), shape_map, false
777
829
| Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) ->
778
830
let item =
779
-
core.extension_constructors ~loc env ~mark subst id1 ext1 ext2
831
+
core.extension_constructors ~loc ~direction env subst id1
832
+
ext1 ext2
780
833
in
781
834
let item = mark_error_as_unrecoverable item in
782
835
let shape_map =
783
836
Shape.Map.add_extcons_proj shape_map id1 orig_shape
784
837
in
785
-
id1, item, shape_map, true
838
+
id1, item, (ext1.ext_uid, ext2.ext_uid), shape_map, true
786
839
| Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _)
787
840
-> begin
788
841
let orig_shape =
789
842
Shape.(proj orig_shape (Item.module_ id1))
790
843
in
791
844
let item =
792
-
module_declarations ~core ~in_eq ~loc env ~mark subst id1
845
+
module_declarations ~core ~direction ~loc env subst id1
793
846
mty1 mty2 orig_shape
794
847
in
795
848
let item, shape_map =
···
814
867
| Mp_absent, Mp_present, _ -> assert false
815
868
in
816
869
let item = mark_error_as_unrecoverable item in
817
-
id1, item, shape_map, present_at_runtime
870
+
let paired_uids = (mty1.md_uid, mty2.md_uid) in
871
+
id1, item, paired_uids, shape_map, present_at_runtime
818
872
end
819
873
| Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) ->
820
874
let item =
821
-
modtype_infos ~core ~in_eq ~loc env ~mark subst id1 info1 info2
875
+
modtype_infos ~core ~direction ~loc env subst id1 info1 info2
822
876
in
823
877
let shape_map =
824
878
Shape.Map.add_module_type_proj shape_map id1 orig_shape
825
879
in
826
880
let item = mark_error_as_unrecoverable item in
827
-
id1, item, shape_map, false
881
+
id1, item, (info1.mtd_uid, info2.mtd_uid), shape_map, false
828
882
| Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) ->
829
883
let item =
830
-
core.class_declarations ~loc env ~mark subst id1 decl1 decl2
884
+
core.class_declarations ~loc ~direction env subst id1 decl1 decl2
831
885
in
832
886
let shape_map =
833
887
Shape.Map.add_class_proj shape_map id1 orig_shape
834
888
in
835
889
let item = mark_error_as_unrecoverable item in
836
-
id1, item, shape_map, true
890
+
id1, item, (decl1.cty_uid, decl2.cty_uid), shape_map, true
837
891
| Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) ->
838
892
let item =
839
-
core.class_type_declarations ~loc env ~mark subst id1 info1 info2
893
+
core.class_type_declarations ~loc ~direction env subst id1
894
+
info1 info2
840
895
in
841
896
let item = mark_error_as_unrecoverable item in
842
897
let shape_map =
843
898
Shape.Map.add_class_type_proj shape_map id1 orig_shape
844
899
in
845
-
id1, item, shape_map, false
900
+
id1, item, (info1.clty_uid, info2.clty_uid), shape_map, false
846
901
| _ ->
847
902
assert false
848
903
in
···
850
905
let first =
851
906
match item with
852
907
| Ok x ->
908
+
begin match direction with
909
+
| { Directionality.in_eq = true; pos = Negative }
910
+
| { Directionality.mark_as_used = Mark_neither; _ } ->
911
+
(* We do not store paired uids when checking for reverse
912
+
module-type inclusion as it would introduce duplicates. *)
913
+
()
914
+
| { Directionality.pos; _} ->
915
+
let paired_uids =
916
+
let elt1, elt2 = paired_uids in
917
+
match pos with
918
+
| Negative ->
919
+
(Cmt_format.Declaration_to_declaration, elt2, elt1)
920
+
| Positive ->
921
+
(Cmt_format.Declaration_to_declaration, elt1, elt2)
922
+
| Strictly_positive ->
923
+
(Cmt_format. Definition_to_declaration, elt1, elt2)
924
+
in
925
+
Cmt_format.record_declaration_dependency paired_uids
926
+
end;
853
927
let runtime_coercions =
854
928
if present_at_runtime then [pos,x] else []
855
929
in
···
863
937
in
864
938
let rest =
865
939
if continue then
866
-
signature_components ~core ~in_eq ~loc old_env ~mark env subst
940
+
signature_components ~core ~direction ~loc old_env env subst
867
941
orig_shape shape_map rem
868
942
else Sign_diff.{ empty with leftovers=rem }
869
943
in
870
944
Sign_diff.merge first rest
871
945
872
-
and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape =
946
+
and module_declarations ~direction ~loc env subst id1 md1 md2 orig_shape =
873
947
Builtin_attributes.check_alerts_inclusion
874
948
~def:md1.md_loc
875
949
~use:md2.md_loc
···
877
951
md1.md_attributes md2.md_attributes
878
952
(Ident.name id1);
879
953
let p1 = Path.Pident id1 in
880
-
if mark_positive mark then
954
+
if Directionality.mark_as_used direction then
881
955
Env.mark_module_used md1.md_uid;
882
-
strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark subst
956
+
strengthened_modtypes ~direction ~loc ~aliasable:true env subst
883
957
md1.md_type p1 md2.md_type orig_shape
884
958
885
959
(* Inclusion between module type specifications *)
886
960
887
-
and modtype_infos ~core ~in_eq ~loc env ~mark subst id info1 info2 =
961
+
and modtype_infos ~core ~direction ~loc env subst id info1 info2 =
888
962
Builtin_attributes.check_alerts_inclusion
889
963
~def:info1.mtd_loc
890
964
~use:info2.mtd_loc
···
897
971
(None, None) -> Ok Tcoerce_none
898
972
| (Some _, None) -> Ok Tcoerce_none
899
973
| (Some mty1, Some mty2) ->
900
-
check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2
974
+
check_modtype_equiv ~core ~direction ~loc env mty1 mty2
901
975
| (None, Some mty2) ->
902
976
let mty1 = Mty_ident(Path.Pident id) in
903
-
check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 in
977
+
check_modtype_equiv ~core ~direction ~loc env mty1 mty2 in
904
978
match r with
905
979
| Ok _ as ok -> ok
906
980
| Error e -> Error Error.(Module_type_declaration (diff info1 info2 e))
907
981
908
-
and check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 =
982
+
and check_modtype_equiv ~core ~direction ~loc env mty1 mty2 =
983
+
let nested_eq = direction.Directionality.in_eq in
984
+
let direction = Directionality.enter_eq direction in
909
985
let c1 =
910
-
modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2
911
-
Shape.dummy_mod
986
+
modtypes ~core ~direction ~loc env Subst.identity mty1 mty2 Shape.dummy_mod
912
987
in
913
988
let c2 =
914
989
(* For nested module type paths, we check only one side of the equivalence:
915
990
the outer module type is the one responsible for checking the other side
916
991
of the equivalence.
917
992
*)
918
-
if in_eq then None
993
+
if nested_eq then None
919
994
else
920
-
let mark = negate_mark mark in
995
+
let direction = Directionality.negate direction in
921
996
Some (
922
-
modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity
997
+
modtypes ~core ~direction ~loc env Subst.identity
923
998
mty2 mty1 Shape.dummy_mod
924
999
)
925
1000
in
···
954
1029
}
955
1030
956
1031
let core_consistency =
957
-
let type_declarations ~loc:_ env ~mark:_ _ _ d1 d2 =
1032
+
let type_declarations ~loc:_ env ~direction:_ _ _ d1 d2 =
958
1033
match Includecore.type_declarations_consistency env d1 d2 with
959
1034
| None -> Ok Tcoerce_none
960
1035
| Some err -> Error Error.(Core(Type_declarations (diff d1 d2 err)))
961
1036
in
962
-
let value_descriptions ~loc:_ env ~mark:_ _ _ vd1 vd2 =
1037
+
let value_descriptions ~loc:_ env ~direction:_ _ _ vd1 vd2 =
963
1038
match Includecore.value_descriptions_consistency env vd1 vd2 with
964
1039
| x -> Ok x
965
1040
| exception Includecore.Dont_match err ->
966
1041
Error Error.(Core (Value_descriptions (diff vd1 vd2 err)))
967
1042
in
968
-
let accept ~loc:_ _env ~mark:_ _subst _id _d1 _d2 = Ok Tcoerce_none in
1043
+
let accept ~loc:_ _env ~direction:_ _subst _id _d1 _d2 = Ok Tcoerce_none in
969
1044
{
970
1045
type_declarations;
971
1046
value_descriptions;
···
991
1066
992
1067
let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 =
993
1068
let aliasable = can_alias env path1 in
994
-
strengthened_modtypes ~core:core_inclusion ~in_eq:false ~loc ~aliasable env
995
-
~mark:Mark_both Subst.identity mty1 path1 mty2 Shape.dummy_mod
1069
+
let direction = Directionality.unknown ~mark:true in
1070
+
strengthened_modtypes ~core:core_inclusion ~direction ~loc ~aliasable env
1071
+
Subst.identity mty1 path1 mty2 Shape.dummy_mod
996
1072
|> Result.map fst
997
1073
998
1074
let check_modtype_inclusion ~loc env mty1 path1 mty2 =
···
1028
1104
1029
1105
let compunit env ~mark impl_name impl_sig intf_name intf_sig unit_shape =
1030
1106
let loc = Location.in_file impl_name in
1107
+
let direction = Directionality.strictly_positive ~mark in
1031
1108
match
1032
-
signatures ~core:core_inclusion ~in_eq:false ~loc env
1033
-
~mark Subst.identity impl_sig intf_sig unit_shape
1109
+
signatures ~core:core_inclusion ~direction ~loc env Subst.identity
1110
+
impl_sig intf_sig unit_shape
1034
1111
with Result.Error reasons ->
1035
1112
let cdiff =
1036
1113
Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in
···
1133
1210
let test st mty1 mty2 =
1134
1211
let loc = Location.none in
1135
1212
let res, _, _ =
1136
-
functor_param ~core:core_inclusion ~in_eq:false ~loc st.env
1137
-
~mark:Mark_neither st.subst mty1 mty2
1213
+
let direction=Directionality.unknown ~mark:false in
1214
+
functor_param ~core:core_inclusion ~direction ~loc st.env
1215
+
st.subst mty1 mty2
1138
1216
in
1139
1217
res
1140
1218
let update = update
···
1227
1305
| Unit, Named _ | (Anonymous | Named _), Unit ->
1228
1306
Result.Error (Error.Incompatible_params(arg,param))
1229
1307
| ( Anonymous | Named _ | Empty_struct ), Named (_, param) ->
1308
+
let direction=Directionality.unknown ~mark:false in
1230
1309
match
1231
-
modtypes ~core:core_inclusion ~in_eq:false ~loc state.env
1232
-
~mark:Mark_neither state.subst arg_mty param
1233
-
Shape.dummy_mod
1310
+
modtypes
1311
+
~core:core_inclusion ~direction ~loc
1312
+
state.env state.subst arg_mty param
1313
+
Shape.dummy_mod
1234
1314
with
1235
1315
| Error mty -> Result.Error (Error.Mismatch mty)
1236
1316
| Ok (cc, _) -> Ok cc
···
1251
1331
(* Hide the context and substitution parameters to the outside world *)
1252
1332
1253
1333
let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 =
1254
-
match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark
1255
-
Subst.identity mty1 mty2 shape
1334
+
(* modtypes with shape is used when typing module expressions in [Typemod] *)
1335
+
let direction = Directionality.strictly_positive ~mark in
1336
+
match
1337
+
modtypes ~core:core_inclusion ~direction ~loc env Subst.identity
1338
+
mty1 mty2 shape
1256
1339
with
1257
1340
| Ok (cc, shape) -> cc, shape
1258
1341
| Error reason -> raise (Error (env, Error.(In_Module_type reason)))
1259
1342
1260
1343
let modtypes_consistency ~loc env mty1 mty2 =
1261
-
match modtypes ~core:core_consistency ~in_eq:false ~loc env ~mark:Mark_neither
1262
-
Subst.identity mty1 mty2 Shape.dummy_mod
1344
+
let direction = Directionality.unknown ~mark:false in
1345
+
match
1346
+
modtypes ~core:core_consistency ~direction ~loc env Subst.identity
1347
+
mty1 mty2 Shape.dummy_mod
1263
1348
with
1264
1349
| Ok _ -> ()
1265
1350
| Error reason -> raise (Error (env, Error.(In_Module_type reason)))
1266
1351
1267
1352
let modtypes ~loc env ~mark mty1 mty2 =
1268
-
match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark
1269
-
Subst.identity mty1 mty2 Shape.dummy_mod
1353
+
let direction = Directionality.unknown ~mark in
1354
+
match
1355
+
modtypes ~core:core_inclusion ~direction ~loc env Subst.identity
1356
+
mty1 mty2 Shape.dummy_mod
1270
1357
with
1271
1358
| Ok (cc, _) -> cc
1272
1359
| Error reason -> raise (Error (env, Error.(In_Module_type reason)))
1273
1360
1274
-
let signatures env ~mark sig1 sig2 =
1275
-
match signatures ~core:core_inclusion ~in_eq:false ~loc:Location.none env
1276
-
~mark Subst.identity sig1 sig2 Shape.dummy_mod
1361
+
let gen_signatures env ~direction sig1 sig2 =
1362
+
match
1363
+
signatures
1364
+
~core:core_inclusion ~direction ~loc:Location.none env
1365
+
Subst.identity sig1 sig2 Shape.dummy_mod
1277
1366
with
1278
1367
| Ok (cc, _) -> cc
1279
1368
| Error reason -> raise (Error(env,Error.(In_Signature reason)))
1280
1369
1370
+
let signatures env ~mark sig1 sig2 =
1371
+
let direction = Directionality.unknown ~mark in
1372
+
gen_signatures env ~direction sig1 sig2
1373
+
1374
+
let check_implementation env impl intf =
1375
+
let direction = Directionality.strictly_positive ~mark:true in
1376
+
ignore (gen_signatures env ~direction impl intf)
1377
+
1281
1378
let type_declarations ~loc env ~mark id decl1 decl2 =
1282
-
match Core_inclusion.type_declarations ~loc env ~mark
1379
+
let direction = Directionality.unknown ~mark in
1380
+
match Core_inclusion.type_declarations ~loc env ~direction
1283
1381
Subst.identity id decl1 decl2
1284
1382
with
1285
1383
| Ok _ -> ()
···
1288
1386
| Error _ -> assert false
1289
1387
1290
1388
let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 =
1291
-
match strengthened_module_decl ~core:core_inclusion ~loc ~aliasable env ~mark
1292
-
Subst.identity md1 path1 md2 Shape.dummy_mod with
1389
+
let direction = Directionality.unknown ~mark in
1390
+
match strengthened_module_decl ~core:core_inclusion ~loc ~aliasable ~direction
1391
+
env Subst.identity md1 path1 md2 Shape.dummy_mod with
1293
1392
| Ok (x, _shape) -> x
1294
1393
| Error mdiff ->
1295
1394
raise (Error(env,Error.(In_Module_type mdiff)))
···
1301
1400
raise (Error(env,In_Expansion(Error.Unbound_module_path path)))
1302
1401
1303
1402
let check_modtype_equiv ~loc env id mty1 mty2 =
1304
-
match check_modtype_equiv ~core:core_inclusion ~in_eq:false ~loc env
1305
-
~mark:Mark_both mty1 mty2
1403
+
let direction = Directionality.unknown ~mark:true in
1404
+
match
1405
+
check_modtype_equiv ~core:core_inclusion ~loc ~direction env mty1 mty2
1306
1406
with
1307
1407
| Ok _ -> ()
1308
1408
| Error e ->
+9
-20
typing/includemod.mli
+9
-20
typing/includemod.mli
···
18
18
open Typedtree
19
19
open Types
20
20
21
-
(** Type describing which arguments of an inclusion to consider as used
22
-
for the usage warnings. [Mark_both] is the default. *)
23
-
type mark =
24
-
| Mark_both
25
-
(** Mark definitions used from both arguments *)
26
-
| Mark_positive
27
-
(** Mark definitions used from the positive (first) argument *)
28
-
| Mark_negative
29
-
(** Mark definitions used from the negative (second) argument *)
30
-
| Mark_neither
31
-
(** Do not mark definitions used from either argument *)
32
-
33
21
module Error: sig
34
22
35
23
type ('elt,'explanation) diff = {
···
152
140
(* Typechecking *)
153
141
154
142
val modtypes:
155
-
loc:Location.t -> Env.t -> mark:mark ->
143
+
loc:Location.t -> Env.t -> mark:bool ->
156
144
module_type -> module_type -> module_coercion
157
-
158
145
159
146
val modtypes_consistency:
160
147
loc:Location.t -> Env.t -> module_type -> module_type -> unit
161
148
162
149
val modtypes_with_shape:
163
-
shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark ->
150
+
shape:Shape.t -> loc:Location.t -> Env.t -> mark:bool ->
164
151
module_type -> module_type -> module_coercion * Shape.t
165
152
166
153
val strengthened_module_decl:
167
-
loc:Location.t -> aliasable:bool -> Env.t -> mark:mark ->
154
+
loc:Location.t -> aliasable:bool -> Env.t -> mark:bool ->
168
155
module_declaration -> Path.t -> module_declaration -> module_coercion
169
156
170
157
val check_modtype_inclusion :
···
177
164
val check_modtype_equiv:
178
165
loc:Location.t -> Env.t -> Ident.t -> module_type -> module_type -> unit
179
166
180
-
val signatures: Env.t -> mark:mark ->
181
-
signature -> signature -> module_coercion
167
+
val signatures: Env.t -> mark:bool -> signature -> signature -> module_coercion
168
+
169
+
(** Check an implementation against an interface *)
170
+
val check_implementation: Env.t -> signature -> signature -> unit
182
171
183
172
val compunit:
184
-
Env.t -> mark:mark -> string -> signature ->
173
+
Env.t -> mark:bool -> string -> signature ->
185
174
string -> signature -> Shape.t -> module_coercion * Shape.t
186
175
187
176
val type_declarations:
188
-
loc:Location.t -> Env.t -> mark:mark ->
177
+
loc:Location.t -> Env.t -> mark:bool ->
189
178
Ident.t -> type_declaration -> type_declaration -> unit
190
179
191
180
val print_coercion: Format.formatter -> module_coercion -> unit
+12
-14
typing/typemod.ml
+12
-14
typing/typemod.ml
···
232
232
| Some fresh_row_id -> Env.add_type ~check:false fresh_row_id newdecl env
233
233
in
234
234
let env = Env.add_signature sg env in
235
-
Includemod.type_declarations ~mark:Mark_both ~loc env fresh_id newdecl decl;
235
+
Includemod.type_declarations ~mark:true ~loc env fresh_id newdecl decl;
236
236
Typedecl.check_coherence env loc path newdecl
237
237
238
238
let make_variance p n i =
···
627
627
let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in
628
628
let md'' = { md' with md_type = mty } in
629
629
let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in
630
-
ignore(Includemod.modtypes ~mark:Mark_both ~loc sig_env
630
+
ignore(Includemod.modtypes ~mark:true ~loc sig_env
631
631
newmd.md_type md.md_type);
632
632
return
633
633
~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv)))
···
637
637
let sig_env = Env.add_signature sg_for_env outer_sig_env in
638
638
let aliasable = not (Env.is_functor_arg path sig_env) in
639
639
ignore
640
-
(Includemod.strengthened_module_decl ~loc ~mark:Mark_both
640
+
(Includemod.strengthened_module_decl ~loc ~mark:true
641
641
~aliasable sig_env md' path md);
642
642
real_ids := [Pident id];
643
643
return ~replace_by:None
···
2024
2024
let coercion, shape =
2025
2025
try
2026
2026
Includemod.modtypes_with_shape ~shape
2027
-
~loc:modl.mod_loc ~mark:Mark_both
2027
+
~loc:modl.mod_loc ~mark:true
2028
2028
env mty_actual' mty_decl'
2029
2029
with Includemod.Error msg ->
2030
2030
raise(Error(modl.mod_loc, env, Not_included msg)) in
···
2111
2111
Result.Error (Errortrace.Package_cannot_scrape r)
2112
2112
| mty1, mty2 ->
2113
2113
let loc = Location.none in
2114
-
match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with
2114
+
match Includemod.modtypes ~loc ~mark:true env mty1 mty2 with
2115
2115
| Tcoerce_none -> Ok ()
2116
2116
| c ->
2117
2117
let msg =
···
2125
2125
let () = Ctype.package_subtype := package_subtype
2126
2126
2127
2127
let wrap_constraint_package env mark arg mty explicit =
2128
-
let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in
2129
2128
let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in
2130
2129
let mty2 = Subst.modtype Keep Subst.identity mty in
2131
2130
let coercion =
···
2141
2140
2142
2141
let wrap_constraint_with_shape env mark arg mty
2143
2142
shape explicit =
2144
-
let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in
2145
2143
let coercion, shape =
2146
2144
try
2147
2145
Includemod.modtypes_with_shape ~shape ~loc:arg.mod_loc env ~mark
···
2409
2407
| { loc = app_loc; attributes = app_attributes;
2410
2408
arg = Some { shape = arg_shape; path = arg_path; arg } } ->
2411
2409
let coercion =
2412
-
try Includemod.modtypes
2413
-
~loc:arg.mod_loc ~mark:Mark_both env arg.mod_type mty_param
2410
+
try Includemod.modtypes ~loc:arg.mod_loc ~mark:true env
2411
+
arg.mod_type mty_param
2414
2412
with Includemod.Error _ -> apply_error ()
2415
2413
in
2416
2414
let mty_appl =
···
2439
2437
raise (Error(app_loc, env, error))
2440
2438
in
2441
2439
begin match
2442
-
Includemod.modtypes
2443
-
~loc:app_loc ~mark:Mark_neither env mty_res nondep_mty
2440
+
Includemod.modtypes ~loc:app_loc ~mark:false env
2441
+
mty_res nondep_mty
2444
2442
with
2445
2443
| Tcoerce_none -> ()
2446
2444
| _ ->
···
3122
3120
in
3123
3121
let dclsig = Env.read_signature compiled_intf_file in
3124
3122
let coercion, shape =
3125
-
Includemod.compunit initial_env ~mark:Mark_positive
3123
+
Includemod.compunit initial_env ~mark:true
3126
3124
sourcefile sg source_intf
3127
3125
dclsig shape
3128
3126
in
···
3143
3141
(Location.in_file (Unit_info.source_file target))
3144
3142
Warnings.Missing_mli;
3145
3143
let coercion, shape =
3146
-
Includemod.compunit initial_env ~mark:Mark_positive
3144
+
Includemod.compunit initial_env ~mark:true
3147
3145
sourcefile sg "(inferred signature)" simple_sg shape
3148
3146
in
3149
3147
check_nongen_signature finalenv simple_sg;
···
3254
3252
end;
3255
3253
let dclsig = Env.read_signature target_cmi in
3256
3254
let cc, _shape =
3257
-
Includemod.compunit initial_env ~mark:Mark_both
3255
+
Includemod.compunit initial_env ~mark:true
3258
3256
"(obtained by packing)" sg mli dclsig shape
3259
3257
in
3260
3258
Cmt_format.save_cmt (Unit_info.companion_cmt target_cmi)