fix(include-qualified): hint dotted module references

bin/describe/describe_pp.ml

@@ -119,7 +119,9 @@ let find_module ~sctx file =
   | Some (m, _, _, origin) ->
     (match
        Dune_rules.Ml_sources.Origin.preprocess origin
-       |> Dune_lang.Preprocess.Per_module.find (Dune_rules.Module.name m)
+       |> Dune_lang.Preprocess.Per_module.find
+            ~path:(Dune_rules.Module.logical_path m)
+            ~name:(Dune_rules.Module.name m)
      with
      | Pps { staged = true; loc; _ } -> Some (`Staged_pps loc)
      | _ -> Some (`Module m))

bin/ocaml/top.ml

@@ -196,7 +196,12 @@ module Module = struct
         let module Merlin = Dune_rules.Merlin in
         let pps = Merlin.pp_config merlin ctx ~expander in
         let+ pps, _ = Action_builder.evaluate_and_collect_facts pps in
-        let pp = Dune_lang.Module_name.Per_item.get pps module_name in
+        let pp =
+          Dune_lang.Module_reference.Per_item.find
+            pps
+            ~path:(Dune_rules.Module.logical_path module_)
+            ~name:module_name
+        in
         match pp with
         | None -> None, None
         | Some pp_flags ->

doc/changes/fixed/15633.md

@@ -0,0 +1,2 @@
+- Support qualified module references in fields such as `per_module` when using
+  `(include_subdirs qualified)` (#15633, fixes #15578, @anmonteiro)

src/dune_lang/dune_lang.ml

@@ -47,6 +47,7 @@ module Dialect = Dialect
 module Lib_mode = Lib_mode
 module Melange = Melange
 module Module_name = Module_name
+module Module_reference = Module_reference
 module Pin_stanza = Pin_stanza
 module Preprocess = Preprocess
 module Link_flags = Link_flags

src/dune_lang/module_reference.ml

@@ -0,0 +1,165 @@
+open Import
+
+module T = struct
+  type mode =
+    | Legacy
+    | Path
+
+  type t =
+    { loc : Loc.t
+    ; path : Module_name.Path.t
+    ; mode : mode
+    }
+
+  let mode_to_string = function
+    | Legacy -> "legacy"
+    | Path -> "path"
+  ;;
+
+  let compare t1 t2 =
+    let open Ordering.O in
+    let= () =
+      match t1.mode, t2.mode with
+      | Legacy, Legacy | Path, Path -> Eq
+      | Legacy, Path -> Lt
+      | Path, Legacy -> Gt
+    in
+    Module_name.Path.compare t1.path t2.path
+  ;;
+
+  let equal t1 t2 = compare t1 t2 |> Ordering.is_eq
+
+  let to_dyn { loc; path; mode } =
+    Dyn.record
+      [ "loc", Loc.to_dyn loc
+      ; "path", Module_name.Path.to_dyn path
+      ; "mode", Dyn.string (mode_to_string mode)
+      ]
+  ;;
+end
+
+include T
+
+let loc t = t.loc
+let path t = t.path
+let to_string t = Module_name.Path.to_string t.path
+
+let is_qualified t =
+  match t.path with
+  | _ :: _ :: _ -> true
+  | [ _ ] -> false
+;;
+
+let is_legacy t =
+  match t.mode with
+  | Legacy -> true
+  | Path -> false
+;;
+
+let make ~loc ~mode path = { loc; path; mode }
+
+let slash_separated_path value =
+  match String.split value ~on:'/' with
+  | first :: second :: rest ->
+    Option.List.traverse (first :: second :: rest) ~f:Module_name.of_string_opt
+    |> Option.map ~f:Nonempty_list.of_list_exn
+  | [] | [ _ ] -> None
+;;
+
+let parse_component loc ~suggestion component =
+  let result = Module_name.of_string_user_error (loc, component) in
+  let result =
+    match result, suggestion with
+    | Error message, Some suggestion ->
+      let hints =
+        [ Pp.textf
+            "%s would be a correct module reference"
+            (Module_name.Path.to_string suggestion)
+        ]
+      in
+      Error { message with User_message.hints }
+    | result, _ -> result
+  in
+  User_error.ok_exn result
+;;
+
+let of_string version (loc, value) =
+  let components = String.split value ~on:'.' in
+  let mode = if version >= (3, 25) then Path else Legacy in
+  if List.length components > 1 && version < (3, 25)
+  then
+    Syntax.Error.since loc Stanza.syntax (3, 25) ~what:"Using qualified module references";
+  let suggestion =
+    match mode with
+    | Legacy -> None
+    | Path -> slash_separated_path value
+  in
+  let path =
+    List.map components ~f:(parse_component loc ~suggestion) |> Nonempty_list.of_list_exn
+  in
+  make ~loc ~mode path
+;;
+
+let decode =
+  let open Decoder in
+  let+ value = located string
+  and+ version = Syntax.get_exn Stanza.syntax in
+  of_string version value
+;;
+
+module Per_item = struct
+  module Base = Per_item.Make (T)
+  include Base
+  open Decoder
+
+  let repr value_repr =
+    Repr.view
+      Repr.(pair (list (triple String.repr String.repr Int.repr)) (list value_repr))
+      ~to_:(fun t ->
+        let references, values = enumerate t in
+        ( List.map references ~f:(fun (reference, index) ->
+            to_string reference, mode_to_string reference.mode, index)
+        , values ))
+  ;;
+
+  let decode ~default value =
+    peek_exn
+    >>= function
+    | List (loc, Atom (_, A "per_module") :: _) ->
+      sum
+        [ ( "per_module"
+          , let+ mappings =
+              repeat
+                (let+ value, references = pair value (repeat decode) in
+                 references, value)
+            in
+            of_mapping mappings ~default
+            |> function
+            | Ok t -> t
+            | Error (reference, _, _) ->
+              User_error.raise
+                ~loc
+                [ Pp.textf "module %s present in two different sets" (to_string reference)
+                ] )
+        ]
+    | _ -> value >>| for_all
+  ;;
+
+  let mode t =
+    match fst (enumerate t) with
+    | [] -> Path
+    | (reference, _) :: _ -> reference.mode
+  ;;
+
+  let find t ~path ~name =
+    let mode = mode t in
+    let path =
+      match mode with
+      | Legacy -> Nonempty_list.[ name ]
+      | Path -> path
+    in
+    Base.get t (make ~loc:Loc.none ~mode path)
+  ;;
+
+  let explicit_references t = fst (enumerate t) |> List.map ~f:fst
+end

src/dune_lang/module_reference.mli

@@ -0,0 +1,32 @@
+open Import
+
+(** A reference to a module in a dune file.
+
+    Starting with version 3.25 of the dune language, references may contain
+    multiple components, for example [Foo.Bar]. *)
+type t
+
+val compare : t -> t -> Ordering.t
+val equal : t -> t -> bool
+val loc : t -> Loc.t
+val path : t -> Module_name.Path.t
+val to_string : t -> string
+val to_dyn : t -> Dyn.t
+val of_string : Syntax.Version.t -> Loc.t * string -> t
+val is_qualified : t -> bool
+val is_legacy : t -> bool
+val decode : t Decoder.t
+
+module Per_item : sig
+  include Per_item with type key = t
+
+  val decode : default:'a -> 'a Decoder.t -> 'a t Decoder.t
+  val repr : 'a Repr.t -> 'a t Repr.t
+
+  (** Find the value associated with a module. [path] is its logical path and
+      [name] is its final component. The latter preserves the lookup semantics
+      of dune language versions before 3.25. *)
+  val find : 'a t -> path:Module_name.Path.t -> name:Module_name.t -> 'a
+
+  val explicit_references : 'a t -> key list
+end

src/dune_lang/preprocess.ml

@@ -317,7 +317,7 @@ module Instrumentation = struct
 end
 
 module Per_module = struct
-  module Per_module = Module_name.Per_item
+  module Per_module = Module_reference.Per_item
 
   type 'a preprocess = 'a t
   type 'a t = 'a preprocess Per_module.t
@@ -326,7 +326,7 @@ module Per_module = struct
   let equal f x y = Per_module.equal (equal f) x y
   let decode = Per_module.decode decode ~default:No_preprocessing
   let no_preprocessing () = Per_module.for_all No_preprocessing
-  let find module_name t = Per_module.get t module_name
+  let find ~path ~name t = Per_module.find t ~path ~name
   let default () = Per_module.for_all No_preprocessing
 
   let pps t =
@@ -394,7 +394,7 @@ let preprocess_fields_with_prefix ~prefix:field_prefix =
     | Some _, None | None, _ -> []
     | Some (loc, deps), Some preprocess ->
       let deps_might_be_used =
-        Module_name.Per_item.exists preprocess ~f:(fun p ->
+        Module_reference.Per_item.exists preprocess ~f:(fun p ->
           match p with
           | Action _ | Pps _ -> true
           | No_preprocessing | Future_syntax _ -> false)
@@ -429,7 +429,7 @@ let preprocess_config ~preprocess ~instrumentation ~preprocessor_deps =
   let config =
     let init =
       let f libname = With_instrumentation.Ordinary libname in
-      Module_name.Per_item.map preprocess ~f:(map ~f)
+      Module_reference.Per_item.map preprocess ~f:(map ~f)
     in
     List.fold_left instrumentation ~init ~f:Per_module.add_instrumentation
   in

src/dune_lang/preprocess.mli

@@ -80,16 +80,16 @@ end
 
 module Per_module : sig
   type 'a preprocess := 'a t
-  type 'a t = 'a preprocess Module_name.Per_item.t
+  type 'a t = 'a preprocess Module_reference.Per_item.t
 
   val repr : 'a Repr.t -> 'a t Repr.t
   val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
   val decode : Without_instrumentation.t t Decoder.t
   val no_preprocessing : unit -> 'a t
   val default : unit -> 'a t
 
-  (** [find module_name] find the preprocessing specification for a given module *)
-  val find : Module_name.t -> 'a t -> 'a preprocess
+  (** Find the preprocessing specification for a module. *)
+  val find : path:Module_name.Path.t -> name:Module_name.t -> 'a t -> 'a preprocess
 
   val pps : Without_instrumentation.t t -> Without_instrumentation.t list
 
@@ -111,7 +111,7 @@ type preprocess =
   }
 
 val preprocess_config
-  :  preprocess:Without_instrumentation.t t Module_name.Per_item.t
+  :  preprocess:Without_instrumentation.t t Module_reference.Per_item.t
   -> instrumentation:Instrumentation.t list
   -> preprocessor_deps:Dep_conf.t list
   -> preprocess

src/dune_rules/import.ml

@@ -119,6 +119,7 @@ include struct
   module Dialect = Dialect
   module Lib_mode = Lib_mode
   module Module_name = Module_name
+  module Module_reference = Module_reference
   module Preprocess = Preprocess
   module Dune_project = Dune_project
   module File_binding = File_binding

src/dune_rules/instrumentation.ml

@@ -12,7 +12,7 @@ let filter_map_resolve (t : _ Preprocess.t) ~f =
   | (No_preprocessing | Action _ | Future_syntax _) as t -> Resolve.Memo.return t
 ;;
 
-module Resolve_traversals = Module_name.Per_item.Make_monad_traversals (Resolve.Memo)
+module Resolve_traversals = Module_reference.Per_item.Make_monad_traversals (Resolve.Memo)
 
 let fold = Resolve_traversals.fold
 

src/dune_rules/instrumentation.mli

@@ -1,7 +1,7 @@
 open Import
 
 val fold
-  :  'a Module_name.Per_item.t
+  :  'a Module_reference.Per_item.t
   -> init:'b
   -> f:('a -> 'b -> 'b Resolve.Memo.t)
   -> 'b Resolve.Memo.t

src/dune_rules/melange/melange_rules.ml

@@ -41,7 +41,12 @@ let setup_melange_sources_copy_rules ~sctx ~dir ~preprocess modules =
       | true -> Memo.return ()
       | false ->
         let builder =
-          match Preprocess.Per_module.find (Module.name m) preprocess with
+          match
+            Preprocess.Per_module.find
+              ~path:(Module.logical_path m)
+              ~name:(Module.name m)
+              preprocess
+          with
           | Pps { staged = false; _ } ->
             (* Non-staged PPX preprocessing receives [-loc-filename] separately,
                so adding a line directive here would shift diagnostics twice. *)