package ocamlformat-mlx-lib
OCaml .mlx Code Formatter
Install
Dune Dependency
Authors
Maintainers
Sources
0.26.2.0.tar.gz
md5=4b32d3b57da54157a0cd8f772094f4bc
sha512=367eeb5d81060a3efb584796cc72cc75d974975bb9b18be6284a86f5937edb90927368fd80e00b3f4c1894e609b4a1503c20d4495c624560243e5055f905390a
doc/src/ocamlformat-mlx-lib.ocaml_common/location.ml.html
Source file location.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 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003
(**************************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) open Lexing type t = Warnings.loc = { loc_start: position; loc_end: position; loc_ghost: bool } let in_file = Warnings.ghost_loc_in_file let none = in_file "_none_" let is_none l = (l = none) let curr lexbuf = { loc_start = lexbuf.lex_start_p; loc_end = lexbuf.lex_curr_p; loc_ghost = false } let init lexbuf fname = lexbuf.lex_curr_p <- { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0; } let symbol_rloc () = { loc_start = Parsing.symbol_start_pos (); loc_end = Parsing.symbol_end_pos (); loc_ghost = false; } let symbol_gloc () = { loc_start = Parsing.symbol_start_pos (); loc_end = Parsing.symbol_end_pos (); loc_ghost = true; } let rhs_loc n = { loc_start = Parsing.rhs_start_pos n; loc_end = Parsing.rhs_end_pos n; loc_ghost = false; } let rhs_interval m n = { loc_start = Parsing.rhs_start_pos m; loc_end = Parsing.rhs_end_pos n; loc_ghost = false; } (* return file, line, char from the given position *) let get_pos_info pos = (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) type 'a loc = { txt : 'a; loc : t; } let mkloc txt loc = { txt ; loc } let mknoloc txt = mkloc txt none (******************************************************************************) (* Input info *) let input_name = ref "_none_" let input_lexbuf = ref (None : lexbuf option) let input_phrase_buffer = ref (None : Buffer.t option) (******************************************************************************) (* Terminal info *) let status = ref Terminfo.Uninitialised let setup_terminal () = if !status = Terminfo.Uninitialised then status := Terminfo.setup stdout (* The number of lines already printed after input. This is used by [highlight_terminfo] to identify the current position of the input in the terminal. This would not be possible without this information, since printing several warnings/errors adds text between the user input and the bottom of the terminal. We also use for {!is_first_report}, see below. *) let num_loc_lines = ref 0 (* We use [num_loc_lines] to determine if the report about to be printed is the first or a follow-up report of the current "batch" -- contiguous reports without user input in between, for example for the current toplevel phrase. We use this to print a blank line between messages of the same batch. *) let is_first_message () = !num_loc_lines = 0 (* This is used by the toplevel to reset [num_loc_lines] before each phrase *) let reset () = num_loc_lines := 0 (* This is used by the toplevel *) let echo_eof () = print_newline (); incr num_loc_lines (* This is used by the toplevel and the report printers below. *) let separate_new_message ppf = if not (is_first_message ()) then begin Format.pp_print_newline ppf (); incr num_loc_lines end (* Code printing errors and warnings must be wrapped using this function, in order to update [num_loc_lines]. [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf arg], and additionally updates [num_loc_lines]. *) let print_updating_num_loc_lines ppf f arg = let open Format in let out_functions = pp_get_formatter_out_functions ppf () in let out_string str start len = let rec count i c = if i = start + len then c else if String.get str i = '\n' then count (succ i) (succ c) else count (succ i) c in num_loc_lines := !num_loc_lines + count start 0 ; out_functions.out_string str start len in pp_set_formatter_out_functions ppf { out_functions with out_string } ; f ppf arg ; pp_print_flush ppf (); pp_set_formatter_out_functions ppf out_functions let setup_colors () = Misc.Style.setup !Clflags.color (******************************************************************************) (* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *) let rewrite_absolute_path path = match Misc.get_build_path_prefix_map () with | None -> path | Some map -> Build_path_prefix_map.rewrite map path let absolute_path s = (* This function could go into Filename *) let open Filename in let s = if not (is_relative s) then s else (rewrite_absolute_path (concat (Sys.getcwd ()) s)) in (* Now simplify . and .. components *) let rec aux s = let base = basename s in let dir = dirname s in if dir = s then dir else if base = current_dir_name then aux dir else if base = parent_dir_name then dirname (aux dir) else concat (aux dir) base in aux s let show_filename file = if !Clflags.absname then absolute_path file else file let print_filename ppf file = Format.pp_print_string ppf (show_filename file) (* Best-effort printing of the text describing a location, of the form 'File "foo.ml", line 3, characters 10-12'. Some of the information (filename, line number or characters numbers) in the location might be invalid; in which case we do not print it. *) let print_loc ppf loc = setup_colors (); let file_valid = function | "_none_" -> (* This is a dummy placeholder, but we print it anyway to please editors that parse locations in error messages (e.g. Emacs). *) true | "" | "//toplevel//" -> false | _ -> true in let line_valid line = line > 0 in let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in let file = (* According to the comment in location.mli, if [pos_fname] is "", we must use [!input_name]. *) if loc.loc_start.pos_fname = "" then !input_name else loc.loc_start.pos_fname in let startline = loc.loc_start.pos_lnum in let endline = loc.loc_end.pos_lnum in let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in let first = ref true in let capitalize s = if !first then (first := false; String.capitalize_ascii s) else s in let comma () = if !first then () else Format.fprintf ppf ", " in Format.fprintf ppf "@{<loc>"; if file_valid file then Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file; (* Print "line 1" in the case of a dummy line number. This is to please the existing setup of editors that parse locations in error messages (e.g. Emacs). *) comma (); let startline = if line_valid startline then startline else 1 in let endline = if line_valid endline then endline else startline in begin if startline = endline then Format.fprintf ppf "%s %i" (capitalize "line") startline else Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline end; if chars_valid ~startchar ~endchar then ( comma (); Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar ); Format.fprintf ppf "@}" (* Print a comma-separated list of locations *) let print_locs ppf locs = Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") print_loc ppf locs (******************************************************************************) (* An interval set structure; additionally, it stores user-provided information at interval boundaries. The implementation provided here is naive and assumes the number of intervals to be small, but the interface would allow for a more efficient implementation if needed. Note: the structure only stores maximal intervals (that therefore do not overlap). *) module ISet : sig type 'a bound = 'a * int type 'a t (* bounds are included *) val of_intervals : ('a bound * 'a bound) list -> 'a t val mem : 'a t -> pos:int -> bool val find_bound_in : 'a t -> range:(int * int) -> 'a bound option val is_start : 'a t -> pos:int -> 'a option val is_end : 'a t -> pos:int -> 'a option val extrema : 'a t -> ('a bound * 'a bound) option end = struct type 'a bound = 'a * int (* non overlapping intervals *) type 'a t = ('a bound * 'a bound) list let of_intervals intervals = let pos = List.map (fun ((a, x), (b, y)) -> if x > y then [] else [((a, x), `S); ((b, y), `E)] ) intervals |> List.flatten |> List.sort (fun ((_, x), k) ((_, y), k') -> (* Make `S come before `E so that consecutive intervals get merged together in the fold below *) let kn = function `S -> 0 | `E -> 1 in compare (x, kn k) (y, kn k')) in let nesting, acc = List.fold_left (fun (nesting, acc) (a, kind) -> match kind, nesting with | `S, `Outside -> `Inside (a, 0), acc | `S, `Inside (s, n) -> `Inside (s, n+1), acc | `E, `Outside -> assert false | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc) | `E, `Inside (s, n) -> `Inside (s, n-1), acc ) (`Outside, []) pos in assert (nesting = `Outside); List.rev acc let mem iset ~pos = List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset let find_bound_in iset ~range:(start, end_) = List.find_map (fun ((a, x), (b, y)) -> if start <= x && x <= end_ then Some (a, x) else if start <= y && y <= end_ then Some (b, y) else None ) iset let is_start iset ~pos = List.find_map (fun ((a, x), _) -> if pos = x then Some a else None ) iset let is_end iset ~pos = List.find_map (fun (_, (b, y)) -> if pos = y then Some b else None ) iset let extrema iset = if iset = [] then None else Some (fst (List.hd iset), snd (List.hd (List.rev iset))) end (******************************************************************************) (* Toplevel: highlighting and quoting locations *) (* Highlight the locations using standout mode. If [locs] is empty, this function is a no-op. *) let highlight_terminfo lb ppf locs = Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) let pos0 = -lb.lex_abs_pos in (* Do nothing if the buffer does not contain the whole phrase. *) if pos0 < 0 then raise Exit; (* Count number of lines in phrase *) let lines = ref !num_loc_lines in for i = pos0 to lb.lex_buffer_len - 1 do if Bytes.get lb.lex_buffer i = '\n' then incr lines done; (* If too many lines, give up *) if !lines >= Terminfo.num_lines stdout - 2 then raise Exit; (* Move cursor up that number of lines *) flush stdout; Terminfo.backup stdout !lines; (* Print the input, switching to standout for the location *) let bol = ref false in print_string "# "; for pos = 0 to lb.lex_buffer_len - pos0 - 1 do if !bol then (print_string " "; bol := false); if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then Terminfo.standout stdout true; if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then Terminfo.standout stdout false; let c = Bytes.get lb.lex_buffer (pos + pos0) in print_char c; bol := (c = '\n') done; (* Make sure standout mode is over *) Terminfo.standout stdout false; (* Position cursor back to original location *) Terminfo.resume stdout !num_loc_lines; flush stdout let highlight_terminfo lb ppf locs = try highlight_terminfo lb ppf locs with Exit -> () (* Highlight the location by printing it again. There are two different styles for highlighting errors in "dumb" mode, depending if the error fits on a single line or spans across several lines. For single-line errors, foo the_error bar gets displayed as follows, where X is the line number: X | foo the_error bar ^^^^^^^^^ For multi-line errors, foo the_ error bar gets displayed as: X1 | ....the_ X2 | error.... An ellipsis hides the middle lines of the multi-line error if it has more than [max_lines] lines. If [locs] is empty then this function is a no-op. *) type input_line = { text : string; start_pos : int; } (* Takes a list of lines with possibly missing line numbers. If the line numbers that are present are consistent with the number of lines between them, then infer the intermediate line numbers. This is not always the case, typically if lexer line directives are involved... *) let infer_line_numbers (lines: (int option * input_line) list): (int option * input_line) list = let (_, offset, consistent) = List.fold_left (fun (i, offset, consistent) (lnum, _) -> match lnum, offset with | None, _ -> (i+1, offset, consistent) | Some n, None -> (i+1, Some (n - i), consistent) | Some n, Some m -> (i+1, offset, consistent && n = m + i) ) (0, None, true) lines in match offset, consistent with | Some m, true -> List.mapi (fun i (_, line) -> (Some (m + i), line)) lines | _, _ -> lines (* [get_lines] must return the lines to highlight, given starting and ending positions. See [lines_around_from_current_input] below for an instantiation of [get_lines] that reads from the current input. *) let highlight_quote ppf ~(get_lines: start_pos:position -> end_pos:position -> input_line list) ?(max_lines = 10) highlight_tag locs = let iset = ISet.of_intervals @@ List.filter_map (fun loc -> let s, e = loc.loc_start, loc.loc_end in if s.pos_cnum = -1 || e.pos_cnum = -1 then None else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1)) ) locs in match ISet.extrema iset with | None -> () | Some ((leftmost, _), (rightmost, _)) -> let lines = get_lines ~start_pos:leftmost ~end_pos:rightmost |> List.map (fun ({ text; start_pos } as line) -> let end_pos = start_pos + String.length text - 1 in let line_nb = match ISet.find_bound_in iset ~range:(start_pos, end_pos) with | None -> None | Some (p, _) -> Some p.pos_lnum in (line_nb, line)) |> infer_line_numbers |> List.map (fun (lnum, { text; start_pos }) -> (text, Option.fold ~some:Int.to_string ~none:"" lnum, start_pos)) in Format.fprintf ppf "@[<v>"; begin match lines with | [] | [("", _, _)] -> () | [(line, line_nb, line_start_cnum)] -> (* Single-line error *) Format.fprintf ppf "%s | %s@," line_nb line; Format.fprintf ppf "%*s " (String.length line_nb) ""; (* Iterate up to [rightmost], which can be larger than the length of the line because we may point to a location after the end of the last token on the line, for instance: {[ token ^ Did you forget ... ]} *) for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do let pos = line_start_cnum + i in if ISet.is_start iset ~pos <> None then Format.fprintf ppf "@{<%s>" highlight_tag; if ISet.mem iset ~pos then Format.pp_print_char ppf '^' else if i < String.length line then begin (* For alignment purposes, align using a tab for each tab in the source code *) if line.[i] = '\t' then Format.pp_print_char ppf '\t' else Format.pp_print_char ppf ' ' end; if ISet.is_end iset ~pos <> None then Format.fprintf ppf "@}" done; Format.fprintf ppf "@}@," | _ -> (* Multi-line error *) Misc.pp_two_columns ~sep:"|" ~max_lines ppf @@ List.map (fun (line, line_nb, line_start_cnum) -> let line = String.mapi (fun i car -> if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.' ) line in (line_nb, line) ) lines end; Format.fprintf ppf "@]" let lines_around ~(start_pos: position) ~(end_pos: position) ~(seek: int -> unit) ~(read_char: unit -> char option): input_line list = seek start_pos.pos_bol; let lines = ref [] in let bol = ref start_pos.pos_bol in let cur = ref start_pos.pos_bol in let b = Buffer.create 80 in let add_line () = if !bol < !cur then begin let text = Buffer.contents b in Buffer.clear b; lines := { text; start_pos = !bol } :: !lines; bol := !cur end in let rec loop () = if !bol >= end_pos.pos_cnum then () else begin match read_char () with | None -> (* end of input *) add_line () | Some c -> incr cur; match c with | '\r' -> loop () | '\n' -> add_line (); loop () | _ -> Buffer.add_char b c; loop () end in loop (); List.rev !lines (* Try to get lines from a lexbuf *) let lines_around_from_lexbuf ~(start_pos: position) ~(end_pos: position) (lb: lexbuf): input_line list = (* Converts a global position to one that is relative to the lexing buffer *) let rel n = n - lb.lex_abs_pos in if rel start_pos.pos_bol < 0 then begin (* Do nothing if the buffer does not contain the input (because it has been refilled while lexing it) *) [] end else begin let pos = ref 0 in (* relative position *) let seek n = pos := rel n in let read_char () = if !pos >= lb.lex_buffer_len then (* end of buffer *) None else let c = Bytes.get lb.lex_buffer !pos in incr pos; Some c in lines_around ~start_pos ~end_pos ~seek ~read_char end (* Attempt to get lines from the phrase buffer *) let lines_around_from_phrasebuf ~(start_pos: position) ~(end_pos: position) (pb: Buffer.t): input_line list = let pos = ref 0 in let seek n = pos := n in let read_char () = if !pos >= Buffer.length pb then None else begin let c = Buffer.nth pb !pos in incr pos; Some c end in lines_around ~start_pos ~end_pos ~seek ~read_char (* Get lines from a file *) let lines_around_from_file ~(start_pos: position) ~(end_pos: position) (filename: string): input_line list = try let cin = open_in_bin filename in let read_char () = try Some (input_char cin) with End_of_file -> None in let lines = lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char in close_in cin; lines with Sys_error _ -> [] (* A [get_lines] function for [highlight_quote] that reads from the current input. It first tries to read from [!input_lexbuf], then if that fails (because the lexbuf no longer contains the input we want), it reads from [!input_name] directly *) let lines_around_from_current_input ~start_pos ~end_pos = (* Be a bit defensive, and do not try to open one of the possible [!input_name] values that we know do not denote valid filenames. *) let file_valid = function | "//toplevel//" | "_none_" | "" -> false | _ -> true in let from_file () = if file_valid !input_name then lines_around_from_file !input_name ~start_pos ~end_pos else [] in match !input_lexbuf, !input_phrase_buffer, !input_name with | _, Some pb, "//toplevel//" -> begin match lines_around_from_phrasebuf pb ~start_pos ~end_pos with | [] -> (* Could not read the input from the phrase buffer. This is likely a sign that we were given a buggy location. *) [] | lines -> lines end | Some lb, _, _ -> begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with | [] -> (* The input is likely not in the lexbuf anymore *) from_file () | lines -> lines end | None, _, _ -> from_file () (******************************************************************************) (* Reporting errors and warnings *) type msg = (Format.formatter -> unit) loc let msg ?(loc = none) fmt = Format.kdprintf (fun txt -> { loc; txt }) fmt type report_kind = | Report_error | Report_warning of string | Report_warning_as_error of string | Report_alert of string | Report_alert_as_error of string type report = { kind : report_kind; main : msg; sub : msg list; } type report_printer = { (* The entry point *) pp : report_printer -> Format.formatter -> report -> unit; pp_report_kind : report_printer -> report -> Format.formatter -> report_kind -> unit; pp_main_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_main_txt : report_printer -> report -> Format.formatter -> (Format.formatter -> unit) -> unit; pp_submsgs : report_printer -> report -> Format.formatter -> msg list -> unit; pp_submsg : report_printer -> report -> Format.formatter -> msg -> unit; pp_submsg_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_submsg_txt : report_printer -> report -> Format.formatter -> (Format.formatter -> unit) -> unit; } let is_dummy_loc loc = (* Fixme: this should be just [loc.loc_ghost] and the function should be inlined below. However, currently, the compiler emits in some places ghost locations with valid ranges that should still be printed. These locations should be made non-ghost -- in the meantime we just check if the ranges are valid. *) loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1 (* It only makes sense to highlight (i.e. quote or underline the corresponding source code) locations that originate from the current input. As of now, this should only happen in the following cases: - if dummy locs or ghost locs leak out of the compiler or a buggy ppx; - more generally, if some code uses the compiler-libs API and feeds it locations that do not match the current values of [!Location.input_name], [!Location.input_lexbuf]; - when calling the compiler on a .ml file that contains lexer line directives indicating an other file. This should happen relatively rarely in practice -- in particular this is not what happens when using -pp or -ppx or a ppx driver. *) let is_quotable_loc loc = not (is_dummy_loc loc) && loc.loc_start.pos_fname = !input_name && loc.loc_end.pos_fname = !input_name let error_style () = match !Clflags.error_style with | Some setting -> setting | None -> Misc.Error_style.default_setting let batch_mode_printer : report_printer = let pp_loc _self report ppf loc = let tag = match report.kind with | Report_warning_as_error _ | Report_alert_as_error _ | Report_error -> "error" | Report_warning _ | Report_alert _ -> "warning" in let highlight ppf loc = match error_style () with | Misc.Error_style.Contextual -> if is_quotable_loc loc then highlight_quote ppf ~get_lines:lines_around_from_current_input tag [loc] | Misc.Error_style.Short -> () in Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc in let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in let pp self ppf report = setup_colors (); separate_new_message ppf; (* Make sure we keep [num_loc_lines] updated. The tabulation box is here to give submessage the option to be aligned with the main message box *) print_updating_num_loc_lines ppf (fun ppf () -> Format.fprintf ppf "@[<v>%a%a%a: %a%a%a%a@]@." Format.pp_open_tbox () (self.pp_main_loc self report) report.main.loc (self.pp_report_kind self report) report.kind Format.pp_set_tab () (self.pp_main_txt self report) report.main.txt (self.pp_submsgs self report) report.sub Format.pp_close_tbox () ) () in let pp_report_kind _self _ ppf = function | Report_error -> Format.fprintf ppf "@{<error>Error@}" | Report_warning w -> Format.fprintf ppf "@{<warning>Warning@} %s" w | Report_warning_as_error w -> Format.fprintf ppf "@{<error>Error@} (warning %s)" w | Report_alert w -> Format.fprintf ppf "@{<warning>Alert@} %s" w | Report_alert_as_error w -> Format.fprintf ppf "@{<error>Error@} (alert %s)" w in let pp_main_loc self report ppf loc = pp_loc self report ppf loc in let pp_main_txt _self _ ppf txt = pp_txt ppf txt in let pp_submsgs self report ppf msgs = List.iter (fun msg -> Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg ) msgs in let pp_submsg self report ppf { loc; txt } = Format.fprintf ppf "@[%a %a@]" (self.pp_submsg_loc self report) loc (self.pp_submsg_txt self report) txt in let pp_submsg_loc self report ppf loc = if not loc.loc_ghost then pp_loc self report ppf loc in let pp_submsg_txt _self _ ppf loc = pp_txt ppf loc in { pp; pp_report_kind; pp_main_loc; pp_main_txt; pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt } let terminfo_toplevel_printer (lb: lexbuf): report_printer = let pp self ppf err = setup_colors (); (* Highlight all toplevel locations of the report, instead of displaying the main location. Do it now instead of in [pp_main_loc], to avoid messing with Format boxes. *) let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in let all_locs = err.main.loc :: sub_locs in let locs_highlighted = List.filter is_quotable_loc all_locs in highlight_terminfo lb ppf locs_highlighted; batch_mode_printer.pp self ppf err in let pp_main_loc _ _ _ _ = () in let pp_submsg_loc _ _ ppf loc = if not loc.loc_ghost then Format.fprintf ppf "%a:@ " print_loc loc in { batch_mode_printer with pp; pp_main_loc; pp_submsg_loc } let best_toplevel_printer () = setup_terminal (); match !status, !input_lexbuf with | Terminfo.Good_term, Some lb -> terminfo_toplevel_printer lb | _, _ -> batch_mode_printer (* Creates a printer for the current input *) let default_report_printer () : report_printer = if !input_name = "//toplevel//" then best_toplevel_printer () else batch_mode_printer let report_printer = ref default_report_printer let print_report ppf report = let printer = !report_printer () in printer.pp printer ppf report (******************************************************************************) (* Reporting errors *) type error = report let report_error ppf err = print_report ppf err let mkerror loc sub txt = { kind = Report_error; main = { loc; txt }; sub } let errorf ?(loc = none) ?(sub = []) = Format.kdprintf (mkerror loc sub) let error ?(loc = none) ?(sub = []) msg_str = mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str) let error_of_printer ?(loc = none) ?(sub = []) pp x = mkerror loc sub (fun ppf -> pp ppf x) let error_of_printer_file print x = error_of_printer ~loc:(in_file !input_name) print x (******************************************************************************) (* Reporting warnings: generating a report from a warning number using the information in [Warnings] + convenience functions. *) let default_warning_alert_reporter report mk (loc: t) w : report option = match report w with | `Inactive -> None | `Active { Warnings.id; message; is_error; sub_locs } -> let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in let kind = mk is_error id in let main = { loc; txt = msg_of_str message } in let sub = List.map (fun (loc, sub_message) -> { loc; txt = msg_of_str sub_message } ) sub_locs in Some { kind; main; sub } let default_warning_reporter = default_warning_alert_reporter Warnings.report (fun is_error id -> if is_error then Report_warning_as_error id else Report_warning id ) let warning_reporter = ref default_warning_reporter let report_warning loc w = !warning_reporter loc w let formatter_for_warnings = ref Format.err_formatter let print_warning loc ppf w = match report_warning loc w with | None -> () | Some report -> print_report ppf report let prerr_warning loc w = print_warning loc !formatter_for_warnings w let default_alert_reporter = default_warning_alert_reporter Warnings.report_alert (fun is_error id -> if is_error then Report_alert_as_error id else Report_alert id ) let alert_reporter = ref default_alert_reporter let report_alert loc w = !alert_reporter loc w let print_alert loc ppf w = match report_alert loc w with | None -> () | Some report -> print_report ppf report let prerr_alert loc w = print_alert loc !formatter_for_warnings w let alert ?(def = none) ?(use = none) ~kind loc message = prerr_alert loc {Warnings.kind; message; def; use} let deprecated ?def ?use loc message = alert ?def ?use ~kind:"deprecated" loc message let auto_include_alert lib = let message = Printf.sprintf "\ OCaml's lib directory layout changed in 5.0. The %s subdirectory has been \ automatically added to the search path, but you should add -I +%s to the \ command-line to silence this alert (e.g. by adding %s to the list of \ libraries in your dune file, or adding use_%s to your _tags file for \ ocamlbuild, or using -package %s for ocamlfind)." lib lib lib lib lib in let alert = {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} in prerr_alert none alert let deprecated_script_alert program = let message = Printf.sprintf "\ Running %s where the first argument is an implicit basename with no \ extension (e.g. %s script-file) is deprecated. Either rename the script \ (%s script-file.ml) or qualify the basename (%s ./script-file)" program program program program in let alert = {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} in prerr_alert none alert (******************************************************************************) (* Reporting errors on exceptions *) let error_of_exn : (exn -> error option) list ref = ref [] let register_error_of_exn f = error_of_exn := f :: !error_of_exn exception Already_displayed_error = Warnings.Errors let error_of_exn exn = match exn with | Already_displayed_error -> Some `Already_displayed | _ -> let rec loop = function | [] -> None | f :: rest -> match f exn with | Some error -> Some (`Ok error) | None -> loop rest in loop !error_of_exn let () = register_error_of_exn (function | Sys_error msg -> Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) | _ -> None ) external reraise : exn -> 'a = "%reraise" let report_exception ppf exn = let rec loop n exn = match error_of_exn exn with | None -> reraise exn | Some `Already_displayed -> () | Some (`Ok err) -> report_error ppf err | exception exn when n > 0 -> loop (n-1) exn in loop 5 exn exception Error of error let () = register_error_of_exn (function | Error e -> Some e | _ -> None ) let raise_errorf ?(loc = none) ?(sub = []) = Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt)))
sectionYPositions = computeSectionYPositions($el), 10)"
x-init="setTimeout(() => sectionYPositions = computeSectionYPositions($el), 10)"
>