Skip to content

Commit ef2d35e

Browse files
gaschegasche
committed
Merge pull request #9642 from garrigue/fix9640
Fix #9640: regression introduced by #9623 (cherry picked from commit 357d624)
1 parent e69df58 commit ef2d35e

3 files changed

Lines changed: 127 additions & 36 deletions

File tree

‎Changes‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -474,7 +474,7 @@ OCaml 4.11
474474
on Power and Z System
475475
(Xavier Leroy, review by Nicolás Ojeda Bär)
476476

477-
- #9623: fix typing environments in Typedecl.transl_with_constraint
477+
- #9623, #9642: fix typing environments in Typedecl.transl_with_constraint
478478
(Gabriel Scherer, review by Jacques Garrigue and Leo White,
479479
report by Hugo Heuzard)
480480

‎testsuite/tests/typing-modules/merge_constraint.ml‎

Lines changed: 95 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
(* TEST
22
* expect *)
33

4+
(* #9623 *)
5+
46
module RhsScopeCheck = struct
57
module type Sig1 = sig
68
type t
@@ -151,3 +153,96 @@ module CorrectEnvConstructionTest :
151153
end
152154
end
153155
|}]
156+
157+
(* #9640 *)
158+
159+
module type Packet_type = sig
160+
type t
161+
end
162+
module type Unpacked_header = sig
163+
module Packet_type : Packet_type
164+
type t
165+
val f : t -> Packet_type.t -> unit
166+
end
167+
module type Header = sig
168+
module Packet_type : Packet_type
169+
module Unpacked : Unpacked_header with module Packet_type := Packet_type
170+
end
171+
module type S = sig
172+
module Packet_type : Packet_type
173+
module Header : Header with module Packet_type = Packet_type
174+
end
175+
[%%expect{|
176+
module type Packet_type = sig type t end
177+
module type Unpacked_header =
178+
sig
179+
module Packet_type : Packet_type
180+
type t
181+
val f : t -> Packet_type.t -> unit
182+
end
183+
module type Header =
184+
sig
185+
module Packet_type : Packet_type
186+
module Unpacked : sig type t val f : t -> Packet_type.t -> unit end
187+
end
188+
module type S =
189+
sig
190+
module Packet_type : Packet_type
191+
module Header :
192+
sig
193+
module Packet_type : sig type t = Packet_type.t end
194+
module Unpacked : sig type t val f : t -> Packet_type.t -> unit end
195+
end
196+
end
197+
|}]
198+
module type Iobuf_packet = sig
199+
module Make (Header : Header) () :
200+
S
201+
with module Packet_type = Header.Packet_type
202+
with module Header.Unpacked = Header.Unpacked
203+
end
204+
[%%expect{|
205+
module type Iobuf_packet =
206+
sig
207+
module Make :
208+
functor (Header : Header) () ->
209+
sig
210+
module Packet_type : sig type t = Header.Packet_type.t end
211+
module Header :
212+
sig
213+
module Packet_type : sig type t = Packet_type.t end
214+
module Unpacked :
215+
sig
216+
type t = Header.Unpacked.t
217+
val f : t -> Header.Packet_type.t -> unit
218+
end
219+
end
220+
end
221+
end
222+
|}]
223+
224+
(* Simpler example by @gasche *)
225+
module type S = sig
226+
type t
227+
type u = t
228+
end
229+
module type Pack = sig
230+
module M : S
231+
end
232+
[%%expect{|
233+
module type S = sig type t type u = t end
234+
module type Pack = sig module M : S end
235+
|}]
236+
module type Weird = sig
237+
module M : S
238+
module P : Pack
239+
with type M.t = M.t
240+
with type M.u = M.u
241+
end
242+
[%%expect{|
243+
module type Weird =
244+
sig
245+
module M : S
246+
module P : sig module M : sig type t = M.t type u = M.u end end
247+
end
248+
|}]

‎typing/typemod.ml‎

Lines changed: 31 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -459,8 +459,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
459459
| Pwith_typesubst _ | Pwith_modsubst _ -> true
460460
in
461461
let real_ids = ref [] in
462-
let sig_env = Env.add_signature sg initial_env in
463-
let rec merge sg namelist row_id =
462+
let rec merge sig_env sg namelist row_id =
464463
match (sg, namelist, constr) with
465464
([], _, _) ->
466465
raise(Error(loc, sig_env, With_no_component lid.txt))
@@ -513,30 +512,26 @@ let merge_constraint initial_env remove_aliases loc sg constr =
513512
Sig_type(id_row, decl_row, rs', priv)
514513
:: Sig_type(id, newdecl, rs, priv)
515514
:: rem
516-
| (Sig_type(id, sig_decl, rs, priv) :: rem , [s], Pwith_type (_, sdecl))
515+
| (Sig_type(id, sig_decl, rs, priv) :: rem , [s],
516+
(Pwith_type (_, sdecl) | Pwith_typesubst (_, sdecl) as constr))
517517
when Ident.name id = s ->
518518
let tdecl =
519519
Typedecl.transl_with_constraint id None
520520
~sig_env ~sig_decl ~outer_env:initial_env sdecl in
521-
let newdecl = tdecl.typ_type in
522-
let loc = sdecl.ptype_loc in
521+
let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in
523522
check_type_decl sig_env loc id row_id newdecl sig_decl rs rem;
524-
(Pident id, lid, Twith_type tdecl),
525-
Sig_type(id, newdecl, rs, priv) :: rem
523+
begin match constr with
524+
Pwith_type _ ->
525+
(Pident id, lid, Twith_type tdecl),
526+
Sig_type(id, newdecl, rs, priv) :: rem
527+
| (* Pwith_typesubst *) _ ->
528+
real_ids := [Pident id];
529+
(Pident id, lid, Twith_typesubst tdecl),
530+
update_rec_next rs rem
531+
end
526532
| (Sig_type(id, _, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
527533
when Ident.name id = s ^ "#row" ->
528-
merge rem namelist (Some id)
529-
| (Sig_type(id, decl, rs, _priv) :: rem, [s], Pwith_typesubst (_, sdecl))
530-
when Ident.name id = s ->
531-
(* Check as for a normal with constraint, but discard definition *)
532-
let tdecl =
533-
Typedecl.transl_with_constraint id None
534-
~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in
535-
let newdecl = tdecl.typ_type in
536-
check_type_decl sig_env sdecl.ptype_loc id row_id newdecl decl rs rem;
537-
real_ids := [Pident id];
538-
(Pident id, lid, Twith_typesubst tdecl),
539-
update_rec_next rs rem
534+
merge sig_env rem namelist (Some id)
540535
| (Sig_module(id, pres, md, rs, priv) :: rem, [s], Pwith_module (_, lid'))
541536
when Ident.name id = s ->
542537
let path, md' = Env.lookup_module ~loc lid'.txt initial_env in
@@ -557,34 +552,35 @@ let merge_constraint initial_env remove_aliases loc sg constr =
557552
real_ids := [Pident id];
558553
(Pident id, lid, Twith_modsubst (path, lid')),
559554
update_rec_next rs rem
560-
| (Sig_module(id, _, ({md_type = Mty_alias _} as md), _, _) as item :: rem,
561-
s :: namelist, (Pwith_module _ | Pwith_type _))
555+
| (Sig_module(id, _, md, rs, priv) as item :: rem, s :: namelist, constr)
562556
when Ident.name id = s ->
563-
let ((path, _, tcstr), _) =
564-
merge (extract_sig sig_env loc md.md_type) namelist None
565-
in
557+
let sg = extract_sig sig_env loc md.md_type in
558+
let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in
566559
let path = path_concat id path in
567560
real_ids := path :: !real_ids;
568-
(path, lid, tcstr), item :: rem
569-
| (Sig_module(id, _, md, rs, priv) :: rem, s :: namelist, _)
570-
when Ident.name id = s ->
571-
let ((path, _path_loc, tcstr), newsg) =
572-
merge (extract_sig sig_env loc md.md_type) namelist None
561+
let item =
562+
match md.md_type, constr with
563+
Mty_alias _, (Pwith_module _ | Pwith_type _) ->
564+
(* A module alias cannot be refined, so keep it
565+
and just check that the constraint is correct *)
566+
item
567+
| _ ->
568+
let newmd = {md with md_type = Mty_signature newsg} in
569+
Sig_module(id, Mp_present, newmd, rs, priv)
573570
in
574-
let path = path_concat id path in
575-
real_ids := path :: !real_ids;
576-
let newmd = {md with md_type=Mty_signature newsg} in
577-
let item = Sig_module(id, Mp_present, newmd, rs, priv) in
578571
(path, lid, tcstr),
579572
item :: rem
580573
| (item :: rem, _, _) ->
581-
let (cstr, items) = merge rem namelist row_id
574+
let (cstr, items) = merge sig_env rem namelist row_id
582575
in
583576
cstr, item :: items
577+
and merge_signature env sg namelist =
578+
let sig_env = Env.add_signature sg env in
579+
merge sig_env sg namelist None
584580
in
585581
try
586582
let names = Longident.flatten lid.txt in
587-
let (tcstr, sg) = merge sg names None in
583+
let (tcstr, sg) = merge_signature initial_env sg names in
588584
if destructive_substitution then (
589585
match List.rev !real_ids with
590586
| [] -> assert false

0 commit comments

Comments
 (0)