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

@@ -25,8 +25,6 @@ type t =
   ; odoc : Odoc.t Memo.Lazy.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
@@ -39,15 +37,8 @@ let artifacts t = Memo.Lazy.force t.artifacts
 let inline_tests t = Memo.Lazy.force t.inline_tests
 let js_of_ocaml t = Memo.Lazy.force t.js_of_ocaml
 let menhir_flags t = Memo.Lazy.force t.menhir_flags |> Action_builder.of_memo_join
-let format_config t = Memo.Lazy.force t.format_config
-
-let set_format_config t format_config =
-  { t with format_config = Memo.Lazy.of_val 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 +61,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
@@ -81,17 +71,6 @@ let make
        | Some t -> Memo.Lazy.force t >>= field)
       >>= extend)
   in
-  let inherited_if_absent ~field ~root ~f_absent =
-    Memo.lazy_ (fun () ->
-      match root with
-      | Some x -> Memo.return x
-      | None ->
-        (match inherit_from with
-         | None -> f_absent None
-         | Some t ->
-           let* field = Memo.Lazy.force t >>= field in
-           f_absent (Some field)))
-  in
   let local_binaries =
     Memo.lazy_ (fun () ->
       Memo.parallel_map
@@ -214,21 +193,6 @@ let make
       let standard = flags in
       Expander.expand_and_eval_set expander config.coq ~standard)
   in
-  let format_config =
-    inherited_if_absent
-      ~field:format_config
-      ~root:config.format_config
-      ~f_absent:(function
-      | Some x -> Memo.return x
-      | None ->
-        Code_error.raise
-          "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
@@ -241,7 +205,5 @@ let make
   ; menhir_flags
   ; 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
@@ -43,6 +42,3 @@ val artifacts : t -> Artifacts.t Memo.t
 val odoc : t -> Odoc.t Memo.t
 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,86 @@
+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 =
+    Only_packages.stanzas_in_dir dir
+    >>| function
+    | 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
+    match Dune_env.Stanza.find_opt stanza ~profile with
+    | None -> Memo.return None
+    | Some stanza -> f stanza)
+;;
+
+let bin_annot ~dir =
+  value ~default:true ~dir ~f:(fun (t : Dune_env.Stanza.config) ->
+    Memo.return 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 Memo.t)
+  -> 'a Memo.t
+
+val bin_annot : dir:Path.Build.t -> bool Memo.t

src/dune_rules/format_rules.ml

@@ -154,29 +154,49 @@ let gen_rules_output
   Rules.Produce.Alias.add_deps alias_formatted (Action_builder.return ())
 ;;
 
+let format_config ~dir =
+  let open Memo.O in
+  Env_stanza_db.value ~default:None ~dir ~f:(fun (t : Dune_env.Stanza.config) ->
+    match t.format_config with
+    | Some x -> Memo.return @@ Some (Some x)
+    | None -> Memo.return None)
+  >>= function
+  | Some s -> Memo.return s
+  | None ->
+    Path.Build.drop_build_context_exn dir
+    |> Source_tree.nearest_dir
+    >>| Source_tree.Dir.project
+    >>| Dune_project.format_config
+;;
+
+let with_config ~dir f =
+  let open Memo.O in
+  let* config = format_config ~dir in
+  if Format_config.is_empty config
+  then
+    (* CR-rgrinberg: this [is_empty] check is weird. We should use [None]
+       to represent that no settings have been set. *)
+    Memo.return ()
+  else f config
+;;
+
 let gen_rules sctx ~output_dir =
   let open Memo.O in
   let dir = Path.Build.parent_exn output_dir in
-  let* config = Super_context.env_node sctx ~dir >>= Env_node.format_config in
-  Memo.when_
-    (not (Format_config.is_empty config))
-    (fun () ->
-      let* expander = Super_context.expander sctx ~dir in
-      let* scope = Scope.DB.find_by_dir output_dir in
-      let project = Scope.project scope in
-      let dialects = Dune_project.dialects project in
-      let version = Dune_project.dune_version project in
-      gen_rules_output sctx config ~version ~dialects ~expander ~output_dir)
+  with_config ~dir (fun config ->
+    let* expander = Super_context.expander sctx ~dir in
+    (* CR-rgrinberg: initializing the library database seems unnecessary here *)
+    let* scope = Scope.DB.find_by_dir output_dir in
+    let project = Scope.project scope in
+    let dialects = Dune_project.dialects project in
+    let version = Dune_project.dune_version project in
+    gen_rules_output sctx config ~version ~dialects ~expander ~output_dir)
 ;;
 
-let setup_alias sctx ~dir =
-  let open Memo.O in
-  let* config = Super_context.env_node sctx ~dir >>= Env_node.format_config in
-  Memo.when_
-    (not (Format_config.is_empty config))
-    (fun () ->
-      let output_dir = Path.Build.relative dir formatted_dir_basename in
-      let alias = Alias.fmt ~dir in
-      let alias_formatted = Alias.fmt ~dir:output_dir in
-      Rules.Produce.Alias.add_deps alias (Action_builder.dep (Dep.alias alias_formatted)))
+let setup_alias ~dir =
+  with_config ~dir (fun (_ : Format_config.t) ->
+    let output_dir = Path.Build.relative dir formatted_dir_basename in
+    let alias = Alias.fmt ~dir in
+    let alias_formatted = Alias.fmt ~dir:output_dir in
+    Rules.Produce.Alias.add_deps alias (Action_builder.dep (Dep.alias alias_formatted)))
 ;;

src/dune_rules/format_rules.mli

@@ -9,6 +9,6 @@ val gen_rules : Super_context.t -> output_dir:Path.Build.t -> unit Memo.t
 
 (** This must be called from the main directory, i.e. the ones containing the
     source files and the the [formatted_dir_basename] sub-directory. *)
-val setup_alias : Super_context.t -> dir:Path.Build.t -> unit Memo.t
+val setup_alias : dir:Path.Build.t -> unit Memo.t
 
 val formatted_dir_basename : Filename.t

src/dune_rules/gen_rules.ml

@@ -300,7 +300,7 @@ let gen_rules_for_stanzas
 ;;
 
 let gen_format_and_cram_rules sctx ~expander ~dir source_dir =
-  let+ () = Format_rules.setup_alias sctx ~dir
+  let+ () = Format_rules.setup_alias ~dir
   and+ () =
     Source_tree.Dir.cram_tests source_dir >>= Cram_rules.rules ~sctx ~expander ~dir
   in

src/dune_rules/install_rules.ml

@@ -279,7 +279,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

@@ -136,11 +136,7 @@ end = struct
     let project = Scope.project scope in
     let inherit_from =
       if Path.Build.equal dir (Scope.root scope)
-      then (
-        let format_config = Dune_project.format_config project in
-        Memo.lazy_ (fun () ->
-          let+ default_env = Memo.Lazy.force t.default_env in
-          Env_node.set_format_config default_env format_config))
+      then Memo.lazy_ (fun () -> Memo.Lazy.force t.default_env)
       else (
         match Path.Build.parent dir with
         | None ->
@@ -178,7 +174,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
@@ -276,7 +271,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
@@ -432,7 +426,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

@@ -31,7 +31,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