diff --git a/src/lib.ml b/src/lib.ml index 39573dbd..7adf0b37 100644 --- a/src/lib.ml +++ b/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. diff --git a/src/lib.mli b/src/lib.mli index d35f55f3..b6a67bbf 100644 --- a/src/lib.mli +++ b/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 diff --git a/src/odoc.ml b/src/odoc.ml index c011a24c..6b665833 100644 --- a/src/odoc.ml +++ b/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 diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 24435595..228f6612 100644 --- a/src/preprocessing.ml +++ b/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