Merge pull request #12124 from Alizter/gh12018

fix(ctypes): mismatch between modules field and ctypes stanza

Author: Alizter

src/dune_rules/buildable_rules.ml

@@ -94,6 +94,9 @@ let modules_rules
       ~preprocessor_deps
       ~lint
       ~empty_module_interface_if_absent
+      ~ctypes
+      ~modules_loc
+      ~buildable_loc
       sctx
       expander
       ~dir
@@ -135,6 +138,39 @@ let modules_rules
         fun name -> default || List.mem executable_names name ~equal:Module_name.equal)
       else fun _ -> default
   in
+  let* () =
+    match ctypes with
+    | Some ctypes ->
+      let (ctypes : Ctypes_field.t) = ctypes in
+      let modules = Modules.With_vlib.modules modules in
+      (* Here we collect all the modules that ctypes expects to be present in
+         that stanza in order to validate their existence. We do this using
+         [Memo.parallel_iter] in order to collect all the errors rather than
+         just the first occurances. *)
+      (ctypes.type_description.functor_loc, ctypes.type_description.functor_)
+      :: List.map
+           ~f:(fun (x : Ctypes_field.Function_description.t) -> x.functor_loc, x.functor_)
+           ctypes.function_description
+      |> Memo.parallel_iter ~f:(fun ((functor_loc, m) : Loc.t * Module_name.t) ->
+        match Modules.With_vlib.find modules m with
+        | Some _ -> Memo.return ()
+        | None ->
+          let loc =
+            Option.first_some modules_loc buildable_loc
+            |> Option.value
+                 ~default:
+                   (Path.build dir |> Path.drop_optional_build_context |> Loc.in_dir)
+          in
+          User_error.raise
+            ~loc
+            [ Pp.textf
+                "Module %s is required by ctypes at %s but is missing in the modules \
+                 field of the stanza."
+                (Module_name.to_string m)
+                (Loc.to_file_colon_line functor_loc)
+            ])
+    | None -> Memo.return ()
+  in
   let+ modules =
     Modules.map_user_written modules ~f:(fun m ->
       let* m = Pp_spec.pp_module pp m in
@@ -159,15 +195,31 @@ let modules_rules sctx kind expander ~dir scope modules =
           [ Pp.text "The compiler you are using is not compatible with library parameter"
           ]
   in
-  let preprocess, preprocessor_deps, lint, empty_module_interface_if_absent =
+  let ( preprocess
+      , preprocessor_deps
+      , lint
+      , empty_module_interface_if_absent
+      , ctypes
+      , modules_loc
+      , buildable_loc )
+    =
     match kind with
     | Executables (buildable, _) | Library (buildable, _) | Parameter (buildable, _) ->
       ( buildable.preprocess
       , buildable.preprocessor_deps
       , buildable.lint
-      , buildable.empty_module_interface_if_absent )
+      , buildable.empty_module_interface_if_absent
+      , buildable.ctypes
+      , Ordered_set_lang.Unexpanded.loc buildable.modules.modules
+      , Some buildable.loc )
     | Melange { preprocess; preprocessor_deps; lint; empty_module_interface_if_absent } ->
-      preprocess, preprocessor_deps, lint, empty_module_interface_if_absent
+      ( preprocess
+      , preprocessor_deps
+      , lint
+      , empty_module_interface_if_absent
+      , None
+      , None
+      , None )
   in
   let lib_name =
     match kind with
@@ -184,6 +236,9 @@ let modules_rules sctx kind expander ~dir scope modules =
     ~preprocessor_deps
     ~lint
     ~empty_module_interface_if_absent
+    ~ctypes
+    ~modules_loc
+    ~buildable_loc
     sctx
     expander
     ~dir

src/dune_rules/ctypes/ctypes_field.ml

@@ -91,15 +91,16 @@ end
 module Type_description = struct
   type t =
     { functor_ : Module_name.t
+    ; functor_loc : Loc.t
     ; instance : Module_name.t
     }
 
   let decode =
     let open Dune_lang.Decoder in
     fields
-      (let+ functor_ = field "functor" Module_name.decode
+      (let+ functor_loc, functor_ = located @@ field "functor" Module_name.decode
        and+ instance = field "instance" Module_name.decode in
-       { functor_; instance })
+       { functor_; functor_loc; instance })
   ;;
 end
 
@@ -108,6 +109,7 @@ module Function_description = struct
     { concurrency : Concurrency_policy.t
     ; errno_policy : Errno_policy.t
     ; functor_ : Module_name.t
+    ; functor_loc : Loc.t
     ; instance : Module_name.t
     }
 
@@ -116,11 +118,12 @@ module Function_description = struct
     fields
       (let+ concurrency = field_o "concurrency" Concurrency_policy.decode
        and+ errno_policy = field_o "errno_policy" Errno_policy.decode
-       and+ functor_ = field "functor" Module_name.decode
+       and+ functor_loc, functor_ = located @@ field "functor" Module_name.decode
        and+ instance = field "instance" Module_name.decode in
        { concurrency = Option.value concurrency ~default:Concurrency_policy.default
        ; errno_policy = Option.value errno_policy ~default:Errno_policy.default
        ; functor_
+       ; functor_loc
        ; instance
        })
   ;;

src/dune_rules/ctypes/ctypes_field.mli

@@ -36,6 +36,7 @@ end
 module Type_description : sig
   type t =
     { functor_ : Module_name.t
+    ; functor_loc : Loc.t
     ; instance : Module_name.t
     }
 end
@@ -45,6 +46,7 @@ module Function_description : sig
     { concurrency : Concurrency_policy.t
     ; errno_policy : Errno_policy.t
     ; functor_ : Module_name.t
+    ; functor_loc : Loc.t
     ; instance : Module_name.t
     }
 end

test/blackbox-tests/test-cases/ctypes/gh12018.t

@@ -0,0 +1,57 @@
+Reproduction case for https://github.com/ocaml/dune/issues/12018
+
+  $ cat > dune-project <<EOF
+  > (lang dune 3.20)
+  > (using ctypes 0.3)
+  > EOF
+
+  $ cat > type_description.ml <<EOF
+  > module Types (F : Ctypes.TYPE) = struct end
+  > EOF
+
+  $ cat > function_description.ml <<EOF
+  > open Ctypes
+  > module Types = Types_generated
+  >  
+  > module Functions (F : Ctypes.FOREIGN) = struct
+  >   open F
+  >   let add2 =
+  >     foreign "example_add2" (int @-> returning int)
+  > end
+  > EOF
+
+  $ cat > foo.ml <<EOF
+  > let () = Printf.printf "%d" (C.Functions.add2 2)
+  > EOF
+
+  $ cat > dune <<EOF
+  > (executable
+  >  (name foo)
+  >  (modules foo)
+  >  (ctypes
+  >   (external_library_name libexample)
+  >   (headers (include "example.h"))
+  >   (build_flags_resolver pkg_config)
+  >   (type_description
+  >    (instance Types)
+  >    (functor Type_description))
+  >   (function_description
+  >    (instance Functions)
+  >    (functor Function_description))
+  >   (generated_entry_point C)))
+  > EOF
+
+  $ LIBEX=$(realpath "$PWD/libexample")
+  $ DYLD_LIBRARY_PATH="$LIBEX" LD_LIBRARY_PATH="$LIBEX" PKG_CONFIG_PATH="$LIBEX/pkgconfig" PKG_CONFIG_ARGN="--define-prefix" dune exec ./foo.exe
+  File "dune", line 3, characters 10-13:
+  3 |  (modules foo)
+                ^^^
+  Error: Module Function_description is required by ctypes at dune:13 but is
+  missing in the modules field of the stanza.
+  File "dune", line 3, characters 10-13:
+  3 |  (modules foo)
+                ^^^
+  Error: Module Type_description is required by ctypes at dune:10 but is
+  missing in the modules field of the stanza.
+  [1]
+

test/blackbox-tests/test-cases/ctypes/github-5561-name-mangle.t

@@ -16,8 +16,16 @@
   > EOF
 
   $ bash -c 'set -o pipefail; dune build 2>&1 | head -n 20'
-  File "fooBar__type_gen.ml", line 3, characters 12-34:
-  3 |     (module Type_description.Types)
-                  ^^^^^^^^^^^^^^^^^^^^^^
-  Error: Unbound module Type_description
+  File "dune", lines 1-9, characters 0-211:
+  1 | (library
+  2 |  (name foo)
+  3 |  (ctypes
+  4 |   (external_library_name fooBar)
+  5 |   (build_flags_resolver vendored)
+  6 |   (generated_entry_point Types_generated2)
+  7 |   (type_description
+  8 |    (instance Type)
+  9 |    (functor Type_description))))
+  Error: Module Type_description is required by ctypes at dune:9 but is missing
+  in the modules field of the stanza.
   [1]