Source file `EnvMods.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
(* 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'