Variants v2

* Explicit computation of variant list at virtual library build time * Implicit detection of local variants * Explicit declaration of external variants Signed-off-by: Lucas Pluvinage <[email protected]>
ocaml · May 20, 2019 · edf681c · edf681c
1 parent 620e8e8
commit edf681c
Show file tree

Hide file tree

Showing 61 changed files with 514 additions and 182 deletions.
diff --git a/src/dune_file.ml b/src/dune_file.ml
@@ -55,7 +55,7 @@ let library_variants =
   let syntax =
     Syntax.create ~name:"library_variants"
       ~desc:"the experimental library variants feature."
-      [ (0, 1) ]
+      [ (0, 2) ]
   in
   Dune_project.Extension.register_simple ~experimental:true
     syntax (Dune_lang.Decoder.return []);
@@ -998,7 +998,7 @@ module Library = struct
            "A library cannot be both virtual and implement %s"
            (Lib_name.to_string impl));
        match virtual_modules, default_implementation with
-       | None, Some (loc, _) ->
+       | None, (Some (loc, _)) ->
          of_sexp_error loc
            "Only virtual libraries can specify a default implementation."
        | _ -> ();
@@ -2082,6 +2082,29 @@ module Toplevel = struct
     )
 end
 
+module Variant_implementation = struct
+  type t =
+    { implementation : Lib_name.t
+    ; virtual_lib : Lib_name.t
+    ; variant : Variant.t
+    ; project : Dune_project.t
+    ; loc : Loc.t
+    }
+
+  let decode =
+    let open Stanza.Decoder in
+    let+ (loc, (virtual_lib, variant,implementation)) = located
+      (triple Lib_name.decode Variant.decode Lib_name.decode)
+    and+ project = Dune_project.get_exn ()
+    in
+    { implementation
+    ; virtual_lib
+    ; variant
+    ; project
+    ; loc
+    }
+end
+
 module Copy_files = struct
   type t = { add_line_directive : bool
            ; glob : String_with_vars.t
@@ -2125,16 +2148,17 @@ module Include_subdirs = struct
 end
 
 type Stanza.t +=
-  | Library         of Library.t
-  | Executables     of Executables.t
-  | Rule            of Rule.t
-  | Install         of File_binding.Unexpanded.t Install_conf.t
-  | Alias           of Alias_conf.t
-  | Copy_files      of Copy_files.t
-  | Documentation   of Documentation.t
-  | Tests           of Tests.t
-  | Include_subdirs of Loc.t * Include_subdirs.t
-  | Toplevel        of Toplevel.t
+  | Library                of Library.t
+  | Executables            of Executables.t
+  | Rule                   of Rule.t
+  | Install                of File_binding.Unexpanded.t Install_conf.t
+  | Alias                  of Alias_conf.t
+  | Copy_files             of Copy_files.t
+  | Documentation          of Documentation.t
+  | Tests                  of Tests.t
+  | Include_subdirs        of Loc.t * Include_subdirs.t
+  | Toplevel               of Toplevel.t
+  | Variant_implementation of Variant_implementation.t
 
 module Stanzas = struct
   type t = Stanza.t list
@@ -2203,6 +2227,10 @@ module Stanzas = struct
       (let+ () = Syntax.since Stanza.syntax (1, 0)
        and+ t = Tests.single in
        [Tests t])
+    ; "external_variant",
+      (let+ () = Syntax.since library_variants (0, 2)
+       and+ t = Variant_implementation.decode in
+       [Variant_implementation t])
     ; "env",
       (let+ x = Dune_env.Stanza.decode in
        [Dune_env.T x])

diff --git a/src/dune_file.mli b/src/dune_file.mli
@@ -450,22 +450,33 @@ module Toplevel : sig
     }
 end
 
+module Variant_implementation : sig
+  type t =
+    { implementation : Lib_name.t
+    ; virtual_lib : Lib_name.t
+    ; variant : Variant.t
+    ; project : Dune_project.t
+    ; loc : Loc.t
+    }
+end
+
 module Include_subdirs : sig
   type qualification = Unqualified | Qualified
   type t = No | Include of qualification
 end
 
 type Stanza.t +=
-  | Library         of Library.t
-  | Executables     of Executables.t
-  | Rule            of Rule.t
-  | Install         of File_binding.Unexpanded.t Install_conf.t
-  | Alias           of Alias_conf.t
-  | Copy_files      of Copy_files.t
-  | Documentation   of Documentation.t
-  | Tests           of Tests.t
-  | Include_subdirs of Loc.t * Include_subdirs.t
-  | Toplevel        of Toplevel.t
+  | Library                of Library.t
+  | Executables            of Executables.t
+  | Rule                   of Rule.t
+  | Install                of File_binding.Unexpanded.t Install_conf.t
+  | Alias                  of Alias_conf.t
+  | Copy_files             of Copy_files.t
+  | Documentation          of Documentation.t
+  | Tests                  of Tests.t
+  | Include_subdirs        of Loc.t * Include_subdirs.t
+  | Toplevel               of Toplevel.t
+  | Variant_implementation of Variant_implementation.t
 
 val stanza_package : Stanza.t -> Package.t option
 

diff --git a/src/dune_package.ml b/src/dune_package.ml
@@ -19,9 +19,9 @@ module Lib = struct
     ; ppx_runtime_deps : (Loc.t * Lib_name.t) list
     ; sub_systems      : 'sub_system Sub_system_name.Map.t
     ; virtual_         : bool
-    ; implements       : (Loc.t * Lib_name.t) option
-    ; variant          : Variant.t option
+    ; known_implementations : (Loc.t * (Variant.t * Lib_name.t)) list
     ; default_implementation  : (Loc.t * Lib_name.t)  option
+    ; implements       : (Loc.t * Lib_name.t) option
     ; modules          : Lib_modules.t option
     ; main_module_name : Module.Name.t option
     ; requires         : (Loc.t * Lib_name.t) list
@@ -33,8 +33,8 @@ module Lib = struct
 
   let make ~loc ~kind ~name ~synopsis ~archives ~plugins ~foreign_objects
         ~foreign_archives ~jsoo_runtime ~main_module_name ~sub_systems
-        ~requires ~ppx_runtime_deps ~implements ~variant
-        ~default_implementation ~virtual_ ~modules ~modes
+        ~requires ~ppx_runtime_deps ~implements
+        ~default_implementation ~virtual_ ~known_implementations ~modules ~modes
         ~version ~orig_src_dir ~obj_dir
         ~special_builtin_support =
     let dir = Obj_dir.dir obj_dir in
@@ -60,11 +60,11 @@ module Lib = struct
     ; requires
     ; ppx_runtime_deps
     ; implements
-    ; variant
-    ; default_implementation
     ; version
     ; orig_src_dir
     ; virtual_
+    ; known_implementations
+    ; default_implementation
     ; modules
     ; modes
     ; obj_dir
@@ -85,8 +85,8 @@ module Lib = struct
   let encode ~package_root
         { loc = _ ; kind ; synopsis ; name ; archives ; plugins
         ; foreign_objects ; foreign_archives ; jsoo_runtime ; requires
-        ; ppx_runtime_deps ; sub_systems ; virtual_
-        ; implements ; variant ; default_implementation
+        ; ppx_runtime_deps ; sub_systems ; virtual_ ; known_implementations
+        ; implements ; default_implementation
         ; main_module_name ; version = _; obj_dir ; orig_src_dir
         ; modules ; modes ; special_builtin_support
         } =
@@ -111,7 +111,8 @@ module Lib = struct
     ; libs "requires" requires
     ; libs "ppx_runtime_deps" ppx_runtime_deps
     ; field_o "implements" (no_loc Lib_name.encode) implements
-    ; field_o "variant" Variant.encode variant
+    ; field_l "known_implementations"
+        (no_loc (pair Variant.encode Lib_name.encode)) known_implementations
     ; field_o "default_implementation"
         (no_loc Lib_name.encode) default_implementation
     ; field_o "main_module_name" Module.Name.encode main_module_name
@@ -139,7 +140,6 @@ module Lib = struct
     record (
       let* main_module_name = field_o "main_module_name" Module.Name.decode in
       let* implements = field_o "implements" (located Lib_name.decode) in
-      let* variant = field_o "variant" Variant.decode in
       let* default_implementation =
         field_o "default_implementation" (located Lib_name.decode) in
       let* name = field "name" Lib_name.decode in
@@ -162,14 +162,18 @@ module Lib = struct
       and+ requires = libs "requires"
       and+ ppx_runtime_deps = libs "ppx_runtime_deps"
       and+ virtual_ = field_b "virtual"
+      and+ known_implementations = field_l "known_implementations"
+                                     (located (pair Variant.decode
+                                                 Lib_name.decode))
       and+ sub_systems = Sub_system_info.record_parser ()
       and+ orig_src_dir = field_o "orig_src_dir" path
       and+ modules = field_o "modules" (Lib_modules.decode
-                                          ~implements:(Option.is_some implements) ~obj_dir)
-       and+ special_builtin_support =
-         field_o "special_builtin_support"
-           (Syntax.since Stanza.syntax (1, 10) >>>
-            Dune_file.Library.Special_builtin_support.decode)
+                                          ~implements:(Option.is_some
+                                                         implements) ~obj_dir)
+      and+ special_builtin_support =
+        field_o "special_builtin_support"
+          (Syntax.since Stanza.syntax (1, 10) >>>
+           Dune_file.Library.Special_builtin_support.decode)
       in
       let modes = Mode.Dict.Set.of_list modes in
       { kind
@@ -184,8 +188,8 @@ module Lib = struct
       ; requires
       ; ppx_runtime_deps
       ; implements
-      ; variant
       ; default_implementation
+      ; known_implementations
       ; sub_systems
       ; main_module_name
       ; virtual_
@@ -215,7 +219,7 @@ module Lib = struct
   let foreign_archives t = t.foreign_archives
   let requires t = t.requires
   let implements t = t.implements
-  let variant t = t.variant
+  let known_implementations t = t.known_implementations
   let default_implementation t = t.default_implementation
   let modes t = t.modes
   let special_builtin_support t = t.special_builtin_support

diff --git a/src/dune_package.mli b/src/dune_package.mli
@@ -23,7 +23,7 @@ module Lib : sig
   val plugins : _ t -> Path.t list Mode.Dict.t
   val jsoo_runtime : _ t -> Path.t list
   val implements : _ t -> (Loc.t * Lib_name.t) option
-  val variant : _ t -> Variant.t option
+  val known_implementations : _ t -> (Loc.t * (Variant.t * Lib_name.t)) list
   val default_implementation : _ t -> (Loc.t * Lib_name.t) option
   val special_builtin_support
     : _ t -> Dune_file.Library.Special_builtin_support.t option
@@ -51,9 +51,9 @@ module Lib : sig
     -> requires:(Loc.t * Lib_name.t) list
     -> ppx_runtime_deps:(Loc.t * Lib_name.t) list
     -> implements:(Loc.t * Lib_name.t) option
-    -> variant: (Variant.t) option
     -> default_implementation: (Loc.t * Lib_name.t) option
     -> virtual_:bool
+    -> known_implementations: (Loc.t * (Variant.t * Lib_name.t)) list
     -> modules:Lib_modules.t option
     -> modes:Mode.Dict.Set.t
     -> version:string option

diff --git a/src/findlib.ml b/src/findlib.ml
@@ -231,7 +231,7 @@ module Package = struct
       ~ppx_runtime_deps:(List.map ~f:add_loc (ppx_runtime_deps t))
       ~virtual_:false
       ~implements:None
-      ~variant:None
+      ~known_implementations:[]
       ~default_implementation:None
       ~modules:None
       ~main_module_name:None (* XXX remove *)

diff --git a/src/gen_rules.ml b/src/gen_rules.ml
@@ -286,11 +286,47 @@ module type Gen = sig
   val sctx : Super_context.t
 end
 
-let relevant_stanzas pkgs stanzas =
-  List.filter stanzas ~f:(fun stanza ->
+let map_variant relevant_lib_names lib =
+  match lib with
+  | { Library.variant=(Some variant)
+    ; implements=(Some (loc, vlib))
+    ; project
+    ; _} as conf ->
+    Option.some_if
+      (Lib_name.Set.mem relevant_lib_names vlib)
+      (Variant_implementation
+         { implementation = (Library.best_name conf)
+         ; virtual_lib = vlib
+         ; variant
+         ; project
+         ; loc
+         })
+  | _ -> None
+
+let map_stanza relevant_lib_names = function
+  | Library lib -> map_variant relevant_lib_names lib
+  | _ -> None
+
+let build_name_set pkgs stanzas =
+  stanzas
+  |> List.filter_map
+       ~f:(function
+         | Library
+             ({ public = Some { package; _ }
+              ; _
+              } as conf)
+           when (Package.Name.Set.mem pkgs package.name) ->
+           Some (Library.best_name conf)
+         | _ -> None)
+  |> Lib_name.Set.of_list
+
+let relevant_stanzas relevant_lib_names pkgs stanzas =
+  List.filter_map stanzas ~f:(fun stanza ->
     match Dune_file.stanza_package stanza with
-    | Some package -> Package.Name.Set.mem pkgs package.name
-    | None -> true)
+    | Some package when Package.Name.Set.mem pkgs package.name -> Some stanza
+    | None -> Some stanza
+    | Some _ -> map_stanza relevant_lib_names stanza
+  )
 
 let gen ~contexts
       ?(external_lib_deps_mode=false)
@@ -315,14 +351,20 @@ let gen ~contexts
         Fiber.Ivar.read (Hashtbl.find_exn sctxs h.name)
         >>| Option.some
     in
+
     let stanzas () =
       let+ stanzas = Dune_load.Dune_files.eval ~context dune_files in
       match only_packages with
       | None -> stanzas
       | Some pkgs ->
+        let relevant_lib_names =
+          stanzas
+          |> List.concat_map ~f:(fun (dir_conf : Dune_load.Dune_file.t) -> dir_conf.stanzas)
+          |> build_name_set pkgs
+        in
         List.map stanzas ~f:(fun (dir_conf : Dune_load.Dune_file.t) ->
           { dir_conf with
-            stanzas = relevant_stanzas pkgs dir_conf.stanzas
+            stanzas = relevant_stanzas relevant_lib_names pkgs dir_conf.stanzas
           })
     in
     let* (host, stanzas) = Fiber.fork_and_join host stanzas in