feat(oxcaml): parameterised inline_tests

Signed-off-by: Arthur Wendling <[email protected]>

Author: art-w

.github/workflows/workflow.yml

@@ -373,10 +373,10 @@ jobs:
           opam-pin: false
 
       - name: Pin deps
-        run: opam pin add -n . --with-version=3.20.2+ox
+        run: opam pin add -n . --with-version=3.21.0
 
       - name: Install deps
-        run: opam install csexp pp re spawn uutf ./dune.opam
+        run: opam install csexp pp re spawn uutf ppx_inline_test ./dune.opam
 
       - name: Build dune
         run: opam exec -- make bootstrap

doc/tests.rst

@@ -288,6 +288,24 @@ a ``deps`` field the ``inline_tests`` field. The argument of this
     (inline_tests (deps data.txt))
     (preprocess (pps ppx_expect)))
 
+Specifying Inline Test arguments for Parameterised Libraries
+------------------------------------------------------------
+
+If your library is parameterised (see
+:doc:`/reference/dune/library_parameter`), you must specify which
+implementation of the parameters to use with the ``arguments`` field.  For
+example, suppose `foo` is a parameterised library that takes parameters
+`a_param` and `b_param`, you can specify the implementations of these
+parameters for inline tests as follows:
+
+.. code:: ocaml
+
+   (library
+    (name foo)
+    (parameters a_param b_param)
+    (inline_tests
+     (arguments a_impl b_impl)))
+
 
 Passing Special Arguments to the Test Runner
 --------------------------------------------

src/dune_rules/inline_tests.ml

@@ -264,7 +264,23 @@ include Sub_system.Register_end_point (struct
             Resolve.Memo.List.concat_map backends ~f:(fun (backend : Backend.t) ->
               backend.runner_libraries)
           in
-          let* lib = Lib.DB.resolve lib_db (loc, Library.best_name lib) in
+          let* arguments =
+            Resolve.Memo.lift_memo
+            @@ Memo.List.map info.arguments ~f:(fun (loc, dep) ->
+              let open Memo.O in
+              let+ dep = Lib.DB.resolve lib_db (loc, dep) in
+              loc, dep)
+          in
+          let* lib =
+            let* lib = Lib.DB.resolve lib_db (loc, Library.best_name lib) in
+            Resolve.Memo.lift
+            @@ Lib.Parameterised.instantiate
+                 ~from:`inline_tests
+                 ~loc
+                 lib
+                 arguments
+                 ~parent_parameters:[]
+          in
           let* more_libs =
             Resolve.Memo.List.map info.libraries ~f:(Lib.DB.resolve lib_db)
           in

src/dune_rules/inline_tests_info.ml

@@ -134,6 +134,7 @@ module Tests = struct
     ; executable_link_flags : Ordered_set_lang.Unexpanded.t
     ; backend : (Loc.t * Lib_name.t) option
     ; libraries : (Loc.t * Lib_name.t) list
+    ; arguments : (Loc.t * Lib_name.t) list
     ; enabled_if : Blang.t
     }
 
@@ -165,6 +166,12 @@ module Tests = struct
                    ocaml_flags, link_flags))
        and+ backend = field_o "backend" (located Lib_name.decode)
        and+ libraries = field "libraries" (repeat (located Lib_name.decode)) ~default:[]
+       and+ arguments =
+         field
+           "arguments"
+           (Dune_lang.Syntax.since Dune_lang.Oxcaml.syntax (0, 1)
+            >>> repeat (located Lib_name.decode))
+           ~default:[]
        and+ modes =
          field
            "modes"
@@ -180,6 +187,7 @@ module Tests = struct
        ; executable_link_flags
        ; backend
        ; libraries
+       ; arguments
        ; modes
        ; enabled_if
        })

src/dune_rules/inline_tests_info.mli

@@ -46,6 +46,7 @@ module Tests : sig
     ; executable_link_flags : Ordered_set_lang.Unexpanded.t
     ; backend : (Loc.t * Lib_name.t) option
     ; libraries : (Loc.t * Lib_name.t) list
+    ; arguments : (Loc.t * Lib_name.t) list
     ; enabled_if : Blang.t
     }
 

src/dune_rules/lib.ml

@@ -264,19 +264,34 @@ module Error = struct
       ]
   ;;
 
-  let missing_parameter ~loc p =
+  let missing_parameter_inline_tests ~loc p =
     let name = Lib_name.to_string (Lib_info.name p) in
     make_resolve
       ~loc
-      [ Pp.textf "Parameter %S is missing." name ]
+      [ Pp.textf "To run the inline tests, please provide the missing parameter %S." name
+      ]
       ~hints:
         [ Pp.textf
-            "Pass an argument implementing %s to the dependency, or add (parameters %s)"
-            name
+            "Add (arguments ...) to the inline_tests to specify which implementation of \
+             the parameter %S to use."
             name
         ]
   ;;
 
+  let missing_parameter_depends ~loc p =
+    let name = Lib_name.to_string (Lib_info.name p) in
+    make_resolve
+      ~loc
+      [ Pp.textf "Missing argument for parameter %S." name ]
+      ~hints:[ Pp.textf "Pass an argument implementing %S to the dependency." name ]
+  ;;
+
+  let missing_parameter ~from ~loc ~loc_param p =
+    match from with
+    | `depends -> missing_parameter_depends ~loc p
+    | `inline_tests -> missing_parameter_inline_tests ~loc:loc_param p
+  ;;
+
   let missing_implements ~loc p =
     let name = Lib_name.to_string (Lib_info.name p) in
     make_resolve
@@ -375,7 +390,7 @@ module T = struct
     ; pps : t list Resolve.t
     ; resolved_selects : Resolved_select.t list Resolve.t
     ; allow_unused_libraries : t list Resolve.t
-    ; parameters : t list Resolve.t
+    ; parameters : (Loc.t * t) list Resolve.t
     ; arguments : t option list
     ; implements : t Resolve.t option
     ; project : Dune_project.t option
@@ -477,7 +492,7 @@ let name t = t.name
 let info t = t.info
 let project t = t.project
 let implements t = Option.map ~f:Memo.return t.implements
-let parameters t = Resolve.Memo.lift t.parameters
+let parameters t = Resolve.Memo.lift (Resolve.map ~f:(List.map ~f:snd) t.parameters)
 let requires t = Memo.return t.requires
 let re_exports t = Memo.return t.re_exports
 let ppx_runtime_deps t = Memo.return t.ppx_runtime_deps
@@ -558,7 +573,7 @@ module Parameterised = struct
   let parameterised_arguments t =
     let open Resolve.O in
     let+ parameters = t.parameters in
-    List.combine parameters t.arguments
+    List.map2 ~f:(fun (loc, param) arg -> loc, param, arg) parameters t.arguments
   ;;
 
   let apply_arguments t new_arguments =
@@ -574,27 +589,26 @@ module Parameterised = struct
         | [], _ ->
           (* Ignore remaining arguments *)
           Resolve.return (List.rev acc)
-        | keep, [] ->
-          (* Keep the remaining existing parameters *)
-          Resolve.return (List.rev_append acc keep)
-        | (param_intf, Some arg) :: existing, _ ->
+        | (_, _, None) :: existing, [] ->
+          (* Keep required parameter which are still unspecifed *)
+          go (None :: acc) existing []
+        | (_, _, Some arg) :: existing, _ ->
           (* Keep already applied parameter *)
-          go ((param_intf, Some arg) :: acc) existing given'
-        | ((param_intf, None) as keep) :: existing, (param_intf', arg) :: given ->
+          go (Some arg :: acc) existing given'
+        | (_, param_intf, None) :: existing, (param_intf', arg) :: given ->
           (match compare param_intf param_intf' with
            | Eq ->
              (* Apply the argument to the unset parameter *)
-             go ((param_intf, Some arg) :: acc) existing given
+             go (Some arg :: acc) existing given
            | Lt ->
              (* Keep the existing parameter as being unknown *)
-             go (keep :: acc) existing given'
+             go (None :: acc) existing given'
            | Gt ->
              (* Skip unwanted argument *)
              go acc existing' given)
       in
       let* t_arguments = parameterised_arguments t in
       let+ arguments = go [] t_arguments new_arguments in
-      let arguments = List.map ~f:snd arguments in
       { t with arguments }
   ;;
 
@@ -615,15 +629,19 @@ module Parameterised = struct
     List.sort arguments ~compare:(fun (param, _) (param', _) -> compare param param')
   ;;
 
-  let instantiate ~loc lib args ~parent_parameters =
+  let instantiate ~loc ~from lib args ~parent_parameters =
     let open Resolve.O in
     let* args = make_arguments args in
     let* lib = apply_arguments lib args in
     let+ () =
       let* all_args = parameterised_arguments lib in
+      let is_inherited param =
+        List.exists parent_parameters ~f:(fun (_, parent_param) ->
+          equal param parent_param)
+      in
       Resolve.List.iter all_args ~f:(function
-        | param, None when not (List.exists parent_parameters ~f:(equal param)) ->
-          Error.missing_parameter ~loc param.info
+        | loc_param, param, None when not (is_inherited param) ->
+          Error.missing_parameter ~from ~loc ~loc_param param.info
         | _ -> Resolve.return ())
     in
     lib
@@ -636,7 +654,7 @@ module Parameterised = struct
       let open Resolve.O in
       let* parent_arguments = parameterised_arguments parent in
       let parent_arguments =
-        List.filter_map parent_arguments ~f:(fun (param, opt_arg) ->
+        List.filter_map parent_arguments ~f:(fun (_loc, param, opt_arg) ->
           Option.map opt_arg ~f:(fun arg -> param, arg))
       in
       let* arguments =
@@ -1142,14 +1160,14 @@ module rec Resolve_names : sig
     :  db
     -> Lib_dep.t list
     -> private_deps:private_deps
-    -> parameters:lib list
+    -> parameters:(Loc.t * lib) list
     -> Resolved.deps Memo.t
 
   val resolve_deps_and_add_runtime_deps
     :  db
     -> Lib_dep.t list
     -> private_deps:private_deps
-    -> parameters:t list
+    -> parameters:(Loc.t * t) list
     -> pps:(Loc.t * Lib_name.t) list
     -> dune_version:Dune_lang.Syntax.Version.t option
     -> Resolved.t Memo.t
@@ -1210,7 +1228,7 @@ end = struct
       | _ :: ps -> check_duplicates ps
     in
     let+ () = check_duplicates parameters in
-    List.map parameters ~f:(fun (_, _, param) -> param)
+    List.map parameters ~f:(fun (loc, _, param) -> loc, param)
   ;;
 
   let instantiate_impl db (name, info, hidden) =
@@ -1298,6 +1316,7 @@ end = struct
                "expected Virtual or Parameter"
                [ "implements", to_dyn impl ])
       in
+      let requires_params = List.map ~f:snd requires_params in
       let requires = List.concat [ requires_implements; requires_params; requires ] in
       let (_ : Set.t), requires =
         List.fold_left requires ~init:(Set.empty, []) ~f:(fun (seen, lst) lib ->
@@ -1747,7 +1766,12 @@ end = struct
       >>| Option.map ~f:(fun dep ->
         let open Resolve.O in
         let* dep = dep in
-        Parameterised.instantiate ~loc dep arguments ~parent_parameters:parameters)
+        Parameterised.instantiate
+          ~loc
+          ~from:`depends
+          dep
+          arguments
+          ~parent_parameters:parameters)
     in
     Memo.List.fold_left ~init:Resolved.Builder.empty deps ~f:(fun acc (dep : Lib_dep.t) ->
       match dep with
@@ -1853,6 +1877,7 @@ end = struct
       let open Resolve.Memo.O in
       let* resolved = Memo.return resolved in
       let* runtime_deps = runtime_deps in
+      let parameters = List.map ~f:snd parameters in
       re_exports_closure (List.concat [ resolved; runtime_deps; parameters ])
     and+ pps = pps in
     { Resolved.requires; pps; selects; re_exports }
@@ -2594,9 +2619,7 @@ let to_dune_lib
       ~lib_field:(Option.map ~f:Memo.return lib.implements)
   and+ parameters =
     let+ lib_parameters = Resolve.Memo.lift lib.parameters in
-    List.map
-      (List.combine (Lib_info.parameters info) lib_parameters)
-      ~f:(fun ((loc, _), param) -> loc, mangled_name param)
+    List.map lib_parameters ~f:(fun (loc, param) -> loc, mangled_name param)
   and+ default_implementation =
     use_public_name
       ~info_field:(Lib_info.default_implementation info)

src/dune_rules/lib.mli

@@ -30,9 +30,10 @@ module Parameterised : sig
 
   val instantiate
     :  loc:Loc.t
+    -> from:[ `depends | `inline_tests ]
     -> t
     -> (Loc.t * t Resolve.t) list
-    -> parent_parameters:t list
+    -> parent_parameters:(Loc.t * t) list
     -> t Resolve.t
 end
 

src/dune_rules/parameterised_rules.ml

@@ -349,7 +349,11 @@ let resolve_instantiation scope instance_name =
     | Some lib ->
       Memo.List.map ~f:go args
       >>| List.map ~f:(fun arg -> Loc.none, arg)
-      >>| Lib.Parameterised.instantiate ~loc:Loc.none lib ~parent_parameters:[]
+      >>| Lib.Parameterised.instantiate
+            ~loc:Loc.none
+            ~from:`depends
+            lib
+            ~parent_parameters:[]
   in
   go (Parameterised_name.of_string instance_name) |> Resolve.Memo.read_memo
 ;;

test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t

@@ -70,11 +70,10 @@ It's an error for the binary to partially instantiate `lib_ab`:
   File "bin/dune", line 3, characters 26-32:
   3 |   (libraries (instantiate lib_ab b_impl))) ; missing a_impl
                                 ^^^^^^
-  Error: Parameter "project.a" is missing.
+  Error: Missing argument for parameter "project.a".
   -> required by _build/default/bin/bin.exe
   -> required by _build/install/default/bin/project.bin
-  Hint: Pass an argument implementing project.a to the dependency, or add
-  (parameters project.a)
+  Hint: Pass an argument implementing "project.a" to the dependency.
   [1]
 
 It's an error to instantiate twice without renamming: (dune might be able to
@@ -141,12 +140,11 @@ dependencies, because its parameter `b` is missing:
   File "bin/dune", line 6, characters 31-37:
   6 |     (instantiate lib_ab a_impl a_of_b)))
                                      ^^^^^^
-  Error: Parameter "project.b" is missing.
+  Error: Missing argument for parameter "project.b".
   -> required by _build/default/bin/.bin.eobjs/native/dune__exe__Bin.cmx
   -> required by _build/default/bin/bin.exe
   -> required by _build/install/default/bin/project.bin
-  Hint: Pass an argument implementing project.b to the dependency, or add
-  (parameters project.b)
+  Hint: Pass an argument implementing "project.b" to the dependency.
   [1]
 
 However `lib_ab` can depend on `a_of_b`, such that the parameter `b` will be

test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t

@@ -335,13 +335,12 @@ required parameters.
   File "bin/dune", line 1, characters 34-37:
   1 | (executable (name bin) (libraries lib))
                                         ^^^
-  Error: Parameter "project.a" is missing.
+  Error: Missing argument for parameter "project.a".
   -> required by _build/default/bin/.bin.eobjs/native/dune__exe__Bin.cmx
   -> required by _build/default/bin/bin.exe
   -> required by alias bin/all
   -> required by alias default
-  Hint: Pass an argument implementing project.a to the dependency, or add
-  (parameters project.a)
+  Hint: Pass an argument implementing "project.a" to the dependency.
   [1]
 
   $ rm -r bin
@@ -357,14 +356,13 @@ Same for libraries:
   File "lib2/dune", line 1, characters 32-35:
   1 | (library (name lib2) (libraries lib))
                                       ^^^
-  Error: Parameter "project.a" is missing.
+  Error: Missing argument for parameter "project.a".
   -> required by library "lib2" in _build/default/lib2
   -> required by _build/default/lib2/.lib2.objs/native/lib2.cmx
   -> required by _build/default/lib2/lib2.a
   -> required by alias lib2/all
   -> required by alias default
-  Hint: Pass an argument implementing project.a to the dependency, or add
-  (parameters project.a)
+  Hint: Pass an argument implementing "project.a" to the dependency.
   [1]
 
 It works if `lib2` is itself parameterised with the same parameters as `lib`: