Merge pull request #601 from rgrinberg/env-context

Move env var handling outside of Context.t
2018-03-12 19:13:33 +07:00 · 2018-03-12 19:13:33 +07:00 · 2f7db648ed
parent f74817e00d eef3633d9a
commit 2f7db648ed
8 changed files with 152 additions and 122 deletions
--- a/src/action.ml
+++ b/src/action.ml
@ -1,8 +1,6 @@
 open Import
 open Sexp.Of_sexp

-module Env_var_map = Context.Env_var_map
-
 module Outputs = struct
  include Action_intf.Outputs

@ -699,10 +697,9 @@ end
 type exec_context =
  { context : Context.t option
  ; purpose : Process.purpose
-  ; env     : string array
  }

-let exec_run_direct ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
+let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args =
  begin match ectx.context with
   | None
   | Some { Context.for_host = None; _ } -> ()
@ -717,8 +714,8 @@ let exec_run_direct ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
     invalid_prefix ("_build/" ^ target.name);
     invalid_prefix ("_build/install/" ^ target.name);
  end;
-  let env = Context.extend_env ~vars:env_extra ~env:ectx.env in
-  Process.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to ~stderr_to
+  Process.run Strict ~dir:(Path.to_string dir) ~env
+    ~stdout_to ~stderr_to
    ~purpose:ectx.purpose
    (Path.reach_for_running ~from:dir prog) args

@ -733,17 +730,17 @@ let exec_echo stdout_to str =
     | None -> print_string str; flush stdout
     | Some (_, oc) -> output_string oc str)

-let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
+let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
  match t with
  | Run (Error e, _) ->
    Prog.Not_found.raise e
  | Run (Ok prog, args) ->
-    exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args
+    exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to prog args
  | Chdir (dir, t) ->
-    exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
+    exec t ~ectx ~dir ~env ~stdout_to ~stderr_to
  | Setenv (var, value, t) ->
    exec t ~ectx ~dir ~stdout_to ~stderr_to
-      ~env_extra:(Env_var_map.add env_extra var value)
+      ~env:(Env.add env ~var ~value)
  | Redirect (Stdout, fn, Echo s) ->
    Io.write_file (Path.to_string fn) s;
    Fiber.return ()
@ -755,13 +752,13 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
      | Stderr -> (get_std_output stdout_to, out)
      | Outputs -> (out, out)
    in
-    exec_run_direct ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args
+    exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args
  | Redirect (outputs, fn, t) ->
-    redirect ~ectx ~dir outputs fn t ~env_extra ~stdout_to ~stderr_to
+    redirect ~ectx ~dir outputs fn t ~env ~stdout_to ~stderr_to
  | Ignore (outputs, t) ->
-    redirect ~ectx ~dir outputs Config.dev_null t ~env_extra ~stdout_to ~stderr_to
+    redirect ~ectx ~dir outputs Config.dev_null t ~env ~stdout_to ~stderr_to
  | Progn l ->
-    exec_list l ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
+    exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to
  | Echo str -> exec_echo stdout_to str
  | Cat fn ->
    Io.with_file_in (Path.to_string fn) ~f:(fun ic ->
@ -814,9 +811,9 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
    let path, arg =
      Utils.system_shell_exn ~needed_to:"interpret (system ...) actions"
    in
-    exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to path [arg; cmd]
+    exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to path [arg; cmd]
  | Bash cmd ->
-    exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
+    exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to
      (Utils.bash_exn ~needed_to:"interpret (bash ...) actions")
      ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
  | Write_file (fn, s) ->
@ -868,7 +865,7 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
      Print_diff.print file1 file2
    end

-and redirect outputs fn t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
+and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to =
  let fn = Path.to_string fn in
  let oc = Io.open_out fn in
  let out = Some (fn, oc) in
@ -878,30 +875,29 @@ and redirect outputs fn t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
    | Stderr -> (stdout_to, out)
    | Outputs -> (out, out)
  in
-  exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to >>| fun () ->
+  exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>| fun () ->
  close_out oc

-and exec_list l ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
+and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to =
  match l with
  | [] ->
    Fiber.return ()
  | [t] ->
-    exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
+    exec t ~ectx ~dir ~env ~stdout_to ~stderr_to
  | t :: rest ->
-    exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to >>= fun () ->
-    exec_list rest ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
+    exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>= fun () ->
+    exec_list rest ~ectx ~dir ~env ~stdout_to ~stderr_to

 let exec ~targets ?context t =
  let env =
    match (context : Context.t option) with
-    | None -> Lazy.force Context.initial_env
+    | None -> Env.initial ()
    | Some c -> c.env
  in
  let targets = Path.Set.to_list targets in
  let purpose = Process.Build_job targets in
-  let ectx = { purpose; context; env } in
-  exec t ~ectx ~dir:Path.root ~env_extra:Env_var_map.empty
-    ~stdout_to:None ~stderr_to:None
+  let ectx = { purpose; context } in
+  exec t ~ectx ~dir:Path.root ~env ~stdout_to:None ~stderr_to:None

 let sandbox t ~sandboxed ~deps ~targets =
  Progn
--- a/src/context.ml
+++ b/src/context.ml
@ -18,17 +18,6 @@ module Kind = struct
                           ])
 end

-module Env_var = struct
-  type t = string
-  let compare a b =
-    if Sys.win32 then
-      String.compare (String.lowercase a) (String.lowercase b)
-    else
-      String.compare a b
-end
-
-module Env_var_map = Map.Make(Env_var)
-
 type t =
  { name                    : string
  ; kind                    : Kind.t
@ -44,8 +33,7 @@ type t =
  ; ocamlopt                : Path.t option
  ; ocamldep                : Path.t
  ; ocamlmklib              : Path.t
-  ; env                     : string array
-  ; env_extra               : string Env_var_map.t
+  ; env                     : Env.t
  ; findlib                 : Findlib.t
  ; findlib_toolchain       : string option
  ; arch_sixtyfour          : bool
@ -103,7 +91,7 @@ let sexp_of_t t =
    ; "ocamlopt", option path t.ocamlopt
    ; "ocamldep", path t.ocamldep
    ; "ocamlmklib", path t.ocamlmklib
-    ; "env", list (pair string string) (Env_var_map.to_list t.env_extra)
+    ; "env", Env.sexp_of_t (Env.diff t.env (Env.initial ()))
    ; "findlib_path", list path (Findlib.path t.findlib)
    ; "arch_sixtyfour", bool t.arch_sixtyfour
    ; "natdynlink_supported", bool t.natdynlink_supported
@ -130,44 +118,10 @@ let opam_config_var ~env ~cache var =
        Some s
      | Error _ -> None

-let get_env env var =
-  let rec loop i =
-    if i = Array.length env then
-      None
-    else
-      let entry = env.(i) in
-      match String.lsplit2 entry ~on:'=' with
-      | Some (key, value) when Env_var.compare key var = Eq ->
-        Some value
-      | _ -> loop (i + 1)
-  in
-  loop 0
-
 let which ~cache ~path x =
  Hashtbl.find_or_add cache x ~f:(Bin.which ~path)

-let extend_env ~vars ~env =
-  if Env_var_map.is_empty vars then
-    env
-  else
-    let imported =
-      Array.to_list env
-      |> List.filter ~f:(fun s ->
-        match String.index s '=' with
-        | None -> true
-        | Some i ->
-          let key = String.sub s ~pos:0 ~len:i in
-          not (Env_var_map.mem vars key))
-    in
-    List.rev_append
-      (List.map (Env_var_map.to_list vars)
-         ~f:(fun (k, v) -> sprintf "%s=%s" k v))
-      imported
-    |> Array.of_list
-
-let create ~(kind : Kind.t) ~path ~base_env ~env_extra ~name ~merlin
-      ~targets () =
-  let env = extend_env ~env:base_env ~vars:env_extra in
+let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets () =
  let opam_var_cache = Hashtbl.create 128 in
  (match kind with
   | Opam { root; _ } ->
@ -281,7 +235,7 @@ let create ~(kind : Kind.t) ~path ~base_env ~env_extra ~name ~merlin
           (Ocaml_config.Vars.of_lines lines >>= Ocaml_config.make))
    >>= fun (findlib_path, ocfg) ->
    let version = Ocaml_config.version ocfg in
-    let env, env_extra =
+    let env =
      (* See comment in ansi_color.ml for setup_env_for_colors. For
         OCaml < 4.05, OCAML_COLOR is not supported so we use
         OCAMLPARAM. OCaml 4.02 doesn't support 'color' in OCAMLPARAM,
@ -291,14 +245,13 @@ let create ~(kind : Kind.t) ~path ~base_env ~env_extra ~name ~merlin
      && version >= (4, 03, 0)
      && version <  (4, 05, 0) then
        let value =
-          match get_env env "OCAMLPARAM" with
+          match Env.get env "OCAMLPARAM" with
          | None -> "color=always,_"
          | Some s -> "color=always," ^ s
        in
-        extend_env ~env ~vars:((Env_var_map.singleton "OCAMLPARAM" value)),
-        (Env_var_map.add env_extra "OCAMLPARAM" value)
+        Env.add env ~var:"OCAMLPARAM" ~value
      else
-        env,env_extra
+        env
    in
    let stdlib_dir = Path.of_string (Ocaml_config.standard_library ocfg) in
    let natdynlink_supported = Ocaml_config.natdynlink_supported ocfg in
@ -313,7 +266,8 @@ let create ~(kind : Kind.t) ~path ~base_env ~env_extra ~name ~merlin
      ; for_host = host
      ; build_dir
      ; path
-      ; toplevel_path = Option.map (get_env env "OCAML_TOPLEVEL_PATH") ~f:Path.absolute
+      ; toplevel_path =
+          Option.map (Env.get env "OCAML_TOPLEVEL_PATH") ~f:Path.absolute

      ; ocaml_bin  = dir
      ; ocaml      = (match which "ocaml" with Some p -> p | None -> prog_not_found_in_path "ocaml")
@ -323,7 +277,6 @@ let create ~(kind : Kind.t) ~path ~base_env ~env_extra ~name ~merlin
      ; ocamlmklib = get_ocaml_tool_exn "ocamlmklib"

      ; env
-      ; env_extra
      ; findlib = Findlib.create ~stdlib_dir ~path:findlib_path
      ; findlib_toolchain
      ; arch_sixtyfour
@ -384,18 +337,8 @@ let create ~(kind : Kind.t) ~path ~base_env ~env_extra ~name ~merlin

 let opam_config_var t var = opam_config_var ~env:t.env ~cache:t.opam_var_cache var

-let initial_env = lazy (
-  Lazy.force Colors.setup_env_for_colors;
-  Unix.environment ())
-
 let default ?(merlin=true) ~targets () =
-  let env = Lazy.force initial_env in
-  let path =
-    match get_env env "PATH" with
-    | Some s -> Bin.parse_path s
-    | None -> []
-  in
-  create ~kind:Default ~path ~base_env:env ~env_extra:Env_var_map.empty
+  create ~kind:Default ~path:Bin.path ~env:(Env.initial ())
    ~name:"default" ~merlin ~targets ()

 let create_for_opam ?root ~targets ~switch ~name ?(merlin=false) () =
@ -413,8 +356,8 @@ let create_for_opam ?root ~targets ~switch ~name ?(merlin=false) () =
    let vars =
      Usexp.parse_string ~fname:"<opam output>" ~mode:Single s
      |> Sexp.Of_sexp.(list (pair string string))
-      |> Env_var_map.of_list_multi
-      |> Env_var_map.mapi ~f:(fun var values ->
+      |> Env.Map.of_list_multi
+      |> Env.Map.mapi ~f:(fun var values ->
        match List.rev values with
        | [] -> assert false
        | [x] -> x
@ -430,13 +373,12 @@ let create_for_opam ?root ~targets ~switch ~name ?(merlin=false) () =
          x)
    in
    let path =
-      match Env_var_map.find vars "PATH" with
+      match Env.Map.find vars "PATH" with
      | None -> Bin.path
      | Some s -> Bin.parse_path s
    in
-    let env = Lazy.force initial_env in
-    create ~kind:(Opam { root; switch }) ~targets
-      ~path ~base_env:env ~env_extra:vars ~name ~merlin ()
+    let env = Env.extend (Env.initial ()) ~vars in
+    create ~kind:(Opam { root; switch }) ~targets ~path ~env ~name ~merlin ()

 let create ?merlin def =
  match (def : Workspace.Context.t) with
@ -472,7 +414,7 @@ let env_for_exec t =
  let cwd = Sys.getcwd () in
  let extend_var var v =
    let v = Filename.concat cwd (Path.to_string v) in
-    match get_env t.env var with
+    match Env.get t.env var with
    | None -> (var, v)
    | Some prev -> (var, sprintf "%s%c%s" v sep prev)
  in
@ -491,7 +433,7 @@ let env_for_exec t =
        (Config.local_install_man_dir ~context:t.name)
    ]
  in
-  extend_env ~env:t.env ~vars:(Env_var_map.of_list_exn vars)
+  Env.to_unix (Env.extend t.env ~vars:(Env.Map.of_list_exn vars))

 let compiler t (mode : Mode.t) =
  match mode with
--- a/src/context.mli
+++ b/src/context.mli
@ -30,13 +30,6 @@ module Kind : sig
  type t = Default | Opam of Opam.t
 end

-module Env_var : sig
-  type t = string
-  val compare : t -> t -> Ordering.t
-end
-
-module Env_var_map : Map.S with type key := Env_var.t
-
 type t =
  { name : string
  ; kind : Kind.t
@ -70,10 +63,7 @@ type t =
  ; ocamlmklib : Path.t

  ; (** Environment variables *)
-    env : string array
-
-  ; (** Diff between the base environment and [env] *)
-    env_extra : string Env_var_map.t
+    env : Env.t

  ; findlib : Findlib.t
  ; findlib_toolchain : string option
@ -135,8 +125,6 @@ val create

 val which : t -> string -> Path.t option

-val extend_env : vars:string Env_var_map.t -> env:string array -> string array
-
 val opam_config_var : t -> string -> string option Fiber.t

 val install_prefix : t -> Path.t Fiber.t
@ -144,8 +132,6 @@ val install_ocaml_libdir : t -> Path.t option Fiber.t

 val env_for_exec : t -> string array

-val initial_env : string array Lazy.t
-
 (** Return the compiler needed for this compilation mode *)
 val compiler : t -> Mode.t -> Path.t option

--- a/src/env.ml
+++ b/src/env.ml
@ -0,0 +1,81 @@
+open Import
+
+module Var = struct
+  type t = string
+  let compare =
+    if Sys.win32 then (
+      fun a b -> String.compare (String.lowercase a) (String.lowercase b)
+    ) else (
+      String.compare
+    )
+end
+
+module Map = Map.Make(Var)
+
+type t =
+  { vars : string Map.t
+  ; mutable unix : string array option
+  }
+
+let make vars =
+  { vars
+  ; unix = None
+  }
+
+let get t k = Map.find t.vars k
+
+let to_unix t =
+  match t.unix with
+  | Some v -> v
+  | None ->
+    let res =
+      Map.foldi ~init:[] ~f:(fun k v acc ->
+        (sprintf "%s=%s" k v)::acc
+      ) t.vars
+      |> Array.of_list in
+    t.unix <- Some res;
+    res
+
+let of_unix arr =
+  Array.to_list arr
+  |> List.map ~f:(fun s ->
+    match String.lsplit2 s ~on:'=' with
+    | None ->
+      Sexp.code_error "Env.of_unix: entry without '=' found in the environ"
+        ["var", Sexp.To_sexp.string s]
+    | Some (k, v) -> (k, v))
+  |> Map.of_list
+  |> function
+  | Ok x -> x
+  | Error (var, v1, v2) ->
+    Sexp.code_error "Env.of_unix: duplicated variable found in the environment"
+      [ "var"   , Sexp.To_sexp.string var
+      ; "value1", Sexp.To_sexp.string v1
+      ; "value2", Sexp.To_sexp.string v2
+      ]
+
+let initial =
+  let i =
+    lazy (
+      make (Lazy.force Colors.setup_env_for_colors;
+            Unix.environment ()
+            |> of_unix)
+    ) in
+  fun () -> Lazy.force i
+
+let add t ~var ~value =
+  make (Map.add t.vars var value)
+
+let extend t ~vars =
+  make (Map.union t.vars vars ~f:(fun _ _ v -> Some v))
+
+let sexp_of_t t =
+  let open Sexp.To_sexp in
+  (list (pair string string)) (Map.to_list t.vars)
+
+let diff x y =
+  Map.merge x.vars y.vars ~f:(fun _k vx vy ->
+    match vy with
+    | Some _ -> None
+    | None -> vx)
+  |> make
--- a/src/env.mli
+++ b/src/env.mli
@ -0,0 +1,24 @@
+open Import
+
+module Var : sig
+  type t = string
+  val compare : t -> t -> Ordering.t
+end
+
+type t
+
+module Map : Map.S with type key = Var.t
+
+val initial : unit -> t
+
+val to_unix : t -> string array
+
+val get : t -> Var.t -> string option
+
+val extend : t -> vars:string Map.t -> t
+
+val add : t -> var:Var.t -> value:string -> t
+
+val diff : t -> t -> t
+
+val sexp_of_t : t -> Sexp.t
--- a/src/jbuild_load.ml
+++ b/src/jbuild_load.ml
@ -148,7 +148,8 @@ end
           in
         ]}
      *)
-      Process.run Strict ~dir:(Path.to_string dir) ~env:context.env
+      Process.run Strict ~dir:(Path.to_string dir)
+        ~env:context.env
        (Path.to_string context.ocaml)
        args
      >>= fun () ->
--- a/src/process.ml
+++ b/src/process.ml
@ -243,7 +243,7 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env ~purpose
      Unix.create_process prog argv
        Unix.stdin stdout stderr
    | Some env ->
-      Unix.create_process_env prog argv env
+      Unix.create_process_env prog argv (Env.to_unix env)
        Unix.stdin stdout stderr
  in
  let pid =
--- a/src/process.mli
+++ b/src/process.mli
@ -41,7 +41,7 @@ val run
  :  ?dir:string
  -> ?stdout_to:std_output_to
  -> ?stderr_to:std_output_to
-  -> ?env:string array
+  -> ?env:Env.t
  -> ?purpose:purpose
  -> (unit, 'a) failure_mode
  -> string
@ -51,7 +51,7 @@ val run
 (** Run a command and capture its output *)
 val run_capture
  :  ?dir:string
-  -> ?env:string array
+  -> ?env:Env.t
  -> ?purpose:purpose
  -> (string, 'a) failure_mode
  -> string
@ -59,7 +59,7 @@ val run_capture
  -> 'a Fiber.t
 val run_capture_line
  :  ?dir:string
-  -> ?env:string array
+  -> ?env:Env.t
  -> ?purpose:purpose
  -> (string, 'a) failure_mode
  -> string
@ -67,7 +67,7 @@ val run_capture_line
  -> 'a Fiber.t
 val run_capture_lines
  :  ?dir:string
-  -> ?env:string array
+  -> ?env:Env.t
  -> ?purpose:purpose
  -> (string list, 'a) failure_mode
  -> string