diff options
Diffstat (limited to 'src/reporting_basic.ml')
| -rw-r--r-- | src/reporting_basic.ml | 96 |
1 files changed, 81 insertions, 15 deletions
diff --git a/src/reporting_basic.ml b/src/reporting_basic.ml index 5ff43208..a47ee8ae 100644 --- a/src/reporting_basic.ml +++ b/src/reporting_basic.ml @@ -87,19 +87,84 @@ (* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (**************************************************************************) -let format_pos ff p = ( - Format.fprintf ff "File \"%s\", line %d, character %d:\n" - p.Lexing.pos_fname p.Lexing.pos_lnum (p.Lexing.pos_cnum - p.Lexing.pos_bol); - Format.pp_print_flush ff ()) +let rec skip_lines in_chan = function + | n when n <= 0 -> () + | n -> input_line in_chan; skip_lines in_chan (n - 1) +let rec read_lines in_chan = function + | n when n <= 0 -> [] + | n -> + let l = input_line in_chan in + let ls = read_lines in_chan (n - 1) in + l :: ls -let format_pos2 ff p1 p2 = ( - Format.fprintf ff "File \"%s\", line %d, character %d to line %d, character %d" - p1.Lexing.pos_fname - p1.Lexing.pos_lnum (p1.Lexing.pos_cnum - p1.Lexing.pos_bol + 1) - p2.Lexing.pos_lnum (p2.Lexing.pos_cnum - p2.Lexing.pos_bol); - Format.pp_print_flush ff () -) +let termcode n = "\x1B[" ^ string_of_int n ^ "m" + +let print_code1 ff fname lnum1 cnum1 cnum2 = + try + let in_chan = open_in fname in + begin + try + skip_lines in_chan (lnum1 - 1); + let line = input_line in_chan in + Format.fprintf ff "%s%s%s%s%s" + (Str.string_before line cnum1) + (termcode 41) + (Str.string_before (Str.string_after line cnum1) (cnum2 - cnum1)) + (termcode 49) + (Str.string_after line cnum2); + close_in in_chan + with e -> (close_in_noerr in_chan; print_endline (Printexc.to_string e)) + end + with _ -> () + +let format_pos ff p = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d:\n\n" + p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol); + print_code1 ff p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) (p.pos_cnum - p.pos_bol + 1); + Format.fprintf ff "\n\n"; + Format.pp_print_flush ff () + end + +let print_code2 ff fname lnum1 cnum1 lnum2 cnum2 = + try + let in_chan = open_in fname in + begin + try + skip_lines in_chan (lnum1 - 1); + let line = input_line in_chan in + Format.fprintf ff "%s%s%s%s\n" + (Str.string_before line cnum1) + (termcode 41) + (Str.string_after line cnum1) + (termcode 49); + let lines = read_lines in_chan (lnum2 - lnum1 - 1) in + List.iter (fun l -> Format.fprintf ff "%s%s%s\n" (termcode 41) l (termcode 49)) lines; + let line = input_line in_chan in + Format.fprintf ff "%s%s%s%s" + (termcode 41) + (Str.string_before line cnum2) + (termcode 49) + (Str.string_after line cnum2); + close_in in_chan + with e -> (close_in_noerr in_chan; print_endline (Printexc.to_string e)) + end + with _ -> () + +let format_pos2 ff p1 p2 = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d\n\n" + p1.pos_fname + p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1) + p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + if p1.pos_lnum == p2.pos_lnum + then print_code1 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol) + else print_code2 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + Format.pp_print_flush ff () + end (* reads the part between p1 and p2 from the file *) @@ -171,12 +236,12 @@ let loc_to_string l = type pos_or_loc = Loc of Parse_ast.l | LocD of Parse_ast.l * Parse_ast.l | Pos of Lexing.position let print_err_internal fatal verb_loc p_l m1 m2 = + Format.eprintf "%s at " m1; let _ = (match p_l with Pos p -> print_err_pos p | Loc l -> print_err_loc l | LocD (l1,l2) -> print_err_loc l1; Format.fprintf Format.err_formatter " and "; print_err_loc l2) in - let m12 = if String.length m2 = 0 then "" else ": " in - Format.eprintf " %s%s%s\n" m1 m12 m2; + Format.eprintf "%s\n" m2; if verb_loc then (match p_l with Loc l -> format_loc_source Format.err_formatter l; Format.pp_print_newline Format.err_formatter (); | _ -> ()); @@ -220,5 +285,6 @@ let report_error e = let (m1, verb_pos, pos_l, m2) = dest_err e in (print_err_internal verb_pos false pos_l m1 m2; exit 1) - - +let print_error e = + let (m1, verb_pos, pos_l, m2) = dest_err e in + print_err_internal verb_pos false pos_l m1 m2 |