Add Vlib.Unimplemented to maintain unimplemented libs

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

src/lib.ml

@@ -570,7 +570,7 @@ let result_of_resolve_status = function
   | St_not_found          -> Error Error.Library_not_available.Reason.Not_found
   | St_hidden (_, hidden) -> Error (Hidden hidden)
 
-module Virtual_libs : sig
+module Vlib : sig
   (** Make sure that for every virtual library in the list there is at
       most one corresponding implementation.
 
@@ -582,7 +582,51 @@ module Virtual_libs : sig
     -> orig_stack:Dep_stack.t
     -> linking:bool
     -> t list Or_exn.t
+
+  module Unimplemented : sig
+    (** set of unimplemented libraries*)
+    type t
+
+    val empty : t
+
+    val add : t -> lib -> t Or_exn.t
+
+    val fold
+      :  t
+      -> init:'acc
+      -> f:(lib -> 'acc -> 'acc Or_exn.t)
+      -> 'acc Or_exn.t
+  end
 end = struct
+  module Unimplemented = struct
+    type status = Implemented | Not_implemented
+    type t = status Map.t
+
+    let empty = Map.empty
+
+    let add t lib =
+      match lib.implements, lib.info.virtual_ with
+      | None, None -> Ok t
+      | Some _, Some _ ->
+        assert false (* can't be virtual and implement *)
+      | None, Some _ ->
+        Ok (Map.update t lib ~f:(function
+          | None -> Some Not_implemented
+          | Some _ as x -> x))
+      | Some vlib, None ->
+        let+ vlib = vlib in
+        Map.add t vlib Implemented
+
+    let fold =
+      let rec loop ~f ~acc = function
+        | [] -> Ok acc
+        | (_, Implemented) :: libs -> loop ~f ~acc libs
+        | (lib, Not_implemented) :: libs ->
+          let* acc = f lib acc in
+          loop ~f ~acc libs
+      in
+      fun t ~init ~f -> loop (Map.to_list t) ~acc:init ~f
+  end
   module Table = struct
     module Partial = struct
       type vlib_status =
@@ -671,13 +715,6 @@ end = struct
       Ok closure
 end
 
-module Vlib_status = struct
-  type nonrec t =
-    | No_implementation
-    | Implemented_by of t
-    | Too_many_impl of t list
-end
-
 module Vlib_visit : sig
   type t
 
@@ -737,29 +774,6 @@ let rec find_implementation_for db lib ~variants =
                       ; conflict
                       }))
 
-(* Update the variant status map according to `lib` which is being added to the
-   closure. *)
-let handle_vlibs lib virtual_status =
-  match lib.info.virtual_, lib.implements with
-  | Some _, Some _ -> assert false
-  | None, None -> Ok virtual_status
-  | Some _, None ->
-    (* Virtual library: add it in the map if it doesn't exist yet. *)
-    Ok (
-      match Map.find virtual_status lib with
-      | None -> Map.add virtual_status lib Vlib_status.No_implementation
-      | Some _ -> virtual_status)
-  | None, Some implements ->
-    (* Implementation: find the corresponding virtual library *)
-    let+ implements = implements in
-    Map.update virtual_status implements ~f:(fun status ->
-      Option.some @@
-      match status with
-      | Some No_implementation
-      | None -> Vlib_status.Implemented_by lib
-      | Some (Implemented_by x) -> Too_many_impl [lib; x]
-      | Some (Too_many_impl lst) -> Too_many_impl (lib :: lst))
-
 let rec instantiate db name (info : Lib_info.t) ~stack ~hidden =
   let id, stack =
     Dep_stack.create_and_push stack name info.src_dir
@@ -1096,7 +1110,7 @@ and closure_with_overlap_checks db ts ~stack:orig_stack ~linking ~variants =
       ~allow_private_deps:true ~loc ~stack:Dep_stack.empty
   in
   let visited = ref Map.empty in
-  let virtual_status = ref Map.empty in
+  let unimplemented = ref Vlib.Unimplemented.empty in
   let res = ref [] in
   let rec loop t ~stack =
     match Map.find !visited t with
@@ -1131,8 +1145,8 @@ and closure_with_overlap_checks db ts ~stack:orig_stack ~linking ~variants =
       in
       let* new_stack = Dep_stack.push stack (to_id t) in
       let* deps = t.requires in
-      let* virtual_status' = handle_vlibs t !virtual_status in
-      virtual_status := virtual_status';
+      let* unimplemented' = Vlib.Unimplemented.add !unimplemented t in
+      unimplemented := unimplemented';
       let+ () = Result.List.iter deps ~f:(loop ~stack:new_stack) in
       res := (t, stack) :: !res
   in
@@ -1144,24 +1158,18 @@ and closure_with_overlap_checks db ts ~stack:orig_stack ~linking ~variants =
     else begin
       (* Virtual libraries: find implementations according to variants. *)
       let* (lst, with_default_impl) =
-        Map.foldi !virtual_status ~init:(Ok ([], []))
-          ~f:(fun lib status acc ->
-            match status with
-            | Implemented_by _
-            | Too_many_impl _ -> acc
-            | No_implementation ->
-              let* (lst, def) = acc in
-              let (lib, _) = Map.find_exn !visited lib in
-              let* impl =
-                find_implementation_for (Option.value_exn db) lib ~variants in
-              match impl, lib.default_implementation with
-              | None, Some _ ->
-                Ok (lst, (lib :: def))
-              | None, None ->
-                Ok (lst, def)
-              | Some (impl_info : Lib_info.t), _ ->
-                let* impl = name_to_lib impl_info.name impl_info.loc in
-                Ok (impl :: lst, def))
+        !unimplemented
+        |> Vlib.Unimplemented.fold ~init:([], []) ~f:(fun lib (lst, def) ->
+          let* impl =
+            find_implementation_for (Option.value_exn db) lib ~variants in
+          match impl, lib.default_implementation with
+          | None, Some _ ->
+            Ok (lst, (lib :: def))
+          | None, None ->
+            Ok (lst, def)
+          | Some (impl_info : Lib_info.t), _ ->
+            let* impl = name_to_lib impl_info.name impl_info.loc in
+            Ok (impl :: lst, def))
       in
       (* Manage unimplemented libraries that have a default implementation. *)
       match lst, with_default_impl with
@@ -1175,7 +1183,7 @@ and closure_with_overlap_checks db ts ~stack:orig_stack ~linking ~variants =
     end
   in
   let* () = handle ts ~stack:orig_stack in
-  Virtual_libs.associate (List.rev !res) ~linking ~orig_stack
+  Vlib.associate (List.rev !res) ~linking ~orig_stack
 
 let closure_with_overlap_checks db l ~variants =
   closure_with_overlap_checks db l ~stack:Dep_stack.empty ~variants