unikernel/duniverse/dune_/bin/printenv.ml

@@ -0,0 +1,140 @@
+open Import
+
+let dump sctx ~dir =
+  (* TODO all of this printing functions should probably be inlined here as
+     well *)
+  let module Env_node = Dune_rules.Env_node in
+  let module Link_flags = Dune_rules.Link_flags in
+  let module Ocaml_flags = Dune_rules.Ocaml_flags in
+  let open Action_builder.O in
+  let+ o_dump =
+    Dune_rules.Ocaml_flags_db.ocaml_flags_env ~dir
+    |> Action_builder.of_memo
+    >>= Ocaml_flags.dump
+  and+ c_dump =
+    let* foreign_flags =
+      Dune_rules.Foreign_rules.foreign_flags_env ~dir |> Action_builder.of_memo
+    in
+    let+ c_flags = foreign_flags.c
+    and+ cxx_flags = foreign_flags.cxx in
+    List.map
+      ~f:Dune_lang.Encoder.(pair string (list string))
+      [ "c_flags", c_flags; "cxx_flags", cxx_flags ]
+  and+ link_flags_dump =
+    Action_builder.of_memo (Dune_rules.Ocaml_flags_db.link_env ~dir) >>= Link_flags.dump
+  and+ menhir_dump =
+    Dune_rules.Menhir_rules.menhir_env ~dir
+    |> Action_builder.of_memo
+    >>= Dune_lang.Menhir_env.dump
+  and+ coq_dump = Dune_rules.Coq.Coq_rules.coq_env ~dir >>| Dune_rules.Coq.Coq_flags.dump
+  and+ jsoo_js_dump =
+    let module Js_of_ocaml = Dune_lang.Js_of_ocaml in
+    let* jsoo = Action_builder.of_memo (Dune_rules.Jsoo_rules.jsoo_env ~dir ~mode:JS) in
+    Js_of_ocaml.Flags.dump ~mode:JS jsoo.flags
+  and+ jsoo_wasm_dump =
+    let module Js_of_ocaml = Dune_lang.Js_of_ocaml in
+    let* jsoo = Action_builder.of_memo (Dune_rules.Jsoo_rules.jsoo_env ~dir ~mode:Wasm) in
+    Js_of_ocaml.Flags.dump ~mode:Wasm jsoo.flags
+  in
+  let env =
+    List.concat
+      [ o_dump
+      ; c_dump
+      ; link_flags_dump
+      ; menhir_dump
+      ; coq_dump
+      ; jsoo_js_dump
+      ; jsoo_wasm_dump
+      ]
+  in
+  Super_context.context sctx |> Context.name, env
+;;
+
+let pp ppf ~fields sexps =
+  let fields = String.Set.of_list fields in
+  List.iter sexps ~f:(fun sexp ->
+    let do_print =
+      String.Set.is_empty fields
+      ||
+      match sexp with
+      | Dune_lang.List (Atom (A name) :: _) -> String.Set.mem fields name
+      | _ -> false
+    in
+    if do_print
+    then (
+      let version = Dune_lang.Syntax.greatest_supported_version_exn Stanza.syntax in
+      Dune_lang.Ast.add_loc sexp ~loc:Loc.none
+      |> Dune_lang.Cst.concrete
+      |> List.singleton
+      |> Dune_lang.Format.pp_top_sexps ~version
+      |> Format.fprintf ppf "%a@?" Pp.to_fmt))
+;;
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ dir = Arg.(value & pos 0 dir "" & info [] ~docv:"PATH")
+  and+ fields =
+    Arg.(
+      value
+      & opt_all string []
+      & info
+          [ "field" ]
+          ~docv:"FIELD"
+          ~doc:
+            "Only print this field. This option can be repeated multiple times to print \
+             multiple fields.")
+  in
+  let common, config = Common.init builder in
+  Scheduler.go_with_rpc_server ~common ~config (fun () ->
+    let open Fiber.O in
+    let* setup = Import.Main.setup () in
+    let* setup = Memo.run setup in
+    let dir = Path.of_string dir in
+    let checked = Util.check_path setup.contexts dir in
+    let request =
+      Action_builder.all
+        (match checked with
+         | In_build_dir (ctx, _) ->
+           let sctx =
+             Dune_engine.Context_name.Map.find_exn setup.scontexts (Context.name ctx)
+           in
+           [ dump sctx ~dir:(Path.as_in_build_dir_exn dir) ]
+         | In_source_dir dir ->
+           Dune_engine.Context_name.Map.values setup.scontexts
+           |> List.map ~f:(fun sctx ->
+             let dir =
+               Path.Build.append_source
+                 (Context.build_dir (Super_context.context sctx))
+                 dir
+             in
+             dump sctx ~dir)
+         | In_private_context _ | External _ ->
+           User_error.raise [ Pp.text "Environment is not defined for external paths" ]
+         | In_install_dir _ ->
+           User_error.raise [ Pp.text "Environment is not defined in install dirs" ])
+    in
+    build_exn (fun () ->
+      let open Memo.O in
+      let+ res, _facts = Action_builder.evaluate_and_collect_facts request in
+      res)
+    >>| function
+    | [ (_, env) ] -> Format.printf "%a" (pp ~fields) env
+    | l ->
+      List.iter l ~f:(fun (name, env) ->
+        Format.printf
+          "@[<v2>Environment for context %s:@,%a@]@."
+          (Dune_engine.Context_name.to_string name)
+          (pp ~fields)
+          env))
+;;
+
+let command =
+  let doc = "Print the environment of a directory." in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|$(b,dune show env DIR) prints the environment of a directory|}
+    ; `Blocks Common.help_secs
+    ]
+  in
+  Cmd.v (Cmd.info "env" ~doc ~man) term
+;;