refactor: introduce simpler env stanza db

Signed-off-by: Rudi Grinberg <[email protected]>

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

Author: rgrinberg

src/dune_rules/compilation_context.ml

@@ -174,7 +174,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/dune_env.ml

@@ -89,6 +89,11 @@ module Stanza = struct
     ; bin_annot : bool option
     }
 
+  let dyn_of_config { bin_annot; _ } =
+    let open Dyn in
+    record [ "bin_annot", option bool bin_annot ]
+  ;;
+
   let equal_config
     { flags
     ; foreign_flags
@@ -150,6 +155,13 @@ module Stanza = struct
     | Profile of Profile.t
     | Any
 
+  let dyn_of_pattern =
+    let open Dyn in
+    function
+    | Any -> variant "Any" []
+    | Profile p -> variant "Profile" [ Profile.to_dyn p ]
+  ;;
+
   let equal_pattern x y =
     match x, y with
     | Profile x, Profile y -> Profile.equal x y
@@ -165,7 +177,11 @@ module Stanza = struct
     }
 
   let hash { loc = _; rules } = List.hash (Tuple.T2.hash hash_pattern hash_config) rules
-  let to_dyn = Dyn.opaque
+
+  let to_dyn { rules; loc = _ } =
+    let open Dyn in
+    Dyn.list (pair dyn_of_pattern dyn_of_config) rules
+  ;;
 
   let equal { loc = _; rules } t =
     List.equal (Tuple.T2.equal equal_pattern equal_config) rules t.rules
@@ -292,14 +308,14 @@ module Stanza = struct
 
   let empty = { loc = Loc.none; rules = [] }
 
-  let find t ~profile =
-    Option.value ~default:empty_config
-    @@ List.find_map t.rules ~f:(fun (pat, cfg) ->
+  let find_opt t profile =
+    List.find_map t.rules ~f:(fun (pat, cfg) ->
       match pat with
       | Any -> Some cfg
       | Profile a -> Option.some_if (a = profile) cfg)
   ;;
 
+  let find t ~profile = Option.value ~default:empty_config (find_opt t profile)
   let map_configs t ~f = { t with rules = List.map t.rules ~f:(fun (p, c) -> p, f c) }
 
   let add_error t ~message =

src/dune_rules/dune_env.mli

@@ -60,6 +60,7 @@ module Stanza : sig
 
   val decode : t Dune_lang.Decoder.t
   val empty : t
+  val find_opt : t -> Profile.t -> config option
   val find : t -> profile:Profile.t -> config
   val add_error : t -> message:User_message.t -> t
   val add_warning : t -> message:User_message.t -> t

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_bin_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_bin_artifacts:Artifacts.Bin.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,85 @@
+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 in
+    let context = Option.some_if (not (context = Dune_env.Stanza.empty)) context in
+    let workspace = Option.some_if (not (workspace = Dune_env.Stanza.empty)) workspace 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

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

@@ -173,7 +173,6 @@ end = struct
       ~default_context_flags
       ~default_env:t.context_env
       ~default_bin_artifacts:t.bin_artifacts
-      ~default_bin_annot:true
   ;;
 
   (* Here we jump through some hoops to construct [t] as well as create a
@@ -337,7 +336,6 @@ let link_flags t ~dir (spec : Link_flags.Spec.t) =
 
 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 ocaml_flags = Env_tree.get_node t ~dir >>= Env_node.ocaml_flags in
@@ -498,7 +496,6 @@ let create ~(context : Context.t) ~host ~packages ~stanzas =
           ~default_context_flags
           ~default_env:context_env
           ~default_bin_artifacts:artifacts.bin
-          ~default_bin_annot:true
       in
       make
         ~config_stanza:context.env_nodes.context

src/dune_rules/super_context.mli

@@ -50,7 +50,6 @@ val link_flags : t -> dir:Path.Build.t -> Link_flags.Spec.t -> Link_flags.t Memo
 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