diff --git a/Changes b/Changes index a8dc05591..3fa0364ab 100644 --- a/Changes +++ b/Changes @@ -554,6 +554,9 @@ Working version - #9848, #9855: Fix double free of bytecode in toplevel (Stephen Dolan, report by Sampsa Kiiskinen, review by Gabriel Scherer) +- #9858, #9861: Compiler fails with Ctype.Nondep_cannot_erase exception + (Thomas Refis, report by @pveber, review by Florian Angeletti) + - #9860: wrong range constraint for subtract immediate on zSystems / s390x (Xavier Leroy, review by Stephen Dolan) diff --git a/testsuite/tests/typing-fstclassmod/nondep_instance.ml b/testsuite/tests/typing-fstclassmod/nondep_instance.ml new file mode 100644 index 000000000..34f37b1c8 --- /dev/null +++ b/testsuite/tests/typing-fstclassmod/nondep_instance.ml @@ -0,0 +1,51 @@ +(* TEST + * expect *) + +module type Vector_space = sig + type t + type scalar + val scale : scalar -> t -> t +end;; +[%%expect{| +module type Vector_space = + sig type t type scalar val scale : scalar -> t -> t end +|}];; + +module type Scalar = sig + type t + include Vector_space with type t := t + and type scalar = t +end;; +[%%expect{| +module type Scalar = + sig type t type scalar = t val scale : scalar -> t -> t end +|}];; + +module type Linear_map = sig + type ('a, 'b) t + val scale : + (module Vector_space with type t = 'a and type scalar = 'l) -> + 'l -> ('a, 'a) t +end;; +[%%expect{| +module type Linear_map = + sig + type ('a, 'b) t + val scale : + (module Vector_space with type scalar = 'l and type t = 'a) -> + 'l -> ('a, 'a) t + end +|}];; + +module Primitive(Linear_map : Linear_map) = struct + let f (type s) (s : (module Scalar with type t = s)) x = + Linear_map.scale s x +end;; +[%%expect{| +Line 3, characters 21-22: +3 | Linear_map.scale s x + ^ +Error: This expression has type (module Scalar with type t = s) + but an expression was expected of type + (module Vector_space with type scalar = 'a and type t = 'b) +|}];; diff --git a/typing/ctype.ml b/typing/ctype.ml index 2202632fa..a4e41966f 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2484,6 +2484,8 @@ let eq_package_path env p1 p2 = let nondep_type' = ref (fun _ _ _ -> assert false) let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false) +exception Nondep_cannot_erase of Ident.t + let rec concat_longident lid1 = let open Longident in function @@ -2525,7 +2527,14 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = match Env.find_type_by_name lid env' with | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = Some t2}) -> - (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 + begin match nondep_instance env' lv2 id2 t2 with + | t -> (n, t) :: complete nl ntl2 + | exception Nondep_cannot_erase _ -> + if allow_absent then + complete nl ntl2 + else + raise Exit + end | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = None}) when allow_absent -> @@ -4618,8 +4627,6 @@ let nondep_variants = TypeHash.create 17 let clear_hash () = TypeHash.clear nondep_hash; TypeHash.clear nondep_variants -exception Nondep_cannot_erase of Ident.t - let rec nondep_type_rec ?(expand_private=false) env ids ty = let expand_abbrev env t = if expand_private then expand_abbrev_opt env t else expand_abbrev env t