Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 821 lines (723 sloc) 28.997 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
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
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
76 module Db = QmlAst.Db
fccc685 Initial open-source release
MLstate authored
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) =
2536662 Rudy Sicard [feature] closure serialisation: restrict to new @public_env directive
OpaOnWindowsNow authored
89 "@"^(QmlDirectives.to_string d)
fccc685 Initial open-source release
MLstate authored
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
327 method path f (el, knd) =
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
328 let pp_el fmt () = Format.fprintf fmt "%a" (pp_list "" self#path_elt) el in
329 match knd with
2b94068 Quentin Bourgerie [enhance] compiler/lib: (big) default value on bson unserialize + fix up...
BourgerieQuentin authored
330 | Q.Db.Update u -> pp f "%a <- %a //update" pp_el () (QmlAst.Db.pp_update self#expr) u
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
331 | _ ->
332 pp f "%s%a" (
333 match knd with
334 | Q.Db.Default -> "" | Q.Db.Option -> "?"
335 | Q.Db.Valpath -> "!" | Q.Db.Ref -> "@"
336 | Q.Db.Update _ -> assert false
337 ) pp_el ()
fccc685 Initial open-source release
MLstate authored
338
339 method path_elts f el =
340 pp f "%a" (pp_list "" self#path_elt) el
341
342 (*---------------------*)
343 (*---- expr printer ---*)
344 (*---------------------*)
345 method expr0 f = function
346 | (Q.Lambda _ | Q.Coerce _) as e when coerce -> pp f "(%a)" self#reset#expr0 e
347 | (Q.Lambda _) as e when comma -> pp f "(%a)" self#reset#expr0 e
348 | Q.LetIn _ | Q.LetRecIn _ as e when record -> pp f "(%a)" self#reset#expr0 e
349 | Q.Match _ | Q.Lambda _ | Q.LetIn _ | Q.LetRecIn _ as e when op -> pp f "(%a)" self#reset#expr0 e
350 | Q.Const (_, c) -> self#const f c
351 | Q.Ident (_, i) -> self#ident f i
352 | Q.LetIn (_, b, e) ->
353 pp f "@[<v>%a@ %a@]" (pp_list "@ " self#binding) b self#expr e
354 | Q.LetRecIn (_, iel, e) -> pp f "@[<v>rec %a@ %a@]" (pp_list "@ and " self#binding) iel self#expr e
355 | Q.Lambda (_, il, e) ->
356 pp f "@[<2>@[<h>%a@] ->@ %a@]" (pp_list ",@ " self#ident) il self#expr e
357 | Q.Apply (_, Q.Ident (_, s), [e1; e2]) as e when is_infix s ->
358 if op then pp f "(%a)" self#reset#expr0 e else
359 let name = Ident.original_name s in
360 pp f "%a %s %a" self#under_op#expr e1 name self#under_op#expr e2
361 | Q.Apply (_, e, el) ->
362 pp f "@[<2>%a(@,%a)@]" self#apply_expr e (pp_list ",@ " self#reset#under_comma#expr) el
363 | Q.Match (_, e, pel) ->
364 pp f "@[<v>@[<2>match@ %a@ with@]@ | %a@ end@]" self#expr e (pp_list "@ | " self#rule_) pel
365 | Q.Record (_, [ s, Q.Coerce (_, Q.Record (_, []), Q.TypeRecord (Q.TyRow ([], None))) ] ) -> pp f "{%s}" s
366 | Q.Record (_, sel) -> self#reset#under_record#record f sel
367 | Q.Dot (_, e, s) -> pp f "%a.%s" self#apply_expr e s
368 | Q.ExtendRecord (_, s, e1, e2) ->
369 pp f "@[<2>{%s = %a} ::@ %a@]" s self#expr e1 self#expr e2
370 | Q.Bypass (_, s) -> Format.pp_print_string f ("%%" ^ (BslKey.to_string s) ^ "%%")
371 | Q.Coerce (_, e,ty) -> pp f "%a : %a" self#under_coerce#expr e self#ty ty
372 | Q.Path (_, el, knd) -> self#path f (el, knd)
373 | Q.Directive (_, `module_, [e], _) -> pp f "{%a}" self#reset#expr e
374 | Q.Directive (_, dir, exprs, tys) -> self#directive f dir exprs tys
375 method bind_field fmt (f, d) = pp fmt "%s = %a" f self#under_record#expr d
376 method binding f (i, e) =
377 pp f "@[<hv2>%a =@ %a@]" self#ident i self#expr e
378 method expr f e =
379 self#expr_node f e
380 method apply_expr f = function
9ddf00d [fix] qmlPrint: less useless parenthesis around bypasses
Valentin Gatien-Baron authored
381 | Q.Bypass _
fccc685 Initial open-source release
MLstate authored
382 | Q.Directive _
383 | Q.Ident _
384 | Q.Apply _
385 | Q.Dot _ as e -> self#expr f e
386 | e -> pp f "(%a)" self#reset#expr e
387 method directive f variant exprs tys =
388 let variant_aux f var =
389 match var with
390 | `abstract_ty_arg (tyvars,rowvars,colvars) ->
391 pp f "@[<2>@@abstract_ty_arg(%a|%a|%a)@]"
392 (pp_list ",@ " self#under_arrow#typevar) tyvars
393 (pp_list ",@ " self#under_arrow#rowvar) rowvars
394 (pp_list ",@ " self#under_arrow#colvar) colvars
395 | `apply_ty_arg (tys,tyrows,tycols) ->
396 pp f "@[<2>@@apply_ty_arg(%a|%a|%a)@]"
397 (pp_list ",@ " self#under_arrow#ty) tys
398 (pp_list ",@ " self#under_arrow#tyrow) tyrows
399 (pp_list ",@ " self#under_arrow#tysum) tycols
400 | _ -> pp f"@[<2>%s@]" (directive var)
401 in
402 match exprs, tys with
403 | [], [] -> pp f "@[<2>%a@]" variant_aux variant
404 | _, [] ->
8ba7656 [fix] qmlPrint: printing more line breaks when printing long directives
Valentin Gatien-Baron authored
405 pp f "@[<2>%a(@,%a)@]" variant_aux variant (pp_list ",@ " self#reset#under_comma#expr) exprs
fccc685 Initial open-source release
MLstate authored
406 | _ ->
8ba7656 [fix] qmlPrint: printing more line breaks when printing long directives
Valentin Gatien-Baron authored
407 pp f "@[<2>%a(@,%a ;@ %a)@]" variant_aux variant
fccc685 Initial open-source release
MLstate authored
408 (pp_list ",@ " self#reset#under_comma#expr) exprs
409 (pp_list ",@ " self#reset#under_comma#ty) tys
410 method record f l =
411 match l with
412 | [] -> pp f "{}"
413 | _ ->
414 let is_tilde_field field =
415 let getvar = function
416 | Q.Ident (_, i) -> Some i
417 | _ -> None
418 in
419 self#is_tilde_field getvar field
420 in
421 if List.for_all is_tilde_field l
422 then
423 let pp_field f (field, _) = Format.pp_print_string f field in
424 pp f "@[<hv>~{ %a }@]" (pp_list "@, " pp_field) l
425 else
426 pp f "@[<hv>{ %a }@]" (pp_list " ;@ " self#record_binding) l
427
428 method record_binding f ((s, e) as expr) =
429 match e with
430 | Q.Record (_, [])
431 | Q.Coerce (_, Q.Record (_, []), _)
432 | Q.Directive (_, `coerce, [ Q.Record (_, []) ], _) ->
433 Format.pp_print_string f s
434 | _ ->
435 let getvar = function
436 | Q.Ident (_, i) -> Some i
437 | _ -> None
438 in
439 if self#is_tilde_field getvar expr
440 then
441 pp f "~%s" s
442 else
443 pp f "@[<2>%s =@ %a@]" s self#expr e
444
445 method rule_ f (p,e) =
446 pp f "@[<2>%a ->@ %a@]" self#pat p self#expr e
447 method path_elt f =
448 function
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
449 | Db.FldKey (s) -> pp f "/%s" s
450 | Db.ExprKey e -> pp f "[@[<hv>%a@]]" self#reset#expr e
451 | Db.NewKey -> pp f "[?]"
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
452 | Db.Query _ -> pp f "query TODO"
fccc685 Initial open-source release
MLstate authored
453
454 (*---------------------*)
455 (*---- code printer ---*)
456 (*---------------------*)
457 method code_elt f elt =
458 let newval rec_ iel =
459 pp f "@[<v>%t%s%a%t@]"
460 (fun f -> match iel with [_] -> () | _ -> pp f "/* group start */@ ")
461 (if rec_ then "rec " else "")
462 (if rec_
463 then (pp_list "@ and " self#binding)
464 else (pp_list "@ " self#binding)
465 ) iel
466 (fun f -> match iel with [_] -> () | _ -> pp f "@ /* group end */")
467 in
468 match elt with
469 | Q.Database (_, ident, _p, opts) -> pp f "@[<h>database /* %a */@ %s@]" self#ident ident (Q.Db.options_to_string opts)
470 | Q.NewDbValue (_, def) -> pp f "@[<hv2>%a@]" (Q.Db.print_def self#expr self#ty) def
471 | Q.NewType (_, l) -> pp f "@[<v>%a@]" (pp_list "@ " self#typedef) l
472 | Q.NewVal (_, iel) -> newval false iel
473 | Q.NewValRec (_, iel) -> newval true iel
474
475 method code f l =
476 pp f "@[<v>%a@]" (pp_list "@ @ " self#code_elt) l
477 end
478
479 (** {6 Other mode of printing} *)
480
481 class base_printer_with_sugared_types =
482 object (self)
483 inherit base_printer as super
484
485 (* Variables scope for type variables *)
486 val typevar_scope = QmlTypeVars.TypeVarPrint.new_scope ()
487 val rowvar_scope = QmlTypeVars.RowVarPrint.new_scope ()
488 val colvar_scope = QmlTypeVars.ColVarPrint.new_scope ()
489
490 method reset_typevars =
491 QmlTypeVars.TypeVarPrint.reset typevar_scope ;
492 QmlTypeVars.RowVarPrint.reset rowvar_scope ;
493 QmlTypeVars.ColVarPrint.reset colvar_scope ;
494 ()
495
496 method! typevar f t = QmlTypeVars.TypeVarPrint.pp typevar_scope f t
497 method! quant_rowvar f t = QmlTypeVars.RowVarPrint.pp rowvar_scope f t
498 method! quant_colvar f t = QmlTypeVars.ColVarPrint.pp colvar_scope f t
499 method! rowvar f _ = Format.pp_print_string f "..."
500 method! colvar f _ = Format.pp_print_string f "..."
501
502 method! scheme f vars rvars cvars ty =
503 QmlTypeVars.TypeVarPrint.push typevar_scope ;
504 QmlTypeVars.RowVarPrint.push rowvar_scope ;
505 QmlTypeVars.ColVarPrint.push colvar_scope ;
506 super#scheme f vars rvars cvars ty ;
507 QmlTypeVars.TypeVarPrint.pop typevar_scope ;
508 QmlTypeVars.RowVarPrint.pop rowvar_scope ;
509 QmlTypeVars.ColVarPrint.pop colvar_scope ;
510 ()
511
512 method ty_new_scope f ty =
513 self#reset_typevars;
514 self#ty f ty
515
516 method! code_elt f elt =
517 self#reset_typevars;
518 super#code_elt f elt
519 end
520
521 (**
522 The default pretty printer
523 *)
524 class opa_printer =
525 object (self)
526 inherit base_printer_with_sugared_types as super
527
528 method expr0 f expr =
529 match expr with
530 | Q.Match (_, e, pel) -> (
531 match QmlAstWatch.uncons_ifthenelse e pel with
532 | Some (if_, then_, else_) ->
533 pp f "@[<v>@[<2>if@ (%a)@]@ then %a@ else %a@]" self#reset#expr if_ self#expr then_ self#expr else_
534 | None ->
535 super#expr0 f expr
536 )
537 | Q.ExtendRecord (_, s, e1, e2) ->
538 let e2, fields = regroup_extend_record e2 in
539 let fields = (s, e1)::fields in
540 pp f "@[<4>{%a with@ %a}@]" self#under_record#expr e2 (pp_list ";@ " self#reset#bind_field) fields
541 | _ -> super#expr0 f expr
542
543 method binding f (i,e) =
544 pp f "@[<hv2>%a%a" self#ident i self#binding_expr e
545
546 method binding_expr f e =
547 match e with
548 | Q.Lambda (_, il, e) ->
549 pp f "(%a)%a" (pp_list ", " self#ident) il self#binding_expr e
550 | Q.Coerce (_, e, ty) ->
551 pp f " : %a =@ %a@]" self#ty ty self#expr e
552 | _ ->
553 pp f " = @ %a@]" self#expr e
554 end
555
556 (**
557 A printer for printing only the toplevel declarations.
558 *)
559 class declaration_printer =
560 object(self)
561 inherit opa_printer as super (* yeah, opa_printer is really super *)
562 method binding f (i, _) = self#ident f i
563 end
564
565 (**
566 Same than the standard printer, but with light identifiers.
567 *)
568 class light_ident_printer =
569 object
570 inherit opa_printer
571 method ident_to_string i = Ident.light_ident i
572 end
573
574 class very_light_ident_printer =
575 object
576 inherit opa_printer
577 method ident_to_string i = Ident.original_name i
578 end
579
580 let annotation_node_factory annot pp fmt ast =
581 Format.fprintf fmt "(%a : § %d)" pp ast (Annot.to_int (annot ast))
582
583 class annotation_printer =
584 object(self)
585 inherit base_printer_with_sugared_types
586 method expr_node fmt expr =
587 annotation_node_factory QmlAst.QAnnot.expr self#expr0 fmt expr
588 method pat_node fmt expr =
589 annotation_node_factory QmlAst.QAnnot.pat self#pat0 fmt expr
590 end
591
f0aca58 fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
592
593
594 (* ************************************************************************** *)
595 (** {b Descr}: Prints an AST element and its source code location. Used by the
596 position printer below which is made available in opatrack via file
597 qmlTracker.ml.
598 {b Visibility}: Not exported outside this module. *)
599 (* ************************************************************************** *)
600 let position_node_factory pos pp fmt ast =
601 Format.fprintf fmt "(%a : § %a)" pp ast FilePos.pp (pos ast)
602
603
604
605 (* ************************************************************************** *)
606 (** {b Descr}: Printer decorating source code with positions of its elements.
607 {b Visibility}: Exported outside this module. *)
608 (* ************************************************************************** *)
609 class position_printer =
610 object(self)
611 inherit base_printer_with_sugared_types
612 method expr_node fmt expr =
613 position_node_factory QmlAst.Pos.expr self#expr0 fmt expr
614 method pat_node fmt expr =
615 position_node_factory QmlAst.Pos.pat self#pat0 fmt expr
616 end
617
618
619
fccc685 Initial open-source release
MLstate authored
620 exception Bad_printer
621
622 (* you cannot create instances of these two printers
623 * because you need an annotmap to do so *)
624 class printer_with_type annotmap =
625 object (self)
626 inherit base_printer
627 method expr_node fmt expr =
628 match QmlAnnotMap.find_ty_opt (QmlAst.QAnnot.expr expr) annotmap with
629 | None -> raise Bad_printer
630 | Some ty -> Format.fprintf fmt "(%a : %a)" self#expr0 expr self#ty ty
631
632 method pat_node fmt pat =
633 match QmlAnnotMap.find_ty_opt (QmlAst.QAnnot.pat pat) annotmap with
634 | None -> raise Bad_printer
635 | Some ty -> Format.fprintf fmt "(%a : %a)" self#pat0 pat self#ty ty
636
637 method code f l =
638 try
639 pp f "@[<v>%a@]" (pp_list "@ @ " self#code_elt) l
640 with Bad_printer -> pp f "Stupid! printer_with_type does not work on this pass"
641
642 end
643
644 class printer_for_ei annotmap =
645 object (self)
646 inherit base_printer as super
647 method expr_node f expr =
648 let annot = QmlAst.QAnnot.expr expr in
649 match QmlAnnotMap.find_tsc_opt annot annotmap with
650 | None -> (
651 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
652 | None -> super#expr_node f expr
653 | Some tsc -> pp f "(%a :- %a)" self#expr0 expr self#tsc tsc
654 )
655 | Some tsc ->
656 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
657 | None -> pp f "(%a :+ %a)" self#expr0 expr self#tsc tsc
658 | Some tsc_inst ->
659 pp f "(%a :- %a :+ %a)" self#expr0 expr self#tsc tsc_inst self#tsc tsc
660
661 method pat_node f pat =
662 let annot = QmlAst.QAnnot.pat pat in
663 match QmlAnnotMap.find_tsc_opt annot annotmap with
664 | None -> (
665 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
666 | None -> super#pat_node f pat
667 | Some tsc -> pp f "(%a :- %a)" self#pat0 pat self#tsc tsc
668 )
669 | Some tsc ->
670 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
671 | None -> pp f "(%a :+ %a)" self#pat0 pat self#tsc tsc
672 | Some tsc_inst ->
673 pp f "(%a :- %a :+ %a)" self#pat0 pat self#tsc tsc_inst self#tsc tsc
674
675 end
676
677 class pp_value_restriction =
678 object
679 inherit opa_printer as super
680 val bound_tyvs = QmlTypeVars.TypeVarSet.empty
681 val bound_cols = QmlTypeVars.ColVarSet.empty
682 val bound_rows = QmlTypeVars.RowVarSet.empty
683 method typevar f v =
684 if QmlTypeVars.TypeVarSet.mem v bound_tyvs then super#typevar f v
685 else pp f "@{<bright>%a@}" super#typevar v
686 method colvar f v =
687 if QmlTypeVars.ColVarSet.mem v bound_cols then super#colvar f v
688 else pp f "@{<bright>%a@}" super#colvar v
689 method rowvar f v =
690 if QmlTypeVars.RowVarSet.mem v bound_rows then super#rowvar f v
691 else pp f "@{<bright>%a@}" super#rowvar v
692 method ty f = function
693 | Q.TypeForall (tyvs, rows, cols, t) ->
694 let self =
695 {< bound_tyvs = List.fold_left (fun acc v -> QmlTypeVars.TypeVarSet.add v acc) bound_tyvs tyvs;
696 bound_rows = List.fold_left (fun acc v -> QmlTypeVars.RowVarSet.add v acc) bound_rows rows;
697 bound_cols = List.fold_left (fun acc v -> QmlTypeVars.ColVarSet.add v acc) bound_cols cols;
698 >} in
699 self#scheme f tyvs rows cols t
700 | ty -> super#ty f ty
701 end
702
703 (** {6 Exporting an instance of each printer} *)
704
705 let pp_base = new base_printer
706 let pp_base_with_sugared_types = new base_printer_with_sugared_types
707 let pp = new opa_printer
708 let pp_light_ident = new light_ident_printer
709 let pp_very_light_ident = new very_light_ident_printer
710 let pp_declaration = new declaration_printer
711 let pp_annotation = new annotation_printer
f0aca58 fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
712 let pp_position = new position_printer
fccc685 Initial open-source release
MLstate authored
713 let pp_value_restriction = new pp_value_restriction
714
715 (**
716 {6 Not pretty printers}
717 *)
718
719 (**
720 Sexp printer
721 *)
722 let sexp_tyv f t = Format.pp_print_string f (QmlTypeVars.TypeVar.to_string t)
723 let sexp_rowv f t = Format.pp_print_string f (QmlTypeVars.RowVar.to_string t)
724 let sexp_colv f t = Format.pp_print_string f (QmlTypeVars.ColVar.to_string t)
725 let rec sexp_ty f = function
726 | Q.TypeConst Q.TyFloat -> Format.fprintf f "F"
727 | Q.TypeConst Q.TyInt -> Format.fprintf f "I"
728 | Q.TypeConst Q.TyNull -> Format.fprintf f "Null"
729 | Q.TypeConst Q.TyString -> Format.fprintf f "S"
730 | Q.TypeVar t -> Format.fprintf f "(V %a)" sexp_tyv t
731 | Q.TypeArrow (tyl,ty) ->
732 Format.fprintf f "(A ";
733 List.iter (fun ty -> sexp_ty f ty; Format.fprintf f " ") tyl;
734 sexp_ty f ty;
735 Format.fprintf f ")"
736 | Q.TypeRecord (Q.TyRow (fields,None)) ->
737 Format.fprintf f "(R1 ";
738 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
739 Format.fprintf f ")"
740 | Q.TypeRecord (Q.TyRow (fields,Some v)) ->
741 Format.fprintf f "(R2 ";
742 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
743 Format.fprintf f " %s)" (QmlTypeVars.RowVar.to_string v)
744 | Q.TypeSum (Q.TyCol (fieldss,None)) ->
745 Format.fprintf f "(S1";
746 List.iter
747 (fun fields ->
748 Format.fprintf f "(";
749 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
750 Format.fprintf f ")"
751 ) fieldss;
752 Format.fprintf f ")"
753 | Q.TypeSum (Q.TyCol (fieldss,Some v)) ->
754 Format.fprintf f "(S2";
755 List.iter
756 (fun fields ->
757 Format.fprintf f "(";
758 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
759 Format.fprintf f ")"
760 ) fieldss;
761 Format.fprintf f " %s)" (QmlTypeVars.ColVar.to_string v)
762 | Q.TypeSumSugar _ ->
763 assert false
764 | Q.TypeName (tyl,ident) ->
765 Format.fprintf f "(N %s " (Q.TypeIdent.to_string ident);
766 List.iter (sexp_ty f) tyl;
767 Format.fprintf f ")"
768 | Q.TypeAbstract ->
769 Format.fprintf f "Abs"
770 | Q.TypeForall (tyvl,rowl,coll,ty) ->
771 sexp_scheme f tyvl rowl coll ty
772
773 and sexp_scheme ?(tag="Forall") f tyvl rowl coll ty =
774 Format.fprintf f "(%s (" tag;
775 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.TypeVar.to_string tyv)) tyvl;
776 Format.fprintf f ") (";
777 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.RowVar.to_string tyv)) rowl;
778 Format.fprintf f ") (";
779 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.ColVar.to_string tyv)) coll;
780 Format.fprintf f ") ";
781 sexp_ty f ty;
782 Format.fprintf f ")"
783
784 let sexp_tsc f tsc =
785 let (quant,ty,()) = QmlGenericScheme.export_unsafe tsc in
786 let (vars, rvars, cvars) = QmlTypeVars.FreeVars.export_as_lists quant in
787 sexp_scheme ~tag:"Tsc" f vars rvars cvars ty
788
789 (** {6 Backward Compatibility} *)
790 (**
791 Until we clean this up
792 *)
793
794 let bw_ty = Format.sprintf "%a" pp#ty
795 let bw_expr = Format.sprintf "%a" pp#expr
796
797
798
799 (* ************************************************************************** *)
800 (** {b Descr}: Function to dump the content of a [QmlAst.annotmap]. This is
801 mostly for debug purpose and is really very verbose.
802 {b Visibility}: Exported outside this module. *)
803 (* ************************************************************************** *)
804 let debug_QmlAst_annotmap annotmap =
805 QmlAnnotMap.iteri
806 ~f_for_key:
807 (fun key -> Format.printf "Key: %s@." (Annot.to_string key))
808 ~f_for_ty:
809 (function
810 | None -> Format.printf " Type: -@."
811 | Some t -> Format.printf "@[ Type: %a@]@." pp#ty t)
812 ~f_for_tsc:
813 (function
814 | None -> Format.printf " Sch gen: -@."
815 | Some sch -> Format.printf "@[ Sch gen: %a@]@." pp#tsc sch)
816 ~f_for_tsc_inst:
817 (function
818 | None -> Format.printf " Sch inst: -@."
819 | Some sch -> Format.printf "@[ Sch inst: %a@]@." pp#tsc sch)
820 annotmap
Something went wrong with that request. Please try again.