Fix soundness bug in include functor

testsuite/tests/typing-modules/include_functor_is_expansive.ml

@@ -0,0 +1,77 @@
+(* TEST
+ flags = "-extension include_functor -w +a";
+ expect;
+*)
+
+(* This is a regression test.  The include functor version of the below program
+   used to typecheck - we check here it gets the same error as the
+   non-include-functor version. *)
+
+module type T = sig
+  type t
+end
+
+module Ref (A : T) : sig
+  val r : A.t option ref
+end = struct
+  let r = ref None
+end;;
+[%%expect{|
+module type T = sig type t end
+module Ref : functor (A : T) -> sig val r : A.t option ref end
+|}]
+
+
+(* Legacy version *)
+let r (type a) =
+  let module R = struct
+    module T = struct
+      type t = a
+    end
+
+    include Ref(T)
+  end
+  in
+  R.r
+;;
+
+let magic (type a b) (a : a) : b =
+  r := Some a;
+  match !r with
+  | Some r -> r
+  | None -> assert false
+;;
+[%%expect{|
+val r : '_a option ref = {contents = None}
+Line 14, characters 12-13:
+14 |   r := Some a;
+                 ^
+Error: This expression has type "a" but an expression was expected of type "'a"
+       The type constructor "a" would escape its scope
+|}]
+
+(* Include functor version *)
+let r (type a) =
+  let module R = struct
+    type t = a
+
+    include functor Ref
+  end
+  in
+  R.r
+;;
+
+let magic (type a b) (a : a) : b =
+  r := Some a;
+  match !r with
+  | Some r -> r
+  | None -> assert false
+;;
+[%%expect{|
+val r : '_a option ref = {contents = None}
+Line 12, characters 12-13:
+12 |   r := Some a;
+                 ^
+Error: This expression has type "a" but an expression was expected of type "'a"
+       The type constructor "a" would escape its scope
+|}]

typing/typecore.ml

@@ -4230,8 +4230,12 @@ and is_nonexpansive_mod mexp =
           | Tstr_value (_, pat_exp_list) ->
               List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
           | Tstr_module {mb_expr=m;_}
-          | Tstr_open {open_expr=m;_}
-          | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
+          | Tstr_open {open_expr=m;_} -> is_nonexpansive_mod m
+          | Tstr_include {incl_mod=m;incl_kind=k;_} ->
+            begin match k with
+            | Tincl_structure -> is_nonexpansive_mod m
+            | Tincl_functor _ | Tincl_gen_functor _ -> false
+            end
           | Tstr_recmodule id_mod_list ->
               List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
                 id_mod_list