From df4ea51da1e486cbc3fe3e316137735b142a2f9a Mon Sep 17 00:00:00 2001 From: Marc Lasson Date: Wed, 24 Apr 2019 08:33:23 +0100 Subject: [PATCH] Allow variables in pps flags This commit adds support for variables in the flags of the "pps" (and "pps_staged") kind of preprocessing. This allows, for instance, to pass %{profile}, %{context_name}, or environment variables as preprocessor argument. Signed-off-by: Marc Lasson --- CHANGES.md | 2 + src/dune_file.ml | 41 ++++++++++---- src/dune_file.mli | 2 +- src/dune_lang/dune_lang.mli | 4 ++ src/dune_lang/template.ml | 53 +++++++++++++++++++ src/dune_lang/template.mli | 2 + src/merlin.ml | 9 ++-- src/preprocessing.ml | 2 + src/string_with_vars.ml | 8 +++ src/string_with_vars.mli | 4 ++ .../dune-ppx-driver-system/driver-tests/dune | 5 +- .../driver-tests/dune-project | 4 +- .../test-cases/dune-ppx-driver-system/run.t | 4 +- 13 files changed, 121 insertions(+), 19 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 9cb1fcd4e9a3..35a0608d1db3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -25,6 +25,8 @@ unreleased to produce targets that are present in the source tree. This has been a warning for long enough (#2068, @diml) +- Allow %{...} variables in pps flags (#2076, @mlasson review by @diml) + - Add more opam metadata and use it to generate corrections to the .opam files in the source. This allows the user to partially specify opam metadata in the the dune-project file. (#2017, @avsm, @jonludlam) diff --git a/src/dune_file.ml b/src/dune_file.ml index 67bc992492e3..bdb9b23e8030 100644 --- a/src/dune_file.ml +++ b/src/dune_file.ml @@ -137,7 +137,7 @@ module Pps_and_flags = struct module Jbuild_syntax = struct let of_string ~loc s = if String.is_prefix s ~prefix:"-" then - Right [s] + Right [String_with_vars.make_text loc s] else Left (loc, Lib_name.of_string_exn ~loc:(Some loc) s) @@ -146,7 +146,10 @@ module Pps_and_flags = struct | Template { loc; _ } -> no_templates loc "in the preprocessors field" | Atom _ | Quoted_string _ -> plain_string of_string - | List _ -> list string >>| fun l -> Right l + | List _ -> + repeat (plain_string (fun ~loc str -> + String_with_vars.make_text loc str)) + >>| (fun x -> Right x) let split l = let pps, flags = List.partition_map l ~f:Fn.id in @@ -159,17 +162,35 @@ module Pps_and_flags = struct let decode = let+ l, flags = until_keyword "--" - ~before:(plain_string (fun ~loc s -> (loc, s))) - ~after:(repeat string) + ~before:String_with_vars.decode + ~after:(repeat String_with_vars.decode) + and+ syntax_version = Syntax.get_exn Stanza.syntax in + let check_allowed_variable flag = + if String_with_vars.has_vars flag then + Syntax.Error.since (String_with_vars.loc flag) + Stanza.syntax + (1, 10) + ~what:"Using variables in pps flags" + in + let flags = Option.value flags ~default:[] in + if syntax_version < (1, 10) then + List.iter ~f:check_allowed_variable flags; let pps, more_flags = - List.partition_map l ~f:(fun (loc, s) -> - if String.is_prefix s ~prefix:"-" then + List.partition_map l ~f:(fun s -> + if String_with_vars.is_prefix s ~prefix:"-" then begin + if syntax_version < (1, 10) then + check_allowed_variable s; Right s - else - Left (loc, Lib_name.of_string_exn ~loc:(Some loc) s)) + end else + let loc = String_with_vars.loc s in + match String_with_vars.text_only s with + | None -> no_templates loc "in the ppx library names" + | Some txt -> + Left (loc, Lib_name.of_string_exn ~loc:(Some loc) txt) + ) in - (pps, more_flags @ Option.value flags ~default:[]) + (pps, more_flags @ flags) end let decode = @@ -258,7 +279,7 @@ module Preprocess = struct type pps = { loc : Loc.t ; pps : (Loc.t * Lib_name.t) list - ; flags : string list + ; flags : String_with_vars.t list ; staged : bool } type t = diff --git a/src/dune_file.mli b/src/dune_file.mli index d64b08c6e50d..362e520eca93 100644 --- a/src/dune_file.mli +++ b/src/dune_file.mli @@ -7,7 +7,7 @@ module Preprocess : sig type pps = { loc : Loc.t ; pps : (Loc.t * Lib_name.t) list - ; flags : string list + ; flags : String_with_vars.t list ; staged : bool } diff --git a/src/dune_lang/dune_lang.mli b/src/dune_lang/dune_lang.mli index 8f9294af7f34..e548f3d4fda1 100644 --- a/src/dune_lang/dune_lang.mli +++ b/src/dune_lang/dune_lang.mli @@ -41,11 +41,15 @@ module Template : sig ; loc: Loc.t } + val compare_no_loc: t -> t -> Ordering.t + val string_of_var : var -> string val to_string : t -> syntax:File_syntax.t -> string val remove_locs : t -> t + + val is_prefix : t -> prefix:string -> bool end (** The S-expression type *) diff --git a/src/dune_lang/template.ml b/src/dune_lang/template.ml index 6f15a5295ef5..b23e0bb21c3d 100644 --- a/src/dune_lang/template.ml +++ b/src/dune_lang/template.ml @@ -2,6 +2,36 @@ open! Stdune include Types.Template +let compare_var_syntax x y = + match x, y with + | Percent, Percent + | Dollar_brace, Dollar_brace + | Dollar_paren, Dollar_paren -> Ordering.Eq + | Percent, (Dollar_brace | Dollar_paren) -> Ordering.Lt + | (Dollar_brace | Dollar_paren), Percent -> Ordering.Gt + | Dollar_brace, Dollar_paren -> Ordering.Lt + | Dollar_paren, Dollar_brace -> Ordering.Gt + +let compare_var_no_loc v1 v2 = + match String.compare v1.name v2.name with + | Ordering.Lt | Gt as a -> a + | Eq -> + match Option.compare String.compare v1.payload v2.payload with + | Ordering.Lt | Gt as a -> a + | Eq -> compare_var_syntax v1.syntax v2.syntax + +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 + +let compare_no_loc t1 t2 = + match List.compare ~compare:compare_part t1.parts t2.parts with + | Ordering.Lt | Gt as a -> a + | Eq -> Bool.compare t1.quoted t2.quoted + let var_enclosers = function | Percent -> "%{", "}" | Dollar_brace -> "${", "}" @@ -100,3 +130,26 @@ let remove_locs t = | Var v -> Var { v with loc = Loc.none } | Text _ as s -> s) } + +let is_prefix {parts; _} ~prefix = + let rec compare_substrings s1 k1 s2 k2 len = + len = 0 || (s1.[k1] = s2.[k2] && + compare_substrings s1 (k1 + 1) s2 (k2 + 1) (len - 1)) + in + let prefix_len = String.length prefix in + let rec aux from parts = + if from = prefix_len then + true + else + match parts with + | Var _ :: _ | [] -> false + | Text part :: parts -> + let part_len = String.length part in + let len = prefix_len - from in + if len <= part_len then + compare_substrings prefix from part 0 len + else + compare_substrings prefix from part 0 part_len + && aux (from + part_len) parts + in + aux 0 parts diff --git a/src/dune_lang/template.mli b/src/dune_lang/template.mli index 7ea15c8920ef..902c5502dcf6 100644 --- a/src/dune_lang/template.mli +++ b/src/dune_lang/template.mli @@ -23,6 +23,7 @@ type t = Types.Template.t = } val to_string : t -> syntax:File_syntax.t -> string +val compare_no_loc : t -> t -> Ordering.t val string_of_var : var -> string val pp : File_syntax.t -> Format.formatter -> t -> unit @@ -30,3 +31,4 @@ val pp : File_syntax.t -> Format.formatter -> t -> unit val pp_split_strings : Format.formatter -> t -> unit val remove_locs : t -> t +val is_prefix : t -> prefix:string -> bool diff --git a/src/merlin.ml b/src/merlin.ml index b4cb47d3d9e2..075cb42038ae 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -38,7 +38,7 @@ module Preprocess = struct | Pps { loc ; pps = pps1; flags = flags1; staged = s1 }, Pps { loc = _; pps = pps2; flags = flags2; staged = s2 } -> if Bool.(<>) s1 s2 - || List.compare flags1 flags2 ~compare:String.compare <> Eq + || List.compare flags1 flags2 ~compare:String_with_vars.compare_no_loc <> Eq || List.compare pps1 pps2 ~compare:(fun (_, x) (_, y) -> Lib_name.compare x y) <> Eq then @@ -130,6 +130,7 @@ let pp_flags sctx ~expander ~dir_kind { preprocess; libname; _ } = match Preprocessing.get_ppx_driver sctx ~scope ~dir_kind pps with | Error _ -> None | Ok exe -> + let flags = List.map ~f:(Expander.expand_str expander) flags in (Path.to_absolute_filename exe :: "--as-ppx" :: Preprocessing.cookie_library_name libname @@ -225,7 +226,8 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind let merge_two ~allow_approx_merlin a b = { requires = Lib.Set.union a.requires b.requires ; flags = a.flags &&& b.flags >>^ (fun (a, b) -> a @ b) - ; preprocess = Preprocess.merge ~allow_approx_merlin a.preprocess b.preprocess + ; preprocess = + Preprocess.merge ~allow_approx_merlin a.preprocess b.preprocess ; libname = (match a.libname with | Some _ as x -> x @@ -237,7 +239,8 @@ let merge_two ~allow_approx_merlin a b = let merge_all ~allow_approx_merlin = function | [] -> None | init :: ts -> - Some (List.fold_left ~init ~f:(merge_two ~allow_approx_merlin) ts) + Some ( + List.fold_left ~init ~f:(merge_two ~allow_approx_merlin) ts) let add_rules sctx ~dir ~more_src_dirs ~expander ~dir_kind merlin = if (SC.context sctx).merlin then diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 8ea05cc38575..21071ebd903a 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -584,6 +584,7 @@ let lint_module sctx ~dir ~expander ~dep_kind ~lint ~lib_name ~scope ~dir_kind = if staged then Errors.fail loc "Staged ppx rewriters cannot be used as linters."; + let flags = List.map ~f:(Expander.expand_str expander) flags in let args : _ Arg_spec.t = S [ As flags ; As (cookie_library_name lib_name) @@ -659,6 +660,7 @@ let make sctx ~dir ~expander ~dep_kind ~lint ~preprocess if lint then lint_module ~ast ~source:m; ast) | Pps { loc; pps; flags; staged } -> + let flags = List.map ~f:(Expander.expand_str expander) flags in if not staged then begin let args : _ Arg_spec.t = S [ As flags diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index 14a727100ac1..2faed2780595 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -8,6 +8,11 @@ type t = ; syntax_version : Syntax.Version.t } +let compare_no_loc t1 t2 = + match Syntax.Version.compare t1.syntax_version t2.syntax_version with + | Ordering.Lt | Gt as a -> a + | Eq -> Dune_lang.Template.compare_no_loc t1.template t2.template + let make_syntax = (1, 0) let make ?(quoted=false) loc part = @@ -321,6 +326,9 @@ let remove_locs t = { t with template = Dune_lang.Template.remove_locs t.template } +let is_prefix t = + Dune_lang.Template.is_prefix t.template + module Upgrade_var = struct type info = | Keep diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index 722706ced2bc..a7a9e0d76797 100644 --- a/src/string_with_vars.mli +++ b/src/string_with_vars.mli @@ -9,6 +9,8 @@ open Import type t (** A sequence of text and variables. *) +val compare_no_loc: t -> t -> Ordering.t + val loc : t -> Loc.t (** [loc t] returns the location of [t] — typically, in the jbuild file. *) @@ -83,6 +85,8 @@ val partial_expand val remove_locs : t -> t +val is_prefix : t -> prefix:string -> bool + (** Upgrade the following string with variables coming from a jbuild file to one suitable for a dune file. Fail if the [<] variable is found and [allow_first_dep_var] is [true]. *) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune b/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune index 82192e381a0b..169871109e16 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune @@ -85,4 +85,7 @@ (library (name test_ppx_staged) (modules test_ppx_staged) - (preprocess (staged_pps -arg1 driver_print_tool -arg2 -- -foo bar))) + (preprocess + (staged_pps -arg1 driver_print_tool -arg2 -arg3=%{env:SOME_UNDEFINED_VARIABLE=undefined} + -- -foo bar %{env:SOME_UNDEFINED_VARIABLE=undefined}) +)) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune-project b/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune-project index 60ccc0ab9839..d8c0dcc78ef1 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune-project +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune-project @@ -1,3 +1,3 @@ -(lang dune 1.9) +(lang dune 1.10) -(allow_approximate_merlin) \ No newline at end of file +(allow_approximate_merlin) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t index 09ab7ff98c6a..4ca5eddebfd6 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t @@ -79,10 +79,10 @@ Test that going throught the -ppx option of the compiler works Entering directory 'driver-tests' ocamldep .test_ppx_staged.objs/test_ppx_staged.ml.d tool name: ocamldep - args:--as-ppx -arg1 -arg2 -foo bar --cookie library-name="test_ppx_staged" + args:--as-ppx -arg1 -arg2 -arg3=undefined -foo bar undefined --cookie library-name="test_ppx_staged" ocamlc .test_ppx_staged.objs/byte/test_ppx_staged.{cmi,cmo,cmt} tool name: ocamlc - args:--as-ppx -arg1 -arg2 -foo bar --cookie library-name="test_ppx_staged" + args:--as-ppx -arg1 -arg2 -arg3=undefined -foo bar undefined --cookie library-name="test_ppx_staged" Test using installed drivers