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 ~compare (name, value) additions =
  match
    List.find_opt (fun (name', _value) -> compare name' name = 0) additions
  with
  | Some _ -> additions
  | None -> (name, value) :: additions

let add name value t =
  let a' = add_one ~compare:String.compare (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 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 ~compare:String.compare) a.additions b.additions;
    path_prepends = a.path_prepends @ b.path_prepends;
    removals = merge_removals a.removals b.removals;
  }

module CaseSensitiveMap = Map.Make (String)

let insensitive_compare a b =
  String.compare (String.uppercase_ascii a) (String.uppercase_ascii b)

module CaseInsensitiveMap = Map.Make (struct
  type t = string

  let compare = insensitive_compare
end)

module type CasedMap = Map.S with type key = string

let add_from_env_if_present ~win32 names env_bindings t =
  (* Construct a case-sensitive map for Unix or case-insensitive map for Windows *)
  let map_module, compare =
    if win32 then ((module CaseInsensitiveMap : CasedMap), insensitive_compare)
    else ((module CaseSensitiveMap : CasedMap), String.compare)
  in
  let module M = (val map_module) in
  let env =
    List.fold_left
      (fun map (name, value) -> M.add name value map)
      M.empty env_bindings
  in
  (* add *)
  let a' =
    List.fold_left
      (fun acc name ->
        match M.find_opt name env with
        | None -> acc
        | Some value -> add_one ~compare (name, value) acc)
      t.additions names
  in
  { t with additions = a' }

let apply ~win32 t env_bindings =
  (* Construct a case-sensitive map for Unix or case-insensitive map for Windows *)
  let map_module =
    if win32 then (module CaseInsensitiveMap : CasedMap)
    else (module CaseSensitiveMap : CasedMap)
  in
  let module M = (val map_module) in
  let env =
    List.fold_left
      (fun map (name, value) -> M.add name value map)
      M.empty env_bindings
  in
  (* Do the apply *)
  let t' = cohere t in
  let pathsep = if win32 then ";" else ":" in
  let remove_from_env ~envnames env =
    List.fold_left (fun env' name -> M.remove name env') env envnames
  in
  let env_after_adds =
    List.fold_left
      (fun env' (name, value) -> M.add name value env')
      env t'.additions
  in
  let env_after_path_prepends =
    List.fold_right (* maintain order *)
      (fun (name, value) env' ->
        match M.find_opt name env' with
        | None -> M.add name value env'
        | Some value' -> M.add name (value ^ pathsep ^ value') env')
      t'.path_prepends env_after_adds
  in
  let env' = remove_from_env ~envnames:t'.removals env_after_path_prepends in
  M.bindings env'