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
type t = Lexing.position * Lexing.position
let from_info (file : string) (sline : int) (scol : int) (eline : int) (ecol : int) : t =
let spos =
{ Lexing.pos_fname = file; Lexing.pos_lnum = sline; Lexing.pos_cnum = scol; Lexing.pos_bol = 1 }
in
let epos =
{ Lexing.pos_fname = file; Lexing.pos_lnum = eline; Lexing.pos_cnum = ecol; Lexing.pos_bol = 1 }
in
(spos, epos)
let get_start_line (pos : t) : int =
let s, _ = pos in
s.Lexing.pos_lnum
let get_start_column (pos : t) : int =
let s, _ = pos in
s.Lexing.pos_cnum - s.Lexing.pos_bol + 1
let get_end_line (pos : t) : int =
let _, e = pos in
e.Lexing.pos_lnum
let get_end_column (pos : t) : int =
let _, e = pos in
e.Lexing.pos_cnum - e.Lexing.pos_bol + 1
let get_file (pos : t) : string = (fst pos).Lexing.pos_fname
let to_string (pos : t) : string =
let s, e = pos in
Printf.sprintf "in file %s, from %d:%d to %d:%d" s.Lexing.pos_fname s.Lexing.pos_lnum
(s.Lexing.pos_cnum - s.Lexing.pos_bol + 1)
e.Lexing.pos_lnum
(e.Lexing.pos_cnum - e.Lexing.pos_bol + 1)
let to_string_short (pos : t) : string =
let s, e = pos in
Printf.sprintf "%s;%d:%d--%d:%d" s.Lexing.pos_fname s.Lexing.pos_lnum
(s.Lexing.pos_cnum - s.Lexing.pos_bol + 1)
e.Lexing.pos_lnum
(e.Lexing.pos_cnum - e.Lexing.pos_bol + 1)
let indent_number (s : string) : int =
try
let rec aux (i : int) = if s.[i] = ' ' then aux (i + 1) else i in
aux 0
with Invalid_argument _ -> String.length s
let retrieve_loc_text (pos : t) : string =
let filename = get_file pos in
let blue_style = [ ANSITerminal.Bold; ANSITerminal.blue ] in
if filename = "" then "No position information"
else
let sline = get_start_line pos in
let eline = get_end_line pos in
let oc =
try open_in filename
with Sys_error _ ->
Cli.error_print (Printf.sprintf "File not found : \"%s\"" filename);
exit (-1)
in
let input_line_opt () : string option = try Some (input_line oc) with End_of_file -> None in
let print_matched_line (line : string) (line_no : int) : string =
let line_indent = indent_number line in
let error_indicator_style = [ ANSITerminal.red; ANSITerminal.Bold ] in
line
^
if line_no >= sline && line_no <= eline then
"\n"
^
if line_no = sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s"
(get_end_column pos - 1)
(String.make (max (get_end_column pos - get_start_column pos) 0) '^')
else if line_no = sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s"
(String.length line - 1)
(String.make (max (String.length line - get_start_column pos) 0) '^')
else if line_no <> sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s%s" line_indent ""
(String.make (max (String.length line - line_indent) 0) '^')
else if line_no <> sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s%*s" line_indent ""
(get_end_column pos - 1 - line_indent)
(String.make (max (get_end_column pos - line_indent) 0) '^')
else assert false
else ""
in
let = 0 in
let rec get_lines (n : int) : string list =
match input_line_opt () with
| Some line ->
if n < sline - include_extra_count then get_lines (n + 1)
else if n >= sline - include_extra_count && n <= eline + include_extra_count then
print_matched_line line n :: get_lines (n + 1)
else []
| None -> []
in
let pos_lines = get_lines 1 in
let spaces = int_of_float (log10 (float_of_int eline)) + 1 in
close_in oc;
Cli.print_with_style blue_style "%*s--> %s\n%s" spaces "" filename
(Cli.add_prefix_to_each_line
(Printf.sprintf "\n%s" (String.concat "\n" pos_lines))
(fun i ->
let cur_line = sline - include_extra_count + i - 1 in
if
cur_line >= sline
&& cur_line <= sline + (2 * (eline - sline))
&& cur_line mod 2 = sline mod 2
then Cli.print_with_style blue_style "%*d | " spaces (sline + ((cur_line - sline) / 2))
else if cur_line >= sline - include_extra_count && cur_line < sline then
Cli.print_with_style blue_style "%*d | " spaces cur_line
else if
cur_line <= sline + (2 * (eline - sline)) + 1 + include_extra_count
&& cur_line > sline + (2 * (eline - sline)) + 1
then Cli.print_with_style blue_style "%*d | " spaces (cur_line - (eline - sline + 1))
else Cli.print_with_style blue_style "%*s | " spaces ""))
type 'a marked = 'a * t
let no_pos : t =
let zero_pos =
{ Lexing.pos_fname = ""; Lexing.pos_lnum = 0; Lexing.pos_cnum = 0; Lexing.pos_bol = 0 }
in
(zero_pos, zero_pos)
let unmark ((x, _) : 'a marked) : 'a = x
let get_position ((_, x) : 'a marked) : t = x
let map_under_mark (f : 'a -> 'b) ((x, y) : 'a marked) : 'b marked = (f x, y)
let same_pos_as (x : 'a) ((_, y) : 'b marked) : 'a marked = (x, y)
let unmark_option (x : 'a marked option) : 'a option =
match x with Some x -> Some (unmark x) | None -> None