From ff05369868e69dbc9bb86c22af04a6e054d1c858 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 3 Mar 2018 01:44:03 +0700 Subject: [PATCH] Introduce package name private type --- bin/main.ml | 16 +++++++++++----- src/gen_rules.ml | 6 +++--- src/gen_rules.mli | 2 +- src/install.ml | 3 ++- src/install.mli | 4 ++-- src/install_rules.ml | 28 +++++++++++++++------------- src/jbuild.ml | 36 ++++++++++++++++++------------------ src/jbuild.mli | 4 ++-- src/jbuild_load.ml | 15 ++++++++------- src/jbuild_load.mli | 3 +-- src/main.ml | 14 ++++++++------ src/main.mli | 8 ++++---- src/package.ml | 19 +++++++++++++++++-- src/package.mli | 15 ++++++++++++++- src/super_context.ml | 7 ++++--- src/super_context.mli | 4 ++-- src/utils.ml | 3 ++- src/utils.mli | 5 ++++- 18 files changed, 118 insertions(+), 74 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index d76a7951..d6c16d2a 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -15,7 +15,7 @@ type common = ; workspace_file : string option ; root : string ; target_prefix : string - ; only_packages : String_set.t option + ; only_packages : Package.Name.Set.t option ; capture_outputs : bool ; x : string option ; diff_command : string option @@ -159,6 +159,9 @@ let find_root () = | None -> assert false | Some (_, dir, to_cwd) -> (dir, to_cwd) +let package_name = + Arg.conv ((fun p -> Ok (Package.Name.of_string p)), Package.Name.pp) + let common_footer = `Blocks [ `S "BUGS" @@ -253,7 +256,8 @@ let common = ; ignore_promoted_rules ; only_packages = Option.map only_packages - ~f:(fun s -> String_set.of_list (String.split s ~on:',')) + ~f:(fun s -> Package.Name.Set.of_list ( + List.map ~f:Package.Name.of_string (String.split s ~on:','))) ; x ; config } @@ -524,7 +528,9 @@ let resolve_package_install setup pkg = match Main.package_install_file setup pkg with | Ok path -> path | Error () -> - die "Unknown package %s!%s" pkg (hint pkg (String_map.keys setup.packages)) + die "Unknown package %s!%s" (pkg :> string) + (hint (pkg :> string) + ((Package.Name.Map.keys setup.packages) :> string list)) let target_hint (setup : Main.setup) path = assert (Path.is_local path); @@ -946,7 +952,7 @@ let install_uninstall ~what = (Main.setup ~log common >>= fun setup -> let pkgs = match pkgs with - | [] -> String_map.keys setup.packages + | [] -> Package.Name.Map.keys setup.packages | l -> l in let install_files, missing_install_files = @@ -1018,7 +1024,7 @@ let install_uninstall ~what = is specified the default is $(i,\\$prefix/lib), otherwise \ it is the output of $(b,ocamlfind printconf destdir)" ) - $ Arg.(value & pos_all string [] name_)) + $ Arg.(value & pos_all package_name [] name_)) , Term.info what ~doc ~man:help_secs) let install = install_uninstall ~what:"install" diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 17bf1383..968f5147 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -946,8 +946,8 @@ let gen ~contexts ~build_system match only_packages with | None -> packages | Some pkgs -> - String_map.filter packages ~f:(fun { Package.name; _ } -> - String_set.mem pkgs name) + Package.Name.Map.filter packages ~f:(fun { Package.name; _ } -> + Package.Name.Set.mem pkgs name) in let sctxs = Hashtbl.create 4 in List.iter contexts ~f:(fun c -> @@ -973,7 +973,7 @@ let gen ~contexts ~build_system | Library { public = Some { package; _ }; _ } | Alias { package = Some package ; _ } | Install { package; _ } -> - String_set.mem pkgs package.name + Package.Name.Set.mem pkgs package.name | _ -> true))) in Fiber.fork_and_join host stanzas >>= fun (host, stanzas) -> diff --git a/src/gen_rules.mli b/src/gen_rules.mli index 5ac661d2..32d59cef 100644 --- a/src/gen_rules.mli +++ b/src/gen_rules.mli @@ -6,6 +6,6 @@ val gen : contexts:Context.t list -> build_system:Build_system.t -> ?filter_out_optional_stanzas_with_missing_deps:bool (* default: true *) - -> ?only_packages:String_set.t + -> ?only_packages:Package.Name.Set.t -> Jbuild_load.conf -> (Path.t * Scope_info.t * Stanzas.t) list String_map.t Fiber.t diff --git a/src/install.ml b/src/install.ml index 6c1eb029..b95739c8 100644 --- a/src/install.ml +++ b/src/install.ml @@ -62,7 +62,8 @@ module Section = struct let man = Path.(relative root) "man" end - let install_dir t ~package = + let install_dir t ~(package : Package.Name.t) = + let package = (package :> string) in match t with | Bin -> Paths.bin | Sbin -> Paths.sbin diff --git a/src/install.mli b/src/install.mli index be64cf63..99501d8e 100644 --- a/src/install.mli +++ b/src/install.mli @@ -28,8 +28,8 @@ module Entry : sig val make : Section.t -> ?dst:string -> Path.t -> t val set_src : t -> Path.t -> t - val relative_installed_path : t -> package:string -> Path.t - val add_install_prefix : t -> package:string -> prefix:Path.t -> t + val relative_installed_path : t -> package:Package.Name.t -> Path.t + val add_install_prefix : t -> package:Package.Name.t -> prefix:Path.t -> t end val files : Entry.t list -> Path.Set.t diff --git a/src/install_rules.ml b/src/install_rules.ml index 247bbb5f..4d6e104b 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -47,16 +47,17 @@ module Gen(P : Install_params) = struct let public_libs = Lib.DB.all (SC.public_libs sctx) in Lib.Set.iter public_libs ~f:gen_lib_dune_file; Lib.Set.to_list public_libs - |> List.map ~f:(fun lib -> (Findlib.root_package_name (Lib.name lib), lib)) - |> String_map.of_list_multi - |> String_map.merge (SC.packages sctx) ~f:(fun _name pkg libs -> + |> List.map ~f:(fun lib -> + (Package.Name.of_string (Findlib.root_package_name (Lib.name lib)), lib)) + |> Package.Name.Map.of_list_multi + |> Package.Name.Map.merge (SC.packages sctx) ~f:(fun _name pkg libs -> let pkg = Option.value_exn pkg in let libs = Option.value libs ~default:[] in Some (pkg, libs)) - |> String_map.iter ~f:(fun ((pkg : Package.t), libs) -> + |> Package.Name.Map.iter ~f:(fun ((pkg : Package.t), libs) -> let path = Path.append ctx.build_dir pkg.path in SC.on_load_dir sctx ~dir:path ~f:(fun () -> - let meta_fn = "META." ^ pkg.name in + let meta_fn = "META." ^ (pkg.name :> string) in let meta_template = Path.relative path (meta_fn ^ ".template" ) in let meta = Path.relative path meta_fn in @@ -78,7 +79,7 @@ module Gen(P : Install_params) = struct ~else_:(loop rest) in loop - [ pkg.name ^ ".version" + [ (pkg.name :> string) ^ ".version" ; "version" ; "VERSION" ] @@ -94,7 +95,7 @@ module Gen(P : Install_params) = struct let meta_contents = version >>^ fun version -> Gen_meta.gen - ~package:pkg.name + ~package:(pkg.name :> string) ~version libs in @@ -228,11 +229,11 @@ module Gen(P : Install_params) = struct acc) in let entries = - let opam = Path.relative package_path (package ^ ".opam") in + let opam = Path.relative package_path (Package.Name.opam_fn package) in Install.Entry.make Lib opam ~dst:"opam" :: entries in let entries = - let meta_fn = "META." ^ package in + let meta_fn = "META." ^ (package :> string) in let meta = Path.append ctx.build_dir (Path.relative package_path meta_fn) in Install.Entry.make Lib meta ~dst:"META" :: entries in @@ -275,17 +276,18 @@ module Gen(P : Install_params) = struct (package.name, Install.Entry.make section (Path.relative dir src) ?dst)) | _ -> []) - |> String_map.of_list_multi + |> Package.Name.Map.of_list_multi in - String_map.iter (SC.packages sctx) ~f:(fun (pkg : Package.t) -> + Package.Name.Map.iter (SC.packages sctx) ~f:(fun (pkg : Package.t) -> let stanzas = - Option.value (String_map.find entries_per_package pkg.name) ~default:[] + Option.value (Package.Name.Map.find entries_per_package pkg.name) + ~default:[] in install_file pkg.path pkg.name stanzas) let init_install_files () = if not ctx.implicit then - String_map.iteri (SC.packages sctx) + Package.Name.Map.iteri (SC.packages sctx) ~f:(fun pkg { Package.path = src_path; _ } -> let install_fn = Utils.install_file ~package:pkg diff --git a/src/jbuild.ml b/src/jbuild.ml index 4987e1b1..5e3c8e8c 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -90,13 +90,13 @@ module Scope_info = struct type t = { name : Name.t - ; packages : Package.t String_map.t + ; packages : Package.t Package.Name.Map.t ; root : Path.t } let anonymous = { name = None - ; packages = String_map.empty + ; packages = Package.Name.Map.empty ; root = Path.root } @@ -109,24 +109,24 @@ module Scope_info = struct in let root = pkg.path in List.iter rest ~f:(fun pkg -> assert (pkg.Package.path = root)); - { name = Some name + { name = Some (name :> string) ; packages = - String_map.of_list_exn (List.map pkgs ~f:(fun pkg -> + Package.Name.Map.of_list_exn (List.map pkgs ~f:(fun pkg -> pkg.Package.name, pkg)) ; root } let package_listing packages = let longest_pkg = - String.longest_map packages ~f:(fun p -> p.Package.name) + String.longest_map packages ~f:(fun p -> (p.Package.name :> string)) in String.concat ~sep:"\n" (List.map packages ~f:(fun pkg -> - sprintf "- %-*s (because of %s)" longest_pkg pkg.Package.name - (Path.to_string (Path.relative pkg.path (pkg.name ^ ".opam"))))) + sprintf "- %-*s (because of %s)" longest_pkg (pkg.Package.name :> string) + (Path.to_string (Package.opam_file pkg)))) let default t = - match String_map.values t.packages with + match Package.Name.Map.values t.packages with | [pkg] -> Ok pkg | [] -> Error @@ -142,39 +142,39 @@ module Scope_info = struct stanza is for. I have the choice between these ones:\n\ %s\n\ You need to add a (package ...) field in this (install ...) stanza" - (package_listing (String_map.values t.packages))) + (package_listing (Package.Name.Map.values t.packages))) let resolve t name = - match String_map.find t.packages name with + match Package.Name.Map.find t.packages name with | Some pkg -> Ok pkg | None -> - if String_map.is_empty t.packages then + if Package.Name.Map.is_empty t.packages then Error (sprintf "You cannot declare items to be installed without \ adding a .opam file at the root of your project.\n\ To declare elements to be installed as part of package %S, \ add a %S file at the root of your project." - name (name ^ ".opam")) + (name :> string) (Package.Name.opam_fn name)) else Error (sprintf "The current scope doesn't define package %S.\n\ The only packages for which you can declare \ elements to be installed in this directory are:\n\ %s%s" - name - (package_listing (String_map.values t.packages)) - (hint name (String_map.keys t.packages))) + (name :> string) + (package_listing (Package.Name.Map.values t.packages)) + (hint (name :> string) (Package.Name.Map.keys t.packages :> string list))) let package t sexp = - match resolve t (string sexp) with + match resolve t (Package.Name.of_string (string sexp)) with | Ok p -> p | Error s -> Loc.fail (Sexp.Ast.loc sexp) "%s" s let package_field t = map_validate (field_o "package" string) ~f:(function | None -> default t - | Some name -> resolve t name) + | Some name -> resolve t (Package.Name.of_string name)) end @@ -531,7 +531,7 @@ module Public_lib = struct match String.split s ~on:'.' with | [] -> assert false | pkg :: rest -> - match Scope_info.resolve pkgs pkg with + match Scope_info.resolve pkgs (Package.Name.of_string pkg) with | Ok pkg -> Ok (Some { package = pkg diff --git a/src/jbuild.mli b/src/jbuild.mli index 39a73437..a2d84fd4 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -26,7 +26,7 @@ module Scope_info : sig { name : string option (** First package name in alphabetical order. [None] for the global scope. *) - ; packages : Package.t String_map.t + ; packages : Package.t Package.Name.Map.t ; root : Path.t } @@ -39,7 +39,7 @@ module Scope_info : sig (** [resolve t package_name] looks up [package_name] in [t] and returns the package description if it exists, otherwise it returns an error. *) - val resolve : t -> string -> (Package.t, string) result + val resolve : t -> Package.Name.t -> (Package.t, string) result end (** Ppx preprocessors *) diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 7b13cd0b..a520d2a1 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -157,7 +157,7 @@ end type conf = { file_tree : File_tree.t ; jbuilds : Jbuilds.t - ; packages : Package.t String_map.t + ; packages : Package.t Package.Name.Map.t ; scopes : Scope_info.t list } @@ -186,27 +186,28 @@ let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () = | Some (String (_, s)) -> Some s | _ -> None in - (pkg, - { Package. name = pkg + let name = Package.Name.of_string pkg in + (name, + { Package. name ; path ; version_from_opam_file }) :: acc | _ -> acc)) in let packages = - String_map.of_list_multi packages - |> String_map.mapi ~f:(fun name pkgs -> + Package.Name.Map.of_list_multi packages + |> Package.Name.Map.mapi ~f:(fun name pkgs -> match pkgs with | [pkg] -> pkg | _ -> die "Too many opam files for package %S:\n%s" - name + (name :> string) (String.concat ~sep:"\n" (List.map pkgs ~f:(fun pkg -> sprintf "- %s" (Path.to_string (Package.opam_file pkg)))))) in let scopes = - String_map.values packages + Package.Name.Map.values packages |> List.map ~f:(fun pkg -> (pkg.Package.path, pkg)) |> Path.Map.of_list_multi |> Path.Map.map ~f:Scope_info.make diff --git a/src/jbuild_load.mli b/src/jbuild_load.mli index bb075632..addce278 100644 --- a/src/jbuild_load.mli +++ b/src/jbuild_load.mli @@ -1,4 +1,3 @@ -open Import open Jbuild module Jbuilds : sig @@ -13,7 +12,7 @@ end type conf = { file_tree : File_tree.t ; jbuilds : Jbuilds.t - ; packages : Package.t String_map.t + ; packages : Package.t Package.Name.Map.t ; scopes : Scope_info.t list } diff --git a/src/main.ml b/src/main.ml index 4f94fe85..0f163010 100644 --- a/src/main.ml +++ b/src/main.ml @@ -7,12 +7,12 @@ type setup = { build_system : Build_system.t ; stanzas : (Path.t * Jbuild.Scope_info.t * Jbuild.Stanzas.t) list String_map.t ; contexts : Context.t list - ; packages : Package.t String_map.t + ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t } let package_install_file { packages; _ } pkg = - match String_map.find packages pkg with + match Package.Name.Map.find packages pkg with | None -> Error () | Some p -> Ok (Path.relative p.path @@ -29,11 +29,13 @@ let setup ?(log=Log.no_log) () = let conf = Jbuild_load.load ?extra_ignored_subtrees ?ignore_promoted_rules () in Option.iter only_packages ~f:(fun set -> - String_set.iter set ~f:(fun pkg -> - if not (String_map.mem conf.packages pkg) then + Package.Name.Set.iter set ~f:(fun pkg -> + if not (Package.Name.Map.mem conf.packages pkg) then die "@{Error@}: I don't know about package %s \ (passed through --only-packages/--release)%s" - pkg (hint pkg (String_map.keys conf.packages)))); + (pkg :> string) + (hint (pkg :> string) + (Package.Name.Map.keys conf.packages :> string list)))); let workspace = match workspace with | Some w -> w @@ -94,7 +96,7 @@ let external_lib_deps ?log ~packages () = List.map packages ~f:(fun pkg -> match package_install_file setup pkg with | Ok path -> path - | Error () -> die "Unknown package %S" pkg) + | Error () -> die "Unknown package %S" (pkg :> string)) in match String_map.find setup.stanzas "default" with | None -> die "You need to set a default context to use external-lib-deps" diff --git a/src/main.mli b/src/main.mli index 0787ef17..3d474269 100644 --- a/src/main.mli +++ b/src/main.mli @@ -6,12 +6,12 @@ type setup = ; (* Evaluated jbuilds per context names *) stanzas : (Path.t * Scope_info.t * Stanzas.t) list String_map.t ; contexts : Context.t list - ; packages : Package.t String_map.t + ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t } (* Returns [Error ()] if [pkg] is unknown *) -val package_install_file : setup -> string -> (Path.t, unit) result +val package_install_file : setup -> Package.Name.t -> (Path.t, unit) result (** Scan the source tree and discover everything that's needed in order to build it. *) @@ -20,14 +20,14 @@ val setup -> ?filter_out_optional_stanzas_with_missing_deps:bool -> ?workspace:Workspace.t -> ?workspace_file:string - -> ?only_packages:String_set.t + -> ?only_packages:Package.Name.Set.t -> ?x:string -> ?ignore_promoted_rules:bool -> unit -> setup Fiber.t val external_lib_deps : ?log:Log.t - -> packages:string list + -> packages:Package.Name.t list -> unit -> Build.lib_deps Path.Map.t diff --git a/src/package.ml b/src/package.ml index c09c6986..66eb5a7e 100644 --- a/src/package.ml +++ b/src/package.ml @@ -1,7 +1,22 @@ + +module Name = struct + type t = string + + let of_string x = x + + let opam_fn t = t ^ ".opam" + + module Map = Import.String_map + module Set = Import.String_set + + let pp = Format.pp_print_string +end + + type t = - { name : string + { name : Name.t ; path : Path.t ; version_from_opam_file : string option } -let opam_file t = Path.relative t.path (t.name ^ ".opam") +let opam_file t = Path.relative t.path (Name.opam_fn t.name) diff --git a/src/package.mli b/src/package.mli index 501c7859..3ab3ecd6 100644 --- a/src/package.mli +++ b/src/package.mli @@ -1,7 +1,20 @@ (** Information about a package defined in the workspace *) +module Name : sig + type t = private string + + val of_string : string -> t + + val opam_fn : t -> string + + module Map : Stdune.Map.S with type key = t + module Set : Stdune.Set.S with type elt = t + + val pp : Format.formatter -> t -> unit +end + type t = - { name : string + { name : Name.t ; path : Path.t ; version_from_opam_file : string option } diff --git a/src/super_context.ml b/src/super_context.ml index c9513770..a9ea49c9 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -21,7 +21,7 @@ type t = ; public_libs : Lib.DB.t ; installed_libs : Lib.DB.t ; stanzas : Dir_with_jbuild.t list - ; packages : Package.t String_map.t + ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t ; artifacts : Artifacts.t ; stanzas_to_consider_for_install : (Path.t * Scope.t * Stanza.t) list @@ -336,7 +336,7 @@ module Pkg_version = struct let spec sctx (p : Package.t) = let fn = Path.relative (Path.append sctx.context.build_dir p.path) - (sprintf "%s.version.sexp" p.name) + (sprintf "%s.version.sexp" (p.name :> string)) in Build.Vspec.T (fn, (module V)) @@ -462,7 +462,8 @@ module Action = struct Some (str_exp (string_of_bool ( Lib.DB.available (Scope.libs scope) lib))) | Some ("version", s) -> begin - match Scope_info.resolve (Scope.info scope) s with + match Scope_info.resolve (Scope.info scope) + (Package.Name.of_string s) with | Ok p -> let x = Pkg_version.read sctx p >>^ function diff --git a/src/super_context.mli b/src/super_context.mli index f00d175d..d0bf17ac 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -25,7 +25,7 @@ val create -> ?host:t -> scopes:Scope_info.t list -> file_tree:File_tree.t - -> packages:Package.t String_map.t + -> packages:Package.t Package.Name.Map.t -> stanzas:(Path.t * Scope_info.t * Stanzas.t) list -> filter_out_optional_stanzas_with_missing_deps:bool -> build_system:Build_system.t @@ -33,7 +33,7 @@ val create val context : t -> Context.t val stanzas : t -> Dir_with_jbuild.t list -val packages : t -> Package.t String_map.t +val packages : t -> Package.t Package.Name.Map.t val file_tree : t -> File_tree.t val artifacts : t -> Artifacts.t val stanzas_to_consider_for_install : t -> (Path.t * Scope.t * Stanza.t) list diff --git a/src/utils.ml b/src/utils.ml index ab986086..0e9ab80d 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -142,7 +142,8 @@ let g () = else [] -let install_file ~package ~findlib_toolchain = +let install_file ~(package : Package.Name.t) ~findlib_toolchain = + let package = (package :> string) in match findlib_toolchain with | None -> package ^ ".install" | Some x -> sprintf "%s-%s.install" package x diff --git a/src/utils.mli b/src/utils.mli index d52364fd..1c33eccb 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -53,7 +53,10 @@ val library_not_found : ?context:string -> ?hint:string -> string -> _ (** [\["-g"\]] if [!Clflags.g] and [\[\]] otherwise *) val g : unit -> string list -val install_file : package:string -> findlib_toolchain:string option -> string +val install_file + : package:Package.Name.t + -> findlib_toolchain:string option + -> string (** Digest files with caching *) module Cached_digest : sig