feat(oxcaml): instantiate parameterized libraries

Signed-off-by: ArthurW <[email protected]>

Author: art-w

bin/describe/describe_external_lib_deps.ml

@@ -97,7 +97,7 @@ let resolve_lib_deps db lib_deps =
   let open Memo.O in
   Memo.parallel_map lib_deps ~f:(fun (lib : Lib_dep.t) ->
     match lib with
-    | Direct (_, name) | Re_export (_, name) ->
+    | Direct (_, name) | Re_export (_, name) | Instantiate { lib = name; _ } ->
       let+ v = resolve_lib db name Kind.Required in
       [ v ]
     | Select select ->

src/dune_lang/lib_dep.ml

@@ -98,6 +98,12 @@ type t =
   | Direct of (Loc.t * Lib_name.t)
   | Re_export of (Loc.t * Lib_name.t)
   | Select of Select.t
+  | Instantiate of
+      { loc : Loc.t
+      ; lib : Lib_name.t
+      ; arguments : (Loc.t * Lib_name.t) list
+      ; new_name : Module_name.t option
+      }
 
 let equal = Poly.equal
 
@@ -107,6 +113,13 @@ let to_dyn =
   | Direct (_, name) -> Lib_name.to_dyn name
   | Re_export (_, name) -> variant "re_export" [ Lib_name.to_dyn name ]
   | Select s -> variant "select" [ Select.to_dyn s ]
+  | Instantiate { lib; arguments; new_name; loc = _ } ->
+    variant
+      "instantiate"
+      [ Lib_name.to_dyn lib
+      ; list (fun (_, arg) -> Lib_name.to_dyn arg) arguments
+      ; option Module_name.to_dyn new_name
+      ]
 ;;
 
 let direct x = Direct x
@@ -126,6 +139,19 @@ let decode ~allow_re_export =
            , let+ select = Select.decode in
              Select select )
          ]
+       <|> enter
+             ((* TODO art-w: oxcaml extension is not recognized by installed
+                 libraries, which are missing a `(using oxcaml 0.1)`
+              let+ () = Syntax.since Oxcaml.syntax (0, 1) *)
+              let+ () = Syntax.since Stanza.syntax (3, 20)
+              and+ loc, lib = located Lib_name.decode
+              and+ arguments, new_name =
+                until_keyword
+                  ":as"
+                  ~before:(located Lib_name.decode)
+                  ~after:Module_name.decode
+              in
+              Instantiate { loc; lib; arguments; new_name })
        <|> let+ loc, name = located Lib_name.decode in
            Direct (loc, name))
   in
@@ -144,11 +170,22 @@ let encode =
     Code_error.raise
       "Lib_dep.encode: cannot encode select"
       [ "select", Select.to_dyn select ]
+  | Instantiate { lib; arguments; new_name; loc = _ } ->
+    let as_name =
+      match new_name with
+      | None -> []
+      | Some new_name -> [ string ":as"; Module_name.encode new_name ]
+    in
+    list
+      sexp
+      ((Lib_name.encode lib :: List.map arguments ~f:(fun (_, arg) -> Lib_name.encode arg))
+       @ as_name)
 ;;
 
 module L = struct
   type kind =
     | Required
+    | Required_multiple
     | Optional
     | Forbidden
 
@@ -186,12 +223,21 @@ module L = struct
              [ Pp.textf
                  "library %S is present both as a forbidden and required dependency"
                  (Lib_name.to_string name)
+             ]
+         | Required_multiple, Required_multiple -> acc
+         | Required_multiple, _ | _, Required_multiple ->
+           User_error.raise
+             ~loc
+             [ Pp.textf
+                 "parameterized library %S is present in multiple forms"
+                 (Lib_name.to_string name)
              ])
     in
     ignore
       (List.fold_left t ~init:Lib_name.Map.empty ~f:(fun acc x ->
          match x with
          | Re_export (_, s) | Direct (_, s) -> add Required s acc
+         | Instantiate { lib = s; _ } -> add Required_multiple s acc
          | Select { choices; _ } ->
            List.fold_left choices ~init:acc ~f:(fun acc (c : Select.Choice.t) ->
              let acc = Lib_name.Set.fold c.required ~init:acc ~f:(add Optional) in

src/dune_lang/lib_dep.mli

@@ -22,6 +22,12 @@ type t =
   | Direct of (Loc.t * Lib_name.t)
   | Re_export of (Loc.t * Lib_name.t)
   | Select of Select.t
+  | Instantiate of
+      { loc : Loc.t
+      ; lib : Lib_name.t
+      ; arguments : (Loc.t * Lib_name.t) list
+      ; new_name : Module_name.t option
+      }
 
 val equal : t -> t -> bool
 val to_dyn : t -> Dyn.t

src/dune_rules/compilation_context.ml

@@ -89,6 +89,7 @@ type t =
   ; requires_link : Lib.t list Resolve.t Memo.Lazy.t
   ; implements : Virtual_rules.t
   ; parameters : Module_name.t list Resolve.Memo.t
+  ; instances : Lib.Parameterized.instance list Resolve.Memo.t
   ; includes : Includes.t
   ; preprocessing : Pp_spec.t
   ; opaque : bool
@@ -162,6 +163,7 @@ let create
       ?modes
       ?bin_annot
       ?loc
+      ?instances
       ()
   =
   let project = Scope.project scope in
@@ -187,6 +189,11 @@ let create
     | None -> Resolve.Memo.return []
     | Some parameters -> parameters_main_modules parameters
   in
+  let instances =
+    match instances with
+    | None -> Resolve.Memo.return []
+    | Some instances -> instances
+  in
   let sandbox = Sandbox_config.no_special_requirements in
   let modes =
     let default =
@@ -236,6 +243,7 @@ let create
   ; bin_annot
   ; loc
   ; ocaml
+  ; instances
   }
 ;;
 
@@ -244,7 +252,7 @@ let alias_and_root_module_flags =
   fun base -> Ocaml_flags.append_common base extra
 ;;
 
-let for_alias_module t alias_module =
+let for_alias_module ~has_instances t alias_module =
   let keep_flags = Modules.With_vlib.is_stdlib_alias (modules t) alias_module in
   let flags =
     if keep_flags
@@ -256,6 +264,15 @@ let for_alias_module t alias_module =
       let profile = Super_context.context t.super_context |> Context.profile in
       Ocaml_flags.default ~dune_version ~profile)
   in
+  let flags =
+    if has_instances
+    then
+      (* If the alias file instantiates parameterized libraries,
+         the [misplace-attribute] warning is currently raised on
+         [@jane.non_erasable.instances] *)
+      Ocaml_flags.append_common flags [ "-w"; "-53" ]
+    else flags
+  in
   let sandbox =
     (* If the compiler reads the cmi for module alias even with [-w -49
        -no-alias-deps], we must sandbox the build of the alias module since the
@@ -342,3 +359,4 @@ let for_plugin_executable t ~embed_in_plugin_libraries =
 let without_bin_annot t = { t with bin_annot = false }
 let set_obj_dir t obj_dir = { t with obj_dir }
 let set_modes t ~modes = { t with modes }
+let instances t = t.instances

src/dune_rules/compilation_context.mli

@@ -38,11 +38,12 @@ val create
   -> ?modes:Mode_conf.Set.Details.t Lib_mode.Map.t
   -> ?bin_annot:bool
   -> ?loc:Loc.t
+  -> ?instances:Lib.Parameterized.instance list Resolve.Memo.t
   -> unit
   -> t Memo.t
 
 (** Return a compilation context suitable for compiling the alias module. *)
-val for_alias_module : t -> Module.t -> t
+val for_alias_module : has_instances:bool -> t -> Module.t -> t
 
 val super_context : t -> Super_context.t
 val context : t -> Context.t
@@ -90,3 +91,4 @@ val dep_graphs : t -> Dep_graph.t Ml_kind.Dict.t
 val loc : t -> Loc.t option
 val set_obj_dir : t -> Path.Build.t Obj_dir.t -> t
 val set_modes : t -> modes:Lib_mode.Map.Set.t -> t
+val instances : t -> Lib.Parameterized.instance list Resolve.Memo.t

src/dune_rules/dir_contents.ml

@@ -129,7 +129,7 @@ end = struct
        dependencies *)
     List.filter_map libraries ~f:(fun dep ->
       match (dep : Lib_dep.t) with
-      | Re_export _ | Direct _ -> None
+      | Re_export _ | Direct _ | Instantiate _ -> None
       | Select s -> Some s.result_fn)
   ;;
 

src/dune_rules/dune_package.ml

@@ -254,6 +254,7 @@ module Lib = struct
            | Public (_, _) -> Lib_info.Status.Installed
          in
          let version = None in
+         let local_main_module_name = main_module_name in
          let main_module_name = Lib_info.Inherited.This main_module_name in
          let foreign_objects = Lib_info.Source.External foreign_objects in
          let public_headers = Lib_info.File_deps.External public_headers in
@@ -281,6 +282,7 @@ module Lib = struct
            ~version
            ~synopsis
            ~main_module_name
+           ~local_main_module_name
            ~sub_systems
            ~requires
            ~parameters

src/dune_rules/exe_rules.ml

@@ -184,6 +184,7 @@ let executables_rules
   let* cctx =
     let requires_compile = Lib.Compile.direct_requires compile_info in
     let requires_link = Lib.Compile.requires_link compile_info in
+    let instances = Lib.Compile.instances compile_info in
     let js_of_ocaml =
       Js_of_ocaml.Mode.Pair.mapi js_of_ocaml ~f:(fun mode x ->
         Option.some_if
@@ -205,6 +206,7 @@ let executables_rules
       ~opaque:Inherit_from_settings
       ~melange_package_name:None
       ~package:exes.package
+      ~instances
   in
   let lib_config = ocaml.lib_config in
   let* requires_compile = Compilation_context.requires_compile cctx in

src/dune_rules/findlib.ml

@@ -143,6 +143,7 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc
     let implements = None in
     let parameters = [] in
     let orig_src_dir = None in
+    let local_main_module_name = 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
     let requires =
@@ -252,6 +253,7 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc
       ~version
       ~synopsis
       ~main_module_name
+      ~local_main_module_name
       ~sub_systems
       ~requires
       ~parameters

src/dune_rules/gen_rules.ml

@@ -533,7 +533,14 @@ let gen_rules_regular_directory (sctx : Super_context.t Memo.t) ~src_dir ~compon
                 (* XXX sync this list with the pattern matches above. It's quite ugly
                    we need this, we should rewrite this code to avoid this. *)
                 Filename.Set.of_list
-                  [ ".js"; "_doc"; "_doc_new"; ".ppx"; ".dune"; ".topmod" ]
+                  [ ".js"
+                  ; "_doc"
+                  ; "_doc_new"
+                  ; ".ppx"
+                  ; ".dune"
+                  ; ".topmod"
+                  ; ".parameterized"
+                  ]
             in
             Filename.Set.union automatic toplevel
           in
@@ -621,6 +628,10 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t =
       ~dir
       (Subdir_set.of_set (Filename.Set.of_list [ "cc_vendor" ]))
       (fun () -> Configurator_rules.gen_rules ctx)
+  | ".parameterized" :: rest ->
+    let* sctx = sctx
+    and* scope = Scope.DB.find_by_dir dir in
+    Parameterized_rules.gen_rules ~sctx ~scope ~dir rest
   | _ -> gen_rules_regular_directory sctx ~src_dir ~components ~dir
 ;;