Merge pull request #626 from rgrinberg/doc-pkg

Implement Lib.package

src/lib.ml

@@ -8,20 +8,20 @@ open Result.O
 module Status = struct
   type t =
     | Installed
-    | Public
+    | Public  of Package.t
     | Private of Jbuild.Scope_info.Name.t
 
   let pp ppf t =
     Format.pp_print_string ppf
       (match t with
        | Installed -> "installed"
-       | Public -> "public"
+       | Public _ -> "public"
        | Private s ->
          sprintf "private (%s)" (Jbuild.Scope_info.Name.to_string s))
 
   let is_private = function
     | Private _ -> true
-    | Installed | Public -> false
+    | Installed | Public _ -> false
 end
 
 module Info = struct
@@ -89,7 +89,7 @@ module Info = struct
     let status =
       match conf.public with
       | None   -> Status.Private conf.scope_name
-      | Some _ -> Public
+      | Some p -> Public p.package
     in
     let foreign_archives =
       { Mode.Dict.
@@ -353,6 +353,15 @@ let is_local t = Path.is_local t.obj_dir
 
 let status t = t.status
 
+let package t =
+  match t.status with
+  | Installed ->
+    Some (Findlib.root_package_name t.name
+          |> Package.Name.of_string)
+  | Public p -> Some p.name
+  | Private _ ->
+    None
+
 let to_id t : Id.t =
   { unique_id = t.unique_id
   ; path      = t.src_dir

src/lib.mli

@@ -35,7 +35,7 @@ module Set : Set.S with type elt = t
 module Status : sig
   type t =
     | Installed
-    | Public
+    | Public  of Package.t
     | Private of Jbuild.Scope_info.Name.t
 
   val pp : t Fmt.t
@@ -43,6 +43,8 @@ end
 
 val status : t -> Status.t
 
+val package : t -> Package.Name.t option
+
 (** Operations on list of libraries *)
 module L : sig
   type nonrec t = t list

src/odoc.ml

@@ -35,7 +35,7 @@ module Doc = struct
             dir_internal t
               (match Lib.status lib with
                | Installed -> assert false
-               | Public    -> Public (Lib.name lib)
+               | Public _  -> Public (Lib.name lib)
                | Private s -> Private (Lib.name lib, s))
           in
           Build_system.Alias.stamp_file (alias ~dir) :: acc
@@ -220,7 +220,7 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~scope ~modules ~mld_files
       let name = Lib.name lib in
       match Lib.status lib with
       | Installed -> assert false
-      | Public    -> name
+      | Public _  -> name
       | Private scope_name ->
         sprintf "%s@%s" name (Scope_info.Name.to_string scope_name)
     in

src/preprocessing.ml

@@ -126,15 +126,6 @@ let gen_rules sctx components =
     build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe
   | _ -> ()
 
-let most_specific_db (a : Lib.Status.t) (b : Lib.Status.t) =
-  match a, b with
-  | Private x, Private y -> assert (x = y); a
-  | Private _, _         -> a
-  | _        , Private _ -> b
-  | Public   , _
-  | _        , Public    -> Public
-  | Installed, Installed -> Installed
-
 let get_ppx_driver sctx ~scope pps =
   let driver, names =
     match List.rev_map pps ~f:(fun (_loc, pp) -> Pp.to_string pp) with
@@ -142,25 +133,34 @@ let get_ppx_driver sctx ~scope pps =
     | driver :: rest -> (Some driver, rest)
   in
   let sctx = SC.host sctx in
-  let name_and_db name =
+  let name_and_scope_for_key name =
     match Lib.DB.find (Scope.libs scope) name with
     | Error _ ->
       (* XXX unknown but assume it's public *)
-      (name, Lib.Status.Installed)
+      (name, None)
     | Ok lib ->
-      (Lib.name lib, Lib.status lib)
+      (Lib.name lib,
+       match Lib.status lib with
+       | Private scope_name   -> Some scope_name
+       | Public _ | Installed -> None)
   in
-  let driver, driver_db =
+  let driver, scope_for_key =
     match driver with
-    | None -> (None, Lib.Status.Installed)
+    | None -> (None, None)
     | Some driver ->
-      let name, db = name_and_db driver in
-      (Some name, db)
+      let name, scope_for_key = name_and_scope_for_key driver in
+      (Some name, scope_for_key)
   in
-  let names, db =
-    List.fold_left names ~init:([], driver_db) ~f:(fun (names, db) lib ->
-      let name, db' = name_and_db lib in
-      (name :: names, most_specific_db db db'))
+  let names, scope_for_key =
+    List.fold_left names ~init:([], scope_for_key)
+      ~f:(fun (names, scope_for_key) lib ->
+        let name, scope_for_key' = name_and_scope_for_key lib in
+        (name :: names,
+         match scope_for_key, scope_for_key' with
+         | Some a, Some b -> assert (a = b); scope_for_key
+         | Some _, None   -> scope_for_key
+         | None  , Some _ -> scope_for_key'
+         | None  , None   -> None))
   in
   let names = List.sort ~compare:String.compare names in
   let names =
@@ -174,9 +174,9 @@ let get_ppx_driver sctx ~scope pps =
     | _  -> String.concat names ~sep:"+"
   in
   let key =
-    match db with
-    | Installed | Public -> key
-    | Private scope_name -> SC.Scope_key.to_string key scope_name
+    match scope_for_key with
+    | None            -> key
+    | Some scope_name -> SC.Scope_key.to_string key scope_name
   in
   let sctx = SC.host sctx in
   ppx_exe sctx ~key