Skip to content
Newer
Older
100644 173 lines (133 sloc) 5.23 KB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* refactoring *)
19
20 (* alias *)
21 module Q = QmlAst
22
23 module Context =
24 struct
25
26 type context = {
27 pos : FilePos.pos ;
28
29 (* The annotmap is for finding types *)
30 annotmap : QmlAst.annotmap list ;
31
32 code_elt : QmlAst.code_elt list ;
33
34 expr : QmlAst.expr list ;
35
36 pat : QmlAst.pat list ;
37
38 ty : QmlAst.ty list ;
39
40 what_a_shame : string list ;
41 }
42
43 let default = {
44 pos = FilePos.nopos "QmlError.Context.default" ;
45 annotmap = [] ;
46 code_elt = [] ;
47 expr = [] ;
48 pat = [] ;
49 ty = [] ;
50 what_a_shame = [] ;
51 }
52
53 let insert_aux list o =
54 if List.exists (fun o' -> o == o') list
55 then list
56 else o::list
57
58 let merge_aux a b = List.fold_left insert_aux b a
59
60 let merge2 c1 c2 = {
61 pos = FilePos.merge_pos c1.pos c2.pos ;
62
63 annotmap = merge_aux c1.annotmap c2.annotmap ;
64 code_elt = merge_aux c1.code_elt c2.code_elt ;
65 expr = merge_aux c1.expr c2.expr ;
66 pat = merge_aux c1.pat c2.pat ;
67 ty = merge_aux c1.ty c2.ty ;
68 what_a_shame = merge_aux c1.what_a_shame c2.what_a_shame ;
69 }
70 let merge = List.fold_left merge2
71
72 let pos pos = { default with pos = pos }
73 let label label = { default with pos = Annot.pos label }
74 let annotmap annotmap = { default with annotmap = [annotmap] }
75 let code_elt code_elt = { default with code_elt = [code_elt] ; pos = QmlAst.Pos.code_elt code_elt }
76 let expr expr = { default with expr = [expr] }
77 let exprs expr exprs = { default with expr = expr::exprs }
78 let pat pat = { default with pat = [pat] }
79 let ty ty = { default with ty = [ty] }
80 let shame_on_me_i_am_too_lazy no_context = { default with what_a_shame = [no_context] }
81
82 let annoted_expr annotmap expr = { default with annotmap = [annotmap] ; expr = [expr] }
83 let annoted_pat annotmap pat = { default with annotmap = [annotmap] ; pat = [pat] }
84
85 (* OUTPUT *)
86
87 (*
88 The goal there:
89 We try at least to print the location in the console.
90 If we are not able to do that, we will print some AST, using [QmlPrint.pp].
91 The full printer is used internally for opatrack traces, as the code
92 has been transormed, we print totally
93 *)
94
95 module Output =
96 struct
97 (* merge all positions found from the context *)
98 let extract_position c =
99 let fold pos acc e =
100 FilePos.merge_pos acc (pos e)
101 in
102 let pos = c.pos in
103 let pos = List.fold_left (fold Q.Pos.expr) pos c.expr in
104 let pos = List.fold_left (fold Q.Pos.pat) pos c.pat in
105 pos
106
107 (* strategy:
108 + if we have some positions, we print just them, it is enough,
109 printing the code is not a good idea because it does not correspond to
110 what the user wrote anyway.
111 + if we do not have positions, it is because we are not finished with the refactoring
112 of positions in the AST. In this case, will will print the 'full' printer in the console.
113 *)
114
115 let sep = String.make 80 '='
116
117 let of_type annot fmt c =
118 let iter annotmap =
119 match QmlAnnotMap.find_ty_opt annot annotmap with
120 | Some ty ->
121 Format.fprintf fmt "%s@\nAnnoted with the following type:@\n%a@\n"
122 sep QmlPrint.pp#ty ty
123 | None -> () in
124 List.iter iter c.annotmap
125
126 let full fmt c =
127 let pos = extract_position c in
128
129 Format.fprintf fmt "%s@\n%a@\n" sep FilePos.pp_pos pos ;
130
131 if c.expr = [] && c.pat = [] then (
132
133 List.iter (fun code_elt ->
134 Format.fprintf fmt "%s@\nIn the following toplevel definition:@\n%a@\n"
135 sep QmlPrint.pp#code_elt code_elt) c.code_elt ;
136
137 ()
138
139 );
140
141 List.iter (fun expr ->
142 Format.fprintf fmt "%s@\nIn the following expression:@\n%a@\n%a"
143 sep QmlPrint.pp#expr expr (of_type (Q.QAnnot.expr expr)) c) c.expr ;
144
145 List.iter (fun pat ->
146 Format.fprintf fmt "%s@\nIn the following pattern:@\n%a@\n%a"
147 sep QmlPrint.pp#pat pat (of_type (Q.QAnnot.pat pat)) c) c.pat ;
148
149 List.iter (fun ty ->
150 Format.fprintf fmt "%s@\nIn the following type:@\n%a@\n"
151 sep QmlPrint.pp#ty ty) c.ty ;
152
153 List.iter (fun shame ->
154 Format.fprintf fmt "%s@\nIn the following internal positions:@\n%a@\n"
155 sep Format.pp_print_string shame) c.what_a_shame ;
156 ()
157
158 let console fmt c =
159 let pos = extract_position c in
160 if FilePos.is_empty pos
161 then full fmt c
162 else Format.fprintf fmt "%a@\n" FilePos.pp_pos pos
163 end
164
165 let full = Output.full
166 let console = Output.console
167 let get_pos = Output.extract_position
168
169 end
170 type context = Context.context
171 module E = PassError.LangError(Context)
172 include E
Something went wrong with that request. Please try again.