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 <marc.lasson@lexifi.com>

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)

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 =

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
     }
 

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 *)

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

src/dune_lang/template.mli

@@ -23,10 +23,12 @@ 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
 
 val pp_split_strings : Format.formatter -> t -> unit
 
 val remove_locs : t -> t
+val is_prefix : t -> prefix:string -> bool

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

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

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

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]. *)

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})
+))

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)
+(allow_approximate_merlin)

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