From d959d5bfa4b2c52b2ca891ecf1e7d30d233e6bba Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 31 Jan 2024 19:30:40 -0700 Subject: [PATCH] feature: dynamic_include stanza Introduce the [dynamic_include] stanza. It's like [(include ..)], but doesn't allow us to generate static stanzas (see [Dune_file0] for what those are). Signed-off-by: Rudi Grinberg --- bin/describe/describe_external_lib_deps.ml | 2 +- bin/describe/describe_pp.ml | 10 +- bin/describe/describe_workspace.ml | 2 +- src/dune_rules/alias_rec.ml | 5 +- src/dune_rules/artifacts_db.ml | 7 +- src/dune_rules/cram/cram_rules.ml | 8 +- src/dune_rules/dir_contents.ml | 68 +++---- src/dune_rules/dir_status.ml | 24 ++- src/dune_rules/dune_file.ml | 189 +++++++++++++----- src/dune_rules/dune_file.mli | 5 +- src/dune_rules/dune_file0.ml | 2 +- src/dune_rules/dune_load.ml | 4 +- src/dune_rules/env_binaries.ml | 14 +- src/dune_rules/env_stanza_db.ml | 7 +- src/dune_rules/gen_rules.ml | 2 +- src/dune_rules/include_stanza.ml | 78 ++++++-- src/dune_rules/include_stanza.mli | 9 +- src/dune_rules/install_rules.ml | 2 +- src/dune_rules/melange/melange_rules.ml | 23 +-- src/dune_rules/packages.ml | 2 +- src/dune_rules/sites/site_env.ml | 2 +- src/dune_rules/stanzas/executables.ml | 7 +- src/dune_rules/stanzas/install_conf.ml | 4 +- src/dune_rules/stanzas/install_conf.mli | 2 +- src/dune_rules/stanzas/stanzas.ml | 20 ++ src/dune_rules/stanzas/stanzas.mli | 6 + src/dune_rules/super_context.ml | 19 +- src/dune_rules/utop.ml | 2 +- .../dynamic-include-stanza.t | 21 ++ .../forbidden-stanzas.t | 77 +++++++ .../dynamic-include-stanza/nested.t | 27 +++ 31 files changed, 473 insertions(+), 177 deletions(-) create mode 100644 test/blackbox-tests/test-cases/dynamic-include-stanza/dynamic-include-stanza.t create mode 100644 test/blackbox-tests/test-cases/dynamic-include-stanza/forbidden-stanzas.t create mode 100644 test/blackbox-tests/test-cases/dynamic-include-stanza/nested.t diff --git a/bin/describe/describe_external_lib_deps.ml b/bin/describe/describe_external_lib_deps.ml index ca9b4f6a4744..9069e3fa4ce8 100644 --- a/bin/describe/describe_external_lib_deps.ml +++ b/bin/describe/describe_external_lib_deps.ml @@ -144,7 +144,7 @@ let libs db (context : Context.t) = let* dune_files = Context.name context |> Dune_rules.Dune_load.dune_files in Memo.parallel_map dune_files ~f:(fun (dune_file : Dune_rules.Dune_file.t) -> Dune_file.stanzas dune_file - |> Memo.parallel_map ~f:(fun stanza -> + >>= Memo.parallel_map ~f:(fun stanza -> let dir = Dune_file.dir dune_file in match Stanza.repr stanza with | Dune_rules.Executables.T exes -> diff --git a/bin/describe/describe_pp.ml b/bin/describe/describe_pp.ml index d438198974cf..7109cddfc905 100644 --- a/bin/describe/describe_pp.ml +++ b/bin/describe/describe_pp.ml @@ -57,17 +57,19 @@ let get_pped_file super_context file = >>| Path.source in let* dune_file = Dune_rules.Dune_load.stanzas_in_dir (dir |> in_build_dir) in - let staged_pps = - Option.bind dune_file ~f:(fun dune_file -> + let* staged_pps = + match dune_file with + | None -> Memo.return None + | Some dune_file -> Dune_file.find_stanzas dune_file Dune_rules.Library.key - |> List.fold_left ~init:None ~f:(fun acc (lib : Dune_rules.Library.t) -> + >>| List.fold_left ~init:None ~f:(fun acc (lib : Dune_rules.Library.t) -> let preprocess = Dune_rules.Preprocess.Per_module.( lib.buildable.preprocess |> single_preprocess) in match preprocess with | Dune_rules.Preprocess.Pps ({ staged = true; _ } as pps) -> Some pps - | _ -> acc)) + | _ -> acc) in (match staged_pps with | None -> diff --git a/bin/describe/describe_workspace.ml b/bin/describe/describe_workspace.ml index 096063caa945..8f93a6ef79f1 100644 --- a/bin/describe/describe_workspace.ml +++ b/bin/describe/describe_workspace.ml @@ -536,7 +536,7 @@ module Crawl = struct their direct library dependencies *) Memo.parallel_map dune_files ~f:(fun (dune_file : Dune_file.t) -> Dune_file.stanzas dune_file - |> Memo.parallel_map ~f:(fun stanza -> + >>= Memo.parallel_map ~f:(fun stanza -> match Stanza.repr stanza with | Executables.T exes -> let dir = diff --git a/src/dune_rules/alias_rec.ml b/src/dune_rules/alias_rec.ml index ee010a36a6bc..bf719dad888e 100644 --- a/src/dune_rules/alias_rec.ml +++ b/src/dune_rules/alias_rec.ml @@ -50,9 +50,10 @@ include Alias_builder.Alias_rec (struct | None -> Action_builder.return found_in_source | Some stanzas -> let+ in_melange_target_dirs = - let melange_target_dirs = + let* melange_target_dirs = Dune_file.find_stanzas stanzas Melange_stanzas.Emit.key - |> List.map ~f:(fun mel -> + |> Action_builder.of_memo + >>| List.map ~f:(fun mel -> Melange_stanzas.Emit.target_dir ~dir:build_path mel) in Action_builder.List.map diff --git a/src/dune_rules/artifacts_db.ml b/src/dune_rules/artifacts_db.ml index 1df36b8aa826..0e3c351f6d2c 100644 --- a/src/dune_rules/artifacts_db.ml +++ b/src/dune_rules/artifacts_db.ml @@ -71,14 +71,15 @@ let get_installed_binaries ~(context : Context.t) stanzas = y) >>| Filename.Map.map ~f:Appendable_list.singleton in - Dune_file.stanzas d + Dune_file.static_stanzas d |> Memo.List.map ~f:(fun stanza -> match Stanza.repr stanza with - | Install_conf.T { section = Section Bin; files; enabled_if; _ } -> + | Install_conf.T { section = _loc, Section Bin; files; enabled_if; _ } -> let enabled_if = eval_blang ~dir enabled_if in binaries_from_install ~enabled_if files | Executables.T - ({ install_conf = Some { section = Section Bin; files; _ }; _ } as exes) -> + ({ install_conf = Some { section = _loc, Section Bin; files; _ }; _ } as exes) + -> let enabled_if = let enabled_if = eval_blang ~dir exes.enabled_if in match exes.optional with diff --git a/src/dune_rules/cram/cram_rules.ml b/src/dune_rules/cram/cram_rules.ml index 49ac72ded73c..c0adaff34a16 100644 --- a/src/dune_rules/cram/cram_rules.ml +++ b/src/dune_rules/cram/cram_rules.ml @@ -99,12 +99,12 @@ let test_rule let collect_stanzas = let stanzas dir ~f = - let+ stanzas = Dune_load.stanzas_in_dir dir in - match stanzas with - | None -> [] + Dune_load.stanzas_in_dir dir + >>= function + | None -> Memo.return [] | Some (d : Dune_file.t) -> Dune_file.find_stanzas d Cram_stanza.key - |> List.filter_map ~f:(fun c -> Option.some_if (f c) (dir, c)) + >>| List.filter_map ~f:(fun c -> Option.some_if (f c) (dir, c)) in let rec collect_whole_subtree acc dir = let* acc = diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 8e46d90d9765..fc2522e1c97b 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -128,7 +128,7 @@ let build_mlds_map stanzas ~dir ~files = |> Memo.return) in Dune_file.find_stanzas stanzas Documentation.key - |> Memo.parallel_map ~f:(fun (doc : Documentation.t) -> + >>= Memo.parallel_map ~f:(fun (doc : Documentation.t) -> let+ mlds = let+ mlds = Memo.Lazy.force mlds in Ordered_set_lang.Unordered_string.eval @@ -269,7 +269,7 @@ end = struct let+ files, rules = Rules.collect (fun () -> let src_dir = Dune_file.dir d in - load_text_files sctx st_dir stanzas ~src_dir ~dir) + stanzas >>= load_text_files sctx st_dir ~src_dir ~dir) in let dirs = [ { Source_file_dir.dir; path_to_root = []; files } ] in let ml = @@ -278,17 +278,17 @@ end = struct let loc = loc_of_dune_file st_dir in let libs = Scope.DB.find_by_dir dir >>| Scope.libs in let* expander = Super_context.expander sctx ~dir in - Ml_sources.make - stanzas - ~expander - ~dir - ~libs - ~project - ~lib_config - ~loc - ~include_subdirs - ~lookup_vlib - ~dirs) + stanzas + >>= Ml_sources.make + ~expander + ~dir + ~libs + ~project + ~lib_config + ~loc + ~include_subdirs + ~lookup_vlib + ~dirs) in { Standalone_or_root.root = { kind = Standalone @@ -299,10 +299,10 @@ end = struct ; foreign_sources = Memo.lazy_ (fun () -> let dune_version = Dune_project.dune_version project in - Memo.return (Foreign_sources.make stanzas ~dune_version ~dirs)) + stanzas >>| Foreign_sources.make ~dune_version ~dirs) ; coq = Memo.lazy_ (fun () -> - Coq_sources.of_dir stanzas ~dir ~include_subdirs ~dirs |> Memo.return) + stanzas >>| Coq_sources.of_dir ~dir ~include_subdirs ~dirs) } ; rules ; subdirs = Path.Build.Map.empty @@ -332,12 +332,12 @@ end = struct Rules.collect (fun () -> Memo.fork_and_join (fun () -> - load_text_files - sctx - source_dir - stanzas - ~src_dir:(Dune_file.dir dune_file) - ~dir) + stanzas + >>= load_text_files + sctx + source_dir + ~src_dir:(Dune_file.dir dune_file) + ~dir) (fun () -> Memo.parallel_map components @@ -362,26 +362,26 @@ end = struct let lookup_vlib = lookup_vlib sctx ~current_dir:dir in let libs = Scope.DB.find_by_dir dir >>| Scope.libs in let* expander = Super_context.expander sctx ~dir in - Ml_sources.make - stanzas - ~expander - ~dir - ~project - ~libs - ~lib_config - ~loc - ~lookup_vlib - ~include_subdirs - ~dirs) + stanzas + >>= Ml_sources.make + ~expander + ~dir + ~project + ~libs + ~lib_config + ~loc + ~lookup_vlib + ~include_subdirs + ~dirs) in let foreign_sources = Memo.lazy_ (fun () -> let dune_version = Dune_project.dune_version project in - Memo.return (Foreign_sources.make stanzas ~dune_version ~dirs)) + stanzas >>| Foreign_sources.make ~dune_version ~dirs) in let coq = Memo.lazy_ (fun () -> - Coq_sources.of_dir stanzas ~dir ~dirs ~include_subdirs |> Memo.return) + stanzas >>| Coq_sources.of_dir ~dir ~dirs ~include_subdirs) in let subdirs = List.map subdirs ~f:(fun { Source_file_dir.dir; path_to_root = _; files } -> diff --git a/src/dune_rules/dir_status.ml b/src/dune_rules/dir_status.ml index 3bb54e1782ab..77c921364866 100644 --- a/src/dune_rules/dir_status.ml +++ b/src/dune_rules/dir_status.ml @@ -144,16 +144,18 @@ end = struct | Lock_dir | Generated | Source_only _ | Standalone _ | Group_root _ -> Memo.return Appendable_list.empty | Is_component_of_a_group_but_not_the_root { stanzas; group_root = _ } -> + let* stanzas = + match stanzas with + | None -> Memo.return [] + | Some dune_file -> Dune_file.stanzas dune_file + in walk_children st_dir ~dir ~local >>| Appendable_list.( @ ) (Appendable_list.singleton { Group_component.dir ; path_to_group_root = List.rev local ; source_dir = st_dir - ; stanzas = - (match stanzas with - | None -> [] - | Some d -> Dune_file.stanzas d) + ; stanzas }) and walk_children st_dir ~dir ~local = (* TODO take account of directory targets *) @@ -170,7 +172,9 @@ end = struct ;; let has_dune_file ~dir st_dir ~build_dir_is_project_root (d : Dune_file.t) = - match get_include_subdirs (Dune_file.find_stanzas d Include_subdirs.key) with + Dune_file.find_stanzas d Include_subdirs.key + >>| get_include_subdirs + >>= function | Some (loc, Include mode) -> let components = Memo.Lazy.create (fun () -> collect_group st_dir ~dir) in Memo.return @@ -190,7 +194,8 @@ end = struct | No_group -> Memo.return @@ Standalone (st_dir, d) | Group_root group_root -> let+ () = - match find_module_stanza (Dune_file.stanzas d) with + let* stanzas = Dune_file.stanzas d in + match find_module_stanza stanzas with | None -> Memo.return () | Some loc -> get ~dir:group_root @@ -257,12 +262,15 @@ let directory_targets t ~dir = | Lock_dir | Generated | Source_only _ | Is_component_of_a_group_but_not_the_root _ -> Memo.return Path.Build.Map.empty | Standalone (_, dune_file) -> - extract_directory_targets ~dir (Dune_file.stanzas dune_file) + Dune_file.stanzas dune_file >>= extract_directory_targets ~dir | Group_root { components; dune_file; _ } -> let f ~dir stanzas acc = extract_directory_targets ~dir stanzas >>| Path.Build.Map.superpose acc in - let* init = f ~dir (Dune_file.stanzas dune_file) Path.Build.Map.empty in + let* init = + let* stanzas = Dune_file.stanzas dune_file in + f ~dir stanzas Path.Build.Map.empty + in components >>= Memo.List.fold_left ~init ~f:(fun acc { Group_component.dir; stanzas; _ } -> f ~dir stanzas acc) diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index 2d0bdfe29f38..6a1f39e5530a 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -3,11 +3,14 @@ open Import type t = { dir : Path.Source.t ; project : Dune_project.t - ; stanzas : Stanza.t list + ; stanzas : Stanza.t list Memo.Lazy.t + ; dynamic_includes : (Loc.t * string) list + ; static_stanzas : Stanza.t list } let dir t = t.dir -let stanzas t = t.stanzas +let stanzas t = Memo.Lazy.force t.stanzas +let static_stanzas t = t.static_stanzas let project t = t.project let is_promoted_rule = @@ -48,7 +51,7 @@ let parse ~file ~dir (project : Dune_project.t) sexps = let open Memo.O in let* stanzas = let context = - Include_stanza.in_file + Include_stanza.in_src_file @@ match file with | Some f -> f @@ -74,17 +77,70 @@ let parse ~file ~dir (project : Dune_project.t) sexps = stanzas ;; -let parse sexps ~dir ~file ~project = +module Mask = struct + type 'a t = + | True + | Fun of ('a -> bool) + + let combine x y = + match x, y with + | True, x -> x + | x, True -> x + | Fun f, Fun g -> Fun (fun x -> f x && g x) + ;; + + let filter_stanzas t list = + match t with + | True -> list + | Fun f -> + List.filter_map list ~f:(fun stanza -> + if f stanza + then Some stanza + else ( + match Stanza.repr stanza with + | Library.T l -> + Library_redirect.Local.of_private_lib l + |> Option.map ~f:Library_redirect.Local.make_stanza + | _ -> None)) + ;; + + let of_only_packages_mask mask = + match mask with + | None -> True + | Some visible_pkgs -> + Fun + (fun stanza -> + match Stanzas.stanza_package stanza with + | None -> true + | Some package -> + let name = Package.name package in + Package.Name.Map.mem visible_pkgs name) + ;; + + let ignore_promote project = + match !Clflags.ignore_promoted_rules with + | false -> True + | true -> + let version = Dune_project.dune_version project in + Fun (fun stanza -> not (is_promoted_rule version stanza)) + ;; +end + +let parse_stanzas sexps ~mask ~dir ~file ~project = let open Memo.O in let+ stanzas = parse ~file ~dir project sexps in - let stanzas = - if !Clflags.ignore_promoted_rules - then ( - let version = Dune_project.dune_version project in - List.filter stanzas ~f:(fun s -> not (is_promoted_rule version s))) - else stanzas - in - { dir; project; stanzas } + Mask.filter_stanzas mask stanzas +;; + +let parse sexps ~mask ~dir ~file ~project = + let open Memo.O in + let+ stanzas = parse_stanzas sexps ~mask ~dir ~file ~project in + { dir + ; project + ; static_stanzas = stanzas + ; stanzas = Memo.Lazy.of_val stanzas + ; dynamic_includes = [] + } ;; module Make_fold (M : Monad.S) = struct @@ -93,7 +149,7 @@ module Make_fold (M : Monad.S) = struct let rec fold_stanzas l ~init ~f = match l with | [] -> M.return init - | t :: l -> inner_fold t t.stanzas l ~init ~f + | t :: l -> inner_fold t t.static_stanzas l ~init ~f and inner_fold t inner_list l ~init ~f = match inner_list with @@ -111,8 +167,10 @@ let fold_stanzas t ~init ~f = Id_fold.fold_stanzas t ~init ~f let to_dyn = Dyn.opaque let find_stanzas t key = + let open Memo.O in + let+ stanzas = Memo.Lazy.force t.stanzas in (* CR-rgrinberg: save a map to represent the stanzas to make this fast. *) - List.filter_map t.stanzas ~f:(Stanza.Key.get key) + List.filter_map stanzas ~f:(Stanza.Key.get key) ;; module Jbuild_plugin : sig @@ -248,7 +306,7 @@ module Script = struct directory *) let generated_dune_files_dir = Path.Build.relative Path.Build.root ".dune" - let eval_one ~context { script = { dir; file; project }; from_parent } = + let eval_one ~mask ~context { script = { dir; file; project }; from_parent } = let generated_dune_file = Path.Build.append_source (Path.Build.relative generated_dune_files_dir (Context_name.to_string context)) @@ -288,47 +346,36 @@ module Script = struct Path.build generated_dune_file |> Io.Untracked.with_lexbuf_from_file ~f:(Dune_lang.Parser.parse ~mode:Many) |> List.rev_append from_parent - |> parse ~dir ~file:(Some file) ~project + |> parse ~mask ~dir ~file:(Some file) ~project ;; end -let filter_out_stanzas_from_hidden_packages ~visible_pkgs = - List.filter_map ~f:(fun stanza -> - let include_stanza = - match Stanzas.stanza_package stanza with - | None -> true - | Some package -> - let name = Package.name package in - Package.Name.Map.mem visible_pkgs name - in - if include_stanza - then Some stanza - else ( - match Stanza.repr stanza with - | Library.T l -> - Library_redirect.Local.of_private_lib l - |> Option.map ~f:Library_redirect.Local.make_stanza - | _ -> None)) -;; - -let filter_stanzas (mask : Only_packages.t) (dune_files : t list) = - match mask with - | None -> dune_files - | Some visible_pkgs -> - List.map dune_files ~f:(fun dune_file -> - { dune_file with - stanzas = filter_out_stanzas_from_hidden_packages ~visible_pkgs dune_file.stanzas - }) +let check_dynamic_stanza = + (* CR-rgrinberg: unfortunately this needs to kept in sync with the rules + manually *) + let err = [ Pp.text "This stanza cannot be generated dynamically" ] in + fun stanza -> + match Stanza.repr stanza with + | Install_conf.T { section = loc, Section Bin; _ } -> + User_error.raise ~loc [ Pp.text "binary section cannot be generated dynamically" ] + | Coq_stanza.Theory.T { buildable = { Coq_stanza.Buildable.loc; _ }; _ } + | Library.T { buildable = { loc; _ }; _ } + | Install_conf.T { section = _, Site { loc; _ }; _ } + | Executables.T + { buildable = { loc; _ }; install_conf = Some { section = _, Section Bin; _ }; _ } + | Deprecated_library_name.T { Library_redirect.loc; _ } + | Plugin.T { site = loc, (_, _); _ } -> User_error.raise ~loc err + | _ -> () ;; module Eval = struct - type nonrec t = + type script = | Literal of t | Script of Script.t open Memo.O - let context_independent ~dir project dune_file = + let context_independent ~mask ~dir project dune_file = let file = Dune_file0.path dune_file in let static = Dune_file0.get_static_sexp dune_file in match Dune_file0.kind dune_file with @@ -345,25 +392,65 @@ module Eval = struct ; from_parent = static }) | Plain -> - let+ stanzas = parse static ~dir ~file ~project in + let+ stanzas = parse static ~mask ~dir ~file ~project in Literal stanzas ;; - let eval dune_files (mask : Only_packages.t) = + let process_dynamic_includes dune_file = + let static_stanzas, dynamic_includes = + List.partition_map dune_file.static_stanzas ~f:(fun stanza -> + match Stanza.repr stanza with + | Stanzas.Dynamic_include.T (loc, fn) -> Right (loc, fn) + | _ -> Left stanza) + in + { dune_file with static_stanzas; dynamic_includes } + ;; + + let eval dune_files mask = + let mask = Mask.of_only_packages_mask mask in (* CR-rgrinberg: all this evaluation complexity is to share some work in multi context builds. Is it worth it? *) let+ static, dynamic = Appendable_list.to_list dune_files |> Memo.parallel_map ~f:(fun (dir, project, dune_file) -> - context_independent ~dir project dune_file) + let mask = Mask.combine mask (Mask.ignore_promote project) in + context_independent ~mask ~dir project dune_file) >>| List.partition_map ~f:(function | Literal x -> Left x | Script s -> Right s) in - let static = filter_stanzas mask static in + let static = List.map static ~f:process_dynamic_includes in fun context -> - let+ dynamic = Memo.parallel_map dynamic ~f:(Script.eval_one ~context) in - static @ filter_stanzas mask dynamic + let+ ocaml_syntax = + Memo.parallel_map dynamic ~f:(fun script -> + let mask = Mask.combine mask (Mask.ignore_promote script.script.project) in + Script.eval_one ~mask ~context script) + in + let static = + List.map static ~f:(fun t -> + let mask = Mask.combine (Mask.ignore_promote t.project) mask in + let origin = + Path.Build.append_source + (Context_name.build_dir context) + (Path.Source.relative t.dir Dune_file0.fname) + in + let dynamic_includes = + Memo.List.concat_map t.dynamic_includes ~f:(fun (loc, include_file) -> + let* ast, _ = + let context = Include_stanza.in_build_file origin in + Include_stanza.load_sexps ~context (loc, include_file) + in + parse_stanzas ast ~mask ~dir:t.dir ~file:None ~project:t.project) + in + { t with + stanzas = + Memo.lazy_ (fun () -> + let+ stanzas = dynamic_includes in + List.iter stanzas ~f:check_dynamic_stanza; + t.static_stanzas @ stanzas) + }) + in + static @ ocaml_syntax ;; end diff --git a/src/dune_rules/dune_file.mli b/src/dune_rules/dune_file.mli index c7a4b3f3cd56..8a06320e42e1 100644 --- a/src/dune_rules/dune_file.mli +++ b/src/dune_rules/dune_file.mli @@ -6,10 +6,11 @@ open Import type t val dir : t -> Path.Source.t -val stanzas : t -> Stanza.t list +val stanzas : t -> Stanza.t list Memo.t +val static_stanzas : t -> Stanza.t list val project : t -> Dune_project.t val to_dyn : t -> Dyn.t -val find_stanzas : t -> 'a Stanza.Key.t -> 'a list +val find_stanzas : t -> 'a Stanza.Key.t -> 'a list Memo.t val fold_stanzas : t list -> init:'acc -> f:(t -> Stanza.t -> 'acc -> 'acc) -> 'acc val eval diff --git a/src/dune_rules/dune_file0.ml b/src/dune_rules/dune_file0.ml index e2580b2d4a35..eac36034e38c 100644 --- a/src/dune_rules/dune_file0.ml +++ b/src/dune_rules/dune_file0.ml @@ -444,7 +444,7 @@ let decode ~file project sexps = Dune_lang.Decoder.parse d Univ_map.empty (Dune_lang.Ast.List (Loc.none, ast))) } in - let context = Include_stanza.in_file file in + let context = Include_stanza.in_src_file file in let inside_include = false in let inside_subdir = false in Ast.decode ~inside_include ~inside_subdir diff --git a/src/dune_rules/dune_load.ml b/src/dune_rules/dune_load.ml index db474abd248e..12b35781b1da 100644 --- a/src/dune_rules/dune_load.ml +++ b/src/dune_rules/dune_load.ml @@ -95,7 +95,9 @@ let load () = let packages = Only_packages.filter_packages mask packages in let projects = List.rev_map projects ~f:snd in let dune_files = - let without_ctx = Memo.lazy_ (fun () -> Dune_file.eval dune_files mask) in + let without_ctx = + Memo.lazy_ ~name:"dune-files-eval" (fun () -> Dune_file.eval dune_files mask) + in Per_context.create_by_name ~name:"dune-files" (fun ctx -> Memo.Lazy.create (fun () -> let* f = Memo.Lazy.force without_ctx in diff --git a/src/dune_rules/env_binaries.ml b/src/dune_rules/env_binaries.ml index 5de3e1631923..1839e8cb4e3d 100644 --- a/src/dune_rules/env_binaries.ml +++ b/src/dune_rules/env_binaries.ml @@ -20,13 +20,13 @@ let impl dir = >>= function | None -> Memo.return [] | Some stanzas -> - let+ profile = Per_context.profile ctx in - (match - match Dune_file.find_stanzas stanzas Dune_env.key with - | [ config ] -> Some config - | [] -> None - | _ :: _ :: _ -> assert false - with + let* profile = Per_context.profile ctx in + Dune_file.find_stanzas stanzas Dune_env.key + >>| (function + | [ config ] -> Some config + | [] -> None + | _ :: _ :: _ -> assert false) + >>| (function | None -> [] | Some stanza -> (match Dune_env.find_opt stanza ~profile with diff --git a/src/dune_rules/env_stanza_db.ml b/src/dune_rules/env_stanza_db.ml index 4f238ee019de..eef1cc43d98d 100644 --- a/src/dune_rules/env_stanza_db.ml +++ b/src/dune_rules/env_stanza_db.ml @@ -23,10 +23,11 @@ module Node = struct let in_dir ~dir = Dune_load.stanzas_in_dir dir - >>| function - | None -> None + >>= function + | None -> Memo.return None | Some stanzas -> - (match Dune_file.find_stanzas stanzas Dune_env.key with + Dune_file.find_stanzas stanzas Dune_env.key + >>| (function | [ config ] -> Some config | _ -> None) ;; diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index 50519c9eb98b..7b20ad4e9b9c 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -211,7 +211,7 @@ let define_all_alias ~dir ~project ~js_targets = let gen_rules_for_stanzas sctx dir_contents cctxs expander dune_file ~dir:ctx_dir = let src_dir = Dune_file.dir dune_file in - let stanzas = Dune_file.stanzas dune_file in + let* stanzas = Dune_file.stanzas dune_file in let* { For_stanza.merlin = merlins; cctx = cctxs; js = js_targets; source_dirs } = let* scope = Scope.DB.find_by_dir ctx_dir in For_stanza.of_stanzas diff --git a/src/dune_rules/include_stanza.ml b/src/dune_rules/include_stanza.ml index abe107fd3a77..8a53729c83cc 100644 --- a/src/dune_rules/include_stanza.ml +++ b/src/dune_rules/include_stanza.ml @@ -1,13 +1,48 @@ open Import -type context = - { current_file : Path.Source.t - ; include_stack : (Loc.t * Path.Source.t) list +module type Path = sig + type t + + val parent_exn : t -> t + val to_string_maybe_quoted : t -> string + val relative : t -> Loc.t -> Filename.t -> t + val equal : t -> t -> bool + val file_exists : t -> bool Memo.t + val with_lexbuf_from_file : t -> f:(Lexing.lexbuf -> 'a) -> 'a Memo.t +end + +module Source = struct + include Path.Source + + let relative t loc f = relative ~error_loc:loc t f + let file_exists t = Fs_memo.file_exists (In_source_dir t) + let with_lexbuf_from_file t ~f = Fs_memo.with_lexbuf_from_file (In_source_dir t) ~f +end + +module Build = struct + include Path.Build + + let relative t loc f = relative ~error_loc:loc t f + let file_exists _ = Memo.return true + + let with_lexbuf_from_file t ~f = + Build_system.with_file (Path.build t) ~f:(fun path -> + Io.Untracked.with_lexbuf_from_file path ~f) + ;; +end + +type 'a context = + { current_file : 'a + ; include_stack : (Loc.t * 'a) list + ; path : (module Path with type t = 'a) } -let in_file file = { current_file = file; include_stack = [] } +let in_file file path = { current_file = file; include_stack = []; path } +let in_src_file file = in_file file (module Source) +let in_build_file file = in_file file (module Build) -let error { current_file = file; include_stack } = +let error (type a) { current_file = (file : a); include_stack; path } = + let module Path = (val path : Path with type t = a) in let last, rest = match include_stack with | [] -> assert false @@ -15,39 +50,40 @@ let error { current_file = file; include_stack } = in let loc = fst (Option.value (List.last rest) ~default:last) in let line_loc (loc, file) = - sprintf "%s:%d" (Path.Source.to_string_maybe_quoted file) (Loc.start loc).pos_lnum + sprintf "%s:%d" (Path.to_string_maybe_quoted file) (Loc.start loc).pos_lnum in User_error.raise ~loc [ Pp.text "Recursive inclusion of dune files detected:" ; Pp.textf "File %s is included from %s" - (Path.Source.to_string_maybe_quoted file) + (Path.to_string_maybe_quoted file) (line_loc last) ; Pp.chain rest ~f:(fun x -> Pp.textf "included from %s" (line_loc x)) ] ;; -let load_sexps ~context:{ current_file; include_stack } (loc, fn) = +let load_sexps + (type a) + ~context:({ current_file; include_stack; path } as context) + (loc, fn) + = + let module Path = (val path : Path with type t = a) in let include_stack = (loc, current_file) :: include_stack in - let dir = Path.Source.parent_exn current_file in - let current_file = Path.Source.relative ~error_loc:loc dir fn in + let dir = Path.parent_exn current_file in + let current_file = Path.relative dir loc fn in let open Memo.O in - let* exists = Fs_memo.file_exists (In_source_dir current_file) in + let* exists = Path.file_exists current_file in if not exists then User_error.raise ~loc - [ Pp.textf - "File %s doesn't exist." - (Path.Source.to_string_maybe_quoted current_file) - ]; - if List.exists include_stack ~f:(fun (_, f) -> Path.Source.equal f current_file) - then error { current_file; include_stack }; + [ Pp.textf "File %s doesn't exist." (Path.to_string_maybe_quoted current_file) ]; + let context = { context with current_file; include_stack } in + if List.exists include_stack ~f:(fun (_, f) -> Path.equal f current_file) + then error context; let+ sexps = - Fs_memo.with_lexbuf_from_file - (In_source_dir current_file) - ~f:(Dune_lang.Parser.parse ~mode:Many) + Path.with_lexbuf_from_file current_file ~f:(Dune_lang.Parser.parse ~mode:Many) in - sexps, { current_file; include_stack } + sexps, context ;; diff --git a/src/dune_rules/include_stanza.mli b/src/dune_rules/include_stanza.mli index fb12546b954e..925037fc64d4 100644 --- a/src/dune_rules/include_stanza.mli +++ b/src/dune_rules/include_stanza.mli @@ -1,10 +1,11 @@ open Import -type context +type 'a context -val in_file : Path.Source.t -> context +val in_src_file : Path.Source.t -> Path.Source.t context +val in_build_file : Path.Build.t -> Path.Build.t context val load_sexps - : context:context + : context:'a context -> Loc.t * string - -> (Dune_lang.Ast.t list * context) Memo.t + -> (Dune_lang.Ast.t list * 'a context) Memo.t diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 530add899dab..30bdc13be376 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -397,7 +397,7 @@ end = struct fun fb ~kind -> let src = File_binding.Expanded.src fb in let dst = File_binding.Expanded.dst fb in - Install_entry_with_site.make_with_site ?dst ~kind i.section section src + Install_entry_with_site.make_with_site ?dst ~kind (snd i.section) section src in let+ files = let* files_expanded = diff --git a/src/dune_rules/melange/melange_rules.ml b/src/dune_rules/melange/melange_rules.ml index f0bfd1f1d9f1..8951106575e7 100644 --- a/src/dune_rules/melange/melange_rules.ml +++ b/src/dune_rules/melange/melange_rules.ml @@ -576,12 +576,11 @@ let rec under_melange_emit_target ~dir = >>= (function | None -> under_melange_emit_target ~dir:parent | Some stanzas -> - (match - Dune_file.find_stanzas stanzas Melange_stanzas.Emit.key - |> List.find_map ~f:(fun mel -> - let target_dir = Melange_stanzas.Emit.target_dir ~dir:parent mel in - Option.some_if (Path.Build.equal target_dir dir) mel) - with + Dune_file.find_stanzas stanzas Melange_stanzas.Emit.key + >>| List.find_map ~f:(fun mel -> + let target_dir = Melange_stanzas.Emit.target_dir ~dir:parent mel in + Option.some_if (Path.Build.equal target_dir dir) mel) + >>= (function | None -> under_melange_emit_target ~dir:parent | Some stanza -> Memo.return @@ Some { stanza_dir = parent; stanza })) ;; @@ -638,14 +637,14 @@ let setup_emit_js_rules sctx ~dir = | None -> (* this should probably be handled by [Dir_status] *) Dune_load.stanzas_in_dir dir - >>| (function - | None -> Gen_rules.no_rules + >>= (function + | None -> Memo.return Gen_rules.no_rules | Some dune_file -> - let build_dir_only_sub_dirs = + let+ build_dir_only_sub_dirs = Dune_file.find_stanzas dune_file Melange_stanzas.Emit.key - |> List.map ~f:(fun (mel : Melange_stanzas.Emit.t) -> mel.target) - |> Subdir_set.of_list - |> Gen_rules.Build_only_sub_dirs.singleton ~dir + >>| List.map ~f:(fun (mel : Melange_stanzas.Emit.t) -> mel.target) + >>| Subdir_set.of_list + >>| Gen_rules.Build_only_sub_dirs.singleton ~dir in Gen_rules.make ~build_dir_only_sub_dirs (Memo.return Rules.empty)) ;; diff --git a/src/dune_rules/packages.ml b/src/dune_rules/packages.ml index 1ec164d02480..d7f1d3766111 100644 --- a/src/dune_rules/packages.ml +++ b/src/dune_rules/packages.ml @@ -14,7 +14,7 @@ let mlds_by_package_def = |> Dune_load.dune_files >>= Memo.parallel_map ~f:(fun dune_file -> Dune_file.stanzas dune_file - |> Memo.parallel_map ~f:(fun stanza -> + >>= Memo.parallel_map ~f:(fun stanza -> match Stanza.repr stanza with | Documentation.T d -> let+ mlds = diff --git a/src/dune_rules/sites/site_env.ml b/src/dune_rules/sites/site_env.ml index de738c80ba54..9eeda24ae5f5 100644 --- a/src/dune_rules/sites/site_env.ml +++ b/src/dune_rules/sites/site_env.ml @@ -66,7 +66,7 @@ let add_packages_env context ~base stanzas packages = add_in_package_section acc pkg_name section in match Stanza.repr stanza with - | Install_conf.T { section = Site { pkg; site; loc }; _ } -> + | Install_conf.T { section = _loc, Site { pkg; site; loc }; _ } -> add_in_package_sites pkg site loc | Plugin.T { site = loc, (pkg, site); _ } -> add_in_package_sites pkg site loc | _ -> Memo.return acc) diff --git a/src/dune_rules/stanzas/executables.ml b/src/dune_rules/stanzas/executables.ml index cef59448c06f..d59d75f1fe80 100644 --- a/src/dune_rules/stanzas/executables.ml +++ b/src/dune_rules/stanzas/executables.ml @@ -181,7 +181,12 @@ end = struct ~dir:(Some dir)))) |> List.filter_opt in - { Install_conf.section = Section Bin + let loc = + match public_names with + | [] -> assert false + | (loc, _) :: _ -> loc + in + { Install_conf.section = loc, Section Bin ; files ; dirs = [] ; package diff --git a/src/dune_rules/stanzas/install_conf.ml b/src/dune_rules/stanzas/install_conf.ml index bd8eccc760cd..0545597cd46e 100644 --- a/src/dune_rules/stanzas/install_conf.ml +++ b/src/dune_rules/stanzas/install_conf.ml @@ -1,7 +1,7 @@ open Import type t = - { section : Section_with_site.t + { section : Loc.t * Section_with_site.t ; files : Install_entry.File.t list ; dirs : Install_entry.Dir.t list ; source_trees : Install_entry.Dir.t list @@ -19,7 +19,7 @@ let decode = let open Dune_lang.Decoder in fields (let+ loc = loc - and+ section = field "section" Section_with_site.decode + and+ section = field "section" (located Section_with_site.decode) and+ files = field_o "files" (repeat Install_entry.File.decode) and+ dirs = field_o diff --git a/src/dune_rules/stanzas/install_conf.mli b/src/dune_rules/stanzas/install_conf.mli index fb21a8f06f44..c13592783669 100644 --- a/src/dune_rules/stanzas/install_conf.mli +++ b/src/dune_rules/stanzas/install_conf.mli @@ -1,7 +1,7 @@ open Import type t = - { section : Section_with_site.t + { section : Loc.t * Section_with_site.t ; files : Install_entry.File.t list ; dirs : Install_entry.Dir.t list ; source_trees : Install_entry.Dir.t list diff --git a/src/dune_rules/stanzas/stanzas.ml b/src/dune_rules/stanzas/stanzas.ml index 5e2311bc80eb..601f68b46bc4 100644 --- a/src/dune_rules/stanzas/stanzas.ml +++ b/src/dune_rules/stanzas/stanzas.ml @@ -15,6 +15,22 @@ let () = module Include = struct type t = Loc.t * string + let decode = + let+ loc = loc + and+ fn = relative_file in + loc, fn + ;; + + include Stanza.Make (struct + type nonrec t = t + + include Poly + end) +end + +module Dynamic_include = struct + type t = Include.t + include Stanza.Make (struct type nonrec t = t @@ -117,6 +133,10 @@ let stanzas : constructors = , let+ () = Dune_lang.Syntax.since Stanza.syntax (2, 0) and+ t = Deprecated_library_name.decode in [ Deprecated_library_name.make_stanza t ] ) + ; ( "dynamic_include" + , let+ () = Dune_lang.Syntax.since Stanza.syntax (3, 14) + and+ include_ = Include.decode in + [ Dynamic_include.make_stanza include_ ] ) ] ] |> List.concat diff --git a/src/dune_rules/stanzas/stanzas.mli b/src/dune_rules/stanzas/stanzas.mli index 102fa5c1f4ac..af37e774256e 100644 --- a/src/dune_rules/stanzas/stanzas.mli +++ b/src/dune_rules/stanzas/stanzas.mli @@ -6,6 +6,12 @@ module Include : sig include Stanza.S with type t := t end +module Dynamic_include : sig + type t = Include.t + + include Stanza.S with type t := t +end + val stanza_package : Stanza.t -> Package.t option (** [of_ast project ast] is the list of [Stanza.t]s derived from decoding the diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index da008787f4d8..8214555a484c 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -94,15 +94,16 @@ end = struct let get_env_stanza ~dir = let open Memo.O in - let+ stanzas = Dune_load.stanzas_in_dir dir in - Option.value ~default:Dune_env.empty - @@ - let open Option.O in - let* stanzas = stanzas in - match Dune_file.find_stanzas stanzas Dune_env.key with - | [] -> None - | [ x ] -> Some x - | _ :: _ -> assert false + Dune_load.stanzas_in_dir dir + >>= (function + | None -> Memo.return None + | Some dune_file -> + Dune_file.find_stanzas dune_file Dune_env.key + >>| (function + | [] -> None + | [ x ] -> Some x + | _ :: _ -> assert false)) + >>| Option.value ~default:Dune_env.empty ;; let get_impl t dir = diff --git a/src/dune_rules/utop.ml b/src/dune_rules/utop.ml index 729b7630aea2..178b309e2a5a 100644 --- a/src/dune_rules/utop.ml +++ b/src/dune_rules/utop.ml @@ -128,7 +128,7 @@ let libs_and_ppx_under_dir sctx ~db ~dir = | None -> Memo.return Libs_and_ppxs.empty | Some (d : Dune_file.t) -> Dune_file.stanzas d - |> Memo.List.fold_left ~init:Libs_and_ppxs.empty ~f:(add_stanza db ~dir)) + >>= Memo.List.fold_left ~init:Libs_and_ppxs.empty ~f:(add_stanza db ~dir)) in Appendable_list.to_list libs, Appendable_list.to_list pps ;; diff --git a/test/blackbox-tests/test-cases/dynamic-include-stanza/dynamic-include-stanza.t b/test/blackbox-tests/test-cases/dynamic-include-stanza/dynamic-include-stanza.t new file mode 100644 index 000000000000..2f4b895a78d0 --- /dev/null +++ b/test/blackbox-tests/test-cases/dynamic-include-stanza/dynamic-include-stanza.t @@ -0,0 +1,21 @@ +Demonstrate that we can load dynamically generated rules + + $ cat >dune-project < (lang dune 3.14) + > EOF + + $ mkdir a b + + $ cat >a/dune < (rule + > (with-stdout-to dune.inc + > (echo "(rule (with-stdout-to foo (echo dynamic)))"))) + > EOF + + $ dune build a/dune.inc + + $ cat >b/dune < (dynamic_include ../a/dune.inc) + > EOF + + $ dune build b/foo diff --git a/test/blackbox-tests/test-cases/dynamic-include-stanza/forbidden-stanzas.t b/test/blackbox-tests/test-cases/dynamic-include-stanza/forbidden-stanzas.t new file mode 100644 index 000000000000..4f9ede96f583 --- /dev/null +++ b/test/blackbox-tests/test-cases/dynamic-include-stanza/forbidden-stanzas.t @@ -0,0 +1,77 @@ +Some stanzas aren't allowed to be generated: + + $ cat >dune-project < (lang dune 3.14) + > (using dune_site 0.1) + > (package (name foo)) + > EOF + + $ mkdir a b + + $ cat >b/dune < (dynamic_include ../a/dune.inc) + > (rule (with-stdout-to x (echo ""))) + > EOF + + $ cat >a/dune < (copy_files ../dune.inc) + > EOF + + $ runtest() { + > cat >dune.inc + > dune build b/x + > } + + $ runtest < (library (name foo)) + > EOF + File "_build/default/a/dune.inc", line 1, characters 0-20: + 1 | (library (name foo)) + ^^^^^^^^^^^^^^^^^^^^ + Error: This stanza cannot be generated dynamically + [1] + + $ runtest < (install + > (section bin) + > (files foo as bar)) + > EOF + File "_build/default/a/dune.inc", line 2, characters 10-13: + 2 | (section bin) + ^^^ + Error: binary section cannot be generated dynamically + [1] + + $ runtest < (executable + > (public_name foo)) + > EOF + File "_build/default/a/dune.inc", line 1, characters 0-31: + 1 | (executable + 2 | (public_name foo)) + Error: This stanza cannot be generated dynamically + [1] + + $ runtest < (plugin + > (libraries) + > (name foo) + > (site (foo bar))) + > EOF + File "_build/default/a/dune.inc", line 4, characters 7-16: + 4 | (site (foo bar))) + ^^^^^^^^^ + Error: This stanza cannot be generated dynamically + [1] + + $ runtest < (deprecated_library_name + > (old_public_name foo) + > (new_public_name y)) + > EOF + File "_build/default/a/dune.inc", line 1, characters 0-69: + 1 | (deprecated_library_name + 2 | (old_public_name foo) + 3 | (new_public_name y)) + Error: This stanza cannot be generated dynamically + [1] diff --git a/test/blackbox-tests/test-cases/dynamic-include-stanza/nested.t b/test/blackbox-tests/test-cases/dynamic-include-stanza/nested.t new file mode 100644 index 000000000000..c5b61763d25b --- /dev/null +++ b/test/blackbox-tests/test-cases/dynamic-include-stanza/nested.t @@ -0,0 +1,27 @@ +Nesting of dynamic_include stanzas + + $ mkdir a b c + + $ cat >dune-project < (lang dune 3.14) + > EOF + + $ cat >a/dune < (dynamic_include ../b/dune.inc) + > EOF + + $ cat >b/dune.inc < (rule + > (with-stdout-to dune.inc + > (echo "(dynamic_include ../c/dune.inc)"))) + > EOF + + $ cat >c/dune.inc < (rule + > (with-stdout-to dune.inc + > (echo "(rule (with-stdout-to foo (echo bar)))"))) + > EOF + + $ dune build a/foo + Error: Don't know how to build a/foo + [1]