1 | open Lexing |
---|
2 | |
---|
3 | type t = |
---|
4 | { |
---|
5 | start_p : Lexing.position; |
---|
6 | end_p : Lexing.position |
---|
7 | } |
---|
8 | |
---|
9 | type position = t |
---|
10 | |
---|
11 | type 'a located = |
---|
12 | { |
---|
13 | value : 'a; |
---|
14 | position : t; |
---|
15 | } |
---|
16 | |
---|
17 | let value { value = v } = |
---|
18 | v |
---|
19 | |
---|
20 | let position { position = p } = |
---|
21 | p |
---|
22 | |
---|
23 | let destruct p = |
---|
24 | (p.value, p.position) |
---|
25 | |
---|
26 | let with_pos p v = |
---|
27 | { |
---|
28 | value = v; |
---|
29 | position = p; |
---|
30 | } |
---|
31 | |
---|
32 | let with_poss p1 p2 v = |
---|
33 | with_pos { start_p = p1; end_p = p2 } v |
---|
34 | |
---|
35 | let map f v = |
---|
36 | { |
---|
37 | value = f v.value; |
---|
38 | position = v.position; |
---|
39 | } |
---|
40 | |
---|
41 | let iter f { value = v } = |
---|
42 | f v |
---|
43 | |
---|
44 | let mapd f v = |
---|
45 | let w1, w2 = f v.value in |
---|
46 | let pos = v.position in |
---|
47 | ({ value = w1; position = pos }, { value = w2; position = pos }) |
---|
48 | |
---|
49 | let dummy = |
---|
50 | { |
---|
51 | start_p = Lexing.dummy_pos; |
---|
52 | end_p = Lexing.dummy_pos |
---|
53 | } |
---|
54 | |
---|
55 | let unknown_pos v = |
---|
56 | { |
---|
57 | value = v; |
---|
58 | position = dummy |
---|
59 | } |
---|
60 | |
---|
61 | let start_of_position p = p.start_p |
---|
62 | |
---|
63 | let end_of_position p = p.end_p |
---|
64 | |
---|
65 | let filename_of_position p = |
---|
66 | p.start_p.Lexing.pos_fname |
---|
67 | |
---|
68 | let line p = |
---|
69 | p.pos_lnum |
---|
70 | |
---|
71 | let column p = |
---|
72 | p.pos_cnum - p.pos_bol |
---|
73 | |
---|
74 | let characters p1 p2 = |
---|
75 | (column p1, p2.pos_cnum - p1.pos_bol) (* intentionally [p1.pos_bol] *) |
---|
76 | |
---|
77 | let join x1 x2 = |
---|
78 | { |
---|
79 | start_p = if x1 = dummy then x2.start_p else x1.start_p; |
---|
80 | end_p = if x2 = dummy then x1.end_p else x2.end_p |
---|
81 | } |
---|
82 | |
---|
83 | let lex_join x1 x2 = |
---|
84 | { |
---|
85 | start_p = x1; |
---|
86 | end_p = x2 |
---|
87 | } |
---|
88 | |
---|
89 | let join_located l1 l2 f = |
---|
90 | { |
---|
91 | value = f l1.value l2.value; |
---|
92 | position = join l1.position l2.position; |
---|
93 | } |
---|
94 | |
---|
95 | let string_of_lex_pos p = |
---|
96 | let c = p.pos_cnum - p.pos_bol in |
---|
97 | (string_of_int p.pos_lnum)^":"^(string_of_int c) |
---|
98 | |
---|
99 | let string_of_pos p = |
---|
100 | let filename = filename_of_position p in |
---|
101 | let l = line p.start_p in |
---|
102 | let c1, c2 = characters p.start_p p.end_p in |
---|
103 | if filename = "" then |
---|
104 | Printf.sprintf "Line %d, characters %d-%d" l c1 c2 |
---|
105 | else |
---|
106 | Printf.sprintf "File \"%s\", line %d, characters %d-%d" filename l c1 c2 |
---|
107 | |
---|
108 | let pos_or_undef = function |
---|
109 | | None -> dummy |
---|
110 | | Some x -> x |
---|
111 | |
---|
112 | let cpos lexbuf = |
---|
113 | { |
---|
114 | start_p = Lexing.lexeme_start_p lexbuf; |
---|
115 | end_p = Lexing.lexeme_end_p lexbuf; |
---|
116 | } |
---|
117 | |
---|
118 | let with_cpos lexbuf v = |
---|
119 | with_pos (cpos lexbuf) v |
---|
120 | |
---|
121 | let string_of_cpos lexbuf = |
---|
122 | string_of_pos (cpos lexbuf) |
---|
123 | |
---|
124 | let joinf f t1 t2 = |
---|
125 | join (f t1) (f t2) |
---|
126 | |
---|
127 | let ljoinf f = |
---|
128 | List.fold_left (fun p t -> join p (f t)) dummy |
---|
129 | |
---|
130 | let join_located_list ls f = |
---|
131 | { |
---|
132 | value = f (List.map (fun l -> l.value) ls); |
---|
133 | position = ljoinf (fun x -> x.position) ls |
---|
134 | } |
---|