Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 242 lines (209 sloc) 8.119 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"
77daeb8 @BourgerieQuentin [enhance] printers: Add stdlib gamma to the qml printers
BourgerieQuentin authored
125 let stdlib_gamma_id = define "stdlib_gamma"
fccc685 Initial open-source release
MLstate authored
126
127 let printers extract _ =
128 let make_code fct fmt env =
129 let _, _, code = extract env in
130 fct fmt code in
131 let make_ac fct fmt env =
132 let annotmap, _, code = extract env in
133 fct fmt annotmap code in
134 let make_gamma fct fmt env =
77daeb8 @BourgerieQuentin [enhance] printers: Add stdlib gamma to the qml printers
BourgerieQuentin authored
135 let _, (gamma, _), _ = extract env in
fccc685 Initial open-source release
MLstate authored
136 fct fmt gamma in
77daeb8 @BourgerieQuentin [enhance] printers: Add stdlib gamma to the qml printers
BourgerieQuentin authored
137 let make_stdlib_gamma fct fmt env =
138 let _, (_, stdlib_gamma), _ = extract env in
139 fct fmt stdlib_gamma in
fccc685 Initial open-source release
MLstate authored
140 [
141 code_id, make_code Printer.code ;
142 light_ident_id, make_code Printer.light_ident ;
143 very_light_ident_id, make_code Printer.very_light_ident ;
144 declaration_id, make_code Printer.declaration ;
145 annotation_id, make_code Printer.annotation;
f0aca58 @fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
146 (* Source code positions printer registered. *)
147 position_id, make_code Printer.position;
fccc685 Initial open-source release
MLstate authored
148 size_id, make_code Printer.size ;
149 with_type_id, make_ac Printer.code_with_type;
150 for_ei_id, make_ac Printer.code_for_ei;
151 gamma_id, make_gamma Printer.gamma;
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not plac...
BourgerieQuentin authored
152 stdlib_gamma_id, make_stdlib_gamma Printer.gamma;
fccc685 Initial open-source release
MLstate authored
153 (* waiting for flexibility in passhander options *)
154 (* tracked_id, make Printer.tracked ; *)
155 ]
156
157 module Tracker =
158 struct
159 let pp_print_expr = QmlPrint.pp#expr
160 let pp_print_code_elt = QmlPrint.pp#code_elt
161
162 let directive iter =
163 QmlAstWalk.CodeExpr.iter
164 (QmlAstWalk.Expr.iter
165 (function
166 | Q.Directive (_, `tracker t, [e], _) -> iter.PassTracker.track (PassTracker.filename t) pp_print_expr e
167 | _ -> ()))
168
169 (* We keep the full code_elt for each val
170 it is a duplication, but it speed up searching
171 anyway, the folder _tracks can be cleaned *)
172 let val_ iter = List.iter
173 (function
174 | Q.NewVal (_, binds)
175 | ( Q.NewValRec (_, binds) ) as elt -> List.iter
176 (fun (s, _) ->
177 let filename = Ident.stident s in
178 iter.PassTracker.track filename pp_print_code_elt elt
179 ) binds
180 | _ -> ())
181 end
182
183 let define = PassHandler.define_tracker
184 let directive_id = define "track"
185 let val_id = define "val"
186
187 let trackers extract _ =
188 let make fct fmt env = fct fmt (extract env) in
189 [
190 directive_id, make Tracker.directive ;
191 val_id, make Tracker.val_ ;
192 ]
193
194 (* iterator on `track directive with something else that expr *)
195 module WIP =
196 struct
197 (* other iterators : wip *)
198 type ('tracked, 'env) iter_tracker =
199 ( 'env -> QmlAst.code ) ->
200 (PassTracker.t -> 'tracked PassHandler.printer -> 'tracked -> unit) -> 'env -> unit
201
202 let pp_print_expr = QmlPrint.pp#expr
203 let pp_print_annot fmt annot =
204 Format.pp_print_string fmt (Annot.to_string annot)
205 let pp_print_ty = QmlPrint.pp#ty
206
207 let iter_tracker extract iter env =
208 QmlAstWalk.CodeExpr.iter
209 (QmlAstWalk.Expr.iter
210 (function
211 | Q.Directive (_, `tracker t, [e], _) -> iter.PassTracker.track (PassTracker.filename t) pp_print_expr e
212 | _ -> ()))
213 (extract env)
214
215 let iter_annot_tracker extract iter env =
216 QmlAstWalk.CodeExpr.iter
217 (QmlAstWalk.Expr.iter
218 (function
219 | Q.Directive (_, `tracker t, [e], _) -> iter t pp_print_annot (Q.QAnnot.expr e)
220 | _ -> () ))
221 (extract env)
222
223 let iter_ty_tracker extract_annotmap extract_code iter env =
224 QmlAstWalk.CodeExpr.iter
225 (QmlAstWalk.Expr.iter
226 (function
227 | Q.Directive (_, `tracker t, [e], _) -> (
228 let annot = Q.QAnnot.expr e in
229 match QmlAnnotMap.find_ty_opt annot (extract_annotmap env) with
230 | Some ty -> iter t pp_print_ty ty
231 | None -> iter t
232 (fun fmt _ ->
233 Format.fprintf fmt "Annot Not Found: %a. The expr is:@\n%a"
234 pp_print_annot annot pp_print_expr e)
235 (QmlAst.TypeConst QmlAst.TyNull)
236 )
237 | _ -> () )
238 )
239 (extract_code env)
240
241 end
Something went wrong with that request. Please try again.