refactor: introduce simpler env stanza db

doc/changes/8447.md

@@ -0,0 +1,2 @@
+- Do not ignore `(formatting ..)` settings in context or workspace files
+  (#8447, @rgrinberg)

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

@@ -1,13 +1,5 @@
 open Import
 
-module Odoc = struct
-  type warnings = Dune_env.Odoc.warnings =
-    | Fatal
-    | Nonfatal
-
-  type t = { warnings : warnings }
-end
-
 type t =
   { scope : Scope.t
   ; local_binaries : File_binding.Expanded.t list Memo.Lazy.t
@@ -16,13 +8,9 @@ type t =
   ; link_flags : Link_flags.t Memo.Lazy.t
   ; external_env : Env.t Memo.Lazy.t
   ; artifacts : Artifacts.t Memo.Lazy.t
-  ; inline_tests : Dune_env.Inline_tests.t Memo.Lazy.t
   ; menhir_flags : string list Action_builder.t Memo.Lazy.t
-  ; odoc : Odoc.t Action_builder.t Memo.Lazy.t
   ; js_of_ocaml : string list Action_builder.t Js_of_ocaml.Env.t Memo.Lazy.t
   ; coq_flags : Coq_flags.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
@@ -32,18 +20,9 @@ let foreign_flags t = t.foreign_flags
 let link_flags t = Memo.Lazy.force t.link_flags
 let external_env t = Memo.Lazy.force t.external_env
 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 |> Action_builder.of_memo_join
 let coq_flags t = Memo.Lazy.force t.coq_flags
-let bin_annot t = Memo.Lazy.force t.bin_annot
 
 let expand_str_lazy expander sw =
   match String_with_vars.text_only sw with
@@ -66,7 +45,6 @@ let make
   ~default_context_flags
   ~default_env
   ~default_artifacts
-  ~default_bin_annot
   =
   let open Memo.O in
   let config = Dune_env.find config_stanza ~profile in
@@ -77,17 +55,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 config_binaries = Option.value config.binaries ~default:[] in
   let local_binaries =
     Memo.lazy_ (fun () ->
@@ -128,18 +95,6 @@ let make
         ~default:flags
         ~eval:(Expander.expand_and_eval_set expander))
   in
-  let inline_tests =
-    match config with
-    | { inline_tests = Some s; _ } -> Memo.Lazy.of_val s
-    | { inline_tests = None; _ } ->
-      inherited
-        ~field:inline_tests
-        Memo.return
-        ~root:
-          (if Profile.is_inline_test profile
-           then Dune_env.Inline_tests.Enabled
-           else Disabled)
-  in
   let js_of_ocaml =
     inherited
       ~field:(fun t -> js_of_ocaml t)
@@ -195,22 +150,6 @@ let make
           let+ expander = Memo.Lazy.force expander in
           Expander.expand_and_eval_set expander menhir_flags ~standard:flags)
   in
-  let odoc =
-    let open Odoc in
-    let root =
-      (* DUNE4: Enable for dev profile in the future *)
-      Action_builder.return { warnings = Nonfatal }
-    in
-    inherited
-      ~field:(fun t -> Memo.return (odoc t))
-      ~root
-      (fun warnings ->
-        Memo.return
-        @@
-        let open Action_builder.O in
-        let+ { warnings } = warnings in
-        { warnings = Option.value config.odoc.warnings ~default:warnings })
-  in
   let coq_flags : Coq_flags.t Action_builder.t Memo.Lazy.t =
     inherited
       ~field:coq_flags
@@ -231,34 +170,15 @@ let make
          in
          { Coq_flags.coq_flags; coqdoc_flags })
   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
   ; link_flags
   ; external_env
   ; artifacts
   ; local_binaries
-  ; inline_tests
   ; js_of_ocaml
   ; menhir_flags
-  ; odoc
   ; coq_flags
-  ; format_config
-  ; bin_annot
   }
 ;;

src/dune_rules/env_node.mli

@@ -2,14 +2,6 @@
 
 open Import
 
-module Odoc : sig
-  type warnings = Dune_env.Odoc.warnings =
-    | Fatal
-    | Nonfatal
-
-  type t = { warnings : warnings }
-end
-
 type t
 
 val make
@@ -24,13 +16,11 @@ 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
 val external_env : t -> Env.t Memo.t
 val ocaml_flags : t -> Ocaml_flags.t Memo.t
-val inline_tests : t -> Dune_env.Inline_tests.t Memo.t
 val js_of_ocaml : t -> string list Action_builder.t Js_of_ocaml.Env.t Memo.t
 val foreign_flags : t -> string list Action_builder.t Foreign_language.Dict.t
 val link_flags : t -> Link_flags.t Memo.t
@@ -40,9 +30,5 @@ val link_flags : t -> Link_flags.t Memo.t
 val local_binaries : t -> File_binding.Expanded.t list Memo.t
 
 val artifacts : t -> Artifacts.t Memo.t
-val odoc : t -> Odoc.t Action_builder.t
 val coq_flags : t -> Coq_flags.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,99 @@
+open Import
+open Memo.O
+
+module Node = struct
+  type t =
+    { value : Dune_env.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.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.config) -> Memo.return t.bin_annot)
+;;
+
+let inline_tests ~dir =
+  value ~default:None ~dir ~f:(fun (t : Dune_env.config) ->
+    Memo.return
+    @@
+    match t.inline_tests with
+    | None -> None
+    | Some s -> Some (Some s))
+  >>= function
+  | Some s -> Memo.return s
+  | None ->
+    let+ profile = profile ~dir in
+    if Profile.is_inline_test profile then Dune_env.Inline_tests.Enabled else Disabled
+;;

src/dune_rules/env_stanza_db.mli

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

src/dune_rules/format_rules.ml

@@ -154,29 +154,53 @@ let gen_rules_output
   Rules.Produce.Alias.add_deps alias_formatted (Action_builder.return ())
 ;;
 
+let format_config ~dir =
+  let open Memo.O in
+  let+ value =
+    Env_stanza_db.value ~default:None ~dir ~f:(fun (t : Dune_env.config) ->
+      Memo.return
+      @@
+      match t.format_config with
+      | Some x -> Some (Some x)
+      | None -> None)
+  and+ default =
+    (* we always force the default for error checking *)
+    Path.Build.drop_build_context_exn dir
+    |> Source_tree.nearest_dir
+    >>| Source_tree.Dir.project
+    >>| Dune_project.format_config
+  in
+  Option.value value ~default
+;;
+
+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