From fe929a07d78600c1521681a2701e54411f735a37 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 23 Feb 2017 14:58:18 +0000 Subject: [PATCH] Don't require packages to be defined at the root To match the manual --- bin/main.ml | 40 +++++++++++++++++++++++++++++----------- src/file_tree.ml | 9 +++++++++ src/file_tree.mli | 3 +++ src/gen_rules.ml | 42 +++++++++++++++++++++--------------------- src/gen_rules.mli | 4 +++- src/jbuild_load.ml | 39 ++++++++++++++++++++++++++------------- src/jbuild_load.mli | 3 ++- src/main.ml | 38 +++++++++++++++++++++++++++++--------- src/main.mli | 14 ++++++++++++-- 9 files changed, 134 insertions(+), 58 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 0165e2c9..2dfe288a 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -2,6 +2,7 @@ open Jbuilder open Import open Jbuilder_cmdliner.Cmdliner +module Suggest = Jbuilder_cmdliner.Cmdliner_suggest module Main = Jbuilder.Main let (>>=) = Future.(>>=) @@ -74,8 +75,25 @@ let common = let build_package pkg = Future.Scheduler.go ~log:(create_log ()) - (Main.setup () >>= fun (bs, _, _) -> - Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) + (Main.setup () >>= fun setup -> + match Main.package_install_file setup pkg with + | Ok path -> + Build_system.do_build_exn setup.build_system + [path] + | Error () -> + match Suggest.value pkg (String_map.keys setup.packages) with + | [] -> die "Unknown package %s!" pkg + | pkgs -> + let rec mk_hint = function + | [a; b] -> sprintf "%s or %s" a b + | [a] -> a + | a :: l -> sprintf "%s, %s" a (mk_hint l) + | [] -> "" + in + die "Unknown package %s!\nHint: did you mean %s?" + pkg + (mk_hint pkgs) + ) let build_package = let doc = "build a package in release mode" in @@ -112,7 +130,7 @@ let external_lib_deps = $ Arg.(non_empty & pos_all string [] name_)) , Term.info "external-lib-deps" ~doc ~man:help_secs) -let resolve_targets bs (ctx : Context.t) user_targets = +let resolve_targets (setup : Main.setup)user_targets = match user_targets with | [] -> [] | _ -> @@ -122,9 +140,9 @@ let resolve_targets bs (ctx : Context.t) user_targets = if Path.is_in_build_dir path then path else if Path.is_local path && - not (Build_system.is_target bs path) && + not (Build_system.is_target setup.build_system path) && not (Path.exists path) then - Path.append ctx.build_dir path + Path.append setup.context.build_dir path else path) in @@ -140,9 +158,9 @@ let build_targets ~name = let go common targets = set_common common; Future.Scheduler.go ~log:(create_log ()) - (Main.setup () >>= fun (bs, _, ctx) -> - let targets = resolve_targets bs ctx targets in - Build_system.do_build_exn bs targets) in + (Main.setup () >>= fun setup -> + let targets = resolve_targets setup targets in + Build_system.do_build_exn setup.build_system targets) in ( Term.(const go $ common $ Arg.(non_empty & pos_all string [] name_)) @@ -154,7 +172,7 @@ let runtest = let go common dirs = set_common common; Future.Scheduler.go ~log:(create_log ()) - (Main.setup () >>= fun (bs, _, ctx) -> + (Main.setup () >>= fun setup -> let dirs = match dirs with | [] -> [Path.root] @@ -166,11 +184,11 @@ let runtest = if Path.is_in_build_dir dir then dir else - Path.append ctx.build_dir dir + Path.append setup.context.build_dir dir in Alias.file (Alias.runtest ~dir)) in - Build_system.do_build_exn bs targets) in + Build_system.do_build_exn setup.build_system targets) in ( Term.(const go $ common $ Arg.(value & pos_all string [] name_)) diff --git a/src/file_tree.ml b/src/file_tree.ml index 6bc5c021..ca03e69a 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -65,3 +65,12 @@ let fold t ~init ~f = let find_dir t path = Path.Map.find path t.dirs + +let file_exists t path fn = + match Path.Map.find path t.dirs with + | None -> false + | Some { files; _ } -> String_set.mem fn files + +let exists t path = + Path.Map.mem path t.dirs || + file_exists t (Path.parent path) (Path.basename path) diff --git a/src/file_tree.mli b/src/file_tree.mli index 1f5fdbe7..96b61f55 100644 --- a/src/file_tree.mli +++ b/src/file_tree.mli @@ -18,3 +18,6 @@ val fold : t -> init:'a -> f:(Dir.t -> 'a -> 'a) -> 'a val root : t -> Dir.t val find_dir : t -> Path.t -> Dir.t option + +val exists : t -> Path.t -> bool +val file_exists : t -> Path.t -> string -> bool diff --git a/src/gen_rules.ml b/src/gen_rules.ml index d936c680..1dfda347 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -73,7 +73,7 @@ module type Params = sig val file_tree : File_tree.t val tree : Alias.tree val stanzas : (Path.t * Jbuild_types.Stanza.t list) list - val packages : string list + val packages : Path.t String_map.t val filter_out_optional_stanzas_with_missing_deps : bool end @@ -1367,15 +1367,17 @@ module Gen(P : Params) = struct List.map stanzas ~f:(fun s -> (ctx_dir, s))) let () = - List.iter P.packages ~f:(fun package -> + String_map.iter P.packages ~f:(fun ~key:package ~data:src_path -> + let path = Path.append ctx.build_dir src_path in let meta_fn = "META." ^ package in - let meta_path = Path.relative ctx.build_dir meta_fn in - let templ_fn = meta_fn ^ ".template" in + let meta_path = Path.relative path meta_fn in let template = - if Sys.file_exists templ_fn then - Build.path (Path.(relative root) templ_fn) + let templ_fn = meta_fn ^ ".template" in + let templ_path = Path.relative src_path templ_fn in + if File_tree.exists P.file_tree templ_path then + Build.path templ_path >>^ fun () -> - lines_of_file templ_fn + lines_of_file (Path.to_string templ_path) else Build.return ["# JBUILDER_GEN"] in @@ -1543,7 +1545,7 @@ module Gen(P : Params) = struct List.exists [ "README"; "LICENSE"; "CHANGE"; "HISTORY"] ~f:(fun prefix -> String.is_prefix fn ~prefix) - let install_file package = + let install_file package_path package = let entries = List.concat_map stanzas_to_consider_for_install ~f:(fun (dir, stanza) -> match stanza with @@ -1576,18 +1578,15 @@ module Gen(P : Params) = struct acc) in let entries = - let opam = Path.of_string "opam" in - if Path.exists opam then - Install.Entry.make Lib opam :: entries - else - entries + let opam = Path.relative package_path (package ^ ".opam") in + Install.Entry.make Lib opam ~dst:"opam" :: entries in let entries = let meta_fn = "META." ^ package in - if Sys.file_exists meta_fn || - Sys.file_exists (meta_fn ^ ".template") || + if File_tree.file_exists P.file_tree package_path meta_fn || + File_tree.file_exists P.file_tree package_path (meta_fn ^ ".template") || List.exists entries ~f:(fun (e : Install.Entry.t) -> e.section = Lib) then - let meta = Path.relative ctx.build_dir meta_fn in + let meta = Path.append ctx.build_dir (Path.relative package_path meta_fn) in Install.Entry.make Lib meta ~dst:"META" :: entries else entries @@ -1598,16 +1597,17 @@ module Gen(P : Params) = struct Build.create_file ~target:fn (fun () -> Install.write_install_file fn entries)) - let () = List.iter P.packages ~f:install_file + let () = String_map.iter P.packages ~f:(fun ~key:package ~data:package_path -> + install_file package_path package) let () = if Path.basename ctx.build_dir = "default" then - List.iter P.packages ~f:(fun pkg -> - let fn = pkg ^ ".install" in + String_map.iter P.packages ~f:(fun ~key:pkg ~data:path -> + let install_file = Path.relative path (pkg ^ ".install") in add_rule (Build.copy - ~src:(Path.relative ctx.build_dir fn) - ~dst:(Path.relative Path.root fn))) + ~src:(Path.append ctx.build_dir install_file) + ~dst:install_file)) end let gen ~context ~file_tree ~tree ~stanzas ~packages diff --git a/src/gen_rules.mli b/src/gen_rules.mli index 31efd46a..461f07d9 100644 --- a/src/gen_rules.mli +++ b/src/gen_rules.mli @@ -1,9 +1,11 @@ +open Import + val gen : context:Context.t -> file_tree:File_tree.t -> tree:Alias.tree -> stanzas:(Path.t * Jbuild_types.Stanza.t list) list - -> packages:string list + -> packages:Path.t String_map.t -> ?filter_out_optional_stanzas_with_missing_deps:bool (** default: true *) -> unit -> (unit, unit) Build.t list diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index ab933935..b6e8389e 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -5,13 +5,13 @@ type conf = { file_tree : File_tree.t ; tree : Alias.tree ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list - ; packages : string list + ; packages : Path.t String_map.t } let load fn ~dir = (dir, Sexp_load.many fn Stanza.t) let load () = - let rec walk dir stanzas = + let rec walk dir stanzas packages = let path = File_tree.Dir.path dir in let files = File_tree.Dir.files dir in let sub_dirs = File_tree.Dir.sub_dirs dir in @@ -22,14 +22,15 @@ let load () = (lines_of_file (Path.to_string (Path.relative path "jbuild-ignore"))) in String_map.filter sub_dirs ~f:(fun fn _ -> - not (String_set.mem fn ignore_set)) + not (String_set.mem fn ignore_set)) else sub_dirs in - let children, stanzas = - String_map.fold sub_dirs ~init:([], stanzas) ~f:(fun ~key:_ ~data:dir (children, stanzas) -> - let child, stanzas = walk dir stanzas in - (child :: children, stanzas)) + let children, stanzas, packages = + String_map.fold sub_dirs ~init:([], stanzas, []) + ~f:(fun ~key:_ ~data:dir (children, stanzas, packages) -> + let child, stanzas, packages = walk dir stanzas packages in + (child :: children, stanzas, packages)) in let stanzas = if String_set.mem "jbuild" files then @@ -37,16 +38,28 @@ let load () = else stanzas in - (Alias.Node (path, children), stanzas) + let packages = + String_set.fold files ~init:packages ~f:(fun fn acc -> + match Filename.split_ext fn with + | Some (pkg, ".opam") -> (pkg, path) :: acc + | _ -> acc) + in + (Alias.Node (path, children), stanzas, packages) in let ftree = File_tree.load Path.root in let root = File_tree.root ftree in - let tree, stanzas = walk root [] in + let tree, stanzas, packages = walk root [] [] in let packages = - String_set.fold (File_tree.Dir.files root) ~init:[] ~f:(fun fn acc -> - match Filename.split_ext fn with - | Some (pkg, ".opam") -> pkg :: acc - | _ -> acc) + String_map.of_alist_multi packages + |> String_map.mapi ~f:(fun pkg dirs -> + match dirs with + | [dir] -> dir + | _ -> + die "Too many opam files for package %S:\n%s" + pkg + (String.concat ~sep:"\n" + (List.map dirs ~f:(fun dir -> + sprintf "- %s.opam" (Path.to_string dir))))) in { file_tree = ftree ; tree diff --git a/src/jbuild_load.mli b/src/jbuild_load.mli index 1cbadcac..ef86f740 100644 --- a/src/jbuild_load.mli +++ b/src/jbuild_load.mli @@ -1,9 +1,10 @@ +open Import type conf = { file_tree : File_tree.t ; tree : Alias.tree ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list - ; packages : string list + ; packages : Path.t String_map.t } val load : unit -> conf diff --git a/src/main.ml b/src/main.ml index 3a060ce3..89bab800 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,24 +1,44 @@ open Import open Future +type setup = + { build_system : Build_system.t + ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list + ; context : Context.t + ; packages : Path.t String_map.t + } + +let package_install_file { packages; _ } pkg = + match String_map.find pkg packages with + | None -> Error () + | Some path -> Ok (Path.relative path (pkg ^ ".install")) + let setup ?filter_out_optional_stanzas_with_missing_deps () = let { Jbuild_load. file_tree; tree; stanzas; packages } = Jbuild_load.load () in - Lazy.force Context.default >>= fun ctx -> + Lazy.force Context.default >>= fun context -> let rules = - Gen_rules.gen ~context:ctx ~file_tree ~tree ~stanzas ~packages + Gen_rules.gen ~context ~file_tree ~tree ~stanzas ~packages ?filter_out_optional_stanzas_with_missing_deps () in - let bs = Build_system.create ~file_tree ~rules in - return (bs, stanzas, ctx) + let build_system = Build_system.create ~file_tree ~rules in + return { build_system + ; stanzas + ; context + ; packages + } let external_lib_deps ?log ~packages = Future.Scheduler.go ?log (setup () ~filter_out_optional_stanzas_with_missing_deps:false - >>| fun (bs, stanzas, _) -> + >>| fun ({ build_system = bs; stanzas; _ } as setup) -> + let install_files = + List.map packages ~f:(fun pkg -> + match package_install_file setup pkg with + | Ok path -> path + | Error () -> die "Unknown package %S" pkg) + in Path.Map.map - (Build_system.all_lib_deps bs - (List.map packages ~f:(fun pkg -> - Path.(relative root) (pkg ^ ".install")))) + (Build_system.all_lib_deps bs install_files) ~f:(fun deps -> let internals = Jbuild_types.Stanza.lib_names stanzas in String_map.filter deps ~f:(fun name _ -> not (String_set.mem name internals)))) @@ -80,7 +100,7 @@ let bootstrap () = Arg.parse [ "-j", Set_int Clflags.concurrency, "JOBS concurrency" ] anon "Usage: boot.exe [-j JOBS]\nOptions are:"; Future.Scheduler.go ~log:(create_log ()) - (setup () >>= fun (bs, _, _) -> + (setup () >>= fun { build_system = bs; _ } -> Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) in try diff --git a/src/main.mli b/src/main.mli index ff9cd8b6..fe21116e 100644 --- a/src/main.mli +++ b/src/main.mli @@ -1,9 +1,19 @@ open! Import + +type setup = + { build_system : Build_system.t + ; stanzas : (Path.t * Jbuild_types.Stanza.t list) list + ; context : Context.t + ; packages : Path.t String_map.t + } + +(* Returns [Error ()] if [pkg] is unknown *) +val package_install_file : setup -> string -> (Path.t, unit) result + val setup : ?filter_out_optional_stanzas_with_missing_deps:bool -> unit - -> (Build_system.t * (Path.t * Jbuild_types.Stanza.t list) list * Context.t) - Future.t + -> setup Future.t val external_lib_deps : ?log:out_channel -> packages:string list