Fix shadowing of forms

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

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

src/pform.ml

@@ -1,73 +1,93 @@
 open Import
 
-type t =
+module Var = struct
-  | Values of Value.t list
+  type t =
-  | Project_root
+    | Values of Value.t list
-  | First_dep
+    | Project_root
-  | Deps
+    | First_dep
-  | Targets
+    | Deps
-  | Named_local
+    | Targets
-  | Exe
+    | Named_local
-  | Dep
+end
-  | Bin
-  | Lib
-  | Libexec
-  | Lib_available
-  | Version
-  | Read
-  | Read_strings
-  | Read_lines
-  | Path_no_dep
-  | Ocaml_config
 
-type with_info =
+module Macro = struct
-  | No_info    of t
+  type t =
-  | Since      of t * Syntax.Version.t
+    | Exe
-  | Deleted_in of t * Syntax.Version.t * string option
+    | 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)
+  type t =
-  let renamed_in ~new_name ~version  = Renamed_in (version, new_name)
+    { vars   : Var.t   map
-  let deleted_in ~version ?repl kind = Deleted_in (kind, version, repl)
+    ; macros : Macro.t map
-  let since ~version v               = Since (v, version)
+    }
 
-  let static =
+  let static_vars =
-    let macro x = No_info x in
+    String.Map.of_list_exn
-    [ "targets", since ~version:(1, 0) Targets
+      [ "targets", since ~version:(1, 0) Var.Targets
-    ; "deps", since ~version:(1, 0) Deps
+      ; "deps", since ~version:(1, 0) Var.Deps
-    ; "project_root", since ~version:(1, 0) Project_root
+      ; "project_root", since ~version:(1, 0) Var.Project_root
 
-    ; "<", deleted_in First_dep ~version:(1, 0)
+      ; "<", deleted_in Var.First_dep ~version:(1, 0)
-             ~repl:"Use a named dependency instead:\
+               ~repl:"Use a named dependency instead:\
-                    \n\
+                      \n\
-                    \n\  (deps (:x <dep>) ...)\
+                      \n\  (deps (:x <dep>) ...)\
-                    \n\   ... %{x} ..."
+                      \n\   ... %{x} ..."
-    ; "@", renamed_in ~version:(1, 0) ~new_name:"targets"
+      ; "@", renamed_in ~version:(1, 0) ~new_name:"targets"
-    ; "^", renamed_in ~version:(1, 0) ~new_name:"deps"
+      ; "^", renamed_in ~version:(1, 0) ~new_name:"deps"
-    ; "SCOPE_ROOT", renamed_in ~version:(1, 0) ~new_name:"project_root"
+      ; "SCOPE_ROOT", renamed_in ~version:(1, 0) ~new_name:"project_root"
+      ]
 
-    ; "exe", macro Exe
+  let macros =
-    ; "bin", macro Bin
+    let macro (x : Macro.t) = No_info x in
-    ; "lib", macro Lib
+    String.Map.of_list_exn
-    ; "libexec", macro Libexec
+      [ "exe", macro Exe
-    ; "lib-available", macro Lib_available
+      ; "bin", macro Bin
-    ; "version", macro Version
+      ; "lib", macro Lib
-    ; "read", macro Read
+      ; "libexec", macro Libexec
-    ; "read-lines", macro Read_lines
+      ; "lib-available", macro Lib_available
-    ; "read-strings", macro Read_strings
+      ; "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"
+      ; "path", renamed_in ~version:(1, 0) ~new_name:"dep"
-    ; "findlib", renamed_in ~version:(1, 0) ~new_name:"lib"
+      ; "findlib", renamed_in ~version:(1, 0) ~new_name:"lib"
 
-    ; "path-no-dep", deleted_in ~version:(1, 0) Path_no_dep
+      ; "path-no-dep", deleted_in ~version:(1, 0) Macro.Path_no_dep
-    ; "ocaml-config", macro Ocaml_config
+      ; "ocaml-config", macro Ocaml_config
-    ]
+      ]
-    |> String.Map.of_list_exn
 
   let create ~(context : Context.t) ~cxx_flags =
     let ocamlopt =
@@ -117,67 +137,96 @@ module Map = struct
       ; "profile"        , string context.profile
       ]
     in
-    String.Map.superpose
+    { vars =
-      static
+        String.Map.superpose
-      (String.Map.of_list_exn
+          static_vars
-         (List.concat
+          (String.Map.of_list_exn
-            [ lowercased
+             (List.concat
-            ; uppercased
+                [ lowercased
-            ; other
+                ; 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 ->
+    String.Map.find map name >>= fun v ->
-      let describe = String_with_vars.Var.describe in
+    let describe = String_with_vars.Var.describe in
-      match v with
+    match v with
-      | No_info v -> Some v
+    | No_info v -> Some v
-      | Since (v, min_version) ->
+    | Since (v, min_version) ->
-        if syntax_version >= min_version then
+      if syntax_version >= min_version then
-          Some v
+        Some v
-        else
+      else
-          Syntax.Error.since (String_with_vars.Var.loc pform)
+        Syntax.Error.since (String_with_vars.Var.loc pform)
-            Stanza.syntax min_version
+          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
+            ~to_:(describe
-          if syntax_version >= in_version then
+                    (String_with_vars.Var.with_name pform ~name:new_name))
-            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
         else
-          Syntax.Error.deleted_in (String_with_vars.Var.loc pform)
+          expand map ~syntax_version:in_version
-            Stanza.syntax syntax_version ~what:(describe pform) ?repl)
+            ~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
+    { vars = List.map ~f:(fun (k, x) -> (k, No_info x)) pforms
-    |> String.Map.of_list_exn
+             |> String.Map.of_list_exn
+    ; macros = String.Map.empty
+    }
 
-  let of_bindings =
+  let of_bindings bindings =
-    Jbuild.Bindings.fold ~f:(fun x acc ->
+    { vars =
-      match x with
+        Jbuild.Bindings.fold bindings ~init:String.Map.empty ~f:(fun x acc ->
-      | Unnamed _ -> acc
+          match x with
-      | Named (s, _) -> String.Map.add acc s (No_info Named_local)
+          | Unnamed _ -> acc
-    ) ~init:empty
+          | 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
+    let value = Var.Values (Value.L.paths [path]) in
-    [ "input-file", since ~version:(1, 0) value
+    { vars =
-    ; "<", renamed_in ~new_name:"input-file" ~version:(1, 0)
+        String.Map.of_list_exn
-    ]
+          [ "input-file", since ~version:(1, 0) value
-    |> String.Map.of_list_exn
+          ; "<", renamed_in ~new_name:"input-file" ~version:(1, 0)
+          ]
+    ; macros = String.Map.empty
+    }
 end

src/pform.mli

@@ -1,30 +1,38 @@
 open Stdune
 
-type t =
+module Var : sig
-  (* Variables *)
+  type t =
-  | Values of Value.t list
+    | Values of Value.t list
-  | Project_root
+    | Project_root
-  | First_dep
+    | First_dep
-  | Deps
+    | Deps
-  | Targets
+    | Targets
-  | Named_local
+    | Named_local
+end
 
-  (* Macros *)
+module Macro : sig
-  | Exe
+  type t =
-  | Dep
+    | Exe
-  | Bin
+    | Dep
-  | Lib
+    | Bin
-  | Libexec
+    | Lib
-  | Lib_available
+    | Libexec
-  | Version
+    | Lib_available
-  | Read
+    | Version
-  | Read_strings
+    | Read
-  | Read_lines
+    | Read_strings
-  | Path_no_dep
+    | Read_lines
-  | Ocaml_config
+    | 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

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 expand_ocaml_config t pform name =
-  let name = Option.value_exn (String_with_vars.Var.payload pform) in
   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
+        | Pform.Expansion.Var (Values l) -> l
-        | Ocaml_config -> expand_ocaml_config t pform
+        | Macro (Ocaml_config, s) -> expand_ocaml_config t pform s
-        | Project_root -> [Value.Dir (Scope.root scope)]
+        | 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
+          | Pform.Expansion.Var (Values l) -> Some l
-          | Ocaml_config       -> Some (expand_ocaml_config sctx pform)
+          | Macro (Ocaml_config, s) -> Some (expand_ocaml_config sctx pform s)
-          | Project_root       -> Some [Value.Dir (Scope.root scope)]
+          | Var Project_root -> Some [Value.Dir (Scope.root scope)]
-          | First_dep | Deps | Named_local -> None
+          | Var (First_dep | Deps | Named_local) -> None
-          | Targets ->
+          | 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)))
+          | Macro (Exe, s) -> Some (path_exp (map_exe (Path.relative dir s)))
-          | Dep -> Some (path_exp (Path.relative dir s))
+          | Macro (Dep, s) -> Some (path_exp (Path.relative dir s))
-          | Bin -> begin
+          | 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

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.
+  xb
-  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
   foo
-  [1]