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 (* Errors *)
17
18 exception Fatal_error
19
20 let fatal_errorf fmt =
21 Format.kfprintf
22 (fun _ -> raise Fatal_error)
23 Format.err_formatter
24 ("@?>> Fatal error: " ^^ fmt ^^ "@.")
25
26 let fatal_error msg = fatal_errorf "%s" msg
27
28 (* Exceptions *)
29
30 let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =
31 match work () with
32 | result ->
33 begin match always () with
34 | () -> result
35 | exception always_exn ->
36 let always_bt = Printexc.get_raw_backtrace () in
37 exceptionally ();
38 Printexc.raise_with_backtrace always_exn always_bt
39 end
40 | exception work_exn ->
41 let work_bt = Printexc.get_raw_backtrace () in
42 begin match always () with
43 | () ->
44 exceptionally ();
45 Printexc.raise_with_backtrace work_exn work_bt
46 | exception always_exn ->
47 let always_bt = Printexc.get_raw_backtrace () in
48 exceptionally ();
49 Printexc.raise_with_backtrace always_exn always_bt
50 end
51
52 type ref_and_value = R : 'a ref * 'a -> ref_and_value
53
54 let protect_refs =
55 let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
56 fun refs f ->
57 let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
58 set_refs refs;
59 match f () with
60 | x -> set_refs backup; x
61 | exception e -> set_refs backup; raise e
62
63 (* List functions *)
64
65 let rec map_end f l1 l2 =
66 match l1 with
67 [] -> l2
68 | hd::tl -> f hd :: map_end f tl l2
69
70 let rec map_left_right f = function
71 [] -> []
72 | hd::tl -> let res = f hd in res :: map_left_right f tl
73
74 let rec for_all2 pred l1 l2 =
75 match (l1, l2) with
76 ([], []) -> true
77 | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2
78 | (_, _) -> false
79
80 let rec replicate_list elem n =
81 if n <= 0 then [] else elem :: replicate_list elem (n-1)
82
83 let rec list_remove x = function
84 [] -> []
85 | hd :: tl ->
86 if hd = x then tl else hd :: list_remove x tl
87
88 let rec split_last = function
89 [] -> assert false
90 | [x] -> ([], x)
91 | hd :: tl ->
92 let (lst, last) = split_last tl in
93 (hd :: lst, last)
94
95 module Stdlib = struct
96 module List = struct
97 type 'a t = 'a list
98
99 let rec compare cmp l1 l2 =
100 match l1, l2 with
101 | [], [] -> 0
102 | [], _::_ -> -1
103 | _::_, [] -> 1
104 | h1::t1, h2::t2 ->
105 let c = cmp h1 h2 in
106 if c <> 0 then c
107 else compare cmp t1 t2
108
109 let rec equal eq l1 l2 =
110 match l1, l2 with
111 | ([], []) -> true
112 | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2
113 | (_, _) -> false
114
115 let rec find_map f = function
116 | x :: xs ->
117 begin match f x with
118 | None -> find_map f xs
119 | Some _ as y -> y
120 end
121 | [] -> None
122
123 let map2_prefix f l1 l2 =
124 let rec aux acc l1 l2 =
125 match l1, l2 with
126 | [], _ -> (List.rev acc, l2)
127 | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
128 | h1::t1, h2::t2 ->
129 let h = f h1 h2 in
130 aux (h :: acc) t1 t2
131 in
132 aux [] l1 l2
133
134 let some_if_all_elements_are_some l =
135 let rec aux acc l =
136 match l with
137 | [] -> Some (List.rev acc)
138 | None :: _ -> None
139 | Some h :: t -> aux (h :: acc) t
140 in
141 aux [] l
142
143 let split_at n l =
144 let rec aux n acc l =
145 if n = 0
146 then List.rev acc, l
147 else
148 match l with
149 | [] -> raise (Invalid_argument "split_at")
150 | t::q -> aux (n-1) (t::acc) q
151 in
152 aux n [] l
153
154 let rec is_prefix ~equal t ~of_ =
155 match t, of_ with
156 | [], [] -> true
157 | _::_, [] -> false
158 | [], _::_ -> true
159 | x1::t, x2::of_ -> equal x1 x2 && is_prefix ~equal t ~of_
160
161 type 'a longest_common_prefix_result = {
162 longest_common_prefix : 'a list;
163 first_without_longest_common_prefix : 'a list;
164 second_without_longest_common_prefix : 'a list;
165 }
166
167 let find_and_chop_longest_common_prefix ~equal ~first ~second =
168 let rec find_prefix ~longest_common_prefix_rev l1 l2 =
169 match l1, l2 with
170 | elt1 :: l1, elt2 :: l2 when equal elt1 elt2 ->
171 let longest_common_prefix_rev = elt1 :: longest_common_prefix_rev in
172 find_prefix ~longest_common_prefix_rev l1 l2
173 | l1, l2 ->
174 { longest_common_prefix = List.rev longest_common_prefix_rev;
175 first_without_longest_common_prefix = l1;
176 second_without_longest_common_prefix = l2;
177 }
178 in
179 find_prefix ~longest_common_prefix_rev:[] first second
180 end
181
182 module Option = struct
183 type 'a t = 'a option
184
185 let print print_contents ppf t =
186 match t with
187 | None -> Format.pp_print_string ppf "None"
188 | Some contents ->
189 Format.fprintf ppf "@[(Some@ %a)@]" print_contents contents
190 end
191
192 module Array = struct
193 let exists2 p a1 a2 =
194 let n = Array.length a1 in
195 if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2";
196 let rec loop i =
197 if i = n then false
198 else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true
199 else loop (succ i) in
200 loop 0
201
202 let for_alli p a =
203 let n = Array.length a in
204 let rec loop i =
205 if i = n then true
206 else if p i (Array.unsafe_get a i) then loop (succ i)
207 else false in
208 loop 0
209
210 let all_somes a =
211 try
212 Some (Array.map (function None -> raise_notrace Exit | Some x -> x) a)
213 with
214 | Exit -> None
215 end
216
217 module String = struct
218 include String
219 module Set = Set.Make(String)
220 module Map = Map.Make(String)
221 module Tbl = Hashtbl.Make(struct
222 include String
223 let hash = Hashtbl.hash
224 end)
225
226 let for_all f t =
227 let len = String.length t in
228 let rec loop i =
229 i = len || (f t.[i] && loop (i + 1))
230 in
231 loop 0
232
233 let print ppf t =
234 Format.pp_print_string ppf t
235 end
236
237 external compare : 'a -> 'a -> int = "%compare"
238 end
239
240 (* File functions *)
241
242 let find_in_path path name =
243 if not (Filename.is_implicit name) then
244 if Sys.file_exists name then name else raise Not_found
245 else begin
246 let rec try_dir = function
247 [] -> raise Not_found
248 | dir::rem ->
249 let fullname = Filename.concat dir name in
250 if Sys.file_exists fullname then fullname else try_dir rem
251 in try_dir path
252 end
253
254 let find_in_path_rel path name =
255 let rec simplify s =
256 let open Filename in
257 let base = basename s in
258 let dir = dirname s in
259 if dir = s then dir
260 else if base = current_dir_name then simplify dir
261 else concat (simplify dir) base
262 in
263 let rec try_dir = function
264 [] -> raise Not_found
265 | dir::rem ->
266 let fullname = simplify (Filename.concat dir name) in
267 if Sys.file_exists fullname then fullname else try_dir rem
268 in try_dir path
269
270 let find_in_path_uncap path name =
271 let uname = String.uncapitalize_ascii name in
272 let rec try_dir = function
273 [] -> raise Not_found
274 | dir::rem ->
275 let fullname = Filename.concat dir name
276 and ufullname = Filename.concat dir uname in
277 if Sys.file_exists ufullname then ufullname
278 else if Sys.file_exists fullname then fullname
279 else try_dir rem
280 in try_dir path
281
282 let remove_file filename =
283 try
284 if Sys.file_exists filename
285 then Sys.remove filename
286 with Sys_error _msg ->
287 ()
288
289 (* Expand a -I option: if it starts with +, make it relative to the standard
290 library directory *)
291
292 let expand_directory alt s =
293 if String.length s > 0 && s.[0] = '+'
294 then Filename.concat alt
295 (String.sub s 1 (String.length s - 1))
296 else s
297
298 let path_separator =
299 match Sys.os_type with
300 | "Win32" -> ';'
301 | _ -> ':'
302
303 let split_path_contents ?(sep = path_separator) = function
304 | "" -> []
305 | s -> String.split_on_char sep s
306
307 (* Hashtable functions *)
308
309 let create_hashtable size init =
310 let tbl = Hashtbl.create size in
311 List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
312 tbl
313
314 (* File copy *)
315
316 let copy_file ic oc =
317 let buff = Bytes.create 0x1000 in
318 let rec copy () =
319 let n = input ic buff 0 0x1000 in
320 if n = 0 then () else (output oc buff 0 n; copy())
321 in copy()
322
323 let copy_file_chunk ic oc len =
324 let buff = Bytes.create 0x1000 in
325 let rec copy n =
326 if n <= 0 then () else begin
327 let r = input ic buff 0 (min n 0x1000) in
328 if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
329 end
330 in copy len
331
332 let string_of_file ic =
333 let b = Buffer.create 0x10000 in
334 let buff = Bytes.create 0x1000 in
335 let rec copy () =
336 let n = input ic buff 0 0x1000 in
337 if n = 0 then Buffer.contents b else
338 (Buffer.add_subbytes b buff 0 n; copy())
339 in copy()
340
341 let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
342 let (temp_filename, oc) =
343 Filename.open_temp_file
344 ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename)
345 (Filename.basename filename) ".tmp" in
346 (* The 0o666 permissions will be modified by the umask. It's just
347 like what [open_out] and [open_out_bin] do.
348 With temp_dir = dirname filename, we ensure that the returned
349 temp file is in the same directory as filename itself, making
350 it safe to rename temp_filename to filename later.
351 With prefix = basename filename, we are almost certain that
352 the first generated name will be unique. A fixed prefix
353 would work too but might generate more collisions if many
354 files are being produced simultaneously in the same directory. *)
355 match fn temp_filename oc with
356 | res ->
357 close_out oc;
358 begin try
359 Sys.rename temp_filename filename; res
360 with exn ->
361 remove_file temp_filename; raise exn
362 end
363 | exception exn ->
364 close_out oc; remove_file temp_filename; raise exn
365
366 let protect_writing_to_file ~filename ~f =
367 let outchan = open_out_bin filename in
368 try_finally ~always:(fun () -> close_out outchan)
369 ~exceptionally:(fun () -> remove_file filename)
370 (fun () -> f outchan)
371
372 (* Integer operations *)
373
374 let rec log2 n =
375 if n <= 1 then 0 else 1 + log2(n asr 1)
376
377 let align n a =
378 if n >= 0 then (n + a - 1) land (-a) else n land (-a)
379
380 let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
381
382 let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
383
384 (* Taken from Hacker's Delight, chapter "Overflow Detection" *)
385 let no_overflow_mul a b =
386 not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a))
387
388 let no_overflow_lsl a k =
389 0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k
390
391 module Int_literal_converter = struct
392 (* To convert integer literals, allowing max_int + 1 (PR#4210) *)
393 let cvt_int_aux str neg of_string =
394 if String.length str = 0 || str.[0]= '-'
395 then of_string str
396 else neg (of_string ("-" ^ str))
397 let int s = cvt_int_aux s (~-) int_of_string
398 let int32 s = cvt_int_aux s Int32.neg Int32.of_string
399 let int64 s = cvt_int_aux s Int64.neg Int64.of_string
400 let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
401 end
402
403 (* String operations *)
404
405 let chop_extensions file =
406 let dirname = Filename.dirname file and basename = Filename.basename file in
407 try
408 let pos = String.index basename '.' in
409 let basename = String.sub basename 0 pos in
410 if Filename.is_implicit file && dirname = Filename.current_dir_name then
411 basename
412 else
413 Filename.concat dirname basename
414 with Not_found -> file
415
416 let search_substring pat str start =
417 let rec search i j =
418 if j >= String.length pat then i
419 else if i + j >= String.length str then raise Not_found
420 else if str.[i + j] = pat.[j] then search i (j+1)
421 else search (i+1) 0
422 in search start 0
423
424 let replace_substring ~before ~after str =
425 let rec search acc curr =
426 match search_substring before str curr with
427 | next ->
428 let prefix = String.sub str curr (next - curr) in
429 search (prefix :: acc) (next + String.length before)
430 | exception Not_found ->
431 let suffix = String.sub str curr (String.length str - curr) in
432 List.rev (suffix :: acc)
433 in String.concat after (search [] 0)
434
435 let rev_split_words s =
436 let rec split1 res i =
437 if i >= String.length s then res else begin
438 match s.[i] with
439 ' ' | '\t' | '\r' | '\n' -> split1 res (i+1)
440 | _ -> split2 res i (i+1)
441 end
442 and split2 res i j =
443 if j >= String.length s then String.sub s i (j-i) :: res else begin
444 match s.[j] with
445 ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1)
446 | _ -> split2 res i (j+1)
447 end
448 in split1 [] 0
449
450 let get_ref r =
451 let v = !r in
452 r := []; v
453
454 let set_or_ignore f opt x =
455 match f x with
456 | None -> ()
457 | Some y -> opt := Some y
458
459 let fst3 (x, _, _) = x
460 let snd3 (_,x,_) = x
461 let thd3 (_,_,x) = x
462
463 let fst4 (x, _, _, _) = x
464 let snd4 (_,x,_, _) = x
465 let thd4 (_,_,x,_) = x
466 let for4 (_,_,_,x) = x
467
468
469 module LongString = struct
470 type t = bytes array
471
472 let create str_size =
473 let tbl_size = str_size / Sys.max_string_length + 1 in
474 let tbl = Array.make tbl_size Bytes.empty in
475 for i = 0 to tbl_size - 2 do
476 tbl.(i) <- Bytes.create Sys.max_string_length;
477 done;
478 tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
479 tbl
480
481 let length tbl =
482 let tbl_size = Array.length tbl in
483 Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)
484
485 let get tbl ind =
486 Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
487
488 let set tbl ind c =
489 Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
490 c
491
492 let blit src srcoff dst dstoff len =
493 for i = 0 to len - 1 do
494 set dst (dstoff + i) (get src (srcoff + i))
495 done
496
497 let blit_string src srcoff dst dstoff len =
498 for i = 0 to len - 1 do
499 set dst (dstoff + i) (String.get src (srcoff + i))
500 done
501
502 let output oc tbl pos len =
503 for i = pos to pos + len - 1 do
504 output_char oc (get tbl i)
505 done
506
507 let input_bytes_into tbl ic len =
508 let count = ref len in
509 Array.iter (fun str ->
510 let chunk = min !count (Bytes.length str) in
511 really_input ic str 0 chunk;
512 count := !count - chunk) tbl
513
514 let input_bytes ic len =
515 let tbl = create len in
516 input_bytes_into tbl ic len;
517 tbl
518 end
519
520
521 let edit_distance a b cutoff =
522 let la, lb = String.length a, String.length b in
523 let cutoff =
524 (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
525 we bring it back to the (max la lb) worstcase *)
526 min (max la lb) cutoff in
527 if abs (la - lb) > cutoff then None
528 else begin
529 (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
530 the worst possible cost; this is useful when computing the cost of
531 a case just at the boundary of the cutoff diagonal. *)
532 let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
533 m.(0).(0) <- 0;
534 for i = 1 to la do
535 m.(i).(0) <- i;
536 done;
537 for j = 1 to lb do
538 m.(0).(j) <- j;
539 done;
540 for i = 1 to la do
541 for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
542 let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
543 let best =
544 (* insert, delete or substitute *)
545 min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
546 in
547 let best =
548 (* swap two adjacent letters; we use "cost" again in case of
549 a swap between two identical letters; this is slightly
550 redundant as this is a double-substitution case, but it
551 was done this way in most online implementations and
552 imitation has its virtues *)
553 if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
554 then best
555 else min best (m.(i-2).(j-2) + cost)
556 in
557 m.(i).(j) <- best
558 done;
559 done;
560 let result = m.(la).(lb) in
561 if result > cutoff
562 then None
563 else Some result
564 end
565
566 let spellcheck env name =
567 let cutoff =
568 match String.length name with
569 | 1 | 2 -> 0
570 | 3 | 4 -> 1
571 | 5 | 6 -> 2
572 | _ -> 3
573 in
574 let compare target acc head =
575 match edit_distance target head cutoff with
576 | None -> acc
577 | Some dist ->
578 let (best_choice, best_dist) = acc in
579 if dist < best_dist then ([head], dist)
580 else if dist = best_dist then (head :: best_choice, dist)
581 else acc
582 in
583 let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in
584 fst (List.fold_left (compare name) ([], max_int) env)
585
586 let did_you_mean ppf get_choices =
587 (* flush now to get the error report early, in the (unheard of) case
588 where the search in the get_choices function would take a bit of
589 time; in the worst case, the user has seen the error, she can
590 interrupt the process before the spell-checking terminates. *)
591 Format.fprintf ppf "@?";
592 match get_choices () with
593 | [] -> ()
594 | choices ->
595 let rest, last = split_last choices in
596 Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
597 (String.concat ", " rest)
598 (if rest = [] then "" else " or ")
599 last
600
601 let cut_at s c =
602 let pos = String.index s c in
603 String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
604
605 (* Color handling *)
606 module Color = struct
607 (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *)
608 type color =
609 | Black
610 | Red
611 | Green
612 | Yellow
613 | Blue
614 | Magenta
615 | Cyan
616 | White
617 ;;
618
619 type style =
620 | FG of color (* foreground *)
621 | BG of color (* background *)
622 | Bold
623 | Reset
624
625 let ansi_of_color = function
626 | Black -> "0"
627 | Red -> "1"
628 | Green -> "2"
629 | Yellow -> "3"
630 | Blue -> "4"
631 | Magenta -> "5"
632 | Cyan -> "6"
633 | White -> "7"
634
635 let code_of_style = function
636 | FG c -> "3" ^ ansi_of_color c
637 | BG c -> "4" ^ ansi_of_color c
638 | Bold -> "1"
639 | Reset -> "0"
640
641 let ansi_of_style_l l =
642 let s = match l with
643 | [] -> code_of_style Reset
644 | [s] -> code_of_style s
645 | _ -> String.concat ";" (List.map code_of_style l)
646 in
647 "\x1b[" ^ s ^ "m"
648
649 type styles = {
650 error: style list;
651 warning: style list;
652 loc: style list;
653 }
654
655 let default_styles = {
656 warning = [Bold; FG Magenta];
657 error = [Bold; FG Red];
658 loc = [Bold];
659 }
660
661 let cur_styles = ref default_styles
662 let get_styles () = !cur_styles
663 let set_styles s = cur_styles := s
664
665 (* map a tag to a style, if the tag is known.
666 @raise Not_found otherwise *)
667 let style_of_tag s = match s with
668 | Format.String_tag "error" -> (!cur_styles).error
669 | Format.String_tag "warning" -> (!cur_styles).warning
670 | Format.String_tag "loc" -> (!cur_styles).loc
671 | _ -> raise Not_found
672
673 let color_enabled = ref true
674
675 (* either prints the tag of [s] or delegates to [or_else] *)
676 let mark_open_tag ~or_else s =
677 try
678 let style = style_of_tag s in
679 if !color_enabled then ansi_of_style_l style else ""
680 with Not_found -> or_else s
681
682 let mark_close_tag ~or_else s =
683 try
684 let _ = style_of_tag s in
685 if !color_enabled then ansi_of_style_l [Reset] else ""
686 with Not_found -> or_else s
687
688 (* add color handling to formatter [ppf] *)
689 let set_color_tag_handling ppf =
690 let open Format in
691 let functions = pp_get_formatter_stag_functions ppf () in
692 let functions' = {functions with
693 mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag);
694 mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag);
695 } in
696 pp_set_mark_tags ppf true; (* enable tags *)
697 pp_set_formatter_stag_functions ppf functions';
698 (* also setup margins *)
699 pp_set_margin ppf (pp_get_margin std_formatter());
700 ()
701
702 external isatty : out_channel -> bool = "caml_sys_isatty"
703
704 (* reasonable heuristic on whether colors should be enabled *)
705 let should_enable_color () =
706 let term = try Sys.getenv "TERM" with Not_found -> "" in
707 term <> "dumb"
708 && term <> ""
709 && isatty stderr
710
711 type setting = Auto | Always | Never
712
713 let default_setting = Auto
714
715 let setup =
716 let first = ref true in (* initialize only once *)
717 let formatter_l =
718 [Format.std_formatter; Format.err_formatter; Format.str_formatter]
719 in
720 let enable_color = function
721 | Auto -> should_enable_color ()
722 | Always -> true
723 | Never -> false
724 in
725 fun o ->
726 if !first then (
727 first := false;
728 Format.set_mark_tags true;
729 List.iter set_color_tag_handling formatter_l;
730 color_enabled := (match o with
731 | Some s -> enable_color s
732 | None -> enable_color default_setting)
733 );
734 ()
735 end
736
737 module Error_style = struct
738 type setting =
739 | Contextual
740 | Short
741
742 let default_setting = Contextual
743 end
744
745 let normalise_eol s =
746 let b = Buffer.create 80 in
747 for i = 0 to String.length s - 1 do
748 if s.[i] <> '\r' then Buffer.add_char b s.[i]
749 done;
750 Buffer.contents b
751
752 let delete_eol_spaces src =
753 let len_src = String.length src in
754 let dst = Bytes.create len_src in
755 let rec loop i_src i_dst =
756 if i_src = len_src then
757 i_dst
758 else
759 match src.[i_src] with
760 | ' ' | '\t' ->
761 loop_spaces 1 (i_src + 1) i_dst
762 | c ->
763 Bytes.set dst i_dst c;
764 loop (i_src + 1) (i_dst + 1)
765 and loop_spaces spaces i_src i_dst =
766 if i_src = len_src then
767 i_dst
768 else
769 match src.[i_src] with
770 | ' ' | '\t' ->
771 loop_spaces (spaces + 1) (i_src + 1) i_dst
772 | '\n' ->
773 Bytes.set dst i_dst '\n';
774 loop (i_src + 1) (i_dst + 1)
775 | _ ->
776 for n = 0 to spaces do
777 Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
778 done;
779 loop (i_src + 1) (i_dst + spaces + 1)
780 in
781 let stop = loop 0 0 in
782 Bytes.sub_string dst 0 stop
783
784 let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) =
785 let left_column_size =
786 List.fold_left (fun acc (s, _) -> max acc (String.length s)) 0 lines in
787 let lines_nb = List.length lines in
788 let ellipsed_first, ellipsed_last =
789 match max_lines with
790 | Some max_lines when lines_nb > max_lines ->
791 let printed_lines = max_lines - 1 in (* the ellipsis uses one line *)
792 let lines_before = printed_lines / 2 + printed_lines mod 2 in
793 let lines_after = printed_lines / 2 in
794 (lines_before, lines_nb - lines_after - 1)
795 | _ -> (-1, -1)
796 in
797 Format.fprintf ppf "@[<v>";
798 List.iteri (fun k (line_l, line_r) ->
799 if k = ellipsed_first then Format.fprintf ppf "...@,";
800 if ellipsed_first <= k && k <= ellipsed_last then ()
801 else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r
802 ) lines;
803 Format.fprintf ppf "@]"
804
805 (* showing configuration and configuration variables *)
806 let show_config_and_exit () =
807 Config.print_config stdout;
808 exit 0
809
810 let show_config_variable_and_exit x =
811 match Config.config_var x with
812 | Some v ->
813 (* we intentionally don't print a newline to avoid Windows \r
814 issues: bash only strips the trailing \n when using a command
815 substitution $(ocamlc -config-var foo), so a trailing \r would
816 remain if printing a newline under Windows and scripts would
817 have to use $(ocamlc -config-var foo | tr -d '\r')
818 for portability. Ugh. *)
819 print_string v;
820 exit 0
821 | None ->
822 exit 2
823
824 let get_build_path_prefix_map =
825 let init = ref false in
826 let map_cache = ref None in
827 fun () ->
828 if not !init then begin
829 init := true;
830 match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
831 | exception Not_found -> ()
832 | encoded_map ->
833 match Build_path_prefix_map.decode_map encoded_map with
834 | Error err ->
835 fatal_errorf
836 "Invalid value for the environment variable \
837 BUILD_PATH_PREFIX_MAP: %s" err
838 | Ok map -> map_cache := Some map
839 end;
840 !map_cache
841
842 let debug_prefix_map_flags () =
843 if not Config.as_has_debug_prefix_map then
844 []
845 else begin
846 match get_build_path_prefix_map () with
847 | None -> []
848 | Some map ->
849 List.fold_right
850 (fun map_elem acc ->
851 match map_elem with
852 | None -> acc
853 | Some { Build_path_prefix_map.target; source; } ->
854 (Printf.sprintf "--debug-prefix-map %s=%s"
855 (Filename.quote source)
856 (Filename.quote target)) :: acc)
857 map
858 []
859 end
860
861 let print_if ppf flag printer arg =
862 if !flag then Format.fprintf ppf "%a@." printer arg;
863 arg
864
865
866 type filepath = string
867 type modname = string
868 type crcs = (modname * Digest.t option) list
869
870 type alerts = string Stdlib.String.Map.t
871
872
873 module EnvLazy = struct
874 type ('a,'b) t = ('a,'b) eval ref
875
876 and ('a,'b) eval =
877 | Done of 'b
878 | Raise of exn
879 | Thunk of 'a
880
881 type undo =
882 | Nil
883 | Cons : ('a, 'b) t * 'a * undo -> undo
884
885 type log = undo ref
886
887 let force f x =
888 match !x with
889 | Done x -> x
890 | Raise e -> raise e
891 | Thunk e ->
892 match f e with
893 | y ->
894 x := Done y;
895 y
896 | exception e ->
897 x := Raise e;
898 raise e
899
900 let get_arg x =
901 match !x with Thunk a -> Some a | _ -> None
902
903 let create x =
904 ref (Thunk x)
905
906 let create_forced y =
907 ref (Done y)
908
909 let create_failed e =
910 ref (Raise e)
911
912 let log () =
913 ref Nil
914
915 let force_logged log f x =
916 match !x with
917 | Done x -> x
918 | Raise e -> raise e
919 | Thunk e ->
920 match f e with
921 | (Error _ as err : _ result) ->
922 x := Done err;
923 log := Cons(x, e, !log);
924 err
925 | Ok _ as res ->
926 x := Done res;
927 res
928 | exception e ->
929 x := Raise e;
930 raise e
931
932 let backtrack log =
933 let rec loop = function
934 | Nil -> ()
935 | Cons(x, e, rest) ->
936 x := Thunk e;
937 loop rest
938 in
939 loop !log
940
941 end
942