Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 184 lines (141 sloc) 5.835 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
da48a00 @OpaOnWindowsNow [enhance] QmlError.Context: add a construtor for package context with…
OpaOnWindowsNow authored
40 package : string list ; (* sometime the context is related to compilation option of a package, so you are not on shame but you have no position *)
41
fccc685 Initial open-source release
MLstate authored
42 what_a_shame : string list ;
43 }
44
45 let default = {
46 pos = FilePos.nopos "QmlError.Context.default" ;
47 annotmap = [] ;
48 code_elt = [] ;
49 expr = [] ;
50 pat = [] ;
51 ty = [] ;
da48a00 @OpaOnWindowsNow [enhance] QmlError.Context: add a construtor for package context with…
OpaOnWindowsNow authored
52 package = [] ;
fccc685 Initial open-source release
MLstate authored
53 what_a_shame = [] ;
54 }
55
56 let insert_aux list o =
57 if List.exists (fun o' -> o == o') list
58 then list
59 else o::list
60
61 let merge_aux a b = List.fold_left insert_aux b a
62
63 let merge2 c1 c2 = {
64 pos = FilePos.merge_pos c1.pos c2.pos ;
65
66 annotmap = merge_aux c1.annotmap c2.annotmap ;
67 code_elt = merge_aux c1.code_elt c2.code_elt ;
68 expr = merge_aux c1.expr c2.expr ;
69 pat = merge_aux c1.pat c2.pat ;
70 ty = merge_aux c1.ty c2.ty ;
da48a00 @OpaOnWindowsNow [enhance] QmlError.Context: add a construtor for package context with…
OpaOnWindowsNow authored
71 package = merge_aux c1.package c2.package;
fccc685 Initial open-source release
MLstate authored
72 what_a_shame = merge_aux c1.what_a_shame c2.what_a_shame ;
73 }
74 let merge = List.fold_left merge2
75
76 let pos pos = { default with pos = pos }
77 let label label = { default with pos = Annot.pos label }
78 let annotmap annotmap = { default with annotmap = [annotmap] }
79 let code_elt code_elt = { default with code_elt = [code_elt] ; pos = QmlAst.Pos.code_elt code_elt }
80 let expr expr = { default with expr = [expr] }
81 let exprs expr exprs = { default with expr = expr::exprs }
82 let pat pat = { default with pat = [pat] }
83 let ty ty = { default with ty = [ty] }
da48a00 @OpaOnWindowsNow [enhance] QmlError.Context: add a construtor for package context with…
OpaOnWindowsNow authored
84 let package packagename = { default with package = [packagename] }
fccc685 Initial open-source release
MLstate authored
85 let shame_on_me_i_am_too_lazy no_context = { default with what_a_shame = [no_context] }
86
da48a00 @OpaOnWindowsNow [enhance] QmlError.Context: add a construtor for package context with…
OpaOnWindowsNow authored
87
fccc685 Initial open-source release
MLstate authored
88 let annoted_expr annotmap expr = { default with annotmap = [annotmap] ; expr = [expr] }
89 let annoted_pat annotmap pat = { default with annotmap = [annotmap] ; pat = [pat] }
90
91 (* OUTPUT *)
92
93 (*
94 The goal there:
95 We try at least to print the location in the console.
96 If we are not able to do that, we will print some AST, using [QmlPrint.pp].
97 The full printer is used internally for opatrack traces, as the code
98 has been transormed, we print totally
99 *)
100
101 module Output =
102 struct
103 (* merge all positions found from the context *)
104 let extract_position c =
105 let fold pos acc e =
106 FilePos.merge_pos acc (pos e)
107 in
108 let pos = c.pos in
109 let pos = List.fold_left (fold Q.Pos.expr) pos c.expr in
110 let pos = List.fold_left (fold Q.Pos.pat) pos c.pat in
111 pos
112
113 (* strategy:
114 + if we have some positions, we print just them, it is enough,
115 printing the code is not a good idea because it does not correspond to
116 what the user wrote anyway.
117 + if we do not have positions, it is because we are not finished with the refactoring
118 of positions in the AST. In this case, will will print the 'full' printer in the console.
119 *)
120
121 let sep = String.make 80 '='
122
123 let of_type annot fmt c =
124 let iter annotmap =
125 match QmlAnnotMap.find_ty_opt annot annotmap with
126 | Some ty ->
127 Format.fprintf fmt "%s@\nAnnoted with the following type:@\n%a@\n"
128 sep QmlPrint.pp#ty ty
129 | None -> () in
130 List.iter iter c.annotmap
131
132 let full fmt c =
133 let pos = extract_position c in
134
135 Format.fprintf fmt "%s@\n%a@\n" sep FilePos.pp_pos pos ;
136
137 if c.expr = [] && c.pat = [] then (
138
139 List.iter (fun code_elt ->
140 Format.fprintf fmt "%s@\nIn the following toplevel definition:@\n%a@\n"
141 sep QmlPrint.pp#code_elt code_elt) c.code_elt ;
142
143 ()
144
145 );
146
147 List.iter (fun expr ->
148 Format.fprintf fmt "%s@\nIn the following expression:@\n%a@\n%a"
149 sep QmlPrint.pp#expr expr (of_type (Q.QAnnot.expr expr)) c) c.expr ;
150
151 List.iter (fun pat ->
152 Format.fprintf fmt "%s@\nIn the following pattern:@\n%a@\n%a"
153 sep QmlPrint.pp#pat pat (of_type (Q.QAnnot.pat pat)) c) c.pat ;
154
155 List.iter (fun ty ->
156 Format.fprintf fmt "%s@\nIn the following type:@\n%a@\n"
157 sep QmlPrint.pp#ty ty) c.ty ;
158
da48a00 @OpaOnWindowsNow [enhance] QmlError.Context: add a construtor for package context with…
OpaOnWindowsNow authored
159 List.iter (fun package ->
160 Format.fprintf fmt "%s@\nIn the following package:@\n%a@\n"
161 sep Format.pp_print_string package) c.package ;
162 ();
163
fccc685 Initial open-source release
MLstate authored
164 List.iter (fun shame ->
165 Format.fprintf fmt "%s@\nIn the following internal positions:@\n%a@\n"
166 sep Format.pp_print_string shame) c.what_a_shame ;
167 ()
168
169 let console fmt c =
170 let pos = extract_position c in
171 if FilePos.is_empty pos
172 then full fmt c
173 else Format.fprintf fmt "%a@\n" FilePos.pp_pos pos
174 end
175
176 let full = Output.full
177 let console = Output.console
178 let get_pos = Output.extract_position
179
180 end
181 type context = Context.context
182 module E = PassError.LangError(Context)
183 include E
Something went wrong with that request. Please try again.