Source file EnvMods.ml

(* Vaguely like cmake's or opam's environment modifications. *)

type t = {
  additions : (string * string) list;
  removals : string list;
  path_prepends : (string * string) list;
}

let empty = { additions = []; removals = []; path_prepends = [] }
let additions { additions; _ } = additions
let removals { removals; _ } = removals
let path_prepends { path_prepends; _ } = List.rev path_prepends

(** [cohere mods] removes all additions and path prepends that are in
    the removals list. *)
let cohere t =
  {
    t with
    additions =
      List.fold_left
        (fun acc (name, value) ->
          if List.mem name t.removals then acc else (name, value) :: acc)
        [] t.additions;
    path_prepends =
      List.rev (* maintain order *)
        (List.fold_left
           (fun acc (name, value) ->
             if List.mem name t.removals then acc else (name, value) :: acc)
           [] t.path_prepends);
  }

let list (type a) (pp_v : Format.formatter -> a -> unit)
    (ppf : Format.formatter) (l : a list) =
  let inner =
    Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ") pp_v
  in
  Format.fprintf ppf "@[[@ %a]@]" inner l

let pp ppf t =
  let t' = cohere t in
  Format.fprintf ppf
    "@[@[<hov 2>additions@ %a@]@;\
     @[<hov 2>removals@ %a@]@;\
     @[<hov 2>prepends@ %a@]@]"
    (list (fun fmt (name, value) -> Format.fprintf fmt "+%s=%s" name value))
    (additions t')
    (list (fun fmt name -> Format.fprintf fmt "-%s" name))
    (removals t')
    (list (fun fmt (name, value) -> Format.fprintf fmt "<%s=%s" name value))
    (path_prepends t')

let show t = Format.asprintf "%a" pp t

let add_one (name, value) additions =
  if List.mem_assoc name additions then additions
  else (name, value) :: additions

let add name value t =
  let a' = add_one (name, value) t.additions in
  { t with additions = a' }

let prepend_path name value t =
  { t with path_prepends = (name, value) :: t.path_prepends }

let merge_removals a b = a @ b |> List.sort String.compare

let add_from_env_if_present ~find_opt names env t =
  let a' =
    List.fold_left
      (fun acc name ->
        match find_opt name env with
        | None -> acc
        | Some value -> add_one (name, value) acc)
      t.additions names
  in
  { t with additions = a' }

let remove_names names t =
  let r' = merge_removals names t.removals in
  { t with removals = r' }

let union a b =
  {
    additions = List.fold_right add_one a.additions b.additions;
    path_prepends = a.path_prepends @ b.path_prepends;
    removals = merge_removals a.removals b.removals;
  }

let apply ~find_opt ~set ~remove ~win32 t env =
  let t' = cohere t in
  let pathsep = if win32 then ";" else ":" in
  let remove_from_env ~envnames env =
    List.fold_left (fun env' name -> remove name env') env envnames
  in
  let env_after_adds =
    List.fold_left
      (fun env' (name, value) -> set name value env')
      env t'.additions
  in
  let env_after_path_prepends =
    List.fold_right (* maintain order *)
      (fun (name, value) env' ->
        match find_opt name env' with
        | None -> set name value env'
        | Some value' -> set name (value ^ pathsep ^ value') env')
      t'.path_prepends env_after_adds
  in
  remove_from_env ~envnames:t'.removals env_after_path_prepends