From bfa73a8cac59a9be956e7e9877e8ad77a79f7048 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 10 Jul 2018 05:16:40 +0100 Subject: [PATCH] Fix shadowing of forms Signed-off-by: Jeremie Dimino --- src/inline_tests.ml | 2 +- src/pform.ml | 265 +++++++++++------- src/pform.mli | 60 ++-- src/super_context.ml | 48 ++-- .../test-cases/shadow-bindings/run.t | 11 +- 5 files changed, 216 insertions(+), 170 deletions(-) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 1c7ebd84..8792fbbb 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -203,7 +203,7 @@ include Sub_system.Register_end_point( let target = Path.relative inline_test_dir main_module_filename in let source_modules = Module.Name.Map.values source_modules in let files ml_kind = - Pform.Values (Value.L.paths ( + Pform.Var.Values (Value.L.paths ( List.filter_map source_modules ~f:(fun m -> Module.file m ~dir ml_kind))) in diff --git a/src/pform.ml b/src/pform.ml index ac1971fd..1762abae 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -1,73 +1,93 @@ open Import -type t = - | Values of Value.t list - | Project_root - | First_dep - | Deps - | Targets - | Named_local - | Exe - | Dep - | Bin - | Lib - | Libexec - | Lib_available - | Version - | Read - | Read_strings - | Read_lines - | Path_no_dep - | Ocaml_config +module Var = struct + type t = + | Values of Value.t list + | Project_root + | First_dep + | Deps + | Targets + | Named_local +end -type with_info = - | No_info of t - | Since of t * Syntax.Version.t - | Deleted_in of t * Syntax.Version.t * string option +module Macro = struct + type t = + | Exe + | Dep + | Bin + | Lib + | Libexec + | Lib_available + | Version + | Read + | Read_strings + | Read_lines + | Path_no_dep + | Ocaml_config +end + +module Expansion = struct + type t = + | Var of Var.t + | Macro of Macro.t * string +end + +type 'a t = + | No_info of 'a + | Since of 'a * Syntax.Version.t + | Deleted_in of 'a * Syntax.Version.t * string option | Renamed_in of 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) + module Map = struct - type t = with_info String.Map.t + type 'a map = 'a t String.Map.t - let values v = No_info (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 t = + { vars : Var.t map + ; macros : Macro.t map + } - let static = - let macro x = No_info x in - [ "targets", since ~version:(1, 0) Targets - ; "deps", since ~version:(1, 0) Deps - ; "project_root", since ~version:(1, 0) Project_root + let static_vars = + String.Map.of_list_exn + [ "targets", since ~version:(1, 0) Var.Targets + ; "deps", since ~version:(1, 0) Var.Deps + ; "project_root", since ~version:(1, 0) Var.Project_root - ; "<", deleted_in First_dep ~version:(1, 0) - ~repl:"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" + ; "<", deleted_in Var.First_dep ~version:(1, 0) + ~repl:"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" + ] - ; "exe", macro Exe - ; "bin", macro Bin - ; "lib", macro Lib - ; "libexec", macro Libexec - ; "lib-available", macro Lib_available - ; "version", macro Version - ; "read", macro Read - ; "read-lines", macro Read_lines - ; "read-strings", macro Read_strings + let macros = + let macro (x : Macro.t) = No_info x in + String.Map.of_list_exn + [ "exe", macro Exe + ; "bin", macro Bin + ; "lib", macro Lib + ; "libexec", macro Libexec + ; "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) Dep + ; "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", 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) Path_no_dep - ; "ocaml-config", macro Ocaml_config - ] - |> String.Map.of_list_exn + ; "path-no-dep", deleted_in ~version:(1, 0) Macro.Path_no_dep + ; "ocaml-config", macro Ocaml_config + ] let create ~(context : Context.t) ~cxx_flags = let ocamlopt = @@ -117,67 +137,96 @@ module Map = struct ; "profile" , string context.profile ] in - String.Map.superpose - static - (String.Map.of_list_exn - (List.concat - [ lowercased - ; uppercased - ; other - ])) + { vars = + String.Map.superpose + static_vars + (String.Map.of_list_exn + (List.concat + [ lowercased + ; uppercased + ; other + ])) + ; macros + } - let superpose = String.Map.superpose + let superpose a b = + { vars = String.Map.superpose a.vars b.vars + ; macros = String.Map.superpose a.macros b.macros + } - let rec expand t ~syntax_version ~pform = + let rec expand map ~syntax_version ~pform = + let open Option.O in let name = String_with_vars.Var.name pform in - Option.bind (String.Map.find t name) ~f:(fun v -> - 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 - Syntax.Error.since (String_with_vars.Var.loc pform) - Stanza.syntax min_version + String.Map.find map name >>= fun v -> + 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 + Syntax.Error.since (String_with_vars.Var.loc pform) + Stanza.syntax min_version + ~what:(describe pform) + | Renamed_in (in_version, new_name) -> begin + if syntax_version >= in_version then + Syntax.Error.renamed_in (String_with_vars.Var.loc pform) + Stanza.syntax syntax_version ~what:(describe pform) - | Renamed_in (in_version, new_name) -> begin - if syntax_version >= in_version then - 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 t ~syntax_version:in_version - ~pform:(String_with_vars.Var.with_name pform ~name:new_name) - end - | Deleted_in (v, in_version, repl) -> - if syntax_version < in_version then - Some v + ~to_:(describe + (String_with_vars.Var.with_name pform ~name:new_name)) else - Syntax.Error.deleted_in (String_with_vars.Var.loc pform) - Stanza.syntax syntax_version ~what:(describe pform) ?repl) + expand map ~syntax_version:in_version + ~pform:(String_with_vars.Var.with_name pform ~name:new_name) + end + | Deleted_in (v, in_version, repl) -> + if syntax_version < in_version then + Some v + else + Syntax.Error.deleted_in (String_with_vars.Var.loc pform) + Stanza.syntax syntax_version ~what:(describe pform) ?repl - let empty = String.Map.empty + let expand t ~syntax_version ~pform = + 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 singleton k v = String.Map.singleton k (No_info v) + 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 = - List.map ~f:(fun (k, x) -> (k, No_info x)) pforms - |> String.Map.of_list_exn + { vars = List.map ~f:(fun (k, x) -> (k, No_info x)) pforms + |> String.Map.of_list_exn + ; macros = String.Map.empty + } - let of_bindings = - Jbuild.Bindings.fold ~f:(fun x acc -> - match x with - | Unnamed _ -> acc - | Named (s, _) -> String.Map.add acc s (No_info Named_local) - ) ~init:empty + let of_bindings bindings = + { vars = + Jbuild.Bindings.fold bindings ~init:String.Map.empty ~f:(fun x acc -> + match x with + | Unnamed _ -> acc + | Named (s, _) -> String.Map.add acc s (No_info Var.Named_local)) + ; macros = String.Map.empty + } let input_file path = - let value = Values (Value.L.paths [path]) in - [ "input-file", since ~version:(1, 0) value - ; "<", renamed_in ~new_name:"input-file" ~version:(1, 0) - ] - |> String.Map.of_list_exn + 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 + } end diff --git a/src/pform.mli b/src/pform.mli index 1135c594..fcce5f06 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -1,30 +1,38 @@ open Stdune -type t = - (* Variables *) - | Values of Value.t list - | Project_root - | First_dep - | Deps - | Targets - | Named_local +module Var : sig + type t = + | Values of Value.t list + | Project_root + | First_dep + | Deps + | Targets + | Named_local +end - (* Macros *) - | Exe - | Dep - | Bin - | Lib - | Libexec - | Lib_available - | Version - | Read - | Read_strings - | Read_lines - | Path_no_dep - | Ocaml_config +module Macro : sig + type t = + | Exe + | Dep + | Bin + | Lib + | Libexec + | Lib_available + | Version + | Read + | Read_strings + | Read_lines + | Path_no_dep + | Ocaml_config +end + +module Expansion : sig + type t = + | Var of Var.t + | Macro of Macro.t * string +end module Map : sig - type pform type t val create : context:Context.t -> cxx_flags:string list -> t @@ -34,9 +42,9 @@ module Map : sig (** Map with all named values as [Named_local] *) val of_bindings : _ Jbuild.Bindings.t -> t - val singleton : string -> pform -> t + val singleton : string -> Var.t -> t - val of_list_exn : (string * pform) list -> t + val of_list_exn : (string * Var.t) list -> t val input_file : Path.t -> t @@ -44,7 +52,7 @@ module Map : sig : t -> syntax_version:Syntax.Version.t -> pform:String_with_vars.Var.t - -> pform option + -> Expansion.t option val empty : t -end with type pform := t +end diff --git a/src/super_context.ml b/src/super_context.ml index 17ddaf81..f873ab28 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -85,8 +85,7 @@ let installed_libs t = t.installed_libs let find_scope_by_dir t dir = Scope.DB.find_by_dir t.scopes dir let find_scope_by_name t name = Scope.DB.find_by_name t.scopes name -let expand_ocaml_config t pform = - let name = Option.value_exn (String_with_vars.Var.payload pform) in +let expand_ocaml_config t pform name = match String.Map.find t.ocaml_config name with | Some x -> x | None -> @@ -101,9 +100,9 @@ let (expand_vars_string, expand_vars_path) = | None -> Pform.Map.expand t.pforms ~syntax_version ~pform | Some _ as x -> x) |> Option.map ~f:(function - | Pform.Values l -> l - | Ocaml_config -> expand_ocaml_config t pform - | Project_root -> [Value.Dir (Scope.root scope)] + | Pform.Expansion.Var (Values l) -> l + | Macro (Ocaml_config, s) -> expand_ocaml_config t pform s + | Var Project_root -> [Value.Dir (Scope.root scope)] | _ -> Loc.fail (String_with_vars.Var.loc pform) "%s isn't allowed in this position" @@ -618,15 +617,14 @@ module Action = struct let expand pform syntax_version = let loc = String_with_vars.Var.loc pform in let key = String_with_vars.Var.full_name pform in - let s = Option.value (String_with_vars.Var.payload pform) ~default:"" in let res = Pform.Map.expand bindings ~syntax_version ~pform |> Option.bind ~f:(function - | Pform.Values l -> Some l - | Ocaml_config -> Some (expand_ocaml_config sctx pform) - | Project_root -> Some [Value.Dir (Scope.root scope)] - | First_dep | Deps | Named_local -> None - | Targets -> + | Pform.Expansion.Var (Values l) -> Some l + | Macro (Ocaml_config, s) -> Some (expand_ocaml_config sctx pform s) + | Var Project_root -> Some [Value.Dir (Scope.root scope)] + | Var (First_dep | Deps | Named_local) -> None + | Var Targets -> begin match targets_written_by_user with | Infer -> Loc.fail loc "You cannot use %s with inferred rules." @@ -637,9 +635,9 @@ module Action = struct | Static l -> Some (Value.L.dirs l) (* XXX hack to signal no dep *) end - | Exe -> Some (path_exp (map_exe (Path.relative dir s))) - | Dep -> Some (path_exp (Path.relative dir s)) - | Bin -> begin + | Macro (Exe, s) -> Some (path_exp (map_exe (Path.relative dir s))) + | Macro (Dep, s) -> Some (path_exp (Path.relative dir s)) + | Macro (Bin, s) -> begin let sctx = host sctx in match Artifacts.binary (artifacts sctx) s with | Ok path -> Some (path_exp path) @@ -647,7 +645,7 @@ module Action = struct add_fail acc ({ fail = fun () -> Action.Prog.Not_found.raise e }) end - | Lib -> begin + | Macro (Lib, s) -> begin let lib_dep, file = parse_lib_file ~loc s in add_lib_dep acc lib_dep dep_kind; match @@ -656,7 +654,7 @@ module Action = struct | Ok path -> Some (path_exp path) | Error fail -> add_fail acc fail end - | Libexec -> begin + | Macro (Libexec, s) -> begin let sctx = host sctx in let lib_dep, file = parse_lib_file ~loc s in add_lib_dep acc lib_dep dep_kind; @@ -679,13 +677,13 @@ module Action = struct add_ddep acc ~key dep end end - | Lib_available -> begin + | Macro (Lib_available, s) -> begin let lib = s in add_lib_dep acc lib Optional; Some (str_exp (string_of_bool ( Lib.DB.available (Scope.libs scope) lib))) end - | Version -> begin + | Macro (Version, s) -> begin match Package.Name.Map.find (Scope.project scope).packages (Package.Name.of_string s) with | Some p -> @@ -701,7 +699,7 @@ module Action = struct "Package %S doesn't exist in the current project." s } end - | Read -> begin + | Macro (Read, s) -> begin let path = Path.relative dir s in let data = Build.contents path @@ -709,7 +707,7 @@ module Action = struct in add_ddep acc ~key data end - | Read_lines -> begin + | Macro (Read_lines, s) -> begin let path = Path.relative dir s in let data = Build.lines_of path @@ -717,7 +715,7 @@ module Action = struct in add_ddep acc ~key data end - | Read_strings -> begin + | Macro (Read_strings, s) -> begin let path = Path.relative dir s in let data = Build.strings path @@ -725,7 +723,7 @@ module Action = struct in add_ddep acc ~key data end - | Path_no_dep -> Some [Value.Dir (Path.relative dir s)]) + | Macro (Path_no_dep, s) -> Some [Value.Dir (Path.relative dir s)]) in Option.iter res ~f:(fun v -> acc.sdeps <- Path.Set.union @@ -746,7 +744,7 @@ module Action = struct | Some _ as opt -> opt | None -> Option.map (Pform.Map.expand bindings ~syntax_version ~pform) ~f:(function - | Named_local -> + | Var Named_local -> begin match Jbuild.Bindings.find deps_written_by_user key with | None -> Exn.code_error "Local named variable not present in named deps" @@ -756,11 +754,11 @@ module Action = struct ] | Some x -> Value.L.paths x end - | Deps -> + | Var Deps -> deps_written_by_user |> Jbuild.Bindings.to_list |> Value.L.paths - | First_dep -> + | Var First_dep -> begin match deps_written_by_user with | Named _ :: _ -> (* This case is not possible: ${<} only exist in jbuild diff --git a/test/blackbox-tests/test-cases/shadow-bindings/run.t b/test/blackbox-tests/test-cases/shadow-bindings/run.t index 8c9d2c57..ed2707d6 100644 --- a/test/blackbox-tests/test-cases/shadow-bindings/run.t +++ b/test/blackbox-tests/test-cases/shadow-bindings/run.t @@ -1,14 +1,5 @@ Bindings introduced by user dependencies should shadow existing bindings $ dune runtest - Internal error, please report upstream including the contents of _build/log. - Description: - ("Local named variable not present in named deps" - (pform "\%{read:y}") - (deps_written_by_user ((:read (In_build_dir default/x))))) - Backtrace: - Raised at file "src/dep_path.ml" (inlined), line 45, characters 24-55 - Called from file "src/build_system.ml", line 89, characters 6-48 - Called from file "src/fiber/fiber.ml", line 243, characters 6-18 + xb foo - [1]