Add virtual implementation info to lib info

Only support internal vlibs and implementations for now

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

src/dir_contents.ml

@@ -231,8 +231,7 @@ end = struct
 
   let make (lib : Library.t) ~dir (modules : Module.Name_map.t)
         ~virtual_modules =
-    let main_module_name =
-      Module.Name.of_string (Lib_name.Local.to_string lib.name) in
+    let main_module_name = Library.main_module_name lib in
     let (modules, wrapped_compat) =
       let wrap_modules modules =
         let open Module.Name.Infix in

src/dune_file.ml

@@ -916,7 +916,7 @@ module Library = struct
     ; no_keep_locs             : bool
     ; dune_version             : Syntax.Version.t
     ; virtual_modules          : Ordered_set_lang.t option
-    ; implements               : (Loc.t * string) option
+    ; implements               : (Loc.t * Lib_name.t) option
     }
 
   let dparse =
@@ -958,7 +958,7 @@ module Library = struct
        and implements =
          field_o "implements" (
            Syntax.since Variants.syntax (0, 1)
-           >>= fun () -> (located string))
+           >>= fun () -> located Lib_name.dparse)
        in
        let name =
          let open Syntax.Version.Infix in
@@ -993,7 +993,8 @@ module Library = struct
          of_sexp_errorf
            (Ordered_set_lang.loc virtual_modules
            |> Option.value_exn)
-           "A library cannot be both virtual and implement %s" impl);
+           "A library cannot be both virtual and implement %s"
+           (Lib_name.to_string impl));
        begin match virtual_modules, wrapped, implements with
        | Some _, Some (loc, Wrapped.Simple false), _ ->
          of_sexp_error loc "A virtual library must be wrapped"
@@ -1052,6 +1053,9 @@ module Library = struct
     | Some p -> snd p.name
 
   let is_virtual t = Option.is_some t.virtual_modules
+
+  let main_module_name t =
+    Module.Name.of_local_lib_name t.name
 end
 
 module Install_conf = struct

src/dune_file.mli

@@ -250,7 +250,7 @@ module Library : sig
     ; no_keep_locs             : bool
     ; dune_version             : Syntax.Version.t
     ; virtual_modules          : Ordered_set_lang.t option
-    ; implements               : (Loc.t * string) option
+    ; implements               : (Loc.t * Lib_name.t) option
     }
 
   val has_stubs : t -> bool
@@ -259,6 +259,7 @@ module Library : sig
   val archive : t -> dir:Path.t -> ext:string -> Path.t
   val best_name : t -> Lib_name.t
   val is_virtual : t -> bool
+  val main_module_name : t -> Module.Name.t
 end
 
 module Install_conf : sig

src/lib.ml

@@ -82,6 +82,7 @@ type t =
   ; pps               : t list Or_exn.t
   ; resolved_selects  : Resolved_select.t list
   ; user_written_deps : Dune_file.Lib_deps.t
+  ; implements        : t Or_exn.t option
   ; (* This is mutable to avoid this error:
 
        {[
@@ -492,11 +493,33 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden =
 
   let allow_private_deps = Lib_info.Status.is_private info.status in
 
+  let resolve (loc, name) =
+    resolve_dep db (name : Lib_name.t) ~allow_private_deps ~loc ~stack in
+
+  let implements = Option.map info.implements ~f:resolve in
+
   let requires, pps, resolved_selects =
     resolve_user_deps db info.requires ~allow_private_deps ~pps:info.pps ~stack
   in
+  let requires =
+    match implements with
+    | None -> requires
+    | Some implements ->
+      implements >>= fun implements ->
+      implements.requires >>= fun irequires ->
+      requires >>| fun requires ->
+      L.remove_dups (List.rev_append irequires requires)
+  in
   let ppx_runtime_deps =
-    resolve_simple_deps db info.ppx_runtime_deps ~allow_private_deps ~stack
+    let ppx_rd =
+      resolve_simple_deps db info.ppx_runtime_deps ~allow_private_deps ~stack in
+    match implements with
+    | None -> ppx_rd
+    | Some implements ->
+      implements >>= fun implements ->
+      implements.ppx_runtime_deps >>= fun ippx_rd ->
+      ppx_rd >>| fun ppx_rd ->
+      L.remove_dups (List.rev_append ippx_rd ppx_rd)
   in
   let map_error x =
     Result.map_error x ~f:(fun e ->
@@ -504,8 +527,6 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden =
   in
   let requires         = map_error requires         in
   let ppx_runtime_deps = map_error ppx_runtime_deps in
-  let resolve (loc, name) =
-    resolve_dep db (name : Lib_name.t) ~allow_private_deps ~loc ~stack in
   let t =
     { info
     ; name
@@ -516,6 +537,7 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden =
     ; resolved_selects
     ; user_written_deps = Lib_info.user_written_deps info
     ; sub_systems       = Sub_system_name.Map.empty
+    ; implements
     }
   in
   t.sub_systems <-
@@ -702,7 +724,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
   in
   (deps, pps, resolved_selects)
 
-  and closure_with_overlap_checks db ts ~stack =
+and closure_with_overlap_checks db ts ~stack =
   let visited = ref Lib_name.Map.empty in
   let res = ref [] in
   let orig_stack = stack in

src/lib_info.ml

@@ -41,6 +41,23 @@ module Deps = struct
     | Complex l -> l
 end
 
+module Virtual = struct
+  module Modules = struct
+    type t =
+      | Unexpanded
+  end
+
+  module Dep_graph = struct
+    type t =
+      | Local
+  end
+
+  type t =
+    { modules   : Modules.t
+    ; dep_graph : Dep_graph.t
+    }
+end
+
 type t =
   { loc              : Loc.t
   ; kind             : Dune_file.Library.Kind.t
@@ -60,6 +77,8 @@ type t =
   ; virtual_deps     : (Loc.t * Lib_name.t) list
   ; dune_version : Syntax.Version.t option
   ; sub_systems      : Dune_file.Sub_system_info.t Sub_system_name.Map.t
+  ; virtual_         : Virtual.t option
+  ; implements       : (Loc.t * Lib_name.t) option
   }
 
 let user_written_deps t =
@@ -96,6 +115,14 @@ let of_library_stanza ~dir ~ext_lib (conf : Dune_file.Library.t) =
         :: stubs
     }
   in
+  let virtual_ =
+    Option.map conf.virtual_modules ~f:(fun _ ->
+      { Virtual.
+        modules = Virtual.Modules.Unexpanded
+      ; dep_graph = Virtual.Dep_graph.Local
+      }
+    )
+  in
   { loc = conf.buildable.loc
   ; kind     = conf.kind
   ; src_dir  = dir
@@ -114,6 +141,8 @@ let of_library_stanza ~dir ~ext_lib (conf : Dune_file.Library.t) =
   ; pps = Dune_file.Preprocess_map.pps conf.buildable.preprocess
   ; sub_systems = conf.sub_systems
   ; dune_version = Some conf.dune_version
+  ; virtual_
+  ; implements = conf.implements
   }
 
 let of_findlib_package pkg =
@@ -144,4 +173,6 @@ let of_findlib_package pkg =
     foreign_archives = Mode.Dict.make_both []
   ; sub_systems      = sub_systems
   ; dune_version = None
+  ; virtual_ = None
+  ; implements = None
   }

src/lib_info.mli

@@ -21,6 +21,23 @@ module Deps : sig
   val of_lib_deps : Dune_file.Lib_deps.t -> t
 end
 
+module Virtual : sig
+  module Modules : sig
+    type t = private
+      | Unexpanded
+  end
+
+  module Dep_graph : sig
+    type t = private
+      | Local
+  end
+
+  type t = private
+    { modules   : Modules.t
+    ; dep_graph : Dep_graph.t
+    }
+end
+
 type t = private
   { loc              : Loc.t
   ; kind             : Dune_file.Library.Kind.t
@@ -40,6 +57,8 @@ type t = private
   ; virtual_deps     : (Loc.t * Lib_name.t) list
   ; dune_version : Syntax.Version.t option
   ; sub_systems      : Dune_file.Sub_system_info.t Sub_system_name.Map.t
+  ; virtual_         : Virtual.t option
+  ; implements       : (Loc.t * Lib_name.t) option
   }
 
 val of_library_stanza

src/module.ml

@@ -28,6 +28,9 @@ module Name = struct
   module Map = String.Map
   module Top_closure = Top_closure.String
   module Infix = Comparable.Operators(T)
+
+  let of_local_lib_name s =
+    of_string (Lib_name.Local.to_string s)
 end
 
 module Syntax = struct

src/module.mli

@@ -24,6 +24,8 @@ module Name : sig
   module Top_closure : Top_closure.S with type key := t
 
   module Infix : Comparable.OPS with type t = t
+
+  val of_local_lib_name : Lib_name.Local.t -> t
 end
 
 module Syntax : sig