diff options
author | Chris Casinghino <ccasinghino@janestreet.com> | 2022-12-01 01:31:40 -0500 |
---|---|---|
committer | Florian Angeletti <florian.angeletti@inria.fr> | 2022-12-01 11:13:52 +0100 |
commit | b2b74bf07937b635897210674dcf2ca3e5759d46 (patch) | |
tree | 069d3d853472aed8d9082515c861db7e63fdf43e | |
parent | bc510ed522f2f755e3952677feb8578899b8eb33 (diff) | |
download | ocaml-b2b74bf07937b635897210674dcf2ca3e5759d46.tar.gz |
Fix bug in `Mtype.strengthen_lazy` causing spurious typing errors (#11776)
(cherry picked from commit 4243c4b26d2bdcc02d00a6f0b5de7df909788ee2)
-rw-r--r-- | Changes | 3 | ||||
-rw-r--r-- | testsuite/tests/typing-modules/functors.ml | 44 | ||||
-rw-r--r-- | typing/env.ml | 8 | ||||
-rw-r--r-- | typing/env.mli | 2 | ||||
-rw-r--r-- | typing/mtype.ml | 3 |
5 files changed, 60 insertions, 0 deletions
@@ -75,6 +75,9 @@ OCaml 4.14 maintenance branch multiple threads. (Marc Lasson, Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp) +- #11776: Extend environment with functor parameters in `strengthen_lazy`. + (Chris Casinghino and Luke Maurer, review by Gabriel Scherer) + OCaml 4.14.0 (28 March 2022) ---------------------------- diff --git a/testsuite/tests/typing-modules/functors.ml b/testsuite/tests/typing-modules/functors.ml index 932bc9f9fc..3fa34a1d89 100644 --- a/testsuite/tests/typing-modules/functors.ml +++ b/testsuite/tests/typing-modules/functors.ml @@ -1701,3 +1701,47 @@ Error: The functor application Bar(A)(FiveArgsExt)(TY)(TY)(TY)(TY)(TY) is ill-ty 8. Module TY matches the expected module type ty 9. Module TY matches the expected module type ty |}] + +module Shape_arg = struct + module M1 (Arg1 : sig end) = struct + module type S1 = sig + type t + end + end + + module type S2 = sig + module Make (Arg2 : sig end) : M1(Arg2).S1 + end + + module M2 : S2 = struct + module Make (Arg3 : sig end) = struct + type t = T + end + end + + module M3 (Arg4 : sig end) = struct + module type S3 = sig + type t = M2.Make(Arg4).t + end + end + + module M4 (Arg5 : sig end) : M3(Arg5).S3 = struct + module M5 = M2.Make (Arg5) + + type t = M5.t + end +end +[%%expect{| +module Shape_arg : + sig + module M1 : + functor (Arg1 : sig end) -> sig module type S1 = sig type t end end + module type S2 = + sig module Make : functor (Arg2 : sig end) -> M1(Arg2).S1 end + module M2 : S2 + module M3 : + functor (Arg4 : sig end) -> + sig module type S3 = sig type t = M2.Make(Arg4).t end end + module M4 : functor (Arg5 : sig end) -> M3(Arg5).S3 + end +|}] diff --git a/typing/env.ml b/typing/env.ml index 29d7cdb0e4..6e324888da 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -2223,6 +2223,14 @@ and add_cltype ?shape id ty env = let add_module ?arg ?shape id presence mty env = add_module_declaration ~check:false ?arg ?shape id presence (md mty) env +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env + let add_local_type path info env = { env with local_constraints = Path.Map.add path info env.local_constraints } diff --git a/typing/env.mli b/typing/env.mli index 55ab3a5b6f..49040b83cb 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -289,6 +289,8 @@ val add_extension: check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t val add_module: ?arg:bool -> ?shape:Shape.t -> Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> Ident.t -> module_presence -> module_declaration -> t -> t val add_module_declaration_lazy: update_summary:bool -> diff --git a/typing/mtype.ml b/typing/mtype.ml index d649bcdc87..f6aba79222 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -46,6 +46,9 @@ let rec strengthen_lazy ~aliasable env mty p = MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) | MtyL_functor(Named (Some param, arg), res) when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in MtyL_functor(Named (Some param, arg), strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) | MtyL_functor(Named (None, arg), res) |