From ef05a2ea3053aea8ae78a368d4a2c3d556d61234 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Thu, 3 Jun 2021 10:28:15 +0100 Subject: [PATCH] Get rid of the last remaning bits of "static evaluation" (#4662) Signed-off-by: Jeremie Dimino --- src/dune_engine/action_builder.ml | 130 +---- src/dune_engine/action_builder.mli | 12 +- src/dune_engine/string_with_vars.ml | 2 +- src/dune_engine/string_with_vars.mli | 2 +- src/dune_lang/template.mli | 2 + src/dune_rules/action_unexpanded.ml | 290 +++++----- src/dune_rules/action_unexpanded.mli | 2 +- src/dune_rules/blang.ml | 14 +- src/dune_rules/blang.mli | 6 +- src/dune_rules/cram_rules.ml | 17 +- src/dune_rules/dep_conf_eval.ml | 253 +++++---- src/dune_rules/dir_contents.ml | 5 +- src/dune_rules/dune_file.ml | 7 +- src/dune_rules/dune_file.mli | 5 +- src/dune_rules/env_node.ml | 4 +- src/dune_rules/expander.ml | 508 +++++++++++------- src/dune_rules/expander.mli | 78 +-- src/dune_rules/file_binding.ml | 28 +- src/dune_rules/file_binding.mli | 14 +- src/dune_rules/foreign_rules.ml | 130 ++--- src/dune_rules/gen_rules.ml | 125 +++-- src/dune_rules/install_rules.ml | 72 +-- src/dune_rules/lib_rules.ml | 4 +- src/dune_rules/merlin.ml | 26 +- src/dune_rules/ml_sources.ml | 13 +- src/dune_rules/preprocessing.ml | 76 +-- src/dune_rules/preprocessing.mli | 2 +- src/dune_rules/scope.ml | 114 ++-- src/dune_rules/scope.mli | 2 +- src/dune_rules/simple_rules.ml | 46 +- src/dune_rules/super_context.ml | 42 +- src/dune_rules/toplevel.ml | 60 +-- src/memo/memo.ml | 4 + src/memo/memo.mli | 2 + .../test-cases/coq/compose-cycle.t/run.t | 2 + .../test-cases/coq/compose-two-scopes.t/run.t | 1 + .../coq/public-dep-on-private.t/run.t | 1 + .../test-cases/deps-conf-vars.t/run.t | 1 + .../enabled_if/eif-context_name.t/run.t | 5 + .../test-cases/env/env-bin-pform.t/run.t | 1 + .../named-dep-in-diff-question-mark.t | 20 + 41 files changed, 1107 insertions(+), 1021 deletions(-) create mode 100644 test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t diff --git a/src/dune_engine/action_builder.ml b/src/dune_engine/action_builder.ml index d7647f379aa..c2484f5800d 100644 --- a/src/dune_engine/action_builder.ml +++ b/src/dune_engine/action_builder.ml @@ -36,6 +36,9 @@ module T = struct | Goal : 'a t -> 'a t | Action : Action_desc.t t -> unit t | Action_stdout : Action_desc.t t -> string t + | Push_stack_frame : + (unit -> User_message.Style.t Pp.t) * (unit -> 'a t) + -> 'a t and 'a memo = { name : string @@ -78,6 +81,9 @@ let ignore x = Map (Fun.const (), x) let map2 x y ~f = Map2 (f, x, y) +let push_stack_frame ~human_readable_description f = + Push_stack_frame (human_readable_description, f) + let delayed f = Map (f, Pure ()) let all_unit xs = @@ -408,134 +414,20 @@ struct let* act, facts = exec t in let+ s = Build_deps.execute_action_stdout ~observing_facts:facts act in (s, Dep.Map.empty) + | Push_stack_frame (human_readable_description, f) -> + Memo.push_stack_frame ~human_readable_description (fun () -> + exec (f ())) end include Execution end -(* Static evaluation *) - -(* Note: there is some duplicated logic between [can_eval_statically] and - [static_eval]. More precisely, [can_eval_statically] returns [false] exactly - for the nodes [static_eval] produces [assert false]. The duplication is not - ideal, but the code is simpler this way and also we expect that we will get - rid of this function eventually, once we have pushed the [Memo.Build.t] monad - enough in the code base. - - If this code ends being more permanent that we expected, we should probably - get rid of the duplication. This code was introduced on February 2021, to - give an idea of how long it has been here. *) - -let rec can_eval_statically : type a. a t -> bool = function - | Pure _ -> true - | Map (_, a) -> can_eval_statically a - | Both (a, b) -> can_eval_statically a && can_eval_statically b - | Seq (a, b) -> can_eval_statically a && can_eval_statically b - | Map2 (_, a, b) -> can_eval_statically a && can_eval_statically b - | All xs -> List.for_all xs ~f:can_eval_statically - | Paths_glob _ -> false - | Deps _ -> true - | Dyn_paths b -> can_eval_statically b - | Dyn_deps b -> can_eval_statically b - | Source_tree _ -> false - | Contents _ -> false - | Lines_of _ -> false - | Fail _ -> true - | If_file_exists (_, _, _) -> false - | Memo _ -> false - | Memo_build _ -> false - | Dyn_memo_build _ -> false - | Bind _ -> - (* TODO jeremiedimino: This should be [can_eval_statically t], however it - breaks the [Expander.set_artifacts_dynamic] trick that it used to break a - cycle. The cycle is as follow: - - - [(rule (deps %{cmo:x}) ..)] requires expanding %{cmo:x} - - - expanding %{cmo:x} requires computing the artifacts DB - - - computing the artifacts DB requires computing the module<->library - assignment - - - computing the above requires knowing the set of source files (static - and generated) in a given directory - - - computing the above works by looking at the source tree and adding all - targets of user rules - - - computing targets of user rules is done by effectively generating the - rules for the user rules, which means interpreting the [(deps - %{cmo:...})] thing - - If we find another way to break this cycle we should be able to change - this code. *) - false - | Dep_on_alias_if_exists _ -> false - | Goal t -> can_eval_statically t - | Action _ -> false - | Action_stdout _ -> false - -let static_eval = - let rec loop : type a. a t -> Dep.Set.t -> a * Dep.Set.t = - fun t acc -> - match t with - | Pure x -> (x, acc) - | Map (f, a) -> - let x, acc = loop a acc in - (f x, acc) - | Both (a, b) -> - let a, acc = loop a acc in - let b, acc = loop b acc in - ((a, b), acc) - | Seq (a, b) -> - let (), acc = loop a acc in - let b, acc = loop b acc in - (b, acc) - | Map2 (f, a, b) -> - let a, acc = loop a acc in - let b, acc = loop b acc in - (f a b, acc) - | All xs -> loop_many [] xs acc - | Paths_glob _ -> assert false - | Deps deps -> ((), Dep.Set.union deps acc) - | Dyn_paths b -> - let (x, ps), acc = loop b acc in - (x, Dep.Set.union (Dep.Set.of_files_set ps) acc) - | Dyn_deps b -> - let (x, deps), acc = loop b acc in - (x, Dep.Set.union deps acc) - | Source_tree _ -> assert false - | Contents _ -> assert false - | Lines_of _ -> assert false - | Fail { fail } -> fail () - | If_file_exists (_, _, _) -> assert false - | Memo _ -> assert false - | Memo_build _ -> assert false - | Dyn_memo_build _ -> assert false - | Bind _ -> assert false - | Dep_on_alias_if_exists _ -> assert false - | Goal t -> loop t acc - | Action _ -> assert false - | Action_stdout _ -> assert false - and loop_many : type a. a list -> a t list -> Dep.Set.t -> a list * Dep.Set.t - = - fun acc_res l acc -> - match l with - | [] -> (List.rev acc_res, acc) - | t :: l -> - let x, acc = loop t acc in - loop_many (x :: acc_res) l acc - in - fun t -> - if can_eval_statically t then - Some (loop t Dep.Set.empty) - else - None - let dyn_memo_build_deps t = dyn_deps (dyn_memo_build t) let dep_on_alias_if_exists t = Dep_on_alias_if_exists t module List = struct let map l ~f = all (List.map l ~f) + + let concat_map l ~f = map l ~f >>| List.concat end diff --git a/src/dune_engine/action_builder.mli b/src/dune_engine/action_builder.mli index 588f1e17bc8..9e8985a9041 100644 --- a/src/dune_engine/action_builder.mli +++ b/src/dune_engine/action_builder.mli @@ -86,8 +86,15 @@ val all_unit : unit t list -> unit t module List : sig val map : 'a list -> f:('a -> 'b t) -> 'b list t + + val concat_map : 'a list -> f:('a -> 'b list t) -> 'b list t end +val push_stack_frame : + human_readable_description:(unit -> User_message.Style.t Pp.t) + -> (unit -> 'a t) + -> 'a t + (** Delay a static computation until the description is evaluated *) val delayed : (unit -> 'a) -> 'a t @@ -253,11 +260,6 @@ val action : Action_desc.t t -> unit t (** Same as [action], but captures the output of the action. *) val action_stdout : Action_desc.t t -> string t -(** {1 Analysis} *) - -(** Returns [Some (x, deps)] if the following can be evaluated statically. *) -val static_eval : 'a t -> ('a * Dep.Set.t) option - (** [goal t] ignores all facts that have been accumulated about the dependencies of [t]. For example, [goal (path p)] declares that a path [p] contributes to the "goal" of the resulting action builder, which means [p] must be built, diff --git a/src/dune_engine/string_with_vars.ml b/src/dune_engine/string_with_vars.ml index edb8ce5fa63..e2318b294a8 100644 --- a/src/dune_engine/string_with_vars.ml +++ b/src/dune_engine/string_with_vars.ml @@ -296,7 +296,7 @@ struct { t with parts } end -include Make_expander (Applicative.Id) +include Make_expander (Memo.Build) let is_pform t pform = match t.parts with diff --git a/src/dune_engine/string_with_vars.mli b/src/dune_engine/string_with_vars.mli index c77df1593f5..dfc9d6767a8 100644 --- a/src/dune_engine/string_with_vars.mli +++ b/src/dune_engine/string_with_vars.mli @@ -119,7 +119,7 @@ module type Expander = sig t -> dir:Path.t -> f:Value.t list option app expander -> t app end -include Expander with type 'a app := 'a +include Expander with type 'a app := 'a Memo.Build.t module Make_expander (A : Applicative) : Expander with type 'a app := 'a A.t diff --git a/src/dune_lang/template.mli b/src/dune_lang/template.mli index 9fe44bbaeef..b0909856b5c 100644 --- a/src/dune_lang/template.mli +++ b/src/dune_lang/template.mli @@ -7,6 +7,8 @@ module Pform : sig ; payload : string option } + val to_string : t -> string + val to_dyn : t -> Dyn.t val name : t -> string diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index d9c2343a908..27f0481f77f 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -3,6 +3,12 @@ open! Stdune open Import module Mapper = Action_mapper.Make (Action_dune_lang) (Action_dune_lang) +(* So that we can confortably use both the [Action_builder.O] and [Memo.BUild.O] + monad at the same time *) +let ( let+! ) = Memo.Build.O.( let+ ) + +let ( let*! ) = Memo.Build.O.( let* ) + let as_in_build_dir ~what ~loc p = match Path.as_in_build_dir p with | Some p -> p @@ -35,7 +41,8 @@ module Action_expander : sig val set_env : var:string -> value:string t -> (value:string -> 'a) t -> 'a t - val run : 'a t -> expander:Expander.t -> 'a Action_builder.With_targets.t + val run : + 'a t -> expander:Expander.t -> 'a Action_builder.With_targets.t Memo.Build.t (* String with vars expansion *) module E : sig @@ -63,19 +70,20 @@ module Action_expander : sig val prog_and_args : String_with_vars.t -> (Action.Prog.t * string list) t - (* Expand a template statically and pass it to [f]. Raise if it cannot be - expanded statically. *) - val static_path : String_with_vars.t -> f:(Path.t -> 'a t) -> 'a t + module At_rule_eval_stage : sig + (* Expansion that happens at the time the rule is constructed rather than + at the time the rule is being executed. As a result, the result can be + used immediately. However, percent forms that introduce action + dependencies are disallowed. *) + val path : String_with_vars.t -> f:(Path.t -> 'a t) -> 'a t - val static_string : String_with_vars.t -> f:(string -> 'a t) -> 'a t + val string : String_with_vars.t -> f:(string -> 'a t) -> 'a t + end end end = struct open Action_builder.O - type deps = - { static : Path.Set.t - ; dyn : Path.Set.t Action_builder.t - } + type deps = Path.Set.t Action_builder.t type collector = { targets : Path.Build.Set.t @@ -89,63 +97,61 @@ end = struct ; dir : Path.Build.t } - type 'a t = env -> collector -> 'a Action_builder.t * collector + type 'a t = env -> collector -> ('a Action_builder.t * collector) Memo.Build.t - let return x _env acc = (Action_builder.return x, acc) + let return x _env acc = Memo.Build.return (Action_builder.return x, acc) let map t ~f env acc = - let b, acc = t env acc in + let+! b, acc = t env acc in (Action_builder.map b ~f, acc) let both a b env acc = - let a, acc = a env acc in - let b, acc = b env acc in - (Action_builder.both a b, acc) + let*! a, acc = a env acc in + let*! b, acc = b env acc in + Memo.Build.return (Action_builder.both a b, acc) let all = let rec loop res l env acc = match l with - | [] -> (Action_builder.map (Action_builder.all res) ~f:List.rev, acc) + | [] -> + Memo.Build.return + (Action_builder.map (Action_builder.all res) ~f:List.rev, acc) | t :: l -> - let x, acc = t env acc in + let*! x, acc = t env acc in loop (x :: res) l env acc in fun l env acc -> loop [] l env acc let run t ~expander = - let deps = - { static = Path.Set.empty; dyn = Action_builder.return Path.Set.empty } - in + let deps = Action_builder.return Path.Set.empty in let acc = { targets = Path.Build.Set.empty; deps; deps_if_exist = deps } in let env = { expander; infer = true; dir = Expander.dir expander } in - let b, acc = t env acc in - let { targets; deps; deps_if_exist } = acc in - (* A file can be inferred as both a dependency and a target, for instance: - - {[ (progn (copy a b) (copy b c)) ]} *) - let remove_targets = - let targets = - Path.Build.Set.to_list targets |> Path.Set.of_list_map ~f:Path.build - in - fun deps -> Path.Set.diff deps targets - in - let action_builder_path_set_if_exist deps_if_exist = - Path.Set.fold deps_if_exist ~init:(Action_builder.return ()) - ~f:(fun f acc -> - acc - >>> Action_builder.if_file_exists f ~then_:(Action_builder.path f) - ~else_:(Action_builder.return ())) - in - let add_deps f { static; dyn } = - f (remove_targets static) - >>> let* set = dyn in - f (remove_targets set) - in - Action_builder.with_targets_set ~targets - (let+ () = add_deps Action_builder.path_set deps - and+ () = add_deps action_builder_path_set_if_exist deps_if_exist - and+ res = b in - res) + Memo.Build.map (t env acc) ~f:(fun (b, acc) -> + let { targets; deps; deps_if_exist } = acc in + (* A file can be inferred as both a dependency and a target, for + instance: + + {[ (progn (copy a b) (copy b c)) ]} *) + let remove_targets = + let targets = + Path.Build.Set.to_list targets |> Path.Set.of_list_map ~f:Path.build + in + fun deps -> Path.Set.diff deps targets + in + let deps = deps >>| remove_targets in + let deps_if_exist = deps_if_exist >>| remove_targets in + let action_builder_path_set_if_exist deps_if_exist = + Path.Set.fold deps_if_exist ~init:(Action_builder.return ()) + ~f:(fun f acc -> + acc + >>> Action_builder.if_file_exists f ~then_:(Action_builder.path f) + ~else_:(Action_builder.return ())) + in + Action_builder.with_targets_set ~targets + (let+ () = deps >>= Action_builder.path_set + and+ () = deps_if_exist >>= action_builder_path_set_if_exist + and+ res = b in + res)) let chdir dir t env acc = (* We do not change the directory of the expander to make sure payloads are @@ -166,14 +172,14 @@ end = struct t { env with dir } acc let set_env ~var ~value t env acc = - let value, acc = value env acc in + let*! value, acc = value env acc in let value = Action_builder.memoize "env var" value in let env = { env with expander = Expander.set_local_env_var env.expander ~var ~value } in - let f, acc = t env acc in + let+! f, acc = t env acc in let b = let+ f = f and+ value = value in @@ -182,7 +188,7 @@ end = struct (b, acc) let no_infer t env acc = - let x, _acc = t { env with infer = false } acc in + let+! x, _acc = t { env with infer = false } acc in (x, acc) module O = struct @@ -191,9 +197,9 @@ end = struct let ( and+ ) = both let ( >>> ) a b env acc = - let a, acc = a env acc in - let b, acc = b env acc in - (Action_builder.O.( >>> ) a b, acc) + let*! a, acc = a env acc in + let*! b, acc = b env acc in + Memo.Build.return (Action_builder.O.( >>> ) a b, acc) end module E = struct @@ -220,143 +226,94 @@ end = struct let+ v = expand env ~mode:Many sw in Value.L.to_strings v ~dir:(Path.build env.dir) - module Static = struct + let artifacts = Expander.artifacts + + let map_exe = Expander.map_exe + + module No_deps = struct let expand env ~mode template = String_with_vars.expand ~dir:(Path.build env.dir) ~mode template - ~f:(Expander.Static.expand_pform env.expander) + ~f:(Expander.No_deps.expand_pform env.expander) let expand_path env sw = - let v = expand env ~mode:Single sw in + let+! v = expand env ~mode:Single sw in Value.to_path v ~error_loc:(String_with_vars.loc sw) ~dir:(Path.build env.dir) let expand_string env sw = - let v = expand env ~mode:Single sw in + let+! v = expand env ~mode:Single sw in Value.to_string v ~dir:(Path.build env.dir) - - module Or_exn = struct - let expand_path env sw = - Result.try_with (fun () -> expand_path env sw) - - let expand_string env sw = - Result.try_with (fun () -> expand_string env sw) - end end - - let artifacts = Expander.artifacts - - let map_exe = Expander.map_exe end - let string sw env acc = (Expander.expand_string env sw, acc) + let string sw env acc = + Memo.Build.return (Expander.expand_string env sw, acc) - let strings sw env acc = (Expander.expand_strings env sw, acc) + let strings sw env acc = + Memo.Build.return (Expander.expand_strings env sw, acc) - let fail exn acc = - (Action_builder.fail { fail = (fun () -> raise exn) }, acc) + let path sw env acc = Memo.Build.return (Expander.expand_path env sw, acc) - let static_string sw ~f env acc = - match Expander.Static.Or_exn.expand_string env sw with - | Ok s -> f s env acc - | Error exn -> fail exn acc + module At_rule_eval_stage = struct + let make ~expand sw ~f env acc = + let*! x = expand env sw in + f x env acc - let path sw env acc = (Expander.expand_path env sw, acc) + let string sw ~f = make ~expand:Expander.No_deps.expand_string sw ~f - let static_path sw ~f env acc = - match Expander.Static.Or_exn.expand_path env sw with - | Ok s -> f s env acc - | Error exn -> fail exn acc + let path sw ~f = make ~expand:Expander.No_deps.expand_path sw ~f + end let register_dep x ~f env acc = - if not env.infer then - (x, acc) - else - (* Try to collect the dependency statically as it helps for [dune - external-lib-deps]. *) - match Action_builder.static_eval x with - | Some (x, deps) -> ( - ( Action_builder.deps deps >>> Action_builder.return x - , match f x with - | None -> acc - | Some fn -> - { acc with - deps = - { acc.deps with static = Path.Set.add acc.deps.static fn } - } )) - | None - | (exception User_error.E _) -> + Memo.Build.return + (if not env.infer then + (x, acc) + else let x = Action_builder.memoize "dep" x in ( x , { acc with deps = - { acc.deps with - dyn = - (let+ x = x - and+ set = acc.deps.dyn in - match f x with - | None -> set - | Some fn -> Path.Set.add set fn) - } - } ) + (let+ x = x + and+ set = acc.deps in + match f x with + | None -> set + | Some fn -> Path.Set.add set fn) + } )) let dep sw env acc = let fn = Expander.expand_path env sw in register_dep fn ~f:Option.some env acc let dep_if_exists sw env acc = - let fn = Expander.expand_path env sw in + Memo.Build.return + (let fn = Expander.expand_path env sw in + if not env.infer then + (fn, acc) + else + let fn = Action_builder.memoize "dep_if_exists" fn in + ( fn + , { acc with + deps_if_exist = + (let+ fn = fn + and+ set = acc.deps_if_exist in + Path.Set.add set fn) + } )) + + let add_or_remove_target ~what ~f sw env acc = if not env.infer then - (fn, acc) + Memo.Build.return + ( (let+ p = Expander.expand_path env sw in + as_in_build_dir ~what ~loc:(loc sw) p) + , acc ) else - match Action_builder.static_eval fn with - | Some (fn, deps) -> - ( Action_builder.deps deps >>> Action_builder.return fn - , { acc with - deps_if_exist = - { acc.deps_if_exist with - static = Path.Set.add acc.deps_if_exist.static fn - } - } ) - | None - | (exception User_error.E _) -> - let fn = Action_builder.memoize "dep_if_exists" fn in - ( fn - , { acc with - deps_if_exist = - { acc.deps_if_exist with - dyn = - (let+ fn = fn - and+ set = acc.deps_if_exist.dyn in - Path.Set.add set fn) - } - } ) - - let consume_file sw env acc = - if not env.infer then - let b, acc = path sw env acc in - let b = - let+ p = b in - as_in_build_dir p ~what:"File" ~loc:(loc sw) - in - (b, acc) - else - static_path sw env acc ~f:(fun p _env acc -> - let p = as_in_build_dir p ~what:"File" ~loc:(loc sw) in - ( Action_builder.return p - , { acc with targets = Path.Build.Set.remove acc.targets p } )) + let+! p = Expander.No_deps.expand_path env sw in + let p = as_in_build_dir p ~what ~loc:(loc sw) in + (Action_builder.return p, { acc with targets = f acc.targets p }) - let target sw env acc = - if not env.infer then - ( (let+ p = Expander.expand_path env sw in - as_in_build_dir ~what:"Target" ~loc:(loc sw) p) - , acc ) - else - match Expander.Static.Or_exn.expand_path env sw with - | Error exn -> fail exn acc - | Ok p -> - let p = as_in_build_dir ~what:"Target" ~loc:(loc sw) p in - ( Action_builder.return p - , { acc with targets = Path.Build.Set.add acc.targets p } ) + let consume_file = + add_or_remove_target ~what:"File" ~f:Path.Build.Set.remove + + let target = add_or_remove_target ~what:"Target" ~f:Path.Build.Set.add let prog_and_args sw env acc = let b = @@ -414,13 +371,13 @@ let rec expand (t : Action_dune_lang.t) : Action.t Action_expander.t = let+ prog, args = expand_run prog args in O.Dynamic_run (prog, args) | Chdir (fn, t) -> - E.static_path fn ~f:(fun dir -> + E.At_rule_eval_stage.path fn ~f:(fun dir -> A.chdir (as_in_build_dir dir ~loc:(String_with_vars.loc fn) ~what:"Directory") (let+ t = expand t in O.Chdir (dir, t))) | Setenv (var, value, t) -> - E.static_string var ~f:(fun var -> + E.At_rule_eval_stage.string var ~f:(fun var -> A.set_env ~var ~value:(E.string value) (let+ t = expand t in fun ~value -> O.Setenv (var, value, t))) @@ -532,8 +489,8 @@ let expand_no_targets t ~loc ~deps:deps_written_by_user ~expander ~what = let expander = Expander.set_expanding_what expander (User_action_without_targets { what }) in - let { Action_builder.With_targets.build; targets } = - Action_expander.run (expand t) ~expander + let* { Action_builder.With_targets.build; targets } = + Action_builder.memo_build (Action_expander.run (expand t) ~expander) in if not (Path.Build.Set.is_empty targets) then User_error.raise ~loc @@ -565,13 +522,14 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir (match multiplicity with | One -> Target | Multiple -> Targets)) - (Action_builder.return - (Value.L.paths (List.map targets ~f:Path.build)))) + (Expander.Deps.Without + (Memo.Build.return + (Value.L.paths (List.map targets ~f:Path.build))))) in let expander = Expander.set_expanding_what expander (User_action targets_written_by_user) in - let { Action_builder.With_targets.build; targets } = + let+! { Action_builder.With_targets.build; targets } = Action_expander.run (expand t) ~expander in let targets = diff --git a/src/dune_rules/action_unexpanded.mli b/src/dune_rules/action_unexpanded.mli index 5d928e1f7aa..501b409a084 100644 --- a/src/dune_rules/action_unexpanded.mli +++ b/src/dune_rules/action_unexpanded.mli @@ -33,7 +33,7 @@ val expand : -> targets_dir:Path.Build.t -> targets:Path.Build.t Targets.t -> expander:Expander.t - -> Action.t Action_builder.With_targets.t + -> Action.t Action_builder.With_targets.t Memo.Build.t (** [what] as the same meaning as the argument of [Expander.Expanding_what.User_action_without_targets] *) diff --git a/src/dune_rules/blang.ml b/src/dune_rules/blang.ml index 6cf4b596a2f..808bfaa2db6 100644 --- a/src/dune_rules/blang.ml +++ b/src/dune_rules/blang.ml @@ -40,21 +40,23 @@ type t = let true_ = Const true let rec eval t ~dir ~f = + let open Memo.Build.O in match t with - | Const x -> x + | Const x -> Memo.Build.return x | Expr sw -> ( - match String_with_vars.expand sw ~mode:Single ~dir ~f with + String_with_vars.expand sw ~mode:Single ~dir ~f >>| function | String "true" -> true | String "false" -> false | _ -> let loc = String_with_vars.loc sw in User_error.raise ~loc [ Pp.text "This value must be either true or false" ]) - | And xs -> List.for_all ~f:(eval ~f ~dir) xs - | Or xs -> List.exists ~f:(eval ~f ~dir) xs + | And xs -> + Memo.Build.List.map xs ~f:(eval ~f ~dir) >>| List.for_all ~f:Fun.id + | Or xs -> Memo.Build.List.map xs ~f:(eval ~f ~dir) >>| List.exists ~f:Fun.id | Compare (op, x, y) -> - let x = String_with_vars.expand x ~mode:Many ~dir ~f - and y = String_with_vars.expand y ~mode:Many ~dir ~f in + let+ x = String_with_vars.expand x ~mode:Many ~dir ~f + and+ y = String_with_vars.expand y ~mode:Many ~dir ~f in Op.eval op (Value.L.compare_vals ~dir x y) let rec to_dyn = diff --git a/src/dune_rules/blang.mli b/src/dune_rules/blang.mli index 6cc23bdac30..c7f8f99a4cd 100644 --- a/src/dune_rules/blang.mli +++ b/src/dune_rules/blang.mli @@ -21,7 +21,11 @@ type t = val true_ : t -val eval : t -> dir:Path.t -> f:Value.t list String_with_vars.expander -> bool +val eval : + t + -> dir:Path.t + -> f:Value.t list Memo.Build.t String_with_vars.expander + -> bool Memo.Build.t val to_dyn : t -> Dyn.t diff --git a/src/dune_rules/cram_rules.ml b/src/dune_rules/cram_rules.ml index d58d5776614..a5b8728f31f 100644 --- a/src/dune_rules/cram_rules.ml +++ b/src/dune_rules/cram_rules.ml @@ -42,8 +42,9 @@ let missing_run_t (error : Cram_test.t) = let test_rule ~sctx ~expander ~dir (spec : effective) (test : (Cram_test.t, Source_tree.Dir.error) result) = + let open Memo.Build.O in let module Alias_rules = Simple_rules.Alias_rules in - let enabled = Expander.eval_blang expander (Blang.And spec.enabled_if) in + let* enabled = Expander.eval_blang expander (Blang.And spec.enabled_if) in let loc = Some spec.loc in let aliases = Alias.Name.Set.to_list_map spec.alias ~f:(Alias.make ~dir) in match test with @@ -143,7 +144,7 @@ let rules ~sctx ~expander ~dir tests = | false -> acc | true -> let* acc = acc in - let+ deps = + let* deps = match spec.deps with | None -> Memo.Build.return acc.deps | Some deps -> @@ -165,15 +166,13 @@ let rules ~sctx ~expander ~dir tests = | Some (p : Package.t) -> Package.Name.Set.add acc.packages (Package.Id.name p.id) in - let locks = + let+ locks = (* Locks must be relative to the cram stanza directory and not the individual tests direcories *) - List.fold_left ~init:acc.locks - ~f:(fun acc lock -> - Expander.Static.expand_str expander lock - |> Path.relative (Path.build dir) - |> Path.Set.add acc) - spec.locks + Memo.Build.List.map spec.locks ~f:(fun lock -> + Expander.No_deps.expand_str expander lock + >>| Path.relative (Path.build dir)) + >>| Path.Set.of_list >>| Path.Set.union acc.locks in { acc with enabled_if; locks; deps; alias; packages }) in diff --git a/src/dune_rules/dep_conf_eval.ml b/src/dune_rules/dep_conf_eval.ml index 7e7ecdc0f79..fedcdfb50da 100644 --- a/src/dune_rules/dep_conf_eval.ml +++ b/src/dune_rules/dep_conf_eval.ml @@ -19,96 +19,132 @@ let collect_source_files_recursively dir ~f = ~f:(fun dir -> f (Path.append_source prefix_with (Source_tree.Dir.path dir))) -let dep expander = function - | File s -> - let* path = Expander.expand_path expander s in +type dep_evaluation_result = + | Simple of Path.t Memo.Build.t + | Other of Path.t list Action_builder.t + +let to_action_builder = function + | Simple path -> + let* path = Action_builder.memo_build path in let+ () = Action_builder.path path in [ path ] + | Other x -> x + +let dep expander = function + | File s -> ( + match Expander.With_deps_if_necessary.expand_path expander s with + | Without path -> + (* This special case is to support this pattern: + + {v ... (deps (:x foo)) (action (... (diff? %{x} %{x}.corrected))) ... + v} + + Indeed, the second argument of [diff?] must be something that can be + evaluated at rule production time since the dependency/target inferrer + treats this argument as "consuming a target", and targets must be known + at rule production time. This is not compatible with computing its + expansion in the action builder monad, which is evaluated at rule + execution time. *) + Simple path + | With path -> + Other + (let* path = path in + let+ () = Action_builder.path path in + [ path ])) | Alias s -> - let* a = make_alias expander s in - let+ () = Action_builder.alias a in - [] + Other + (let* a = make_alias expander s in + let+ () = Action_builder.alias a in + []) | Alias_rec s -> - let* a = make_alias expander s in - let+ () = Build_system.Alias.dep_rec ~loc:(String_with_vars.loc s) a in - [] + Other + (let* a = make_alias expander s in + let+ () = Build_system.Alias.dep_rec ~loc:(String_with_vars.loc s) a in + []) | Glob_files { glob = s; recursive } -> - let loc = String_with_vars.loc s in - let* path = Expander.expand_path expander s in - let pred = Glob.of_string_exn loc (Path.basename path) |> Glob.to_pred in - let dir = Path.parent_exn path in - let files_in dir = - Action_builder.paths_matching ~loc (File_selector.create ~dir pred) - in - let+ files = - if recursive then - collect_source_files_recursively dir ~f:files_in - else - files_in dir - in - Path.Set.to_list files + Other + (let loc = String_with_vars.loc s in + let* path = Expander.expand_path expander s in + let pred = Glob.of_string_exn loc (Path.basename path) |> Glob.to_pred in + let dir = Path.parent_exn path in + let files_in dir = + Action_builder.paths_matching ~loc (File_selector.create ~dir pred) + in + let+ files = + if recursive then + collect_source_files_recursively dir ~f:files_in + else + files_in dir + in + Path.Set.to_list files) | Source_tree s -> - let* path = Expander.expand_path expander s in - Action_builder.map ~f:Path.Set.to_list - (Action_builder.source_tree ~dir:path) + Other + (let* path = Expander.expand_path expander s in + Action_builder.map ~f:Path.Set.to_list + (Action_builder.source_tree ~dir:path)) | Package p -> - let* pkg = Expander.expand_str expander p in - let+ () = - let pkg = Package.Name.of_string pkg in - let context = Expander.context expander in - match Expander.find_package expander pkg with - | Some (Local pkg) -> - Action_builder.alias - (Build_system.Alias.package_install - ~context:(Context.build_context context) - ~pkg) - | Some (Installed pkg) -> - let version = - Dune_project.dune_version @@ Scope.project @@ Expander.scope expander - in - if version < (2, 9) then - Action_builder.fail - { fail = - (fun () -> - let loc = String_with_vars.loc p in - User_error.raise ~loc - [ Pp.textf - "Dependency on an installed package requires at least \ - (lang dune 2.9)" - ]) - } - else - let files = - List.concat_map - ~f:(fun (s, l) -> - let dir = Section.Map.find_exn pkg.sections s in - List.map l ~f:(fun d -> - Path.relative dir (Install.Dst.to_string d))) - pkg.files - in - Action_builder.paths files - | None -> - Action_builder.fail - { fail = - (fun () -> - let loc = String_with_vars.loc p in - User_error.raise ~loc - [ Pp.textf "Package %s does not exist" - (Package.Name.to_string pkg) - ]) - } - in - [] + Other + (let* pkg = Expander.expand_str expander p in + let+ () = + let pkg = Package.Name.of_string pkg in + let context = Expander.context expander in + match Expander.find_package expander pkg with + | Some (Local pkg) -> + Action_builder.alias + (Build_system.Alias.package_install + ~context:(Context.build_context context) + ~pkg) + | Some (Installed pkg) -> + let version = + Dune_project.dune_version @@ Scope.project + @@ Expander.scope expander + in + if version < (2, 9) then + Action_builder.fail + { fail = + (fun () -> + let loc = String_with_vars.loc p in + User_error.raise ~loc + [ Pp.textf + "Dependency on an installed package requires at \ + least (lang dune 2.9)" + ]) + } + else + let files = + List.concat_map + ~f:(fun (s, l) -> + let dir = Section.Map.find_exn pkg.sections s in + List.map l ~f:(fun d -> + Path.relative dir (Install.Dst.to_string d))) + pkg.files + in + Action_builder.paths files + | None -> + Action_builder.fail + { fail = + (fun () -> + let loc = String_with_vars.loc p in + User_error.raise ~loc + [ Pp.textf "Package %s does not exist" + (Package.Name.to_string pkg) + ]) + } + in + []) | Universe -> - let+ () = Action_builder.dep Dep.universe in - [] + Other + (let+ () = Action_builder.dep Dep.universe in + []) | Env_var var_sw -> - let* var = Expander.expand_str expander var_sw in - let+ () = Action_builder.env_var var in - [] + Other + (let* var = Expander.expand_str expander var_sw in + let+ () = Action_builder.env_var var in + []) | Sandbox_config sandbox_config -> - let+ () = Action_builder.dep (Dep.sandbox_config sandbox_config) in - [] + Other + (let+ () = Action_builder.dep (Dep.sandbox_config sandbox_config) in + []) let prepare_expander expander = Expander.set_expanding_what expander Deps_like_field @@ -117,7 +153,7 @@ let unnamed ~expander l = let expander = prepare_expander expander in List.fold_left l ~init:(Action_builder.return ()) ~f:(fun acc x -> let+ () = acc - and+ _x = dep expander x in + and+ _x = to_action_builder (dep expander x) in ()) let named ~expander l = @@ -126,26 +162,53 @@ let named ~expander l = List.fold_left l ~init:([], Pform.Map.empty) ~f:(fun (builders, bindings) x -> match x with - | Bindings.Unnamed x -> (dep expander x :: builders, bindings) - | Named (name, x) -> - let x = - Action_builder.memoize ("dep " ^ name) - (let+ l = Action_builder.all (List.map x ~f:(dep expander)) in - List.concat l) - in - let bindings = - Pform.Map.set bindings (Var (User_var name)) - (let+ paths = x in - Dune_util.Value.L.paths paths) - in - (x :: builders, bindings)) + | Bindings.Unnamed x -> + (to_action_builder (dep expander x) :: builders, bindings) + | Named (name, x) -> ( + let x = List.map x ~f:(dep expander) in + match + Option.List.all + (List.map x ~f:(function + | Simple x -> Some x + | Other _ -> None)) + with + | Some x -> + let open Memo.Build.O in + let x = Memo.lazy_ (fun () -> Memo.Build.all x) in + let bindings = + Pform.Map.set bindings (Var (User_var name)) + (Expander.Deps.Without + (let+ paths = Memo.Lazy.force x in + Dune_util.Value.L.paths paths)) + in + let x = + let open Action_builder.O in + let* x = Action_builder.memo_build (Memo.Lazy.force x) in + let+ () = Action_builder.paths x in + x + in + (x :: builders, bindings) + | None -> + let x = + Action_builder.memoize ("dep " ^ name) + (Action_builder.List.concat_map x ~f:to_action_builder) + in + let bindings = + Pform.Map.set bindings (Var (User_var name)) + (Expander.Deps.With + (let+ paths = x in + Dune_util.Value.L.paths paths)) + in + (x :: builders, bindings))) in let builder = let+ l = Action_builder.all (List.rev builders) in Dune_util.Value.L.paths (List.concat l) in let builder = Action_builder.memoize "deps" builder in - let bindings = Pform.Map.set bindings (Var Deps) builder in + let bindings = + Pform.Map.set bindings (Var Deps) (Expander.Deps.With builder) + in let expander = Expander.add_bindings_full expander ~bindings in let builder = Action_builder.ignore builder in (builder, expander) diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 5bc948a6e10..c0a07580f91 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -131,10 +131,7 @@ end = struct (* Interpret a few stanzas in order to determine the list of files generated by the user. *) let* expander = - let+ expander = - Super_context.expander sctx ~dir >>| add_sources_to_expander sctx - in - Expander.set_artifacts_dynamic expander true + Super_context.expander sctx ~dir >>| add_sources_to_expander sctx in let+ generated_files = Memo.Build.parallel_map stanzas ~f:(fun stanza -> diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index 53336cc4dec..1ecfc84d6d4 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -806,6 +806,7 @@ module Library = struct ~lib_config: ({ Lib_config.has_native; ext_lib; ext_dll; natdynlink_supported; _ } as lib_config) = + let open Memo.Build.O in let obj_dir = obj_dir ~dir conf in let archive ?(dir = dir) ext = archive conf ~dir ~ext in let modes = Mode_conf.Set.eval ~has_native conf.modes in @@ -878,12 +879,12 @@ module Library = struct in let main_module_name = main_module_name conf in let name = best_name conf in - let enabled = - let enabled_if_result = + let+ enabled = + let+ enabled_if_result = Blang.eval conf.enabled_if ~dir:(Path.build dir) ~f:(fun ~source:_ pform -> let value = Lib_config.get_for_enabled_if lib_config pform in - [ String value ]) + Memo.Build.return [ Value.String value ]) in if not enabled_if_result then Lib_info.Enabled_status.Disabled_because_of_enabled_if diff --git a/src/dune_rules/dune_file.mli b/src/dune_rules/dune_file.mli index 53386374d5a..773395d55fe 100644 --- a/src/dune_rules/dune_file.mli +++ b/src/dune_rules/dune_file.mli @@ -182,7 +182,10 @@ module Library : sig val main_module_name : t -> Lib_info.Main_module_name.t val to_lib_info : - t -> dir:Path.Build.t -> lib_config:Lib_config.t -> Lib_info.local + t + -> dir:Path.Build.t + -> lib_config:Lib_config.t + -> Lib_info.local Memo.Build.t end module Plugin : sig diff --git a/src/dune_rules/env_node.ml b/src/dune_rules/env_node.ml index 2c3cfbaea5e..fc0900ec3a2 100644 --- a/src/dune_rules/env_node.ml +++ b/src/dune_rules/env_node.ml @@ -82,10 +82,10 @@ let make ~dir ~inherit_from ~scope ~config_stanza ~profile ~expander Memo.Build.sequential_map config.binaries ~f: (File_binding.Unexpanded.expand ~dir ~f:(fun template -> - let+ expander_for_artifacts = + let* expander_for_artifacts = Memo.Lazy.force expander_for_artifacts in - Expander.Static.expand_str expander_for_artifacts template)) + Expander.No_deps.expand_str expander_for_artifacts template)) in binaries @ expanded) in diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index 792bdae76ba..8654ea6ef94 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -14,6 +14,39 @@ module Expanding_what = struct | User_action_without_targets of { what : string } end +module Deps = struct + module T = struct + type 'a t = + | Without of 'a Memo.Build.t + | With of 'a Action_builder.t + + let return x = Without (Memo.Build.return x) + + let map t ~f = + match t with + | Without t -> Without (Memo.Build.map t ~f) + | With t -> With (Action_builder.map t ~f) + + let both a b = + match (a, b) with + | Without a, Without b -> Without (Memo.Build.both a b) + | With a, With b -> With (Action_builder.both a b) + | Without a, With b -> + With (Action_builder.both (Action_builder.memo_build a) b) + | With a, Without b -> + With (Action_builder.both a (Action_builder.memo_build b)) + end + + include T + include Applicative.Make (T) + + let action_builder = function + | Without x -> Action_builder.memo_build x + | With x -> x +end + +type value = Value.t list Deps.t + type t = { dir : Path.Build.t ; env : Env.t @@ -21,12 +54,11 @@ type t = ; lib_artifacts : Artifacts.Public_libs.t ; lib_artifacts_host : Artifacts.Public_libs.t ; bin_artifacts_host : Artifacts.Bin.t - ; bindings : Value.t list Action_builder.t Pform.Map.t + ; bindings : value Pform.Map.t ; scope : Scope.t ; scope_host : Scope.t ; c_compiler : string ; context : Context.t - ; artifacts_dynamic : bool ; lookup_artifacts : (dir:Path.Build.t -> Ml_sources.Artifacts.t Memo.Build.t) option ; foreign_flags : @@ -55,8 +87,6 @@ let set_scope t ~scope = { t with scope } let set_bin_artifacts t ~bin_artifacts_host = { t with bin_artifacts_host } -let set_artifacts_dynamic t artifacts_dynamic = { t with artifacts_dynamic } - let set_lookup_ml_sources t ~f = { t with lookup_artifacts = Some f } let set_expanding_what t x = { t with expanding_what = x } @@ -80,7 +110,8 @@ let add_bindings_full t ~bindings = let add_bindings t ~bindings = add_bindings_full t - ~bindings:(Pform.Map.map bindings ~f:(fun v -> Action_builder.return v)) + ~bindings: + (Pform.Map.map bindings ~f:(fun v -> Deps.Without (Memo.Build.return v))) let path p = [ Value.Path p ] @@ -204,10 +235,10 @@ let relative ~source d s = (Path.Build.relative ~error_loc:(Dune_lang.Template.Pform.loc source) d s) type nonrec expansion_result = - | Direct of Value.t list Action_builder.t - | Need_full_expander of (t -> Value.t list Action_builder.t) + | Direct of value + | Need_full_expander of (t -> value) -let static v = Direct (Action_builder.return v) +let static v = Direct (Without (Memo.Build.return v)) let[@inline never] invalid_use_of_target_variable t ~(source : Dune_lang.Template.Pform.t) ~var_multiplicity = @@ -269,13 +300,15 @@ let expand_pform_gen ~(context : Context.t) ~bindings ~dir ~source | Ocamlc -> static (path context.ocamlc) | Ocamlopt -> static (get_prog context.ocamlopt) | Make -> + let open Memo.Build.O in Direct - (Action_builder.memo_build (context.which "make") >>| function - | None -> - Utils.program_not_found ~context:context.name - ~loc:(Some (Dune_lang.Template.Pform.loc source)) - "make" - | Some p -> path p) + (Without + (context.which "make" >>| function + | None -> + Utils.program_not_found ~context:context.name + ~loc:(Some (Dune_lang.Template.Pform.loc source)) + "make" + | Some p -> path p)) | Cpp -> static (strings (c_compiler_and_flags context @ [ "-E" ])) | Pa_cpp -> static @@ -319,18 +352,21 @@ let expand_pform_gen ~(context : Context.t) ~bindings ~dir ~source | Project_root -> Need_full_expander (fun t -> - Action_builder.return - [ Value.Dir (Path.build (Scope.root t.scope)) ]) + Without + (Memo.Build.return + [ Value.Dir (Path.build (Scope.root t.scope)) ])) | Cc -> Need_full_expander (fun t -> - let* cc = Action_builder.memo_build (cc t) in - cc.c) + With + (let* cc = Action_builder.memo_build (cc t) in + cc.c)) | Cxx -> Need_full_expander (fun t -> - let* cc = Action_builder.memo_build (cc t) in - cc.cxx) + With + (let* cc = Action_builder.memo_build (cc t) in + cc.cxx)) | Ccomp_type -> static (string @@ -364,176 +400,220 @@ let expand_pform_gen ~(context : Context.t) ~bindings ~dir ~source | Some (var, default) -> ( match Env.Var.Map.find t.local_env var with | Some v -> - let+ v = v in - string v + With + (let+ v = v in + string v) | None -> - Action_builder.return - (string (Option.value ~default (Env.get t.env var))))) + Without + (Memo.Build.return + (string (Option.value ~default (Env.get t.env var)))))) | Version -> Need_full_expander - (fun t -> Action_builder.return (expand_version t ~source s)) + (fun t -> Without (Memo.Build.return (expand_version t ~source s))) | Artifact a -> - Need_full_expander - (fun t -> - if t.artifacts_dynamic then - let* () = Action_builder.return () in - expand_artifact ~source t a s - else - expand_artifact ~source t a s) + Need_full_expander (fun t -> With (expand_artifact ~source t a s)) | Path_no_dep -> (* This case is for %{path-no-dep:...} which was only allowed inside jbuild files *) assert false | Exe -> - Need_full_expander (fun t -> dep (map_exe t (relative ~source t.dir s))) - | Dep -> Need_full_expander (fun t -> dep (relative ~source t.dir s)) + Need_full_expander + (fun t -> With (dep (map_exe t (relative ~source t.dir s)))) + | Dep -> + Need_full_expander (fun t -> With (dep (relative ~source t.dir s))) | Bin -> Need_full_expander (fun t -> - let* prog = - Action_builder.memo_build - (Artifacts.Bin.binary - ~loc:(Some (Dune_lang.Template.Pform.loc source)) - t.bin_artifacts_host s) - in - dep (Action.Prog.ok_exn prog)) + With + (let* prog = + Action_builder.memo_build + (Artifacts.Bin.binary + ~loc:(Some (Dune_lang.Template.Pform.loc source)) + t.bin_artifacts_host s) + in + dep (Action.Prog.ok_exn prog))) | Lib { lib_exec; lib_private } -> Need_full_expander (fun t -> - let lib, file = - let loc = Dune_lang.Template.Pform.loc source in - match String.lsplit2 s ~on:':' with - | None -> - User_error.raise ~loc - [ Pp.textf "invalid %%{lib:...} form: %s" s ] - | Some (lib, f) -> (Lib_name.parse_string_exn (loc, lib), f) - in - let scope = - if lib_exec then - t.scope_host - else - t.scope - in - let p = - let open Resolve.O in - if lib_private then - let* lib = - Lib.DB.resolve (Scope.libs scope) - (Dune_lang.Template.Pform.loc source, lib) - in - let current_project = Scope.project t.scope - and referenced_project = - Lib.info lib |> Lib_info.status |> Lib_info.Status.project - in - if - Option.equal Dune_project.equal (Some current_project) - referenced_project - then - Resolve.return - (Path.relative (Lib_info.src_dir (Lib.info lib)) file) - else - Resolve.fail - (User_error.make - ~loc:(Dune_lang.Template.Pform.loc source) - [ Pp.textf - "The variable \"lib%s-private\" can only refer to \ - libraries within the same project. The current \ - project's name is %S, but the reference is to %s." - (if lib_exec then - "exec" - else - "") - (Dune_project.Name.to_string_hum - (Dune_project.name current_project)) - (match referenced_project with - | None -> "an external library" - | Some project -> - Dune_project.name project - |> Dune_project.Name.to_string_hum |> String.quoted) - ]) - else - let artifacts = - if lib_exec then - t.lib_artifacts_host - else - t.lib_artifacts - in - Artifacts.Public_libs.file_of_lib artifacts - ~loc:(Dune_lang.Template.Pform.loc source) - ~lib ~file - in - match Resolve.peek p with - | Ok p -> - if - (not lib_exec) || (not Sys.win32) - || Filename.extension s = ".exe" - then - dep p - else - let p_exe = Path.extend_basename p ~suffix:".exe" in - Action_builder.if_file_exists p_exe ~then_:(dep p_exe) - ~else_:(dep p) - | Error () -> - let p = - let open Resolve.O in - if lib_private || not (Lib.DB.available (Scope.libs scope) lib) - then - p >>| fun _ -> assert false - else - Resolve.fail - (User_error.make - ~loc:(Dune_lang.Template.Pform.loc source) - [ Pp.textf - "The library %S is not public. The variable \ - \"lib%s\" expands to the file's installation path \ - which is not defined for private libraries." - (Lib_name.to_string lib) - (if lib_exec then - "exec" - else - "") - ]) - in - Resolve.read p) + With + (let lib, file = + let loc = Dune_lang.Template.Pform.loc source in + match String.lsplit2 s ~on:':' with + | None -> + User_error.raise ~loc + [ Pp.textf "invalid %%{lib:...} form: %s" s ] + | Some (lib, f) -> (Lib_name.parse_string_exn (loc, lib), f) + in + let scope = + if lib_exec then + t.scope_host + else + t.scope + in + let p = + let open Resolve.O in + if lib_private then + let* lib = + Lib.DB.resolve (Scope.libs scope) + (Dune_lang.Template.Pform.loc source, lib) + in + let current_project = Scope.project t.scope + and referenced_project = + Lib.info lib |> Lib_info.status |> Lib_info.Status.project + in + if + Option.equal Dune_project.equal (Some current_project) + referenced_project + then + Resolve.return + (Path.relative (Lib_info.src_dir (Lib.info lib)) file) + else + Resolve.fail + (User_error.make + ~loc:(Dune_lang.Template.Pform.loc source) + [ Pp.textf + "The variable \"lib%s-private\" can only refer \ + to libraries within the same project. The \ + current project's name is %S, but the reference \ + is to %s." + (if lib_exec then + "exec" + else + "") + (Dune_project.Name.to_string_hum + (Dune_project.name current_project)) + (match referenced_project with + | None -> "an external library" + | Some project -> + Dune_project.name project + |> Dune_project.Name.to_string_hum + |> String.quoted) + ]) + else + let artifacts = + if lib_exec then + t.lib_artifacts_host + else + t.lib_artifacts + in + Artifacts.Public_libs.file_of_lib artifacts + ~loc:(Dune_lang.Template.Pform.loc source) + ~lib ~file + in + match Resolve.peek p with + | Ok p -> + if + (not lib_exec) || (not Sys.win32) + || Filename.extension s = ".exe" + then + dep p + else + let p_exe = Path.extend_basename p ~suffix:".exe" in + Action_builder.if_file_exists p_exe ~then_:(dep p_exe) + ~else_:(dep p) + | Error () -> + let p = + let open Resolve.O in + if + lib_private + || not (Lib.DB.available (Scope.libs scope) lib) + then + p >>| fun _ -> assert false + else + Resolve.fail + (User_error.make + ~loc:(Dune_lang.Template.Pform.loc source) + [ Pp.textf + "The library %S is not public. The variable \ + \"lib%s\" expands to the file's installation \ + path which is not defined for private \ + libraries." + (Lib_name.to_string lib) + (if lib_exec then + "exec" + else + "") + ]) + in + Resolve.read p)) | Lib_available -> Need_full_expander (fun t -> - let lib = - Lib_name.parse_string_exn (Dune_lang.Template.Pform.loc source, s) - in - Action_builder.return - (Lib.DB.available (Scope.libs t.scope) lib - |> string_of_bool |> string)) + Without + (let lib = + Lib_name.parse_string_exn + (Dune_lang.Template.Pform.loc source, s) + in + Memo.Build.return + (Lib.DB.available (Scope.libs t.scope) lib + |> string_of_bool |> string))) | Read -> let path = relative ~source dir s in - Direct (Action_builder.map (Action_builder.contents path) ~f:string) + Direct + (With (Action_builder.map (Action_builder.contents path) ~f:string)) | Read_lines -> let path = relative ~source dir s in - Direct (Action_builder.map (Action_builder.lines_of path) ~f:strings) + Direct + (With (Action_builder.map (Action_builder.lines_of path) ~f:strings)) | Read_strings -> let path = relative ~source dir s in - Direct (Action_builder.map (Action_builder.strings path) ~f:strings))) + Direct + (With (Action_builder.map (Action_builder.strings path) ~f:strings)))) (* Make sure to delay exceptions *) let expand_pform_gen ~context ~bindings ~dir ~source pform = match expand_pform_gen ~context ~bindings ~source ~dir pform with | exception (User_error.E _ as exn) -> - Direct (Action_builder.fail { fail = (fun () -> reraise exn) }) + Direct + (Without + (let open Memo.Build.O in + let+ () = Memo.Build.return () in + reraise exn)) | Direct _ as x -> x | Need_full_expander f -> Need_full_expander (fun t -> try f t with | User_error.E _ as exn -> - Action_builder.fail { fail = (fun () -> reraise exn) }) + Without + (let open Memo.Build.O in + let+ () = Memo.Build.return () in + reraise exn)) + +let describe_source ~source = + Pp.textf "%s at %s" + (Dune_lang.Template.Pform.to_string source) + (Loc.to_file_colon_line source.loc) let expand_pform t ~source pform = - match - expand_pform_gen ~context:t.context ~bindings:t.bindings ~dir:t.dir ~source - pform - with - | Direct v -> v - | Need_full_expander f -> f t + Action_builder.push_stack_frame + (fun () -> + match + match + expand_pform_gen ~context:t.context ~bindings:t.bindings ~dir:t.dir + ~source pform + with + | Direct v -> v + | Need_full_expander f -> f t + with + | With x -> x + | Without x -> Action_builder.memo_build x) + ~human_readable_description:(fun () -> describe_source ~source) + +let expand_pform_no_deps t ~source pform = + Memo.push_stack_frame + (fun () -> + match + match + expand_pform_gen ~context:t.context ~bindings:t.bindings ~dir:t.dir + ~source pform + with + | Direct v -> v + | Need_full_expander f -> f t + with + | With _ -> isn't_allowed_in_this_position ~source + | Without x -> x) + ~human_readable_description:(fun () -> describe_source ~source) let expand t ~mode template = Action_builder.Expander.expand ~dir:(Path.build t.dir) ~mode template @@ -552,7 +632,6 @@ let make ~scope ~scope_host ~(context : Context.t) ~lib_artifacts ; bin_artifacts_host ; c_compiler = Ocaml_config.c_compiler context.ocaml_config ; context - ; artifacts_dynamic = false ; lookup_artifacts = None ; foreign_flags = (fun ~dir -> @@ -570,62 +649,88 @@ let expand_str t sw = let+ v = expand t ~mode:Single sw in Value.to_string v ~dir:(Path.build t.dir) -module Static = struct - let expand_pform t ~source pform = - match Action_builder.static_eval (expand_pform t ~source pform) with - | Some (v, _) -> v - | None -> isn't_allowed_in_this_position ~source +module No_deps = struct + open Memo.Build.O + + let expand_pform = expand_pform_no_deps - let expand t ~mode template = - String_with_vars.expand ~dir:(Path.build t.dir) ~mode template - ~f:(expand_pform t) + let expand t ~mode sw = + String_with_vars.expand ~dir:(Path.build t.dir) ~mode sw ~f:(expand_pform t) let expand_path t sw = - let v = expand t ~mode:Single sw in + let+ v = expand t ~mode:Single sw in Value.to_path v ~error_loc:(String_with_vars.loc sw) ~dir:(Path.build t.dir) let expand_str t sw = - let v = expand t ~mode:Single sw in + let+ v = expand t ~mode:Single sw in Value.to_string v ~dir:(Path.build t.dir) +end - module Or_exn = struct - let expand_path t sw = Result.try_with (fun () -> expand_path t sw) - - let expand_str t sw = Result.try_with (fun () -> expand_str t sw) - end +module With_deps_if_necessary = struct + open Deps.O + module E = String_with_vars.Make_expander (Deps) - module With_reduced_var_set = struct - let expand_pform_opt ~(context : Context.t) ~dir ~source pform = + let expand_pform t ~source pform : _ Deps.t = + match match - expand_pform_gen ~context ~bindings:Pform.Map.empty ~dir ~source pform + expand_pform_gen ~context:t.context ~bindings:t.bindings ~dir:t.dir + ~source pform with - | Direct v -> ( - match Action_builder.static_eval v with - | Some (v, _) -> Some v - | None -> None) - | Need_full_expander _ -> None - - let expand_pform ~context ~dir ~source pform = - match expand_pform_opt ~context ~dir ~source pform with - | Some v -> v - | None -> isn't_allowed_in_this_position ~source - - let expand ~(context : Context.t) ~dir ~mode template = - String_with_vars.expand ~dir:(Path.build dir) ~mode template - ~f:(expand_pform ~context ~dir) - - let expand_path ~context ~dir sw = - let v = expand ~context ~dir ~mode:Single sw in - Value.to_path v ~error_loc:(String_with_vars.loc sw) ~dir:(Path.build dir) - - let expand_str ~context ~dir sw = - let v = expand ~context ~dir ~mode:Single sw in - Value.to_string v ~dir:(Path.build dir) - - let expand_str_partial ~context ~dir sw = - String_with_vars.expand_as_much_as_possible sw ~dir:(Path.build dir) - ~f:(expand_pform_opt ~context ~dir) - end + | Direct v -> v + | Need_full_expander f -> f t + with + | Without t -> + Without + (Memo.push_stack_frame + (fun () -> t) + ~human_readable_description:(fun () -> describe_source ~source)) + | With t -> + With + (Action_builder.push_stack_frame + (fun () -> t) + ~human_readable_description:(fun () -> describe_source ~source)) + + let expand t ~mode sw = + E.expand ~dir:(Path.build t.dir) ~mode sw ~f:(expand_pform t) + + let expand_path t sw = + let+ v = expand t ~mode:Single sw in + Value.to_path v ~error_loc:(String_with_vars.loc sw) ~dir:(Path.build t.dir) + + let expand_str t sw = + let+ v = expand t ~mode:Single sw in + Value.to_string v ~dir:(Path.build t.dir) +end + +module With_reduced_var_set = struct + open Memo.Build.O + + let expand_pform_opt ~context ~bindings ~dir ~source pform = + let open Memo.Build.O in + Memo.push_stack_frame + (fun () -> + match expand_pform_gen ~context ~bindings ~dir ~source pform with + | Need_full_expander _ + | Direct (With _) -> + Memo.Build.return None + | Direct (Without x) -> x >>| Option.some) + ~human_readable_description:(fun () -> describe_source ~source) + + let expand_pform ~context ~bindings ~dir ~source pform = + expand_pform_opt ~context ~bindings ~dir ~source pform >>| function + | Some v -> v + | None -> isn't_allowed_in_this_position ~source + + let expand_str ~context ~dir sw = + let+ v = + String_with_vars.expand ~dir:(Path.build dir) ~mode:Single sw + ~f:(expand_pform ~context ~bindings:Pform.Map.empty ~dir) + in + Value.to_string v ~dir:(Path.build dir) + + let expand_str_partial ~context ~dir sw = + String_with_vars.expand_as_much_as_possible ~dir:(Path.build dir) sw + ~f:(expand_pform_opt ~context ~bindings:Pform.Map.empty ~dir) end let expand_and_eval_set t set ~standard = @@ -640,7 +745,8 @@ let expand_and_eval_set t set ~standard = s) let eval_blang t = function - | Blang.Const x -> x (* common case *) - | blang -> Blang.eval blang ~dir:(Path.build t.dir) ~f:(Static.expand_pform t) + | Blang.Const x -> Memo.Build.return x (* common case *) + | blang -> + Blang.eval blang ~dir:(Path.build t.dir) ~f:(No_deps.expand_pform t) let find_package t pkg = t.find_package pkg diff --git a/src/dune_rules/expander.mli b/src/dune_rules/expander.mli index a95a07af9a8..303c6cdad07 100644 --- a/src/dune_rules/expander.mli +++ b/src/dune_rules/expander.mli @@ -1,12 +1,4 @@ -(** An expander is able to expand any dune template. It has two modes of - expansion: - - 1. Static. In this mode it will only expand variables that do not introduce - dependencies - - 2. Dynamic. In this mode, the expander will record dependencies that are - introduced by forms it has failed to expand. Later, these dependenceis can - be filled for a full expansion.*) +(** An expander is able to expand any dune template. *) open! Dune_engine open Import @@ -49,8 +41,6 @@ val set_scope : t -> scope:Scope.t -> t val set_bin_artifacts : t -> bin_artifacts_host:Artifacts.Bin.t -> t -val set_artifacts_dynamic : t -> bool -> t - val set_lookup_ml_sources : t -> f:(dir:Path.Build.t -> Ml_sources.Artifacts.t Memo.Build.t) -> t @@ -75,8 +65,19 @@ val set_expanding_what : t -> Expanding_what.t -> t such bindings. *) val add_bindings : t -> bindings:Value.t list Pform.Map.t -> t -val add_bindings_full : - t -> bindings:Value.t list Action_builder.t Pform.Map.t -> t +module Deps : sig + type 'a t = + | Without of 'a Memo.Build.t + | With of 'a Action_builder.t + + include Applicative with type 'a t := 'a t + + val action_builder : 'a t -> 'a Action_builder.t +end + +type value = Value.t list Deps.t + +val add_bindings_full : t -> bindings:value Pform.Map.t -> t val extend_env : t -> env:Env.t -> t @@ -92,34 +93,43 @@ val expand_str : t -> String_with_vars.t -> string Action_builder.t val expand_pform : t -> Value.t list Action_builder.t String_with_vars.expander -module Static : sig - val expand : t -> mode:'a String_with_vars.Mode.t -> String_with_vars.t -> 'a +module No_deps : sig + (** Same as [expand_xxx] but disallow percent forms that introduce action + dependencies, such as [%{dep:...}] *) - val expand_path : t -> String_with_vars.t -> Path.t + val expand_pform : t -> Value.t list Memo.Build.t String_with_vars.expander - val expand_str : t -> String_with_vars.t -> string + val expand : + t + -> mode:'a String_with_vars.Mode.t + -> String_with_vars.t + -> 'a Memo.Build.t - val expand_pform : t -> Value.t list String_with_vars.expander + val expand_path : t -> String_with_vars.t -> Path.t Memo.Build.t - module With_reduced_var_set : sig - val expand_path : - context:Context.t -> dir:Path.Build.t -> String_with_vars.t -> Path.t + val expand_str : t -> String_with_vars.t -> string Memo.Build.t +end - val expand_str : - context:Context.t -> dir:Path.Build.t -> String_with_vars.t -> string +module With_deps_if_necessary : sig + (** Same as [expand_xxx] but stay in the [Memo.Build] monad if possible. *) - val expand_str_partial : - context:Context.t - -> dir:Path.Build.t - -> String_with_vars.t - -> String_with_vars.t - end + val expand_path : t -> String_with_vars.t -> Path.t Deps.t - module Or_exn : sig - val expand_path : t -> String_with_vars.t -> Path.t Or_exn.t + val expand_str : t -> String_with_vars.t -> string Deps.t +end - val expand_str : t -> String_with_vars.t -> string Or_exn.t - end +module With_reduced_var_set : sig + val expand_str : + context:Context.t + -> dir:Path.Build.t + -> String_with_vars.t + -> string Memo.Build.t + + val expand_str_partial : + context:Context.t + -> dir:Path.Build.t + -> String_with_vars.t + -> String_with_vars.t Memo.Build.t end (** Expand forms of the form (:standard \ foo bar). Expansion is only possible @@ -131,7 +141,7 @@ val expand_and_eval_set : -> standard:string list Action_builder.t -> string list Action_builder.t -val eval_blang : t -> Blang.t -> bool +val eval_blang : t -> Blang.t -> bool Memo.Build.t val map_exe : t -> Path.t -> Path.t diff --git a/src/dune_rules/file_binding.ml b/src/dune_rules/file_binding.ml index d5d5209bedb..62b95da3897 100644 --- a/src/dune_rules/file_binding.ml +++ b/src/dune_rules/file_binding.ml @@ -1,5 +1,6 @@ open! Dune_engine open! Stdune +open Memo.Build.O type ('src, 'dst) t = { src : 'src @@ -38,14 +39,14 @@ module Unexpanded = struct ; dst = Some (String_with_vars.make_text locd dst) } - let expand_src t ~dir ~f = Path.Build.relative dir (f t.src) + let expand_src t ~dir ~f = f t.src >>| Path.Build.relative dir let destination_relative_to_install_path t ~section ~expand ~expand_partial = - let dst = Option.map ~f:expand t.dst in - Install.Entry.adjust_dst ~section ~src:(expand_partial t.src) ~dst + let+ src = expand_partial t.src + and+ dst = Memo.Build.Option.map ~f:expand t.dst in + Install.Entry.adjust_dst ~section ~src ~dst let expand t ~dir ~f = - let open Memo.Build.O in let f sw = let+ f = f sw in (String_with_vars.loc sw, f) @@ -63,25 +64,6 @@ module Unexpanded = struct in { src; dst } - (* CR-someday amokhov: The function below is almost the same as [expand] but - factoring out the common functionality might make it more complicated, so - I'm not doing this for now. This function has only one remaining use site - and is likely to disappear with further "monadification". *) - let expand_static t ~dir ~f = - let f sw = (String_with_vars.loc sw, f sw) in - let src = - let loc, expanded = f t.src in - (loc, Path.Build.relative dir expanded) - in - { src - ; dst = - (let f sw = - let loc, p = f sw in - (loc, p) - in - Option.map ~f t.dst) - } - module L = struct let decode_file = let open Dune_lang.Decoder in diff --git a/src/dune_rules/file_binding.mli b/src/dune_rules/file_binding.mli index f4ab6b7309d..05f126a280f 100644 --- a/src/dune_rules/file_binding.mli +++ b/src/dune_rules/file_binding.mli @@ -26,18 +26,18 @@ module Unexpanded : sig -> f:(String_with_vars.t -> string Memo.Build.t) -> Expanded.t Memo.Build.t - val expand_static : - t -> dir:Path.Build.t -> f:(String_with_vars.t -> string) -> Expanded.t - val expand_src : - t -> dir:Path.Build.t -> f:(String_with_vars.t -> string) -> Path.Build.t + t + -> dir:Path.Build.t + -> f:(String_with_vars.t -> string Memo.Build.t) + -> Path.Build.t Memo.Build.t val destination_relative_to_install_path : t -> section:Install.Section.t - -> expand:(String_with_vars.t -> string) - -> expand_partial:(String_with_vars.t -> String_with_vars.t) - -> Install.Dst.t + -> expand:(String_with_vars.t -> string Memo.Build.t) + -> expand_partial:(String_with_vars.t -> String_with_vars.t Memo.Build.t) + -> Install.Dst.t Memo.Build.t module L : sig val decode : t list Dune_lang.Decoder.t diff --git a/src/dune_rules/foreign_rules.ml b/src/dune_rules/foreign_rules.ml index 3f47576ff70..0ed8a7b1834 100644 --- a/src/dune_rules/foreign_rules.ml +++ b/src/dune_rules/foreign_rules.ml @@ -25,74 +25,76 @@ let include_dir_flags ~expander ~dir (stubs : Foreign.Stubs.t) = match (include_dir : Foreign.Stubs.Include_dir.t) with | Dir dir -> Resolve.return - ( String_with_vars.loc dir - , Expander.Static.expand_path expander dir ) + (String_with_vars.loc dir, Expander.expand_path expander dir) | Lib (loc, lib_name) -> let+ lib_dir = lib_dir loc lib_name in - (loc, lib_dir) + (loc, Action_builder.return lib_dir) in - let dep_args = - match Path.extract_build_context_dir include_dir with - | None -> - (* This branch corresponds to an external directory. The current - implementation tracks its contents NON-recursively. *) - (* TODO: Track the contents recursively. One way to implement - this is to change [Build_system.Loaded.Non_build] so that it - contains not only files but also directories and traverse them - recursively in [Build_system.Exported.Pred]. *) - let () = - let error msg = - User_error.raise ~loc - [ Pp.textf "Unable to read the include directory." - ; Pp.textf "Reason: %s." msg - ] + Command.Args.Dyn + (let open Action_builder.O in + let+ include_dir = include_dir in + let dep_args = + match Path.extract_build_context_dir include_dir with + | None -> + (* This branch corresponds to an external directory. The + current implementation tracks its contents NON-recursively. *) + (* TODO: Track the contents recursively. One way to implement + this is to change [Build_system.Loaded.Non_build] so that it + contains not only files but also directories and traverse + them recursively in [Build_system.Exported.Pred]. *) + let () = + let error msg = + User_error.raise ~loc + [ Pp.textf "Unable to read the include directory." + ; Pp.textf "Reason: %s." msg + ] + in + match Path.is_directory_with_error include_dir with + | Error msg -> error msg + | Ok false -> + error + (Printf.sprintf "%S is not a directory" + (Path.to_string include_dir)) + | Ok true -> () in - match Path.is_directory_with_error include_dir with - | Error msg -> error msg - | Ok false -> - error - (Printf.sprintf "%S is not a directory" - (Path.to_string include_dir)) - | Ok true -> () - in - let deps = - Dep.Set.singleton - (Dep.file_selector - (File_selector.create ~dir:include_dir Predicate.true_)) - in - Command.Args.Hidden_deps deps - | Some (build_dir, source_dir) -> - let open Action_builder.O in - Command.Args.Dyn - ((* This branch corresponds to a source directory. We track its - contents recursively. *) - Action_builder.memo_build (Source_tree.find_dir source_dir) - >>= function - | None -> - User_error.raise ~loc - [ Pp.textf "Include directory %S does not exist." - (Path.reach ~from:(Path.build dir) include_dir) - ] - | Some dir -> - let+ l = - Source_tree_map_reduce.map_reduce dir - ~traverse:Sub_dirs.Status.Set.all ~f:(fun t -> - let dir = - Path.append_source build_dir - (Source_tree.Dir.path t) - in - let deps = - Dep.Set.singleton - (Dep.file_selector - (File_selector.create ~dir Predicate.true_)) - in - Action_builder.return - (Appendable_list.singleton - (Command.Args.Hidden_deps deps))) - in - Command.Args.S (Appendable_list.to_list l)) - in - Command.Args.S [ A "-I"; Path include_dir; dep_args ]))) + let deps = + Dep.Set.singleton + (Dep.file_selector + (File_selector.create ~dir:include_dir Predicate.true_)) + in + Command.Args.Hidden_deps deps + | Some (build_dir, source_dir) -> + let open Action_builder.O in + Command.Args.Dyn + ((* This branch corresponds to a source directory. We track + its contents recursively. *) + Action_builder.memo_build (Source_tree.find_dir source_dir) + >>= function + | None -> + User_error.raise ~loc + [ Pp.textf "Include directory %S does not exist." + (Path.reach ~from:(Path.build dir) include_dir) + ] + | Some dir -> + let+ l = + Source_tree_map_reduce.map_reduce dir + ~traverse:Sub_dirs.Status.Set.all ~f:(fun t -> + let dir = + Path.append_source build_dir + (Source_tree.Dir.path t) + in + let deps = + Dep.Set.singleton + (Dep.file_selector + (File_selector.create ~dir Predicate.true_)) + in + Action_builder.return + (Appendable_list.singleton + (Command.Args.Hidden_deps deps))) + in + Command.Args.S (Appendable_list.to_list l)) + in + Command.Args.S [ A "-I"; Path include_dir; dep_args ])))) let build_c ~kind ~sctx ~dir ~expander ~include_flags (loc, src, dst) = let ctx = Super_context.context sctx in diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index ef64cee9cb7..757660a5936 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -88,21 +88,26 @@ end = struct Lib_rules.foreign_rules lib ~sctx ~dir ~dir_contents ~expander in empty_none - | Executables exes when Expander.eval_blang expander exes.enabled_if -> - let* () = Memo.Build.Option.iter exes.install_conf ~f:files_to_install in - let+ cctx, merlin = - Exe_rules.rules exes ~sctx ~dir ~scope ~expander ~dir_contents - in - { merlin = Some merlin - ; cctx = Some (exes.buildable.loc, cctx) - ; js = - Some - (List.concat_map exes.names ~f:(fun (_, exe) -> - List.map - [ exe ^ ".bc.js"; exe ^ ".bc.runtime.js" ] - ~f:(Path.Build.relative dir))) - ; source_dirs = None - } + | Executables exes -> ( + Expander.eval_blang expander exes.enabled_if >>= function + | false -> Memo.Build.return empty_none + | true -> + let* () = + Memo.Build.Option.iter exes.install_conf ~f:files_to_install + in + let+ cctx, merlin = + Exe_rules.rules exes ~sctx ~dir ~scope ~expander ~dir_contents + in + { merlin = Some merlin + ; cctx = Some (exes.buildable.loc, cctx) + ; js = + Some + (List.concat_map exes.names ~f:(fun (_, exe) -> + List.map + [ exe ^ ".bc.js"; exe ^ ".bc.runtime.js" ] + ~f:(Path.Build.relative dir))) + ; source_dirs = None + }) | Alias alias -> let+ () = Simple_rules.alias sctx alias ~dir ~expander in empty_none @@ -116,9 +121,9 @@ end = struct ; source_dirs = None } | Copy_files { files = glob; _ } -> - let source_dirs = + let* source_dirs = let loc = String_with_vars.loc glob in - let src_glob = Expander.Static.expand_str expander glob in + let+ src_glob = Expander.No_deps.expand_str expander glob in if Filename.is_relative src_glob then Some (Path.Source.relative src_dir src_glob ~error_loc:loc @@ -136,9 +141,12 @@ end = struct | Cinaps.T cinaps -> let+ () = Cinaps.gen_rules sctx cinaps ~dir ~scope in empty_none - | Mdx.T mdx when Expander.eval_blang expander (Mdx.enabled_if mdx) -> - let+ () = Mdx.gen_rules ~sctx ~dir ~expander mdx in - empty_none + | Mdx.T mdx -> ( + Expander.eval_blang expander (Mdx.enabled_if mdx) >>= function + | false -> Memo.Build.return empty_none + | true -> + let+ () = Mdx.gen_rules ~sctx ~dir ~expander mdx in + empty_none) | _ -> Memo.Build.return empty_none let of_stanzas stanzas ~cctxs ~sctx ~src_dir ~ctx_dir ~scope ~dir_contents @@ -219,11 +227,12 @@ let gen_rules sctx dir_contents cctxs expander = let files_to_install { Install_conf.section = _; files; package = _; enabled_if = _ } = - Path.Set.of_list_map files ~f:(fun fb -> + Memo.Build.List.map files ~f:(fun fb -> File_binding.Unexpanded.expand_src ~dir:ctx_dir fb - ~f:(Expander.Static.expand_str expander) - |> Path.build) - |> Rules.Produce.Alias.add_static_deps (Alias.all ~dir:ctx_dir) + ~f:(Expander.No_deps.expand_str expander) + >>| Path.build) + >>| Path.Set.of_list + >>= Rules.Produce.Alias.add_static_deps (Alias.all ~dir:ctx_dir) in let* { For_stanza.merlin = merlins ; cctx = cctxs @@ -243,37 +252,43 @@ let gen_rules sctx dir_contents cctxs expander let* () = Memo.Build.parallel_iter stanzas ~f:(fun stanza -> match (stanza : Stanza.t) with - | Menhir.T m when Expander.eval_blang expander m.enabled_if -> ( - let* ml_sources = Dir_contents.ocaml dir_contents in - match - List.find_map (Menhir_rules.module_names m) ~f:(fun name -> - Option.bind (Ml_sources.lookup_module ml_sources name) - ~f:(fun buildable -> - List.find_map cctxs ~f:(fun (loc, cctx) -> - Option.some_if (Loc.equal loc buildable.loc) cctx))) - with - | None -> - (* This happens often when passing a [-p ...] option that hides a - library *) - let targets = - List.map (Menhir_rules.targets m) ~f:(Path.Build.relative ctx_dir) - in - Super_context.add_rule sctx ~dir:ctx_dir - (Action_builder.fail - { fail = - (fun () -> - User_error.raise ~loc:m.loc - [ Pp.text - "I can't determine what library/executable the \ - files produced by this stanza are part of." - ]) - } - |> Action_builder.with_targets ~targets) - | Some cctx -> Menhir_rules.gen_rules cctx m ~dir:ctx_dir) - | Coq_stanza.Theory.T m when Expander.eval_blang expander m.enabled_if - -> - Coq_rules.setup_rules ~sctx ~dir:ctx_dir ~dir_contents m - >>= Super_context.add_rules ~dir:ctx_dir sctx + | Menhir.T m -> ( + Expander.eval_blang expander m.enabled_if >>= function + | false -> Memo.Build.return () + | true -> ( + let* ml_sources = Dir_contents.ocaml dir_contents in + match + List.find_map (Menhir_rules.module_names m) ~f:(fun name -> + Option.bind (Ml_sources.lookup_module ml_sources name) + ~f:(fun buildable -> + List.find_map cctxs ~f:(fun (loc, cctx) -> + Option.some_if (Loc.equal loc buildable.loc) cctx))) + with + | None -> + (* This happens often when passing a [-p ...] option that hides a + library *) + let targets = + List.map (Menhir_rules.targets m) + ~f:(Path.Build.relative ctx_dir) + in + Super_context.add_rule sctx ~dir:ctx_dir + (Action_builder.fail + { fail = + (fun () -> + User_error.raise ~loc:m.loc + [ Pp.text + "I can't determine what library/executable the \ + files produced by this stanza are part of." + ]) + } + |> Action_builder.with_targets ~targets) + | Some cctx -> Menhir_rules.gen_rules cctx m ~dir:ctx_dir)) + | Coq_stanza.Theory.T m -> ( + Expander.eval_blang expander m.enabled_if >>= function + | false -> Memo.Build.return () + | true -> + Coq_rules.setup_rules ~sctx ~dir:ctx_dir ~dir_contents m + >>= Super_context.add_rules ~dir:ctx_dir sctx) | Coq_stanza.Extraction.T m -> Coq_rules.extraction_rules ~sctx ~dir:ctx_dir ~dir_contents m >>= Super_context.add_rules ~dir:ctx_dir sctx diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index b8c589c76d8..76dfb85e15a 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -95,7 +95,7 @@ end = struct let loc = lib.buildable.loc in let ctx = Super_context.context sctx in let lib_config = ctx.lib_config in - let info = Dune_file.Library.to_lib_info lib ~dir ~lib_config in + let* info = Dune_file.Library.to_lib_info lib ~dir ~lib_config in let obj_dir = Lib_info.obj_dir info in let make_entry section ?sub_dir ?dst fn = ( Some loc @@ -214,31 +214,32 @@ end = struct (Dune_file.Library.best_name lib)) | Dune_file.Documentation _ -> Memo.Build.return true | Dune_file.Install { enabled_if; _ } -> - Memo.Build.return (Expander.eval_blang expander enabled_if) + Expander.eval_blang expander enabled_if | Dune_file.Plugin _ -> Memo.Build.return true - | Dune_file.Executables ({ install_conf = Some _; _ } as exes) -> - if not (Expander.eval_blang expander exes.enabled_if) then - Memo.Build.return false - else if not exes.optional then - Memo.Build.return true - else - let+ compile_info = - let dune_version = - Scope.project scope |> Dune_project.dune_version - in - let+ pps = - Resolve.read_memo_build - (Preprocess.Per_module.with_instrumentation - exes.buildable.preprocess - ~instrumentation_backend: - (Lib.DB.instrumentation_backend (Scope.libs scope))) - >>| Preprocess.Per_module.pps + | Dune_file.Executables ({ install_conf = Some _; _ } as exes) -> ( + Expander.eval_blang expander exes.enabled_if >>= function + | false -> Memo.Build.return false + | true -> + if not exes.optional then + Memo.Build.return true + else + let+ compile_info = + let dune_version = + Scope.project scope |> Dune_project.dune_version + in + let+ pps = + Resolve.read_memo_build + (Preprocess.Per_module.with_instrumentation + exes.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope))) + >>| Preprocess.Per_module.pps + in + Lib.DB.resolve_user_written_deps_for_exes (Scope.libs scope) + exes.names exes.buildable.libraries ~pps ~dune_version + ~allow_overlaps:exes.buildable.allow_overlapping_dependencies in - Lib.DB.resolve_user_written_deps_for_exes (Scope.libs scope) - exes.names exes.buildable.libraries ~pps ~dune_version - ~allow_overlaps:exes.buildable.allow_overlapping_dependencies - in - Resolve.is_ok (Lib.Compile.direct_requires compile_info) + Resolve.is_ok (Lib.Compile.direct_requires compile_info)) | Coq_stanza.Theory.T d -> Memo.Build.return (Option.is_some d.package) | _ -> Memo.Build.return false in @@ -323,20 +324,19 @@ end = struct | Dune_file.Install i | Dune_file.Executables { install_conf = Some i; _ } -> let path_expander = - File_binding.Unexpanded.expand_static ~dir - ~f:(Expander.Static.expand_str expander) + File_binding.Unexpanded.expand ~dir + ~f:(Expander.No_deps.expand_str expander) in let section = i.section in - Memo.Build.return - (List.map i.files ~f:(fun unexpanded -> - let fb = path_expander unexpanded in - let loc = File_binding.Expanded.src_loc fb in - let src = File_binding.Expanded.src fb in - let dst = File_binding.Expanded.dst fb in - ( Some loc - , Install.Entry.make_with_site section - (Super_context.get_site_of_packages sctx) - src ?dst ))) + Memo.Build.List.map i.files ~f:(fun unexpanded -> + let+ fb = path_expander unexpanded in + let loc = File_binding.Expanded.src_loc fb in + let src = File_binding.Expanded.src fb in + let dst = File_binding.Expanded.dst fb in + ( Some loc + , Install.Entry.make_with_site section + (Super_context.get_site_of_packages sctx) + src ?dst )) | Dune_file.Library lib -> let sub_dir = Dune_file.Library.sub_dir lib in let* dir_contents = Dir_contents.get sctx ~dir in diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index 5b78c298633..d96df476c4b 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -314,9 +314,9 @@ let setup_build_archives (lib : Dune_file.Library.t) ~cctx [Obj_dir]. That's fragile and will break if the layout of the object directory changes *) let dir = Obj_dir.dir obj_dir in - let native_archives = + let* native_archives = let lib_config = ctx.lib_config in - let lib_info = Library.to_lib_info lib ~dir ~lib_config in + let+ lib_info = Library.to_lib_info lib ~dir ~lib_config in Lib_info.eval_native_archives_exn lib_info ~modules:(Some modules) in let cm_files = Cm_files.make ~obj_dir ~ext_obj ~modules ~top_sorted_modules in diff --git a/src/dune_rules/merlin.ml b/src/dune_rules/merlin.ml index 7bdc6b3cf6c..d3c2ac23256 100644 --- a/src/dune_rules/merlin.ml +++ b/src/dune_rules/merlin.ml @@ -310,20 +310,18 @@ module Unprocessed = struct | Action (loc, (action : Action_dune_lang.t)) -> pp_flag_of_action ~expander ~loc ~action | No_preprocessing -> Action_builder.return None - | Pps { loc; pps; flags; staged = _ } -> ( - match - Resolve.peek - (Preprocessing.get_ppx_driver sctx ~loc ~expander ~lib_name:libname - ~flags ~scope pps) - with - | Error () -> Action_builder.return None - | Ok (exe, flags) -> - let args = - Path.to_absolute_filename (Path.build exe) :: "--as-ppx" :: flags - |> List.map ~f:quote_if_needed - |> String.concat ~sep:" " - in - Action_builder.return (Some Processed.{ flag = "-ppx"; args })) + | Pps { loc; pps; flags; staged = _ } -> + let open Action_builder.O in + let* exe, flags = + Preprocessing.get_ppx_driver sctx ~loc ~expander ~lib_name:libname + ~flags ~scope pps + in + let args = + Path.to_absolute_filename (Path.build exe) :: "--as-ppx" :: flags + |> List.map ~f:quote_if_needed + |> String.concat ~sep:" " + in + Action_builder.return (Some Processed.{ flag = "-ppx"; args }) let process { modules diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index 6dba8df43bb..961fe7e7678 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -93,14 +93,14 @@ module Artifacts = struct let lookup_library { libraries; modules = _ } = Lib_name.Map.find libraries let make (d : _ Dir_with_dune.t) ~lib_config (libs, exes) = - let libraries = - List.fold_left ~init:Lib_name.Map.empty libs - ~f:(fun libraries (lib, _, _) -> + let+ libraries = + Memo.Build.List.map libs ~f:(fun (lib, _, _) -> let name = Lib_name.of_local lib.Library.name in - let info = + let+ info = Dune_file.Library.to_lib_info lib ~dir:d.ctx_dir ~lib_config in - Lib_name.Map.add_exn libraries name info) + (name, info)) + >>| Lib_name.Map.of_list_exn in let modules = let by_name modules obj_dir = @@ -333,7 +333,6 @@ let make (d : _ Dir_with_dune.t) ~lib_config ~loc ~lookup_vlib ~include_subdirs in let modules = Modules.make libs_and_exes in let artifacts = - Memo.lazy_ (fun () -> - Memo.Build.return (Artifacts.make ~lib_config d libs_and_exes)) + Memo.lazy_ (fun () -> Artifacts.make ~lib_config d libs_and_exes) in { modules; artifacts } diff --git a/src/dune_rules/preprocessing.ml b/src/dune_rules/preprocessing.ml index 80e5dd1e1da..02177a90e8a 100644 --- a/src/dune_rules/preprocessing.ml +++ b/src/dune_rules/preprocessing.ml @@ -387,6 +387,7 @@ let ppx_driver_exe sctx libs = ppx_exe sctx ~key let get_cookies ~loc ~expander ~lib_name libs = + let open Memo.Build.O in let expander, library_name_cookie = match lib_name with | None -> (expander, None) @@ -399,48 +400,50 @@ let get_cookies ~loc ~expander ~lib_name libs = , Some ("library-name", (library_name, Lib_name.of_local (loc, lib_name))) ) in - match - List.concat_map libs ~f:(fun t -> + let+ cookies = + Memo.Build.List.concat_map libs ~f:(fun t -> let info = Lib.info t in let kind = Lib_info.kind info in match kind with - | Normal -> [] + | Normal -> Memo.Build.return [] | Ppx_rewriter { cookies } | Ppx_deriver { cookies } -> - List.map + Memo.Build.List.map ~f:(fun { Lib_kind.Ppx_args.Cookie.name; value } -> - (name, (Expander.Static.expand_str expander value, Lib.name t))) + let+ value = Expander.No_deps.expand_str expander value in + (name, (value, Lib.name t))) cookies) - |> (fun l -> - match library_name_cookie with - | None -> l - | Some cookie -> cookie :: l) - |> String.Map.of_list_reducei - ~f:(fun name ((val1, lib1) as res) (val2, lib2) -> - if String.equal val1 val2 then - res - else - let lib1 = Lib_name.to_string lib1 in - let lib2 = Lib_name.to_string lib2 in - User_error.raise ~loc - [ Pp.textf - "%s and %s have inconsistent requests for cookie %S; %s \ - requests %S and %s requests %S" - lib1 lib2 name lib1 val1 lib2 val2 - ]) - |> String.Map.foldi ~init:[] ~f:(fun name (value, _) acc -> - (name, value) :: acc) - |> List.rev - |> List.concat_map ~f:(fun (name, value) -> - [ "--cookie"; sprintf "%s=%S" name value ]) - with - | x -> Resolve.return x - | exception User_error.E (msg, []) -> Resolve.fail msg + in + cookies + |> (fun l -> + match library_name_cookie with + | None -> l + | Some cookie -> cookie :: l) + |> String.Map.of_list_reducei + ~f:(fun name ((val1, lib1) as res) (val2, lib2) -> + if String.equal val1 val2 then + res + else + let lib1 = Lib_name.to_string lib1 in + let lib2 = Lib_name.to_string lib2 in + User_error.raise ~loc + [ Pp.textf + "%s and %s have inconsistent requests for cookie %S; %s \ + requests %S and %s requests %S" + lib1 lib2 name lib1 val1 lib2 val2 + ]) + |> String.Map.to_list_map ~f:(fun name (value, _) -> + [ "--cookie"; sprintf "%s=%S" name value ]) + |> List.concat let ppx_driver_and_flags_internal sctx ~loc ~expander ~lib_name ~flags libs = - let open Resolve.O in - let flags = List.map ~f:(Expander.Static.expand_str expander) flags in - let+ cookies = get_cookies ~loc ~lib_name ~expander libs in + let open Action_builder.O in + let* flags = + Action_builder.List.map ~f:(Expander.expand_str expander) flags + in + let+ cookies = + Action_builder.memo_build (get_cookies ~loc ~lib_name ~expander libs) + in let sctx = SC.host sctx in (ppx_driver_exe sctx libs, flags @ cookies) @@ -448,8 +451,7 @@ let ppx_driver_and_flags sctx ~lib_name ~expander ~scope ~loc ~flags pps = let open Action_builder.O in let* libs = Resolve.read (Lib.DB.resolve_pps (Scope.libs scope) pps) in let* exe, flags = - Resolve.read - (ppx_driver_and_flags_internal sctx ~loc ~expander ~lib_name ~flags libs) + ppx_driver_and_flags_internal sctx ~loc ~expander ~lib_name ~flags libs in let* libs = Resolve.read (Lib.closure libs ~linking:true) in let+ driver = @@ -714,8 +716,8 @@ let make sctx ~dir ~expander ~lint ~preprocess ~preprocessor_deps |> Pp_spec.make let get_ppx_driver sctx ~loc ~expander ~scope ~lib_name ~flags pps = - let open Resolve.O in - let* libs = Lib.DB.resolve_pps (Scope.libs scope) pps in + let open Action_builder.O in + let* libs = Resolve.read (Lib.DB.resolve_pps (Scope.libs scope) pps) in ppx_driver_and_flags_internal sctx ~loc ~expander ~lib_name ~flags libs let ppx_exe sctx ~scope pp = diff --git a/src/dune_rules/preprocessing.mli b/src/dune_rules/preprocessing.mli index e2222bcfa5e..e5b6dc38484 100644 --- a/src/dune_rules/preprocessing.mli +++ b/src/dune_rules/preprocessing.mli @@ -25,7 +25,7 @@ val get_ppx_driver : -> lib_name:Lib_name.Local.t option -> flags:String_with_vars.t list -> (Loc.t * Lib_name.t) list - -> (Path.Build.t * string list) Resolve.t + -> (Path.Build.t * string list) Action_builder.t val gen_rules : Super_context.t -> string list -> unit Memo.Build.t diff --git a/src/dune_rules/scope.ml b/src/dune_rules/scope.ml index 50c7a1d7692..fc1f126fbb2 100644 --- a/src/dune_rules/scope.ml +++ b/src/dune_rules/scope.ml @@ -52,50 +52,54 @@ module DB = struct | Deprecated_library_name of Dune_file.Deprecated_library_name.t end - let create_db_from_stanzas ~parent ~lib_config ~modules_of_lib stanzas = - let map : Found_or_redirect.t Lib_name.Map.t = - List.map stanzas ~f:(fun stanza -> + let create_db_from_stanzas ~parent ~lib_config ~modules_of_lib + ~projects_by_package stanzas = + let open Memo.Build.O in + let+ (map : Found_or_redirect.t Lib_name.Map.t) = + Memo.Build.List.map stanzas ~f:(fun stanza -> match (stanza : Library_related_stanza.t) with | Library_redirect s -> let old_public_name = Lib_name.of_local s.old_name in - Found_or_redirect.redirect old_public_name s.new_public_name + Memo.Build.return + (Found_or_redirect.redirect old_public_name s.new_public_name) | Deprecated_library_name s -> let old_public_name = Dune_file.Deprecated_library_name.old_public_name s in - Found_or_redirect.redirect old_public_name s.new_public_name + Memo.Build.return + (Found_or_redirect.redirect old_public_name s.new_public_name) | Library (dir, (conf : Dune_file.Library.t)) -> - let info = + let+ info = Dune_file.Library.to_lib_info conf ~dir ~lib_config - |> Lib_info.of_local + >>| Lib_info.of_local in (Dune_file.Library.best_name conf, Found_or_redirect.found info)) - |> Lib_name.Map.of_list_reducei - ~f:(fun name (v1 : Found_or_redirect.t) v2 -> - let res = - match (v1, v2) with - | Found info1, Found info2 -> - Error (Lib_info.loc info1, Lib_info.loc info2) - | Found info, Redirect (loc, _) - | Redirect (loc, _), Found info -> - Error (loc, Lib_info.loc info) - | Redirect (loc1, lib1), Redirect (loc2, lib2) -> - if Lib_name.equal lib1 lib2 then - Ok v1 - else - Error (loc1, loc2) - in - match res with - | Ok x -> x - | Error (loc1, loc2) -> - User_error.raise - [ Pp.textf "Library %s is defined twice:" - (Lib_name.to_string name) - ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) - ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) - ]) + >>| Lib_name.Map.of_list_reducei + ~f:(fun name (v1 : Found_or_redirect.t) v2 -> + let res = + match (v1, v2) with + | Found info1, Found info2 -> + Error (Lib_info.loc info1, Lib_info.loc info2) + | Found info, Redirect (loc, _) + | Redirect (loc, _), Found info -> + Error (loc, Lib_info.loc info) + | Redirect (loc1, lib1), Redirect (loc2, lib2) -> + if Lib_name.equal lib1 lib2 then + Ok v1 + else + Error (loc1, loc2) + in + match res with + | Ok x -> x + | Error (loc1, loc2) -> + User_error.raise + [ Pp.textf "Library %s is defined twice:" + (Lib_name.to_string name) + ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) + ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) + ]) in - Lib.DB.create () ~parent:(Some parent) + Lib.DB.create () ~parent:(Some parent) ~projects_by_package ~resolve:(fun name -> match Lib_name.Map.find map name with | None -> Lib.DB.Resolve_result.not_found @@ -181,8 +185,12 @@ module DB = struct ~all:(fun () -> Lib_name.Map.keys public_libs) ~lib_config () + module Path_source_map_traversals = + Memo.Build.Make_map_traversals (Path.Source.Map) + let scopes_by_dir context ~projects_by_package ~modules_of_lib ~projects ~public_libs stanzas coq_stanzas = + let open Memo.Build.O in let projects_by_dir = List.map projects ~f:(fun (project : Dune_project.t) -> (Dune_project.root project, project)) @@ -199,29 +207,36 @@ module DB = struct (Dune_project.root project, stanza)) |> Path.Source.Map.of_list_multi in - let coq_stanzas_by_project_dir = + let coq_db_by_project_dir = List.map coq_stanzas ~f:(fun (dir, t) -> let project = t.Coq_stanza.Theory.project in (Dune_project.root project, (dir, t))) |> Path.Source.Map.of_list_multi - in - let stanzas_by_project_dir = - Path.Source.Map.merge stanzas_by_project_dir coq_stanzas_by_project_dir - ~f:(fun _dir stanzas coq_stanzas -> - let stanza = Option.value stanzas ~default:[] in - let coq_stanzas = Option.value coq_stanzas ~default:[] in - Some (stanza, coq_stanzas)) + |> Path.Source.Map.map ~f:Coq_lib.DB.create_from_coqlib_stanzas in let lib_config = Context.lib_config context in - Path.Source.Map.merge projects_by_dir stanzas_by_project_dir - ~f:(fun _dir project stanzas -> - let project = Option.value_exn project in - let stanzas, coq_stanzas = Option.value stanzas ~default:([], []) in - let db = - create_db_from_stanzas stanzas ~parent:public_libs ~modules_of_lib - ~projects_by_package ~lib_config + let+ db_by_project_dir = + Path.Source.Map.merge projects_by_dir stanzas_by_project_dir + ~f:(fun _dir project stanzas -> + let project = Option.value_exn project in + let stanzas = Option.value stanzas ~default:[] in + Some (project, stanzas)) + |> Path_source_map_traversals.parallel_map + ~f:(fun _dir (project, stanzas) -> + let+ db = + create_db_from_stanzas stanzas ~parent:public_libs + ~modules_of_lib ~projects_by_package ~lib_config + in + (project, db)) + in + Path.Source.Map.merge db_by_project_dir coq_db_by_project_dir + ~f:(fun _dir project_and_db coq_db -> + let project, db = Option.value_exn project_and_db in + let coq_db = + match coq_db with + | Some db -> db + | None -> Coq_lib.DB.create_from_coqlib_stanzas [] in - let coq_db = Coq_lib.DB.create_from_coqlib_stanzas coq_stanzas in let root = Path.Build.append_source context.build_dir (Dune_project.root project) in @@ -229,13 +244,14 @@ module DB = struct let create ~projects_by_package ~context ~installed_libs ~modules_of_lib ~projects stanzas coq_stanzas = + let open Memo.Build.O in let t = Fdecl.create Dyn.Encoder.opaque in let public_libs = let lib_config = Context.lib_config context in public_libs t ~installed_libs ~lib_config ~projects_by_package ~modules_of_lib stanzas in - let by_dir = + let+ by_dir = scopes_by_dir context ~projects ~projects_by_package ~public_libs ~modules_of_lib stanzas coq_stanzas in diff --git a/src/dune_rules/scope.mli b/src/dune_rules/scope.mli index c6f99a74096..83a339c278d 100644 --- a/src/dune_rules/scope.mli +++ b/src/dune_rules/scope.mli @@ -31,7 +31,7 @@ module DB : sig -> modules_of_lib: (dir:Path.Build.t -> name:Lib_name.t -> Modules.t Memo.Build.t) Fdecl.t -> Dune_file.t list - -> t * Lib.DB.t + -> (t * Lib.DB.t) Memo.Build.t val find_by_dir : t -> Path.Build.t -> scope diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 64265e749f9..f263524c4b4 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -16,7 +16,7 @@ module Alias_rules = struct end let interpret_locks ~expander = - List.map ~f:(Expander.Static.expand_path expander) + Memo.Build.List.map ~f:(Expander.No_deps.expand_path expander) let check_filename = let not_in_dir ~error_loc s = @@ -56,18 +56,17 @@ let rule_kind ~(rule : Rule.t) | Some target -> Alias_with_targets (alias, target)) let add_user_rule sctx ~dir ~(rule : Rule.t) ~action ~expander = + let* locks = interpret_locks ~expander rule.locks in SC.add_rule_get_targets sctx (* user rules may have extra requirements, in which case they will be specified as a part of rule.deps, which will be correctly taken care of by the action builder *) ~sandbox:Sandbox_config.no_special_requirements ~dir ~mode:rule.mode - ~loc:rule.loc - ~locks:(interpret_locks ~expander rule.locks) - action + ~loc:rule.loc ~locks action let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = - match Expander.eval_blang expander rule.enabled_if with + Expander.eval_blang expander rule.enabled_if >>= function | false -> ( match rule.alias with | None -> Memo.Build.return Path.Build.Set.empty @@ -76,26 +75,28 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = let+ () = Alias_rules.add_empty sctx ~alias ~loc:(Some rule.loc) in Path.Build.Set.empty) | true -> ( - let targets : _ Targets.t = + let* targets = match rule.targets with - | Infer -> Infer + | Infer -> Memo.Build.return Targets.Infer | Static { targets; multiplicity } -> - let targets = - List.concat_map targets ~f:(fun target -> + let+ targets = + Memo.Build.List.concat_map targets ~f:(fun target -> let error_loc = String_with_vars.loc target in (match multiplicity with - | One -> [ Expander.Static.expand expander ~mode:Single target ] - | Multiple -> Expander.Static.expand expander ~mode:Many target) - |> List.map ~f:(check_filename ~dir ~error_loc)) + | One -> + let+ x = Expander.No_deps.expand expander ~mode:Single target in + [ x ] + | Multiple -> Expander.No_deps.expand expander ~mode:Many target) + >>| List.map ~f:(check_filename ~dir ~error_loc)) in - Static { multiplicity; targets } + Targets.Static { multiplicity; targets } in let expander = match extra_bindings with | None -> expander | Some bindings -> Expander.add_bindings expander ~bindings in - let action = + let* action = Action_unexpanded.expand (snd rule.action) ~loc:(fst rule.action) ~expander ~deps:rule.deps ~targets ~targets_dir:dir in @@ -110,7 +111,7 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = add_user_rule sctx ~dir ~rule ~action ~expander | Alias_only name -> let alias = Alias.make ~dir name in - let locks = interpret_locks ~expander rule.locks in + let* locks = interpret_locks ~expander rule.locks in let+ () = Alias_rules.add sctx ~alias ~loc:(Some rule.loc) action.build ~locks in @@ -118,8 +119,8 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = let loc = String_with_vars.loc def.files in - let glob_in_src = - let src_glob = Expander.Static.expand_str expander def.files in + let* glob_in_src = + let+ src_glob = Expander.No_deps.expand_str expander def.files in if Filename.is_relative src_glob then Path.Source.relative src_dir src_glob ~error_loc:loc |> Path.source else @@ -199,15 +200,14 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = targets let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = - if Expander.eval_blang expander def.enabled_if then - copy_files sctx ~dir ~expander ~src_dir def - else - Memo.Build.return Path.Set.empty + Expander.eval_blang expander def.enabled_if >>= function + | true -> copy_files sctx ~dir ~expander ~src_dir def + | false -> Memo.Build.return Path.Set.empty let alias sctx ?extra_bindings ~dir ~expander (alias_conf : Alias_conf.t) = let alias = Alias.make ~dir alias_conf.name in let loc = Some alias_conf.loc in - match Expander.eval_blang expander alias_conf.enabled_if with + Expander.eval_blang expander alias_conf.enabled_if >>= function | false -> Alias_rules.add_empty sctx ~loc ~alias | true -> ( match alias_conf.action with @@ -215,7 +215,7 @@ let alias sctx ?extra_bindings ~dir ~expander (alias_conf : Alias_conf.t) = let builder, _expander = Dep_conf_eval.named ~expander alias_conf.deps in Rules.Produce.Alias.add_deps alias ?loc builder | Some (action_loc, action) -> - let locks = interpret_locks ~expander alias_conf.locks in + let* locks = interpret_locks ~expander alias_conf.locks in let action = let builder, expander = Dep_conf_eval.named ~expander alias_conf.deps in let open Action_builder.O in diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index 9b30d592f6b..630d2a63117 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -426,19 +426,19 @@ let resolve_program t ~dir ?hint ~loc bin = Artifacts.Bin.binary ?hint ~loc bin_artifacts bin let get_installed_binaries stanzas ~(context : Context.t) = - let open Resolve.O in + let open Memo.Build.O in let install_dir = Local_install_path.bin_dir ~context:context.name in let expand_str ~dir sw = - Expander.Static.With_reduced_var_set.expand_str ~context ~dir sw + Expander.With_reduced_var_set.expand_str ~context ~dir sw in let expand_str_partial ~dir sw = - Expander.Static.With_reduced_var_set.expand_str_partial ~context ~dir sw + Expander.With_reduced_var_set.expand_str_partial ~context ~dir sw in - Resolve.List.map stanzas ~f:(fun (d : _ Dir_with_dune.t) -> - Resolve.List.map d.data ~f:(fun stanza -> + Memo.Build.List.map stanzas ~f:(fun (d : _ Dir_with_dune.t) -> + Memo.Build.List.map d.data ~f:(fun stanza -> let binaries_from_install files = - List.fold_left files ~init:Path.Build.Set.empty ~f:(fun acc fb -> - let p = + Memo.Build.List.map files ~f:(fun fb -> + let+ p = File_binding.Unexpanded.destination_relative_to_install_path fb ~section:Bin ~expand:(expand_str ~dir:d.ctx_dir) @@ -446,24 +446,26 @@ let get_installed_binaries stanzas ~(context : Context.t) = in let p = Path.Local.of_string (Install.Dst.to_string p) in if Path.Local.is_root (Path.Local.parent_exn p) then - Path.Build.Set.add acc (Path.Build.append_local install_dir p) + Some (Path.Build.append_local install_dir p) else - acc) + None) + >>| List.filter_map ~f:Fun.id >>| Path.Build.Set.of_list in match (stanza : Stanza.t) with | Dune_file.Install { section = Section Bin; files; _ } -> - Resolve.return (binaries_from_install files) + binaries_from_install files | Dune_file.Executables ({ install_conf = Some { section = Section Bin; files; _ }; _ } as exes) -> - let+ compile_info = + let* compile_info = let project = Scope.project d.scope in let dune_version = Dune_project.dune_version project in let+ pps = - Preprocess.Per_module.with_instrumentation - exes.buildable.preprocess - ~instrumentation_backend: - (Lib.DB.instrumentation_backend (Scope.libs d.scope)) + Resolve.read_memo_build + (Preprocess.Per_module.with_instrumentation + exes.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs d.scope))) >>| Preprocess.Per_module.pps in Lib.DB.resolve_user_written_deps_for_exes (Scope.libs d.scope) @@ -476,8 +478,8 @@ let get_installed_binaries stanzas ~(context : Context.t) = if available then binaries_from_install files else - Path.Build.Set.empty - | _ -> Resolve.return Path.Build.Set.empty) + Memo.Build.return Path.Build.Set.empty + | _ -> Memo.Build.return Path.Build.Set.empty) >>| Path.Build.Set.union_all) >>| Path.Build.Set.union_all @@ -533,7 +535,7 @@ let create ~(context : Context.t) ~host ~projects ~packages ~stanzas = Lib.DB.create_from_findlib context.findlib ~lib_config ~projects_by_package in let modules_of_lib_for_scope = Fdecl.create Dyn.Encoder.opaque in - let scopes, public_libs = + let* scopes, public_libs = Scope.DB.create_from_stanzas ~projects ~projects_by_package ~context ~installed_libs ~modules_of_lib:modules_of_lib_for_scope stanzas in @@ -553,9 +555,7 @@ let create ~(context : Context.t) ~host ~projects ~packages ~stanzas = (stanzas.Dir_with_dune.ctx_dir, stanzas)) in let* artifacts = - let+ local_bins = - Resolve.read_memo_build (get_installed_binaries ~context stanzas) - in + let+ local_bins = get_installed_binaries ~context stanzas in Artifacts.create context ~public_libs ~local_bins in let any_package = any_package_aux ~packages ~context in diff --git a/src/dune_rules/toplevel.ml b/src/dune_rules/toplevel.ml index 1ebd2e9458a..5f23113204b 100644 --- a/src/dune_rules/toplevel.ml +++ b/src/dune_rules/toplevel.ml @@ -68,36 +68,33 @@ type t = let make ~cctx ~source ~preprocess = { cctx; source; preprocess } let pp_flags t = + let open Action_builder.O in let open Pp.O in let sctx = Compilation_context.super_context t.cctx in let scope = Compilation_context.scope t.cctx in let expander = Compilation_context.expander t.cctx in match t.preprocess with - | Pps { loc; pps; flags; staged = _ } -> ( - match - Resolve.peek - (Preprocessing.get_ppx_driver sctx ~loc ~expander ~lib_name:None ~flags - ~scope pps) - with - | Error () -> Pp.nop - | Ok (exe, flags) -> - let ppx = - Dyn.Encoder.list Dyn.Encoder.string - [ Path.to_absolute_filename (Path.build exe) :: "--as-ppx" :: flags - |> String.concat ~sep:" " - ] - in - (* Set Clflags.all_ppx for dune utop, and Compenv.first_ppx for custom - toplevels because Topmain.main() resets Clflags.all_ppx. *) - Pp.vbox ~indent:2 - (Pp.verbatim "Clflags.all_ppx :=" ++ Pp.cut ++ Dyn.pp ppx) - ++ Pp.verbatim ";" ++ Pp.newline - ++ Pp.verbatim "Compenv.first_ppx :=" - ++ Pp.cut ++ Dyn.pp ppx ++ Pp.verbatim ";" ++ Pp.newline) + | Pps { loc; pps; flags; staged = _ } -> + let+ exe, flags = + Preprocessing.get_ppx_driver sctx ~loc ~expander ~lib_name:None ~flags + ~scope pps + in + let ppx = + Dyn.Encoder.list Dyn.Encoder.string + [ Path.to_absolute_filename (Path.build exe) :: "--as-ppx" :: flags + |> String.concat ~sep:" " + ] + in + (* Set Clflags.all_ppx for dune utop, and Compenv.first_ppx for custom + toplevels because Topmain.main() resets Clflags.all_ppx. *) + Pp.vbox ~indent:2 (Pp.verbatim "Clflags.all_ppx :=" ++ Pp.cut ++ Dyn.pp ppx) + ++ Pp.verbatim ";" ++ Pp.newline + ++ Pp.verbatim "Compenv.first_ppx :=" + ++ Pp.cut ++ Dyn.pp ppx ++ Pp.verbatim ";" ++ Pp.newline | Action _ | Future_syntax _ -> assert false (* Error in parsing *) - | No_preprocessing -> Pp.nop + | No_preprocessing -> Action_builder.return Pp.nop let setup_module_rules t = let dir = Compilation_context.dir t.cctx in @@ -105,17 +102,16 @@ let setup_module_rules t = let path = Source.source_path t.source in let requires_compile = Compilation_context.requires_compile t.cctx in let main_ml = + let open Action_builder.O in Action_builder.write_file_dyn path - (Resolve.read - (let open Resolve.O in - let* libs = requires_compile in - let include_dirs = - Path.Set.to_list (Lib.L.include_paths libs Mode.Byte) - in - let pp_ppx = pp_flags t in - let pp_dirs = Source.pp_ml t.source ~include_dirs in - let pp = Pp.seq pp_ppx pp_dirs in - Resolve.return (Format.asprintf "%a@." Pp.to_fmt pp))) + (let* libs = Resolve.read requires_compile in + let include_dirs = + Path.Set.to_list (Lib.L.include_paths libs Mode.Byte) + in + let* pp_ppx = pp_flags t in + let pp_dirs = Source.pp_ml t.source ~include_dirs in + let pp = Pp.seq pp_ppx pp_dirs in + Action_builder.return (Format.asprintf "%a@." Pp.to_fmt pp)) in Super_context.add_rule sctx ~dir main_ml diff --git a/src/memo/memo.ml b/src/memo/memo.ml index cfb956eb591..d388705f4a8 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -40,6 +40,8 @@ module type Build = sig module List : sig val map : 'a list -> f:('a -> 'b t) -> 'b list t + + val concat_map : 'a list -> f:('a -> 'b list t) -> 'b list t end val memo_build : 'a build -> 'a t @@ -81,6 +83,8 @@ module Build0 = struct module List = struct let map = parallel_map + + let concat_map l ~f = map l ~f >>| List.concat end let memo_build = Fun.id diff --git a/src/memo/memo.mli b/src/memo/memo.mli index e45d7c89210..7ca198d3936 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -7,6 +7,8 @@ module type Build = sig module List : sig val map : 'a list -> f:('a -> 'b t) -> 'b list t + + val concat_map : 'a list -> f:('a -> 'b list t) -> 'b list t end val memo_build : 'a build -> 'a t diff --git a/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t b/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t index 1b63014d0b9..42f41bea52d 100644 --- a/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t +++ b/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t @@ -9,6 +9,7 @@ -> required by _build/default/a/a.vo -> required by _build/install/default/lib/coq/user-contrib/a/a.vo -> required by _build/default/ccycle.install + -> required by %{read:ccycle.install} at dune:3 -> required by alias default in dune:1 File "b/dune", line 2, characters 7-8: 2 | (name b) @@ -20,5 +21,6 @@ -> required by _build/default/b/b.vo -> required by _build/install/default/lib/coq/user-contrib/b/b.vo -> required by _build/default/ccycle.install + -> required by %{read:ccycle.install} at dune:3 -> required by alias default in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t b/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t index d8f218a07d2..f3f0a13bde2 100644 --- a/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t +++ b/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t @@ -6,5 +6,6 @@ -> required by _build/default/b/b.vo -> required by _build/install/default/lib/coq/user-contrib/b/b.vo -> required by _build/default/cvendor.install + -> required by %{read:cvendor.install} at dune:3 -> required by alias default in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t b/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t index 43e0f2d6739..2fc16ed13f1 100644 --- a/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t +++ b/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t @@ -7,5 +7,6 @@ -> required by _build/default/public/b.vo -> required by _build/install/default/lib/coq/user-contrib/public/b.vo -> required by _build/default/public.install + -> required by %{read:public.install} at dune:3 -> required by alias default in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t b/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t index 68d61f15047..3189aac0a7f 100644 --- a/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t +++ b/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t @@ -13,6 +13,7 @@ for this feature. $ dune build --root dynamic Entering directory 'dynamic' Error: No rule found for foo + -> required by %{read:foo} at dune:3 -> required by alias default in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t b/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t index 82ac65090f6..d669dc1b78b 100644 --- a/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t +++ b/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t @@ -6,6 +6,11 @@ dune < 2.8 > EOF $ dune build bar + File "dune", line 8, characters 16-31: + 8 | (enabled_if (= %{context_name} "not-the-context-name"))) + ^^^^^^^^^^^^^^^ + Error: %{context_name} is only available since version 2.8 of the dune + language. Please update your dune-project file to have (lang dune 2.8). File "dune", line 13, characters 16-31: 13 | (enabled_if (= %{context_name} "default"))) ^^^^^^^^^^^^^^^ diff --git a/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t b/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t index cffbc03dbc6..d50af8c202b 100644 --- a/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t +++ b/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t @@ -4,5 +4,6 @@ binaries stanza. %{bin:foo} is visible on the other hand. foo alias default this is foo.exe Error: No rule found for foo.exe + -> required by %{exe:foo.exe} at dune:7 -> required by alias default in dune:5 [1] diff --git a/test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t b/test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t new file mode 100644 index 00000000000..7e0125d0108 --- /dev/null +++ b/test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t @@ -0,0 +1,20 @@ +Regression test for using %{test} in (diff ...) + +The action expander treats the second argument of diff? as "consuming +a target". Since targets needs to be known at rule creation time +rather than at rule evaluation time and dependencies are usually +evaluated at the latter stage, the bellow pattern could break if we +are not careful. We want to support it because it is a common pattern. + + $ echo '(lang dune 2.8)' > dune-project + $ cat > dune < (rule + > (alias runtest) + > (deps + > (:x test.ml)) + > (action + > (diff? %{x} %{x}.corrected))) + > EOF + $ touch test.ml + + $ dune runtest