Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 237 lines (204 sloc) 7.901 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 (* THIS FILE HAS A DOCUMENTED MLI *)
19
20 (* depends *)
21 module Format = Base.Format
22
23 (* refactoring in progress *)
24
25 (* shorthands *)
26 module Q = QmlAst
27
28 let contains_tracker e =
29 QmlAstWalk.Expr.exists
30 (function
31 | Q.Directive (_, `tracker _, _, _) -> true
32 | _ -> false) e
33
34 module Printer =
35 struct
36 let code fmt code =
37 Format.fprintf fmt "/* printer: --print code */@\n@\n" ;
38 QmlPrint.pp#code fmt code ;
39 Format.fprintf fmt "@."
40
41 let light_ident fmt code =
42 Format.fprintf fmt "/* printer: --print light_ident */@\n@\n" ;
43 QmlPrint.pp_light_ident#code fmt code ;
44 Format.fprintf fmt "@."
45
46 let very_light_ident fmt code =
47 Format.fprintf fmt "/* printer: --print very_light_ident */@\n@\n" ;
48 QmlPrint.pp_very_light_ident#code fmt code ;
49 Format.fprintf fmt "@."
50
51 let code_with_type fmt annotmap code =
52 Format.fprintf fmt "/* printer: --print code_with_type */@\n@\n" ;
53 (new QmlPrint.printer_with_type annotmap)#code fmt code ;
54 Format.fprintf fmt "@."
55
56 let code_for_ei fmt annotmap code =
57 Format.fprintf fmt "/* printer: --print code_for_ei */@\n@\n" ;
58 (new QmlPrint.printer_for_ei annotmap)#code fmt code ;
59 Format.fprintf fmt "@."
60
61 (* <!> beware opatrack uses this formating.
62 Do not change it or please update opatrack *)
63 let size fmt code =
64 let i =
65 QmlAstWalk.CodeExpr.fold
66 (QmlAstWalk.Expr.fold (fun acc _ -> acc + 1)) 0 code in
67 Format.fprintf fmt
68 "%d declarations@\n%d nodes@." (List.length code) i
69
70 let declaration fmt code =
71 Format.fprintf fmt "/* printer: --print declaration */@\n@\n" ;
72 QmlPrint.pp_declaration#code fmt code ;
73 Format.fprintf fmt "@."
74
75 let annotation fmt code =
76 Format.fprintf fmt "/* printer: --print annotation */@\n@\n";
77 QmlPrint.pp_annotation#code fmt code;
78 Format.fprintf fmt "@."
79
f0aca58 @fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
80 (* ************************************************************************ *)
81 (** {b Descr}: Printer for position in source code.
82 {b Visibility} : Not exported outside this module. *)
83 (* ************************************************************************ *)
84 let position fmt code =
85 Format.fprintf fmt "/* printer: --print position */@\n@\n";
86 QmlPrint.pp_position#code fmt code;
87 Format.fprintf fmt "@."
88
fccc685 Initial open-source release
MLstate authored
89 let tracked fmt code =
90 Format.fprintf fmt "/* printer: --print tracked */" ;
91 let bind kw rec_ (s, e) =
92 let val_ = if !kw then (kw := false; "val"^rec_) else "and" in
93 Format.fprintf fmt "@\n@\n@\n@\n@\n/* %s %s */@\n@\n%s %s =@ %a@\n"
94 val_ (Ident.stident s) val_ (Ident.stident s) QmlPrint.pp#expr e
95 in
96 let is_tracked = List.exists (fun (_, e) -> contains_tracker e) in
97 List.iter
98 (function
99 | Q.NewVal (_, b) ->
100 if is_tracked b then List.iter (bind (ref true) "") b
101 | Q.NewValRec (_, b) ->
102 if is_tracked b then List.iter (bind (ref true) " rec") b
103 | _ -> ()
104 ) code;
105 Format.fprintf fmt "@."
106
107 let gamma fmt gamma =
108 Format.fprintf fmt "/* printer: --print gamma*/@.";
109 QmlTypes.Env.pp fmt gamma;
110 Format.fprintf fmt "@."
111 end
112
113 let define = PassHandler.define_printer
114 let code_id = define "code"
115 let light_ident_id = define "light_ident"
116 let very_light_ident_id = define "very_light_ident"
117 let with_type_id = define "with_type"
118 let for_ei_id = define "for_ei"
119 let size_id = define "size"
120 let declaration_id = define "declaration"
121 let annotation_id = define "annotation"
f0aca58 @fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
122 let position_id = define "position"
fccc685 Initial open-source release
MLstate authored
123 let tracked_id = define "tracked"
124 let gamma_id = define "gamma"
125
126 let printers extract _ =
127 let make_code fct fmt env =
128 let _, _, code = extract env in
129 fct fmt code in
130 let make_ac fct fmt env =
131 let annotmap, _, code = extract env in
132 fct fmt annotmap code in
133 let make_gamma fct fmt env =
134 let _, gamma, _ = extract env in
135 fct fmt gamma in
136 [
137 code_id, make_code Printer.code ;
138 light_ident_id, make_code Printer.light_ident ;
139 very_light_ident_id, make_code Printer.very_light_ident ;
140 declaration_id, make_code Printer.declaration ;
141 annotation_id, make_code Printer.annotation;
f0aca58 @fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
142 (* Source code positions printer registered. *)
143 position_id, make_code Printer.position;
fccc685 Initial open-source release
MLstate authored
144 size_id, make_code Printer.size ;
145 with_type_id, make_ac Printer.code_with_type;
146 for_ei_id, make_ac Printer.code_for_ei;
147 gamma_id, make_gamma Printer.gamma;
148 (* waiting for flexibility in passhander options *)
149 (* tracked_id, make Printer.tracked ; *)
150 ]
151
152 module Tracker =
153 struct
154 let pp_print_expr = QmlPrint.pp#expr
155 let pp_print_code_elt = QmlPrint.pp#code_elt
156
157 let directive iter =
158 QmlAstWalk.CodeExpr.iter
159 (QmlAstWalk.Expr.iter
160 (function
161 | Q.Directive (_, `tracker t, [e], _) -> iter.PassTracker.track (PassTracker.filename t) pp_print_expr e
162 | _ -> ()))
163
164 (* We keep the full code_elt for each val
165 it is a duplication, but it speed up searching
166 anyway, the folder _tracks can be cleaned *)
167 let val_ iter = List.iter
168 (function
169 | Q.NewVal (_, binds)
170 | ( Q.NewValRec (_, binds) ) as elt -> List.iter
171 (fun (s, _) ->
172 let filename = Ident.stident s in
173 iter.PassTracker.track filename pp_print_code_elt elt
174 ) binds
175 | _ -> ())
176 end
177
178 let define = PassHandler.define_tracker
179 let directive_id = define "track"
180 let val_id = define "val"
181
182 let trackers extract _ =
183 let make fct fmt env = fct fmt (extract env) in
184 [
185 directive_id, make Tracker.directive ;
186 val_id, make Tracker.val_ ;
187 ]
188
189 (* iterator on `track directive with something else that expr *)
190 module WIP =
191 struct
192 (* other iterators : wip *)
193 type ('tracked, 'env) iter_tracker =
194 ( 'env -> QmlAst.code ) ->
195 (PassTracker.t -> 'tracked PassHandler.printer -> 'tracked -> unit) -> 'env -> unit
196
197 let pp_print_expr = QmlPrint.pp#expr
198 let pp_print_annot fmt annot =
199 Format.pp_print_string fmt (Annot.to_string annot)
200 let pp_print_ty = QmlPrint.pp#ty
201
202 let iter_tracker extract iter env =
203 QmlAstWalk.CodeExpr.iter
204 (QmlAstWalk.Expr.iter
205 (function
206 | Q.Directive (_, `tracker t, [e], _) -> iter.PassTracker.track (PassTracker.filename t) pp_print_expr e
207 | _ -> ()))
208 (extract env)
209
210 let iter_annot_tracker extract iter env =
211 QmlAstWalk.CodeExpr.iter
212 (QmlAstWalk.Expr.iter
213 (function
214 | Q.Directive (_, `tracker t, [e], _) -> iter t pp_print_annot (Q.QAnnot.expr e)
215 | _ -> () ))
216 (extract env)
217
218 let iter_ty_tracker extract_annotmap extract_code iter env =
219 QmlAstWalk.CodeExpr.iter
220 (QmlAstWalk.Expr.iter
221 (function
222 | Q.Directive (_, `tracker t, [e], _) -> (
223 let annot = Q.QAnnot.expr e in
224 match QmlAnnotMap.find_ty_opt annot (extract_annotmap env) with
225 | Some ty -> iter t pp_print_ty ty
226 | None -> iter t
227 (fun fmt _ ->
228 Format.fprintf fmt "Annot Not Found: %a. The expr is:@\n%a"
229 pp_print_annot annot pp_print_expr e)
230 (QmlAst.TypeConst QmlAst.TyNull)
231 )
232 | _ -> () )
233 )
234 (extract_code env)
235
236 end
Something went wrong with that request. Please try again.