diff --git a/src/context.ml b/src/context.ml index a38ffcfd..360c2e77 100644 --- a/src/context.ml +++ b/src/context.ml @@ -315,6 +315,10 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets () = | Some host -> Env.get host.env "PATH" ) + |> Env.extend_env ( + Option.value ~default:Env.empty + (Option.map findlib_config ~f:Findlib.Config.env) + ) in let stdlib_dir = Path.of_string (Ocaml_config.standard_library ocfg) in let natdynlink_supported = Ocaml_config.natdynlink_supported ocfg in diff --git a/src/env.ml b/src/env.ml index 09cf9cd9..4eb5df57 100644 --- a/src/env.ml +++ b/src/env.ml @@ -22,6 +22,8 @@ let make vars = ; unix = None } +let empty = make Map.empty + let get t k = Map.find t.vars k let to_unix t = @@ -73,3 +75,6 @@ let diff x y = let update t ~var ~f = make (Map.update t.vars var ~f) + +let of_string_map m = + make (String.Map.foldi ~init:Map.empty ~f:(fun k v acc -> Map.add acc k v) m) diff --git a/src/env.mli b/src/env.mli index 25763588..8b20f1ae 100644 --- a/src/env.mli +++ b/src/env.mli @@ -9,6 +9,8 @@ type t module Map : Map.S with type key = Var.t +val empty : t + (** The environment when the process started *) val initial : t @@ -28,3 +30,4 @@ val update : t -> var:string -> f:(string option -> string option) -> t val sexp_of_t : t -> Sexp.t +val of_string_map : string String.Map.t -> t diff --git a/src/findlib.ml b/src/findlib.ml index e534ed3b..e2fecae1 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -11,6 +11,14 @@ module Rule = struct ; value : string } + let pp fmt { preds_required; preds_forbidden; value } = + Fmt.record fmt + [ "preds_required", Fmt.const Ps.pp preds_required + ; "preds_forbidden", Fmt.const Ps.pp preds_forbidden + ; "value", Fmt.const (fun fmt -> Format.fprintf fmt "%S") value + ] + + let formal_predicates_count t = Ps.cardinal t.preds_required + Ps.cardinal t.preds_forbidden @@ -45,19 +53,25 @@ module Rules = struct ; add_rules : Rule.t list } + let pp fmt { set_rules; add_rules } = + Fmt.record fmt + [ "set_rules", (fun fmt () -> Fmt.ocaml_list Rule.pp fmt set_rules) + ; "add_rules", (fun fmt () -> Fmt.ocaml_list Rule.pp fmt add_rules) + ] + let interpret t ~preds = let rec find_set_rule = function - | [] -> "" + | [] -> None | rule :: rules -> if Rule.matches rule ~preds then - rule.value + Some rule.value else find_set_rule rules in let v = find_set_rule t.set_rules in List.fold_left t.add_rules ~init:v ~f:(fun v rule -> if Rule.matches rule ~preds then - v ^ " " ^ rule.value + Some ((Option.value ~default:"" v) ^ " " ^ rule.value) else v) @@ -77,9 +91,8 @@ module Vars = struct type t = Rules.t String.Map.t let get (t : t) var preds = - match String.Map.find t var with - | None -> None - | Some rules -> Some (Rules.interpret rules ~preds) + Option.map (String.Map.find t var) ~f:(fun r -> + Option.value ~default:"" (Rules.interpret r ~preds)) let get_words t var preds = match get t var preds with @@ -93,6 +106,15 @@ module Config = struct ; preds : Ps.t } + let pp fmt { vars; preds } = + Fmt.record fmt + [ "vars" + , Fmt.const (Fmt.ocaml_list (Fmt.tuple Format.pp_print_string Rules.pp)) + (String.Map.to_list vars) + ; "preds" + , Fmt.const Ps.pp preds + ] + let load path ~toolchain ~context = let path = Path.extend_basename path ~suffix:".d" in let conf_file = Path.relative path (toolchain ^ ".conf") in @@ -106,6 +128,11 @@ module Config = struct let get { vars; preds } var = Vars.get vars var preds + + let env t = + let preds = Ps.add t.preds (P.make "env") in + String.Map.filter_map ~f:(Rules.interpret ~preds) t.vars + |> Env.of_string_map end module Package = struct diff --git a/src/findlib.mli b/src/findlib.mli index 39c875d8..83875550 100644 --- a/src/findlib.mli +++ b/src/findlib.mli @@ -1,6 +1,6 @@ (** Findlib database *) -open Stdune +open Import (** Findlib database *) type t @@ -60,6 +60,11 @@ val dummy_package : t -> name:string -> Package.t module Config : sig type t + + val pp : t Fmt.t + val load : Path.t -> toolchain:string -> context:string -> t val get : t -> string -> string option + + val env : t -> Env.t end diff --git a/src/import.ml b/src/import.ml index fd1640f2..ca2d0407 100644 --- a/src/import.ml +++ b/src/import.ml @@ -150,6 +150,9 @@ module Fmt = struct let pp_sep fmt () = Format.fprintf fmt "@,; " in Format.fprintf fmt "@[{ %a@ }@]" (Format.pp_print_list ~pp_sep pp) xs + + let tuple ppfa ppfb fmt (a, b) = + Format.fprintf fmt "@[(%a, %a)@]" ppfa a ppfb b end (* This is ugly *) diff --git a/src/interned.ml b/src/interned.ml index 34111eb5..ac663573 100644 --- a/src/interned.ml +++ b/src/interned.ml @@ -9,6 +9,8 @@ module type S = sig module Set : sig include Set.S with type elt = t val make : string list -> t + + val pp : t Fmt.t end module Map : Map.S with type key = t module Table : sig @@ -72,11 +74,15 @@ module Make() = struct let to_string t = Table.get names t + let pp fmt t = Format.fprintf fmt "%S" (to_string t) + module Set = struct include Int_set let make l = List.fold_left l ~init:empty ~f:(fun acc s -> add acc (make s)) + + let pp fmt (t : t) = Fmt.ocaml_list pp fmt (to_list t) end module Map = Int_map diff --git a/src/interned.mli b/src/interned.mli index 14aee82d..613020bc 100644 --- a/src/interned.mli +++ b/src/interned.mli @@ -17,6 +17,8 @@ module type S = sig include Set.S with type elt = t val make : string list -> t + + val pp : t Fmt.t end module Map : Map.S with type key = t diff --git a/test/unit-tests/jbuild b/test/unit-tests/jbuild index 729685a4..eae5a281 100644 --- a/test/unit-tests/jbuild +++ b/test/unit-tests/jbuild @@ -23,6 +23,7 @@ (deps (tests.mlt (glob_files ${SCOPE_ROOT}/src/.jbuilder.objs/*.cmi) (glob_files ${SCOPE_ROOT}/src/stdune/.stdune.objs/*.cmi) + (files_recursively_in toolchain.d) (files_recursively_in findlib-db))) (action (chdir ${SCOPE_ROOT} (progn diff --git a/test/unit-tests/tests.mlt b/test/unit-tests/tests.mlt index 0cded15a..c3fafb4e 100644 --- a/test/unit-tests/tests.mlt +++ b/test/unit-tests/tests.mlt @@ -77,3 +77,38 @@ val meta : Jbuilder.Meta.Simplified.t = ; subs = [] } |}] + +#install_printer Findlib.Config.pp;; + +let conf = + Findlib.Config.load (Path.of_string "test/unit-tests/toolchain") + ~toolchain:"tlc" ~context:"" + +[%%expect{| +val conf : Jbuilder.Findlib.Config.t = + { vars = + [ (FOO_BAR, { set_rules = + [ { preds_required = [ "tlc"; "env" ] + ; preds_forbidden = [] + ; value = "my variable" + } + ] + ; add_rules = [] + }) + ] + ; preds = [ "tlc" ] + } +|}] + +let env_pp fmt env = Sexp.pp fmt (Env.sexp_of_t env);; +#install_printer env_pp;; + +[%%expect{| +val env_pp : Format.formatter -> Jbuilder.Env.t -> unit = +|}] + +let env = Findlib.Config.env conf + +[%%expect{| +val env : Jbuilder.Env.t = ((FOO_BAR "my variable")) +|}] diff --git a/test/unit-tests/toolchain.d/tlc.conf b/test/unit-tests/toolchain.d/tlc.conf new file mode 100644 index 00000000..71f5150d --- /dev/null +++ b/test/unit-tests/toolchain.d/tlc.conf @@ -0,0 +1 @@ +FOO_BAR(tlc, env) = "my variable" \ No newline at end of file