diff --git a/CHANGES.md b/CHANGES.md index 1251f2de74b..a784c650b60 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -23,6 +23,8 @@ Unreleased - Do not pass include directories containing native objects when compiling bytecode (#4200, @nojb) +- Detect unknown variables more eagerly (#4184, @jeremiedimino) + 2.8.2 (21/01/2021) ------------------ diff --git a/bin/arg.ml b/bin/arg.ml index b00b2a9b020..772e31e9ca9 100644 --- a/bin/arg.ml +++ b/bin/arg.ml @@ -57,7 +57,9 @@ module Dep = struct let dep_parser = Dune_lang.Syntax.set Stanza.syntax (Active Stanza.latest_version) - Dep_conf.decode + (String_with_vars.set_decoding_env + (Pform.Env.initial Stanza.latest_version) + Dep_conf.decode) let parser s = match parse_alias s with diff --git a/bin/top.ml b/bin/top.ml index 9d74f0e690c..94372751ba6 100644 --- a/bin/top.ml +++ b/bin/top.ml @@ -57,8 +57,8 @@ let term = let files_to_load = List.filter files ~f:(fun p -> let ext = Path.extension p in - ext = Dune_rules.Mode.compiled_lib_ext Byte - || ext = Dune_rules.Cm_kind.ext Cmo) + ext = Dune_engine.Mode.compiled_lib_ext Byte + || ext = Dune_engine.Cm_kind.ext Cmo) in Dune_rules.Toplevel.print_toplevel_init_file ~include_paths ~files_to_load; Fiber.return ()) diff --git a/src/dune_engine/action.ml b/src/dune_engine/action.ml index 16287fb68fb..9319a8ba8f2 100644 --- a/src/dune_engine/action.ml +++ b/src/dune_engine/action.ml @@ -14,13 +14,15 @@ module Prog = struct let create ?hint ~context ~program ~loc () = { hint; context; program; loc } - let raise { context; program; hint; loc } = + let user_message { context; program; hint; loc } = let hint = match program with | "refmt" -> Some (Option.value ~default:"opam install reason" hint) | _ -> hint in - Utils.program_not_found ?hint ~loc ~context program + Utils.program_not_found_message ?hint ~loc ~context program + + let raise t = raise (User_error.E (user_message t)) let to_dyn { context; program; hint; loc = _ } = let open Dyn.Encoder in diff --git a/src/dune_engine/action.mli b/src/dune_engine/action.mli index e96d9986877..32e8b90039e 100644 --- a/src/dune_engine/action.mli +++ b/src/dune_engine/action.mli @@ -31,6 +31,8 @@ module Prog : sig -> t val raise : t -> _ + + val user_message : t -> User_message.t end type t = (Path.t, Not_found.t) result diff --git a/src/dune_engine/action_dune_lang.ml b/src/dune_engine/action_dune_lang.ml index 7728c49f1b8..6830399af87 100644 --- a/src/dune_engine/action_dune_lang.ml +++ b/src/dune_engine/action_dune_lang.ml @@ -11,7 +11,7 @@ type target = String_with_vars.t module String_with_vars = struct include String_with_vars - let is_dev_null = String_with_vars.is_var ~name:"null" + let is_dev_null t = String_with_vars.is_pform t (Var Dev_null) end module type Uast = diff --git a/src/dune_rules/cm_kind.ml b/src/dune_engine/cm_kind.ml similarity index 97% rename from src/dune_rules/cm_kind.ml rename to src/dune_engine/cm_kind.ml index aa78ab41546..06f8f92beff 100644 --- a/src/dune_rules/cm_kind.ml +++ b/src/dune_engine/cm_kind.ml @@ -1,4 +1,3 @@ -open! Dune_engine open Import type t = diff --git a/src/dune_rules/cm_kind.mli b/src/dune_engine/cm_kind.mli similarity index 95% rename from src/dune_rules/cm_kind.mli rename to src/dune_engine/cm_kind.mli index 72efa70c4e9..2b00538453f 100644 --- a/src/dune_rules/cm_kind.mli +++ b/src/dune_engine/cm_kind.mli @@ -1,4 +1,3 @@ -open! Dune_engine open Import type t = diff --git a/src/dune_engine/config.ml b/src/dune_engine/config.ml index f41e7ecd9dd..71d2c72eba7 100644 --- a/src/dune_engine/config.ml +++ b/src/dune_engine/config.ml @@ -313,7 +313,9 @@ end) let () = Lang.register syntax () -let load_config_file p = load_exn p ~f:(fun _lang -> decode) +let load_config_file p = + load_exn p ~f:(fun lang -> + String_with_vars.set_decoding_env (Pform.Env.initial lang.version) decode) let load_user_config_file () = if Path.exists user_config_file then diff --git a/src/dune_engine/dialect.ml b/src/dune_engine/dialect.ml index 55c39a95ded..03a7ee76831 100644 --- a/src/dune_engine/dialect.ml +++ b/src/dune_engine/dialect.ml @@ -80,11 +80,11 @@ let ocaml = in let module S = String_with_vars in Action_dune_lang.chdir - (S.make_var Loc.none "workspace_root") + (S.make_pform Loc.none (Var Workspace_root)) (Action_dune_lang.run (S.make_text Loc.none "ocamlformat") [ S.make_text Loc.none (flag_of_kind kind) - ; S.make_var Loc.none "input-file" + ; S.make_pform Loc.none (Var Input_file) ]) in let file_kind kind extension = @@ -110,13 +110,13 @@ let reason = (S.make_text Loc.none "refmt") [ S.make_text Loc.none "--print" ; S.make_text Loc.none "binary" - ; S.make_var Loc.none "input-file" + ; S.make_pform Loc.none (Var Input_file) ] in let format = Action_dune_lang.run (S.make_text Loc.none "refmt") - [ S.make_var Loc.none "input-file" ] + [ S.make_pform Loc.none (Var Input_file) ] in { File_kind.kind ; extension diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index 57d556738ae..585dac53324 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -52,3 +52,6 @@ module Hooks = Hooks module Promotion = Promotion module Cached_digest = Cached_digest module Report_error = Report_error +module Pform = Pform +module Cm_kind = Cm_kind +module Mode = Mode diff --git a/src/dune_engine/dune_project.ml b/src/dune_engine/dune_project.ml index cf3239e8e6d..03471ae43de 100644 --- a/src/dune_engine/dune_project.ml +++ b/src/dune_engine/dune_project.ml @@ -485,6 +485,10 @@ let interpret_lang_and_extensions ~(lang : Lang.Instance.t) ~explicit_extensions (Dune_lang.Syntax.key lang.syntax) (Active lang.version) in + let init = + Univ_map.set init String_with_vars.decoding_env_key + (Pform.Env.initial lang.version) + in List.fold_left extensions ~init ~f:(fun acc ((ext : Extension.automatic), _) -> let syntax = @@ -662,235 +666,241 @@ end let anonymous ~dir = infer ~dir Package.Name.Map.empty let parse ~dir ~lang ~opam_packages ~file ~dir_status = - fields - (let+ name = field_o "name" Name.decode - and+ version = field_o "version" string - and+ info = Package.Info.decode () - and+ packages = multi_field "package" (Package.decode ~dir) - and+ explicit_extensions = - multi_field "using" - (let+ loc = loc - and+ name = located string - and+ ver = located Dune_lang.Syntax.Version.decode - and+ parse_args = capture in - (* We don't parse the arguments quite yet as we want to set the - version of extensions before parsing them. *) - Extension.instantiate ~dune_lang_ver:lang.Lang.Instance.version ~loc - ~parse_args name ver) - and+ implicit_transitive_deps = - field_o_b "implicit_transitive_deps" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 7)) - and+ wrapped_executables = - field_o_b "wrapped_executables" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) - and+ _allow_approx_merlin = - (* TODO DUNE3 remove this field from parsing *) - let+ loc = loc - and+ f = - field_o_b "allow_approximate_merlin" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 9)) - in - let vendored = - match dir_status with - | Sub_dirs.Status.Vendored -> true - | _ -> false - in - if - Option.is_some f - && Dune_lang.Syntax.Version.Infix.(lang.version >= (2, 8)) - && not vendored - then - Dune_lang.Syntax.Warning.deprecated_in - ~extra_info: - "It is useless since the Merlin configurations are not ambiguous \ - anymore." - loc lang.syntax (2, 8) ~what:"This field" - and+ executables_implicit_empty_intf = - field_o_b "executables_implicit_empty_intf" - ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 9)) - and+ () = Dune_lang.Versioned_file.no_more_lang - and+ generate_opam_files = - field_o_b "generate_opam_files" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 10)) - and+ use_standard_c_and_cxx_flags = - field_o_b "use_standard_c_and_cxx_flags" - ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 8)) - and+ dialects = - multi_field "dialect" - ( Dune_lang.Syntax.since Stanza.syntax (1, 11) - >>> located Dialect.decode ) - and+ explicit_js_mode = - field_o_b "explicit_js_mode" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) - and+ format_config = Format_config.field ~since:(2, 0) - and+ strict_package_deps = - field_o_b "strict_package_deps" - ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 3)) - and+ cram = - Toggle.field "cram" ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 7)) - in - let packages = - if List.is_empty packages then - Package.Name.Map.map opam_packages ~f:(fun (_loc, p) -> Lazy.force p) - else ( - ( match (packages, name) with - | [ p ], Some (Named name) -> - if Package.Name.to_string (Package.name p) <> name then - User_error.raise ~loc:p.loc - [ Pp.textf - "when a single package is defined, it must have the same \ - name as the project name: %s" - name - ] - | _, _ -> () ); - let package_defined_twice name loc1 loc2 = - User_error.raise - [ Pp.textf "Package name %s is defined twice:" - (Package.Name.to_string name) - ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) - ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) - ] - in - let deprecated_package_names = - List.fold_left packages ~init:Package.Name.Map.empty - ~f:(fun acc { Package.deprecated_package_names; _ } -> - Package.Name.Map.union acc deprecated_package_names - ~f:package_defined_twice) - in - List.iter packages ~f:(fun p -> - let name = Package.name p in - match Package.Name.Map.find deprecated_package_names name with - | None -> () - | Some loc -> package_defined_twice name loc p.loc); - match - Package.Name.Map.of_list_map packages ~f:(fun p -> - (Package.name p, p)) - with - | Error (_, _, p) -> - let name = Package.name p in - User_error.raise ~loc:p.loc - [ Pp.textf "package %s is already defined" - (Package.Name.to_string name) - ] - | Ok packages -> - Package.Name.Map.merge packages opam_packages - ~f:(fun _name dune opam -> - match (dune, opam) with - | _, None -> dune - | Some p, Some _ -> Some { p with has_opam_file = true } - | None, Some (loc, _) -> - User_error.raise ~loc - [ Pp.text - "This opam file doesn't have a corresponding (package \ - ...) stanza in the dune-project_file. Since you have \ - at least one other (package ...) stanza in your \ - dune-project file, you must a (package ...) stanza for \ - each opam package in your project." - ]) - ) - in - let packages = - Package.Name.Map.map packages ~f:(fun p -> - let info = Package.Info.superpose info p.info in - let version = - match p.version with - | Some _ as v -> v - | None -> version - in - { p with version; info }) - in - let name = - match name with - | Some n -> n - | None -> default_name ~dir ~packages - in - let project_file : Project_file.t = - { file; exists = true; project_name = name } - in - let parsing_context, stanza_parser, extension_args = - interpret_lang_and_extensions ~lang ~explicit_extensions ~project_file - in - let implicit_transitive_deps = - Option.value implicit_transitive_deps - ~default:(implicit_transitive_deps_default ~lang) - in - let wrapped_executables = - Option.value wrapped_executables - ~default:(wrapped_executables_default ~lang) - in - let executables_implicit_empty_intf = - Option.value executables_implicit_empty_intf - ~default:(executables_implicit_empty_intf_default ~lang) - in - let strict_package_deps = - Option.value strict_package_deps - ~default:(strict_package_deps_default ~lang) - in - let dune_version = lang.version in - let explicit_js_mode = - Option.value explicit_js_mode ~default:(explicit_js_mode_default ~lang) - in - let generate_opam_files = - Option.value ~default:false generate_opam_files - in - let use_standard_c_and_cxx_flags = - match use_standard_c_and_cxx_flags with - | None when dune_version >= (3, 0) -> Some false - | None -> None - | some -> some - in - let cram = - match cram with - | None -> false - | Some t -> Toggle.enabled t - in - let root = dir in - let file_key = File_key.make ~name ~root in - let dialects = - List.fold_left - ~f:(fun dialects (loc, dialect) -> - Dialect.DB.add dialects ~loc dialect) - ~init:Dialect.DB.builtin dialects - in - let () = - match name with - | Named _ -> () - | Anonymous _ -> - if - dune_version >= (2, 8) - && generate_opam_files - && dir_status = Sub_dirs.Status.Normal - then - let loc = Loc.in_file (Path.source file) in - User_warning.emit ~loc - [ Pp.text - "Project name is not specified. Add a (name ) \ - field to your dune-project file to make sure that $ dune \ - subst works in release or pinned builds" - ] - in - { name - ; file_key - ; root - ; version - ; info - ; packages - ; stanza_parser - ; project_file - ; extension_args - ; parsing_context - ; implicit_transitive_deps - ; wrapped_executables - ; executables_implicit_empty_intf - ; dune_version - ; generate_opam_files - ; use_standard_c_and_cxx_flags - ; dialects - ; explicit_js_mode - ; format_config - ; strict_package_deps - ; cram - }) + String_with_vars.set_decoding_env + (Pform.Env.initial lang.Lang.Instance.version) + (fields + (let+ name = field_o "name" Name.decode + and+ version = field_o "version" string + and+ info = Package.Info.decode () + and+ packages = multi_field "package" (Package.decode ~dir) + and+ explicit_extensions = + multi_field "using" + (let+ loc = loc + and+ name = located string + and+ ver = located Dune_lang.Syntax.Version.decode + and+ parse_args = capture in + (* We don't parse the arguments quite yet as we want to set the + version of extensions before parsing them. *) + Extension.instantiate ~dune_lang_ver:lang.Lang.Instance.version + ~loc ~parse_args name ver) + and+ implicit_transitive_deps = + field_o_b "implicit_transitive_deps" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 7)) + and+ wrapped_executables = + field_o_b "wrapped_executables" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) + and+ _allow_approx_merlin = + (* TODO DUNE3 remove this field from parsing *) + let+ loc = loc + and+ f = + field_o_b "allow_approximate_merlin" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 9)) + in + let vendored = + match dir_status with + | Sub_dirs.Status.Vendored -> true + | _ -> false + in + if + Option.is_some f + && Dune_lang.Syntax.Version.Infix.(lang.version >= (2, 8)) + && not vendored + then + Dune_lang.Syntax.Warning.deprecated_in + ~extra_info: + "It is useless since the Merlin configurations are not \ + ambiguous anymore." + loc lang.syntax (2, 8) ~what:"This field" + and+ executables_implicit_empty_intf = + field_o_b "executables_implicit_empty_intf" + ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 9)) + and+ () = Dune_lang.Versioned_file.no_more_lang + and+ generate_opam_files = + field_o_b "generate_opam_files" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 10)) + and+ use_standard_c_and_cxx_flags = + field_o_b "use_standard_c_and_cxx_flags" + ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 8)) + and+ dialects = + multi_field "dialect" + ( Dune_lang.Syntax.since Stanza.syntax (1, 11) + >>> located Dialect.decode ) + and+ explicit_js_mode = + field_o_b "explicit_js_mode" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) + and+ format_config = Format_config.field ~since:(2, 0) + and+ strict_package_deps = + field_o_b "strict_package_deps" + ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 3)) + and+ cram = + Toggle.field "cram" + ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 7)) + in + let packages = + if List.is_empty packages then + Package.Name.Map.map opam_packages ~f:(fun (_loc, p) -> + Lazy.force p) + else ( + ( match (packages, name) with + | [ p ], Some (Named name) -> + if Package.Name.to_string (Package.name p) <> name then + User_error.raise ~loc:p.loc + [ Pp.textf + "when a single package is defined, it must have the same \ + name as the project name: %s" + name + ] + | _, _ -> () ); + let package_defined_twice name loc1 loc2 = + User_error.raise + [ Pp.textf "Package name %s is defined twice:" + (Package.Name.to_string name) + ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) + ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) + ] + in + let deprecated_package_names = + List.fold_left packages ~init:Package.Name.Map.empty + ~f:(fun acc { Package.deprecated_package_names; _ } -> + Package.Name.Map.union acc deprecated_package_names + ~f:package_defined_twice) + in + List.iter packages ~f:(fun p -> + let name = Package.name p in + match Package.Name.Map.find deprecated_package_names name with + | None -> () + | Some loc -> package_defined_twice name loc p.loc); + match + Package.Name.Map.of_list_map packages ~f:(fun p -> + (Package.name p, p)) + with + | Error (_, _, p) -> + let name = Package.name p in + User_error.raise ~loc:p.loc + [ Pp.textf "package %s is already defined" + (Package.Name.to_string name) + ] + | Ok packages -> + Package.Name.Map.merge packages opam_packages + ~f:(fun _name dune opam -> + match (dune, opam) with + | _, None -> dune + | Some p, Some _ -> Some { p with has_opam_file = true } + | None, Some (loc, _) -> + User_error.raise ~loc + [ Pp.text + "This opam file doesn't have a corresponding \ + (package ...) stanza in the dune-project_file. \ + Since you have at least one other (package ...) \ + stanza in your dune-project file, you must a \ + (package ...) stanza for each opam package in your \ + project." + ]) + ) + in + let packages = + Package.Name.Map.map packages ~f:(fun p -> + let info = Package.Info.superpose info p.info in + let version = + match p.version with + | Some _ as v -> v + | None -> version + in + { p with version; info }) + in + let name = + match name with + | Some n -> n + | None -> default_name ~dir ~packages + in + let project_file : Project_file.t = + { file; exists = true; project_name = name } + in + let parsing_context, stanza_parser, extension_args = + interpret_lang_and_extensions ~lang ~explicit_extensions ~project_file + in + let implicit_transitive_deps = + Option.value implicit_transitive_deps + ~default:(implicit_transitive_deps_default ~lang) + in + let wrapped_executables = + Option.value wrapped_executables + ~default:(wrapped_executables_default ~lang) + in + let executables_implicit_empty_intf = + Option.value executables_implicit_empty_intf + ~default:(executables_implicit_empty_intf_default ~lang) + in + let strict_package_deps = + Option.value strict_package_deps + ~default:(strict_package_deps_default ~lang) + in + let dune_version = lang.version in + let explicit_js_mode = + Option.value explicit_js_mode + ~default:(explicit_js_mode_default ~lang) + in + let generate_opam_files = + Option.value ~default:false generate_opam_files + in + let use_standard_c_and_cxx_flags = + match use_standard_c_and_cxx_flags with + | None when dune_version >= (3, 0) -> Some false + | None -> None + | some -> some + in + let cram = + match cram with + | None -> false + | Some t -> Toggle.enabled t + in + let root = dir in + let file_key = File_key.make ~name ~root in + let dialects = + List.fold_left + ~f:(fun dialects (loc, dialect) -> + Dialect.DB.add dialects ~loc dialect) + ~init:Dialect.DB.builtin dialects + in + let () = + match name with + | Named _ -> () + | Anonymous _ -> + if + dune_version >= (2, 8) + && generate_opam_files + && dir_status = Sub_dirs.Status.Normal + then + let loc = Loc.in_file (Path.source file) in + User_warning.emit ~loc + [ Pp.text + "Project name is not specified. Add a (name \ + ) field to your dune-project file to make \ + sure that $ dune subst works in release or pinned builds" + ] + in + { name + ; file_key + ; root + ; version + ; info + ; packages + ; stanza_parser + ; project_file + ; extension_args + ; parsing_context + ; implicit_transitive_deps + ; wrapped_executables + ; executables_implicit_empty_intf + ; dune_version + ; generate_opam_files + ; use_standard_c_and_cxx_flags + ; dialects + ; explicit_js_mode + ; format_config + ; strict_package_deps + ; cram + })) let load_dune_project ~dir opam_packages ~dir_status = let file = Path.Source.relative dir filename in diff --git a/src/dune_engine/install.ml b/src/dune_engine/install.ml index 075ead9ce6f..1f51df5a778 100644 --- a/src/dune_engine/install.ml +++ b/src/dune_engine/install.ml @@ -214,19 +214,19 @@ module Entry = struct Section.compare x.section y.section let adjust_dst ~src ~dst ~section = - let error var = - User_error.raise - ~loc:(String_with_vars.Var.loc var) + let error (source_pform : Dune_lang.Template.Pform.t) = + User_error.raise ~loc:source_pform.loc [ Pp.textf "Because this file is installed in the 'bin' section, you cannot \ - use the variable %s in its basename." - (String_with_vars.Var.describe var) + use the %s %s in its basename." + (Dune_lang.Template.Pform.describe_kind source_pform) + (Dune_lang.Template.Pform.describe source_pform) ] in let is_source_executable () = let has_ext ext = match String_with_vars.Partial.is_suffix ~suffix:ext src with - | Unknown var -> error var + | Unknown { source_pform } -> error source_pform | Yes -> true | No -> false in @@ -238,10 +238,10 @@ module Entry = struct | Unexpanded src -> ( match String_with_vars.known_suffix src with | Full s -> Filename.basename s - | Partial (var, suffix) -> ( + | Partial { source_pform; suffix } -> ( match String.rsplit2 ~on:'/' suffix with | Some (_, basename) -> basename - | None -> error var ) ) + | None -> error source_pform ) ) in match dst with | Some dst' when Filename.extension dst' = ".exe" -> Dst.explicit dst' diff --git a/src/dune_rules/mode.ml b/src/dune_engine/mode.ml similarity index 98% rename from src/dune_rules/mode.ml rename to src/dune_engine/mode.ml index 3f6301b053b..638373fb050 100644 --- a/src/dune_rules/mode.ml +++ b/src/dune_engine/mode.ml @@ -1,5 +1,3 @@ -open! Dune_engine -open! Stdune open! Import type t = diff --git a/src/dune_rules/mode.mli b/src/dune_engine/mode.mli similarity index 98% rename from src/dune_rules/mode.mli rename to src/dune_engine/mode.mli index 26d75835530..8b72cea3cb0 100644 --- a/src/dune_rules/mode.mli +++ b/src/dune_engine/mode.mli @@ -1,4 +1,3 @@ -open! Dune_engine open! Import type t = diff --git a/src/dune_engine/pform.ml b/src/dune_engine/pform.ml new file mode 100644 index 00000000000..5992f4af466 --- /dev/null +++ b/src/dune_engine/pform.ml @@ -0,0 +1,564 @@ +open! Stdune + +module Var = struct + type t = + | User_var of string + | Nothing + | Project_root + | Workspace_root + | First_dep + | Deps + | Targets + | Target + | Cc + | Cxx + | Ccomp_type + | Cpp + | Pa_cpp + | Make + | Ocaml_version + | Ocaml + | Ocamlc + | Ocamlopt + | Ocaml_bin_dir + | Ocaml_stdlib_dir + | Dev_null + | Ext_obj + | Ext_asm + | Ext_lib + | Ext_dll + | Ext_exe + | Ext_plugin + | Profile + | Context_name + | Os_type + | Architecture + | Arch_sixtyfour + | System + | Model + | Ignoring_promoted_rules + | Input_file + | Library_name + | Impl_files + | Intf_files + | Test + | Corrected_suffix + | Inline_tests + + let compare : t -> t -> Ordering.t = Poly.compare + + let to_dyn = function + | User_var v -> Dyn.Variant ("User_var", [ String v ]) + | t -> + let cstr = + match t with + | User_var _ -> assert false + | Nothing -> "Nothing" + | Project_root -> "Project_root" + | Workspace_root -> "Workspace_root" + | First_dep -> "First_dep" + | Deps -> "Deps" + | Targets -> "Targets" + | Target -> "Target" + | Cc -> "Cc" + | Cxx -> "Cxx" + | Ccomp_type -> "Ccomp_type" + | Cpp -> "Cpp" + | Pa_cpp -> "Pa_cpp" + | Make -> "Make" + | Ocaml_version -> "Ocaml_version" + | Ocaml -> "Ocaml" + | Ocamlc -> "Ocamlc" + | Ocamlopt -> "Ocamlopt" + | Ocaml_bin_dir -> "Ocaml_bin_dir" + | Ocaml_stdlib_dir -> "Ocaml_stdlib_dir" + | Dev_null -> "Dev_null" + | Ext_obj -> "Ext_obj" + | Ext_asm -> "Ext_asm" + | Ext_lib -> "Ext_lib" + | Ext_dll -> "Ext_dll" + | Ext_exe -> "Ext_exe" + | Ext_plugin -> "Ext_plugin" + | Profile -> "Profile" + | Context_name -> "Context_name" + | Os_type -> "Os_type" + | Architecture -> "Architecture" + | Arch_sixtyfour -> "Arch_sixtyfour" + | System -> "System" + | Model -> "Model" + | Ignoring_promoted_rules -> "Ignoring_promoted_rules" + | Input_file -> "Input_file" + | Library_name -> "Library_name" + | Impl_files -> "Impl_files" + | Intf_files -> "Intf_files" + | Test -> "Test" + | Corrected_suffix -> "Corrected_suffix" + | Inline_tests -> "Inline_tests" + in + Dyn.Variant (cstr, []) +end + +module Artifact = struct + type t = + | Mod of Cm_kind.t + | Lib of Mode.t + + let compare x y = + match (x, y) with + | Mod x, Mod y -> Cm_kind.compare x y + | Mod _, _ -> Lt + | _, Mod _ -> Gt + | Lib x, Lib y -> Mode.compare x y + + let ext = function + | Mod cm_kind -> Cm_kind.ext cm_kind + | Lib mode -> Mode.compiled_lib_ext mode + + let all = + List.map ~f:(fun kind -> Mod kind) Cm_kind.all + @ List.map ~f:(fun mode -> Lib mode) Mode.all + + let to_dyn a = + let open Dyn.Encoder in + match a with + | Mod cm_kind -> constr "Mod" [ Cm_kind.to_dyn cm_kind ] + | Lib mode -> constr "Lib" [ Mode.to_dyn mode ] +end + +module Macro = struct + type t = + | Exe + | Dep + | Bin + | Lib of + { lib_exec : bool + ; lib_private : bool + } + | Lib_available + | Version + | Read + | Read_strings + | Read_lines + | Path_no_dep + | Ocaml_config + | Env + | Artifact of Artifact.t + + let compare x y = + match (x, y) with + | Exe, Exe -> Eq + | Exe, _ -> Lt + | _, Exe -> Gt + | Dep, Dep -> Eq + | Dep, _ -> Lt + | _, Dep -> Gt + | Bin, Bin -> Eq + | Bin, _ -> Lt + | _, Bin -> Gt + | Lib { lib_exec; lib_private }, Lib y -> + Tuple.T2.compare Bool.compare Bool.compare (lib_exec, lib_private) + (y.lib_exec, y.lib_private) + | Lib _, _ -> Lt + | _, Lib _ -> Gt + | Lib_available, Lib_available -> Eq + | Lib_available, _ -> Lt + | _, Lib_available -> Gt + | Version, Version -> Eq + | Version, _ -> Lt + | _, Version -> Gt + | Read, Read -> Eq + | Read, _ -> Lt + | _, Read -> Gt + | Read_strings, Read_strings -> Eq + | Read_strings, _ -> Lt + | _, Read_strings -> Gt + | Read_lines, Read_lines -> Eq + | Read_lines, _ -> Lt + | _, Read_lines -> Gt + | Path_no_dep, Path_no_dep -> Eq + | Path_no_dep, _ -> Lt + | _, Path_no_dep -> Gt + | Ocaml_config, Ocaml_config -> Eq + | Ocaml_config, _ -> Lt + | _, Ocaml_config -> Gt + | Env, Env -> Eq + | Env, _ -> Lt + | _, Env -> Gt + | Artifact x, Artifact y -> Artifact.compare x y + + let to_dyn = + let open Dyn.Encoder in + function + | Exe -> string "Exe" + | Dep -> string "Dep" + | Bin -> string "Bin" + | Lib { lib_private; lib_exec } -> + constr "Lib" + [ record + [ ("lib_exec", bool lib_exec); ("lib_private", bool lib_private) ] + ] + | Lib_available -> string "Lib_available" + | Version -> string "Version" + | Read -> string "Read" + | Read_strings -> string "Read_strings" + | Read_lines -> string "Read_lines" + | Path_no_dep -> string "Path_no_dep" + | Ocaml_config -> string "Ocaml_config" + | Env -> string "Env" + | Artifact ext -> constr "Artifact" [ Artifact.to_dyn ext ] +end + +module T = struct + type t = + | Var of Var.t + | Macro of Macro.t * string + + let to_dyn e = + let open Dyn.Encoder in + match e with + | Var v -> pair string Var.to_dyn ("Var", v) + | Macro (m, s) -> triple string Macro.to_dyn string ("Macro", m, s) + + let compare x y = + match (x, y) with + | Var x, Var y -> Var.compare x y + | Var _, _ -> Lt + | _, Var _ -> Gt + | Macro (m1, s1), Macro (m2, s2) -> + Tuple.T2.compare Macro.compare String.compare (m1, s1) (m2, s2) +end + +include T +module Map = Map.Make (T) + +type encode_result = + | Success of + { name : string + ; payload : string option + } + | Pform_was_deleted + +let encode_to_latest_dune_lang_version t = + match t with + | Var x -> ( + match + match x with + | User_var x -> Some x + | Nothing -> None + | Project_root -> Some "project_root" + | Workspace_root -> Some "workspace_root" + | First_dep -> None + | Deps -> Some "deps" + | Targets -> Some "targets" + | Target -> Some "target" + | Cc -> Some "cc" + | Cxx -> Some "cxx" + | Ccomp_type -> Some "ccomp_type" + | Cpp -> Some "cpp" + | Pa_cpp -> Some "pa_cpp" + | Make -> Some "make" + | Ocaml_version -> Some "ocaml_version" + | Ocaml -> Some "ocaml" + | Ocamlc -> Some "ocamlc" + | Ocamlopt -> Some "ocamlopt" + | Ocaml_bin_dir -> Some "ocaml_bin" + | Ocaml_stdlib_dir -> Some "ocaml_where" + | Dev_null -> Some "null" + | Ext_obj -> Some "ext_obj" + | Ext_asm -> Some "ext_asm" + | Ext_lib -> Some "ext_lib" + | Ext_dll -> Some "ext_dll" + | Ext_exe -> Some "ext_exe" + | Ext_plugin -> Some "ext_plugin" + | Profile -> Some "profile" + | Context_name -> Some "context_name" + | Os_type -> Some "os_type" + | Architecture -> Some "architecture" + | Arch_sixtyfour -> Some "arch_sixtyfour" + | System -> Some "system" + | Model -> Some "model" + | Ignoring_promoted_rules -> Some "ignoring_promoted_rules" + | Input_file -> Some "input_file" + | Library_name -> Some "library-name" + | Impl_files -> Some "impl-files" + | Intf_files -> Some "intf-files" + | Test -> Some "test" + | Corrected_suffix -> Some "corrected-suffix" + | Inline_tests -> Some "inline_tests" + with + | None -> Pform_was_deleted + | Some name -> Success { name; payload = None } ) + | Macro (x, payload) -> ( + match + match x with + | Exe -> Some "exe" + | Dep -> Some "dep" + | Bin -> Some "bin" + | Lib { lib_exec = false; lib_private = false } -> Some "lib" + | Lib { lib_exec = true; lib_private = false } -> Some "libexec" + | Lib { lib_exec = false; lib_private = true } -> Some "lib-private" + | Lib { lib_exec = true; lib_private = true } -> Some "libexec-private" + | Lib_available -> Some "lib-available" + | Version -> Some "version" + | Read -> Some "read" + | Read_strings -> Some "read-strings" + | Read_lines -> Some "read-lines" + | Path_no_dep -> None + | Ocaml_config -> Some "ocaml-config" + | Env -> Some "env" + | Artifact a -> Some (String.drop (Artifact.ext a) 1) + with + | None -> Pform_was_deleted + | Some name -> Success { name; payload = Some payload } ) + +let describe_kind = function + | Var _ -> "variable" + | Macro _ -> "macro" + +module With_versioning_info = struct + type 'a t = + | No_info of 'a + | Since of 'a * Dune_lang.Syntax.Version.t + | Deleted_in of + 'a * Dune_lang.Syntax.Version.t * User_message.Style.t Pp.t list + | Renamed_in of 'a * Dune_lang.Syntax.Version.t * string + + let get_data = function + | No_info x + | Since (x, _) + | Deleted_in (x, _, _) + | Renamed_in (x, _, _) -> + x + + let renamed_in x ~new_name ~version = Renamed_in (x, version, new_name) + + let deleted_in ~version ?(repl = []) kind = Deleted_in (kind, version, repl) + + let since ~version v = Since (v, version) + + let to_dyn f = + let open Dyn.Encoder in + function + | No_info x -> constr "No_info" [ f x ] + | Since (x, v) -> constr "Since" [ f x; Dune_lang.Syntax.Version.to_dyn v ] + | Deleted_in (x, v, repl) -> + constr "Deleted_in" + [ f x + ; Dune_lang.Syntax.Version.to_dyn v + ; List + (List.map repl ~f:(fun pp -> + Dyn.String (Format.asprintf "%a" Pp.to_fmt pp))) + ] + | Renamed_in (x, v, s) -> + constr "Renamed_in" [ f x; Dune_lang.Syntax.Version.to_dyn v; string s ] +end + +open With_versioning_info + +module Env = struct + type 'a map = 'a With_versioning_info.t String.Map.t + + type t = + { syntax_version : Dune_lang.Syntax.Version.t + ; vars : Var.t map + ; macros : Macro.t map + } + + let syntax_version t = t.syntax_version + + let initial = + let macros = + let macro (x : Macro.t) = No_info x in + let artifact x = + ( String.drop (Artifact.ext x) 1 + , since ~version:(2, 0) (Macro.Artifact x) ) + in + String.Map.of_list_exn + ( [ ("exe", macro Exe) + ; ("bin", macro Bin) + ; ("lib", macro (Lib { lib_exec = false; lib_private = false })) + ; ("libexec", macro (Lib { lib_exec = true; lib_private = false })) + ; ( "lib-private" + , since ~version:(2, 1) + (Macro.Lib { lib_exec = false; lib_private = true }) ) + ; ( "libexec-private" + , since ~version:(2, 1) + (Macro.Lib { lib_exec = true; lib_private = true }) ) + ; ("lib-available", macro Lib_available) + ; ("version", macro Version) + ; ("read", macro Read) + ; ("read-lines", macro Read_lines) + ; ("read-strings", macro Read_strings) + ; ("dep", since ~version:(1, 0) Macro.Dep) + ; ("path", renamed_in ~version:(1, 0) ~new_name:"dep" Macro.Dep) + ; ( "findlib" + , renamed_in ~version:(1, 0) ~new_name:"lib" + (Macro.Lib { lib_exec = false; lib_private = false }) ) + ; ("path-no-dep", deleted_in ~version:(1, 0) Macro.Path_no_dep) + ; ("ocaml-config", macro Ocaml_config) + ; ("env", since ~version:(1, 4) Macro.Env) + ] + @ List.map ~f:artifact Artifact.all ) + in + let vars = + let lowercased : (string * Var.t With_versioning_info.t) list = + [ ("cpp", No_info Cpp) + ; ("pa_cpp", No_info Pa_cpp) + ; ("ocaml", No_info Ocaml) + ; ("ocamlc", No_info Ocamlc) + ; ("ocamlopt", No_info Ocamlopt) + ; ("arch_sixtyfour", No_info Arch_sixtyfour) + ; ("make", No_info Make) + ; ("cc", No_info Cc) + ; ("cxx", No_info Cxx) + ] + in + let uppercased = + List.map lowercased ~f:(fun (k, v) -> + match v with + | No_info v -> + (String.uppercase k, renamed_in v ~new_name:k ~version:(1, 0)) + | _ -> assert false) + in + let other : (string * Var.t With_versioning_info.t) list = + [ ("targets", since ~version:(1, 0) Var.Targets) + ; ("target", since ~version:(1, 11) Var.Target) + ; ("deps", since ~version:(1, 0) Var.Deps) + ; ("project_root", since ~version:(1, 0) Var.Project_root) + ; ( "<" + , deleted_in Var.First_dep ~version:(1, 0) + ~repl: + [ Pp.text + "Use a named dependency instead:\n\n\ + \ (deps (:x ) ...)\n\ + \ ... %{x} ..." + ] ) + ; ("@", renamed_in ~version:(1, 0) ~new_name:"targets" Var.Deps) + ; ("^", renamed_in ~version:(1, 0) ~new_name:"deps" Var.Targets) + ; ( "SCOPE_ROOT" + , renamed_in ~version:(1, 0) ~new_name:"project_root" Var.Project_root + ) + ; ("-verbose", deleted_in ~version:(3, 0) Var.Nothing) + ; ("ocaml_bin", No_info Ocaml_bin_dir) + ; ("ocaml_version", No_info Ocaml_version) + ; ("ocaml_where", No_info Ocaml_stdlib_dir) + ; ("ccomp_type", since ~version:(3, 0) Var.Ccomp_type) + ; ("null", No_info Dev_null) + ; ("ext_obj", No_info Ext_obj) + ; ("ext_asm", No_info Ext_asm) + ; ("ext_lib", No_info Ext_lib) + ; ("ext_dll", No_info Ext_dll) + ; ("ext_exe", No_info Ext_exe) + ; ("ext_plugin", since ~version:(2, 4) Var.Ext_plugin) + ; ("profile", No_info Profile) + ; ("workspace_root", No_info Workspace_root) + ; ("context_name", No_info Context_name) + ; ( "ROOT" + , renamed_in ~version:(1, 0) ~new_name:"workspace_root" + Var.Workspace_root ) + ; ("os_type", since ~version:(1, 10) Var.Os_type) + ; ("architecture", since ~version:(1, 10) Var.Architecture) + ; ("system", since ~version:(1, 10) Var.System) + ; ("model", since ~version:(1, 10) Var.Model) + ; ( "ignoring_promoted_rules" + , since ~version:(1, 10) Var.Ignoring_promoted_rules ) + ; ("library-name", No_info Library_name) + ; ("impl-files", No_info Impl_files) + ; ("intf-files", No_info Intf_files) + ; ("test", No_info Test) + ; ("input-file", since ~version:(1, 0) Var.Input_file) + ; ("corrected-suffix", No_info Corrected_suffix) + ; ("inline_tests", No_info Inline_tests) + ] + in + String.Map.of_list_exn (List.concat [ lowercased; uppercased; other ]) + in + fun syntax_version -> { syntax_version; vars; macros } + + let lt_renamed_input_file t = + { t with + vars = + String.Map.set t.vars "<" + (renamed_in ~new_name:"input-file" ~version:(1, 0) Var.Input_file) + } + + let parse map syntax_version (pform : Dune_lang.Template.Pform.t) = + let module P = Dune_lang.Template.Pform in + match String.Map.find map pform.name with + | None -> + User_error.raise ~loc:pform.loc + [ Pp.textf "Unknown %s %s" (P.describe_kind pform) (P.describe pform) ] + | Some v -> ( + match v with + | No_info v -> v + | Since (v, min_version) -> + if syntax_version >= min_version then + v + else + Dune_lang.Syntax.Error.since (P.loc pform) Stanza.syntax min_version + ~what:(P.describe pform) + | Renamed_in (v, in_version, new_name) -> + if syntax_version < in_version then + v + else + Dune_lang.Syntax.Error.renamed_in (P.loc pform) Stanza.syntax + in_version ~what:(P.describe pform) + ~to_:(P.describe { pform with name = new_name }) + | Deleted_in (v, in_version, repl) -> + if syntax_version < in_version then + v + else + Dune_lang.Syntax.Error.deleted_in (P.loc pform) Stanza.syntax + in_version ~what:(P.describe pform) ~repl ) + + let parse t (pform : Dune_lang.Template.Pform.t) = + match pform.payload with + | None -> Var (parse t.vars t.syntax_version pform) + | Some payload -> Macro (parse t.macros t.syntax_version pform, payload) + + let unsafe_parse_without_checking_version map + (pform : Dune_lang.Template.Pform.t) = + let module P = Dune_lang.Template.Pform in + match String.Map.find map pform.name with + | None -> + User_error.raise ~loc:pform.loc + [ Pp.textf "Unknown %s %s" (P.describe_kind pform) (P.describe pform) ] + | Some v -> With_versioning_info.get_data v + + let unsafe_parse_without_checking_version t + (pform : Dune_lang.Template.Pform.t) = + match pform.payload with + | None -> Var (unsafe_parse_without_checking_version t.vars pform) + | Some payload -> + Macro (unsafe_parse_without_checking_version t.macros pform, payload) + + let to_dyn { syntax_version; vars; macros } = + let open Dyn.Encoder in + record + [ ("syntax_version", Dune_lang.Syntax.Version.to_dyn syntax_version) + ; ("vars", String.Map.to_dyn (to_dyn Var.to_dyn) vars) + ; ("macros", String.Map.to_dyn (to_dyn Macro.to_dyn) macros) + ] + + let add_user_vars t vars = + { t with + vars = + List.fold_left vars ~init:t.vars ~f:(fun vars var -> + String.Map.set vars var (No_info (Var.User_var var))) + } + + type stamp = + Dune_lang.Syntax.Version.t + * (string * Var.t With_versioning_info.t) list + * (string * Macro.t With_versioning_info.t) list + + let to_stamp { syntax_version; vars; macros } : stamp = + (syntax_version, String.Map.to_list vars, String.Map.to_list macros) + + let all_known { syntax_version = _; vars; macros } = + String.Map.union + (String.Map.map vars ~f:(fun x -> Var (With_versioning_info.get_data x))) + (String.Map.map macros ~f:(fun x -> + Macro (With_versioning_info.get_data x, ""))) + ~f:(fun _ _ _ -> assert false) +end diff --git a/src/dune_engine/pform.mli b/src/dune_engine/pform.mli new file mode 100644 index 00000000000..e59ff7db8d6 --- /dev/null +++ b/src/dune_engine/pform.mli @@ -0,0 +1,149 @@ +open! Stdune + +module Var : sig + type t = + | User_var of string + | Nothing + | Project_root + | Workspace_root + | First_dep + | Deps + | Targets + | Target + | Cc + | Cxx + | Ccomp_type + | Cpp + | Pa_cpp + | Make + | Ocaml_version + | Ocaml + | Ocamlc + | Ocamlopt + | Ocaml_bin_dir + | Ocaml_stdlib_dir + | Dev_null + | Ext_obj + | Ext_asm + | Ext_lib + | Ext_dll + | Ext_exe + | Ext_plugin + | Profile + | Context_name + | Os_type + | Architecture + | Arch_sixtyfour + | System + | Model + | Ignoring_promoted_rules + | Input_file + | Library_name + | Impl_files + | Intf_files + | Test + | Corrected_suffix + | Inline_tests + + val compare : t -> t -> Ordering.t + + val to_dyn : t -> Dyn.t +end + +module Artifact : sig + type t = + | Mod of Cm_kind.t + | Lib of Mode.t + + val compare : t -> t -> Ordering.t + + val to_dyn : t -> Dyn.t + + val ext : t -> string + + val all : t list +end + +module Macro : sig + type t = + | Exe + | Dep + | Bin + (* All four combinations are allowed and correspond to variables [lib], + [libexec], [lib-private], and [libexec-private]. *) + | Lib of + { lib_exec : bool + ; lib_private : bool + } + | Lib_available + | Version + | Read + | Read_strings + | Read_lines + | Path_no_dep + | Ocaml_config + | Env + | Artifact of Artifact.t + + val compare : t -> t -> Ordering.t + + val to_dyn : t -> Dyn.t +end + +type t = + | Var of Var.t + | Macro of Macro.t * string + +val compare : t -> t -> Ordering.t + +val to_dyn : t -> Dyn.t + +type encode_result = + | Success of + { name : string + ; payload : string option + } + | Pform_was_deleted + +(** Enode using the latest name for a given percent form. *) +val encode_to_latest_dune_lang_version : t -> encode_result + +(** "macro" or "variable" *) +val describe_kind : t -> string + +module Map : Map.S with type key = t + +module Env : sig + type pform = t + + (** Decoding environment *) + type t + + val initial : Dune_lang.Syntax.Version.t -> t + + val add_user_vars : t -> string list -> t + + val parse : t -> Dune_lang.Template.Pform.t -> pform + + (** Used to parse percent forms in [enabled_if] fields, as the checks are done + manually *) + val unsafe_parse_without_checking_version : + t -> Dune_lang.Template.Pform.t -> pform + + (** The set of all variables and macros known, including deleted ones. Macros + are returned with an empty payload. *) + val all_known : t -> pform String.Map.t + + val syntax_version : t -> Dune_lang.Syntax.Version.t + + (** Introduce the renaming "<" -> "input-file". In [initial], "<" is marked as + deleted. *) + val lt_renamed_input_file : t -> t + + type stamp + + val to_stamp : t -> stamp + + val to_dyn : t -> Dyn.t +end +with type pform := t diff --git a/src/dune_engine/string_with_vars.ml b/src/dune_engine/string_with_vars.ml index 7993f944394..45093fce483 100644 --- a/src/dune_engine/string_with_vars.ml +++ b/src/dune_engine/string_with_vars.ml @@ -1,64 +1,98 @@ open! Stdune open! Import -open Dune_lang.Template + +type part = + | Text of string + | Pform of Dune_lang.Template.Pform.t * Pform.t + (* [Error _] is for percent forms that failed to parse with lang dune < 3.0 *) + | Error of Dune_lang.Template.Pform.t * User_message.t type t = - { template : Dune_lang.Template.t - ; syntax_version : Dune_lang.Syntax.Version.t + { quoted : bool + ; parts : part list + ; loc : Loc.t } let compare_no_loc t1 t2 = - match - Dune_lang.Syntax.Version.compare t1.syntax_version t2.syntax_version - with + match Bool.compare t1.quoted t2.quoted with | (Ordering.Lt | Gt) as a -> a - | Eq -> Dune_lang.Template.compare_no_loc t1.template t2.template + | Eq -> + List.compare t1.parts t2.parts ~compare:(fun a b -> + match (a, b) with + | Text a, Text b -> String.compare a b + | Pform (_, a), Pform (_, b) -> Pform.compare a b + | Error (_, a), Error (_, b) -> Poly.compare a b + | Text _, _ -> Lt + | _, Text _ -> Gt + | Pform _, _ -> Lt + | _, Pform _ -> Gt) let equal_no_loc t1 t2 = Ordering.is_eq (compare_no_loc t1 t2) -let make_syntax = (1, 0) - -let make template = { template; syntax_version = make_syntax } - -let make_text ?(quoted = false) loc s = make { parts = [ Text s ]; quoted; loc } +let make_text ?(quoted = false) loc s = { quoted; loc; parts = [ Text s ] } -let make_var ?(quoted = false) loc ?payload name = - let var = { loc; name; payload } in - make { parts = [ Var var ]; quoted; loc } +let make_pform ?(quoted = false) loc pform = + let source = + match Pform.encode_to_latest_dune_lang_version pform with + | Success { name; payload } -> + { Dune_lang.Template.Pform.loc; name; payload } + | Pform_was_deleted -> assert false + in + { quoted; loc; parts = [ Pform (source, pform) ] } let literal ~quoted ~loc s = { parts = [ Text s ]; quoted; loc } -let decode = - let open Dune_lang.Decoder in - let template_parser = - raw >>| function - | Template t -> t - | Atom (loc, A s) -> literal ~quoted:false ~loc s - | Quoted_string (loc, s) -> literal ~quoted:true ~loc s - | List (loc, _) -> User_error.raise ~loc [ Pp.text "Unexpected list" ] - in - let+ syntax_version = Dune_lang.Syntax.get_exn Stanza.syntax - and+ template = template_parser in - { template; syntax_version } +let decoding_env_key = + Univ_map.Key.create ~name:"pform decoding environment" Pform.Env.to_dyn -let loc t = t.template.loc +let set_decoding_env env = Dune_lang.Decoder.set decoding_env_key env -let syntax_version t = t.syntax_version +let add_user_vars_to_decoding_env vars = + Dune_lang.Decoder.update_var decoding_env_key ~f:(function + | None -> Code_error.raise "Decoding env not set" [] + | Some env -> Some (Pform.Env.add_user_vars env vars)) -let virt_var ?(quoted = false) pos s = - assert ( - String.for_all s ~f:(function - | ':' -> false - | _ -> true) ); - let loc = Loc.of_pos pos in - let template = - { parts = [ Var { payload = None; name = s; loc } ]; loc; quoted } +let decode_manually f = + let open Dune_lang.Decoder in + let+ env = get decoding_env_key + and+ x = raw in + let env = + match env with + | Some env -> env + | None -> + Code_error.raise ~loc:(Dune_lang.Ast.loc x) + "pform decoding environment not set" [] in - { template; syntax_version = make_syntax } + match x with + | Atom (loc, A s) -> literal ~quoted:false ~loc s + | Quoted_string (loc, s) -> literal ~quoted:true ~loc s + | List (loc, _) -> User_error.raise ~loc [ Pp.text "Unexpected list" ] + | Template { quoted; loc; parts } -> + { quoted + ; loc + ; parts = + List.map parts ~f:(function + | Dune_lang.Template.Text s -> Text s + | Pform v -> ( + match f env v with + | pform -> Pform (v, pform) + | exception User_error.E msg + when Pform.Env.syntax_version env < (3, 0) -> + (* Before dune 3.0, unknown variable errors were delayed *) + Error (v, msg) )) + } + +let decode = decode_manually Pform.Env.parse + +let loc t = t.loc + +let virt_pform ?quoted pos pform = + let loc = Loc.of_pos pos in + make_pform ?quoted loc pform let virt_text pos s = - let template = { parts = [ Text s ]; loc = Loc.of_pos pos; quoted = true } in - { template; syntax_version = make_syntax } + let loc = Loc.of_pos pos in + { parts = [ Text s ]; loc; quoted = true } let concat_rev = function | [] -> "" @@ -84,84 +118,67 @@ module Mode = struct | Single, _ -> None end -let invalid_multivalue (v : var) x = - User_error.raise ~loc:v.loc +let invalid_multivalue source _pform x = + User_error.raise ~loc:source.Dune_lang.Template.Pform.loc [ Pp.textf - "Variable %s expands to %d values, however a single value is expected \ - here. Please quote this atom." - (string_of_var v) (List.length x) + "%s %s expands to %d values, however a single value is expected here. \ + Please quote this atom." + (String.capitalize_ascii + (Dune_lang.Template.Pform.describe_kind source)) + (Dune_lang.Template.Pform.describe source) + (List.length x) ] -module Var = struct - type t = var - - let loc (t : t) = t.loc - - let name { name; _ } = name - - let full_name t = - match t.payload with - | None -> t.name - | Some v -> t.name ^ ":" ^ v - - let payload t = t.payload - - let to_string = string_of_var - - let to_dyn t = Dyn.Encoder.string (to_string t) - - let with_name t ~name = { t with name } - - let is_macro t = Option.is_some t.payload - - let describe t = - to_string - ( match t.payload with - | None -> t - | Some _ -> { t with payload = Some ".." } ) -end - type known_suffix = | Full of string - | Partial of (Var.t * string) + | Partial of + { source_pform : Dune_lang.Template.Pform.t + ; suffix : string + } let known_suffix = let rec go t acc = match t with | Text s :: rest -> go rest (s :: acc) | [] -> Full (String.concat ~sep:"" acc) - | Var v :: _ -> Partial (v, String.concat ~sep:"" acc) + | (Pform (p, _) | Error (p, _)) :: _ -> + Partial { source_pform = p; suffix = String.concat ~sep:"" acc } in - fun t -> go (List.rev t.template.parts) [] + fun t -> go (List.rev t.parts) [] type known_prefix = | Full of string - | Partial of (string * Var.t) + | Partial of + { prefix : string + ; source_pform : Dune_lang.Template.Pform.t + } let known_prefix = let rec go t acc = match t with | Text s :: rest -> go rest (s :: acc) | [] -> Full (String.concat ~sep:"" (List.rev acc)) - | Var v :: _ -> Partial (String.concat ~sep:"" (List.rev acc), v) + | (Pform (p, _) | Error (p, _)) :: _ -> + Partial + { prefix = String.concat ~sep:"" (List.rev acc); source_pform = p } in - fun t -> go t.template.parts [] + fun t -> go t.parts [] -let fold_vars = +let fold_pforms = let rec loop parts acc f = match parts with | [] -> acc - | Text _ :: parts -> loop parts acc f - | Var v :: parts -> loop parts (f v acc) f + | (Text _ | Error _) :: parts -> loop parts acc f + | Pform (p, v) :: parts -> loop parts (f ~source:p v acc) f in - fun t ~init ~f -> loop t.template.parts init f + fun t ~init ~f -> loop t.parts init f -type 'a expander = Var.t -> Dune_lang.Syntax.Version.t -> 'a +type 'a expander = source:Dune_lang.Template.Pform.t -> Pform.t -> 'a type yes_no_unknown = | Yes | No - | Unknown of Var.t + | Unknown of { source_pform : Dune_lang.Template.Pform.t } let is_suffix t ~suffix:want = match known_suffix t with @@ -170,11 +187,11 @@ let is_suffix t ~suffix:want = Yes else No - | Partial (v, have) -> + | Partial { suffix = have; source_pform } -> if String.is_suffix ~suffix:want have then Yes else if String.is_suffix ~suffix:have want then - Unknown v + Unknown { source_pform } else No @@ -185,11 +202,11 @@ let is_prefix t ~prefix:want = Yes else No - | Partial (have, v) -> + | Partial { prefix = have; source_pform } -> if String.is_prefix ~prefix:want have then Yes else if String.is_prefix ~prefix:have want then - Unknown v + Unknown { source_pform } else No @@ -252,34 +269,36 @@ module Make (A : Applicative_intf.S1) = struct let partial_expand : 'a. t -> mode:'a Mode.t -> dir:Path.t -> f:Value.t list option A.t expander -> 'a Partial.t A.t = - fun ({ template; syntax_version } as t) ~mode ~dir ~f -> - match template.parts with + fun t ~mode ~dir ~f -> + match t.parts with (* Optimizations for some common cases *) | [] -> A.return (Partial.Expanded (Mode.string mode "")) | [ Text s ] -> A.return (Partial.Expanded (Mode.string mode s)) - | [ Var var ] when not template.quoted -> ( + | [ Pform (source, p) ] when not t.quoted -> ( let open App.O in - let+ exp = f var syntax_version in + let+ exp = f ~source p in match exp with | None -> Partial.Unexpanded t | Some e -> Expanded ( match Mode.value mode e with - | None -> invalid_multivalue var e + | None -> invalid_multivalue source p e | Some s -> s ) ) | _ -> let expanded_parts = - List.map template.parts ~f:(fun part -> + List.map t.parts ~f:(fun part -> match part with - | Text s -> App.return (Text s) - | Var var -> ( + | Text _ + | Error _ -> + App.return part + | Pform (source, p) -> ( let open App.O in - let+ exp = f var syntax_version in + let+ exp = f ~source p in match exp with - | Some (([] | _ :: _ :: _) as e) when not template.quoted -> - invalid_multivalue var e + | Some (([] | _ :: _ :: _) as e) when not t.quoted -> + invalid_multivalue source p e | Some t -> Text (Value.L.concat ~dir t) - | None -> Var var )) + | None -> part )) in let open App.O in let+ expanded = App.all expanded_parts in @@ -297,10 +316,7 @@ module Make (A : Applicative_intf.S1) = struct match acc with | [] -> Partial.Expanded (Mode.string mode (concat_rev acc_text)) | _ -> - let template = - { template with parts = List.rev (commit_text acc_text acc) } - in - Unexpanded { template; syntax_version } ) + Unexpanded { t with parts = List.rev (commit_text acc_text acc) } ) | Text s :: items -> loop (s :: acc_text) acc items | it :: items -> loop [] (it :: commit_text acc_text acc) items in @@ -308,47 +324,66 @@ module Make (A : Applicative_intf.S1) = struct let expand t ~mode ~dir ~f = let open App.O in - let+ exp = - partial_expand t ~mode ~dir ~f:(fun var syntax_version -> - let+ exp = f var syntax_version in - match exp with - | None -> - if Var.is_macro var then - User_error.raise ~loc:var.loc - [ Pp.textf "Unknown macro %s" (Var.describe var) ] - else - User_error.raise ~loc:var.loc - [ Pp.textf "Unknown variable %S" (Var.name var) ] - | s -> s) - in + let+ exp = partial_expand t ~mode ~dir ~f in match exp with | Partial.Expanded s -> s - | Unexpanded _ -> assert false + | Unexpanded t -> + List.iter t.parts ~f:(function + | Error (_, msg) -> raise (User_error.E msg) + | _ -> ()); + assert false end include Make (Applicative.Id) -let is_var { template; syntax_version = _ } ~name = - match template.parts with - | [ Var n ] -> name = Var.full_name n +let is_pform t pform = + match t.parts with + | [ Pform (_, pform') ] -> Pform.compare pform pform' = Eq | _ -> false let text_only t = - match t.template.parts with + match t.parts with | [ Text s ] -> Some s | _ -> None -let has_vars t = Option.is_none (text_only t) +let has_pforms t = Option.is_none (text_only t) let encode t = match text_only t with | Some s -> Dune_lang.atom_or_quoted_string s - | None -> Dune_lang.Template t.template + | None -> + Dune_lang.Template + { loc = t.loc + ; quoted = t.quoted + ; parts = + List.map t.parts ~f:(function + | Text s -> Dune_lang.Template.Text s + | Error (_, msg) -> raise (User_error.E msg) + | Pform (source, pform) -> ( + match Pform.encode_to_latest_dune_lang_version pform with + | Pform_was_deleted -> + User_error.raise ~loc:source.loc + [ Pp.textf + "%s was deleted in the latest version of the dune \ + language. It cannot appear here. " + (Dune_lang.Template.Pform.describe source) + ] + | Success { name; payload } -> + Pform { loc = source.loc; name; payload } )) + } let to_dyn t = Dune_lang.to_dyn (encode t) -let remove_locs t = - { t with template = Dune_lang.Template.remove_locs t.template } +let remove_locs { quoted; loc = _; parts } = + { quoted + ; loc = Loc.none + ; parts = + List.map parts ~f:(function + | Text _ as p -> p + | Error (source, msg) -> + Error ({ source with loc = Loc.none }, { msg with loc = None }) + | Pform (source, p) -> Pform ({ source with loc = Loc.none }, p)) + } module Partial = struct include Private.Partial diff --git a/src/dune_engine/string_with_vars.mli b/src/dune_engine/string_with_vars.mli index a61107ba328..3b17fa1bf71 100644 --- a/src/dune_engine/string_with_vars.mli +++ b/src/dune_engine/string_with_vars.mli @@ -16,27 +16,42 @@ val equal_no_loc : t -> t -> bool (** [loc t] returns the location of [t] — typically, in the [dune] file. *) val loc : t -> Loc.t -val syntax_version : t -> Dune_lang.Syntax.Version.t - val to_dyn : t Dyn.Encoder.t include Dune_lang.Conv.S with type t := t +(** For complex cases, such as [enabled_if] fields *) +val decode_manually : + (Pform.Env.t -> Dune_lang.Template.Pform.t -> Pform.t) + -> t Dune_lang.Decoder.t + +val decoding_env_key : Pform.Env.t Univ_map.Key.t + +val set_decoding_env : + Pform.Env.t + -> ('a, 'k) Dune_lang.Decoder.parser + -> ('a, 'k) Dune_lang.Decoder.parser + +val add_user_vars_to_decoding_env : + string list + -> ('a, 'k) Dune_lang.Decoder.parser + -> ('a, 'k) Dune_lang.Decoder.parser + (** [t] generated by the OCaml code. The first argument should be [__POS__]. [quoted] says whether the string is quoted ([false] by default). *) -val virt_var : ?quoted:bool -> string * int * int * int -> string -> t +val virt_pform : ?quoted:bool -> string * int * int * int -> Pform.t -> t val virt_text : string * int * int * int -> string -> t -val make_var : ?quoted:bool -> Loc.t -> ?payload:string -> string -> t +val make_pform : ?quoted:bool -> Loc.t -> Pform.t -> t val make_text : ?quoted:bool -> Loc.t -> string -> t -val make : Dune_lang.Template.t -> t +(*val make : Dune_lang.Template.t -> t*) -val is_var : t -> name:string -> bool +val is_pform : t -> Pform.t -> bool -val has_vars : t -> bool +val has_pforms : t -> bool (** If [t] contains no variable, returns the contents of [t]. *) val text_only : t -> string option @@ -54,32 +69,10 @@ module Mode : sig | Many : Value.t list t end -module Var : sig - (** Variables are of the form %\{foo\} or %\{foo:bar\}. The latter form is - also referred to as macros. *) - type t - - val to_dyn : t -> Dyn.t - - val name : t -> string - - val loc : t -> Loc.t - - val full_name : t -> string - - (** Variables do not have a payload. While macros always do. *) - val payload : t -> string option - - val with_name : t -> name:string -> t - - (** Describe what this variable is *) - val describe : t -> string -end - type yes_no_unknown = | Yes | No - | Unknown of Var.t + | Unknown of { source_pform : Dune_lang.Template.Pform.t } module Partial : sig type string_with_vars @@ -107,11 +100,17 @@ with type string_with_vars := t type known_suffix = | Full of string - | Partial of (Var.t * string) + | Partial of + { source_pform : Dune_lang.Template.Pform.t + ; suffix : string + } type known_prefix = | Full of string - | Partial of (string * Var.t) + | Partial of + { prefix : string + ; source_pform : Dune_lang.Template.Pform.t + } val known_suffix : t -> known_suffix @@ -121,9 +120,13 @@ val is_suffix : t -> suffix:string -> yes_no_unknown val is_prefix : t -> prefix:string -> yes_no_unknown -val fold_vars : t -> init:'a -> f:(Var.t -> 'a -> 'a) -> 'a +val fold_pforms : + t + -> init:'a + -> f:(source:Dune_lang.Template.Pform.t -> Pform.t -> 'a -> 'a) + -> 'a -type 'a expander = Var.t -> Dune_lang.Syntax.Version.t -> 'a +type 'a expander = source:Dune_lang.Template.Pform.t -> Pform.t -> 'a module type S = sig type 'a app diff --git a/src/dune_engine/utils.ml b/src/dune_engine/utils.ml index ae088245f10..54c622c667b 100644 --- a/src/dune_engine/utils.ml +++ b/src/dune_engine/utils.ml @@ -29,7 +29,7 @@ let bash_exn = [ Pp.textf "I need bash to %s but I couldn't find it :(" needed_to ] let not_found fmt ?loc ?context ?hint x = - User_error.raise ?loc + User_error.make ?loc ( Pp.textf fmt (String.maybe_quoted x) :: ( match context with @@ -41,12 +41,15 @@ let not_found fmt ?loc ?context ?hint x = | None -> [] | Some hint -> [ Pp.text hint ] ) -let program_not_found ?context ?hint ~loc prog = +let program_not_found_message ?context ?hint ~loc prog = not_found "Program %s not found in the tree or in PATH" ?context ?hint ?loc prog +let program_not_found ?context ?hint ~loc prog = + raise (User_error.E (program_not_found_message ?context ?hint ~loc prog)) + let library_not_found ?context ?hint lib = - not_found "Library %s not found" ?context ?hint lib + raise (User_error.E (not_found "Library %s not found" ?context ?hint lib)) let install_file ~(package : Package.Name.t) ~findlib_toolchain = let package = Package.Name.to_string package in diff --git a/src/dune_engine/utils.mli b/src/dune_engine/utils.mli index 623f71b0cff..101d0d6d0b9 100644 --- a/src/dune_engine/utils.mli +++ b/src/dune_engine/utils.mli @@ -13,6 +13,13 @@ val bash_exn : needed_to:string -> Path.t val program_not_found : ?context:Context_name.t -> ?hint:string -> loc:Loc.t option -> string -> _ +val program_not_found_message : + ?context:Context_name.t + -> ?hint:string + -> loc:Loc.t option + -> string + -> User_message.t + (** Raise an error about a library not found *) val library_not_found : ?context:Context_name.t -> ?hint:string -> string -> _ diff --git a/src/dune_lang/decoder.ml b/src/dune_lang/decoder.ml index eedacf3babd..8d0c6efc9e7 100644 --- a/src/dune_lang/decoder.ml +++ b/src/dune_lang/decoder.ml @@ -174,6 +174,19 @@ let set : type a b k. a Univ_map.Key.t -> a -> (b, k) parser -> (b, k) parser = | Fields (loc, cstr, uc) -> t (Fields (loc, cstr, Univ_map.set uc key v)) state +let update_var : + type a b k. + a Univ_map.Key.t + -> f:(a option -> a option) + -> (b, k) parser + -> (b, k) parser = + fun key ~f t ctx state -> + match ctx with + | Values (loc, cstr, uc) -> + t (Values (loc, cstr, Univ_map.update uc key ~f)) state + | Fields (loc, cstr, uc) -> + t (Fields (loc, cstr, Univ_map.update uc key ~f)) state + let set_many : type a k. Univ_map.t -> (a, k) parser -> (a, k) parser = fun map t ctx state -> match ctx with diff --git a/src/dune_lang/decoder.mli b/src/dune_lang/decoder.mli index 53834f27961..7aa052d433e 100644 --- a/src/dune_lang/decoder.mli +++ b/src/dune_lang/decoder.mli @@ -74,6 +74,12 @@ val get_all : (Univ_map.t, _) parser val set_many : Univ_map.t -> ('a, 'k) parser -> ('a, 'k) parser +val update_var : + 'a Univ_map.Key.t + -> f:('a option -> 'a option) + -> ('b, 'k) parser + -> ('b, 'k) parser + (** Return the location of the list currently being parsed. *) val loc : (Loc.t, _) parser diff --git a/src/dune_lang/lexer.mll b/src/dune_lang/lexer.mll index 24de3715df6..0b42ee85978 100644 --- a/src/dune_lang/lexer.mll +++ b/src/dune_lang/lexer.mll @@ -362,7 +362,7 @@ and template_variable = parse | Some "" -> error lexbuf "payload after : in variable cannot be empty" | p -> p in - Template.Var + Template.Pform { loc = { start = Lexing.lexeme_start_p lexbuf ; stop = Lexing.lexeme_end_p lexbuf diff --git a/src/dune_lang/template.ml b/src/dune_lang/template.ml index dd8c524e300..539c8d2050c 100644 --- a/src/dune_lang/template.ml +++ b/src/dune_lang/template.ml @@ -1,14 +1,55 @@ open! Stdune -type var = - { loc : Loc.t - ; name : string - ; payload : string option - } +module Pform = struct + type t = + { loc : Loc.t + ; name : string + ; payload : string option + } + + let loc (t : t) = t.loc + + let name { name; _ } = name + + let compare_no_loc v1 v2 = + match String.compare v1.name v2.name with + | (Ordering.Lt | Gt) as a -> a + | Eq -> Option.compare String.compare v1.payload v2.payload + + let full_name t = + match t.payload with + | None -> t.name + | Some v -> t.name ^ ":" ^ v + + let payload t = t.payload + + let to_string { loc = _; name; payload } = + let before, after = ("%{", "}") in + match payload with + | None -> before ^ name ^ after + | Some p -> before ^ name ^ ":" ^ p ^ after + + let to_dyn { loc = _; name; payload } = + let open Dyn.Encoder in + record [ ("name", string name); ("payload", option string payload) ] + + let with_name t ~name = { t with name } + + let describe t = + to_string + ( match t.payload with + | None -> t + | Some _ -> { t with payload = Some ".." } ) + + let describe_kind t = + match t.payload with + | None -> "variable" + | Some _ -> "macro" +end type part = | Text of string - | Var of var + | Pform of Pform.t type t = { quoted : bool @@ -16,17 +57,12 @@ type t = ; loc : Loc.t } -let compare_var_no_loc v1 v2 = - match String.compare v1.name v2.name with - | (Ordering.Lt | Gt) as a -> a - | Eq -> Option.compare String.compare v1.payload v2.payload - let compare_part p1 p2 = match (p1, p2) with | Text s1, Text s2 -> String.compare s1 s2 - | Var v1, Var v2 -> compare_var_no_loc v1 v2 - | Text _, Var _ -> Ordering.Lt - | Var _, Text _ -> Ordering.Gt + | Pform v1, Pform v2 -> Pform.compare_no_loc v1 v2 + | Text _, Pform _ -> Ordering.Lt + | Pform _, Text _ -> Ordering.Gt let compare_no_loc t1 t2 = match List.compare ~compare:compare_part t1.parts t2.parts with @@ -38,7 +74,7 @@ module Pp : sig end = struct let buf = Buffer.create 16 - let add_var { loc = _; name; payload } = + let add_pform { Pform.loc = _; name; payload } = let before, after = ("%{", "}") in Buffer.add_string buf before; Buffer.add_string buf name; @@ -75,9 +111,9 @@ end = struct else acc_text ^ s ) rest - | Var v :: rest -> + | Pform v :: rest -> commit_text acc_text; - add_var v; + add_pform v; add_parts "" rest in add_parts "" parts; @@ -87,12 +123,6 @@ end let to_string = Pp.to_string -let string_of_var { loc = _; name; payload } = - let before, after = ("%{", "}") in - match payload with - | None -> before ^ name ^ after - | Some p -> before ^ name ^ ":" ^ p ^ after - let pp t = Stdune.Pp.verbatim (Pp.to_string t) let pp_split_strings ppf (t : t) = @@ -100,10 +130,10 @@ let pp_split_strings ppf (t : t) = t.quoted || List.exists t.parts ~f:(function | Text s -> String.contains s '\n' - | Var _ -> false) + | Pform _ -> false) then ( List.iter t.parts ~f:(function - | Var s -> Format.pp_print_string ppf (string_of_var s) + | Pform s -> Format.pp_print_string ppf (Pform.to_string s) | Text s -> ( match String.split s ~on:'\n' with | [] -> assert false @@ -121,19 +151,15 @@ let remove_locs t = loc = Loc.none ; parts = List.map t.parts ~f:(function - | Var v -> Var { v with loc = Loc.none } + | Pform v -> Pform { v with loc = Loc.none } | Text _ as s -> s) } -let dyn_of_var { loc = _; name; payload } = - let open Dyn.Encoder in - record [ ("name", string name); ("payload", option string payload) ] - let dyn_of_part = let open Dyn.Encoder in function | Text s -> constr "Text" [ string s ] - | Var v -> constr "Var" [ dyn_of_var v ] + | Pform v -> constr "Pform" [ Pform.to_dyn v ] let to_dyn { quoted; parts; loc = _ } = let open Dyn.Encoder in diff --git a/src/dune_lang/template.mli b/src/dune_lang/template.mli index fe6bd3314d3..9fe44bbaeef 100644 --- a/src/dune_lang/template.mli +++ b/src/dune_lang/template.mli @@ -1,14 +1,35 @@ open! Stdune -type var = - { loc : Loc.t - ; name : string - ; payload : string option - } +module Pform : sig + type t = + { loc : Loc.t + ; name : string + ; payload : string option + } + + val to_dyn : t -> Dyn.t + + val name : t -> string + + val loc : t -> Loc.t + + val full_name : t -> string + + (** Variables do not have a payload. While macros always do. *) + val payload : t -> string option + + val with_name : t -> name:string -> t + + (** Describe what this percent form is *) + val describe : t -> string + + (** "macro" or "variable" *) + val describe_kind : t -> string +end type part = | Text of string - | Var of var + | Pform of Pform.t type t = { quoted : bool @@ -20,8 +41,6 @@ val to_string : t -> string val compare_no_loc : t -> t -> Ordering.t -val string_of_var : var -> string - val pp : t -> _ Pp.t val pp_split_strings : Format.formatter -> t -> unit diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index 9b7d44ad1ed..7c7cfff1356 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -637,7 +637,7 @@ end = struct open Outcome_unexp let ( +@+ ) acc fn = - if String_with_vars.is_var fn ~name:"null" then + if String_with_vars.is_pform fn (Var Dev_null) then acc else { acc with targets = fn :: acc.targets } @@ -651,7 +651,7 @@ end = struct let ( + t <> fn) } diff --git a/src/dune_rules/bindings.ml b/src/dune_rules/bindings.ml index e9267bf0c61..827894d8b64 100644 --- a/src/dune_rules/bindings.ml +++ b/src/dune_rules/bindings.ml @@ -72,3 +72,14 @@ let encode encode bindings = | Named (name, bindings) -> Dune_lang.List (Dune_lang.atom (":" ^ name) :: List.map ~f:encode bindings))) + +let var_names t = + List.filter_map t ~f:(function + | Unnamed _ -> None + | Named (s, _) -> Some s) + +let to_pform_map t = + Pform.Map.of_list_exn + (List.filter_map t ~f:(function + | Unnamed _ -> None + | Named (name, l) -> Some (Pform.Var (User_var name), l))) diff --git a/src/dune_rules/bindings.mli b/src/dune_rules/bindings.mli index cbdec2c8a47..023850aa587 100644 --- a/src/dune_rules/bindings.mli +++ b/src/dune_rules/bindings.mli @@ -27,3 +27,7 @@ val to_dyn : 'a Dyn.Encoder.t -> 'a t Dyn.Encoder.t val decode : 'a Dune_lang.Decoder.t -> 'a t Dune_lang.Decoder.t val encode : 'a Dune_lang.Encoder.t -> 'a t -> Dune_lang.t + +val var_names : _ t -> string list + +val to_pform_map : 'a t -> 'a list Pform.Map.t diff --git a/src/dune_rules/blang.ml b/src/dune_rules/blang.ml index e0d5423b836..ca97cf52d60 100644 --- a/src/dune_rules/blang.ml +++ b/src/dune_rules/blang.ml @@ -71,13 +71,13 @@ let rec to_dyn = let ops = [ ("=", Op.Eq); (">=", Gte); ("<=", Lt); (">", Gt); ("<", Lt); ("<>", Neq) ] -let decode = +let decode_gen decode_string = let open Dune_lang.Decoder in let ops = List.map ops ~f:(fun (name, op) -> ( name - , let+ x = String_with_vars.decode - and+ y = String_with_vars.decode in + , let+ x = decode_string + and+ y = decode_string in Compare (op, x, y) )) in let decode = @@ -86,25 +86,13 @@ let decode = ( ("or", repeat t >>| fun x -> Or x) :: ("and", repeat t >>| fun x -> And x) :: ops ) - <|> let+ v = String_with_vars.decode in + <|> let+ v = decode_string in Expr v) in let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 1) and+ decode = decode in decode -let rec fold_vars t ~init ~f = - match t with - | Const _ -> init - | Expr sw -> String_with_vars.fold_vars sw ~init ~f - | And l - | Or l -> - fold_vars_list l ~init ~f - | Compare (_, x, y) -> - String_with_vars.fold_vars y ~f - ~init:(String_with_vars.fold_vars x ~f ~init) +let decode = decode_gen String_with_vars.decode -and fold_vars_list ts ~init ~f = - match ts with - | [] -> init - | t :: ts -> fold_vars_list ts ~f ~init:(fold_vars t ~init ~f) +let decode_manually f = decode_gen (String_with_vars.decode_manually f) diff --git a/src/dune_rules/blang.mli b/src/dune_rules/blang.mli index 5039cf79c25..acb3db6bdf4 100644 --- a/src/dune_rules/blang.mli +++ b/src/dune_rules/blang.mli @@ -21,11 +21,14 @@ type t = val true_ : t -val fold_vars : t -> init:'a -> f:(String_with_vars.Var.t -> 'a -> 'a) -> 'a - val eval : t -> dir:Path.t -> f:Value.t list option String_with_vars.expander -> bool val to_dyn : t -> Dyn.t val decode : t Dune_lang.Decoder.t + +(** Resolve variables manually. For complex cases such as [enabled_if] *) +val decode_manually : + (Pform.Env.t -> Dune_lang.Template.Pform.t -> Pform.t) + -> t Dune_lang.Decoder.t diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index afa1a78b264..00030e1a888 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -884,14 +884,10 @@ module Library = struct let name = best_name conf in let enabled = let enabled_if_result = - Blang.eval conf.enabled_if ~dir:(Path.build dir) ~f:(fun v _ver -> - match - (String_with_vars.Var.name v, String_with_vars.Var.payload v) - with - | var, None -> - let value = Lib_config.get_for_enabled_if lib_config ~var in - Some [ String value ] - | _ -> None) + 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 + Some [ String value ]) in if not enabled_if_result then Lib_info.Enabled_status.Disabled_because_of_enabled_if @@ -1590,37 +1586,39 @@ module Rule = struct } let long_form = - let+ loc = loc - and+ action = field "action" (located Action_dune_lang.decode) - and+ targets = Targets.field - and+ deps = + let* deps = field "deps" (Bindings.decode Dep_conf.decode) ~default:Bindings.empty - and+ locks = field "locks" (repeat String_with_vars.decode) ~default:[] - and+ () = - let+ fallback = - field_b - ~check: - (Dune_lang.Syntax.renamed_in Stanza.syntax (1, 0) - ~to_:"(mode fallback)") - "fallback" - in - (* The "fallback" field was only allowed in jbuild file, which we don't - support anymore. So this cannot be [true]. We just keep the parser to - provide a nice error message for people switching from jbuilder to - dune. *) - assert (not fallback) - and+ mode = field "mode" Mode.decode ~default:Mode.Standard - and+ enabled_if = - Enabled_if.decode ~allowed_vars:Any ~since:(Some (1, 4)) () - and+ package = - field_o "package" - ( Dune_lang.Syntax.since Stanza.syntax (2, 0) - >>> Stanza_common.Pkg.decode ) - and+ alias = - field_o "alias" - (Dune_lang.Syntax.since Stanza.syntax (2, 0) >>> Alias.Name.decode) in - { targets; deps; action; mode; locks; loc; enabled_if; alias; package } + String_with_vars.add_user_vars_to_decoding_env (Bindings.var_names deps) + (let+ loc = loc + and+ action = field "action" (located Action_dune_lang.decode) + and+ targets = Targets.field + and+ locks = field "locks" (repeat String_with_vars.decode) ~default:[] + and+ () = + let+ fallback = + field_b + ~check: + (Dune_lang.Syntax.renamed_in Stanza.syntax (1, 0) + ~to_:"(mode fallback)") + "fallback" + in + (* The "fallback" field was only allowed in jbuild file, which we don't + support anymore. So this cannot be [true]. We just keep the parser + to provide a nice error message for people switching from jbuilder + to dune. *) + assert (not fallback) + and+ mode = field "mode" Mode.decode ~default:Mode.Standard + and+ enabled_if = + Enabled_if.decode ~allowed_vars:Any ~since:(Some (1, 4)) () + and+ package = + field_o "package" + ( Dune_lang.Syntax.since Stanza.syntax (2, 0) + >>> Stanza_common.Pkg.decode ) + and+ alias = + field_o "alias" + (Dune_lang.Syntax.since Stanza.syntax (2, 0) >>> Alias.Name.decode) + in + { targets; deps; action; mode; locks; loc; enabled_if; alias; package }) let decode = peek_exn >>= function @@ -1672,13 +1670,13 @@ module Rule = struct ; action = ( loc , Chdir - ( S.virt_var __POS__ "workspace_root" + ( S.virt_pform __POS__ (Var Workspace_root) , Run ( S.virt_text __POS__ "ocamllex" , [ S.virt_text __POS__ "-q" ; S.virt_text __POS__ "-o" - ; S.virt_var __POS__ "targets" - ; S.virt_var __POS__ "deps" + ; S.virt_pform __POS__ (Var Targets) + ; S.virt_pform __POS__ (Var Deps) ] ) ) ) ; mode ; locks = [] @@ -1702,10 +1700,10 @@ module Rule = struct ; action = ( loc , Chdir - ( S.virt_var __POS__ "workspace_root" + ( S.virt_pform __POS__ (Var Workspace_root) , Run ( S.virt_text __POS__ "ocamlyacc" - , [ S.virt_var __POS__ "deps" ] ) ) ) + , [ S.virt_pform __POS__ (Var Deps) ] ) ) ) ; mode ; locks = [] ; loc @@ -1766,21 +1764,28 @@ module Alias_conf = struct let decode = fields - (let+ name = field "name" Alias.Name.decode - and+ package = field_o "package" Stanza_common.Pkg.decode - and+ action = - field_o "action" - (let extra_info = "Use a rule stanza with the alias field instead" in - let* () = - Dune_lang.Syntax.deleted_in ~extra_info Stanza.syntax (2, 0) - in - located Action_dune_lang.decode) - and+ loc = loc - and+ locks = field "locks" (repeat String_with_vars.decode) ~default:[] - and+ deps = + (let* deps = field "deps" (Bindings.decode Dep_conf.decode) ~default:Bindings.empty - and+ enabled_if = field "enabled_if" Blang.decode ~default:Blang.true_ in - { name; deps; action; package; locks; enabled_if; loc }) + in + String_with_vars.add_user_vars_to_decoding_env (Bindings.var_names deps) + (let+ name = field "name" Alias.Name.decode + and+ package = field_o "package" Stanza_common.Pkg.decode + and+ action = + field_o "action" + (let extra_info = + "Use a rule stanza with the alias field instead" + in + let* () = + Dune_lang.Syntax.deleted_in ~extra_info Stanza.syntax (2, 0) + in + located Action_dune_lang.decode) + and+ loc = loc + and+ locks = + field "locks" (repeat String_with_vars.decode) ~default:[] + and+ enabled_if = + field "enabled_if" Blang.decode ~default:Blang.true_ + in + { name; deps; action; package; locks; enabled_if; loc })) end module Tests = struct @@ -1795,49 +1800,52 @@ module Tests = struct let gen_parse names = fields - (let+ buildable = Buildable.decode Executable - and+ link_flags = Ordered_set_lang.Unexpanded.field "link_flags" - and+ names = names - and+ package = field_o "package" Stanza_common.Pkg.decode - and+ locks = field "locks" (repeat String_with_vars.decode) ~default:[] - and+ modes = - field "modes" Executables.Link_mode.Map.decode - ~default:Executables.Link_mode.Map.default_for_tests - and+ deps = + (let* deps = field "deps" (Bindings.decode Dep_conf.decode) ~default:Bindings.empty - and+ enabled_if = - Enabled_if.decode ~allowed_vars:Any ~since:(Some (1, 4)) () - and+ action = - field_o "action" - ( Dune_lang.Syntax.since ~fatal:false Stanza.syntax (1, 2) - >>> Action_dune_lang.decode ) - and+ forbidden_libraries = - field "forbidden_libraries" - ( Dune_lang.Syntax.since Stanza.syntax (2, 0) - >>> repeat (located Lib_name.decode) ) - ~default:[] in - { exes = - { Executables.link_flags - ; link_deps = [] - ; modes - ; optional = false - ; buildable - ; names - ; package = None - ; promote = None - ; install_conf = None - ; embed_in_plugin_libraries = [] - ; forbidden_libraries - ; bootstrap_info = None - ; enabled_if - } - ; locks - ; package - ; deps - ; enabled_if - ; action - }) + String_with_vars.add_user_vars_to_decoding_env (Bindings.var_names deps) + (let+ buildable = Buildable.decode Executable + and+ link_flags = Ordered_set_lang.Unexpanded.field "link_flags" + and+ names = names + and+ package = field_o "package" Stanza_common.Pkg.decode + and+ locks = + field "locks" (repeat String_with_vars.decode) ~default:[] + and+ modes = + field "modes" Executables.Link_mode.Map.decode + ~default:Executables.Link_mode.Map.default_for_tests + and+ enabled_if = + Enabled_if.decode ~allowed_vars:Any ~since:(Some (1, 4)) () + and+ action = + field_o "action" + ( Dune_lang.Syntax.since ~fatal:false Stanza.syntax (1, 2) + >>> Action_dune_lang.decode ) + and+ forbidden_libraries = + field "forbidden_libraries" + ( Dune_lang.Syntax.since Stanza.syntax (2, 0) + >>> repeat (located Lib_name.decode) ) + ~default:[] + in + { exes = + { Executables.link_flags + ; link_deps = [] + ; modes + ; optional = false + ; buildable + ; names + ; package = None + ; promote = None + ; install_conf = None + ; embed_in_plugin_libraries = [] + ; forbidden_libraries + ; bootstrap_info = None + ; enabled_if + } + ; locks + ; package + ; deps + ; enabled_if + ; action + })) let multi = gen_parse (field "names" (repeat1 (located string))) diff --git a/src/dune_rules/dune_package.ml b/src/dune_rules/dune_package.ml index 223c329a937..535abbdcf6b 100644 --- a/src/dune_rules/dune_package.ml +++ b/src/dune_rules/dune_package.ml @@ -435,7 +435,10 @@ module Or_meta = struct let load p = let dir = Path.parent_exn p in - Vfile.load p ~f:(fun lang -> decode ~lang ~dir) + Vfile.load p ~f:(fun lang -> + String_with_vars.set_decoding_env + (Pform.Env.initial lang.version) + (decode ~lang ~dir)) let pp ~dune_version ppf t = let t = encode ~dune_version t in diff --git a/src/dune_rules/dune_rules.ml b/src/dune_rules/dune_rules.ml index f848537f1af..7722a2baa6f 100644 --- a/src/dune_rules/dune_rules.ml +++ b/src/dune_rules/dune_rules.ml @@ -29,8 +29,6 @@ module Opam_create = Opam_create module Link_mode = Link_mode module Utop = Utop module Setup = Setup -module Mode = Mode -module Cm_kind = Cm_kind module Meta = Meta module Toplevel = Toplevel diff --git a/src/dune_rules/enabled_if.ml b/src/dune_rules/enabled_if.ml index c9bd9517520..eeeb668a0f0 100644 --- a/src/dune_rules/enabled_if.ml +++ b/src/dune_rules/enabled_if.ml @@ -30,46 +30,44 @@ let common_vars ~since = common_vars_list) let emit_warning allowed_vars is_error var = - let loc = String_with_vars.Var.loc var in + let loc = Dune_lang.Template.Pform.loc var in let var_names = List.map ~f:fst allowed_vars in User_warning.emit ~loc ~is_error [ Pp.textf "Only %s variables are allowed in this 'enabled_if' field. If you \ think that %s should also be allowed, please file an issue about it." (String.enumerate_and var_names) - (String_with_vars.Var.name var) - ]; - return () + (Dune_lang.Template.Pform.name var) + ] let decode ~allowed_vars ?(is_error = true) ~since () = - let check_var ~allowed_vars var decoder_acc = - ( match String_with_vars.Var.payload var with - | Some _ -> emit_warning allowed_vars is_error var - | None -> ( - let name = String_with_vars.Var.name var in - match List.assoc allowed_vars name with - | None -> emit_warning allowed_vars is_error var - | Some min_ver -> - let* current_ver = Dune_lang.Syntax.get_exn Stanza.syntax in - if min_ver > current_ver then - let loc = String_with_vars.Var.loc var in - let what = "This variable" in - Dune_lang.Syntax.Error.since loc Stanza.syntax min_ver ~what - else - return () ) ) - >>> decoder_acc - in - let check_vars blang = + let decode = match allowed_vars with - | Any -> return blang + | Any -> Blang.decode | Only allowed_vars -> - Blang.fold_vars blang ~init:(return blang) ~f:(check_var ~allowed_vars) + Blang.decode_manually (fun env var -> + match Dune_lang.Template.Pform.payload var with + | Some _ -> + emit_warning allowed_vars is_error var; + Pform.Env.parse env var + | None -> ( + let name = Dune_lang.Template.Pform.name var in + match List.assoc allowed_vars name with + | None -> + emit_warning allowed_vars is_error var; + Pform.Env.parse env var + | Some min_ver -> + let current_ver = Pform.Env.syntax_version env in + if min_ver > current_ver then + let loc = Dune_lang.Template.Pform.loc var in + let what = Dune_lang.Template.Pform.describe var in + Dune_lang.Syntax.Error.since loc Stanza.syntax min_ver ~what + else + Pform.Env.unsafe_parse_without_checking_version env var )) in let decode = - ( match since with - | None -> Blang.decode - | Some since -> Dune_lang.Syntax.since Stanza.syntax since >>> Blang.decode - ) - >>= check_vars + match since with + | None -> decode + | Some since -> Dune_lang.Syntax.since Stanza.syntax since >>> decode in field "enabled_if" ~default:Blang.true_ decode diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index 846e3a4adca..9f956fa1aad 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -4,14 +4,14 @@ open Import module Expanded = struct type t = | Value of Value.t list - | Deferred of Pform.Expansion.t + | Deferred of Dune_lang.Template.Pform.t * Pform.t | Unknown | Error of User_message.t let to_value_opt t ~on_deferred = match t with | Value v -> Some v - | Deferred d -> on_deferred d + | Deferred (source, pform) -> on_deferred ~source pform | Error m -> raise (User_error.E m) | Unknown -> None @@ -32,7 +32,7 @@ type t = ; lib_artifacts_host : Artifacts.Public_libs.t ; bin_artifacts_host : Artifacts.Bin.t ; ocaml_config : Value.t list String.Map.t Lazy.t - ; bindings : Pform.Map.t + ; bindings : Value.t list Pform.Map.t ; scope : Scope.t ; scope_host : Scope.t ; c_compiler : string @@ -95,21 +95,20 @@ let extend_env t ~env = let add_bindings t ~bindings = { t with bindings = Pform.Map.superpose t.bindings bindings } -let expand_ocaml_config ocaml_config pform name = +let expand_ocaml_config ocaml_config ~source name = match String.Map.find ocaml_config name with | Some x -> x | None -> User_error.raise - ~loc:(String_with_vars.Var.loc pform) + ~loc:(Dune_lang.Template.Pform.loc source) [ Pp.textf "Unknown ocaml configuration variable %S" name ] -let expand_env t pform s : Value.t list option = +let expand_env t ~source s : Value.t list option = match String.rsplit2 s ~on:'=' with | None -> - User_error.raise - ~loc:(String_with_vars.Var.loc pform) + User_error.raise ~loc:source.Dune_lang.Template.Pform.loc [ Pp.textf "%s must always come with a default value." - (String_with_vars.Var.describe pform) + (Dune_lang.Template.Pform.describe source) ] ~hints:[ Pp.text "the syntax is %{env:VAR=DEFAULT-VALUE}" ] | Some (var, default) -> @@ -118,7 +117,7 @@ let expand_env t pform s : Value.t list option = else Some [ String (Option.value ~default (Env.get t.env var)) ] -let expand_version scope pform s = +let expand_version scope ~source s = let value_from_version = function | None -> [ Value.String "" ] | Some s -> [ String s ] @@ -133,8 +132,7 @@ let expand_version scope pform s = let libname = Lib_name.of_string s in let pkgname = Lib_name.package_name libname in if not (String.equal (Package.Name.to_string pkgname) s) then - User_error.raise - ~loc:(String_with_vars.Var.loc pform) + User_error.raise ~loc:source.Dune_lang.Template.Pform.loc [ Pp.textf "Library names are not allowed in this position. Only package \ names are allowed" @@ -142,27 +140,27 @@ let expand_version scope pform s = match Lib.DB.find (Scope.libs scope) libname with | Some lib -> value_from_version (Lib_info.version (Lib.info lib)) | None -> - User_error.raise - ~loc:(String_with_vars.Var.loc pform) + User_error.raise ~loc:source.Dune_lang.Template.Pform.loc [ Pp.textf "Package %S doesn't exist in the current project and isn't \ installed either." s ] ) -let isn't_allowed_in_this_position pform = - let loc = String_with_vars.Var.loc pform in - User_error.raise ~loc +let isn't_allowed_in_this_position_message ~source _pform = + User_error.make ~loc:source.Dune_lang.Template.Pform.loc [ Pp.textf "%s isn't allowed in this position" - (String_with_vars.Var.describe pform) + (Dune_lang.Template.Pform.describe source) ] -let expand_var_exn t var syn = - t.expand_var t var syn - |> Expanded.to_value_opt ~on_deferred:(fun _ -> - isn't_allowed_in_this_position var) +let isn't_allowed_in_this_position ~source pform = + raise (User_error.E (isn't_allowed_in_this_position_message ~source pform)) + +let expand_var_exn t ~source pform = + t.expand_var t ~source pform + |> Expanded.to_value_opt ~on_deferred:isn't_allowed_in_this_position -let expand_artifact ~dir ~loc t a s : Expanded.t = +let expand_artifact ~dir ~source t a s : Expanded.t = let path = Path.Build.relative dir s in let name = Path.Build.basename path in let dir = Path.Build.parent_exn path in @@ -176,68 +174,150 @@ let expand_artifact ~dir ~loc t a s : Expanded.t = let artifacts = lookup ~dir in match a with | Pform.Artifact.Mod kind -> ( - let name = Module_name.of_string_allow_invalid (loc, name) in + let name = + Module_name.of_string_allow_invalid + (Dune_lang.Template.Pform.loc source, name) + in match Ml_sources.Artifacts.lookup_module artifacts name with - | None -> does_not_exist ~loc ~what:"Module" (Module_name.to_string name) + | None -> + does_not_exist + ~loc:(Dune_lang.Template.Pform.loc source) + ~what:"Module" + (Module_name.to_string name) | Some (t, m) -> Value ( match Obj_dir.Module.cm_file t m ~kind with | None -> [ Value.String "" ] | Some path -> [ Value.Path (Path.build path) ] ) ) | Lib mode -> ( - let name = Lib_name.parse_string_exn (loc, name) in + let name = + Lib_name.parse_string_exn (Dune_lang.Template.Pform.loc source, name) + in match Ml_sources.Artifacts.lookup_library artifacts name with - | None -> does_not_exist ~loc ~what:"Library" (Lib_name.to_string name) + | None -> + does_not_exist + ~loc:(Dune_lang.Template.Pform.loc source) + ~what:"Library" (Lib_name.to_string name) | Some lib -> let archives = Mode.Dict.get (Lib_info.archives lib) mode in Value (Value.L.paths (List.map ~f:Path.build archives)) ) ) +let path_exp path = [ Value.Path path ] + +let str_exp str = [ Value.String str ] + +let path p = Expanded.Value (path_exp p) + +let string s = Expanded.Value (str_exp s) + +let strings l = Expanded.Value (Value.L.strings l) + +let get_prog = function + | Ok p -> Expanded.Value (path_exp p) + | Error err -> Error (Action.Prog.Not_found.user_message err) + +let c_compiler_and_flags (context : Context.t) = + Ocaml_config.c_compiler context.ocaml_config + :: Ocaml_config.ocamlc_cflags context.ocaml_config + +let common_static_expand ~ocaml_config ~(context : Context.t) ~source + (pform : Pform.t) = + match pform with + | Var Ocaml -> Some (get_prog context.ocaml) + | Var Ocamlc -> Some (path context.ocamlc) + | Var Ocamlopt -> Some (get_prog context.ocamlopt) + | Var Make -> + Some + ( match context.which "make" with + | None -> + Error + (Utils.program_not_found_message ~context:context.name + ~loc:(Some (Dune_lang.Template.Pform.loc source)) + "make") + | Some p -> path p ) + | Var Cpp -> Some (strings (c_compiler_and_flags context @ [ "-E" ])) + | Var Pa_cpp -> + Some + (strings + ( c_compiler_and_flags context + @ [ "-undef"; "-traditional"; "-x"; "c"; "-E" ] )) + | Var Arch_sixtyfour -> Some (string (string_of_bool context.arch_sixtyfour)) + | Var Ocaml_bin_dir -> Some (Value [ Dir context.ocaml_bin ]) + | Var Ocaml_version -> + Some (string (Ocaml_config.version_string context.ocaml_config)) + | Var Ocaml_stdlib_dir -> Some (string (Path.to_string context.stdlib_dir)) + | Var Dev_null -> Some (string (Path.to_string Config.dev_null)) + | Var Ext_obj -> Some (string context.lib_config.ext_obj) + | Var Ext_asm -> Some (string (Ocaml_config.ext_asm context.ocaml_config)) + | Var Ext_lib -> Some (string context.lib_config.ext_lib) + | Var Ext_dll -> Some (string context.lib_config.ext_dll) + | Var Ext_exe -> Some (string (Ocaml_config.ext_exe context.ocaml_config)) + | Var Ext_plugin -> + Some + (string + (Mode.plugin_ext + ( if Ocaml_config.natdynlink_supported context.ocaml_config then + Mode.Native + else + Mode.Byte ))) + | Var Profile -> Some (string (Profile.to_string context.profile)) + | Var Workspace_root -> + Some (Value [ Value.Dir (Path.build context.build_dir) ]) + | Var Context_name -> Some (string (Context_name.to_string context.name)) + | Var Os_type -> + Some + (string + (Ocaml_config.Os_type.to_string + (Ocaml_config.os_type context.ocaml_config))) + | Var Architecture -> + Some (string (Ocaml_config.architecture context.ocaml_config)) + | Var System -> Some (string (Ocaml_config.system context.ocaml_config)) + | Var Model -> Some (string (Ocaml_config.model context.ocaml_config)) + | Var Ignoring_promoted_rules -> + Some (string (string_of_bool !Clflags.ignore_promoted_rules)) + | Macro (Ocaml_config, s) -> + Some (Value (expand_ocaml_config (Lazy.force ocaml_config) ~source s)) + | Var (Library_name | Impl_files | Intf_files | Input_file | Test) -> + (* These are always set locally. If they are not part of [bindings], then + they were used in a context where they shouldn't. *) + Some (Error (isn't_allowed_in_this_position_message ~source pform)) + | _ -> None + (* This expansion function only expands the most "static" variables and macros. These are all known without building anything, evaluating any dune files, and they do not introduce any dependencies. *) let static_expand - ({ ocaml_config; bindings; dir; scope; artifacts_dynamic; _ } as t) var - syntax_version : Expanded.t = - match Pform.Map.expand bindings var syntax_version with - | None -> Unknown - | Some expand -> ( - match expand with - | Pform.Expansion.Var (Values l) -> Value l - | Macro (Ocaml_config, s) -> - Value (expand_ocaml_config (Lazy.force ocaml_config) var s) - | Macro (Env, s) -> Expanded.of_value_opt (expand_env t var s) - | Macro (Version, s) -> Value (expand_version scope var s) - | Var Project_root -> Value [ Value.Dir (Path.build (Scope.root scope)) ] - | Macro (Artifact a, s) when not artifacts_dynamic -> - let loc = String_with_vars.Var.loc var in - expand_artifact ~dir ~loc t a s - | expansion -> Deferred expansion ) - -let cc_cxx_bindings = - Pform.Map.of_list_exn [ ("cc", Pform.Var.Cc); ("cxx", Pform.Var.Cxx) ] + ({ ocaml_config; bindings; dir; scope; artifacts_dynamic; context; _ } as t) + ~source (pform : Pform.t) : Expanded.t = + match Pform.Map.find bindings pform with + | Some x -> Expanded.Value x + | None -> ( + match common_static_expand ~ocaml_config ~context ~source pform with + | Some x -> x + | None -> ( + match pform with + | Var Project_root -> Value [ Value.Dir (Path.build (Scope.root scope)) ] + | Macro (Env, s) -> Expanded.of_value_opt (expand_env t ~source s) + | Macro (Version, s) -> Value (expand_version scope ~source s) + | Macro (Artifact a, s) when not artifacts_dynamic -> + expand_artifact ~dir ~source t a s + | pform -> Deferred (source, pform) ) ) let make ~scope ~scope_host ~(context : Context.t) ~lib_artifacts ~lib_artifacts_host ~bin_artifacts_host ~find_package = let ocaml_config = lazy (make_ocaml_config context.ocaml_config) in - let dir = context.build_dir in - let bindings = - let context = Pform.Map.create ~context in - Pform.Map.superpose context cc_cxx_bindings - in - let env = context.env in - let c_compiler = Ocaml_config.c_compiler context.ocaml_config in - { dir + { dir = context.build_dir ; hidden_env = Env.Var.Set.empty - ; env + ; env = context.env ; ocaml_config - ; bindings + ; bindings = Pform.Map.empty ; scope ; scope_host ; lib_artifacts ; lib_artifacts_host ; bin_artifacts_host ; expand_var = static_expand - ; c_compiler + ; c_compiler = Ocaml_config.c_compiler context.ocaml_config ; context ; artifacts_dynamic = false ; lookup_artifacts = None @@ -290,14 +370,15 @@ type reduced_var_result = let expand_with_reduced_var_set ~(context : Context.t) = let ocaml_config = lazy (make_ocaml_config context.ocaml_config) in - let bindings = Pform.Map.create ~context in - fun var syn -> - match Pform.Map.expand bindings var syn with - | None -> Unknown - | Some (Var (Values l)) -> Expanded l - | Some (Macro (Ocaml_config, s)) -> - Expanded (expand_ocaml_config (Lazy.force ocaml_config) var s) - | Some _ -> Restricted + fun ~source pform -> + match common_static_expand ~ocaml_config ~context ~source pform with + | None -> Restricted + | Some x -> ( + match x with + | Value x -> Expanded x + | Error e -> raise (User_error.E e) + | Deferred (source, pform) -> isn't_allowed_in_this_position ~source pform + | Unknown -> Unknown ) module Resolved_forms = struct type t = @@ -308,14 +389,14 @@ module Resolved_forms = struct ; (* Static deps from %{...} variables. For instance %{exe:...} *) mutable sdeps : Path.Set.t ; (* Dynamic deps from %{...} variables. For instance %{read:...} *) - mutable ddeps : Value.t list Action_builder.t Pform.Expansion.Map.t + mutable ddeps : Value.t list Action_builder.t Pform.Map.t } let create () = { failure = None ; lib_deps = Lib_name.Map.empty ; sdeps = Path.Set.empty - ; ddeps = Pform.Expansion.Map.empty + ; ddeps = Pform.Map.empty } let add_lib_dep acc lib kind = @@ -328,7 +409,7 @@ module Resolved_forms = struct let to_build t = let open Action_builder.O in - let ddeps = Pform.Expansion.Map.to_list t.ddeps in + let ddeps = Pform.Map.to_list t.ddeps in let+ () = Action_builder.label (Lib_deps_info.Label t.lib_deps) and+ () = Action_builder.path_set t.sdeps and+ values = Action_builder.all (List.map ddeps ~f:snd) @@ -337,14 +418,10 @@ module Resolved_forms = struct | None -> Action_builder.return () | Some fail -> Action_builder.fail fail in - List.fold_left2 ddeps values ~init:Pform.Expansion.Map.empty - ~f:(fun acc (var, _) value -> Pform.Expansion.Map.add_exn acc var value) + List.fold_left2 ddeps values ~init:Pform.Map.empty + ~f:(fun acc (var, _) value -> Pform.Map.add_exn acc var value) end -let path_exp path = [ Value.Path path ] - -let str_exp str = [ Value.String str ] - let parse_lib_file ~loc s = match String.lsplit2 s ~on:':' with | None -> User_error.raise ~loc [ Pp.textf "invalid %%{lib:...} form: %s" s ] @@ -361,19 +438,14 @@ type expand_result = | Static of Value.t list | Dynamic of Value.t list Action_builder.t -let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t - expansion = - let loc = String_with_vars.Var.loc pform in - let relative d s = Path.build (Path.Build.relative ~error_loc:loc d s) in +let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) t ~source + (pform : Pform.t) = + let relative d s = + Path.build + (Path.Build.relative ~error_loc:(Dune_lang.Template.Pform.loc source) d s) + in let open Action_builder.O in - match (expansion : Pform.Expansion.t) with - | Var - ( Project_root | First_dep | Deps | Targets | Target | Named_local - | Values _ ) - | Macro ((Ocaml_config | Env | Version), _) -> - (* Some of these values are filled by [static_expand], others are bindings - introduced by the user and handled specifically elsewhere *) - assert false + match pform with | Var Cc -> Dynamic (cc t ~dir).c | Var Cxx -> Dynamic (cc t ~dir).cxx | Macro (Artifact a, s) -> @@ -381,12 +453,12 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t Action_builder.dyn_paths (let+ values = Action_builder.delayed (fun () -> - match expand_artifact ~dir ~loc t a s with + match expand_artifact ~dir ~source t a s with | Value v -> v | Error msg -> raise (User_error.E msg) | Unknown | Deferred _ -> - isn't_allowed_in_this_position pform) + isn't_allowed_in_this_position ~source pform) in (values, Value.L.deps_only values)) in @@ -396,10 +468,14 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t | Macro (Dep, s) -> Static (path_exp (relative dir s)) | Macro (Bin, s) -> Static - ( Artifacts.Bin.binary ~loc:(Some loc) t.bin_artifacts_host s + ( Artifacts.Bin.binary + ~loc:(Some (Dune_lang.Template.Pform.loc source)) + t.bin_artifacts_host s |> Action.Prog.ok_exn |> path_exp ) | Macro (Lib { lib_exec; lib_private }, s) -> ( - let lib, file = parse_lib_file ~loc s in + let lib, file = + parse_lib_file ~loc:(Dune_lang.Template.Pform.loc source) s + in Resolved_forms.add_lib_dep acc lib dep_kind; let scope = if lib_exec then @@ -410,7 +486,10 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t match if lib_private then let open Result.O in - let* lib = Lib.DB.resolve (Scope.libs scope) (loc, lib) in + 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 @@ -423,7 +502,8 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t else Error (User_error.E - (User_error.make ~loc + (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 \ @@ -447,7 +527,9 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t else t.lib_artifacts in - Artifacts.Public_libs.file_of_lib artifacts ~loc ~lib ~file + Artifacts.Public_libs.file_of_lib artifacts + ~loc:(Dune_lang.Template.Pform.loc source) + ~lib ~file with | Ok path -> if (not lib_exec) || (not Sys.win32) || Filename.extension s = ".exe" then @@ -471,7 +553,8 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t | false -> if Lib.DB.available (Scope.libs scope) lib then User_error.E - (User_error.make ~loc + (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 \ @@ -485,7 +568,9 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t else e ) ) | Macro (Lib_available, s) -> - let lib = Lib_name.parse_string_exn (loc, s) in + let lib = + Lib_name.parse_string_exn (Dune_lang.Template.Pform.loc source, s) + in Resolved_forms.add_lib_dep acc lib Optional; Static (Lib.DB.available (Scope.libs t.scope) lib |> string_of_bool |> str_exp) @@ -508,6 +593,7 @@ let expand_and_record_generic acc ~dep_kind ~(dir : Path.Build.t) ~pform t Action_builder.map (Action_builder.strings path) ~f:Value.L.strings in Dynamic data + | _ -> assert false let gen_with_record_deps ~expand t resolved_forms ~dep_kind = let expand_var = @@ -525,17 +611,17 @@ module Deps_like : sig -> f:(t -> 'a Action_builder.t) -> 'a Action_builder.t end = struct - let expand_and_record_static acc ~dep_kind ~(dir : Path.Build.t) ~pform t - expansion = - match expand_and_record_generic acc ~dep_kind ~dir ~pform t expansion with + let expand_and_record_static acc ~dep_kind ~(dir : Path.Build.t) t ~source + pform = + match expand_and_record_generic acc ~dep_kind ~dir t ~source pform with | Static l -> l - | Dynamic _ -> isn't_allowed_in_this_position pform + | Dynamic _ -> isn't_allowed_in_this_position ~source pform - let expand_no_ddeps acc ~dir ~dep_kind ~expand_var t pform syntax_version = + let expand_no_ddeps acc ~dir ~dep_kind ~expand_var t ~source pform = let res = - expand_var t pform syntax_version - |> Expanded.to_value_opt ~on_deferred:(fun exp -> - Some (expand_and_record_static acc ~dep_kind ~dir ~pform t exp)) + expand_var t ~source pform + |> Expanded.to_value_opt ~on_deferred:(fun ~source pform -> + Some (expand_and_record_static acc ~dep_kind ~dir t ~source pform)) in Resolved_forms.add_value_opt acc res; Expanded.of_value_opt res @@ -548,7 +634,7 @@ end = struct let build = f t in let+ x = build and+ dynamic_expansions = Resolved_forms.to_build forms in - if Pform.Expansion.Map.is_empty dynamic_expansions then + if Pform.Map.is_empty dynamic_expansions then x else Code_error.raise "ddeps are not allowed in this position" [] @@ -568,50 +654,36 @@ module Action_like : sig end = struct (* Expand variables that correspond to user defined variables, deps, and target(s) fields *) - let expand_special_vars ~deps_written_by_user ~var pform = - let key = String_with_vars.Var.full_name var in - let loc = String_with_vars.Var.loc var in + let expand_special_vars ~deps_written_by_user ~source:_ pform = match pform with - | Pform.Expansion.Var Named_local -> ( - match Bindings.find deps_written_by_user key with + | Pform.Var (User_var var) -> ( + match Bindings.find deps_written_by_user var with | None -> Code_error.raise "Local named variable not present in named deps" - [ ("pform", String_with_vars.Var.to_dyn var) + [ ("pform", Pform.to_dyn pform) ; ( "deps_written_by_user" , Bindings.to_dyn Path.to_dyn deps_written_by_user ) ] | Some x -> Value.L.paths x ) | Var Deps -> deps_written_by_user |> Bindings.to_list |> Value.L.paths - | Var First_dep -> ( - match deps_written_by_user with - | Named _ :: _ -> - (* This case is not possible: ${<} only exist in jbuild files and named - dependencies are not available in jbuild files *) - assert false - | Unnamed v :: _ -> [ Path v ] - | [] -> - User_warning.emit ~loc - [ Pp.textf "Variable '%s' used with no explicit dependencies" key ]; - [ Value.String "" ] ) + | Var First_dep -> + (* This case is for %{<} which was only allowed inside jbuild files *) + assert false | _ -> - Code_error.raise "Unexpected variable in step2" - [ ("var", String_with_vars.Var.to_dyn var) ] + Code_error.raise "Unexpected percent form in step2" + [ ("pform", Pform.to_dyn pform) ] (* Responsible for the 2nd phase expansions of dynamic dependencies. After we've discovered all Action_builder.t values, waited for them to build, we can finally substitute them back form the dynamic_expansions map *) - let expand_ddeps_and_bindings - ~(dynamic_expansions : Value.t list Pform.Expansion.Map.t) - ~(deps_written_by_user : Path.t Bindings.t) ~expand_var t var - syntax_version = - let open Option.O in - (let* key = Pform.Map.expand t.bindings var syntax_version in - match Pform.Expansion.Map.find dynamic_expansions key with - | Some v -> Some v - | None -> - expand_var t var syntax_version - |> Expanded.to_value_opt ~on_deferred:(fun exp -> - Some (expand_special_vars ~deps_written_by_user ~var exp))) + let expand_ddeps_and_bindings ~(dynamic_expansions : Value.t list Pform.Map.t) + ~(deps_written_by_user : Path.t Bindings.t) ~expand_var t ~source pform = + ( match Pform.Map.find dynamic_expansions pform with + | Some v -> Some v + | None -> + expand_var t ~source pform + |> Expanded.to_value_opt ~on_deferred:(fun ~source pform -> + Some (expand_special_vars ~deps_written_by_user ~source pform)) ) |> Expanded.of_value_opt let add_ddeps_and_bindings t ~dynamic_expansions ~deps_written_by_user = @@ -623,50 +695,47 @@ end = struct (* Expansion where every Dynamic value is not expanded and recorded to be substituted later. *) - let expand_and_record_dynamic acc ~dep_kind ~(dir : Path.Build.t) ~pform t - expansion = - match expand_and_record_generic acc ~dep_kind ~dir ~pform t expansion with + let expand_and_record_dynamic acc ~dep_kind ~(dir : Path.Build.t) t ~source + pform = + match expand_and_record_generic acc ~dep_kind ~dir t ~source pform with | Static l -> Some l | Dynamic dep -> - acc.ddeps <- Pform.Expansion.Map.set acc.ddeps expansion dep; + acc.ddeps <- Pform.Map.set acc.ddeps pform dep; None | exception (User_error.E _ as e) -> acc.failure <- Some { fail = (fun () -> raise e) }; None let expand_and_record_deps acc ~(dir : Path.Build.t) ~dep_kind - ~targets_written_by_user ~expand_var t pform syntax_version = + ~targets_written_by_user ~expand_var t + ~(source : Dune_lang.Template.Pform.t) pform = let res = let targets ~(multiplicity : Targets.Multiplicity.t) = - let loc = String_with_vars.Var.loc pform in match (targets_written_by_user : Targets.Or_forbidden.t) with | Targets.Or_forbidden.Targets Infer -> - User_error.raise ~loc + User_error.raise ~loc:source.loc [ Pp.textf "You cannot use %s with inferred rules." - (String_with_vars.Var.describe pform) + (Dune_lang.Template.Pform.describe source) ] | Forbidden context -> - User_error.raise ~loc - [ Pp.textf "You cannot use %s in %s." - (String_with_vars.Var.describe pform) - context + User_error.raise ~loc:source.loc + [ Pp.textf "You cannot use %s in %s." context + (Dune_lang.Template.Pform.describe source) ] | Targets.Or_forbidden.Targets (Static { targets; multiplicity = field_multiplicity }) -> - Targets.Multiplicity.check_variable_matches_field ~loc + Targets.Multiplicity.check_variable_matches_field ~loc:source.loc ~field:field_multiplicity ~variable:multiplicity; (* XXX hack to signal no dep *) List.map ~f:Path.build targets |> Value.L.dirs in - expand_var t pform syntax_version - |> Expanded.to_value_opt - ~on_deferred:(fun (expansion : Pform.Expansion.t) -> - match expansion with - | Var (First_dep | Deps | Named_local) -> None + expand_var t ~source pform + |> Expanded.to_value_opt ~on_deferred:(fun ~source pform -> + match pform with + | Var (First_dep | Deps | User_var _) -> None | Var Targets -> Some (targets ~multiplicity:Multiple) | Var Target -> Some (targets ~multiplicity:One) - | _ -> - expand_and_record_dynamic acc ~dep_kind ~dir ~pform t expansion) + | _ -> expand_and_record_dynamic acc ~dep_kind ~dir t ~source pform) in Resolved_forms.add_value_opt acc res; Expanded.of_value_opt res diff --git a/src/dune_rules/expander.mli b/src/dune_rules/expander.mli index 80c5b3fa68f..0fbd54247d0 100644 --- a/src/dune_rules/expander.mli +++ b/src/dune_rules/expander.mli @@ -59,7 +59,7 @@ val set_lookup_ml_sources : (** Expander needs to expand custom bindings sometimes. For example, the name of the library for the action that runs inline tests. This is the place to add such bindings. *) -val add_bindings : t -> bindings:Pform.Map.t -> t +val add_bindings : t -> bindings:Value.t list Pform.Map.t -> t val extend_env : t -> env:Env.t -> t diff --git a/src/dune_rules/file_binding.ml b/src/dune_rules/file_binding.ml index d63f704cf18..99eb28cf530 100644 --- a/src/dune_rules/file_binding.ml +++ b/src/dune_rules/file_binding.ml @@ -71,7 +71,7 @@ module Unexpanded = struct and+ version = Dune_lang.Syntax.get_exn Stanza.syntax in if (not is_atom) && version < (1, 6) then let what = - ( if String_with_vars.has_vars s then + ( if String_with_vars.has_pforms s then "variables" else "quoted strings" ) diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index 83af7a8b087..f1d4ba3c5d3 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -231,10 +231,6 @@ include Sub_system.Register_end_point (struct Module.generated ~src_dir name in let modules = Modules.singleton_exe main_module in - let bindings = - Pform.Map.singleton "library-name" - (Values [ String (Lib_name.Local.to_string (snd lib.name)) ]) - in let expander = Super_context.expander sctx ~dir in let runner_libs = let open Result.O in @@ -257,13 +253,12 @@ include Sub_system.Register_end_point (struct |> Option.value_exn |> Path.as_in_build_dir_exn in let files ml_kind = - Pform.Var.Values - (Value.L.paths - (List.filter_map source_modules ~f:(Module.file ~ml_kind))) + Value.L.paths + (List.filter_map source_modules ~f:(Module.file ~ml_kind)) in let bindings = Pform.Map.of_list_exn - [ ("impl-files", files Impl); ("intf-files", files Intf) ] + [ (Var Impl_files, files Impl); (Var Intf_files, files Intf) ] in let expander = Expander.add_bindings expander ~bindings in let action = @@ -318,6 +313,10 @@ include Sub_system.Register_end_point (struct List.map backends ~f:(fun backend -> backend.Backend.info.flags) @ [ info.flags ] in + let bindings = + Pform.Map.singleton (Var Library_name) + [ Value.String (Lib_name.Local.to_string (snd lib.name)) ] + in let expander = Expander.add_bindings expander ~bindings in let open Action_builder.O in let+ l = diff --git a/src/dune_rules/lib_config.ml b/src/dune_rules/lib_config.ml index 7774feb1ede..baa41e942bc 100644 --- a/src/dune_rules/lib_config.ml +++ b/src/dune_rules/lib_config.ml @@ -20,35 +20,30 @@ type t = ; context_name : Context_name.t } -let var_map = - [ ("architecture", fun t -> t.architecture) - ; ("system", fun t -> t.system) - ; ("model", fun t -> t.model) - ; ("os_type", fun t -> Ocaml_config.Os_type.to_string t.os_type) - ; ("ccomp_type", fun t -> Ocaml_config.Ccomp_type.to_string t.ccomp_type) - ; ("profile", fun t -> Profile.to_string t.profile) - ; ("ocaml_version", fun t -> t.ocaml_version_string) - ; ("context_name", fun t -> Context_name.to_string t.context_name) - ] - let allowed_in_enabled_if = - List.map var_map ~f:(fun (var, _) -> - let min_version = - match var with - | "profile" -> (2, 5) - | "ccomp_type" -> (2, 0) - | "ocaml_version" -> (2, 5) - | "context_name" -> (2, 8) - | _ -> (1, 0) - in - (var, min_version)) + [ ("architecture", (1, 0)) + ; ("system", (1, 0)) + ; ("model", (1, 0)) + ; ("os_type", (1, 0)) + ; ("ccomp_type", (2, 0)) + ; ("profile", (2, 5)) + ; ("ocaml_version", (2, 5)) + ; ("context_name", (2, 8)) + ] -let get_for_enabled_if t ~var = - match List.assoc var_map var with - | Some f -> f t - | None -> +let get_for_enabled_if t (pform : Pform.t) = + match pform with + | Var Architecture -> t.architecture + | Var System -> t.system + | Var Model -> t.model + | Var Os_type -> Ocaml_config.Os_type.to_string t.os_type + | Var Ccomp_type -> Ocaml_config.Ccomp_type.to_string t.ccomp_type + | Var Profile -> Profile.to_string t.profile + | Var Ocaml_version -> t.ocaml_version_string + | Var Context_name -> Context_name.to_string t.context_name + | _ -> Code_error.raise "Lib_config.get_for_enabled_if: var not allowed" - [ ("var", Dyn.Encoder.string var) ] + [ ("var", Pform.to_dyn pform) ] let linker_can_create_empty_archives t = match t.ccomp_type with diff --git a/src/dune_rules/lib_config.mli b/src/dune_rules/lib_config.mli index cdd8af736ff..070859cd9d0 100644 --- a/src/dune_rules/lib_config.mli +++ b/src/dune_rules/lib_config.mli @@ -22,6 +22,6 @@ type t = val allowed_in_enabled_if : (string * Dune_lang.Syntax.Version.t) list -val get_for_enabled_if : t -> var:string -> string +val get_for_enabled_if : t -> Pform.t -> string val linker_can_create_empty_archives : t -> bool diff --git a/src/dune_rules/merlin.ml b/src/dune_rules/merlin.ml index 5c2056f3bec..f3a3e7179dd 100644 --- a/src/dune_rules/merlin.ml +++ b/src/dune_rules/merlin.ml @@ -170,7 +170,7 @@ module Unprocessed = struct let args = let open Option.O in let* args, input_file = List.destruct_last args in - if String_with_vars.is_var input_file ~name:"input-file" then + if String_with_vars.is_pform input_file (Var Input_file) then Some args else None diff --git a/src/dune_rules/pform.ml b/src/dune_rules/pform.ml deleted file mode 100644 index 2cdc6fb597f..00000000000 --- a/src/dune_rules/pform.ml +++ /dev/null @@ -1,460 +0,0 @@ -open! Dune_engine -open! Stdune -open Import - -module Var = struct - type t = - | Values of Value.t list - | Project_root - | First_dep - | Deps - | Targets - | Target - | Named_local - | Cc - | Cxx - - let compare x y = - match (x, y) with - | Values v1, Values v2 -> List.compare ~compare:Value.compare v1 v2 - | Values _, _ -> Lt - | _, Values _ -> Gt - | Project_root, Project_root -> Eq - | Project_root, _ -> Lt - | _, Project_root -> Gt - | First_dep, First_dep -> Eq - | First_dep, _ -> Lt - | _, First_dep -> Gt - | Deps, Deps -> Eq - | Deps, _ -> Lt - | _, Deps -> Gt - | Named_local, Named_local -> Eq - | Named_local, _ -> Lt - | _, Named_local -> Gt - | Targets, Targets -> Eq - | Targets, _ -> Lt - | _, Targets -> Gt - | Target, Target -> Eq - | Target, _ -> Lt - | _, Target -> Gt - | Cc, Cc -> Eq - | Cc, _ -> Lt - | _, Cc -> Gt - | Cxx, Cxx -> Eq - - let to_dyn = - let open Dyn.Encoder in - function - | Values values -> constr "Values" [ list Value.to_dyn values ] - | Project_root -> string "Project_root" - | First_dep -> string "First_dep" - | Deps -> string "Deps" - | Targets -> string "Targets" - | Target -> string "Target" - | Named_local -> string "Named_local" - | Cc -> string "cc" - | Cxx -> string "cxx" -end - -module Artifact = struct - type t = - | Mod of Cm_kind.t - | Lib of Mode.t - - let compare x y = - match (x, y) with - | Mod x, Mod y -> Cm_kind.compare x y - | Mod _, _ -> Lt - | _, Mod _ -> Gt - | Lib x, Lib y -> Mode.compare x y - - let ext = function - | Mod cm_kind -> Cm_kind.ext cm_kind - | Lib mode -> Mode.compiled_lib_ext mode - - let all = - List.map ~f:(fun kind -> Mod kind) Cm_kind.all - @ List.map ~f:(fun mode -> Lib mode) Mode.all - - let to_dyn a = - let open Dyn.Encoder in - match a with - | Mod cm_kind -> constr "Mod" [ Cm_kind.to_dyn cm_kind ] - | Lib mode -> constr "Lib" [ Mode.to_dyn mode ] -end - -module Macro = struct - type t = - | Exe - | Dep - | Bin - | Lib of - { lib_exec : bool - ; lib_private : bool - } - | Lib_available - | Version - | Read - | Read_strings - | Read_lines - | Path_no_dep - | Ocaml_config - | Env - | Artifact of Artifact.t - - let compare x y = - match (x, y) with - | Exe, Exe -> Eq - | Exe, _ -> Lt - | _, Exe -> Gt - | Dep, Dep -> Eq - | Dep, _ -> Lt - | _, Dep -> Gt - | Bin, Bin -> Eq - | Bin, _ -> Lt - | _, Bin -> Gt - | Lib { lib_exec; lib_private }, Lib y -> - Tuple.T2.compare Bool.compare Bool.compare (lib_exec, lib_private) - (y.lib_exec, y.lib_private) - | Lib _, _ -> Lt - | _, Lib _ -> Gt - | Lib_available, Lib_available -> Eq - | Lib_available, _ -> Lt - | _, Lib_available -> Gt - | Version, Version -> Eq - | Version, _ -> Lt - | _, Version -> Gt - | Read, Read -> Eq - | Read, _ -> Lt - | _, Read -> Gt - | Read_strings, Read_strings -> Eq - | Read_strings, _ -> Lt - | _, Read_strings -> Gt - | Read_lines, Read_lines -> Eq - | Read_lines, _ -> Lt - | _, Read_lines -> Gt - | Path_no_dep, Path_no_dep -> Eq - | Path_no_dep, _ -> Lt - | _, Path_no_dep -> Gt - | Ocaml_config, Ocaml_config -> Eq - | Ocaml_config, _ -> Lt - | _, Ocaml_config -> Gt - | Env, Env -> Eq - | Env, _ -> Lt - | _, Env -> Gt - | Artifact x, Artifact y -> Artifact.compare x y - - let to_dyn = - let open Dyn.Encoder in - function - | Exe -> string "Exe" - | Dep -> string "Dep" - | Bin -> string "Bin" - | Lib { lib_private; lib_exec } -> - constr "Lib" - [ record - [ ("lib_exec", bool lib_exec); ("lib_private", bool lib_private) ] - ] - | Lib_available -> string "Lib_available" - | Version -> string "Version" - | Read -> string "Read" - | Read_strings -> string "Read_strings" - | Read_lines -> string "Read_lines" - | Path_no_dep -> string "Path_no_dep" - | Ocaml_config -> string "Ocaml_config" - | Env -> string "Env" - | Artifact ext -> constr "Artifact" [ Artifact.to_dyn ext ] -end - -module Expansion = struct - module T = struct - type t = - | Var of Var.t - | Macro of Macro.t * string - - let to_dyn e = - let open Dyn.Encoder in - match e with - | Var v -> pair string Var.to_dyn ("Var", v) - | Macro (m, s) -> triple string Macro.to_dyn string ("Macro", m, s) - - let compare x y = - match (x, y) with - | Var x, Var y -> Var.compare x y - | Var _, _ -> Lt - | _, Var _ -> Gt - | Macro (m1, s1), Macro (m2, s2) -> - Tuple.T2.compare Macro.compare String.compare (m1, s1) (m2, s2) - end - - include T - module Map = Map.Make (T) -end - -type 'a t = - | No_info of 'a - | Since of 'a * Dune_lang.Syntax.Version.t - | Deleted_in of - 'a * Dune_lang.Syntax.Version.t * User_message.Style.t Pp.t list - | Renamed_in of Dune_lang.Syntax.Version.t * string - -let values v = No_info (Var.Values v) - -let renamed_in ~new_name ~version = Renamed_in (version, new_name) - -let deleted_in ~version ?(repl = []) kind = Deleted_in (kind, version, repl) - -let since ~version v = Since (v, version) - -type 'a pform = 'a t - -let to_dyn f = - let open Dyn.Encoder in - function - | No_info x -> constr "No_info" [ f x ] - | Since (x, v) -> constr "Since" [ f x; Dune_lang.Syntax.Version.to_dyn v ] - | Deleted_in (x, v, repl) -> - constr "Deleted_in" - [ f x - ; Dune_lang.Syntax.Version.to_dyn v - ; List - (List.map repl ~f:(fun pp -> - Dyn.String (Format.asprintf "%a" Pp.to_fmt pp))) - ] - | Renamed_in (v, s) -> - constr "Renamed_in" [ Dune_lang.Syntax.Version.to_dyn v; string s ] - -module Map = struct - type 'a map = 'a t String.Map.t - - type t = - { vars : Var.t map - ; macros : Macro.t map - } - - let static_vars = - String.Map.of_list_exn - [ ("targets", since ~version:(1, 0) Var.Targets) - ; ("target", since ~version:(1, 11) Var.Target) - ; ("deps", since ~version:(1, 0) Var.Deps) - ; ("project_root", since ~version:(1, 0) Var.Project_root) - ; ( "<" - , deleted_in Var.First_dep ~version:(1, 0) - ~repl: - [ Pp.text - "Use a named dependency instead:\n\n\ - \ (deps (:x ) ...)\n\ - \ ... %{x} ..." - ] ) - ; ("@", renamed_in ~version:(1, 0) ~new_name:"targets") - ; ("^", renamed_in ~version:(1, 0) ~new_name:"deps") - ; ("SCOPE_ROOT", renamed_in ~version:(1, 0) ~new_name:"project_root") - ] - - let macros = - let macro (x : Macro.t) = No_info x in - let artifact x = - (String.drop (Artifact.ext x) 1, since ~version:(2, 0) (Macro.Artifact x)) - in - String.Map.of_list_exn - ( [ ("exe", macro Exe) - ; ("bin", macro Bin) - ; ("lib", macro (Lib { lib_exec = false; lib_private = false })) - ; ("libexec", macro (Lib { lib_exec = true; lib_private = false })) - ; ( "lib-private" - , since ~version:(2, 1) - (Macro.Lib { lib_exec = false; lib_private = true }) ) - ; ( "libexec-private" - , since ~version:(2, 1) - (Macro.Lib { lib_exec = true; lib_private = true }) ) - ; ("lib-available", macro Lib_available) - ; ("version", macro Version) - ; ("read", macro Read) - ; ("read-lines", macro Read_lines) - ; ("read-strings", macro Read_strings) - ; ("dep", since ~version:(1, 0) Macro.Dep) - ; ("path", renamed_in ~version:(1, 0) ~new_name:"dep") - ; ("findlib", renamed_in ~version:(1, 0) ~new_name:"lib") - ; ("path-no-dep", deleted_in ~version:(1, 0) Macro.Path_no_dep) - ; ("ocaml-config", macro Ocaml_config) - ; ("env", since ~version:(1, 4) Macro.Env) - ] - @ List.map ~f:artifact Artifact.all ) - - let create ~(context : Context.t) = - let ocamlopt = - match context.ocamlopt with - | Error _ -> Path.relative context.ocaml_bin "ocamlopt" - | Ok p -> p - in - let ocaml = - match context.ocaml with - | Error _ -> Path.relative context.ocaml_bin "ocaml" - | Ok p -> p - in - let string s = values [ Value.String s ] in - let path p = values [ Value.Path p ] in - let make = - match Bin.make ~path:(Env.path context.env) with - | None -> string "make" - | Some p -> path p - in - let cflags = Ocaml_config.ocamlc_cflags context.ocaml_config in - let strings s = values (Value.L.strings s) in - let lowercased = - let c_compiler = Ocaml_config.c_compiler context.ocaml_config in - [ ("cpp", strings ((c_compiler :: cflags) @ [ "-E" ])) - ; ( "pa_cpp" - , strings - ( (c_compiler :: cflags) - @ [ "-undef"; "-traditional"; "-x"; "c"; "-E" ] ) ) - ; ("ocaml", path ocaml) - ; ("ocamlc", path context.ocamlc) - ; ("ocamlopt", path ocamlopt) - ; ("arch_sixtyfour", string (string_of_bool context.arch_sixtyfour)) - ; ("make", make) - ; ("cc", No_info Var.Cc) - ; ("cxx", No_info Var.Cxx) - ] - in - let uppercased = - List.map lowercased ~f:(fun (k, _) -> - (String.uppercase k, renamed_in ~new_name:k ~version:(1, 0))) - in - let other = - let ext_asm = Ocaml_config.ext_asm context.ocaml_config in - let ext_exe = Ocaml_config.ext_exe context.ocaml_config in - let os_type = Ocaml_config.os_type context.ocaml_config in - let architecture = Ocaml_config.architecture context.ocaml_config in - let model = Ocaml_config.model context.ocaml_config in - let system = Ocaml_config.system context.ocaml_config in - let version_string = Ocaml_config.version_string context.ocaml_config in - let ext_plugin = - Mode.plugin_ext - ( if Ocaml_config.natdynlink_supported context.ocaml_config then - Mode.Native - else - Mode.Byte ) - in - [ ("-verbose", values []) - ; ("ocaml_bin", values [ Dir context.ocaml_bin ]) - ; ("ocaml_version", string version_string) - ; ("ocaml_where", string (Path.to_string context.stdlib_dir)) - ; ("null", string (Path.to_string Config.dev_null)) - ; ("ext_obj", string context.lib_config.ext_obj) - ; ("ext_asm", string ext_asm) - ; ("ext_lib", string context.lib_config.ext_lib) - ; ("ext_dll", string context.lib_config.ext_dll) - ; ("ext_exe", string ext_exe) - ; ("ext_plugin", since ~version:(2, 4) (Var.Values [ String ext_plugin ])) - ; ("profile", string (Profile.to_string context.profile)) - ; ("workspace_root", values [ Value.Dir (Path.build context.build_dir) ]) - ; ("context_name", string (Context_name.to_string context.name)) - ; ("ROOT", renamed_in ~version:(1, 0) ~new_name:"workspace_root") - ; ( "os_type" - , since ~version:(1, 10) - (Var.Values [ String (Ocaml_config.Os_type.to_string os_type) ]) ) - ; ( "architecture" - , since ~version:(1, 10) (Var.Values [ String architecture ]) ) - ; ("system", since ~version:(1, 10) (Var.Values [ String system ])) - ; ("model", since ~version:(1, 10) (Var.Values [ String model ])) - ; ( "ignoring_promoted_rules" - , since ~version:(1, 10) - (Var.Values - [ String (string_of_bool !Clflags.ignore_promoted_rules) ]) ) - ] - in - { vars = - String.Map.superpose static_vars - (String.Map.of_list_exn - (List.concat [ lowercased; uppercased; other ])) - ; macros - } - - let superpose a b = - { vars = String.Map.superpose a.vars b.vars - ; macros = String.Map.superpose a.macros b.macros - } - - let rec expand map ~syntax_version ~pform = - let open Option.O in - let open Dune_lang.Syntax.Version.Infix in - let name = String_with_vars.Var.name pform in - let* v = String.Map.find map name in - let describe = String_with_vars.Var.describe in - match v with - | No_info v -> Some v - | Since (v, min_version) -> - if syntax_version >= min_version then - Some v - else - Dune_lang.Syntax.Error.since - (String_with_vars.Var.loc pform) - Stanza.syntax min_version ~what:(describe pform) - | Renamed_in (in_version, new_name) -> - if syntax_version >= in_version then - Dune_lang.Syntax.Error.renamed_in - (String_with_vars.Var.loc pform) - Stanza.syntax syntax_version ~what:(describe pform) - ~to_:(describe (String_with_vars.Var.with_name pform ~name:new_name)) - else - expand map ~syntax_version:in_version - ~pform:(String_with_vars.Var.with_name pform ~name:new_name) - | Deleted_in (v, in_version, repl) -> - if syntax_version < in_version then - Some v - else - Dune_lang.Syntax.Error.deleted_in - (String_with_vars.Var.loc pform) - Stanza.syntax in_version ~what:(describe pform) ~repl - - let expand t pform syntax_version = - match String_with_vars.Var.payload pform with - | None -> - Option.map (expand t.vars ~syntax_version ~pform) ~f:(fun x -> - Expansion.Var x) - | Some payload -> - Option.map (expand t.macros ~syntax_version ~pform) ~f:(fun x -> - Expansion.Macro (x, payload)) - - let to_dyn { vars; macros } = - let open Dyn.Encoder in - record - [ ("vars", String.Map.to_dyn (to_dyn Var.to_dyn) vars) - ; ("macros", String.Map.to_dyn (to_dyn Macro.to_dyn) macros) - ] - - let empty = { vars = String.Map.empty; macros = String.Map.empty } - - let singleton k v = - { vars = String.Map.singleton k (No_info v); macros = String.Map.empty } - - let of_list_exn pforms = - { vars = String.Map.of_list_map_exn ~f:(fun (k, x) -> (k, No_info x)) pforms - ; macros = String.Map.empty - } - - let of_bindings bindings = - { vars = - Bindings.fold bindings ~init:String.Map.empty ~f:(fun x acc -> - match x with - | Unnamed _ -> acc - | Named (s, _) -> String.Map.set acc s (No_info Var.Named_local)) - ; macros = String.Map.empty - } - - let input_file path = - let value = Var.Values (Value.L.paths [ path ]) in - { vars = - String.Map.of_list_exn - [ ("input-file", since ~version:(1, 0) value) - ; ("<", renamed_in ~new_name:"input-file" ~version:(1, 0)) - ] - ; macros = String.Map.empty - } - - type stamp = (string * Var.t pform) list * (string * Macro.t pform) list - - let to_stamp { vars; macros } : stamp = - (String.Map.to_list vars, String.Map.to_list macros) -end diff --git a/src/dune_rules/pform.mli b/src/dune_rules/pform.mli deleted file mode 100644 index 1fb98bda614..00000000000 --- a/src/dune_rules/pform.mli +++ /dev/null @@ -1,83 +0,0 @@ -open! Dune_engine -open! Stdune -open Import - -module Var : sig - type t = - | Values of Value.t list - | Project_root - | First_dep - | Deps - | Targets - | Target - | Named_local - | Cc - | Cxx -end - -module Artifact : sig - type t = - | Mod of Cm_kind.t - | Lib of Mode.t - - val ext : t -> string -end - -module Macro : sig - type t = - | Exe - | Dep - | Bin - (* All four combinations are allowed and correspond to variables [lib], - [libexec], [lib-private], and [libexec-private]. *) - | Lib of - { lib_exec : bool - ; lib_private : bool - } - | Lib_available - | Version - | Read - | Read_strings - | Read_lines - | Path_no_dep - | Ocaml_config - | Env - | Artifact of Artifact.t -end - -module Expansion : sig - type t = - | Var of Var.t - | Macro of Macro.t * string - - val to_dyn : t -> Dyn.t - - module Map : Map.S with type key = t -end - -module Map : sig - type t - - val create : context:Context.t -> t - - val superpose : t -> t -> t - - (** Map with all named values as [Named_local] *) - val of_bindings : _ Bindings.t -> t - - val singleton : string -> Var.t -> t - - val of_list_exn : (string * Var.t) list -> t - - val input_file : Path.t -> t - - val expand : t -> Expansion.t option String_with_vars.expander - - val empty : t - - type stamp - - val to_stamp : t -> stamp - - val to_dyn : t -> Dyn.t -end diff --git a/src/dune_rules/preprocess.ml b/src/dune_rules/preprocess.ml index 26a4519b5ed..2a0dc6820a1 100644 --- a/src/dune_rules/preprocess.ml +++ b/src/dune_rules/preprocess.ml @@ -26,7 +26,7 @@ module Pps_and_flags = struct if syntax_version < (1, 10) then List.iter ~f:(fun flag -> - if String_with_vars.has_vars flag then + if String_with_vars.has_pforms flag then Dune_lang.Syntax.Error.since (String_with_vars.loc flag) Stanza.syntax (1, 10) ~what:"Using variables in pps flags") @@ -95,7 +95,15 @@ let decode = sum [ ("no_preprocessing", return No_preprocessing) ; ( "action" - , located Action_dune_lang.decode >>| fun (loc, x) -> Action (loc, x) ) + , let+ loc, x = + located + (update_var String_with_vars.decoding_env_key + ~f:(fun env -> + let env = Option.value_exn env in + Some (Pform.Env.lt_renamed_input_file env)) + Action_dune_lang.decode) + in + Action (loc, x) ) ; ( "pps" , let+ loc = loc and+ pps, flags = Pps_and_flags.decode in @@ -150,7 +158,7 @@ let remove_future_syntax (t : 'a t) ~(for_ : Pp_flag_consumer.t) v : Action ( loc , Run - ( String_with_vars.make_var loc "bin" ~payload:"ocaml-syntax-shims" + ( String_with_vars.make_pform loc (Macro (Bin, "ocaml-syntax-shims")) , ( match for_ with | Compiler -> [ String_with_vars.make_text loc "-dump-ast" ] | Merlin -> @@ -165,7 +173,7 @@ let remove_future_syntax (t : 'a t) ~(for_ : Pp_flag_consumer.t) v : Hopefully this will be fixed in merlin before that becomes a necessity. *) [] ) - @ [ String_with_vars.make_var loc "input-file" ] ) ) + @ [ String_with_vars.make_pform loc (Var Input_file) ] ) ) module Per_module = struct module Per_module = Module_name.Per_item diff --git a/src/dune_rules/preprocessing.ml b/src/dune_rules/preprocessing.ml index 6e80cea053a..4ff31f48774 100644 --- a/src/dune_rules/preprocessing.ml +++ b/src/dune_rules/preprocessing.ml @@ -393,7 +393,7 @@ let get_cookies ~loc ~expander ~lib_name libs = | Some lib_name -> let library_name = Lib_name.Local.to_string lib_name in let bindings = - Pform.Map.singleton "library_name" (Values [ String library_name ]) + Pform.Map.singleton (Var Library_name) [ Value.String library_name ] in ( Expander.add_bindings expander ~bindings , Some ("library-name", (library_name, Lib_name.of_local (loc, lib_name))) @@ -452,7 +452,8 @@ let ppx_driver_and_flags sctx ~lib_name ~expander ~scope ~loc ~flags pps = in (exe, driver, flags) -let workspace_root_var = String_with_vars.virt_var __POS__ "workspace_root" +let workspace_root_var = + String_with_vars.virt_pform __POS__ (Var Workspace_root) let promote_correction fn build ~suffix = Action_builder.progn @@ -467,7 +468,9 @@ let chdir action = Action_unexpanded.Chdir (workspace_root_var, action) let action_for_pp ~dep_kind ~loc ~expander ~action ~src ~target = let action = chdir action in - let bindings = Pform.Map.input_file (Path.build src) in + let bindings = + Pform.Map.singleton (Var Input_file) [ Value.Path (Path.build src) ] + in let expander = Expander.add_bindings expander ~bindings in let targets = Targets.Or_forbidden.Forbidden "preprocessing actions" in let targets_dir = Option.value ~default:src target |> Path.Build.parent_exn in @@ -503,7 +506,7 @@ let setup_dialect_rules sctx ~dir ~dep_kind ~expander (m : Module.t) = let add_corrected_suffix_binding expander suffix = let bindings = - Pform.Map.singleton "corrected-suffix" (Values [ String suffix ]) + Pform.Map.singleton (Var Corrected_suffix) [ Value.String suffix ] in Expander.add_bindings expander ~bindings diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 52a0d020a93..6550b209d1f 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -10,7 +10,7 @@ module Alias_rules = struct ( "user-alias" , Bindings.map ~f:Dep_conf.remove_locs deps , Option.map ~f:Action_unexpanded.remove_locs action - , Option.map extra_bindings ~f:Pform.Map.to_stamp ) + , Option.map extra_bindings ~f:Pform.Map.to_list ) let add sctx ~alias ~stamp ~loc ~locks build = let dir = Alias.dir alias in @@ -23,12 +23,6 @@ end let interpret_locks ~expander = List.map ~f:(Expander.expand_path expander) -let dep_bindings ~extra_bindings deps = - let base = Pform.Map.of_bindings deps in - match extra_bindings with - | Some bindings -> Pform.Map.superpose base bindings - | None -> base - let check_filename = let not_in_dir ~error_loc s = User_error.raise ~loc:error_loc @@ -104,8 +98,11 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = in Static { multiplicity; targets } ) in - let bindings = dep_bindings ~extra_bindings rule.deps in - let expander = Expander.add_bindings expander ~bindings in + let expander = + match extra_bindings with + | None -> expander + | Some bindings -> Expander.add_bindings expander ~bindings + in let action = Dep_conf_eval.named ~expander rule.deps |> Action_unexpanded.expand (snd rule.action) ~loc:(fst rule.action) @@ -227,8 +224,11 @@ let alias sctx ?extra_bindings ~dir ~expander (alias_conf : Alias_conf.t) = let+ (_ : Path.t Bindings.t) = x in Action.empty) | Some (loc, action) -> - let bindings = dep_bindings ~extra_bindings alias_conf.deps in - let expander = Expander.add_bindings expander ~bindings in + let expander = + match extra_bindings with + | None -> expander + | Some bindings -> Expander.add_bindings expander ~bindings + in Action_unexpanded.expand action ~loc ~expander ~dep_kind:Required ~targets:(Forbidden "aliases") ~targets_dir:dir in diff --git a/src/dune_rules/simple_rules.mli b/src/dune_rules/simple_rules.mli index cb8d8ed5d1e..9cb3e0850be 100644 --- a/src/dune_rules/simple_rules.mli +++ b/src/dune_rules/simple_rules.mli @@ -26,7 +26,7 @@ end (** Interpret a [(rule ...)] stanza and return the targets it produces. *) val user_rule : Super_context.t - -> ?extra_bindings:Pform.Map.t + -> ?extra_bindings:Value.t list Pform.Map.t -> dir:Path.Build.t -> expander:Expander.t -> Rule.t @@ -44,7 +44,7 @@ val copy_files : (** Interpret an [(alias ...)] stanza. *) val alias : Super_context.t - -> ?extra_bindings:Pform.Map.t + -> ?extra_bindings:Value.t list Pform.Map.t -> dir:Path.Build.t -> expander:Expander.t -> Alias_conf.t diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index 5b88e50efe4..8c3591ff1c9 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -85,7 +85,7 @@ end = struct get_node t ~dir |> Env_node.inline_tests |> Dune_env.Stanza.Inline_tests.to_string in - Pform.Map.singleton "inline_tests" (Values [ String str ]) + Pform.Map.singleton (Var Inline_tests) [ Value.String str ] in expander_for_artifacts |> Expander.add_bindings ~bindings @@ -406,23 +406,22 @@ let get_installed_binaries stanzas ~(context : Context.t) = let expand_str ~dir sw = let dir = Path.build dir in String_with_vars.expand ~dir ~mode:Single - ~f:(fun var ver -> - match expander var ver with + ~f:(fun ~source pform -> + match expander ~source pform with | Unknown -> None | Expanded x -> Some x | Restricted -> - User_error.raise - ~loc:(String_with_vars.Var.loc var) + User_error.raise ~loc:source.loc [ Pp.textf "%s isn't allowed in this position." - (String_with_vars.Var.describe var) + (Dune_lang.Template.Pform.describe source) ]) sw |> Value.to_string ~dir in let expand_str_partial ~dir sw = String_with_vars.partial_expand ~dir ~mode:Single - ~f:(fun var ver -> - match expander var ver with + ~f:(fun ~source pform -> + match expander ~source pform with | Expander.Unknown | Restricted -> None diff --git a/src/dune_rules/targets.ml b/src/dune_rules/targets.ml index 6223b548e59..9fdd25da905 100644 --- a/src/dune_rules/targets.ml +++ b/src/dune_rules/targets.ml @@ -46,7 +46,7 @@ let decode_static = and+ targets = repeat String_with_vars.decode in if syntax_version < (1, 3) then List.iter targets ~f:(fun target -> - if String_with_vars.has_vars target then + if String_with_vars.has_pforms target then Dune_lang.Syntax.Error.since (String_with_vars.loc target) Stanza.syntax (1, 3) ~what:"Using variables in the targets field"); diff --git a/src/dune_rules/test_rules.ml b/src/dune_rules/test_rules.ml index 946790f65fa..27ec8081946 100644 --- a/src/dune_rules/test_rules.ml +++ b/src/dune_rules/test_rules.ml @@ -17,19 +17,19 @@ let rules (t : Dune_file.Tests.t) ~sctx ~dir ~scope ~expander ~dir_contents = `Regular in List.iter t.exes.names ~f:(fun (loc, s) -> - let test_var_name = "test" in + let test_pform = Pform.Var Test in let run_action = match t.action with | Some a -> a | None -> - Action_unexpanded.Run (String_with_vars.make_var loc test_var_name, []) + Action_unexpanded.Run (String_with_vars.make_pform loc test_pform, []) in let extra_bindings = let test_exe = s ^ ".exe" in let test_exe_path = Expander.map_exe expander (Path.relative (Path.build dir) test_exe) in - Pform.Map.singleton test_var_name (Values [ Path test_exe_path ]) + Pform.Map.singleton test_pform [ Value.Path test_exe_path ] in let add_alias ~loc ~action ~locks = let alias = diff --git a/src/dune_rules/workspace.ml b/src/dune_rules/workspace.ml index fd201e0a879..2b5ae3154ae 100644 --- a/src/dune_rules/workspace.ml +++ b/src/dune_rules/workspace.ml @@ -458,7 +458,10 @@ let load ?x ?profile ?instrument_with p = if Dune_lexer.eof_reached lb then default ?x ?profile ?instrument_with () else - parse_contents lb ~f:(fun _lang -> t ?x ?profile ?instrument_with ())) + parse_contents lb ~f:(fun lang -> + String_with_vars.set_decoding_env + (Pform.Env.initial lang.version) + (t ?x ?profile ?instrument_with ()))) let default ?x ?profile ?instrument_with () = let x = Option.map x ~f:(fun s -> Context.Target.Named s) in diff --git a/src/dune_util/value.ml b/src/dune_util/value.ml index 929665d1501..34359a877f1 100644 --- a/src/dune_util/value.ml +++ b/src/dune_util/value.ml @@ -46,6 +46,8 @@ let to_path ?error_loc t ~dir = p module L = struct + let to_dyn t = Dyn.List (List.map t ~f:to_dyn) + let to_strings t ~dir = List.map t ~f:(to_string ~dir) let compare_vals ~dir = List.compare ~compare:(compare_vals ~dir) diff --git a/src/dune_util/value.mli b/src/dune_util/value.mli index b1b71947887..43987394c07 100644 --- a/src/dune_util/value.mli +++ b/src/dune_util/value.mli @@ -24,6 +24,8 @@ module L : sig ]} *) val compare_vals : dir:Path.t -> t list -> t list -> Ordering.t + val to_dyn : t list -> Dyn.t + val paths : Path.t list -> t list val deps_only : t list -> Path.t list diff --git a/src/jbuild_support/string_with_vars.ml b/src/jbuild_support/string_with_vars.ml index 1c101136950..e90c43aea54 100644 --- a/src/jbuild_support/string_with_vars.ml +++ b/src/jbuild_support/string_with_vars.ml @@ -177,7 +177,14 @@ let upgrade_to_dune s ~loc ~quoted ~allow_first_dep_var = | Var v -> ( match map_var v with | None -> Text (string_of_var v) - | Some name -> Var { name; payload = v.payload; loc = v.loc } ) + | Some name -> Pform { name; payload = v.payload; loc = v.loc } ) in let parts = List.map (parse ~loc s) ~f:map_part in - { Dune_lang.Template.quoted; parts; loc } + match + List.fold_left parts ~init:(Some "") ~f:(fun acc part -> + match (acc, part) with + | Some s, Dune_lang.Template.Text s' -> Some (s ^ s') + | _ -> None) + with + | None -> Dune_lang.Ast.Template { quoted; parts; loc } + | Some s -> Dune_lang.Ast.atom_or_quoted_string loc s diff --git a/src/jbuild_support/string_with_vars.mli b/src/jbuild_support/string_with_vars.mli index 96d45af7dce..aaaf09219f7 100644 --- a/src/jbuild_support/string_with_vars.mli +++ b/src/jbuild_support/string_with_vars.mli @@ -8,4 +8,4 @@ val upgrade_to_dune : -> loc:Loc.t -> quoted:bool -> allow_first_dep_var:bool - -> Dune_lang.Template.t + -> Dune_lang.Ast.t diff --git a/src/upgrader/dune_upgrader.ml b/src/upgrader/dune_upgrader.ml index a6ed969498e..c411c7c2cef 100644 --- a/src/upgrader/dune_upgrader.ml +++ b/src/upgrader/dune_upgrader.ml @@ -174,7 +174,7 @@ module V1 = struct | List (_, l) -> List.exists l ~f:uses_first_dep_var | Template x -> List.exists x.parts ~f:(function - | Dune_lang.Template.Var { name = "<"; _ } -> true + | Dune_lang.Template.Pform { name = "<"; _ } -> true | _ -> false) in let rec map_var ~f = function @@ -185,15 +185,13 @@ module V1 = struct { x with parts = List.map x.parts ~f:(function - | Dune_lang.Template.Var v -> f v + | Dune_lang.Template.Pform v -> f v | x -> x) } in let upgrade_string s ~loc ~quoted = Jbuild_support.String_with_vars.upgrade_to_dune s ~loc ~quoted ~allow_first_dep_var:true - |> String_with_vars.make |> String_with_vars.encode - |> Dune_lang.Ast.add_loc ~loc in let rec upgrade = function | Atom (loc, A s) -> ( @@ -228,8 +226,9 @@ module V1 = struct | (Atom (_, A ("preprocess" | "lint")) as field) :: rest -> upgrade field :: List.map rest ~f:(fun x -> - map_var (upgrade x) ~f:(fun (v : Dune_lang.Template.var) -> - Dune_lang.Template.Var + map_var (upgrade x) + ~f:(fun (v : Dune_lang.Template.Pform.t) -> + Dune_lang.Template.Pform ( if v.name = "<" then { v with name = "input-file" } else diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/driver-tests/dune b/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/driver-tests/dune index 852c7cb3f61..4a0c142d024 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/driver-tests/dune +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/driver-tests/dune @@ -48,7 +48,7 @@ (library (name ppx4) (public_name foo.ppx4) - (kind (ppx_rewriter (cookies (germany "lebkuchen") (library-name "%{library_name}")))) + (kind (ppx_rewriter (cookies (germany "lebkuchen") (library-name "%{library-name}")))) (modules ()) (libraries driver2)) diff --git a/test/blackbox-tests/test-cases/enabled_if-exec.t/run.t b/test/blackbox-tests/test-cases/enabled_if-exec.t/run.t index e12366ce5cb..4daf7ce6370 100644 --- a/test/blackbox-tests/test-cases/enabled_if-exec.t/run.t +++ b/test/blackbox-tests/test-cases/enabled_if-exec.t/run.t @@ -76,7 +76,7 @@ For dune < 2.7 context_name is not allowed File "dune", line 3, characters 18-31: 3 | (enabled_if (= %{context_name} "default"))) ^^^^^^^^^^^^^ - Error: This variable is only available since version 2.7 of the dune + Error: %{context_name} is only available since version 2.7 of the dune language. Please update your dune-project file to have (lang dune 2.7). [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 d90c54b7850..d8cf485c2cc 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,10 +6,10 @@ dune < 2.8 > EOF $ dune build bar - File "dune", line 8, characters 18-31: - 8 | (enabled_if (= %{context_name} "not-the-context-name"))) - ^^^^^^^^^^^^^ - Error: This variable is only available since version 2.8 of the dune + File "dune", line 13, characters 18-31: + 13 | (enabled_if (= %{context_name} "default"))) + ^^^^^^^^^^^^^ + 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). [1] diff --git a/test/blackbox-tests/test-cases/install-with-var.t/run.t b/test/blackbox-tests/test-cases/install-with-var.t/run.t index 68ec9154079..7db9208aa7f 100644 --- a/test/blackbox-tests/test-cases/install-with-var.t/run.t +++ b/test/blackbox-tests/test-cases/install-with-var.t/run.t @@ -69,7 +69,7 @@ extension of [src]: 3 | (files (%{env:FOO=foobar.txt} as foo.txt)) ^^^^^^^^^^^^^^^^^^^ Error: Because this file is installed in the 'bin' section, you cannot use - the variable %{env:..} in its basename. + the macro %{env:..} in its basename. [1] This is fine if the destination extension is already .exe: @@ -108,7 +108,7 @@ Exe basename needs to be fully known if dst is missing though: 3 | (files %{env:FOO=foobar}.txt) ^^^^^^^^^^^^^^^ Error: Because this file is installed in the 'bin' section, you cannot use - the variable %{env:..} in its basename. + the macro %{env:..} in its basename. [1] When basename is fully known, all is well: diff --git a/test/blackbox-tests/test-cases/invalid-pform.t/run.t b/test/blackbox-tests/test-cases/invalid-pform.t/run.t index c1296bb3122..590f7b0d2cd 100644 --- a/test/blackbox-tests/test-cases/invalid-pform.t/run.t +++ b/test/blackbox-tests/test-cases/invalid-pform.t/run.t @@ -6,5 +6,5 @@ When an unknown pform is encountered, a sensible message is printed out. File "dune", line 1, characters 14-22: 1 | (rule (copy %{unknown} x.ml)) ^^^^^^^^ - Error: Unknown variable "unknown" + Error: Unknown variable %{unknown} [1] diff --git a/test/blackbox-tests/test-cases/output-obj.t/run.t b/test/blackbox-tests/test-cases/output-obj.t/run.t index 8387a3cc550..84960fd77bf 100644 --- a/test/blackbox-tests/test-cases/output-obj.t/run.t +++ b/test/blackbox-tests/test-cases/output-obj.t/run.t @@ -1,12 +1,12 @@ $ dune build @all $ dune build @runtest 2>&1 | dune_cmd sanitize static alias runtest - OK: ./static.exe - dynamic alias runtest - OK: ./dynamic.exe ./test.bc$ext_dll + OK: ./static.bc dynamic alias runtest OK: ./dynamic.exe ./test$ext_dll + dynamic alias runtest + OK: ./dynamic.exe ./test.bc$ext_dll static alias runtest - OK: ./static.bc + OK: ./static.exe # static alias runtest # OK: ./static.bc.c.exe diff --git a/test/blackbox-tests/test-cases/path-variables.t/dune/dune b/test/blackbox-tests/test-cases/path-variables.t/dune/dune index 106c811680b..1a7f8700342 100644 --- a/test/blackbox-tests/test-cases/path-variables.t/dune/dune +++ b/test/blackbox-tests/test-cases/path-variables.t/dune/dune @@ -3,12 +3,3 @@ (alias (name test-dep) (action (cat %{dep:generated-file}))) - -(alias - (name test-path) - (action - (chdir - sub-tree/dir - (progn - (echo "%{path:file-that-does-not-exist}\n") - (echo "%{path:.}\n"))))) diff --git a/test/blackbox-tests/test-cases/path-variables.t/run.t b/test/blackbox-tests/test-cases/path-variables.t/run.t index 105ec716e80..1d7b45df9bf 100644 --- a/test/blackbox-tests/test-cases/path-variables.t/run.t +++ b/test/blackbox-tests/test-cases/path-variables.t/run.t @@ -8,12 +8,7 @@ In expands to a file name, and registers this as a dependency. $ dune build --root dune @test-dep Entering directory 'dune' - File "dune", line 13, characters 17-47: - 13 | (echo "%{path:file-that-does-not-exist}\n") - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: %{path:..} was renamed to '%{dep:..}' in the 1.0 version of the dune - language - [1] + dynamic-contents %{path-no-dep:string} --------------------- diff --git a/test/blackbox-tests/test-cases/shadow-bindings.t/run.t b/test/blackbox-tests/test-cases/shadow-bindings.t/run.t index 285e17f11c7..ed2707d6d0f 100644 --- a/test/blackbox-tests/test-cases/shadow-bindings.t/run.t +++ b/test/blackbox-tests/test-cases/shadow-bindings.t/run.t @@ -1,5 +1,5 @@ Bindings introduced by user dependencies should shadow existing bindings $ dune runtest - foo xb + foo diff --git a/test/blackbox-tests/test-cases/syntax-versioning.t/run.t b/test/blackbox-tests/test-cases/syntax-versioning.t/run.t index a5fc335ba5c..d38f257ed89 100644 --- a/test/blackbox-tests/test-cases/syntax-versioning.t/run.t +++ b/test/blackbox-tests/test-cases/syntax-versioning.t/run.t @@ -27,11 +27,12 @@ [1] $ rm -f dune - $ echo '(alias (name x) (deps x) (action (run %{<})))' > dune + $ touch x + $ echo '(alias (name default) (deps x) (action (run %{<})))' > dune $ dune build - File "dune", line 1, characters 40-42: - 1 | (alias (name x) (deps x) (action (run %{<}))) - ^^ + File "dune", line 1, characters 46-48: + 1 | (alias (name default) (deps x) (action (run %{<}))) + ^^ Error: %{<} was deleted in version 1.0 of the dune language. Use a named dependency instead: diff --git a/test/blackbox-tests/test-cases/tests-stanza.t/run.t b/test/blackbox-tests/test-cases/tests-stanza.t/run.t index 0963498047a..1de53705dbb 100644 --- a/test/blackbox-tests/test-cases/tests-stanza.t/run.t +++ b/test/blackbox-tests/test-cases/tests-stanza.t/run.t @@ -5,10 +5,10 @@ $ dune runtest --root plural Entering directory 'plural' - regular_test alias runtest - regular test regular_test2 alias runtest regular test2 + regular_test alias runtest + regular test $ dune runtest --root generated Entering directory 'generated' File "generated.expected", line 1, characters 0-0: diff --git a/test/blackbox-tests/test-cases/variables/variable-resolution.t b/test/blackbox-tests/test-cases/variables/variable-resolution.t index 4981f76d596..4ac71129bcb 100644 --- a/test/blackbox-tests/test-cases/variables/variable-resolution.t +++ b/test/blackbox-tests/test-cases/variables/variable-resolution.t @@ -8,6 +8,11 @@ Test various aspect of variable resolution > echo '(lang dune 2.8)' > dune-project > dune build > echo "exit code: $?" + > echo + > echo "*** Behavior with Dune 3.0 ***" + > echo '(lang dune 3.0)' > dune-project + > dune build + > echo "exit code: $?" > } Unknown variable: @@ -22,7 +27,14 @@ Unknown variable: File "dune", line 3, characters 9-17: 3 | (deps %{unknwon})) ^^^^^^^^ - Error: Unknown variable "unknwon" + Error: Unknown variable %{unknwon} + exit code: 1 + + *** Behavior with Dune 3.0 *** + File "dune", line 3, characters 9-17: + 3 | (deps %{unknwon})) + ^^^^^^^^ + Error: Unknown variable %{unknwon} exit code: 1 Unknown variable that we don't need to resolve: @@ -35,6 +47,13 @@ Unknown variable that we don't need to resolve: *** Behavior with Dune 2.8 *** exit code: 0 + + *** Behavior with Dune 3.0 *** + File "dune", line 3, characters 9-17: + 3 | (deps %{unknwon})) + ^^^^^^^^ + Error: Unknown variable %{unknwon} + exit code: 1 Specific variable used at the wrong place: @@ -48,7 +67,14 @@ Specific variable used at the wrong place: File "dune", line 3, characters 9-22: 3 | (deps %{library-name})) ^^^^^^^^^^^^^ - Error: Unknown variable "library-name" + Error: %{library-name} isn't allowed in this position + exit code: 1 + + *** Behavior with Dune 3.0 *** + File "dune", line 3, characters 9-22: + 3 | (deps %{library-name})) + ^^^^^^^^^^^^^ + Error: %{library-name} isn't allowed in this position exit code: 1 Specific variable used at the wrong place that we don't need to @@ -62,3 +88,6 @@ resolve: *** Behavior with Dune 2.8 *** exit code: 0 + + *** Behavior with Dune 3.0 *** + exit code: 0 diff --git a/test/expect-tests/dune_lang/sexp_tests.ml b/test/expect-tests/dune_lang/sexp_tests.ml index d2678eea110..b1608e27cdf 100644 --- a/test/expect-tests/dune_lang/sexp_tests.ml +++ b/test/expect-tests/dune_lang/sexp_tests.ml @@ -257,7 +257,7 @@ let tq x = Dune_lang.Template { quoted = true; parts = x; loc } let l x = Dune_lang.List x -let var ?payload name = { Dune_lang.Template.loc; name; payload } +let var ?payload name = { Dune_lang.Template.Pform.loc; name; payload } type syntax = | Dune