Skip to content
This repository
Newer
Older
100644 806 lines (709 sloc) 28.572 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2a857ddd » BourgerieQuentin
2012-03-29 [enhance] compiler, printer: db query + options
2 Copyright © 2011, 2012 MLstate
fccc6851 » MLstate
2011-06-21 Initial open-source release
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
19 (**
20 Printers of QML AST.
21 @author Vincent Benayoun
22 @author Mikolaj Konarski
23 @author Mathieu Barbin
24 @author Valentin Gatien-Baron
25 @author Rudy Sicard
26 @author Mehdi Bouaziz
27 @author David Rajchenbach-Teller
28 @author Louis Gesbert
29 *)
30
31 (**
32 This module defines some printers for working on Qml AST.
33
34 New version for printer is based on Format, and object inheritence.
35
36 For each type [t] of the AST, there is a method called [t] which is
37 of type [Format.formatter -> t -> unit].
38
39 Then, it is easy to inherit from the default object for changing just a few cases.
40 By default, at end of the file, there is some alias for hiding the object
41 implementation for user who does not need to use several printers.
42
43 {[
44 class default =
45 object(self)
46
47 method pat ... : Format.formatter -> QmlAst.pat -> unit
48 method expr ...: Format.formatter -> QmlAst.expr -> unit
49 ....
50 method code....: Format.formatter -> QmlAst.code -> unit
51 end
52
53 (* exporting default printer to the top level *)
54 let pat = default#pat
55 let expr = default#expr
56 ....
57
58 (* custom printer *)
59 inherit, and overwrite any method.
60 ]}
61
62 The old printer is deprecated and will be removed (but this means changes in a lot of modules).
63 *)
64
65 (* depends *)
66 module Format = BaseFormat
67 module List = BaseList
68 module String = BaseString
69
70 (* refactoring *)
71
72 (* alias *)
73
74 (* shorthands *)
75 module Q = QmlAst
28521d48 » BourgerieQuentin
2012-01-24 [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
76 module Db = QmlAst.Db
fccc6851 » MLstate
2011-06-21 Initial open-source release
77
78 (* -- *)
79
80 (**
81 In opa, string can contains ["an acces to a {variable}"].
82 So, any char ['{'] from a row string should be escaped.
83 *)
84 let escaped_string s =
85 let s = String.escaped s in
86 String.replace s "{" "\\{"
87
88 let directive (d:QmlAst.qml_directive) =
2536662d » OpaOnWindowsNow
2011-09-23 [feature] closure serialisation: restrict to new @public_env directive
89 "@"^(QmlDirectives.to_string d)
fccc6851 » MLstate
2011-06-21 Initial open-source release
90
91 (* ************************************************************************** *)
92 (** {b Descr}: Returns the string corresponding to a type definition
93 visibility suitable to be printed *before* the "type" token of a type
94 definition pretty print string.
95 {b Visibility}: Not exported outside this module. *)
96 (* ************************************************************************** *)
97 let type_def_visibility = function
98 | Q.TDV_public -> ""
99 | Q.TDV_abstract _ -> "@abstract "
100 | Q.TDV_private _ -> "@private "
101
102
103
104 let pp = Format.fprintf
105 let pp_list = Format.pp_list
106
107 let regroup_patfield = function
108 | Q.PatRecord (_, fields, rowvar) ->
109 fields, rowvar = `open_
110 | _ -> assert false
111 let rec regroup_extend_record ?(acc=[]) = function
112 | Q.ExtendRecord (_, f, d, r) -> regroup_extend_record ~acc:((f,d) :: acc) r
113 | e -> e, List.rev acc
114 let is_infix s = Ident.is_operator s
115
116 class base_printer =
117 object (self)
118
119 (* handling of priorities
120 * when [op] is true, we are under an operator
121 * when [arrow] is true, we are on the lhs of an arrow
122 * when [amper] is true, we are just under a '&'
123 * when [comma] is true, we are just inside a tuple or a lambda binding
124 * when [record] is true, we are just under a record binding
125 *)
126 val op = false
127 val arrow = false
128 val amper = false
129 val comma = false
130 val record = false
131 val coerce = false
132
133 method reset =
134 {<
135 op = false;
136 arrow = false;
137 amper = false;
138 comma = false;
139 record = false;
140 coerce = false;
141 >}
142
143 method under_op = {< op = true >}
144 method under_arrow = {< arrow = true >}
145 method under_amper = {< amper = true >}
146 method under_comma = {< comma = true >}
147 method under_record = {< record = true >}
148 method under_coerce = {< coerce = true >}
149
150 (* annot printer *)
151 method expr_node fmt expr =
152 self#expr0 fmt expr
153
154 method pat_node fmt pat =
155 self#pat0 fmt pat
156
157 method ident_to_string i = Ident.opa_syntax i
158 method ident f i = Format.pp_print_string f (self#ident_to_string i)
159
160 (*--------------------*)
161 (*--- type printer ---*)
162 (*--------------------*)
163 method ty f = function
164 | Q.TypeArrow _ as t when comma -> pp f "(%a)" self#reset#ty t
165 | Q.TypeArrow _ as t when arrow -> pp f "(%a)" self#reset#ty t
166 | Q.TypeForall _ as t when arrow || comma -> pp f "(%a)" self#reset#ty t
167 | Q.TypeConst const -> Format.pp_print_string f (Q.Const.string_of_ty const)
168 | Q.TypeVar typevar -> self#typevar f typevar
169 | Q.TypeArrow (lty1, ty2) -> pp f "@[<2>%a ->@ %a@]" (pp_list ",@ " self#under_arrow#ty) lty1 self#under_arrow#ty ty2
170 | Q.TypeRecord row -> self#reset#tyrow f row
171 | Q.TypeSum ty_col -> self#tysum f ty_col
172 | Q.TypeSumSugar tyl -> pp f "@[%a@]" (pp_list "@ /@ " self#ty) tyl
173 | Q.TypeName ([],t) -> self#typeident f t
174 | Q.TypeName (tyl,t) -> pp f "@[<2>%a(%a)@]" self#typeident t (pp_list ",@ " self#reset#ty) tyl
175 | Q.TypeAbstract -> pp f "external"
176 | Q.TypeForall (tyvl,rowl,coll,ty) -> self#scheme f tyvl rowl coll ty
177 method typeident f t = pp f "%s" (Q.TypeIdent.to_printable_string t)
178 method typevar f t = Format.pp_print_string f (QmlTypeVars.TypeVar.to_string t)
179 method quant_colvar f t = Format.pp_print_string f (QmlTypeVars.ColVar.to_string t)
180 method quant_rowvar f t = Format.pp_print_string f (QmlTypeVars.RowVar.to_string t)
181 method colvar = self#quant_colvar
182 method rowvar = self#quant_rowvar
183 method tyrow f (Q.TyRow (fields,rowvar)) =
184 pp f "@[<hv2>{%a%t}@]"
185 (pp_list ";@ " self#tyrow_binding) fields
186 (fun f ->
187 match rowvar with
188 | None -> ()
189 | Some v -> Format.fprintf f "%s%a" (if fields = [] then "" else "; ") self#rowvar v)
190
191 (*
192 Can be overwritten in a class having a gamma, if needed
193 *)
194 method is_type_void ty =
195 match ty with
196 | Q.TypeRecord (Q.TyRow ([], None))
197 | Q.TypeSum (Q.TyCol ([ [ ] ], None)) ->
198 true
199 | _ -> false
200
201 method tyrow_binding f (s, ty) =
202 if self#is_type_void ty
203 then
204 Format.pp_print_string f s
205 else
206 pp f "@[<h>%s :@ %a@]" s self#ty ty
207
208 method tycol = self#tysum
209 method tysum f (Q.TyCol (fl, colvar)) =
210 (* Attention, if the sum type is closed and contains no row (i.e. a trivial
211 sum type with no possible cases), the printed type would be an empty
212 string, which would be very confusing ! So, manually take care of this
213 case. *)
214 if (List.length fl = 0) && colvar = None then
215 pp f "<empty sum type>"
216 else
217 pp f "@[<2>%a%t@]"
218 (pp_list "@ /@ " (fun f -> pp f "@[{%a}@]" (pp_list ";@ " self#tyrow_binding))) fl
219 (fun f ->
220 match colvar with
221 | None -> ()
222 | Some v -> pp f "@ /@ %a" self#colvar v)
223
224 method typedef f tdef =
225 let visibility_str = type_def_visibility tdef.Q.ty_def_visibility in
226 match tdef.Q.ty_def_params with
227 | [] ->
228 pp f "@[<2>%stype %a =@ %a@]"
229 visibility_str
230 self#typeident tdef.Q.ty_def_name self#ty tdef.Q.ty_def_body
231 | _ ->
232 pp f "@[<2>%stype %a(%a) =@ %a@]"
233 visibility_str
234 self#typeident tdef.Q.ty_def_name
235 (pp_list ",@ " self#typevar) tdef.Q.ty_def_params
236 self#ty tdef.Q.ty_def_body
237
238 method scheme f vars rvars cvars ty =
239 if rvars = [] && cvars = [] then
240 pp f "@[<2>forall(@[<h>%a@]).@ %a@]"
241 (pp_list ",@ " self#typevar) vars
242 self#ty ty
243 else
244 pp f "@[<2>forall(@[<h>%a,@ rows:%a,@ cols:%a@]).@ %a@]"
245 (pp_list ",@ " self#typevar) vars
246 (pp_list ",@ " self#rowvar) rvars
247 (pp_list ",@ " self#colvar) cvars
248 self#ty ty
249
250 method tsc f tsc =
251 let (quant,ty,()) = QmlGenericScheme.export_unsafe tsc in
252 let (vars, rvars, cvars) = QmlTypeVars.FreeVars.export_as_lists quant in
253 self#scheme f vars rvars cvars ty
254
255 (*---------------------*)
256 (*-- pattern printer --*)
257 (*---------------------*)
258 method is_tilde_field : 'a. ('a -> Ident.t option) -> string * 'a -> bool =
259 (fun getvar (field, pat) ->
260 match getvar pat with
261 | Some ident ->
262 let ident = self#ident_to_string ident in
263 String.compare field ident = 0
264 | None -> false
265 )
266
267 method pat_record_binding f ((s, p) as pat) =
268 match p with
269 | Q.PatRecord (_, [], `closed)
270 | Q.PatCoerce (_, Q.PatRecord (_, [], `closed), _)
271 ->
272 Format.pp_print_string f s
273 | _ ->
274 let getvar = function
275 | Q.PatVar (_, i) -> Some i
276 | _ -> None
277 in
278 if self#is_tilde_field getvar pat
279 then
280 pp f "~%s" s
281 else
282 pp f "@[<h>%s =@ %a@]" s self#pat p
283
284 method pat_record f fields rowvar =
285 match fields with
286 | [] ->
287 if rowvar = `open_
288 then
289 Format.pp_print_string f "{ ... }"
290 else
291 Format.pp_print_string f "{}"
292 | _ ->
293 let rowvar = if rowvar = `open_ then " ; ..." else "" in
294 let is_tilde_field field =
295 let getvar = function
296 | Q.PatVar (_, i) -> Some i
297 | _ -> None
298 in
299 self#is_tilde_field getvar field
300 in
301 if List.for_all is_tilde_field fields
302 then
303 let pp_field f (field, _) = Format.pp_print_string f field in
304 pp f "@[<hv2>~{ %a%s }@]"
305 (pp_list "@, " pp_field) fields
306 rowvar
307 else
308 pp f "@[<hv2>{ %a%s }@]"
309 (pp_list " ;@ " self#pat_record_binding) fields
310 rowvar
311
312 method pat0 f = function
313 | Q.PatRecord (_, fields, rowvar) -> self#pat_record f fields rowvar
314 | Q.PatConst (_, Q.String s) -> Format.fprintf f "\"%s\"" (escaped_string s)
315 | Q.PatConst (_, const) -> Format.pp_print_string f (Q.Const.string_of_expr const)
316 | Q.PatVar (_, i) -> self#ident f i
317 | Q.PatAny _ -> pp f "_"
318 | Q.PatCoerce (_, p, ty) -> pp f "(@[<2>%a :@ %a@])" self#pat p self#ty ty
319 | Q.PatAs (_, p, i) -> pp f "@[<2>%a as %a@]" self#pat p self#ident i
320 method pat f v =
321 self#pat_node f v
322
323 method const f = function
324 | Q.String s -> Format.fprintf f "\"%s\"" (escaped_string s)
325 | c -> Format.pp_print_string f (Q.Const.string_of_expr c)
326
df80d98c » BourgerieQuentin
2012-04-03 [feature] compiler, database: Just naive update of libqmlcompil (for …
327 method path f (el, knd, select) = QmlAst.Db.pp_path self#expr f (el, knd, select)
fccc6851 » MLstate
2011-06-21 Initial open-source release
328
329 method path_elts f el =
330 pp f "%a" (pp_list "" self#path_elt) el
331
332 (*---------------------*)
333 (*---- expr printer ---*)
334 (*---------------------*)
335 method expr0 f = function
336 | (Q.Lambda _ | Q.Coerce _) as e when coerce -> pp f "(%a)" self#reset#expr0 e
337 | (Q.Lambda _) as e when comma -> pp f "(%a)" self#reset#expr0 e
338 | Q.LetIn _ | Q.LetRecIn _ as e when record -> pp f "(%a)" self#reset#expr0 e
339 | Q.Match _ | Q.Lambda _ | Q.LetIn _ | Q.LetRecIn _ as e when op -> pp f "(%a)" self#reset#expr0 e
340 | Q.Const (_, c) -> self#const f c
341 | Q.Ident (_, i) -> self#ident f i
342 | Q.LetIn (_, b, e) ->
343 pp f "@[<v>%a@ %a@]" (pp_list "@ " self#binding) b self#expr e
344 | Q.LetRecIn (_, iel, e) -> pp f "@[<v>rec %a@ %a@]" (pp_list "@ and " self#binding) iel self#expr e
345 | Q.Lambda (_, il, e) ->
346 pp f "@[<2>@[<h>%a@] ->@ %a@]" (pp_list ",@ " self#ident) il self#expr e
347 | Q.Apply (_, Q.Ident (_, s), [e1; e2]) as e when is_infix s ->
348 if op then pp f "(%a)" self#reset#expr0 e else
349 let name = Ident.original_name s in
350 pp f "%a %s %a" self#under_op#expr e1 name self#under_op#expr e2
351 | Q.Apply (_, e, el) ->
352 pp f "@[<2>%a(@,%a)@]" self#apply_expr e (pp_list ",@ " self#reset#under_comma#expr) el
353 | Q.Match (_, e, pel) ->
354 pp f "@[<v>@[<2>match@ %a@ with@]@ | %a@ end@]" self#expr e (pp_list "@ | " self#rule_) pel
355 | Q.Record (_, [ s, Q.Coerce (_, Q.Record (_, []), Q.TypeRecord (Q.TyRow ([], None))) ] ) -> pp f "{%s}" s
356 | Q.Record (_, sel) -> self#reset#under_record#record f sel
357 | Q.Dot (_, e, s) -> pp f "%a.%s" self#apply_expr e s
358 | Q.ExtendRecord (_, s, e1, e2) ->
359 pp f "@[<2>{%s = %a} ::@ %a@]" s self#expr e1 self#expr e2
360 | Q.Bypass (_, s) -> Format.pp_print_string f ("%%" ^ (BslKey.to_string s) ^ "%%")
361 | Q.Coerce (_, e,ty) -> pp f "%a : %a" self#under_coerce#expr e self#ty ty
df80d98c » BourgerieQuentin
2012-04-03 [feature] compiler, database: Just naive update of libqmlcompil (for …
362 | Q.Path (_, el, knd, select) -> self#path f (el, knd, select)
fccc6851 » MLstate
2011-06-21 Initial open-source release
363 | Q.Directive (_, `module_, [e], _) -> pp f "{%a}" self#reset#expr e
364 | Q.Directive (_, dir, exprs, tys) -> self#directive f dir exprs tys
365 method bind_field fmt (f, d) = pp fmt "%s = %a" f self#under_record#expr d
366 method binding f (i, e) =
367 pp f "@[<hv2>%a =@ %a@]" self#ident i self#expr e
368 method expr f e =
369 self#expr_node f e
370 method apply_expr f = function
9ddf00d2 » Valentin Gatien-Baron
2011-06-27 [fix] qmlPrint: less useless parenthesis around bypasses
371 | Q.Bypass _
fccc6851 » MLstate
2011-06-21 Initial open-source release
372 | Q.Directive _
373 | Q.Ident _
374 | Q.Apply _
375 | Q.Dot _ as e -> self#expr f e
376 | e -> pp f "(%a)" self#reset#expr e
377 method directive f variant exprs tys =
378 let variant_aux f var =
379 match var with
380 | `abstract_ty_arg (tyvars,rowvars,colvars) ->
381 pp f "@[<2>@@abstract_ty_arg(%a|%a|%a)@]"
382 (pp_list ",@ " self#under_arrow#typevar) tyvars
383 (pp_list ",@ " self#under_arrow#rowvar) rowvars
384 (pp_list ",@ " self#under_arrow#colvar) colvars
385 | `apply_ty_arg (tys,tyrows,tycols) ->
386 pp f "@[<2>@@apply_ty_arg(%a|%a|%a)@]"
387 (pp_list ",@ " self#under_arrow#ty) tys
388 (pp_list ",@ " self#under_arrow#tyrow) tyrows
389 (pp_list ",@ " self#under_arrow#tysum) tycols
390 | _ -> pp f"@[<2>%s@]" (directive var)
391 in
392 match exprs, tys with
393 | [], [] -> pp f "@[<2>%a@]" variant_aux variant
394 | _, [] ->
8ba76562 » Valentin Gatien-Baron
2011-07-06 [fix] qmlPrint: printing more line breaks when printing long directives
395 pp f "@[<2>%a(@,%a)@]" variant_aux variant (pp_list ",@ " self#reset#under_comma#expr) exprs
fccc6851 » MLstate
2011-06-21 Initial open-source release
396 | _ ->
8ba76562 » Valentin Gatien-Baron
2011-07-06 [fix] qmlPrint: printing more line breaks when printing long directives
397 pp f "@[<2>%a(@,%a ;@ %a)@]" variant_aux variant
fccc6851 » MLstate
2011-06-21 Initial open-source release
398 (pp_list ",@ " self#reset#under_comma#expr) exprs
399 (pp_list ",@ " self#reset#under_comma#ty) tys
400 method record f l =
401 match l with
402 | [] -> pp f "{}"
403 | _ ->
404 let is_tilde_field field =
405 let getvar = function
406 | Q.Ident (_, i) -> Some i
407 | _ -> None
408 in
409 self#is_tilde_field getvar field
410 in
411 if List.for_all is_tilde_field l
412 then
413 let pp_field f (field, _) = Format.pp_print_string f field in
414 pp f "@[<hv>~{ %a }@]" (pp_list "@, " pp_field) l
415 else
416 pp f "@[<hv>{ %a }@]" (pp_list " ;@ " self#record_binding) l
417
418 method record_binding f ((s, e) as expr) =
419 match e with
420 | Q.Record (_, [])
421 | Q.Coerce (_, Q.Record (_, []), _)
422 | Q.Directive (_, `coerce, [ Q.Record (_, []) ], _) ->
423 Format.pp_print_string f s
424 | _ ->
425 let getvar = function
426 | Q.Ident (_, i) -> Some i
427 | _ -> None
428 in
429 if self#is_tilde_field getvar expr
430 then
431 pp f "~%s" s
432 else
433 pp f "@[<2>%s =@ %a@]" s self#expr e
434
435 method rule_ f (p,e) =
436 pp f "@[<2>%a ->@ %a@]" self#pat p self#expr e
2a857ddd » BourgerieQuentin
2012-03-29 [enhance] compiler, printer: db query + options
437 method path_elt f = (QmlAst.Db.pp_path_elt self#expr) f
fccc6851 » MLstate
2011-06-21 Initial open-source release
438
439 (*---------------------*)
440 (*---- code printer ---*)
441 (*---------------------*)
442 method code_elt f elt =
443 let newval rec_ iel =
444 pp f "@[<v>%t%s%a%t@]"
445 (fun f -> match iel with [_] -> () | _ -> pp f "/* group start */@ ")
446 (if rec_ then "rec " else "")
447 (if rec_
448 then (pp_list "@ and " self#binding)
449 else (pp_list "@ " self#binding)
450 ) iel
451 (fun f -> match iel with [_] -> () | _ -> pp f "@ /* group end */")
452 in
453 match elt with
454 | Q.Database (_, ident, _p, opts) -> pp f "@[<h>database /* %a */@ %s@]" self#ident ident (Q.Db.options_to_string opts)
455 | Q.NewDbValue (_, def) -> pp f "@[<hv2>%a@]" (Q.Db.print_def self#expr self#ty) def
456 | Q.NewType (_, l) -> pp f "@[<v>%a@]" (pp_list "@ " self#typedef) l
457 | Q.NewVal (_, iel) -> newval false iel
458 | Q.NewValRec (_, iel) -> newval true iel
459
460 method code f l =
461 pp f "@[<v>%a@]" (pp_list "@ @ " self#code_elt) l
462 end
463
464 (** {6 Other mode of printing} *)
465
466 class base_printer_with_sugared_types =
467 object (self)
468 inherit base_printer as super
469
470 (* Variables scope for type variables *)
471 val typevar_scope = QmlTypeVars.TypeVarPrint.new_scope ()
472 val rowvar_scope = QmlTypeVars.RowVarPrint.new_scope ()
473 val colvar_scope = QmlTypeVars.ColVarPrint.new_scope ()
474
475 method reset_typevars =
476 QmlTypeVars.TypeVarPrint.reset typevar_scope ;
477 QmlTypeVars.RowVarPrint.reset rowvar_scope ;
478 QmlTypeVars.ColVarPrint.reset colvar_scope ;
479 ()
480
481 method! typevar f t = QmlTypeVars.TypeVarPrint.pp typevar_scope f t
482 method! quant_rowvar f t = QmlTypeVars.RowVarPrint.pp rowvar_scope f t
483 method! quant_colvar f t = QmlTypeVars.ColVarPrint.pp colvar_scope f t
484 method! rowvar f _ = Format.pp_print_string f "..."
485 method! colvar f _ = Format.pp_print_string f "..."
486
487 method! scheme f vars rvars cvars ty =
488 QmlTypeVars.TypeVarPrint.push typevar_scope ;
489 QmlTypeVars.RowVarPrint.push rowvar_scope ;
490 QmlTypeVars.ColVarPrint.push colvar_scope ;
491 super#scheme f vars rvars cvars ty ;
492 QmlTypeVars.TypeVarPrint.pop typevar_scope ;
493 QmlTypeVars.RowVarPrint.pop rowvar_scope ;
494 QmlTypeVars.ColVarPrint.pop colvar_scope ;
495 ()
496
497 method ty_new_scope f ty =
498 self#reset_typevars;
499 self#ty f ty
500
501 method! code_elt f elt =
502 self#reset_typevars;
503 super#code_elt f elt
504 end
505
506 (**
507 The default pretty printer
508 *)
509 class opa_printer =
510 object (self)
511 inherit base_printer_with_sugared_types as super
512
513 method expr0 f expr =
514 match expr with
515 | Q.Match (_, e, pel) -> (
516 match QmlAstWatch.uncons_ifthenelse e pel with
517 | Some (if_, then_, else_) ->
518 pp f "@[<v>@[<2>if@ (%a)@]@ then %a@ else %a@]" self#reset#expr if_ self#expr then_ self#expr else_
519 | None ->
520 super#expr0 f expr
521 )
522 | Q.ExtendRecord (_, s, e1, e2) ->
523 let e2, fields = regroup_extend_record e2 in
524 let fields = (s, e1)::fields in
525 pp f "@[<4>{%a with@ %a}@]" self#under_record#expr e2 (pp_list ";@ " self#reset#bind_field) fields
526 | _ -> super#expr0 f expr
527
528 method binding f (i,e) =
529 pp f "@[<hv2>%a%a" self#ident i self#binding_expr e
530
531 method binding_expr f e =
532 match e with
533 | Q.Lambda (_, il, e) ->
534 pp f "(%a)%a" (pp_list ", " self#ident) il self#binding_expr e
535 | Q.Coerce (_, e, ty) ->
536 pp f " : %a =@ %a@]" self#ty ty self#expr e
537 | _ ->
538 pp f " = @ %a@]" self#expr e
539 end
540
541 (**
542 A printer for printing only the toplevel declarations.
543 *)
544 class declaration_printer =
545 object(self)
546 inherit opa_printer as super (* yeah, opa_printer is really super *)
547 method binding f (i, _) = self#ident f i
548 end
549
550 (**
551 Same than the standard printer, but with light identifiers.
552 *)
553 class light_ident_printer =
554 object
555 inherit opa_printer
556 method ident_to_string i = Ident.light_ident i
557 end
558
559 class very_light_ident_printer =
560 object
561 inherit opa_printer
562 method ident_to_string i = Ident.original_name i
563 end
564
565 let annotation_node_factory annot pp fmt ast =
566 Format.fprintf fmt "(%a : § %d)" pp ast (Annot.to_int (annot ast))
567
568 class annotation_printer =
569 object(self)
570 inherit base_printer_with_sugared_types
571 method expr_node fmt expr =
572 annotation_node_factory QmlAst.QAnnot.expr self#expr0 fmt expr
573 method pat_node fmt expr =
574 annotation_node_factory QmlAst.QAnnot.pat self#pat0 fmt expr
575 end
576
f0aca58d » fpessaux
2011-07-08 [feature] opatrack: Printer with source locations.
577
578
579 (* ************************************************************************** *)
580 (** {b Descr}: Prints an AST element and its source code location. Used by the
581 position printer below which is made available in opatrack via file
582 qmlTracker.ml.
583 {b Visibility}: Not exported outside this module. *)
584 (* ************************************************************************** *)
585 let position_node_factory pos pp fmt ast =
586 Format.fprintf fmt "(%a : § %a)" pp ast FilePos.pp (pos ast)
587
588
589
590 (* ************************************************************************** *)
591 (** {b Descr}: Printer decorating source code with positions of its elements.
592 {b Visibility}: Exported outside this module. *)
593 (* ************************************************************************** *)
594 class position_printer =
595 object(self)
596 inherit base_printer_with_sugared_types
597 method expr_node fmt expr =
598 position_node_factory QmlAst.Pos.expr self#expr0 fmt expr
599 method pat_node fmt expr =
600 position_node_factory QmlAst.Pos.pat self#pat0 fmt expr
601 end
602
603
604
fccc6851 » MLstate
2011-06-21 Initial open-source release
605 exception Bad_printer
606
607 (* you cannot create instances of these two printers
608 * because you need an annotmap to do so *)
609 class printer_with_type annotmap =
610 object (self)
611 inherit base_printer
612 method expr_node fmt expr =
613 match QmlAnnotMap.find_ty_opt (QmlAst.QAnnot.expr expr) annotmap with
614 | None -> raise Bad_printer
615 | Some ty -> Format.fprintf fmt "(%a : %a)" self#expr0 expr self#ty ty
616
617 method pat_node fmt pat =
618 match QmlAnnotMap.find_ty_opt (QmlAst.QAnnot.pat pat) annotmap with
619 | None -> raise Bad_printer
620 | Some ty -> Format.fprintf fmt "(%a : %a)" self#pat0 pat self#ty ty
621
622 method code f l =
623 try
624 pp f "@[<v>%a@]" (pp_list "@ @ " self#code_elt) l
625 with Bad_printer -> pp f "Stupid! printer_with_type does not work on this pass"
626
627 end
628
629 class printer_for_ei annotmap =
630 object (self)
631 inherit base_printer as super
632 method expr_node f expr =
633 let annot = QmlAst.QAnnot.expr expr in
634 match QmlAnnotMap.find_tsc_opt annot annotmap with
635 | None -> (
636 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
637 | None -> super#expr_node f expr
638 | Some tsc -> pp f "(%a :- %a)" self#expr0 expr self#tsc tsc
639 )
640 | Some tsc ->
641 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
642 | None -> pp f "(%a :+ %a)" self#expr0 expr self#tsc tsc
643 | Some tsc_inst ->
644 pp f "(%a :- %a :+ %a)" self#expr0 expr self#tsc tsc_inst self#tsc tsc
645
646 method pat_node f pat =
647 let annot = QmlAst.QAnnot.pat pat in
648 match QmlAnnotMap.find_tsc_opt annot annotmap with
649 | None -> (
650 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
651 | None -> super#pat_node f pat
652 | Some tsc -> pp f "(%a :- %a)" self#pat0 pat self#tsc tsc
653 )
654 | Some tsc ->
655 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
656 | None -> pp f "(%a :+ %a)" self#pat0 pat self#tsc tsc
657 | Some tsc_inst ->
658 pp f "(%a :- %a :+ %a)" self#pat0 pat self#tsc tsc_inst self#tsc tsc
659
660 end
661
662 class pp_value_restriction =
663 object
664 inherit opa_printer as super
665 val bound_tyvs = QmlTypeVars.TypeVarSet.empty
666 val bound_cols = QmlTypeVars.ColVarSet.empty
667 val bound_rows = QmlTypeVars.RowVarSet.empty
668 method typevar f v =
669 if QmlTypeVars.TypeVarSet.mem v bound_tyvs then super#typevar f v
670 else pp f "@{<bright>%a@}" super#typevar v
671 method colvar f v =
672 if QmlTypeVars.ColVarSet.mem v bound_cols then super#colvar f v
673 else pp f "@{<bright>%a@}" super#colvar v
674 method rowvar f v =
675 if QmlTypeVars.RowVarSet.mem v bound_rows then super#rowvar f v
676 else pp f "@{<bright>%a@}" super#rowvar v
677 method ty f = function
678 | Q.TypeForall (tyvs, rows, cols, t) ->
679 let self =
680 {< bound_tyvs = List.fold_left (fun acc v -> QmlTypeVars.TypeVarSet.add v acc) bound_tyvs tyvs;
681 bound_rows = List.fold_left (fun acc v -> QmlTypeVars.RowVarSet.add v acc) bound_rows rows;
682 bound_cols = List.fold_left (fun acc v -> QmlTypeVars.ColVarSet.add v acc) bound_cols cols;
683 >} in
684 self#scheme f tyvs rows cols t
685 | ty -> super#ty f ty
686 end
687
688 (** {6 Exporting an instance of each printer} *)
689
690 let pp_base = new base_printer
691 let pp_base_with_sugared_types = new base_printer_with_sugared_types
692 let pp = new opa_printer
693 let pp_light_ident = new light_ident_printer
694 let pp_very_light_ident = new very_light_ident_printer
695 let pp_declaration = new declaration_printer
696 let pp_annotation = new annotation_printer
f0aca58d » fpessaux
2011-07-08 [feature] opatrack: Printer with source locations.
697 let pp_position = new position_printer
fccc6851 » MLstate
2011-06-21 Initial open-source release
698 let pp_value_restriction = new pp_value_restriction
699
700 (**
701 {6 Not pretty printers}
702 *)
703
704 (**
705 Sexp printer
706 *)
707 let sexp_tyv f t = Format.pp_print_string f (QmlTypeVars.TypeVar.to_string t)
708 let sexp_rowv f t = Format.pp_print_string f (QmlTypeVars.RowVar.to_string t)
709 let sexp_colv f t = Format.pp_print_string f (QmlTypeVars.ColVar.to_string t)
710 let rec sexp_ty f = function
711 | Q.TypeConst Q.TyFloat -> Format.fprintf f "F"
712 | Q.TypeConst Q.TyInt -> Format.fprintf f "I"
713 | Q.TypeConst Q.TyNull -> Format.fprintf f "Null"
714 | Q.TypeConst Q.TyString -> Format.fprintf f "S"
715 | Q.TypeVar t -> Format.fprintf f "(V %a)" sexp_tyv t
716 | Q.TypeArrow (tyl,ty) ->
717 Format.fprintf f "(A ";
718 List.iter (fun ty -> sexp_ty f ty; Format.fprintf f " ") tyl;
719 sexp_ty f ty;
720 Format.fprintf f ")"
721 | Q.TypeRecord (Q.TyRow (fields,None)) ->
722 Format.fprintf f "(R1 ";
723 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
724 Format.fprintf f ")"
725 | Q.TypeRecord (Q.TyRow (fields,Some v)) ->
726 Format.fprintf f "(R2 ";
727 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
728 Format.fprintf f " %s)" (QmlTypeVars.RowVar.to_string v)
729 | Q.TypeSum (Q.TyCol (fieldss,None)) ->
730 Format.fprintf f "(S1";
731 List.iter
732 (fun fields ->
733 Format.fprintf f "(";
734 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
735 Format.fprintf f ")"
736 ) fieldss;
737 Format.fprintf f ")"
738 | Q.TypeSum (Q.TyCol (fieldss,Some v)) ->
739 Format.fprintf f "(S2";
740 List.iter
741 (fun fields ->
742 Format.fprintf f "(";
743 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
744 Format.fprintf f ")"
745 ) fieldss;
746 Format.fprintf f " %s)" (QmlTypeVars.ColVar.to_string v)
747 | Q.TypeSumSugar _ ->
748 assert false
749 | Q.TypeName (tyl,ident) ->
070e3a00 » BourgerieQuentin
2012-04-12 [fix] compiler: The original name is not adequate since is not uniq
750 Format.fprintf f "(N %s "
751 (try Ident.to_uniq_string ident with _ -> Q.TypeIdent.to_string ident);
fccc6851 » MLstate
2011-06-21 Initial open-source release
752 List.iter (sexp_ty f) tyl;
753 Format.fprintf f ")"
754 | Q.TypeAbstract ->
755 Format.fprintf f "Abs"
756 | Q.TypeForall (tyvl,rowl,coll,ty) ->
757 sexp_scheme f tyvl rowl coll ty
758
759 and sexp_scheme ?(tag="Forall") f tyvl rowl coll ty =
760 Format.fprintf f "(%s (" tag;
761 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.TypeVar.to_string tyv)) tyvl;
762 Format.fprintf f ") (";
763 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.RowVar.to_string tyv)) rowl;
764 Format.fprintf f ") (";
765 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.ColVar.to_string tyv)) coll;
766 Format.fprintf f ") ";
767 sexp_ty f ty;
768 Format.fprintf f ")"
769
770 let sexp_tsc f tsc =
771 let (quant,ty,()) = QmlGenericScheme.export_unsafe tsc in
772 let (vars, rvars, cvars) = QmlTypeVars.FreeVars.export_as_lists quant in
773 sexp_scheme ~tag:"Tsc" f vars rvars cvars ty
774
775 (** {6 Backward Compatibility} *)
776 (**
777 Until we clean this up
778 *)
779
780 let bw_ty = Format.sprintf "%a" pp#ty
781 let bw_expr = Format.sprintf "%a" pp#expr
782
783
784
785 (* ************************************************************************** *)
786 (** {b Descr}: Function to dump the content of a [QmlAst.annotmap]. This is
787 mostly for debug purpose and is really very verbose.
788 {b Visibility}: Exported outside this module. *)
789 (* ************************************************************************** *)
790 let debug_QmlAst_annotmap annotmap =
791 QmlAnnotMap.iteri
792 ~f_for_key:
793 (fun key -> Format.printf "Key: %s@." (Annot.to_string key))
794 ~f_for_ty:
795 (function
796 | None -> Format.printf " Type: -@."
797 | Some t -> Format.printf "@[ Type: %a@]@." pp#ty t)
798 ~f_for_tsc:
799 (function
800 | None -> Format.printf " Sch gen: -@."
801 | Some sch -> Format.printf "@[ Sch gen: %a@]@." pp#tsc sch)
802 ~f_for_tsc_inst:
803 (function
804 | None -> Format.printf " Sch inst: -@."
805 | Some sch -> Format.printf "@[ Sch inst: %a@]@." pp#tsc sch)
806 annotmap
Something went wrong with that request. Please try again.