feat(oxcaml): add parameters field for libraries

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

Author: art-w

doc/reference/dune/library.rst

@@ -217,6 +217,14 @@ order to declare a multi-directory library, you need to use the
 
    See :doc:`/virtual-libraries` or :doc:`/reference/dune/library_parameter`.
 
+.. describe:: (parameters <library-parameter-names>)
+
+   List the library parameters used by the library and its dependencies.
+
+   This feature is experimental and requires the compiler you are using to
+   support parameterized libraries.
+   See :doc:`/reference/dune/library_parameter`.
+
 .. describe:: (js_of_ocaml ...)
 
    Sets options for JavaScript compilation, see :ref:`jsoo-field`.

src/dune_rules/compilation_context.ml

@@ -88,6 +88,7 @@ type t =
   ; requires_hidden : Lib.t list Resolve.Memo.t
   ; requires_link : Lib.t list Resolve.t Memo.Lazy.t
   ; implements : Virtual_rules.t
+  ; parameters : Module_name.t list Resolve.Memo.t
   ; includes : Includes.t
   ; preprocessing : Pp_spec.t
   ; opaque : bool
@@ -112,6 +113,7 @@ let flags t = t.flags
 let requires_compile t = t.requires_compile
 let requires_hidden t = t.requires_hidden
 let requires_link t = Memo.Lazy.force t.requires_link
+let parameters t = t.parameters
 let includes t = t.includes
 let preprocessing t = t.preprocessing
 let opaque t = t.opaque
@@ -128,6 +130,19 @@ let context t = Super_context.context t.super_context
 let dep_graphs t = t.modules.dep_graphs
 let ocaml t = t.ocaml
 
+let parameters_main_modules parameters =
+  let open Resolve.Memo.O in
+  let* parameters = parameters in
+  Resolve.Memo.List.map parameters ~f:(fun param ->
+    let+ main = Lib.main_module_name param in
+    match main with
+    | Some main -> main
+    | None ->
+      Code_error.raise
+        "Expected library parameter to have a main module"
+        [ "param", Lib.to_dyn param ])
+;;
+
 let create
       ~super_context
       ~scope
@@ -143,6 +158,7 @@ let create
       ~package
       ~melange_package_name
       ?(implements = Virtual_rules.no_implements)
+      ?parameters
       ?modes
       ?bin_annot
       ?loc
@@ -166,6 +182,11 @@ let create
       in
       requires_compile, requires_hidden
   in
+  let parameters =
+    match parameters with
+    | None -> Resolve.Memo.return []
+    | Some parameters -> parameters_main_modules parameters
+  in
   let sandbox = Sandbox_config.no_special_requirements in
   let modes =
     let default =
@@ -201,6 +222,7 @@ let create
   ; requires_hidden = hidden_requires
   ; requires_link
   ; implements
+  ; parameters
   ; includes =
       Includes.make ~project ~opaque ~direct_requires ~hidden_requires ocaml.lib_config
   ; preprocessing

src/dune_rules/compilation_context.mli

@@ -34,6 +34,7 @@ val create
   -> package:Package.t option
   -> melange_package_name:Lib_name.t option
   -> ?implements:Virtual_rules.t
+  -> ?parameters:Lib.t list Resolve.Memo.t
   -> ?modes:Mode_conf.Set.Details.t Lib_mode.Map.t
   -> ?bin_annot:bool
   -> ?loc:Loc.t
@@ -57,6 +58,7 @@ val flags : t -> Ocaml_flags.t
 val requires_link : t -> Lib.t list Resolve.Memo.t
 val requires_hidden : t -> Lib.t list Resolve.Memo.t
 val requires_compile : t -> Lib.t list Resolve.Memo.t
+val parameters : t -> Module_name.t list Resolve.Memo.t
 val includes : t -> Command.Args.without_targets Command.Args.t Lib_mode.Cm_kind.Map.t
 val preprocessing : t -> Pp_spec.t
 val opaque : t -> bool

src/dune_rules/dune_package.ml

@@ -92,6 +92,7 @@ module Lib = struct
     let sub_systems = Lib_info.sub_systems info in
     let plugins = Lib_info.plugins info in
     let requires = Lib_info.requires info in
+    let parameters = Lib_info.parameters info in
     let foreign_objects =
       match Lib_info.foreign_objects info with
       | External e -> e
@@ -138,6 +139,7 @@ module Lib = struct
        ; paths "jsoo_runtime" jsoo_runtime
        ; paths "wasmoo_runtime" wasmoo_runtime
        ; Lib_dep.L.field_encode requires ~name:"requires"
+       ; field_l "parameters" (no_loc Lib_name.encode) parameters
        ; libs "ppx_runtime_deps" ppx_runtime_deps
        ; field_o "implements" (no_loc Lib_name.encode) implements
        ; field_o "default_implementation" (no_loc Lib_name.encode) default_implementation
@@ -228,6 +230,7 @@ module Lib = struct
        and+ wasmoo_runtime = paths "wasmoo_runtime"
        and+ melange_runtime_deps = paths "melange_runtime_deps"
        and+ requires = field_l "requires" (Lib_dep.decode ~allow_re_export:true)
+       and+ parameters = field "parameters" ~default:[] (repeat (located Lib_name.decode))
        and+ ppx_runtime_deps = libs "ppx_runtime_deps"
        and+ sub_systems = Sub_system_info.record_parser
        and+ orig_src_dir = field_o "orig_src_dir" path
@@ -280,6 +283,7 @@ module Lib = struct
            ~main_module_name
            ~sub_systems
            ~requires
+           ~parameters
            ~foreign_objects
            ~public_headers
            ~plugins

src/dune_rules/findlib.ml

@@ -141,6 +141,7 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc
     let dune_version = None in
     let virtual_deps = [] in
     let implements = None in
+    let parameters = [] in
     let orig_src_dir = None in
     let main_module_name : Lib_info.Main_module_name.t = This None in
     let enabled = Memo.return Lib_info.Enabled_status.Normal in
@@ -253,6 +254,7 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc
       ~main_module_name
       ~sub_systems
       ~requires
+      ~parameters
       ~foreign_objects
       ~public_headers
       ~plugins

src/dune_rules/lib.ml

@@ -247,6 +247,30 @@ module Error = struct
           (Lib_name.to_string lib)
       ]
   ;;
+
+  let expected_parameter ~loc ~name =
+    make
+      ~loc
+      [ Pp.textf "Expected %S to be a library parameter." (Lib_name.to_string name) ]
+  ;;
+
+  let duplicate_parameters ~loc name name' =
+    make
+      ~loc
+      [ Pp.textf
+          "Duplicate library parameters: %S and %S."
+          (Lib_name.to_string name)
+          (Lib_name.to_string name')
+      ]
+  ;;
+
+  let missing_parameter ~loc p =
+    let name = Lib_name.to_string (Lib_info.name p) in
+    make_resolve
+      ~loc
+      [ Pp.textf "Parameter %S is missing." name ]
+      ~hints:[ Pp.textf "Add (parameters %s)" name ]
+  ;;
 end
 
 (* Types *)
@@ -337,6 +361,7 @@ module T = struct
     ; ppx_runtime_deps : t list Resolve.t
     ; pps : t list Resolve.t
     ; resolved_selects : Resolved_select.t list Resolve.t
+    ; parameters : t list Resolve.t
     ; implements : t Resolve.t option
     ; project : Dune_project.t option
     ; (* these fields cannot be forced until the library is instantiated *)
@@ -430,6 +455,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 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
@@ -456,6 +482,21 @@ let main_module_name t =
      | From _ -> assert false)
 ;;
 
+module Parameterized = struct
+  let check ~loc ~parameters lib =
+    let open Resolve.O in
+    let* lib = lib in
+    let* required_parameters = lib.parameters in
+    let+ () =
+      Resolve.List.iter required_parameters ~f:(function
+        | param when not (List.exists parameters ~f:(equal param)) ->
+          Error.missing_parameter ~loc param.info
+        | _ -> Resolve.return ())
+    in
+    lib
+  ;;
+end
+
 let wrapped t =
   match Lib_info.wrapped t.info with
   | None -> Resolve.Memo.return None
@@ -861,6 +902,7 @@ module rec Resolve_names : sig
     :  db
     -> Lib_dep.t list
     -> private_deps:private_deps
+    -> parameters:t list
     -> pps:(Loc.t * Lib_name.t) list
     -> dune_version:Dune_lang.Syntax.Version.t option
     -> Resolved.t Memo.t
@@ -898,6 +940,32 @@ end = struct
       >>| Package.Name.Map.of_list_exn)
   ;;
 
+  let resolve_parameters db ~private_deps info =
+    let open Resolve.Memo.O in
+    let* parameters =
+      Resolve.Memo.List.filter_map (Lib_info.parameters info) ~f:(fun (loc, name) ->
+        let* lib = Resolve.Memo.lift_memo (resolve_dep db ~private_deps (loc, name)) in
+        match lib with
+        | None -> Resolve.Memo.return None
+        | Some lib ->
+          let* lib = Resolve.Memo.lift lib in
+          (match Lib_info.kind lib.info with
+           | Parameter -> Resolve.Memo.return (Some (loc, name, lib))
+           | _ -> Error.expected_parameter ~loc ~name))
+    in
+    let parameters =
+      List.stable_sort parameters ~compare:(fun (_, _, a) (_, _, b) -> compare a b)
+    in
+    let rec check_duplicates = function
+      | [] | [ _ ] -> Resolve.Memo.return ()
+      | (_, name, p) :: (loc, name', p') :: _ when p = p' ->
+        Error.duplicate_parameters ~loc name name'
+      | _ :: ps -> check_duplicates ps
+    in
+    let+ () = check_duplicates parameters in
+    List.map parameters ~f:(fun (_, _, param) -> param)
+  ;;
+
   let instantiate_impl db (name, info, hidden) =
     let db = Lazy.force db in
     let open Memo.O in
@@ -925,6 +993,7 @@ end = struct
                in this position."
           ]
     in
+    let* parameters = resolve_parameters db ~private_deps info in
     let* resolved =
       let open Resolve.Memo.O in
       let* pps =
@@ -935,9 +1004,10 @@ end = struct
         |> Instrumentation.with_instrumentation ~instrumentation_backend
         >>| Preprocess.Per_module.pps
       in
+      let* parameters = Resolve.Memo.lift parameters in
       let dune_version = Lib_info.dune_version info in
       Lib_info.requires info
-      |> resolve_deps_and_add_runtime_deps db ~private_deps ~dune_version ~pps
+      |> resolve_deps_and_add_runtime_deps db ~private_deps ~parameters ~dune_version ~pps
       |> Memo.map ~f:Resolve.return
     in
     let* implements =
@@ -1067,6 +1137,7 @@ end = struct
          ; resolved_selects
          ; re_exports
          ; implements
+         ; parameters
          ; default_implementation
          ; project
          ; sub_systems =
@@ -1398,17 +1469,23 @@ end = struct
     res, { Resolved_select.src_fn; dst_fn = result_fn }
   ;;
 
-  let resolve_complex_deps db deps ~private_deps : Resolved.deps Memo.t =
+  let resolve_complex_deps db deps ~private_deps ~parameters : Resolved.deps Memo.t =
+    let open Memo.O in
+    let resolve_parameterized_dep (loc, lib) =
+      resolve_dep db (loc, lib) ~private_deps
+      >>| function
+      | None -> None
+      | Some dep -> Some (Parameterized.check ~loc ~parameters dep)
+    in
     Memo.List.fold_left ~init:Resolved.Builder.empty deps ~f:(fun acc (dep : Lib_dep.t) ->
-      let open Memo.O in
       match dep with
       | Re_export lib ->
-        resolve_dep db lib ~private_deps
+        resolve_parameterized_dep lib
         >>| (function
          | None -> acc
          | Some lib -> Resolved.Builder.add_re_exports acc lib)
       | Direct lib ->
-        resolve_dep db lib ~private_deps
+        resolve_parameterized_dep lib
         >>| (function
          | None -> acc
          | Some lib -> Resolved.Builder.add_resolved acc lib)
@@ -1475,6 +1552,7 @@ end = struct
         db
         { Resolved.resolved; selects; re_exports }
         ~private_deps
+        ~parameters
         ~pps
         ~dune_version
     : Resolved.t Memo.t
@@ -1485,15 +1563,22 @@ end = struct
       let open Resolve.Memo.O in
       let* resolved = Memo.return resolved in
       let* runtime_deps = runtime_deps in
-      re_exports_closure (resolved @ runtime_deps)
+      re_exports_closure (resolved @ runtime_deps @ parameters)
     and+ pps = pps in
     { Resolved.requires; pps; selects; re_exports }
   ;;
 
-  let resolve_deps_and_add_runtime_deps db deps ~private_deps ~pps ~dune_version =
+  let resolve_deps_and_add_runtime_deps
+        db
+        deps
+        ~private_deps
+        ~parameters
+        ~pps
+        ~dune_version
+    =
     let open Memo.O in
-    resolve_complex_deps db ~private_deps deps
-    >>= add_pp_runtime_deps db ~private_deps ~dune_version ~pps
+    resolve_complex_deps db ~private_deps ~parameters deps
+    >>= add_pp_runtime_deps db ~private_deps ~parameters ~dune_version ~pps
   ;;
 
   (* Compute transitive closure of libraries to figure which ones will trigger
@@ -2058,6 +2143,7 @@ module DB = struct
           t
           deps
           ~pps
+          ~parameters:[]
           ~private_deps:Allow_all
           ~dune_version:(Some dune_version))
     in
@@ -2193,6 +2279,11 @@ let to_dune_lib
     use_public_name
       ~info_field:(Lib_info.implements info)
       ~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)
   and+ default_implementation =
     use_public_name
       ~info_field:(Lib_info.default_implementation info)
@@ -2223,6 +2314,7 @@ let to_dune_lib
       ~foreign_objects
       ~obj_dir
       ~implements
+      ~parameters
       ~default_implementation
       ~sub_systems
       ~modules

src/dune_rules/lib.mli

@@ -12,6 +12,7 @@ val to_dyn : t -> Dyn.t
 val name : t -> Lib_name.t
 
 val implements : t -> t Resolve.Memo.t option
+val parameters : t -> t list Resolve.Memo.t
 
 (** [is_local t] returns [true] whenever [t] is defined in the local workspace *)
 val is_local : t -> bool