From ca424fb3a83706797df0f88ef7a567a317c95888 Mon Sep 17 00:00:00 2001 From: Wilfred Hughes Date: Sat, 30 Jun 2018 20:02:56 +0100 Subject: [PATCH 01/10] Fix typo Signed-off-by: Wilfred Hughes --- README.md | 2 +- doc/quick-start.rst | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 72801acc..89312478 100644 --- a/README.md +++ b/README.md @@ -85,7 +85,7 @@ $ jbuilder build --only-packages @install Jbuilder is able to build a given source code repository against several configurations simultaneously. This helps maintaining packages -across several versions of OCaml as you can tests them all at once +across several versions of OCaml as you can test them all at once without hassle. This feature should make cross-compilation easy, see details in the diff --git a/doc/quick-start.rst b/doc/quick-start.rst index ce8a9a22..071ead03 100644 --- a/doc/quick-start.rst +++ b/doc/quick-start.rst @@ -15,7 +15,7 @@ In a directory of your choice, write this ``jbuild`` file: (jbuild_version 1) - ;; This declare the hello_world executable implemented by hello_world.ml + ;; This declares the hello_world executable implemented by hello_world.ml (executable ((name hello_world))) From b4dd6565b2ff2d434ff3114ea980cb758447acc1 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sat, 30 Jun 2018 00:02:57 +0100 Subject: [PATCH 02/10] Add Ordered_set_lang.Unexpanded.fold_strings Signed-off-by: Jeremie Dimino --- src/ordered_set_lang.ml | 20 ++++++++++++++++++++ src/ordered_set_lang.mli | 11 +++++++++++ 2 files changed, 31 insertions(+) diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index d9a10958..6301e562 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -271,6 +271,26 @@ module Unexpanded = struct in loop t.ast + type position = Pos | Neg + + let fold_strings t ~init ~f = + let rec loop (t : ast) pos acc = + let open Ast in + match t with + | Standard | Include _ -> acc + | Element x -> f pos x acc + | Union l -> List.fold_left l ~init:acc ~f:(fun acc x -> loop x pos acc) + | Diff (l, r) -> + let acc = loop l pos acc in + let pos = + match pos with + | Pos -> Neg + | Neg -> Pos + in + loop r pos acc + in + loop t.ast Pos init + let expand t ~files_contents ~f = let context = t.context in let rec expand (t : ast) : ast_expanded = diff --git a/src/ordered_set_lang.mli b/src/ordered_set_lang.mli index 189f7013..be36d9cb 100644 --- a/src/ordered_set_lang.mli +++ b/src/ordered_set_lang.mli @@ -76,6 +76,17 @@ module Unexpanded : sig -> files_contents:Sexp.Ast.t String.Map.t -> f:(String_with_vars.t -> string) -> expanded + + type position = Pos | Neg + + (** Fold a function over all strings in a set. The callback receive + whether the string is in position or negative position, i.e. on + the left or right of a [\] operator. *) + val fold_strings + : t + -> init:'a + -> f:(position -> String_with_vars.t -> 'a -> 'a) + -> 'a end with type expanded := t module String : S with type value = string and type 'a map = 'a String.Map.t From 79f3506922bcc1e60efed437d03fcc7478b9c3bf Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sat, 30 Jun 2018 00:04:26 +0100 Subject: [PATCH 03/10] Add String_with_vars.text_only Signed-off-by: Jeremie Dimino --- src/string_with_vars.ml | 5 +++++ src/string_with_vars.mli | 3 +++ 2 files changed, 8 insertions(+) diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index 60f35ffa..ed481966 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -272,3 +272,8 @@ let is_var { template; syntax_version = _ } ~name = match template.parts with | [Var n] -> name = Var.full_name n | _ -> false + +let text_only t = + match t.template.parts with + | [Text s] -> Some s + | _ -> None diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index 72642ce9..bbc080ee 100644 --- a/src/string_with_vars.mli +++ b/src/string_with_vars.mli @@ -30,6 +30,9 @@ val virt_text : (string * int * int * int) -> string -> t val is_var : t -> name:string -> bool +(** If [t] contains no variable, returns the contents of [t]. *) +val text_only : t -> string option + module Mode : sig type 'a t = | Single : Value.t t From 30db63ef71a8fca345276de1ac7eeb704a060bd3 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 28 Jun 2018 12:39:00 +0100 Subject: [PATCH 04/10] Support @@alias to build an alias non-recursively Signed-off-by: Jeremie Dimino --- bin/main.ml | 45 ++++++++++------ doc/usage.rst | 7 +++ src/build_system.ml | 54 +++++++++++++------- src/build_system.mli | 8 +++ test/blackbox-tests/test-cases/aliases/run.t | 2 +- 5 files changed, 81 insertions(+), 35 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 8b6c3ca9..6679518c 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -114,8 +114,21 @@ end type target = | File of Path.t + | Alias of Path.t | Alias_rec of Path.t +let parse_alias path ~contexts = + let dir = Path.parent_exn path in + let name = Path.basename path in + match Path.extract_build_context dir with + | None -> (contexts, dir, name) + | Some ("install", _) -> + die "Invalid alias: %s.\n\ + There are no aliases in %s." + (Path.to_string_maybe_quoted Path.(relative build_dir "install")) + (Path.to_string_maybe_quoted path) + | Some (ctx, dir) -> ([ctx], dir, name) + let request_of_targets (setup : Main.setup) targets = let open Build.O in let contexts = List.map setup.contexts ~f:(fun c -> c.Context.name) in @@ -123,19 +136,12 @@ let request_of_targets (setup : Main.setup) targets = acc >>> match target with | File path -> Build.path path + | Alias path -> + let contexts, dir, name = parse_alias path ~contexts in + Build_system.Alias.dep_multi_contexts ~dir ~name + ~file_tree:setup.file_tree ~contexts | Alias_rec path -> - let dir = Path.parent_exn path in - let name = Path.basename path in - let contexts, dir = - match Path.extract_build_context dir with - | None -> (contexts, dir) - | Some ("install", _) -> - die "Invalid alias: %s.\n\ - There are no aliases in %s." - (Path.to_string_maybe_quoted Path.(relative build_dir "install")) - (Path.to_string_maybe_quoted path) - | Some (ctx, dir) -> ([ctx], dir) - in + let contexts, dir, name = parse_alias path ~contexts in Build_system.Alias.dep_rec_multi_contexts ~dir ~name ~file_tree:setup.file_tree ~contexts) @@ -680,7 +686,13 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = let targets = List.map user_targets ~f:(fun s -> if String.is_prefix s ~prefix:"@" then begin - let s = String.sub s ~pos:1 ~len:(String.length s - 1) in + let pos, is_rec = + if String.length s >= 2 && s.[1] = '@' then + (2, false) + else + (1, true) + in + let s = String.sub s ~pos ~len:(String.length s - pos) in let path = Path.relative Path.root (prefix_target common s) in check_path path; if Path.is_root path then @@ -688,7 +700,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = else if not (Path.is_managed path) then die "@@ on the command line must be followed by a relative path" else - Ok [Alias_rec path] + Ok [if is_rec then Alias_rec path else Alias path] end else begin let path = Path.relative Path.root (prefix_target common s) in check_path path; @@ -725,6 +737,9 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = List.iter targets ~f:(function | File path -> Log.info log @@ "- " ^ (Path.to_string path) + | Alias path -> + Log.info log @@ "- alias " ^ + (Path.to_string_maybe_quoted path) | Alias_rec path -> Log.info log @@ "- recursive alias " ^ (Path.to_string_maybe_quoted path)); @@ -1316,7 +1331,7 @@ let utop = match resolve_targets_exn ~log common setup [utop_target] with | [] -> die "no libraries defined in %s" dir | [File target] -> target - | [Alias_rec _] | _::_::_ -> assert false + | _ -> assert false in do_build setup [File target] >>| fun () -> (setup.build_system, context, Path.to_string target) diff --git a/doc/usage.rst b/doc/usage.rst index c12ba0ac..322951ba 100644 --- a/doc/usage.rst +++ b/doc/usage.rst @@ -121,6 +121,13 @@ So for instance: the ``foo`` build context - ``jbuilder build @runtest`` will run the tests for all build contexts +You can also build an alias non-recursively by using ``@@`` instead of +``@``. For instance to run tests only from the current directory: + +.. code:: + + dune build @@runtest + Finding external libraries ========================== diff --git a/src/build_system.ml b/src/build_system.ml index 16e655fb..7ac64409 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -250,10 +250,26 @@ module Alias0 = struct let fully_qualified_name t = Path.relative t.dir t.name let stamp_file t = - Path.relative (Path.insert_after_build_dir_exn t.dir ".aliases") (t.name ^ suffix) + Path.relative (Path.insert_after_build_dir_exn t.dir ".aliases") + (t.name ^ suffix) let dep t = Build.path (stamp_file t) + let find_dir_specified_on_command_line ~dir ~file_tree = + match File_tree.find_dir file_tree dir with + | None -> + die "From the command line:\n\ + @{Error@}: Don't know about directory %s!" + (Path.to_string_maybe_quoted dir) + | Some dir -> dir + + let dep_multi_contexts ~dir ~name ~file_tree ~contexts = + ignore + (find_dir_specified_on_command_line ~dir ~file_tree : File_tree.Dir.t); + Build.paths (List.map contexts ~f:(fun ctx -> + let dir = Path.append (Path.(relative build_dir) ctx) dir in + stamp_file (make ~dir name))) + let is_standard = function | "runtest" | "install" | "doc" | "doc-private" | "lint" -> true | _ -> false @@ -272,10 +288,14 @@ module Alias0 = struct ~else_:(Build.arr (fun x -> x))) let dep_rec t ~loc ~file_tree = - let ctx_dir, src_dir = Path.extract_build_context_dir t.dir |> Option.value_exn in + let ctx_dir, src_dir = + Path.extract_build_context_dir t.dir |> Option.value_exn + in match File_tree.find_dir file_tree src_dir with - | None -> Build.fail { fail = fun () -> - Loc.fail loc "Don't know about directory %s!" (Path.to_string_maybe_quoted src_dir) } + | None -> + Build.fail { fail = fun () -> + Loc.fail loc "Don't know about directory %s!" + (Path.to_string_maybe_quoted src_dir) } | Some dir -> dep_rec_internal ~name:t.name ~dir ~ctx_dir >>^ fun is_empty -> @@ -285,22 +305,18 @@ module Alias0 = struct t.name (Path.to_string_maybe_quoted src_dir) let dep_rec_multi_contexts ~dir:src_dir ~name ~file_tree ~contexts = - match File_tree.find_dir file_tree src_dir with - | None -> + let open Build.O in + let dir = find_dir_specified_on_command_line ~dir:src_dir ~file_tree in + Build.all (List.map contexts ~f:(fun ctx -> + let ctx_dir = Path.(relative build_dir) ctx in + dep_rec_internal ~name ~dir ~ctx_dir)) + >>^ fun is_empty_list -> + let is_empty = List.for_all is_empty_list ~f:(fun x -> x) in + if is_empty && not (is_standard name) then die "From the command line:\n\ - @{Error@}: Don't know about directory %s!" (Path.to_string_maybe_quoted src_dir) - | Some dir -> - let open Build.O in - Build.all (List.map contexts ~f:(fun ctx -> - let ctx_dir = Path.(relative build_dir) ctx in - dep_rec_internal ~name ~dir ~ctx_dir)) - >>^ fun is_empty_list -> - let is_empty = List.for_all is_empty_list ~f:(fun x -> x) in - if is_empty && not (is_standard name) then - die "From the command line:\n\ - @{Error@}: Alias %s is empty.\n\ - It is not defined in %s or any of its descendants." - name (Path.to_string_maybe_quoted src_dir) + @{Error@}: Alias %S is empty.\n\ + It is not defined in %s or any of its descendants." + name (Path.to_string_maybe_quoted src_dir) let default = make "DEFAULT" let runtest = make "runtest" diff --git a/src/build_system.mli b/src/build_system.mli index 631122ee..f5cbf206 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -129,6 +129,14 @@ module Alias : sig (** [dep t = Build.path (stamp_file t)] *) val dep : t -> ('a, 'a) Build.t + (** Implements [@@alias] on the command line *) + val dep_multi_contexts + : dir:Path.t + -> name:string + -> file_tree:File_tree.t + -> contexts:string list + -> (unit, unit) Build.t + (** Implements [(alias_rec ...)] in dependency specification *) val dep_rec : t diff --git a/test/blackbox-tests/test-cases/aliases/run.t b/test/blackbox-tests/test-cases/aliases/run.t index b249a3bb..78573784 100644 --- a/test/blackbox-tests/test-cases/aliases/run.t +++ b/test/blackbox-tests/test-cases/aliases/run.t @@ -13,7 +13,7 @@ running in src $ dune build --display short @plop From the command line: - Error: Alias plop is empty. + Error: Alias "plop" is empty. It is not defined in . or any of its descendants. [1] $ dune build --display short @truc/x From 0a970aba35eb2598894e1464696435dc3618c63e Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 28 Jun 2018 12:49:43 +0100 Subject: [PATCH 05/10] Improve error message for undefined aliases Signed-off-by: Jeremie Dimino --- src/build_system.ml | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/build_system.ml b/src/build_system.ml index 7ac64409..5ad424d0 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -675,9 +675,9 @@ let no_rule_found = die "No rule found for %s" (Utils.describe_target fn) in fun t fn -> - match Path.extract_build_context fn with - | None -> fail fn - | Some (ctx, _) -> + match Utils.analyse_target fn with + | Other _ -> fail fn + | Regular (ctx, _) -> if String.Map.mem t.contexts ctx then fail fn else @@ -685,6 +685,15 @@ let no_rule_found = (Path.to_string_maybe_quoted fn) ctx (hint ctx (String.Map.keys t.contexts)) + | Alias (ctx, fn') -> + if String.Map.mem t.contexts ctx then + fail fn + else + let fn = Path.append (Path.relative Path.build_dir ctx) fn' in + die "Trying to build alias %s but build context %s doesn't exist.%s" + (Path.to_string_maybe_quoted fn) + ctx + (hint ctx (String.Map.keys t.contexts)) let rec compile_rule t ?(copy_source=false) pre_rule = let { Pre_rule. From 81bcd0f3e19d1debe912ad28d0c723582b31a317 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 28 Jun 2018 12:21:13 +0100 Subject: [PATCH 06/10] Add a "default" alias defined as follow: - if "default" is specified by the user explicitely, use this definition - otherwise assume the following definition: (alias (name default) (deps (alias_rec install))) Signed-off-by: Jeremie Dimino --- CHANGES.md | 7 +++++++ bin/main.ml | 47 +++++++++++++++++++++++++++++++++++---------- doc/jbuild.rst | 2 ++ doc/terminology.rst | 3 +++ doc/usage.rst | 33 ++++++++++++++++++++++++++++--- src/build_system.ml | 27 +++++++++++++++++++++++--- 6 files changed, 103 insertions(+), 16 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 21df2d87..f418619e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -95,6 +95,13 @@ next - Version `dune-workspace` and `~/.config/dune/config` files (#..., @diml) +- Add the ability to build an alias non-recursively from the command + line by writing `@@alias` (#926, @diml) + +- Add a special `default` alias that defaults to `(alias_rec install)` + when not defined by the user and make `@@default` be the default + target (#926, @diml) + 1.0+beta20 (10/04/2018) ----------------------- diff --git a/bin/main.ml b/bin/main.ml index 6679518c..be333e73 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -26,6 +26,7 @@ type common = ; (* Original arguments for the external-lib-deps hint *) orig_args : string list ; config : Config.t + ; default_target : string } let prefix_target common s = common.target_prefix ^ s @@ -234,6 +235,7 @@ let common = ignore_promoted_rules, config_file, profile, + default_target, orig) x display @@ -296,6 +298,7 @@ let common = ; x ; config ; build_dir + ; default_target } in let docs = copts_sect in @@ -484,6 +487,20 @@ let common = in Term.(ret (const merge $ config_file $ no_config)) in + let default_target_default = + match Which_program.t with + | Dune -> "@@default" + | Jbuilder -> "@install" + in + let default_target = + Arg.(value + & opt (some string) None + & info ["default-target"] ~docs ~docv:"TARGET" + ~doc:(sprintf + {|Set the default target that when none is specified to + $(b,dune build). It defaults to %s.|} + default_target_default)) + in let for_release = "for-release-of-packages" in let frop = Arg.(value @@ -496,33 +513,37 @@ let common = packages as well as getting reproducible builds.|}) in let merge root only_packages ignore_promoted_rules - (config_file_opt, config_file) profile release = + (config_file_opt, config_file) profile default_target release = let fail opt = incompatible ("-p/--" ^ for_release) opt in match release, root, only_packages, ignore_promoted_rules, - profile, config_file_opt with - | Some _, Some _, _, _, _, _ -> fail "--root" - | Some _, _, Some _, _, _, _ -> fail "--only-packages" - | Some _, _, _, true , _, _ -> fail "--ignore-promoted-rules" - | Some _, _, _, _, Some _, _ -> fail "--profile" - | Some _, _, _, _, _, Some s -> fail s - | Some pkgs, None, None, false, None, None -> + profile, default_target, config_file_opt with + | Some _, Some _, _, _, _, _, _ -> fail "--root" + | Some _, _, Some _, _, _, _, _ -> fail "--only-packages" + | Some _, _, _, true , _, _, _ -> fail "--ignore-promoted-rules" + | Some _, _, _, _, Some _, _, _ -> fail "--profile" + | Some _, _, _, _, _, Some s, _ -> fail s + | Some _, _, _, _, _, _, Some _ -> fail "--default-target" + | Some pkgs, None, None, false, None, None, None -> `Ok (Some ".", Some pkgs, true, No_config, Some "release", + "@install", ["-p"; pkgs] ) - | None, _, _, _, _, _ -> + | None, _, _, _, _, _, _ -> `Ok (root, only_packages, ignore_promoted_rules, config_file, profile, + Option.value default_target ~default:default_target_default, List.concat [ dump_opt "--root" root ; dump_opt "--only-packages" only_packages ; dump_opt "--profile" profile + ; dump_opt "--default-target" default_target ; if ignore_promoted_rules then ["--ignore-promoted-rules"] else @@ -540,6 +561,7 @@ let common = $ ignore_promoted_rules $ config_file $ profile + $ default_target $ frop)) in let x = @@ -771,9 +793,14 @@ let build_targets = (Main.setup ~log common >>= fun setup -> let targets = resolve_targets_exn ~log common setup targets in do_build setup targets) in + let default_target = + match Which_program.t with + | Dune -> "@@default" + | Jbuilder -> "@install" + in ( Term.(const go $ common - $ Arg.(value & pos_all string ["@install"] name_)) + $ Arg.(value & pos_all string [default_target] name_)) , Term.info "build" ~doc ~man) let runtest = diff --git a/doc/jbuild.rst b/doc/jbuild.rst index 892ea76c..3e8b4065 100644 --- a/doc/jbuild.rst +++ b/doc/jbuild.rst @@ -531,6 +531,8 @@ menhir A ``menhir`` stanza is available to support the menhir_ parser generator. See the :ref:`menhir-main` section for details. +.. _alias-stanza: + alias ----- diff --git a/doc/terminology.rst b/doc/terminology.rst index 7cac56d7..aed21bd3 100644 --- a/doc/terminology.rst +++ b/doc/terminology.rst @@ -50,6 +50,9 @@ Terminology alias in all children directories recursively. Jbuilder defines the following standard aliases: + - ``default`` which is the alias build by default when no targets + are specified on the command line. See :ref:`default-alias` for + details - ``runtest`` which runs user defined tests - ``install`` which depends on everything that should be installed - ``doc`` which depends on the generated HTML diff --git a/doc/usage.rst b/doc/usage.rst index 322951ba..b3ceea8b 100644 --- a/doc/usage.rst +++ b/doc/usage.rst @@ -68,8 +68,9 @@ directory as this is normally the case. Interpretation of targets ========================= -This section describes how ``jbuilder`` interprets the targets given on -the command line. +This section describes how ``dune`` interprets the targets given on +the command line. When no targets are specified, ``dune`` builds the +``default`` alias, see :ref:`default-alias` for more details. Resolution ---------- @@ -128,6 +129,31 @@ You can also build an alias non-recursively by using ``@@`` instead of dune build @@runtest +.. _default-alias: + +Default alias +------------- + +When no targets are given to ``dune build``, it builds the special +``default`` alias. Effectively ``dune build`` is equivalent to: + +.. code:: + + dune build @@default + +When a directory doesn't explicitly define what the ``default`` alias +means via an :ref:`alias-stanza` stanza, the following implicit +definition is assumed: + +.. code:: + + (alias + (name default) + (deps (alias_rec install))) + +Which means that by default ``dune build`` will build everything that +is installable. + Finding external libraries ========================== @@ -214,7 +240,7 @@ follows: build: [["dune" "build" "-p" name "-j" jobs]] ``-p pkg`` is a shorthand for ``--root . --only-packages pkg --profile -release``. ``-p`` is the short version of +release --default-target @install``. ``-p`` is the short version of ``--for-release-of-packages``. This has the following effects: @@ -224,6 +250,7 @@ This has the following effects: - it sets the root to prevent jbuilder from looking it up - it sets the build profile to ``release`` - it uses whatever concurrency option opam provides +- it sets the default target to ``@install`` rather than ``@@default`` Note that ``name`` and ``jobs`` are variables expanded by opam. ``name`` expands to the package name and ``jobs`` to the number of jobs available diff --git a/src/build_system.ml b/src/build_system.ml index 5ad424d0..281b6a7e 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -271,7 +271,7 @@ module Alias0 = struct stamp_file (make ~dir name))) let is_standard = function - | "runtest" | "install" | "doc" | "doc-private" | "lint" -> true + | "runtest" | "install" | "doc" | "doc-private" | "lint" | "default" -> true | _ -> false open Build.O @@ -318,7 +318,7 @@ module Alias0 = struct It is not defined in %s or any of its descendants." name (Path.to_string_maybe_quoted src_dir) - let default = make "DEFAULT" + let default = make "default" let runtest = make "runtest" let install = make "install" let doc = make "doc" @@ -914,7 +914,28 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators = let alias_dir = Path.append (Path.relative alias_dir context_name) sub_dir in let alias_rules, alias_stamp_files = let open Build.O in - String.Map.foldi collector.aliases ~init:([], Path.Set.empty) + let aliases = collector.aliases in + let aliases = + if String.Map.mem collector.aliases "default" then + aliases + else + match Path.extract_build_context_dir dir with + | None -> aliases + | Some (_, src_dir) -> + match File_tree.find_dir t.file_tree src_dir with + | None -> aliases + | Some _ -> + String.Map.add aliases "default" + { deps = Path.Set.empty + ; dyn_deps = + Alias0.dep_rec (Alias0.install ~dir) ~loc:Loc.none + ~file_tree:t.file_tree + >>> + Build.return Path.Set.empty + ; actions = [] + } + in + String.Map.foldi aliases ~init:([], Path.Set.empty) ~f:(fun name { Dir_status. deps; dyn_deps; actions } (rules, alias_stamp_files) -> let base_path = Path.relative alias_dir name in let rules, deps = From fc9f3357abd8106765d9217153b3925b2c0fbdf7 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 28 Jun 2018 17:55:52 +0100 Subject: [PATCH 07/10] Allow some part of a Build.t to be lazy This is useful for (alias_rec ...) since at definition site we recurse through all sub-directories. This is especially relevant now that we have the default alias which defaults to (alias_rec install). Signed-off-by: Jeremie Dimino --- src/build.ml | 3 ++ src/build.mli | 5 +++ src/build_interpret.ml | 46 ++++++++++++++++--------- src/build_system.ml | 77 ++++++++++++++++++++++++------------------ 4 files changed, 82 insertions(+), 49 deletions(-) diff --git a/src/build.ml b/src/build.ml index 94310da1..034bd03c 100644 --- a/src/build.ml +++ b/src/build.ml @@ -37,6 +37,7 @@ module Repr = struct | Fail : fail -> (_, _) t | Memo : 'a memo -> (unit, 'a) t | Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t + | Lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t and 'a memo = { name : string @@ -132,6 +133,8 @@ let rec all = function >>> arr (fun (x, y) -> x :: y) +let lazy_no_targets t = Lazy_no_targets t + let path p = Paths (Path.Set.singleton p) let paths ps = Paths (Path.Set.of_list ps) let path_set ps = Paths ps diff --git a/src/build.mli b/src/build.mli index aed438c6..357592e2 100644 --- a/src/build.mli +++ b/src/build.mli @@ -34,6 +34,10 @@ val fanout4 : ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t -> ('a, 'e) t -> ('a, 'b * val all : ('a, 'b) t list -> ('a, 'b list) t +(** Optimization to avoiding eagerly computing a [Build.t] value, + assume it contains no targets. *) +val lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t + (* CR-someday diml: this API is not great, what about: {[ @@ -202,6 +206,7 @@ module Repr : sig | Fail : fail -> (_, _) t | Memo : 'a memo -> (unit, 'a) t | Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t + | Lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t and 'a memo = { name : string diff --git a/src/build_interpret.ml b/src/build_interpret.ml index a4e7de9f..578d2dd8 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -49,17 +49,23 @@ let inspect_path file_tree path = else None +let no_targets_allowed () = + Exn.code_error "No targets allowed under a [Build.lazy_no_targets] \ + or [Build.if_file_exists]" [] +[@@inline never] + let static_deps t ~all_targets ~file_tree = - let rec loop : type a b. (a, b) t -> Static_deps.t -> Static_deps.t = fun t acc -> + let rec loop : type a b. (a, b) t -> Static_deps.t -> bool -> Static_deps.t + = fun t acc targets_allowed -> match t with | Arr _ -> acc - | Targets _ -> acc - | Store_vfile _ -> acc - | Compose (a, b) -> loop a (loop b acc) - | First t -> loop t acc - | Second t -> loop t acc - | Split (a, b) -> loop a (loop b acc) - | Fanout (a, b) -> loop a (loop b acc) + | Targets _ -> if not targets_allowed then no_targets_allowed (); acc + | Store_vfile _ -> if not targets_allowed then no_targets_allowed (); acc + | Compose (a, b) -> loop a (loop b acc targets_allowed) targets_allowed + | First t -> loop t acc targets_allowed + | Second t -> loop t acc targets_allowed + | Split (a, b) -> loop a (loop b acc targets_allowed) targets_allowed + | Fanout (a, b) -> loop a (loop b acc targets_allowed) targets_allowed | Paths fns -> { acc with action_deps = Path.Set.union fns acc.action_deps } | Paths_for_rule fns -> { acc with rule_deps = Path.Set.union fns acc.rule_deps } @@ -93,28 +99,34 @@ let static_deps t ~all_targets ~file_tree = end | If_file_exists (p, state) -> begin match !state with - | Decided (_, t) -> loop t acc + | Decided (_, t) -> loop t acc false | Undecided (then_, else_) -> let dir = Path.parent_exn p in let targets = all_targets ~dir in if Path.Set.mem targets p then begin state := Decided (true, then_); - loop then_ acc + loop then_ acc false end else begin state := Decided (false, else_); - loop else_ acc + loop else_ acc false end end - | Dyn_paths t -> loop t acc - | Vpath (Vspec.T (p, _)) -> { acc with rule_deps = Path.Set.add acc.rule_deps p } + | Dyn_paths t -> loop t acc targets_allowed + | Vpath (Vspec.T (p, _)) -> + { acc with rule_deps = Path.Set.add acc.rule_deps p } | Contents p -> { acc with rule_deps = Path.Set.add acc.rule_deps p } | Lines_of p -> { acc with rule_deps = Path.Set.add acc.rule_deps p } | Record_lib_deps _ -> acc | Fail _ -> acc - | Memo m -> loop m.t acc - | Catch (t, _) -> loop t acc + | Memo m -> loop m.t acc targets_allowed + | Catch (t, _) -> loop t acc targets_allowed + | Lazy_no_targets t -> loop (Lazy.force t) acc false in - loop (Build.repr t) { rule_deps = Path.Set.empty; action_deps = Path.Set.empty } + loop (Build.repr t) + { rule_deps = Path.Set.empty + ; action_deps = Path.Set.empty + } + true let lib_deps = let rec loop : type a b. (a, b) t -> Build.lib_deps -> Build.lib_deps @@ -141,6 +153,7 @@ let lib_deps = loop (get_if_file_exists_exn state) acc | Memo m -> loop m.t acc | Catch (t, _) -> loop t acc + | Lazy_no_targets t -> loop (Lazy.force t) acc in fun t -> loop (Build.repr t) String.Map.empty @@ -183,6 +196,7 @@ let targets = end | Memo m -> loop m.t acc | Catch (t, _) -> loop t acc + | Lazy_no_targets _ -> acc in fun t -> loop (Build.repr t) [] diff --git a/src/build_system.ml b/src/build_system.ml index 281b6a7e..ea71d66d 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -164,8 +164,7 @@ module Internal_rule = struct type t = { id : Id.t - ; rule_deps : Path.Set.t - ; static_deps : Path.Set.t + ; static_deps : Build_interpret.Static_deps.t Lazy.t ; targets : Path.Set.t ; context : Context.t option ; build : (unit, Action.t) Build.t @@ -178,6 +177,12 @@ module Internal_rule = struct let compare a b = Id.compare a.id b.id let loc ~file_tree ~dir t = rule_loc ~file_tree ~dir ~loc:t.loc + + let lib_deps t = + (* Forcing this lazy ensures that the various globs and + [if_file_exists] are resolved inside the [Build.t] value. *) + ignore (Lazy.force t.static_deps : Build_interpret.Static_deps.t); + Build_interpret.lib_deps t.build end module File_kind = struct @@ -277,15 +282,17 @@ module Alias0 = struct open Build.O let dep_rec_internal ~name ~dir ~ctx_dir = - File_tree.Dir.fold dir ~traverse_ignored_dirs:false ~init:(Build.return true) - ~f:(fun dir acc -> - let path = Path.append ctx_dir (File_tree.Dir.path dir) in - let fn = stamp_file (make ~dir:path name) in - acc - >>> - Build.if_file_exists fn - ~then_:(Build.path fn >>^ fun _ -> false) - ~else_:(Build.arr (fun x -> x))) + Build.lazy_no_targets (lazy ( + File_tree.Dir.fold dir ~traverse_ignored_dirs:false + ~init:(Build.return true) + ~f:(fun dir acc -> + let path = Path.append ctx_dir (File_tree.Dir.path dir) in + let fn = stamp_file (make ~dir:path name) in + acc + >>> + Build.if_file_exists fn + ~then_:(Build.path fn >>^ fun _ -> false) + ~else_:(Build.arr (fun x -> x))))) let dep_rec t ~loc ~file_tree = let ctx_dir, src_dir = @@ -300,8 +307,9 @@ module Alias0 = struct dep_rec_internal ~name:t.name ~dir ~ctx_dir >>^ fun is_empty -> if is_empty && not (is_standard t.name) then - Loc.fail loc "This alias is empty.\n\ - Alias %S is not defined in %s or any of its descendants." + Loc.fail loc + "This alias is empty.\n\ + Alias %S is not defined in %s or any of its descendants." t.name (Path.to_string_maybe_quoted src_dir) let dep_rec_multi_contexts ~dir:src_dir ~name ~file_tree ~contexts = @@ -518,6 +526,8 @@ module Build_exec = struct with exn -> on_error exn end + | Lazy_no_targets t -> + exec dyn_deps (Lazy.force t) x | Memo m -> match m.state with | Evaluated (x, deps) -> @@ -709,20 +719,19 @@ let rec compile_rule t ?(copy_source=false) pre_rule = pre_rule in let targets = Target.paths target_specs in - let { Build_interpret.Static_deps. - rule_deps - ; action_deps = static_deps - } = Build_interpret.static_deps build ~all_targets:(targets_of t) - ~file_tree:t.file_tree + let static_deps = + lazy (Build_interpret.static_deps build ~all_targets:(targets_of t) + ~file_tree:t.file_tree) in let eval_rule () = t.hook Rule_started; - wait_for_deps t rule_deps + wait_for_deps t (Lazy.force static_deps).rule_deps >>| fun () -> Build_exec.exec t build () in let exec_rule (rule_evaluation : Exec_status.rule_evaluation) = + let static_deps = (Lazy.force static_deps).action_deps in Fiber.fork_and_join_unit (fun () -> wait_for_deps t static_deps) @@ -826,7 +835,6 @@ let rec compile_rule t ?(copy_source=false) pre_rule = { Internal_rule. id = Internal_rule.Id.gen () ; static_deps - ; rule_deps ; targets ; build ; context @@ -921,17 +929,16 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators = else match Path.extract_build_context_dir dir with | None -> aliases - | Some (_, src_dir) -> + | Some (ctx_dir, src_dir) -> match File_tree.find_dir t.file_tree src_dir with | None -> aliases - | Some _ -> + | Some dir -> String.Map.add aliases "default" { deps = Path.Set.empty ; dyn_deps = - Alias0.dep_rec (Alias0.install ~dir) ~loc:Loc.none - ~file_tree:t.file_tree - >>> - Build.return Path.Set.empty + (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir + >>^ fun (_ : bool) -> + Path.Set.empty) ; actions = [] } in @@ -1297,7 +1304,8 @@ let rules_for_targets t targets = Internal_rule.Id.Top_closure.top_closure (rules_for_files t targets) ~key:(fun (r : Internal_rule.t) -> r.id) ~deps:(fun (r : Internal_rule.t) -> - rules_for_files t (Path.Set.union r.static_deps r.rule_deps)) + let x = Lazy.force r.static_deps in + rules_for_files t (Path.Set.union x.action_deps x.rule_deps)) with | Ok l -> l | Error cycle -> @@ -1319,8 +1327,8 @@ let static_deps_of_request t request = let all_lib_deps t ~request = let targets = static_deps_of_request t request in List.fold_left (rules_for_targets t targets) ~init:Path.Map.empty - ~f:(fun acc (rule : Internal_rule.t) -> - let deps = Build_interpret.lib_deps rule.build in + ~f:(fun acc rule -> + let deps = Internal_rule.lib_deps rule in if String.Map.is_empty deps then acc else @@ -1334,8 +1342,8 @@ let all_lib_deps t ~request = let all_lib_deps_by_context t ~request = let targets = static_deps_of_request t request in let rules = rules_for_targets t targets in - List.fold_left rules ~init:[] ~f:(fun acc (rule : Internal_rule.t) -> - let deps = Build_interpret.lib_deps rule.build in + List.fold_left rules ~init:[] ~f:(fun acc rule -> + let deps = Internal_rule.lib_deps rule in if String.Map.is_empty deps then acc else @@ -1404,9 +1412,10 @@ let build_rules_internal ?(recursive=false) t ~request = Fiber.fork (fun () -> Fiber.Future.wait rule_evaluation >>| fun (action, dyn_deps) -> + let static_deps = (Lazy.force ir.static_deps).action_deps in { Rule. id = ir.id - ; deps = Path.Set.union ir.static_deps dyn_deps + ; deps = Path.Set.union static_deps dyn_deps ; targets = ir.targets ; context = ir.context ; action = action @@ -1483,7 +1492,9 @@ let package_deps t pkg files = Option.value_exn (Fiber.Future.peek rule_evaluation) | Not_started _ -> assert false in - Path.Set.fold (Path.Set.union ir.static_deps dyn_deps) ~init:acc ~f:loop + Path.Set.fold + (Path.Set.union (Lazy.force ir.static_deps).action_deps dyn_deps) + ~init:acc ~f:loop end in let open Build.O in From 9029c61539cf13aa6a6921510a7c2e568225f328 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sun, 1 Jul 2018 21:57:17 +0100 Subject: [PATCH 08/10] Update changelog Signed-off-by: Jeremie Dimino --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index f418619e..c2fceb22 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -93,7 +93,7 @@ next - Make `dev` the default build profile (#920, @diml) -- Version `dune-workspace` and `~/.config/dune/config` files (#..., @diml) +- Version `dune-workspace` and `~/.config/dune/config` files (#932, @diml) - Add the ability to build an alias non-recursively from the command line by writing `@@alias` (#926, @diml) From 0c47cab6062f86fcaad215c7f790c29a7802aa48 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sun, 1 Jul 2018 21:57:40 +0100 Subject: [PATCH 09/10] Fix cmdliner errors Signed-off-by: Jeremie Dimino --- bin/main.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index be333e73..b135def1 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1468,10 +1468,10 @@ module Help = struct Unix systems and $(b,Local Settings/dune/config) in the User home directory on Windows. However, it is possible to specify an alternative configuration file with the $(b,--config-file) option.|} - ; `P {|The first line of the file must be of the form (lang dune X.Y) \ + ; `P {|The first line of the file must be of the form (lang dune X.Y) where X.Y is the version of the dune language used in the file.|} - ; `P {|The rest of the file must be written in S-expression syntax and be \ - composed of a list of stanzas. The following sections describe \ + ; `P {|The rest of the file must be written in S-expression syntax and be + composed of a list of stanzas. The following sections describe the stanzas available.|} ; `S "DISPLAY MODES" ; `P {|Syntax: $(b,\(display MODE\))|} From d53179a56e96e4b53c1a5bd6981ec7f636f8a6d7 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 2 Jul 2018 04:08:13 +0700 Subject: [PATCH 10/10] Make install tests less verbose (#936) Signed-off-by: Rudi Grinberg --- .../test-cases/gen-opam-install-file/run.t | 31 +------------------ 1 file changed, 1 insertion(+), 30 deletions(-) diff --git a/test/blackbox-tests/test-cases/gen-opam-install-file/run.t b/test/blackbox-tests/test-cases/gen-opam-install-file/run.t index 032d61f5..17332f07 100644 --- a/test/blackbox-tests/test-cases/gen-opam-install-file/run.t +++ b/test/blackbox-tests/test-cases/gen-opam-install-file/run.t @@ -1,33 +1,4 @@ - $ dune runtest --display short - ocamldep .bar.eobjs/bar.ml.d - ocamldep .foo.objs/foo.ml.d - ocamldep .foo.objs/foo.mli.d - ocamlc .foo.objs/foo.{cmi,cmti} - ocamlopt .foo.objs/foo.{cmx,o} - ocamlopt foo.{a,cmxa} - ocamlopt foo.cmxs - ocamldep .foo_byte.objs/foo_byte.ml.d - ocamlc .foo_byte.objs/foo_byte.{cmi,cmo,cmt} - ocamlc foo_byte.cma - ocamldep ppx-new/.foo_ppx_rewriter_dune.objs/foo_ppx_rewriter_dune.ml.d - ocamlc ppx-new/.foo_ppx_rewriter_dune.objs/foo_ppx_rewriter_dune.{cmi,cmo,cmt} - ocamlopt ppx-new/.foo_ppx_rewriter_dune.objs/foo_ppx_rewriter_dune.{cmx,o} - ocamlopt ppx-new/foo_ppx_rewriter_dune.{a,cmxa} - ocamlopt ppx-new/foo_ppx_rewriter_dune.cmxs - ocamldep ppx-old/.foo_ppx_rewriter_jbuild.objs/foo_ppx_rewriter_jbuild.ml.d - ocamlc ppx-old/.foo_ppx_rewriter_jbuild.objs/foo_ppx_rewriter_jbuild.{cmi,cmo,cmt} - ocamlopt ppx-old/.foo_ppx_rewriter_jbuild.objs/foo_ppx_rewriter_jbuild.{cmx,o} - ocamlopt ppx-old/foo_ppx_rewriter_jbuild.{a,cmxa} - ocamlopt ppx-old/foo_ppx_rewriter_jbuild.cmxs - ocamlc .foo.objs/foo.{cmo,cmt} - ocamlc foo.cma - ocamlc .bar.eobjs/bar.{cmi,cmo,cmt} - ocamlopt .bar.eobjs/bar.{cmx,o} - ocamlopt bar.exe - ocamlc ppx-new/foo_ppx_rewriter_dune.cma - ocamlopt .ppx/foo.ppx_rewriter_dune/ppx.exe - ocamlc ppx-old/foo_ppx_rewriter_jbuild.cma - ocamlopt .ppx/jbuild/foo.ppx_rewriter_jbuild/ppx.exe + $ dune runtest lib: [ "_build/install/default/lib/foo/META" {"META"} "_build/install/default/lib/foo/opam" {"opam"}