improve error messages

Signed-off-by: ArthurW <arthur@tarides.com>

Author: art-w

src/dune_rules/lib.ml

@@ -608,9 +608,9 @@ module Parameterized = struct
     List.sort arguments ~compare:(fun (param, _) (param', _) -> compare param param')
   ;;
 
-  let instantiate ~loc named_lib args ~parent_parameters =
+  let instantiate ~loc lib args ~parent_parameters =
     let open Resolve.O in
-    let* lib = named_lib
+    let* lib = lib
     and* args = make_arguments args in
     let* lib = apply_arguments ~ignore_extra:false lib args in
     let+ () =

src/dune_rules/parameterized_rules.ml

@@ -398,38 +398,125 @@ let gen_rules ~sctx ~dir ~scope rest =
 type instance =
   { new_name : Module_name.t
   ; lib_name : Module_name.t
-  ; args : (Module_name.t * Module_name.t) list
+  ; args : (Loc.t * Module_name.t * Module_name.t) list
+  ; loc : Loc.t
   }
 
 type instances =
   | Simple of instance
-  | Wrapped of Module_name.t * instance list
+  | Wrapped of Loc.t * Module_name.t * instance list
+
+module Errors = struct
+  let make_resolve ?loc ?hints paragraphs =
+    Resolve.fail
+      (User_error.make
+         ?loc
+         ?hints
+         paragraphs
+         ~annots:(User_message.Annots.singleton User_message.Annots.needs_stack_trace ()))
+  ;;
+
+  let make ?loc ?hints paragraphs = Memo.return @@ make_resolve ?loc ?hints paragraphs
+
+  let library_not_found ~loc name =
+    make ~loc [ Pp.textf "Library parameter %S not found." (Lib_name.to_string name) ]
+  ;;
+
+  let duplicate_parameters ~loc ~param arg arg' =
+    make
+      ~loc
+      [ Pp.textf
+          "Duplicate arguments %s and %s for parameter %s."
+          (Lib_name.to_string (Lib.name arg))
+          (Lib_name.to_string (Lib.name arg'))
+          (Lib_name.to_string (Lib.name param))
+      ]
+  ;;
+
+  let missing_implements ~loc p =
+    let name = Lib_name.to_string (Lib.name p) in
+    make ~loc [ Pp.textf "Library %S does not implement a library parameter." name ]
+  ;;
+
+  let unexpected_argument ?loc param arg =
+    make
+      ?loc
+      [ Pp.textf
+          "Argument %s implements unexpected parameter %s"
+          (Lib_name.to_string (Lib.name arg))
+          (Lib_name.to_string (Lib.name param))
+      ]
+      ~hints:[ Pp.text "Remove this argument" ]
+  ;;
+
+  let new_name_already_used ?loc name =
+    make
+      ?loc
+      [ Pp.textf "The instance name %s is already used." (Module_name.to_string name) ]
+  ;;
+
+  let module_name_already_used ?loc name =
+    make
+      ?loc
+      [ Pp.textf "Module name %s has already been used." (Module_name.to_string name) ]
+  ;;
+end
 
 let instances ~sctx ~db (deps : Lib_dep.t list) =
   let open Resolve.Memo.O in
   Resolve.Memo.List.concat_map deps ~f:(function
     | Lib_dep.Direct _ | Lib_dep.Re_export _ | Lib_dep.Select _ -> Resolve.Memo.return []
-    | Lib_dep.Instantiate { loc = _; lib; arguments; new_name } ->
-      let+ entry_names =
-        let* lib = Resolve.Memo.lift_memo @@ Lib.DB.find db lib in
+    | Lib_dep.Instantiate { loc; lib = lib_name; arguments; new_name } ->
+      let* lib = Resolve.Memo.lift_memo @@ Lib.DB.find db lib_name in
+      let lib =
         match lib with
-        | None -> Resolve.Memo.return []
-        | Some lib -> Root_module.entry_module_names sctx lib
+        | None -> Code_error.raise "lib not found" [ "lib", Lib_name.to_dyn lib_name ]
+        | Some lib -> lib
+      in
+      let* expected_params =
+        let* parameters = Lib.parameters lib in
+        let+ module_names =
+          Resolve.Memo.List.filter_map parameters ~f:Lib.main_module_name
+        in
+        Module_name.Map.of_list_map_exn module_names ~f:(fun m -> m, [])
+      in
+      let+ entry_names = Root_module.entry_module_names sctx lib
       and+ args =
-        Resolve.Memo.List.filter_map arguments ~f:(fun (_loc, arg_name) ->
-          let* arg = Resolve.Memo.lift_memo @@ Lib.DB.find db arg_name in
-          match arg with
-          | None -> Resolve.Memo.return None
-          | Some arg ->
-            (match Lib.implements arg with
-             | None -> Resolve.Memo.return None
-             | Some param ->
-               let* param = param in
-               let+ param_name = Lib.main_module_name param
-               and+ arg_name = Lib.main_module_name arg in
-               (match param_name, arg_name with
-                | Some param_name, Some arg_name -> Some (param_name, arg_name)
-                | _ -> None)))
+        Resolve.Memo.List.fold_left
+          arguments
+          ~init:expected_params
+          ~f:(fun args (loc, arg_name) ->
+            let* arg = Resolve.Memo.lift_memo @@ Lib.DB.find db arg_name in
+            match arg with
+            | None -> Errors.library_not_found ~loc arg_name
+            | Some arg ->
+              (match Lib.implements arg with
+               | None -> Errors.missing_implements ~loc arg
+               | Some param ->
+                 let* param = param in
+                 let* param_name = Lib.main_module_name param
+                 and* arg_name = Lib.main_module_name arg in
+                 (match param_name, arg_name with
+                  | Some param_name, Some arg_name ->
+                    (match Module_name.Map.find args param_name with
+                     | Some [] ->
+                       Resolve.Memo.return
+                       @@ Module_name.Map.add_multi args param_name (loc, arg, arg_name)
+                     | None -> Errors.unexpected_argument ~loc arg param
+                     | Some ((_, existing, _) :: _) ->
+                       Errors.duplicate_parameters ~loc ~param existing arg)
+                  | None, None | Some _, None | None, Some _ ->
+                    Errors.missing_implements ~loc arg)))
+      in
+      let args =
+        Module_name.Map.foldi args ~init:[] ~f:(fun param arg_opt acc ->
+          match arg_opt with
+          | [] -> acc
+          | [ (loc, _lib, arg) ] -> (loc, param, arg) :: acc
+          | (_, arg, _) :: (_, arg', _) :: _ ->
+            Code_error.raise
+              "duplicate arguments were already reported"
+              [ "arg", Lib.to_dyn arg; "arg'", Lib.to_dyn arg' ])
       in
       (match entry_names with
        | [] -> []
@@ -439,15 +526,55 @@ let instances ~sctx ~db (deps : Lib_dep.t list) =
            | None -> entry_name
            | Some new_name -> new_name
          in
-         [ Simple { new_name; lib_name = entry_name; args } ]
+         [ Simple { new_name; lib_name = entry_name; args; loc } ]
        | _ :: _ :: _ ->
          let instances =
            List.map entry_names ~f:(fun name ->
-             { new_name = name; lib_name = name; args })
+             { new_name = name; lib_name = name; args; loc })
          in
          (match new_name with
           | None -> List.map ~f:(fun i -> Simple i) instances
-          | Some new_name -> [ Wrapped (new_name, instances) ])))
+          | Some new_name -> [ Wrapped (loc, new_name, instances) ])))
+;;
+
+let check_instance known_names instance =
+  if Module_name.Set.mem known_names instance.new_name
+  then Errors.new_name_already_used ~loc:instance.loc instance.new_name
+  else if Module_name.Set.mem known_names instance.lib_name
+  then Errors.module_name_already_used ~loc:instance.loc instance.new_name
+  else
+    let open Resolve.Memo.O in
+    let+ () =
+      Resolve.Memo.List.iter instance.args ~f:(fun (loc, _param_name, arg_name) ->
+        if Module_name.Set.mem known_names arg_name
+        then Errors.module_name_already_used ~loc instance.new_name
+        else Resolve.Memo.return ())
+    in
+    Module_name.Set.add known_names instance.new_name
+;;
+
+let check_instances instances =
+  let open Resolve.Memo.O in
+  Resolve.Memo.List.fold_left
+    instances
+    ~init:Module_name.Set.empty
+    ~f:(fun acc -> function
+    | Simple instance -> check_instance acc instance
+    | Wrapped (loc, wrapped_name, instances) ->
+      if Module_name.Set.mem acc wrapped_name
+      then Errors.new_name_already_used ~loc wrapped_name
+      else
+        let+ _sub_definitions : Module_name.Set.t =
+          Resolve.Memo.List.fold_left instances ~init:acc ~f:check_instance
+        in
+        Module_name.Set.add acc wrapped_name)
+;;
+
+let instances ~sctx ~db deps =
+  let open Resolve.Memo.O in
+  let* instances = instances ~sctx ~db deps in
+  let+ _ = check_instances instances in
+  instances
 ;;
 
 let print_instance b indent instance =
@@ -458,7 +585,7 @@ let print_instance b indent instance =
     (Module_name.to_string instance.new_name)
     (Module_name.to_string instance.lib_name)
     (String.concat ~sep:""
-     @@ List.map instance.args ~f:(fun (param_name, arg_name) ->
+     @@ List.map instance.args ~f:(fun (_loc, param_name, arg_name) ->
        Printf.sprintf
          "(%s)(%s)"
          (Module_name.to_string param_name)
@@ -469,7 +596,7 @@ let print_instances b instances =
   List.iter instances ~f:(fun instances ->
     match instances with
     | Simple instance -> print_instance b "" instance
-    | Wrapped (new_name, instances) ->
+    | Wrapped (_loc, new_name, instances) ->
       Printf.bprintf b "\nmodule %s = struct" (Module_name.to_string new_name);
       List.iter instances ~f:(print_instance b "  ");
       Printf.bprintf b "\nend\n")

test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/.run.t.swn

@@ -2,5 +2,5 @@
  (public_name external.lib)
  (name lib)
  (libraries
-  (paramlib impl)
+  (paramlib impl :as paramlib1)
   (paramlib impl2 :as paramlib2)))

test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune

@@ -1 +1 @@
-let test () = String.uppercase_ascii (Paramlib.v ^ " " ^ Paramlib2.v)
+let test () = String.uppercase_ascii (Paramlib1.v ^ " " ^ Paramlib2.v)

test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml

@@ -48,7 +48,7 @@ and local implementations:
   >   print_endline Paramlib_impl.v ;
   >   print_endline Paramlib_otherext.v ;
   >   print_endline (Lib.test ()) ;
-  >   print_endline (Unwrapped_a.a ^ "," ^ Unwrapped_b.b) ;
+  >   print_endline Unwrap_lib.(Unwrapped_a.a ^ "," ^ Unwrapped_b.b) ;
   >   print_endline (Rewrap.Unwrapped_a.a ^ "," ^ Rewrap.Unwrapped_b.b) ;
   >   print_endline Other_ext.v
   > EOF
@@ -58,7 +58,7 @@ and local implementations:
   >     (external.paramlib external.impl :as paramlib_impl)
   >     (external.paramlib other_ext :as paramlib_otherext)
   >     external.lib ; has instances internally
-  >     (external.unwrapped_lib external.impl)
+  >     (external.unwrapped_lib external.impl :as unwrap_lib)
   >     (external.unwrapped_lib other_ext :as rewrap)
   >     other_ext))
   > EOF

test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t

@@ -71,6 +71,7 @@ It's an error for the binary to partially instantiate `lib_ab`:
   3 |   (libraries (lib_ab b_impl))) ; missing a_impl
                     ^^^^^^
   Error: Parameter "project.a" is missing.
+  -> 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)
@@ -91,11 +92,11 @@ overlapping modules)
   > EOF
 
   $ dune exec project.bin
-  File "bin/.bin.eobjs/dune__exe.ml-gen", line 7, characters 0-75:
-  7 | module Lib_ab = Lib_ab(A)(A_impl)(B)(B_impl) [@jane.non_erasable.instances]
-      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-  Error: Multiple definition of the module name Lib_ab.
-         Names must be unique in a given structure or signature.
+  File "bin/dune", line 7, characters 5-11:
+  7 |     (lib_ab a_impl b_impl)))
+           ^^^^^^
+  Error: The instance name Lib_ab is already used.
+  -> required by _build/install/default/bin/project.bin
   [1]
 
 We add another way to implement the parameter `b` from the parameter `a`:
@@ -126,10 +127,9 @@ dependencies, because its parameter `b` is missing:
   File "bin/dune", line 6, characters 19-25:
   6 |     (lib_ab a_impl a_of_b)))
                          ^^^^^^
-  Error: Parameter "project.b" is missing.
+  Error: Duplicate arguments project.a_impl and project.a_of_b for parameter
+  project.a.
   -> required by _build/install/default/bin/project.bin
-  Hint: Pass an argument implementing project.b to the dependency, or add
-  (parameters project.b)
   [1]
 
 However `lib_ab` can depend on `a_of_b`, such that the parameter `b` will be
@@ -189,9 +189,9 @@ It's an error to provide a non-required parameter:
   File "bin/dune", line 4, characters 15-21:
   4 |     (lib_apply a_impl b_impl :as lib_ab)))
                      ^^^^^^
-  Error: Unexpected argument "project.a_impl"
+  Error: Argument project.a implements unexpected parameter project.a_impl
   -> required by _build/install/default/bin/project.bin
-  Hint: Remove the extra argument
+  Hint: Remove this argument
   [1]
 
 Given another implementation of a parameter,
@@ -216,9 +216,9 @@ which one to use:
   File "bin/dune", line 4, characters 22-29:
   4 |     (lib_apply b_impl b_impl2)))
                             ^^^^^^^
-  Error: Unexpected argument "project.b_impl2"
+  Error: Duplicate arguments project.b_impl and project.b_impl2 for parameter
+  project.b.
   -> required by _build/install/default/bin/project.bin
-  Hint: Remove the extra argument
   [1]
 
 Same error if the argument is repeated:
@@ -233,9 +233,9 @@ Same error if the argument is repeated:
   File "bin/dune", line 4, characters 22-28:
   4 |     (lib_apply b_impl b_impl)))
                             ^^^^^^
-  Error: Unexpected argument "project.b_impl"
+  Error: Duplicate arguments project.b_impl and project.b_impl for parameter
+  project.b.
   -> required by _build/install/default/bin/project.bin
-  Hint: Remove the extra argument
   [1]
 
 We can instantiate the same library multiple times by giving it different names: