String_with_vars: Use a functor to create generic expansion fun

This required to remove the labeled ~dir arguments in Action because
one would have had to use the same label for the expansion context in
String_with_vars, which would have been odd for generic expansion
functions.

src/action.ml

@@ -276,35 +276,32 @@ module Var_expansion = struct
     | Paths (_, Split) | Strings (_, Split) -> true
     | Paths (_, Concat) | Strings (_, Concat) -> false
 
+  type context = Path.t (* For String_with_vars.Expand_to *)
+
   let concat = function
     | [s] -> s
     | l -> String.concat ~sep:" " l
 
-  let to_string = function
-    | Strings (l, _) -> concat l
-    | Paths   (l, _) -> concat (List.map l ~f:Path.to_string)
-
-  (* Relative to [dir]. *)
   let string_of_path ~dir p = Path.reach ~from:dir p
-  let path_of_string ~dir s = Path.relative dir s
+  let path_of_string dir s = Path.relative dir s
 
-  let to_strings_rel ~dir = function
+  let to_strings dir = function
     | Strings (l, Split ) -> l
     | Strings (l, Concat) -> [concat l]
     | Paths   (l, Split ) -> List.map l ~f:(string_of_path ~dir)
     | Paths   (l, Concat) -> [concat (List.map l ~f:(string_of_path ~dir))]
 
-  let to_string_rel ~dir = function
+  let to_string (dir: context) = function
     | Strings (l, _) -> concat l
     | Paths   (l, _) -> concat (List.map l ~f:(string_of_path ~dir))
 
-  let to_path ~dir = function
+  let to_path dir = function
-    | Strings (l, _) -> path_of_string ~dir (concat l)
+    | Strings (l, _) -> path_of_string dir (concat l)
     | Paths ([p], _) -> p
     | Paths (l,   _) ->
-      path_of_string ~dir (concat (List.map l ~f:(string_of_path ~dir)))
+      path_of_string dir (concat (List.map l ~f:(string_of_path ~dir)))
 
-  let to_prog_and_args ~dir exp : Unresolved.Program.t * string list =
+  let to_prog_and_args dir exp : Unresolved.Program.t * string list =
     let module P = Unresolved.Program in
     match exp with
     | Paths   ([p], _) -> (This p, [])
@@ -312,7 +309,7 @@ module Var_expansion = struct
     | Paths ([], _) | Strings ([], _) -> (Search "", [])
     | Paths (l, Concat) ->
       (This
-         (path_of_string ~dir
+         (path_of_string dir
             (concat (List.map l ~f:(string_of_path ~dir)))),
        [])
     | Strings (l, Concat) ->
@@ -324,6 +321,7 @@ module Var_expansion = struct
 end
 
 module VE = Var_expansion
+module To_VE = String_with_vars.Expand_to(VE)
 module SW = String_with_vars
 
 module Unexpanded = struct
@@ -364,24 +362,21 @@ module Unexpanded = struct
       let expand ~generic ~special ~map ~dir ~f = function
         | Inl x -> map x
         | Inr template ->
-           match SW.expand_generic template ~f
+           match To_VE.expand dir template ~f with
-                   ~is_multivalued:VE.is_multivalued
+           | Inl e -> special dir e
-                   ~to_string:(VE.to_string_rel ~dir)
+           | Inr s -> generic dir s
-           with
-           | Inl e -> special ~dir e
-           | Inr s -> generic ~dir s
       [@@inlined always]
 
       let string ~dir ~f x =
         expand ~dir ~f x
-          ~generic:(fun ~dir:_ x -> x)
+          ~generic:(fun _dir x -> x)
-          ~special:VE.to_string_rel
+          ~special:VE.to_string
           ~map:(fun x -> x)
 
       let strings ~dir ~f x =
         expand ~dir ~f x
-          ~generic:(fun ~dir:_ x -> [x])
+          ~generic:(fun _dir x -> [x])
-          ~special:VE.to_strings_rel
+          ~special:VE.to_strings
           ~map:(fun x -> [x])
 
       let path ~dir ~f x =
@@ -392,7 +387,7 @@ module Unexpanded = struct
 
       let prog_and_args ~dir ~f x =
         expand ~dir ~f x
-          ~generic:(fun ~dir:_ s -> (Program.of_string ~dir s, []))
+          ~generic:(fun _dir s -> (Program.of_string ~dir s, []))
           ~special:VE.to_prog_and_args
           ~map:(fun x -> (x, []))
     end
@@ -453,22 +448,20 @@ module Unexpanded = struct
 
   module E = struct
     let expand ~generic ~special ~dir ~f template =
-      match SW.partial_expand_generic template ~f
+      match To_VE.partial_expand dir template ~f with
-              ~is_multivalued:VE.is_multivalued
+      | Inl (Inl e) -> Inl(special dir e)
-              ~to_string:(VE.to_string_rel ~dir) with
+      | Inl (Inr s) -> Inl(generic dir s)
-      | Inl (Inl e) -> Inl(special ~dir e)
-      | Inl (Inr s) -> Inl(generic ~dir s)
       | Inr _ as x -> x
 
     let string ~dir ~f x =
       expand ~dir ~f x
-        ~generic:(fun ~dir:_ x -> x)
+        ~generic:(fun _dir x -> x)
-        ~special:VE.to_string_rel
+        ~special:VE.to_string
 
     let strings ~dir ~f x =
       expand ~dir ~f x
-        ~generic:(fun ~dir:_ x -> [x])
+        ~generic:(fun _dir x -> [x])
-        ~special:VE.to_strings_rel
+        ~special:VE.to_strings
 
     let path ~dir ~f x =
       expand ~dir ~f x
@@ -477,7 +470,7 @@ module Unexpanded = struct
 
     let prog_and_args ~dir ~f x =
       expand ~dir ~f x
-        ~generic:(fun ~dir s -> (Unresolved.Program.of_string ~dir s, []))
+        ~generic:(fun dir s -> (Unresolved.Program.of_string ~dir s, []))
         ~special:VE.to_prog_and_args
   end
 

src/action.mli

@@ -11,7 +11,10 @@ module Var_expansion : sig
     | Paths   of Path.t list * Concat_or_split.t
     | Strings of string list * Concat_or_split.t
 
-  val to_string : t -> string
+  val to_string : Path.t -> t -> string
+  (** [to_string dir v] convert the variable expansion to a string.
+     If it is a path, the corresponding string will be relative to
+     [dir]. *)
 end
 
 module Outputs : module type of struct include Action_intf.Outputs end

src/string_with_vars.ml

@@ -103,73 +103,86 @@ let string_of_var syntax v =
   | Parens -> sprintf "$(%s)" v
   | Braces -> sprintf "${%s}" v
 
-let expand_generic t ~f ~is_multivalued ~to_string =
+module type EXPANSION = sig
-  match t.items with
+  type t
-  | [Var (syntax, v)] when not t.quoted ->
+  val is_multivalued : t -> bool
-     (* Unquoted single var *)
+  type context
-     (match f t.loc v with
+  val to_string : context -> t -> string
-      | Some e -> Inl e
+end
-      | None -> Inr(string_of_var syntax v))
-  | _ ->
-     Inr(List.map t.items ~f:(function
-             | Text s -> s
-             | Var (syntax, v) ->
-                match f t.loc v with
-                | Some x ->
-                   if not t.quoted && is_multivalued x then
-                     Loc.fail t.loc "please quote the string \
-                                     containing the list variable %s"
-                       (string_of_var syntax v)
-                   else to_string x
-                | None -> string_of_var syntax v)
-         |> String.concat ~sep:"")
-
-let always_false _ = false
-let identity_string (s: string) = s
-
-let expand t ~f =
-  match expand_generic t ~f ~is_multivalued:always_false
-          ~to_string:identity_string with
-  | Inl s | Inr s -> s
 
 let concat_rev = function
   | [] -> ""
   | [s] -> s
   | l -> String.concat (List.rev l) ~sep:""
 
-let partial_expand_generic t ~f ~is_multivalued ~to_string =
+module Expand_to(V: EXPANSION) = struct
-  let commit_text acc_text acc =
+
-    let s = concat_rev acc_text in
+  let expand ctx t ~f =
-    if s = "" then acc else Text s :: acc
+    match t.items with
-  in
+    | [Var (syntax, v)] when not t.quoted ->
-  let rec loop acc_text acc items =
+       (* Unquoted single var *)
-    match items with
+       (match f t.loc v with
-    | [] -> begin
+        | Some e -> Inl e
-        match acc with
+        | None -> Inr(string_of_var syntax v))
-        | [] -> Inl (Inr(concat_rev acc_text))
+    | _ ->
-        | _  -> Inr { t with items = List.rev (commit_text acc_text acc) }
+       Inr(List.map t.items ~f:(function
-      end
+               | Text s -> s
-    | Text s :: items -> loop (s :: acc_text) acc items
+               | Var (syntax, v) ->
-    | Var (syntax, v) as it :: items ->
+                  match f t.loc v with
-      match f t.loc v with
+                  | Some x ->
-      | None -> loop [] (it :: commit_text acc_text acc) items
+                     if not t.quoted && V.is_multivalued x then
-      | Some x ->
+                       Loc.fail t.loc "please quote the string \
-         if not t.quoted && is_multivalued x then
+                                       containing the list variable %s"
+                         (string_of_var syntax v)
+                     else V.to_string ctx x
+                  | None -> string_of_var syntax v)
+           |> String.concat ~sep:"")
+
+  let partial_expand ctx t ~f =
+    let commit_text acc_text acc =
+      let s = concat_rev acc_text in
+      if s = "" then acc else Text s :: acc
+    in
+    let rec loop acc_text acc items =
+      match items with
+      | [] -> begin
+          match acc with
+          | [] -> Inl (Inr(concat_rev acc_text))
+          | _  -> Inr { t with items = List.rev (commit_text acc_text acc) }
+        end
+      | Text s :: items -> loop (s :: acc_text) acc items
+      | Var (syntax, v) as it :: items ->
+         match f t.loc v with
+         | None -> loop [] (it :: commit_text acc_text acc) items
+         | Some x ->
+            if not t.quoted && V.is_multivalued x then
            Loc.fail t.loc "please quote the string containing the \
                            list variable %s" (string_of_var syntax v)
-         else loop (to_string x :: acc_text) acc items
+         else loop (V.to_string ctx x :: acc_text) acc items
-  in
+    in
-  match t.items with
+    match t.items with
-  | [Var (_, v)] when not t.quoted ->
+    | [Var (_, v)] when not t.quoted ->
-     (* Unquoted single var *)
+       (* Unquoted single var *)
-     (match f t.loc v with
+       (match f t.loc v with
-      | Some e -> Inl (Inl e)
+        | Some e -> Inl (Inl e)
-      | None -> Inr t)
+        | None -> Inr t)
-  | _ -> loop [] [] t.items
+    | _ -> loop [] [] t.items
+end
+
+module String_expansion = struct
+  type t = string
+  let is_multivalued _ = false
+  type context = unit
+  let to_string () (s: string) = s
+end
+
+module S = Expand_to(String_expansion)
+
+let expand t ~f =
+  match S.expand () t ~f with Inl s | Inr s -> s
 
 let partial_expand t ~f =
-  match partial_expand_generic t ~f ~is_multivalued:always_false
+  match S.partial_expand () t ~f with
-          ~to_string:identity_string with
   | Inl(Inl s | Inr s) -> Inl s
   | Inr _ as x -> x
 

src/string_with_vars.mli

@@ -39,38 +39,48 @@ val iter : t -> f:(Loc.t -> string -> unit) -> unit
 (** [iter t ~f] iterates [f] over all variables of [t], the text
    portions being ignored. *)
 
-val expand_generic :
+module type EXPANSION = sig
-  t -> f:(Loc.t -> string -> 'a option) -> is_multivalued:('a -> bool) ->
+  type t
-  to_string:('a -> string) -> ('a, string) either
+  (** The value to which variables are expanded. *)
-(** [expand_generic t ~f] return [t] where all variables have been expanded
-   using [f].  If [f loc var] return [Some x], the variable [var] is
-   replaced by [x]; otherwise, the variable is inserted as [${var}] or
-   [$(var)] — depending on the original concrete syntax used.
 
-   - [is_multivalued]: says whether the variables is a multivalued
+  val is_multivalued : t -> bool
-   one (such as for example ${@}) which much be in quoted strings to
+  (** Report whether the value is a multivalued one (such as for
-   be concatenated to text or other variables.
+     example ${@}) which much be in quoted strings to be concatenated
-   - [to_string]: For single unquoted variables, the outcome of [f] is
+     to text or other variables. *)
-   directly returned.  For variables containing text portions or which
+
-   are quoted, the value returned by [f] is converted to a string
+  type context
-   using [to_string]. *)
+  (** Context needed to expand values of type [t] to strings. *)
+
+  val to_string : context -> t -> string
+  (** When needing to expand with text portions or if the
+     string-with-vars is quoted, the value is converted to a string
+     using [to_string]. *)
+end
+
+module Expand_to(V : EXPANSION) : sig
+  val expand : V.context -> t -> f:(Loc.t -> string -> V.t option) ->
+               (V.t, string) either
+  (** [expand t ~f] return [t] where all variables have been expanded
+     using [f].  If [f loc var] return [Some x], the variable [var] is
+     replaced by [x]; otherwise, the variable is inserted as [${var}]
+     or [$(var)] — depending on the original concrete syntax used.  *)
+
+  val partial_expand :
+    V.context -> t -> f:(Loc.t -> string -> V.t option) ->
+    ((V.t, string) either, t) either
+  (** [partial_expand t ~f] is like [expand_generic] where all
+     variables that could be expanded (i.e., those for which [f]
+     returns [Some _]) are.  If all the variables of [t] were
+     expanded, a string is returned.  If [f] returns [None] on at
+     least a variable of [t], it returns a string-with-vars. *)
+end
 
 val expand :
   t -> f:(Loc.t -> string -> string option) -> string
-(** Specialized version [expand_generic] that returns a string (so
+(** Specialized version [Expand_to.expand] that returns a string (so
    variables are assumed to expand to a single value). *)
 
-val partial_expand_generic :
-  t -> f:(Loc.t -> string -> 'a option) -> is_multivalued:('a -> bool) ->
-  to_string:('a -> string) -> (('a, string) either, t) either
-(** [partial_expand_generic t ~f] is like [expand_generic] where all
-   variables that could be expanded (i.e., those for which [f] returns
-   [Some _]) are.  If all the variables of [t] were expanded, a string
-   is returned.  If [f] returns [None] on at least a variable of [t],
-   it returns a string-with-vars. *)
-
 val partial_expand :
   t -> f:(Loc.t -> string -> string option) -> (string, t) either
 (** [partial_expand] is a specialized version of
-   [partial_expand_generic] that returns a string. *)
+   [Expand_to.partial_expand] that returns a string. *)
-

src/super_context.ml

@@ -51,7 +51,7 @@ let expand_vars t ~(scope : Lib_db.Scope.t) ~dir s =
       Some (Path.reach ~from:dir (Lib_db.Scope.root scope))
     | var ->
       expand_var_no_root t var
-      |> Option.map ~f:(fun e -> Action.Var_expansion.to_string e))
+      |> Option.map ~f:(fun e -> Action.Var_expansion.to_string dir e))
 
 let resolve_program t ?hint bin =
   Artifacts.binary ?hint t.artifacts bin