Add -as-argument-for parameter (#2177)

Add the ability to compile a module declaring that it is suitable to pass as the argument to a module taking a given parameter. Essentially the module is now checked against two different signatures (its own .mli and the parameter, which of course must be a supertype).

Author: lukemaurer

ocaml/driver/compile_common.ml

@@ -64,9 +64,7 @@ let typecheck_intf info ast =
   let tsg =
     ast
     |> Typemod.type_interface
-        ~sourcefile:info.source_file
-        info.module_name
-        info.env
+         ~sourcefile:info.source_file info.module_name info.env
     |> print_if info.ppf_dump Clflags.dump_typedtree Printtyped.interface
   in
   let sg = tsg.Typedtree.sig_type in
@@ -87,8 +85,14 @@ let emit_signature info ast tsg =
     let kind : Cmi_format.kind =
       if !Clflags.as_parameter then
         Parameter
-      else
-        Normal { cmi_impl = info.module_name }
+      else begin
+        let cmi_arg_for =
+          match !Clflags.as_argument_for with
+          | Some arg_type -> Some (Compilation_unit.Name.of_string arg_type)
+          | None -> None
+        in
+        Normal { cmi_impl = info.module_name; cmi_arg_for }
+      end
     in
     let alerts = Builtin_attributes.alerts_of_sig ast in
     Env.save_signature ~alerts tsg.Typedtree.sig_type

ocaml/driver/main_args.ml

@@ -659,6 +659,11 @@ let mk_as_parameter f =
   " Compiles the interface as a parameter for an open module."
 ;;
 
+let mk_as_argument_for f =
+  "-as-argument-for", Arg.String f,
+  "<module name> Compiles the module as an argument for the named parameter."
+;;
+
 let mk_use_prims f =
   "-use-prims", Arg.String f, "<file>  (undocumented)"
 
@@ -965,6 +970,7 @@ end
 module type Compiler_options = sig
   val _a : unit -> unit
   val _annot : unit -> unit
+  val _as_argument_for : string -> unit
   val _as_parameter : unit -> unit
   val _binannot : unit -> unit
   val _binannot_cms : unit -> unit
@@ -1165,6 +1171,7 @@ struct
     mk_absname F._absname;
     mk_no_absname F._no_absname;
     mk_annot F._annot;
+    mk_as_argument_for F._as_argument_for;
     mk_as_parameter F._as_parameter;
     mk_binannot F._binannot;
     mk_binannot_cms F._binannot_cms;
@@ -1383,6 +1390,7 @@ struct
     mk_afl_instrument F._afl_instrument;
     mk_afl_inst_ratio F._afl_inst_ratio;
     mk_annot F._annot;
+    mk_as_argument_for F._as_argument_for;
     mk_as_parameter F._as_parameter;
     mk_binannot F._binannot;
     mk_binannot_cms F._binannot_cms;
@@ -1970,6 +1978,7 @@ module Default = struct
     let _annot = set annotations
     let _args = Arg.read_arg
     let _args0 = Arg.read_arg0
+    let _as_argument_for s = as_argument_for := Some s
     let _as_parameter = set as_parameter
     let _binannot = set binary_annotations
     let _binannot_cms = set binary_annotations_cms

ocaml/driver/main_args.mli

@@ -88,6 +88,7 @@ end
 module type Compiler_options = sig
   val _a : unit -> unit
   val _annot : unit -> unit
+  val _as_argument_for : string -> unit
   val _as_parameter : unit -> unit
   val _binannot : unit -> unit
   val _binannot_cms : unit -> unit

ocaml/file_formats/cmi_format.ml

@@ -23,6 +23,7 @@ type pers_flags =
 type kind =
   | Normal of {
       cmi_impl : Compilation_unit.t;
+      cmi_arg_for : Compilation_unit.Name.t option;
     }
   | Parameter
 

ocaml/file_formats/cmi_format.mli

@@ -23,6 +23,7 @@ type pers_flags =
 type kind =
   | Normal of {
       cmi_impl : Compilation_unit.t;
+      cmi_arg_for : Compilation_unit.Name.t option;
     }
   | Parameter
 

ocaml/ocamldoc/odoc_analyse.ml

@@ -122,7 +122,9 @@ let process_interface_file sourcefile =
     Pparse.file ~tool_name inputfile
       (no_docstring Parse.interface) Pparse.Signature
   in
-  let sg = Typemod.type_interface ~sourcefile compilation_unit (initial_env()) ast in
+  let sg =
+    Typemod.type_interface ~sourcefile compilation_unit (initial_env()) ast
+  in
   Warnings.check_fatal ();
   (ast, sg, inputfile)
 

ocaml/testsuite/tests/templates/basic/bad_arg_impl.ml

@@ -0,0 +1,4 @@
+type t = unit
+
+let empty = ()
+let append () () = `Banana

ocaml/testsuite/tests/templates/basic/bad_arg_impl.reference

@@ -0,0 +1,12 @@
+File "bad_arg_impl.ml", line 1:
+Error: The argument module bad_arg_impl.ml
+       does not match the parameter signature monoid.cmi: 
+       Values do not match:
+         val append : unit -> unit -> [> `Banana ]
+       is not included in
+         val append : t -> t -> t
+       The type unit -> unit -> [> `Banana ] is not compatible with the type
+         t -> t -> t
+       Type [> `Banana ] is not compatible with type t = unit
+       File "monoid.mli", line 4, characters 0-24: Expected declaration
+       File "bad_arg_impl.ml", line 4, characters 4-10: Actual declaration

ocaml/testsuite/tests/templates/basic/bad_arg_intf.mli

@@ -0,0 +1,4 @@
+type t
+
+val empty : t
+val append : t -> t -> [ `Banana ]

ocaml/testsuite/tests/templates/basic/bad_arg_intf.reference

@@ -0,0 +1,12 @@
+File "bad_arg_intf.mli", line 1:
+Error: The argument module bad_arg_intf.mli
+       does not match the parameter signature monoid.cmi: 
+       Values do not match:
+         val append : t -> t -> [ `Banana ]
+       is not included in
+         val append : t -> t -> t
+       The type t -> t -> [ `Banana ] is not compatible with the type
+         t -> t -> t
+       Type [ `Banana ] is not compatible with type t
+       File "monoid.mli", line 4, characters 0-24: Expected declaration
+       File "bad_arg_intf.mli", line 4, characters 0-34: Actual declaration

ocaml/testsuite/tests/templates/basic/string_monoid.ml

@@ -0,0 +1,4 @@
+type t = string
+
+let empty = ""
+let append = (^)

ocaml/testsuite/tests/templates/basic/string_monoid.mli

@@ -0,0 +1,4 @@
+type t = string
+
+val empty : t
+val append : t -> t -> t

ocaml/testsuite/tests/templates/basic/test.ml

@@ -1,13 +1,136 @@
 (* TEST
- readonly_files = "bad_ref_direct.ml bad_ref_direct.reference monoid.mli ";
- setup-ocamlc.byte-build-env;
- flags = "-as-parameter";
- module = "monoid.mli";
- ocamlc.byte;
- module = "bad_ref_direct.ml";
- compiler_output = "bad_ref_direct.output";
- ocamlc_byte_exit_status = "2";
- ocamlc.byte;
- compiler_reference = "bad_ref_direct.reference";
- check-ocamlc.byte-output;
+ readonly_files = "\
+   bad_arg_impl.ml bad_arg_impl.reference \
+   bad_arg_intf.mli bad_arg_intf.reference \
+   bad_ref_direct.ml bad_ref_direct.reference \
+   monoid.mli \
+   string_monoid.ml string_monoid.mli \
+   test_direct_access.ml test_direct_access.reference \
+ ";
+
+ {
+   setup-ocamlc.byte-build-env;
+
+   flags = "-as-parameter";
+   module = "monoid.mli";
+   ocamlc.byte;
+   {
+     flags = "";
+     module = "bad_ref_direct.ml";
+     compiler_output = "bad_ref_direct.output";
+     ocamlc_byte_exit_status = "2";
+     ocamlc.byte;
+
+     compiler_reference = "bad_ref_direct.reference";
+     check-ocamlc.byte-output;
+   }{
+     flags = "-as-argument-for Monoid";
+     module = "bad_arg_impl.ml";
+     compiler_output = "bad_arg_impl.output";
+     ocamlc_byte_exit_status = "2";
+     ocamlc.byte;
+
+     compiler_reference = "bad_arg_impl.reference";
+     check-ocamlc.byte-output;
+   }{
+     flags = "-as-argument-for Monoid";
+     module = "bad_arg_intf.mli";
+     compiler_output = "bad_arg_intf.output";
+     ocamlc_byte_exit_status = "2";
+     ocamlc.byte;
+
+     compiler_reference = "bad_arg_intf.reference";
+     check-ocamlc.byte-output;
+   }{
+     src = "string_monoid.ml";
+     dst = "string_monoid_no_mli.ml";
+     copy;
+
+     flags = "-as-argument-for Monoid";
+     module = "string_monoid_no_mli.ml string_monoid.mli string_monoid.ml";
+     ocamlc.byte;
+
+     flags = "";
+     module = "test_direct_access.ml";
+     ocamlc.byte;
+
+     flags = "";
+     program = "${test_build_directory}/test_direct_access.bc";
+     module = "";
+     all_modules = "\
+       string_monoid.cmo \
+       string_monoid_no_mli.cmo \
+       test_direct_access.cmo \
+     ";
+     ocamlc.byte;
+
+     output = "test_direct_access.output";
+     run;
+
+     reference = "test_direct_access.reference";
+     check-program-output;
+   }
+ }{
+   setup-ocamlopt.byte-build-env;
+
+   flags = "-as-parameter";
+   module = "monoid.mli";
+   ocamlopt.byte;
+   {
+     flags = "";
+     module = "bad_ref_direct.ml";
+     compiler_output = "bad_ref_direct.output";
+     ocamlopt_byte_exit_status = "2";
+     ocamlopt.byte;
+
+     compiler_reference = "bad_ref_direct.reference";
+     check-ocamlopt.byte-output;
+   }{
+     flags = "-as-argument-for Monoid";
+     module = "bad_arg_impl.ml";
+     compiler_output = "bad_arg_impl.output";
+     ocamlopt_byte_exit_status = "2";
+     ocamlopt.byte;
+
+     compiler_reference = "bad_arg_impl.reference";
+     check-ocamlopt.byte-output;
+   }{
+     flags = "-as-argument-for Monoid";
+     module = "bad_arg_intf.mli";
+     compiler_output = "bad_arg_intf.output";
+     ocamlopt_byte_exit_status = "2";
+     ocamlopt.byte;
+
+     compiler_reference = "bad_arg_intf.reference";
+     check-ocamlopt.byte-output;
+   }{
+     src = "string_monoid.ml";
+     dst = "string_monoid_no_mli.ml";
+     copy;
+
+     flags = "-as-argument-for Monoid";
+     module = "string_monoid_no_mli.ml string_monoid.mli string_monoid.ml";
+     ocamlopt.byte;
+
+     flags = "";
+     module = "test_direct_access.ml";
+     ocamlopt.byte;
+
+     flags = "";
+     program = "${test_build_directory}/test_direct_access.exe";
+     module = "";
+     all_modules = "\
+       string_monoid.cmx \
+       string_monoid_no_mli.cmx \
+       test_direct_access.cmx \
+     ";
+     ocamlopt.byte;
+
+     output = "test_direct_access.output";
+     run;
+
+     reference = "test_direct_access.reference";
+     check-program-output;
+   }
+ }
 *)

ocaml/testsuite/tests/templates/basic/test_direct_access.ml

@@ -0,0 +1,5 @@
+let () =
+  let open Printf in
+  printf "With .mli: %s\n" (String_monoid.append "Hello " "world!");
+  printf "Without .mli: %s\n" (String_monoid_no_mli.append "Hello " "world!");
+  ()

ocaml/testsuite/tests/templates/basic/test_direct_access.reference

@@ -0,0 +1,2 @@
+With .mli: Hello world!
+Without .mli: Hello world!

ocaml/typing/env.ml

@@ -1015,7 +1015,10 @@ let register_import_as_opaque modname =
   Persistent_env.register_import_as_opaque !persistent_env modname
 
 let is_parameter_unit modname =
-  Persistent_env.is_registered_parameter_import !persistent_env modname
+  Persistent_env.is_parameter_import !persistent_env modname
+
+let implemented_parameter modname =
+  Persistent_env.implemented_parameter !persistent_env modname
 
 let reset_declaration_caches () =
   Types.Uid.Tbl.clear !value_declarations;
@@ -2639,6 +2642,9 @@ let read_signature modname filename ~add_binding =
   let mty = read_pers_mod modname filename ~add_binding in
   Subst.Lazy.force_signature mty
 
+let register_parameter_import import =
+  Persistent_env.register_parameter_import !persistent_env import
+
 let is_identchar_latin1 = function
   | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
   | '\248'..'\255' | '\'' | '0'..'9' -> true

ocaml/typing/env.mli

@@ -477,6 +477,9 @@ val save_signature_with_imports:
         (* Arguments: signature, module name, module kind,
            file name, imported units with their CRCs. *)
 
+(* Register a module as a parameter to this unit. *)
+val register_parameter_import: Compilation_unit.Name.t -> unit
+
 (* Return the CRC of the interface of the given compilation unit *)
 val crc_of_unit: Compilation_unit.Name.t -> Digest.t
 
@@ -496,6 +499,11 @@ val register_import_as_opaque: Compilation_unit.Name.t -> unit
    -as-parameter *)
 val is_parameter_unit: Compilation_unit.Name.t -> bool
 
+(* [implemented_parameter md] is the argument given to -as-argument-for when
+   [md] was compiled *)
+val implemented_parameter:
+  Compilation_unit.Name.t -> Compilation_unit.Name.t option
+
 (* Summaries -- compact representation of an environment, to be
    exported in debugging information. *)