this repo has no description
Fix issue #930: Crash when substituting for the same name at different arities
The fix applies inline TypeSubstitution items during include expansion. When
a module type containing a TypeSubstitution (like `type 'a t := unit`) is
included elsewhere, the substitution is now applied at that point rather than
being preserved as-is.
Key changes:
- Add `apply_inner_substs` function in tools.ml that processes TypeSubstitution,
ModuleSubstitution, and ModuleTypeSubstitution items during include expansion
- Add `is_elidable_with_u` optimization to skip recompilation for pure signatures
- Add assertion for arity mismatch in type substitution to aid debugging
- Add `Subst.pp` for debugging substitution maps
This matches OCaml's behavior where destructive substitutions are applied to
produce a simplified signature when included.
Fixes #930, #1385
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
authored by
Claude Opus 4.5
and committed by
Jon Ludlam's Agent
67e84845
0d26341b
+15
-4
src/xref2/compile.ml
+15
-4
src/xref2/compile.ml
···
386
386
fun env id decl ->
387
387
let open Include in
388
388
match decl with
389
-
| ModuleType expr -> ModuleType (u_module_type_expr env id expr)
389
+
| ModuleType expr ->
390
+
let rec is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
391
+
function
392
+
| Path _ -> false
393
+
| Signature _ -> true
394
+
| With (_, expr) -> is_elidable_with_u expr
395
+
| TypeOf _ -> false
396
+
in
397
+
if is_elidable_with_u expr then ModuleType expr
398
+
else ModuleType (u_module_type_expr env id expr)
390
399
| Alias p -> Alias (module_path env p)
391
400
392
401
and module_type : Env.t -> ModuleType.t -> ModuleType.t =
···
425
434
Strengthen.signature cp sg
426
435
| None -> sg
427
436
in
428
-
let e = Lang_of.(simple_expansion map i.parent (Signature sg')) in
429
-
437
+
let sg'' = Tools.apply_inner_substs env sg' in
438
+
let e = Lang_of.(simple_expansion map i.parent (Signature sg'')) in
430
439
let expansion_sg =
431
440
match e with
432
441
| ModuleType.Signature sg -> sg
···
435
444
in
436
445
{ i.expansion with content = expansion_sg }
437
446
in
438
-
let expansion = get_expansion () in
447
+
let expansion =
448
+
if i.expansion.content.compiled then i.expansion else get_expansion ()
449
+
in
439
450
let items, env' = signature_items env i.parent expansion.content.items in
440
451
let expansion =
441
452
{
+10
-1
src/xref2/component.ml
+10
-1
src/xref2/component.ml
···
1093
1093
let pp_sep ppf () = Format.fprintf ppf ", " in
1094
1094
Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep type_param) ts
1095
1095
1096
-
and type_equation c ppf t =
1096
+
and type_equation_manifest c ppf t =
1097
1097
match t.TypeDecl.Equation.manifest with
1098
1098
| None -> ()
1099
1099
| Some m -> Format.fprintf ppf " = %a" (type_expr c) m
1100
+
1101
+
and type_equation_params _c ppf t =
1102
+
match t.TypeDecl.Equation.params with
1103
+
| [] -> ()
1104
+
| ps -> Format.fprintf ppf "%a" type_params ps
1105
+
1106
+
and type_equation c ppf t =
1107
+
Format.fprintf ppf "(params %a)%a" (type_equation_params c) t
1108
+
(type_equation_manifest c) t
1100
1109
1101
1110
and exception_ _c _ppf _e = ()
1102
1111
+4
-3
src/xref2/expand_tools.ml
+4
-3
src/xref2/expand_tools.ml
···
50
50
match t with
51
51
| Var (v, _) -> (
52
52
try List.assoc v map
53
-
with _ ->
54
-
Format.eprintf "Failed to list assoc %s\n%!" v;
55
-
failwith "bah")
53
+
with Not_found ->
54
+
Format.eprintf "Type variable '%s' not found in map [%s]@." v
55
+
(String.concat ", " (List.map fst map));
56
+
assert false)
56
57
| Any -> Any
57
58
| Alias (t, s) ->
58
59
if List.mem_assoc s map then raise Clash else Alias (type_expr map t, s)
+9
-2
src/xref2/link.ml
+9
-2
src/xref2/link.ml
···
712
712
and include_decl : Env.t -> Id.Signature.t -> Include.decl -> Include.decl =
713
713
fun env id decl ->
714
714
let open Include in
715
+
let rec is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
716
+
function
717
+
| Path _ -> false
718
+
| Signature _ -> true
719
+
| With (_, expr) -> is_elidable_with_u expr
720
+
| TypeOf _ -> false
721
+
in
715
722
match decl with
723
+
| ModuleType expr when is_elidable_with_u expr -> ModuleType expr
716
724
| ModuleType expr -> ModuleType (u_module_type_expr env id expr)
717
725
| Alias p -> Alias (module_path env p)
718
726
···
1187
1195
| e ->
1188
1196
Format.eprintf
1189
1197
"Caught unexpected exception when expanding type \
1190
-
declaration (%s)\n\
1191
-
%!"
1198
+
declaration (%s)@."
1192
1199
(Printexc.to_string e);
1193
1200
Constr (`Resolved p, ts))
1194
1201
| _ -> Constr (`Resolved p, ts)
+48
src/xref2/subst.ml
+48
src/xref2/subst.ml
···
29
29
unresolve_opaque_paths = false;
30
30
}
31
31
32
+
let pp fmt s =
33
+
let pp_map pp_binding b fmt map =
34
+
let pp_b fmt (id, v) =
35
+
Format.fprintf fmt "%a -> %a" Ident.fmt id pp_binding v
36
+
in
37
+
Format.fprintf fmt "@[<hov 1>{%a}@]" (Format.pp_print_list pp_b) (b map)
38
+
in
39
+
let pp_subst ppp fmt v =
40
+
Format.fprintf fmt "%s"
41
+
(match v with
42
+
| `Prefixed (p, _) -> Format.asprintf "%a" ppp p
43
+
| `Renamed id' -> Format.asprintf "%a" Ident.fmt id'
44
+
| `Substituted -> "<substituted>")
45
+
in
46
+
let pp_type_replacement fmt (te, eq) =
47
+
Format.fprintf fmt "(%a,%a)"
48
+
Component.Fmt.(type_expr default)
49
+
te
50
+
Component.Fmt.(type_equation default)
51
+
eq
52
+
in
53
+
54
+
Format.fprintf fmt
55
+
"{ module_ = %a;@ module_type = %a;@ type_ = %a;@ class_type = %a;@ \
56
+
type_replacement = %a;@ module_type_replacement = %a;@ \
57
+
path_invalidating_modules = [%a];@ unresolve_opaque_paths = %b }"
58
+
(pp_map (pp_subst Component.Fmt.(module_path default)) ModuleMap.bindings)
59
+
s.module_
60
+
(pp_map
61
+
(pp_subst Component.Fmt.(module_type_path default))
62
+
ModuleTypeMap.bindings)
63
+
s.module_type
64
+
(pp_map (pp_subst Component.Fmt.(type_path default)) TypeMap.bindings)
65
+
s.type_
66
+
(pp_map (pp_subst Component.Fmt.(class_type_path default)) TypeMap.bindings)
67
+
s.class_type
68
+
(pp_map pp_type_replacement TypeMap.bindings)
69
+
s.type_replacement
70
+
(pp_map Component.Fmt.(module_type_expr default) ModuleTypeMap.bindings)
71
+
s.module_type_replacement
72
+
(Format.pp_print_list Ident.fmt)
73
+
s.path_invalidating_modules s.unresolve_opaque_paths
74
+
32
75
let unresolve_opaque_paths s = { s with unresolve_opaque_paths = true }
33
76
34
77
let path_invalidate_module id t =
···
563
606
| Any -> acc
564
607
| Var (n, _) -> (n, type_expr s pexpr) :: acc
565
608
in
609
+
if List.length ts <> List.length eq.params then (
610
+
Format.eprintf
611
+
"Type substitution error: eq.params length=%d ts length=%d@."
612
+
(List.length eq.params) (List.length ts);
613
+
assert false);
566
614
let vars = List.fold_left2 mk_var [] ts eq.params in
567
615
substitute_vars vars t
568
616
| Not_replaced p -> Constr (p, List.map (type_expr s) ts))
+2
src/xref2/subst.mli
+2
src/xref2/subst.mli
+65
src/xref2/tools.ml
+65
src/xref2/tools.ml
···
2350
2350
2351
2351
let resolve_class_type_path env p =
2352
2352
resolve_class_type env p >>= fun (p, _) -> Ok p
2353
+
2354
+
let apply_inner_substs env (sg : Component.Signature.t) : Component.Signature.t
2355
+
=
2356
+
let rec inner (items : Component.Signature.item list) :
2357
+
Component.Signature.item list =
2358
+
match items with
2359
+
| Component.Signature.TypeSubstitution (id, typedecl) :: rest -> (
2360
+
let subst =
2361
+
Component.ModuleType.TypeSubst
2362
+
(`Dot (`Root, Ident.Name.type_ id), typedecl.equation)
2363
+
in
2364
+
let rest =
2365
+
Component.Signature.Type
2366
+
(id, Ordinary, Component.Delayed.put (fun () -> typedecl))
2367
+
:: inner rest
2368
+
in
2369
+
match fragmap env subst { sg with items = rest } with
2370
+
| Ok sg' -> sg'.items
2371
+
| Error _ -> failwith "error")
2372
+
| Component.Signature.ModuleSubstitution (id, modsubst) :: rest -> (
2373
+
let subst =
2374
+
Component.ModuleType.ModuleSubst
2375
+
(`Dot (`Root, Ident.Name.module_ id), modsubst.manifest)
2376
+
in
2377
+
let rest =
2378
+
Component.Signature.Module
2379
+
( id,
2380
+
Ordinary,
2381
+
Component.Delayed.put (fun () ->
2382
+
{
2383
+
Component.Module.source_loc = None;
2384
+
doc = modsubst.doc;
2385
+
type_ = Alias (modsubst.manifest, None);
2386
+
canonical = None;
2387
+
hidden = false;
2388
+
}) )
2389
+
:: inner rest
2390
+
in
2391
+
match fragmap env subst { sg with items = rest } with
2392
+
| Ok sg' -> sg'.items
2393
+
| Error _ -> failwith "error")
2394
+
| Component.Signature.ModuleTypeSubstitution (id, modtypesubst) :: rest -> (
2395
+
let subst =
2396
+
Component.ModuleType.ModuleTypeSubst
2397
+
(`Dot (`Root, Ident.Name.module_type id), modtypesubst.manifest)
2398
+
in
2399
+
let rest =
2400
+
Component.Signature.ModuleType
2401
+
( id,
2402
+
Component.Delayed.put (fun () ->
2403
+
{
2404
+
Component.ModuleType.source_loc = None;
2405
+
doc = modtypesubst.doc;
2406
+
expr = Some modtypesubst.manifest;
2407
+
canonical = None;
2408
+
}) )
2409
+
:: inner rest
2410
+
in
2411
+
match fragmap env subst { sg with items = rest } with
2412
+
| Ok sg' -> sg'.items
2413
+
| Error _ -> failwith "error")
2414
+
| x :: rest -> x :: inner rest
2415
+
| [] -> []
2416
+
in
2417
+
{ sg with items = inner sg.items }
+2
src/xref2/tools.mli
+2
src/xref2/tools.mli
+6
-3
test/xref2/expansion.t/run.t
+6
-3
test/xref2/expansion.t/run.t
···
20
20
module S :
21
21
sig
22
22
module type X = sig module M : sig type t end end
23
-
module X : X with M.t = int (sig : module M : sig type t = int end end)
23
+
module X : X with M.t(params ) = int
24
+
(sig : module M : sig type t = int end end)
24
25
module Y : sig type t end
25
26
module Z : module type of Y (sig : type t end)
26
27
module A : X (sig : module M : sig type t end end)
···
33
34
module S :
34
35
sig
35
36
module type X = sig module M : sig type t end end
36
-
module X : X with M.t = int (sig : module M : sig type t = int end end)
37
+
module X : X with M.t(params ) = int
38
+
(sig : module M : sig type t = int end end)
37
39
module Y : sig type t end
38
40
module Z : module type of Y (sig : type t end)
39
41
module A : X (sig : module M : sig type t end end)
···
42
44
module Test = S
43
45
(sig :
44
46
module type X = sig module M : sig type t end end
45
-
module X : X with M.t = int (sig : module M : sig type t = int end end)
47
+
module X : X with M.t(params ) = int
48
+
(sig : module M : sig type t = int end end)
46
49
module Y : sig type t end
47
50
module Z : module type of Y (sig : type t end)
48
51
module A : X (sig : module M : sig type t end end)
+61
test/xref2/github_issue_930.t/edge_cases.mli
+61
test/xref2/github_issue_930.t/edge_cases.mli
···
1
+
(** Edge case tests for GitHub issue #930 *)
2
+
3
+
(** Multiple TypeSubstitutions in same signature *)
4
+
module type Multi_subst = sig
5
+
type 'a t := unit
6
+
type 'b u := int
7
+
8
+
val f : bool t
9
+
val g : string u
10
+
end
11
+
12
+
(** Deeply nested includes - 5 levels deep *)
13
+
module type Level1 = sig
14
+
type 'a t := unit
15
+
val x : int t
16
+
end
17
+
18
+
module type Level2 = sig
19
+
type t
20
+
include Level1
21
+
end
22
+
23
+
module type Level3 = sig
24
+
include Level2
25
+
end
26
+
27
+
module type Level4 = sig
28
+
include Level3
29
+
end
30
+
31
+
module type Level5 = sig
32
+
include Level4
33
+
end
34
+
35
+
(** Multiple paths to same signature *)
36
+
module type Multipath_base = sig
37
+
type 'a t := unit
38
+
val x : int t
39
+
end
40
+
41
+
module type Multipath_via_a = sig
42
+
include Multipath_base
43
+
end
44
+
45
+
module type Multipath_via_b = sig
46
+
include Multipath_base
47
+
end
48
+
49
+
module type Multipath_use1 = sig
50
+
include Multipath_via_a
51
+
end
52
+
53
+
module type Multipath_use2 = sig
54
+
include Multipath_via_b
55
+
end
56
+
57
+
(** TypeSubstitution with record field types *)
58
+
module type With_record = sig
59
+
type 'a t := unit
60
+
type r = { field : int t }
61
+
end
+90
-5
test/xref2/github_issue_930.t/run.t
+90
-5
test/xref2/github_issue_930.t/run.t
···
1
1
Test for GitHub issue #930: Crash when substituting for the same name at different arities.
2
2
3
-
This test demonstrates that odoc crashes on the MWE. The fix will update this test
4
-
to show correct behavior.
3
+
This tests that inline TypeSubstitution items (type 'a t := unit) are correctly
4
+
applied during include expansion, preventing crashes and producing correct output.
5
5
6
6
$ ocamlc -c -bin-annot test.mli
7
+
$ ocamlc -c -bin-annot edge_cases.mli
8
+
9
+
Compile and link both test files:
10
+
11
+
$ odoc compile test.cmti
12
+
$ odoc compile edge_cases.cmti
13
+
$ odoc link test.odoc
14
+
$ odoc link edge_cases.odoc
15
+
16
+
=== Test 1: Original MWE from issue #930 ===
17
+
18
+
The key test is that odoc doesn't crash with "Invalid_argument(List.fold_left2)".
19
+
Check that includes work correctly - the TypeSubstitution is applied when
20
+
S1 is included in S2 and S2 is included in S3:
21
+
22
+
$ odoc_print test.odocl -r S2.x | jq -c '.type_.Constr[0]'
23
+
{"`Resolved":{"`CoreType":"unit"}}
24
+
25
+
$ odoc_print test.odocl -r S3.x | jq -c '.type_.Constr[0]'
26
+
{"`Resolved":{"`CoreType":"unit"}}
7
27
8
-
Without the fix, odoc compile crashes with Invalid_argument("List.fold_left2"):
28
+
=== Test 2: Issue #1385 - Creators_base with nested types ===
29
+
30
+
Check that S0_with_creators_base compiles without crashing and has the
31
+
concat function with simplified types (t -> t):
32
+
33
+
$ odoc_print test.odocl -r S0_with_creators_base.concat | jq -c '.type_.Arrow[1].Constr[0]'
34
+
{"`Resolved":{"`Identifier":{"`Type":[{"`ModuleType":[{"`Root":["None","Test"]},"S0_with_creators_base"]},"t"]}}}
35
+
36
+
$ odoc_print test.odocl -r S0_with_creators_base.concat | jq -c '.type_.Arrow[2].Constr[0]'
37
+
{"`Resolved":{"`Identifier":{"`Type":[{"`ModuleType":[{"`Root":["None","Test"]},"S0_with_creators_base"]},"t"]}}}
38
+
39
+
=== Test 3: Deeply nested includes ===
40
+
41
+
Level5 goes through 5 levels of includes with TypeSubstitution at Level1.
42
+
The substitution should be applied correctly through all levels:
43
+
44
+
$ odoc_print edge_cases.odocl -r Level5.x | jq -c '.type_.Constr[0]'
45
+
{"`Resolved":{"`CoreType":"unit"}}
46
+
47
+
=== Test 4: Multiple paths to same signature ===
48
+
49
+
Multipath_use1 and Multipath_use2 both include variations of Multipath_base:
50
+
51
+
$ odoc_print edge_cases.odocl -r Multipath_use1.x | jq -c '.type_.Constr[0]'
52
+
{"`Resolved":{"`CoreType":"unit"}}
53
+
54
+
$ odoc_print edge_cases.odocl -r Multipath_use2.x | jq -c '.type_.Constr[0]'
55
+
{"`Resolved":{"`CoreType":"unit"}}
56
+
57
+
=== Test 5: Verify HTML generation succeeds and shows correct types ===
58
+
59
+
$ odoc html-generate test.odocl -o html --indent
60
+
$ odoc html-generate edge_cases.odocl -o html --indent
61
+
62
+
S2.x should show "unit" (TypeSubstitution applied through include of S1):
63
+
64
+
$ grep "val.*x" html/Test/module-type-S2/index.html | sed 's/<[^>]*>//g' | grep -o "val x.*" | head -1
65
+
val x : unit
66
+
67
+
S3.x should show "unit" (TypeSubstitution applied through include of S2):
68
+
69
+
$ grep "val.*x" html/Test/module-type-S3/index.html | sed 's/<[^>]*>//g' | grep -o "val x.*" | head -1
70
+
val x : unit
71
+
72
+
Level5.x should show "unit" after 5 levels of nested includes:
73
+
74
+
$ grep "val.*x" html/Edge_cases/module-type-Level5/index.html | sed 's/<[^>]*>//g' | grep -o "val x.*" | head -1
75
+
val x : unit
76
+
77
+
=== Test 6: Verify TypeSubstitutions in includes are correctly applied ===
78
+
79
+
In S2 and S3, the TypeSubstitution from S1 should be applied (not shown as "type subst"):
80
+
81
+
$ grep -c "type subst" html/Test/module-type-S2/index.html 2>/dev/null || true
82
+
0
83
+
84
+
$ grep -c "type subst" html/Test/module-type-S3/index.html 2>/dev/null || true
85
+
0
86
+
87
+
Level5 should have no TypeSubstitution visible (applied through nested includes):
88
+
89
+
$ grep -c "type subst" html/Edge_cases/module-type-Level5/index.html 2>/dev/null || true
90
+
0
91
+
92
+
Note: S1 still shows its TypeSubstitution declaration because that's where it's defined.
93
+
This is expected - the substitution is only applied when the signature is included:
9
94
10
-
$ odoc compile test.cmti 2>&1 | grep -o 'Invalid_argument("[^"]*")'
11
-
Invalid_argument("List.fold_left2")
95
+
$ grep -c "type subst" html/Test/module-type-S1/index.html
96
+
1
+15
-29
test/xref2/shadow3.t/run.t
+15
-29
test/xref2/shadow3.t/run.t
···
18
18
module type {B}1/shadowed/(CCCC) = A.B
19
19
include {B}1/shadowed/(CCCC)
20
20
(sig : module {A}1/shadowed/(AAAA) = A.A end)
21
-
module type B1 :=
22
-
sig
23
-
module A :
24
-
sig
25
-
include module type of struct include {A}1/shadowed/(AAAA) end
26
-
(sig :
27
-
include module type of struct include A.{A}1/shadowed/(AAAA) end
28
-
(sig : type t = {A}1/shadowed/(AAAA).t end)
29
-
type a = A.A.a
30
-
end)
31
-
type a
32
-
end
33
-
end
34
-
include B1 (sig : module {A}2/shadowed/(CCCC) = A.A end)
21
+
include sig
22
+
module A :
23
+
sig
24
+
include module type of struct include {A}1/shadowed/(AAAA) end
25
+
(sig : type t end)
26
+
type a
27
+
endend (sig : module {A}2/shadowed/(CCCC) = A.A end)
35
28
end)
36
29
include module type of struct include B end
37
30
(sig :
38
31
module type B = B.B
39
32
include B (sig : module {A}1/shadowed/(BBBB) = B.A end)
40
-
module type B1 :=
41
-
sig
42
-
module A :
43
-
sig
44
-
include module type of struct include {A}1/shadowed/(BBBB) end
45
-
(sig :
46
-
include module type of struct include B.{A}1/shadowed/(BBBB) end
47
-
(sig : type t = {A}1/shadowed/(BBBB).t end)
48
-
type b = B.A.b
49
-
end)
50
-
type b
51
-
end
52
-
end
53
-
include B1 (sig : module {A}3/shadowed/(CCCC) = B.A end)
33
+
include sig
34
+
module A :
35
+
sig
36
+
include module type of struct include {A}1/shadowed/(BBBB) end
37
+
(sig : type t end)
38
+
type b
39
+
endend (sig : module {A}3/shadowed/(CCCC) = B.A end)
54
40
end)
55
41
module A :
56
42
sig
57
43
include module type of struct include {A}3/shadowed/(CCCC) end
58
44
(sig :
59
45
include module type of struct include B.{A}1/shadowed/(BBBB) end
60
-
(sig : type t = {A}3/shadowed/(CCCC).t end)
46
+
(sig : type t = B.A.t end)
61
47
type b = B.A.b
62
48
end)
63
49
end
+11
-5
test/xref2/shadow5.t/run.t
+11
-5
test/xref2/shadow5.t/run.t
···
33
33
type t = int
34
34
val y : t
35
35
include sigtype t = t
36
-
val z : tend with [t = t] (sig : val z : t end)
36
+
val z : tend with [t(params ) = t] (sig : val z : t end)
37
37
end
38
38
module type Z =
39
39
sig
···
41
41
(sig :
42
42
type {t}1/shadowed/(AAAA) = int
43
43
val y : int
44
-
include sigtype t = t
45
-
val z : tend with [t = int] (sig : val z : int end)
44
+
include sig
45
+
type t = t
46
+
val z : tend with [t(params ) = {t}1/shadowed/(AAAA)]
47
+
(sig : val z : int end)
46
48
end)
47
49
type t = int
48
50
end
···
76
78
$ odoc_print b.odocl --short --show-include-expansions
77
79
module type X = sig type t val z : t end
78
80
module type Y =
79
-
sig type t = int val y : t include X with [t = t] (sig : val z : t end) end
81
+
sig
82
+
type t = int
83
+
val y : t
84
+
include X with [t(params ) = t] (sig : val z : t end)
85
+
end
80
86
module type Z =
81
87
sig
82
88
include Y
83
89
(sig :
84
90
type {t}1/shadowed/(BBBB) = int
85
91
val y : int
86
-
include X with [t = int] (sig : val z : int end)
92
+
include X with [t(params ) = int] (sig : val z : int end)
87
93
end)
88
94
type t = int
89
95
end