-
Notifications
You must be signed in to change notification settings - Fork 125
/
qmlError.ml
172 lines (133 loc) · 5.23 KB
/
qmlError.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
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* refactoring *)
(* alias *)
module Q = QmlAst
module Context =
struct
type context = {
pos : FilePos.pos ;
(* The annotmap is for finding types *)
annotmap : QmlAst.annotmap list ;
code_elt : QmlAst.code_elt list ;
expr : QmlAst.expr list ;
pat : QmlAst.pat list ;
ty : QmlAst.ty list ;
what_a_shame : string list ;
}
let default = {
pos = FilePos.nopos "QmlError.Context.default" ;
annotmap = [] ;
code_elt = [] ;
expr = [] ;
pat = [] ;
ty = [] ;
what_a_shame = [] ;
}
let insert_aux list o =
if List.exists (fun o' -> o == o') list
then list
else o::list
let merge_aux a b = List.fold_left insert_aux b a
let merge2 c1 c2 = {
pos = FilePos.merge_pos c1.pos c2.pos ;
annotmap = merge_aux c1.annotmap c2.annotmap ;
code_elt = merge_aux c1.code_elt c2.code_elt ;
expr = merge_aux c1.expr c2.expr ;
pat = merge_aux c1.pat c2.pat ;
ty = merge_aux c1.ty c2.ty ;
what_a_shame = merge_aux c1.what_a_shame c2.what_a_shame ;
}
let merge = List.fold_left merge2
let pos pos = { default with pos = pos }
let label label = { default with pos = Annot.pos label }
let annotmap annotmap = { default with annotmap = [annotmap] }
let code_elt code_elt = { default with code_elt = [code_elt] ; pos = QmlAst.Pos.code_elt code_elt }
let expr expr = { default with expr = [expr] }
let exprs expr exprs = { default with expr = expr::exprs }
let pat pat = { default with pat = [pat] }
let ty ty = { default with ty = [ty] }
let shame_on_me_i_am_too_lazy no_context = { default with what_a_shame = [no_context] }
let annoted_expr annotmap expr = { default with annotmap = [annotmap] ; expr = [expr] }
let annoted_pat annotmap pat = { default with annotmap = [annotmap] ; pat = [pat] }
(* OUTPUT *)
(*
The goal there:
We try at least to print the location in the console.
If we are not able to do that, we will print some AST, using [QmlPrint.pp].
The full printer is used internally for opatrack traces, as the code
has been transormed, we print totally
*)
module Output =
struct
(* merge all positions found from the context *)
let extract_position c =
let fold pos acc e =
FilePos.merge_pos acc (pos e)
in
let pos = c.pos in
let pos = List.fold_left (fold Q.Pos.expr) pos c.expr in
let pos = List.fold_left (fold Q.Pos.pat) pos c.pat in
pos
(* strategy:
+ if we have some positions, we print just them, it is enough,
printing the code is not a good idea because it does not correspond to
what the user wrote anyway.
+ if we do not have positions, it is because we are not finished with the refactoring
of positions in the AST. In this case, will will print the 'full' printer in the console.
*)
let sep = String.make 80 '='
let of_type annot fmt c =
let iter annotmap =
match QmlAnnotMap.find_ty_opt annot annotmap with
| Some ty ->
Format.fprintf fmt "%s@\nAnnoted with the following type:@\n%a@\n"
sep QmlPrint.pp#ty ty
| None -> () in
List.iter iter c.annotmap
let full fmt c =
let pos = extract_position c in
Format.fprintf fmt "%s@\n%a@\n" sep FilePos.pp_pos pos ;
if c.expr = [] && c.pat = [] then (
List.iter (fun code_elt ->
Format.fprintf fmt "%s@\nIn the following toplevel definition:@\n%a@\n"
sep QmlPrint.pp#code_elt code_elt) c.code_elt ;
()
);
List.iter (fun expr ->
Format.fprintf fmt "%s@\nIn the following expression:@\n%a@\n%a"
sep QmlPrint.pp#expr expr (of_type (Q.QAnnot.expr expr)) c) c.expr ;
List.iter (fun pat ->
Format.fprintf fmt "%s@\nIn the following pattern:@\n%a@\n%a"
sep QmlPrint.pp#pat pat (of_type (Q.QAnnot.pat pat)) c) c.pat ;
List.iter (fun ty ->
Format.fprintf fmt "%s@\nIn the following type:@\n%a@\n"
sep QmlPrint.pp#ty ty) c.ty ;
List.iter (fun shame ->
Format.fprintf fmt "%s@\nIn the following internal positions:@\n%a@\n"
sep Format.pp_print_string shame) c.what_a_shame ;
()
let console fmt c =
let pos = extract_position c in
if FilePos.is_empty pos
then full fmt c
else Format.fprintf fmt "%a@\n" FilePos.pp_pos pos
end
let full = Output.full
let console = Output.console
let get_pos = Output.extract_position
end
type context = Context.context
module E = PassError.LangError(Context)
include E