Fix getting node for directories

CHANGES.md

@@ -30,6 +30,9 @@ unreleased
   one from [this paper](https://doi.org/10.1145/2756553) (#1489,
   @rudihorn)
 
+- Get the correct environment node for multi project workspaces (#1648,
+  @rgrinberg)
+
 1.6.2 (05/12/2018)
 ------------------
 

src/dune_project.ml

@@ -13,6 +13,8 @@ module Name : sig
     | Named     of string
     | Anonymous of Path.t
 
+  val pp : t Fmt.t
+
   val compare : t -> t -> Ordering.t
 
   val to_string_hum : t -> string
@@ -53,6 +55,12 @@ end = struct
 
   let anonymous_root = Anonymous Path.root
 
+  let pp fmt = function
+    | Named n ->
+      Format.fprintf fmt "Named %S" n
+    | Anonymous p ->
+      Format.fprintf fmt "Anonymous %s" (Path.to_string_maybe_quoted p)
+
   let to_string_hum = function
     | Named     s -> s
     | Anonymous p -> sprintf "<anonymous %s>" (Path.to_string_maybe_quoted p)
@@ -130,6 +138,12 @@ module Project_file = struct
     ; mutable exists : bool
     }
 
+  let pp fmt { file ; exists } =
+    Fmt.record fmt
+      [ "file", Fmt.const Path.pp file
+      ; "exists", Fmt.const Format.pp_print_bool exists
+      ]
+
   let to_sexp { file; exists } =
     Sexp.Encoder.(
       record
@@ -155,6 +169,19 @@ let name t = t.name
 let root t = t.root
 let stanza_parser t = t.stanza_parser
 
+let pp fmt { name ; root ; version ; project_file ; parsing_context = _
+           ; extension_args = _; stanza_parser = _ ; packages } =
+  Fmt.record fmt
+    [ "name", Fmt.const Name.pp name
+    ; "root", Fmt.const Path.Local.pp root
+    ; "version", Fmt.const (Fmt.optional Format.pp_print_string) version
+    ; "project_file", Fmt.const Project_file.pp project_file
+    ; "packages",
+      Fmt.const
+        (Fmt.ocaml_list (Fmt.tuple Package.Name.pp Package.pp))
+        (Package.Name.Map.to_list packages)
+    ]
+
 let find_extension_args t key =
   Univ_map.find t.extension_args key
 

src/dune_project.mli

@@ -112,3 +112,5 @@ val get_exn : unit -> (t, 'k) Dune_lang.Decoder.parser
 val find_extension_args : t -> 'a Extension.t -> 'a option
 
 val set_parsing_context : t -> 'a Dune_lang.Decoder.t -> 'a Dune_lang.Decoder.t
+
+val pp : t Fmt.t

src/env_node.ml

@@ -4,7 +4,7 @@ type t =
   { dir                   : Path.t
   ; inherit_from          : t Lazy.t option
   ; scope                 : Scope.t
-  ; config                : Dune_env.Stanza.t
+  ; config                : Dune_env.Stanza.t option
   ; mutable local_binaries : string File_bindings.t option
   ; mutable ocaml_flags   : Ocaml_flags.t option
   ; mutable external_     : Env.t option
@@ -24,12 +24,17 @@ let make ~dir ~inherit_from ~scope ~config ~env =
   ; local_binaries = None
   }
 
+let find_config t ~profile =
+  let open Option.O in
+  t.config >>= fun config ->
+  Dune_env.Stanza.find config ~profile
+
 let local_binaries t ~profile ~expander =
   match t.local_binaries with
   | Some x -> x
   | None ->
     let local_binaries =
-      match Dune_env.Stanza.find t.config ~profile with
+      match find_config t ~profile with
       | None -> []
       | Some cfg ->
         File_bindings.map cfg.binaries ~f:(fun template ->
@@ -49,7 +54,7 @@ let rec external_ t ~profile ~default =
       | Some (lazy t) -> external_ t ~default ~profile
     in
     let (env, have_binaries) =
-      match Dune_env.Stanza.find t.config ~profile with
+      match find_config t ~profile with
       | None -> (default, false)
       | Some cfg ->
         ( Env.extend_env default cfg.env_vars
@@ -91,7 +96,7 @@ let rec ocaml_flags t ~profile ~expander =
       | Some (lazy t) -> ocaml_flags t ~profile ~expander
     in
     let flags =
-      match Dune_env.Stanza.find t.config ~profile with
+      match find_config t ~profile with
       | None -> default
       | Some cfg ->
         let expander = Expander.set_dir expander ~dir:t.dir in

src/env_node.mli

@@ -9,7 +9,7 @@ val make
   :  dir:Path.t
   -> inherit_from:t Lazy.t option
   -> scope:Scope.t
-  -> config:Dune_env.Stanza.t
+  -> config:Dune_env.Stanza.t option
   -> env:Env.t option
   -> t
 

src/file_bindings.ml

@@ -68,3 +68,11 @@ module Unexpanded = struct
 end
 
 let is_empty xs = List.is_empty xs
+
+let pp f =
+  Fmt.ocaml_list
+    (fun fmt { src; dst } ->
+       Fmt.record fmt
+         [ "src", Fmt.const f src
+         ; "dst", Fmt.const (Fmt.optional f) dst
+         ])

src/file_bindings.mli

@@ -22,3 +22,5 @@ module Unexpanded : sig
 end
 
 val is_empty : _ t -> bool
+
+val pp : 'a Fmt.t -> 'a t Fmt.t

src/gen_rules.ml

@@ -199,7 +199,7 @@ module Gen(P : Install_rules.Params) = struct
        begin match List.last comps with
        | Some ".bin" ->
          let src_dir = Path.parent_exn dir in
-         Super_context.local_binaries sctx ~dir
+         Super_context.local_binaries sctx ~dir:src_dir
          |> List.iter ~f:(fun t ->
            let src = File_bindings.src_path t ~dir:src_dir in
            let dst = File_bindings.dst_path t ~dir in

src/super_context.ml

@@ -96,11 +96,9 @@ end = struct
             | None -> raise_notrace Exit
             | Some parent -> lazy (get t ~dir:parent ~scope)
         in
-        match get_env_stanza t ~dir with
-        | None -> Lazy.force inherit_from
-        | Some config ->
-          Env_node.make ~dir ~scope ~config ~inherit_from:(Some inherit_from)
-            ~env:None
+        let config = get_env_stanza t ~dir in
+        Env_node.make ~dir ~scope ~config ~inherit_from:(Some inherit_from)
+          ~env:None
       in
       Hashtbl.add t.env dir node;
       node
@@ -314,13 +312,14 @@ let create
     in
     match context.env_nodes with
     | { context = None; workspace = None } ->
-      make ~config:{ loc = Loc.none; rules = [] } ~inherit_from:None
-    | { context = Some config; workspace = None }
-    | { context = None; workspace = Some config } ->
+      make ~config:(Some { loc = Loc.none; rules = [] }) ~inherit_from:None
+    | { context = Some _ as config; workspace = None }
+    | { context = None; workspace = Some _ as config } ->
       make ~config ~inherit_from:None
-    | { context = Some context ; workspace = Some workspace } ->
+    | { context = Some _ as context ; workspace = Some _ as workspace } ->
       make ~config:context
-        ~inherit_from:(Some (lazy (make ~inherit_from:None ~config:workspace)))
+        ~inherit_from:(Some (lazy (make ~inherit_from:None
+                                     ~config:workspace)))
   ) in
   let expander =
     let artifacts_host =

src/super_context.mli

@@ -53,8 +53,8 @@ val ocaml_flags
   -> Buildable.t
   -> Ocaml_flags.t
 
-(** Binaries that are symlinked in local .bin directories. [dir]
-    should point to such a [.bin] directory, such as [foo/bar/.bin]. *)
+(** Binaries that are symlinked in the associated .bin directory of [dir]. This
+    associated directory is [Path.relative dir ".bin"] *)
 val local_binaries : t -> dir:Path.t -> string File_bindings.t
 
 (** Dump a directory environment in a readable form *)

test/blackbox-tests/test-cases/embed-jbuild/run.t

@@ -10,15 +10,5 @@ Now lets try with a jbuild project in the subdirectory:
 Now lets try it from the current directory:
 
   $ dune build a-dune-proj/version.ml --root=.
-  File "a-dune-proj/dune", line 5, characters 29-49:
-  5 |     (echo "let version = \"%{version:a-dune-proj}\""))))
-                                   ^^^^^^^^^^^^^^^^^^^^
-  Error: Package "a-dune-proj" doesn't exist in the current project.
-  [1]
   $ dune build a-jbuild-proj/version.ml --root=.
-  File "a-jbuild-proj/jbuild", line 7, characters 10-54:
-  7 |     (echo "let version = \"${version:a-jbuild-proj}\"")))))
-                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-  Error: Package "a-jbuild-proj" doesn't exist in the current project.
-  [1]