refactor: introduce simpler env stanza db

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

<!-- ps-id: 29fc65d4-e525-435a-8fd5-c692f204f7b5 -->

src/dune_rules/compilation_context.ml

@@ -180,7 +180,7 @@ let create
   and+ bin_annot =
     match bin_annot with
     | Some b -> Memo.return b
-    | None -> Super_context.bin_annot super_context ~dir:(Obj_dir.dir obj_dir)
+    | None -> Env_stanza_db.bin_annot ~dir:(Obj_dir.dir obj_dir)
   in
   { super_context
   ; scope

src/dune_rules/env_node.ml

@@ -26,7 +26,6 @@ type t =
   ; js_of_ocaml : string list Action_builder.t Js_of_ocaml.Env.t Memo.Lazy.t
   ; coq : Coq.t Action_builder.t Memo.Lazy.t
   ; format_config : Format_config.t Memo.Lazy.t
-  ; bin_annot : bool Memo.Lazy.t
   }
 
 let scope t = t.scope
@@ -47,7 +46,6 @@ let set_format_config t format_config =
 
 let odoc t = Memo.Lazy.force t.odoc
 let coq t = Memo.Lazy.force t.coq
-let bin_annot t = Memo.Lazy.force t.bin_annot
 
 let expand_str_lazy expander sw =
   match String_with_vars.text_only sw with
@@ -70,7 +68,6 @@ let make
   ~default_context_flags
   ~default_env
   ~default_artifacts
-  ~default_bin_annot
   =
   let open Memo.O in
   let config = Dune_env.Stanza.find config_stanza ~profile in
@@ -225,10 +222,6 @@ let make
           "format config should always have a default value taken from the project root"
           [])
   in
-  let bin_annot =
-    inherited ~field:bin_annot ~root:default_bin_annot (fun default ->
-      Memo.return (Option.value ~default config.bin_annot))
-  in
   { scope
   ; ocaml_flags
   ; foreign_flags
@@ -242,6 +235,5 @@ let make
   ; odoc
   ; coq
   ; format_config
-  ; bin_annot
   }
 ;;

src/dune_rules/env_node.mli

@@ -28,7 +28,6 @@ val make
   -> default_context_flags:string list Action_builder.t Foreign_language.Dict.t
   -> default_env:Env.t
   -> default_artifacts:Artifacts.t
-  -> default_bin_annot:bool
   -> t
 
 val scope : t -> Scope.t
@@ -45,4 +44,3 @@ val coq : t -> Coq.t Action_builder.t Memo.t
 val menhir_flags : t -> string list Action_builder.t
 val format_config : t -> Format_config.t Memo.t
 val set_format_config : t -> Format_config.t -> t
-val bin_annot : t -> bool Memo.t

src/dune_rules/env_stanza_db.ml

@@ -0,0 +1,83 @@
+open Import
+open Memo.O
+
+module Node = struct
+  type t =
+    { value : Dune_env.Stanza.t
+    ; parent : t option Memo.t
+    }
+
+  let by_context dir =
+    let open Memo.O in
+    let+ context = Context.DB.by_dir dir in
+    let { Context.Env_nodes.context; workspace } = Context.env_nodes context in
+    match context, workspace with
+    | None, None -> None
+    | Some value, None | None, Some value -> Some { value; parent = Memo.return None }
+    | Some context, Some workspace ->
+      Some
+        { value = context
+        ; parent = Memo.return (Some { value = workspace; parent = Memo.return None })
+        }
+  ;;
+
+  let in_dir ~dir =
+    let+ stanzas = Only_packages.stanzas_in_dir dir in
+    match stanzas with
+    | None -> None
+    | Some stanzas ->
+      List.find_map stanzas.stanzas ~f:(function
+        | Dune_env.T config -> Some config
+        | _ -> None)
+  ;;
+
+  let rec by_dir dir =
+    let parent =
+      let* scope = Scope.DB.find_by_dir dir in
+      if Path.Build.equal dir (Scope.root scope)
+      then by_context dir
+      else (
+        match Path.Build.parent dir with
+        | None -> by_context dir
+        | Some parent -> by_dir parent)
+    in
+    in_dir ~dir
+    >>= function
+    | Some value -> Memo.return (Some { value; parent })
+    | None -> parent
+  ;;
+end
+
+let value ~default ~f =
+  let rec loop = function
+    | None -> Memo.return default
+    | Some { Node.value; parent } ->
+      let* next =
+        f value
+        >>| function
+        | Some x -> `Ok x
+        | None -> `Parent
+      in
+      (match next with
+       | `Ok x -> Memo.return x
+       | `Parent -> parent >>= loop)
+  in
+  fun ~dir -> Node.by_dir dir >>= loop
+;;
+
+let profile ~dir =
+  let name, _ = Path.Build.extract_build_context_exn dir in
+  let context = Context_name.of_string name in
+  Per_context.profile context
+;;
+
+let value ~default ~dir ~f =
+  let profile = lazy (profile ~dir) in
+  value ~default ~dir ~f:(fun stanza ->
+    let+ profile = Lazy.force profile in
+    Dune_env.Stanza.find_opt stanza ~profile |> Option.bind ~f)
+;;
+
+let bin_annot ~dir =
+  value ~default:true ~dir ~f:(fun (t : Dune_env.Stanza.config) -> t.bin_annot)
+;;

src/dune_rules/env_stanza_db.mli

@@ -0,0 +1,9 @@
+open Import
+
+val value
+  :  default:'a
+  -> dir:Path.Build.t
+  -> f:(Dune_env.Stanza.config -> 'a option)
+  -> 'a Memo.t
+
+val bin_annot : dir:Path.Build.t -> bool Memo.t

src/dune_rules/install_rules.ml

@@ -273,7 +273,7 @@ end = struct
       in
       let set_dir m = List.map ~f:(fun (cm_kind, p) -> cm_dir m cm_kind, p) in
       let+ modules_impl =
-        let+ bin_annot = Super_context.bin_annot sctx ~dir in
+        let+ bin_annot = Env_stanza_db.bin_annot ~dir in
         List.concat_map installable_modules.impl ~f:(fun m ->
           let cmt_files =
             match bin_annot with

src/dune_rules/super_context.ml

@@ -178,7 +178,6 @@ end = struct
       ~default_context_flags
       ~default_env:t.context_env
       ~default_artifacts:t.artifacts
-      ~default_bin_annot:true
   ;;
 
   (* Here we jump through some hoops to construct [t] as well as create a
@@ -285,7 +284,6 @@ let add_alias_action t alias ~dir ~loc action =
 
 let local_binaries t ~dir = Env_tree.get_node t ~dir >>= Env_node.local_binaries
 let env_node = Env_tree.get_node
-let bin_annot t ~dir = Env_tree.get_node t ~dir >>= Env_node.bin_annot
 
 let dump_env t ~dir =
   let node = Env_tree.get_node t ~dir in
@@ -431,7 +429,6 @@ let make_default_env_node
       ~default_context_flags
       ~default_env:root_env
       ~default_artifacts:artifacts
-      ~default_bin_annot:true
   in
   make
     ~config_stanza:env_nodes.context

src/dune_rules/super_context.mli

@@ -28,7 +28,6 @@ val context_env : t -> Env.t
 val local_binaries : t -> dir:Path.Build.t -> File_binding.Expanded.t list Memo.t
 
 val env_node : t -> dir:Path.Build.t -> Env_node.t Memo.t
-val bin_annot : t -> dir:Path.Build.t -> bool Memo.t
 
 (** Dump a directory environment in a readable form *)
 val dump_env : t -> dir:Path.Build.t -> Dune_lang.t list Action_builder.t