diff --git a/src/action.ml b/src/action.ml index c9dcf678..761d77c3 100644 --- a/src/action.ml +++ b/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 - | Strings (l, _) -> path_of_string ~dir (concat l) + let to_path dir = function + | 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 - ~is_multivalued:VE.is_multivalued - ~to_string:(VE.to_string_rel ~dir) - with - | Inl e -> special ~dir e - | Inr s -> generic ~dir s + match To_VE.expand dir template ~f 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) - ~special:VE.to_string_rel + ~generic:(fun _dir x -> x) + ~special:VE.to_string ~map:(fun x -> x) let strings ~dir ~f x = expand ~dir ~f x - ~generic:(fun ~dir:_ x -> [x]) - ~special:VE.to_strings_rel + ~generic:(fun _dir x -> [x]) + ~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 - ~is_multivalued:VE.is_multivalued - ~to_string:(VE.to_string_rel ~dir) with - | Inl (Inl e) -> Inl(special ~dir e) - | Inl (Inr s) -> Inl(generic ~dir s) + match To_VE.partial_expand dir template ~f with + | 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) - ~special:VE.to_string_rel + ~generic:(fun _dir x -> x) + ~special:VE.to_string let strings ~dir ~f x = expand ~dir ~f x - ~generic:(fun ~dir:_ x -> [x]) - ~special:VE.to_strings_rel + ~generic:(fun _dir x -> [x]) + ~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 diff --git a/src/action.mli b/src/action.mli index e9cb8f2f..b85f7254 100644 --- a/src/action.mli +++ b/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 diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index b0ceeec1..74b25260 100644 --- a/src/string_with_vars.ml +++ b/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 = - match t.items with - | [Var (syntax, v)] when not t.quoted -> - (* Unquoted single var *) - (match f t.loc v with - | Some e -> Inl e - | 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 +module type EXPANSION = sig + type t + val is_multivalued : t -> bool + type context + val to_string : context -> t -> string +end let concat_rev = function | [] -> "" | [s] -> s | l -> String.concat (List.rev l) ~sep:"" -let partial_expand_generic t ~f ~is_multivalued ~to_string = - 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 && is_multivalued x then +module Expand_to(V: EXPANSION) = struct + + let expand ctx t ~f = + match t.items with + | [Var (syntax, v)] when not t.quoted -> + (* Unquoted single var *) + (match f t.loc v with + | Some e -> Inl e + | 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 && V.is_multivalued x then + Loc.fail t.loc "please quote the string \ + 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 - in - match t.items with - | [Var (_, v)] when not t.quoted -> - (* Unquoted single var *) - (match f t.loc v with - | Some e -> Inl (Inl e) - | None -> Inr t) - | _ -> loop [] [] t.items + else loop (V.to_string ctx x :: acc_text) acc items + in + match t.items with + | [Var (_, v)] when not t.quoted -> + (* Unquoted single var *) + (match f t.loc v with + | Some e -> Inl (Inl e) + | None -> Inr t) + | _ -> 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 - ~to_string:identity_string with + match S.partial_expand () t ~f with | Inl(Inl s | Inr s) -> Inl s | Inr _ as x -> x diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index a14cfc6a..6f7fcf3f 100644 --- a/src/string_with_vars.mli +++ b/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 : - t -> f:(Loc.t -> string -> 'a option) -> is_multivalued:('a -> bool) -> - to_string:('a -> string) -> ('a, string) either -(** [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. +module type EXPANSION = sig + type t + (** The value to which variables are expanded. *) - - [is_multivalued]: says whether the variables is a multivalued - one (such as for example ${@}) which much be in quoted strings to - be concatenated to text or other variables. - - [to_string]: For single unquoted variables, the outcome of [f] is - directly returned. For variables containing text portions or which - are quoted, the value returned by [f] is converted to a string - using [to_string]. *) + val is_multivalued : t -> bool + (** Report whether the value is a multivalued one (such as for + example ${@}) which much be in quoted strings to be concatenated + to text or other variables. *) + + type context + (** 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. *) diff --git a/src/super_context.ml b/src/super_context.ml index b6ec5c9f..4ec2e691 100644 --- a/src/super_context.ml +++ b/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