1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (** Miscellaneous useful types and functions
17
18 {b Warning:} this module is unstable and part of
19 {{!Compiler_libs}compiler-libs}.
20
21 *)
22
23 val fatal_error: string -> 'a
24 val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
25 exception Fatal_error
26
27 val try_finally :
28 ?always:(unit -> unit) ->
29 ?exceptionally:(unit -> unit) ->
30 (unit -> 'a) -> 'a
31 (** [try_finally work ~always ~exceptionally] is designed to run code
32 in [work] that may fail with an exception, and has two kind of
33 cleanup routines: [always], that must be run after any execution
34 of the function (typically, freeing system resources), and
35 [exceptionally], that should be run only if [work] or [always]
36 failed with an exception (typically, undoing user-visible state
37 changes that would only make sense if the function completes
38 correctly). For example:
39
40 {[
41 let objfile = outputprefix ^ ".cmo" in
42 let oc = open_out_bin objfile in
43 Misc.try_finally
44 (fun () ->
45 bytecode
46 ++ Timings.(accumulate_time (Generate sourcefile))
47 (Emitcode.to_file oc modulename objfile);
48 Warnings.check_fatal ())
49 ~always:(fun () -> close_out oc)
50 ~exceptionally:(fun _exn -> remove_file objfile);
51 ]}
52
53 If [exceptionally] fail with an exception, it is propagated as
54 usual.
55
56 If [always] or [exceptionally] use exceptions internally for
57 control-flow but do not raise, then [try_finally] is careful to
58 preserve any exception backtrace coming from [work] or [always]
59 for easier debugging.
60 *)
61
62
63 val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
64 (* [map_end f l t] is [map f l @ t], just more efficient. *)
65 val map_left_right: ('a -> 'b) -> 'a list -> 'b list
66 (* Like [List.map], with guaranteed left-to-right evaluation order *)
67 val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
68 (* Same as [List.for_all] but for a binary predicate.
69 In addition, this [for_all2] never fails: given two lists
70 with different lengths, it returns false. *)
71 val replicate_list: 'a -> int -> 'a list
72 (* [replicate_list elem n] is the list with [n] elements
73 all identical to [elem]. *)
74 val list_remove: 'a -> 'a list -> 'a list
75 (* [list_remove x l] returns a copy of [l] with the first
76 element equal to [x] removed. *)
77 val split_last: 'a list -> 'a list * 'a
78 (* Return the last element and the other elements of the given list. *)
79
80 type ref_and_value = R : 'a ref * 'a -> ref_and_value
81
82 val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
83 (** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
84 while executing [f]. The previous contents of the references is restored
85 even if [f] raises an exception. *)
86
87 module Stdlib : sig
88 module List : sig
89 type 'a t = 'a list
90
91 val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
92 (** The lexicographic order supported by the provided order.
93 There is no constraint on the relative lengths of the lists. *)
94
95 val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
96 (** Returns [true] iff the given lists have the same length and content
97 with respect to the given equality function. *)
98
99 val find_map : ('a -> 'b option) -> 'a t -> 'b option
100 (** [find_map f l] returns the first evaluation of [f] that returns [Some],
101 or returns None if there is no such element. *)
102
103 val some_if_all_elements_are_some : 'a option t -> 'a t option
104 (** If all elements of the given list are [Some _] then [Some xs]
105 is returned with the [xs] being the contents of those [Some]s, with
106 order preserved. Otherwise return [None]. *)
107
108 val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t)
109 (** [let r1, r2 = map2_prefix f l1 l2]
110 If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n,
111 r1 is [List.map2 f l1 h1] and r2 is t2. *)
112
113 val split_at : int -> 'a t -> 'a t * 'a t
114 (** [split_at n l] returns the pair [before, after] where [before] is
115 the [n] first elements of [l] and [after] the remaining ones.
116 If [l] has less than [n] elements, raises Invalid_argument. *)
117
118 val is_prefix
119 : equal:('a -> 'a -> bool)
120 -> 'a list
121 -> of_:'a list
122 -> bool
123 (** Returns [true] iff the given list, with respect to the given equality
124 function on list members, is a prefix of the list [of_]. *)
125
126 type 'a longest_common_prefix_result = private {
127 longest_common_prefix : 'a list;
128 first_without_longest_common_prefix : 'a list;
129 second_without_longest_common_prefix : 'a list;
130 }
131
132 val find_and_chop_longest_common_prefix
133 : equal:('a -> 'a -> bool)
134 -> first:'a list
135 -> second:'a list
136 -> 'a longest_common_prefix_result
137 (** Returns the longest list that, with respect to the provided equality
138 function, is a prefix of both of the given lists. The input lists,
139 each with such longest common prefix removed, are also returned. *)
140 end
141
142 module Option : sig
143 type 'a t = 'a option
144
145 val print
146 : (Format.formatter -> 'a -> unit)
147 -> Format.formatter
148 -> 'a t
149 -> unit
150 end
151
152 module Array : sig
153 val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
154 (* Same as [Array.exists], but for a two-argument predicate. Raise
155 Invalid_argument if the two arrays are determined to have
156 different lengths. *)
157
158 val for_alli : (int -> 'a -> bool) -> 'a array -> bool
159 (** Same as {!Array.for_all}, but the
160 function is applied with the index of the element as first argument,
161 and the element itself as second argument. *)
162
163 val all_somes : 'a option array -> 'a array option
164 end
165
166 module String : sig
167 include module type of String
168 module Set : Set.S with type elt = string
169 module Map : Map.S with type key = string
170 module Tbl : Hashtbl.S with type key = string
171
172 val print : Format.formatter -> t -> unit
173
174 val for_all : (char -> bool) -> t -> bool
175 end
176
177 external compare : 'a -> 'a -> int = "%compare"
178 end
179
180 val find_in_path: string list -> string -> string
181 (* Search a file in a list of directories. *)
182 val find_in_path_rel: string list -> string -> string
183 (* Search a relative file in a list of directories. *)
184 val find_in_path_uncap: string list -> string -> string
185 (* Same, but search also for uncapitalized name, i.e.
186 if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
187 to match. *)
188 val remove_file: string -> unit
189 (* Delete the given file if it exists. Never raise an error. *)
190 val expand_directory: string -> string -> string
191 (* [expand_directory alt file] eventually expands a [+] at the
192 beginning of file into [alt] (an alternate root directory) *)
193
194 val split_path_contents: ?sep:char -> string -> string list
195 (* [split_path_contents ?sep s] interprets [s] as the value of a "PATH"-like
196 variable and returns the corresponding list of directories. [s] is split
197 using the platform-specific delimiter, or [~sep] if it is passed.
198
199 Returns the empty list if [s] is empty. *)
200
201 val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
202 (* Create a hashtable of the given size and fills it with the
203 given bindings. *)
204
205 val copy_file: in_channel -> out_channel -> unit
206 (* [copy_file ic oc] reads the contents of file [ic] and copies
207 them to [oc]. It stops when encountering EOF on [ic]. *)
208 val copy_file_chunk: in_channel -> out_channel -> int -> unit
209 (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
210 them to [oc]. It raises [End_of_file] when encountering
211 EOF on [ic]. *)
212 val string_of_file: in_channel -> string
213 (* [string_of_file ic] reads the contents of file [ic] and copies
214 them to a string. It stops when encountering EOF on [ic]. *)
215 val output_to_file_via_temporary:
216 ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
217 (* Produce output in temporary file, then rename it
218 (as atomically as possible) to the desired output file name.
219 [output_to_file_via_temporary filename fn] opens a temporary file
220 which is passed to [fn] (name + output channel). When [fn] returns,
221 the channel is closed and the temporary file is renamed to
222 [filename]. *)
223
224 (** Open the given [filename] for writing (in binary mode), pass the
225 [out_channel] to the given function, then close the channel. If the function
226 raises an exception then [filename] will be removed. *)
227 val protect_writing_to_file
228 : filename:string
229 -> f:(out_channel -> 'a)
230 -> 'a
231
232 val log2: int -> int
233 (* [log2 n] returns [s] such that [n = 1 lsl s]
234 if [n] is a power of 2*)
235 val align: int -> int -> int
236 (* [align n a] rounds [n] upwards to a multiple of [a]
237 (a power of 2). *)
238 val no_overflow_add: int -> int -> bool
239 (* [no_overflow_add n1 n2] returns [true] if the computation of
240 [n1 + n2] does not overflow. *)
241 val no_overflow_sub: int -> int -> bool
242 (* [no_overflow_sub n1 n2] returns [true] if the computation of
243 [n1 - n2] does not overflow. *)
244 val no_overflow_mul: int -> int -> bool
245 (* [no_overflow_mul n1 n2] returns [true] if the computation of
246 [n1 * n2] does not overflow. *)
247 val no_overflow_lsl: int -> int -> bool
248 (* [no_overflow_lsl n k] returns [true] if the computation of
249 [n lsl k] does not overflow. *)
250
251 module Int_literal_converter : sig
252 val int : string -> int
253 val int32 : string -> int32
254 val int64 : string -> int64
255 val nativeint : string -> nativeint
256 end
257
258 val chop_extensions: string -> string
259 (* Return the given file name without its extensions. The extensions
260 is the longest suffix starting with a period and not including
261 a directory separator, [.xyz.uvw] for instance.
262
263 Return the given name if it does not contain an extension. *)
264
265 val search_substring: string -> string -> int -> int
266 (* [search_substring pat str start] returns the position of the first
267 occurrence of string [pat] in string [str]. Search starts
268 at offset [start] in [str]. Raise [Not_found] if [pat]
269 does not occur. *)
270
271 val replace_substring: before:string -> after:string -> string -> string
272 (* [replace_substring ~before ~after str] replaces all
273 occurrences of [before] with [after] in [str] and returns
274 the resulting string. *)
275
276 val rev_split_words: string -> string list
277 (* [rev_split_words s] splits [s] in blank-separated words, and returns
278 the list of words in reverse order. *)
279
280 val get_ref: 'a list ref -> 'a list
281 (* [get_ref lr] returns the content of the list reference [lr] and reset
282 its content to the empty list. *)
283
284 val set_or_ignore : ('a -> 'b option) -> 'b option ref -> 'a -> unit
285 (* [set_or_ignore f opt x] sets [opt] to [f x] if it returns [Some _],
286 or leaves it unmodified if it returns [None]. *)
287
288 val fst3: 'a * 'b * 'c -> 'a
289 val snd3: 'a * 'b * 'c -> 'b
290 val thd3: 'a * 'b * 'c -> 'c
291
292 val fst4: 'a * 'b * 'c * 'd -> 'a
293 val snd4: 'a * 'b * 'c * 'd -> 'b
294 val thd4: 'a * 'b * 'c * 'd -> 'c
295 val for4: 'a * 'b * 'c * 'd -> 'd
296
297 module LongString :
298 sig
299 type t = bytes array
300 val create : int -> t
301 val length : t -> int
302 val get : t -> int -> char
303 val set : t -> int -> char -> unit
304 val blit : t -> int -> t -> int -> int -> unit
305 val blit_string : string -> int -> t -> int -> int -> unit
306 val output : out_channel -> t -> int -> int -> unit
307 val input_bytes_into : t -> in_channel -> int -> unit
308 val input_bytes : in_channel -> int -> t
309 end
310
311 val edit_distance : string -> string -> int -> int option
312 (** [edit_distance a b cutoff] computes the edit distance between
313 strings [a] and [b]. To help efficiency, it uses a cutoff: if the
314 distance [d] is smaller than [cutoff], it returns [Some d], else
315 [None].
316
317 The distance algorithm currently used is Damerau-Levenshtein: it
318 computes the number of insertion, deletion, substitution of
319 letters, or swapping of adjacent letters to go from one word to the
320 other. The particular algorithm may change in the future.
321 *)
322
323 val spellcheck : string list -> string -> string list
324 (** [spellcheck env name] takes a list of names [env] that exist in
325 the current environment and an erroneous [name], and returns a
326 list of suggestions taken from [env], that are close enough to
327 [name] that it may be a typo for one of them. *)
328
329 val did_you_mean : Format.formatter -> (unit -> string list) -> unit
330 (** [did_you_mean ppf get_choices] hints that the user may have meant
331 one of the option returned by calling [get_choices]. It does nothing
332 if the returned list is empty.
333
334 The [unit -> ...] thunking is meant to delay any potentially-slow
335 computation (typically computing edit-distance with many things
336 from the current environment) to when the hint message is to be
337 printed. You should print an understandable error message before
338 calling [did_you_mean], so that users get a clear notification of
339 the failure even if producing the hint is slow.
340 *)
341
342 val cut_at : string -> char -> string * string
343 (** [String.cut_at s c] returns a pair containing the sub-string before
344 the first occurrence of [c] in [s], and the sub-string after the
345 first occurrence of [c] in [s].
346 [let (before, after) = String.cut_at s c in
347 before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
348
349 Raise [Not_found] if the character does not appear in the string
350 @since 4.01
351 *)
352
353 (* Color handling *)
354 module Color : sig
355 type color =
356 | Black
357 | Red
358 | Green
359 | Yellow
360 | Blue
361 | Magenta
362 | Cyan
363 | White
364 ;;
365
366 type style =
367 | FG of color (* foreground *)
368 | BG of color (* background *)
369 | Bold
370 | Reset
371
372 val ansi_of_style_l : style list -> string
373 (* ANSI escape sequence for the given style *)
374
375 type styles = {
376 error: style list;
377 warning: style list;
378 loc: style list;
379 }
380
381 val default_styles: styles
382 val get_styles: unit -> styles
383 val set_styles: styles -> unit
384
385 type setting = Auto | Always | Never
386
387 val default_setting : setting
388
389 val setup : setting option -> unit
390 (* [setup opt] will enable or disable color handling on standard formatters
391 according to the value of color setting [opt].
392 Only the first call to this function has an effect. *)
393
394 val set_color_tag_handling : Format.formatter -> unit
395 (* adds functions to support color tags to the given formatter. *)
396 end
397
398 (* See the -error-style option *)
399 module Error_style : sig
400 type setting =
401 | Contextual
402 | Short
403
404 val default_setting : setting
405 end
406
407 val normalise_eol : string -> string
408 (** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
409 removed. Intended for pre-processing text which will subsequently be printed
410 on a channel which performs EOL transformations (i.e. Windows) *)
411
412 val delete_eol_spaces : string -> string
413 (** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
414 line spaces removed. Intended to normalize the output of the
415 toplevel for tests. *)
416
417 val pp_two_columns :
418 ?sep:string -> ?max_lines:int ->
419 Format.formatter -> (string * string) list -> unit
420 (** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two
421 columns separated by [sep] ("|" by default). [max_lines] can be used to
422 indicate a maximum number of lines to print -- an ellipsis gets inserted at
423 the middle if the input has too many lines.
424
425 Example:
426
427 {v pp_two_columns ~max_lines:3 Format.std_formatter [
428 "abc", "hello";
429 "def", "zzz";
430 "a" , "bllbl";
431 "bb" , "dddddd";
432 ] v}
433
434 prints
435
436 {v
437 abc | hello
438 ...
439 bb | dddddd
440 v}
441 *)
442
443 (** configuration variables *)
444 val show_config_and_exit : unit -> unit
445 val show_config_variable_and_exit : string -> unit
446
447 val get_build_path_prefix_map: unit -> Build_path_prefix_map.map option
448 (** Returns the map encoded in the [BUILD_PATH_PREFIX_MAP] environment
449 variable. *)
450
451 val debug_prefix_map_flags: unit -> string list
452 (** Returns the list of [--debug-prefix-map] flags to be passed to the
453 assembler, built from the [BUILD_PATH_PREFIX_MAP] environment variable. *)
454
455 val print_if :
456 Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a
457 (** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *)
458
459
460 type filepath = string
461 type modname = string
462 type crcs = (modname * Digest.t option) list
463
464 type alerts = string Stdlib.String.Map.t
465
466
467 module EnvLazy: sig
468 type ('a,'b) t
469
470 type log
471
472 val force : ('a -> 'b) -> ('a,'b) t -> 'b
473 val create : 'a -> ('a,'b) t
474 val get_arg : ('a,'b) t -> 'a option
475 val create_forced : 'b -> ('a, 'b) t
476 val create_failed : exn -> ('a, 'b) t
477
478 (* [force_logged log f t] is equivalent to [force f t] but if [f]
479 returns [Error _] then [t] is recorded in [log]. [backtrack log]
480 will then reset all the recorded [t]s back to their original
481 state. *)
482 val log : unit -> log
483 val force_logged :
484 log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result
485 val backtrack : log -> unit
486
487 end
488