Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 903 lines (805 sloc) 32.369 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
76
77 (* -- *)
78
79 (**
80 In opa, string can contains ["an acces to a {variable}"].
81 So, any char ['{'] from a row string should be escaped.
82 *)
83 let escaped_string s =
84 let s = String.escaped s in
85 String.replace s "{" "\\{"
86
87 (*
88 TODO: if possible (no problems of cyclic dependancies,
89 put this function in qmlDirectives.ml,
90 and remove the duplication of '@' as first char.
91 *)
92 let directive (d:QmlAst.qml_directive) =
93 match d with
94 | `deprecated -> "@deprecated"
95 | `todo -> "@todo"
96 | `at_init -> "@at_init"
97 | `module_ -> "@module"
98 | `module_field_lifting -> "@module_field_lifting"
99 | `coerce -> "@coerce"
100 | `nonexpansive -> "@nonexpansive"
101 | `unsafe_cast -> "@unsafe_cast"
102 | `opensums -> "@opensums"
103 | `openrecord -> "@openrecord"
104 | `assert_ -> "@assert"
105 | `typeof -> "@typeof"
106 | `atomic -> "@atomic"
107 | `immovable -> "@immovable"
108 | `thread_context -> "@thread_context"
109 | `with_thread_context -> "@with_thread_context"
110 | `js_ident -> "@js_ident"
111 | `throw -> "@throw"
112 | `catch -> "@catch"
113 | `spawn -> "@spawn"
114 | `wait -> "@wait"
115 | `callcc -> "@callcc"
116 | `restricted_bypass pass -> "@restricted_bypass["^ pass ^ "]"
117 | `fail -> "@fail"
118 | `create_lazy_record -> "@create_lazy_record"
119 | `warncoerce -> "@warncoerce"
120 | `apply_ty_arg _ -> "@apply_ty_arg _"
121 | `abstract_ty_arg _ -> "@abstract_ty_arg _"
122 | `closure_create _ -> "@closure_create"
123 | `closure_apply -> "@closure_apply"
124 | `closure_create_no_function _ -> "@closure_create_no_function"
125 | `closure_define_function _ -> "@closure_define_function"
126 | `ajax_publish b -> Printf.sprintf "@ajax_publish(%s)" (match b with `sync -> "`sync" | `async -> "`async")
127 | `ajax_call b -> Printf.sprintf "@ajax_call(%s)" (match b with `sync -> "`sync" | `async -> "`async")
128 | `comet_publish -> "@comet_publish"
129 | `comet_call -> "@comet_call"
130 | `insert_server_value i -> Printf.sprintf "@insert_server_value(%s)" (Ident.to_string i)
131 | `doctype _ -> "@doctype"
132 | `hybrid_value -> "@hybrid_value"
133 | `backend_ident s -> Printf.sprintf "@backend_ident[%s]" s
134 | `tracker _ -> "@track"
135 | `expand _ -> "@expand"
136 | `fun_action None -> "@fun_action"
137 | `fun_action (Some Q.Client_id) -> "@fun_action[Client_id]"
138 | `fun_action (Some Q.Deserialize) -> "@fun_action[Deserialize]"
139 | `cps_stack_lambda _ -> "@cps_stack_lambda"
140 | `cps_stack_apply _ -> "@cps_stack_apply"
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
141 | `async -> "@async"
fccc685 Initial open-source release
MLstate authored
142 | `sliced_expr -> "@sliced_expr"
143 | `may_cps -> "@may_cps"
144 | `stringifier -> "@stringifier"
145 | `comparator -> "@comparator"
146 | `serializer -> "@serializer"
147 | `xmlizer -> "@xmlizer"
148 | `llarray -> "@llarray"
149 | `specialize variant -> Printf.sprintf "@specialize%s" (match variant with `strict -> "_strict" | `polymorphic -> "")
150 | `partial_apply None -> "@partial_apply"
151 | `partial_apply (Some i) -> Printf.sprintf "@partial_apply[misssing:%d]" i
152 | `full_apply n -> Printf.sprintf "@full_apply[env %d]" n
08f3271 [fix] slicer: wrong slicing of nested local functions
Valentin Gatien-Baron authored
153 | `lifted_lambda (n,l) ->
154 Format.sprintf "@@lifted_lambda[env %d,[%a]]"
155 n
156 (Format.pp_list "@ " (fun f i -> Format.pp_print_string f (Ident.to_string i))) l
fccc685 Initial open-source release
MLstate authored
157 | `tagged_string (s, kind) ->
158 Printf.sprintf "@tagged_string[%S, %s]" s
159 (match kind with
160 | Q.Rpc_use -> "rpc_use"
161 | Q.Rpc_def -> "rpc_def"
162 | Q.Type_def -> "type_def"
163 | Q.Type_use -> "type_use"
164 | Q.Client_closure_use -> "client_closure_use")
165 | `apply_cont -> "@apply_cont"
166 | `recval -> "@recval"
167 | `side_annotation a -> (
168 match a with
169 | `server -> "@server"
170 | `client -> "@client"
171 | `both -> "@both"
172 | `prefer_server -> "@prefer_server"
173 | `prefer_client -> "@prefer_client"
174 | `prefer_both -> "@prefer_both"
175 | `both_implem -> "@both_implem"
176 )
177 | `visibility_annotation `private_ -> "@server_private"
178 | `visibility_annotation (`public `sync) -> "@publish"
179 | `visibility_annotation (`public `async) -> "@publish_async"
180 | `visibility_annotation (`public `funaction) -> "@publish_funaction"
181
182 (* ************************************************************************** *)
183 (** {b Descr}: Returns the string corresponding to a type definition
184 visibility suitable to be printed *before* the "type" token of a type
185 definition pretty print string.
186 {b Visibility}: Not exported outside this module. *)
187 (* ************************************************************************** *)
188 let type_def_visibility = function
189 | Q.TDV_public -> ""
190 | Q.TDV_abstract _ -> "@abstract "
191 | Q.TDV_private _ -> "@private "
192
193
194
195 let pp = Format.fprintf
196 let pp_list = Format.pp_list
197
198 let regroup_patfield = function
199 | Q.PatRecord (_, fields, rowvar) ->
200 fields, rowvar = `open_
201 | _ -> assert false
202 let rec regroup_extend_record ?(acc=[]) = function
203 | Q.ExtendRecord (_, f, d, r) -> regroup_extend_record ~acc:((f,d) :: acc) r
204 | e -> e, List.rev acc
205 let is_infix s = Ident.is_operator s
206
207 class base_printer =
208 object (self)
209
210 (* handling of priorities
211 * when [op] is true, we are under an operator
212 * when [arrow] is true, we are on the lhs of an arrow
213 * when [amper] is true, we are just under a '&'
214 * when [comma] is true, we are just inside a tuple or a lambda binding
215 * when [record] is true, we are just under a record binding
216 *)
217 val op = false
218 val arrow = false
219 val amper = false
220 val comma = false
221 val record = false
222 val coerce = false
223
224 method reset =
225 {<
226 op = false;
227 arrow = false;
228 amper = false;
229 comma = false;
230 record = false;
231 coerce = false;
232 >}
233
234 method under_op = {< op = true >}
235 method under_arrow = {< arrow = true >}
236 method under_amper = {< amper = true >}
237 method under_comma = {< comma = true >}
238 method under_record = {< record = true >}
239 method under_coerce = {< coerce = true >}
240
241 (* annot printer *)
242 method expr_node fmt expr =
243 self#expr0 fmt expr
244
245 method pat_node fmt pat =
246 self#pat0 fmt pat
247
248 method ident_to_string i = Ident.opa_syntax i
249 method ident f i = Format.pp_print_string f (self#ident_to_string i)
250
251 (*--------------------*)
252 (*--- type printer ---*)
253 (*--------------------*)
254 method ty f = function
255 | Q.TypeArrow _ as t when comma -> pp f "(%a)" self#reset#ty t
256 | Q.TypeArrow _ as t when arrow -> pp f "(%a)" self#reset#ty t
257 | Q.TypeForall _ as t when arrow || comma -> pp f "(%a)" self#reset#ty t
258 | Q.TypeConst const -> Format.pp_print_string f (Q.Const.string_of_ty const)
259 | Q.TypeVar typevar -> self#typevar f typevar
260 | Q.TypeArrow (lty1, ty2) -> pp f "@[<2>%a ->@ %a@]" (pp_list ",@ " self#under_arrow#ty) lty1 self#under_arrow#ty ty2
261 | Q.TypeRecord row -> self#reset#tyrow f row
262 | Q.TypeSum ty_col -> self#tysum f ty_col
263 | Q.TypeSumSugar tyl -> pp f "@[%a@]" (pp_list "@ /@ " self#ty) tyl
264 | Q.TypeName ([],t) -> self#typeident f t
265 | Q.TypeName (tyl,t) -> pp f "@[<2>%a(%a)@]" self#typeident t (pp_list ",@ " self#reset#ty) tyl
266 | Q.TypeAbstract -> pp f "external"
267 | Q.TypeForall (tyvl,rowl,coll,ty) -> self#scheme f tyvl rowl coll ty
268 method typeident f t = pp f "%s" (Q.TypeIdent.to_printable_string t)
269 method typevar f t = Format.pp_print_string f (QmlTypeVars.TypeVar.to_string t)
270 method quant_colvar f t = Format.pp_print_string f (QmlTypeVars.ColVar.to_string t)
271 method quant_rowvar f t = Format.pp_print_string f (QmlTypeVars.RowVar.to_string t)
272 method colvar = self#quant_colvar
273 method rowvar = self#quant_rowvar
274 method tyrow f (Q.TyRow (fields,rowvar)) =
275 pp f "@[<hv2>{%a%t}@]"
276 (pp_list ";@ " self#tyrow_binding) fields
277 (fun f ->
278 match rowvar with
279 | None -> ()
280 | Some v -> Format.fprintf f "%s%a" (if fields = [] then "" else "; ") self#rowvar v)
281
282 (*
283 Can be overwritten in a class having a gamma, if needed
284 *)
285 method is_type_void ty =
286 match ty with
287 | Q.TypeRecord (Q.TyRow ([], None))
288 | Q.TypeSum (Q.TyCol ([ [ ] ], None)) ->
289 true
290 | _ -> false
291
292 method tyrow_binding f (s, ty) =
293 if self#is_type_void ty
294 then
295 Format.pp_print_string f s
296 else
297 pp f "@[<h>%s :@ %a@]" s self#ty ty
298
299 method tycol = self#tysum
300 method tysum f (Q.TyCol (fl, colvar)) =
301 (* Attention, if the sum type is closed and contains no row (i.e. a trivial
302 sum type with no possible cases), the printed type would be an empty
303 string, which would be very confusing ! So, manually take care of this
304 case. *)
305 if (List.length fl = 0) && colvar = None then
306 pp f "<empty sum type>"
307 else
308 pp f "@[<2>%a%t@]"
309 (pp_list "@ /@ " (fun f -> pp f "@[{%a}@]" (pp_list ";@ " self#tyrow_binding))) fl
310 (fun f ->
311 match colvar with
312 | None -> ()
313 | Some v -> pp f "@ /@ %a" self#colvar v)
314
315 method typedef f tdef =
316 let visibility_str = type_def_visibility tdef.Q.ty_def_visibility in
317 match tdef.Q.ty_def_params with
318 | [] ->
319 pp f "@[<2>%stype %a =@ %a@]"
320 visibility_str
321 self#typeident tdef.Q.ty_def_name self#ty tdef.Q.ty_def_body
322 | _ ->
323 pp f "@[<2>%stype %a(%a) =@ %a@]"
324 visibility_str
325 self#typeident tdef.Q.ty_def_name
326 (pp_list ",@ " self#typevar) tdef.Q.ty_def_params
327 self#ty tdef.Q.ty_def_body
328
329 method scheme f vars rvars cvars ty =
330 if rvars = [] && cvars = [] then
331 pp f "@[<2>forall(@[<h>%a@]).@ %a@]"
332 (pp_list ",@ " self#typevar) vars
333 self#ty ty
334 else
335 pp f "@[<2>forall(@[<h>%a,@ rows:%a,@ cols:%a@]).@ %a@]"
336 (pp_list ",@ " self#typevar) vars
337 (pp_list ",@ " self#rowvar) rvars
338 (pp_list ",@ " self#colvar) cvars
339 self#ty ty
340
341 method tsc f tsc =
342 let (quant,ty,()) = QmlGenericScheme.export_unsafe tsc in
343 let (vars, rvars, cvars) = QmlTypeVars.FreeVars.export_as_lists quant in
344 self#scheme f vars rvars cvars ty
345
346 (*---------------------*)
347 (*-- pattern printer --*)
348 (*---------------------*)
349 method is_tilde_field : 'a. ('a -> Ident.t option) -> string * 'a -> bool =
350 (fun getvar (field, pat) ->
351 match getvar pat with
352 | Some ident ->
353 let ident = self#ident_to_string ident in
354 String.compare field ident = 0
355 | None -> false
356 )
357
358 method pat_record_binding f ((s, p) as pat) =
359 match p with
360 | Q.PatRecord (_, [], `closed)
361 | Q.PatCoerce (_, Q.PatRecord (_, [], `closed), _)
362 ->
363 Format.pp_print_string f s
364 | _ ->
365 let getvar = function
366 | Q.PatVar (_, i) -> Some i
367 | _ -> None
368 in
369 if self#is_tilde_field getvar pat
370 then
371 pp f "~%s" s
372 else
373 pp f "@[<h>%s =@ %a@]" s self#pat p
374
375 method pat_record f fields rowvar =
376 match fields with
377 | [] ->
378 if rowvar = `open_
379 then
380 Format.pp_print_string f "{ ... }"
381 else
382 Format.pp_print_string f "{}"
383 | _ ->
384 let rowvar = if rowvar = `open_ then " ; ..." else "" in
385 let is_tilde_field field =
386 let getvar = function
387 | Q.PatVar (_, i) -> Some i
388 | _ -> None
389 in
390 self#is_tilde_field getvar field
391 in
392 if List.for_all is_tilde_field fields
393 then
394 let pp_field f (field, _) = Format.pp_print_string f field in
395 pp f "@[<hv2>~{ %a%s }@]"
396 (pp_list "@, " pp_field) fields
397 rowvar
398 else
399 pp f "@[<hv2>{ %a%s }@]"
400 (pp_list " ;@ " self#pat_record_binding) fields
401 rowvar
402
403 method pat0 f = function
404 | Q.PatRecord (_, fields, rowvar) -> self#pat_record f fields rowvar
405 | Q.PatConst (_, Q.String s) -> Format.fprintf f "\"%s\"" (escaped_string s)
406 | Q.PatConst (_, const) -> Format.pp_print_string f (Q.Const.string_of_expr const)
407 | Q.PatVar (_, i) -> self#ident f i
408 | Q.PatAny _ -> pp f "_"
409 | Q.PatCoerce (_, p, ty) -> pp f "(@[<2>%a :@ %a@])" self#pat p self#ty ty
410 | Q.PatAs (_, p, i) -> pp f "@[<2>%a as %a@]" self#pat p self#ident i
411 method pat f v =
412 self#pat_node f v
413
414 method const f = function
415 | Q.String s -> Format.fprintf f "\"%s\"" (escaped_string s)
416 | c -> Format.pp_print_string f (Q.Const.string_of_expr c)
417
418 method path f (el, knd) =
419 pp f "%s%a" (Q.Db.path_kind_to_string knd) (pp_list "" self#path_elt) el
420
421 method path_elts f el =
422 pp f "%a" (pp_list "" self#path_elt) el
423
424 (*---------------------*)
425 (*---- expr printer ---*)
426 (*---------------------*)
427 method expr0 f = function
428 | (Q.Lambda _ | Q.Coerce _) as e when coerce -> pp f "(%a)" self#reset#expr0 e
429 | (Q.Lambda _) as e when comma -> pp f "(%a)" self#reset#expr0 e
430 | Q.LetIn _ | Q.LetRecIn _ as e when record -> pp f "(%a)" self#reset#expr0 e
431 | Q.Match _ | Q.Lambda _ | Q.LetIn _ | Q.LetRecIn _ as e when op -> pp f "(%a)" self#reset#expr0 e
432 | Q.Const (_, c) -> self#const f c
433 | Q.Ident (_, i) -> self#ident f i
434 | Q.LetIn (_, b, e) ->
435 pp f "@[<v>%a@ %a@]" (pp_list "@ " self#binding) b self#expr e
436 | Q.LetRecIn (_, iel, e) -> pp f "@[<v>rec %a@ %a@]" (pp_list "@ and " self#binding) iel self#expr e
437 | Q.Lambda (_, il, e) ->
438 pp f "@[<2>@[<h>%a@] ->@ %a@]" (pp_list ",@ " self#ident) il self#expr e
439 | Q.Apply (_, Q.Ident (_, s), [e1; e2]) as e when is_infix s ->
440 if op then pp f "(%a)" self#reset#expr0 e else
441 let name = Ident.original_name s in
442 pp f "%a %s %a" self#under_op#expr e1 name self#under_op#expr e2
443 | Q.Apply (_, e, el) ->
444 pp f "@[<2>%a(@,%a)@]" self#apply_expr e (pp_list ",@ " self#reset#under_comma#expr) el
445 | Q.Match (_, e, pel) ->
446 pp f "@[<v>@[<2>match@ %a@ with@]@ | %a@ end@]" self#expr e (pp_list "@ | " self#rule_) pel
447 | Q.Record (_, [ s, Q.Coerce (_, Q.Record (_, []), Q.TypeRecord (Q.TyRow ([], None))) ] ) -> pp f "{%s}" s
448 | Q.Record (_, sel) -> self#reset#under_record#record f sel
449 | Q.Dot (_, e, s) -> pp f "%a.%s" self#apply_expr e s
450 | Q.ExtendRecord (_, s, e1, e2) ->
451 pp f "@[<2>{%s = %a} ::@ %a@]" s self#expr e1 self#expr e2
452 | Q.Bypass (_, s) -> Format.pp_print_string f ("%%" ^ (BslKey.to_string s) ^ "%%")
453 | Q.Coerce (_, e,ty) -> pp f "%a : %a" self#under_coerce#expr e self#ty ty
454 | Q.Path (_, el, knd) -> self#path f (el, knd)
455 | Q.Directive (_, `module_, [e], _) -> pp f "{%a}" self#reset#expr e
456 | Q.Directive (_, dir, exprs, tys) -> self#directive f dir exprs tys
457 method bind_field fmt (f, d) = pp fmt "%s = %a" f self#under_record#expr d
458 method binding f (i, e) =
459 pp f "@[<hv2>%a =@ %a@]" self#ident i self#expr e
460 method expr f e =
461 self#expr_node f e
462 method apply_expr f = function
9ddf00d [fix] qmlPrint: less useless parenthesis around bypasses
Valentin Gatien-Baron authored
463 | Q.Bypass _
fccc685 Initial open-source release
MLstate authored
464 | Q.Directive _
465 | Q.Ident _
466 | Q.Apply _
467 | Q.Dot _ as e -> self#expr f e
468 | e -> pp f "(%a)" self#reset#expr e
469 method directive f variant exprs tys =
470 let variant_aux f var =
471 match var with
472 | `abstract_ty_arg (tyvars,rowvars,colvars) ->
473 pp f "@[<2>@@abstract_ty_arg(%a|%a|%a)@]"
474 (pp_list ",@ " self#under_arrow#typevar) tyvars
475 (pp_list ",@ " self#under_arrow#rowvar) rowvars
476 (pp_list ",@ " self#under_arrow#colvar) colvars
477 | `apply_ty_arg (tys,tyrows,tycols) ->
478 pp f "@[<2>@@apply_ty_arg(%a|%a|%a)@]"
479 (pp_list ",@ " self#under_arrow#ty) tys
480 (pp_list ",@ " self#under_arrow#tyrow) tyrows
481 (pp_list ",@ " self#under_arrow#tysum) tycols
482 | _ -> pp f"@[<2>%s@]" (directive var)
483 in
484 match exprs, tys with
485 | [], [] -> pp f "@[<2>%a@]" variant_aux variant
486 | _, [] ->
8ba7656 [fix] qmlPrint: printing more line breaks when printing long directives
Valentin Gatien-Baron authored
487 pp f "@[<2>%a(@,%a)@]" variant_aux variant (pp_list ",@ " self#reset#under_comma#expr) exprs
fccc685 Initial open-source release
MLstate authored
488 | _ ->
8ba7656 [fix] qmlPrint: printing more line breaks when printing long directives
Valentin Gatien-Baron authored
489 pp f "@[<2>%a(@,%a ;@ %a)@]" variant_aux variant
fccc685 Initial open-source release
MLstate authored
490 (pp_list ",@ " self#reset#under_comma#expr) exprs
491 (pp_list ",@ " self#reset#under_comma#ty) tys
492 method record f l =
493 match l with
494 | [] -> pp f "{}"
495 | _ ->
496 let is_tilde_field field =
497 let getvar = function
498 | Q.Ident (_, i) -> Some i
499 | _ -> None
500 in
501 self#is_tilde_field getvar field
502 in
503 if List.for_all is_tilde_field l
504 then
505 let pp_field f (field, _) = Format.pp_print_string f field in
506 pp f "@[<hv>~{ %a }@]" (pp_list "@, " pp_field) l
507 else
508 pp f "@[<hv>{ %a }@]" (pp_list " ;@ " self#record_binding) l
509
510 method record_binding f ((s, e) as expr) =
511 match e with
512 | Q.Record (_, [])
513 | Q.Coerce (_, Q.Record (_, []), _)
514 | Q.Directive (_, `coerce, [ Q.Record (_, []) ], _) ->
515 Format.pp_print_string f s
516 | _ ->
517 let getvar = function
518 | Q.Ident (_, i) -> Some i
519 | _ -> None
520 in
521 if self#is_tilde_field getvar expr
522 then
523 pp f "~%s" s
524 else
525 pp f "@[<2>%s =@ %a@]" s self#expr e
526
527 method rule_ f (p,e) =
528 pp f "@[<2>%a ->@ %a@]" self#pat p self#expr e
529 method path_elt f =
530 function
531 | Q.FldKey (s) -> pp f "/%s" s
532 | Q.ExprKey e -> pp f "[@[<hv>%a@]]" self#reset#expr e
533 | Q.NewKey -> pp f "[?]"
534
535 (*---------------------*)
536 (*---- code printer ---*)
537 (*---------------------*)
538 method code_elt f elt =
539 let newval rec_ iel =
540 pp f "@[<v>%t%s%a%t@]"
541 (fun f -> match iel with [_] -> () | _ -> pp f "/* group start */@ ")
542 (if rec_ then "rec " else "")
543 (if rec_
544 then (pp_list "@ and " self#binding)
545 else (pp_list "@ " self#binding)
546 ) iel
547 (fun f -> match iel with [_] -> () | _ -> pp f "@ /* group end */")
548 in
549 match elt with
550 | Q.Database (_, ident, _p, opts) -> pp f "@[<h>database /* %a */@ %s@]" self#ident ident (Q.Db.options_to_string opts)
551 | Q.NewDbValue (_, def) -> pp f "@[<hv2>%a@]" (Q.Db.print_def self#expr self#ty) def
552 | Q.NewType (_, l) -> pp f "@[<v>%a@]" (pp_list "@ " self#typedef) l
553 | Q.NewVal (_, iel) -> newval false iel
554 | Q.NewValRec (_, iel) -> newval true iel
555
556 method code f l =
557 pp f "@[<v>%a@]" (pp_list "@ @ " self#code_elt) l
558 end
559
560 (** {6 Other mode of printing} *)
561
562 class base_printer_with_sugared_types =
563 object (self)
564 inherit base_printer as super
565
566 (* Variables scope for type variables *)
567 val typevar_scope = QmlTypeVars.TypeVarPrint.new_scope ()
568 val rowvar_scope = QmlTypeVars.RowVarPrint.new_scope ()
569 val colvar_scope = QmlTypeVars.ColVarPrint.new_scope ()
570
571 method reset_typevars =
572 QmlTypeVars.TypeVarPrint.reset typevar_scope ;
573 QmlTypeVars.RowVarPrint.reset rowvar_scope ;
574 QmlTypeVars.ColVarPrint.reset colvar_scope ;
575 ()
576
577 method! typevar f t = QmlTypeVars.TypeVarPrint.pp typevar_scope f t
578 method! quant_rowvar f t = QmlTypeVars.RowVarPrint.pp rowvar_scope f t
579 method! quant_colvar f t = QmlTypeVars.ColVarPrint.pp colvar_scope f t
580 method! rowvar f _ = Format.pp_print_string f "..."
581 method! colvar f _ = Format.pp_print_string f "..."
582
583 method! scheme f vars rvars cvars ty =
584 QmlTypeVars.TypeVarPrint.push typevar_scope ;
585 QmlTypeVars.RowVarPrint.push rowvar_scope ;
586 QmlTypeVars.ColVarPrint.push colvar_scope ;
587 super#scheme f vars rvars cvars ty ;
588 QmlTypeVars.TypeVarPrint.pop typevar_scope ;
589 QmlTypeVars.RowVarPrint.pop rowvar_scope ;
590 QmlTypeVars.ColVarPrint.pop colvar_scope ;
591 ()
592
593 method ty_new_scope f ty =
594 self#reset_typevars;
595 self#ty f ty
596
597 method! code_elt f elt =
598 self#reset_typevars;
599 super#code_elt f elt
600 end
601
602 (**
603 The default pretty printer
604 *)
605 class opa_printer =
606 object (self)
607 inherit base_printer_with_sugared_types as super
608
609 method expr0 f expr =
610 match expr with
611 | Q.Match (_, e, pel) -> (
612 match QmlAstWatch.uncons_ifthenelse e pel with
613 | Some (if_, then_, else_) ->
614 pp f "@[<v>@[<2>if@ (%a)@]@ then %a@ else %a@]" self#reset#expr if_ self#expr then_ self#expr else_
615 | None ->
616 super#expr0 f expr
617 )
618 | Q.ExtendRecord (_, s, e1, e2) ->
619 let e2, fields = regroup_extend_record e2 in
620 let fields = (s, e1)::fields in
621 pp f "@[<4>{%a with@ %a}@]" self#under_record#expr e2 (pp_list ";@ " self#reset#bind_field) fields
622 | _ -> super#expr0 f expr
623
624 method binding f (i,e) =
625 pp f "@[<hv2>%a%a" self#ident i self#binding_expr e
626
627 method binding_expr f e =
628 match e with
629 | Q.Lambda (_, il, e) ->
630 pp f "(%a)%a" (pp_list ", " self#ident) il self#binding_expr e
631 | Q.Coerce (_, e, ty) ->
632 pp f " : %a =@ %a@]" self#ty ty self#expr e
633 | _ ->
634 pp f " = @ %a@]" self#expr e
635 end
636
637 (**
638 A printer for printing only the toplevel declarations.
639 *)
640 class declaration_printer =
641 object(self)
642 inherit opa_printer as super (* yeah, opa_printer is really super *)
643 method binding f (i, _) = self#ident f i
644 end
645
646 (**
647 Same than the standard printer, but with light identifiers.
648 *)
649 class light_ident_printer =
650 object
651 inherit opa_printer
652 method ident_to_string i = Ident.light_ident i
653 end
654
655 class very_light_ident_printer =
656 object
657 inherit opa_printer
658 method ident_to_string i = Ident.original_name i
659 end
660
661 let annotation_node_factory annot pp fmt ast =
662 Format.fprintf fmt "(%a : § %d)" pp ast (Annot.to_int (annot ast))
663
664 class annotation_printer =
665 object(self)
666 inherit base_printer_with_sugared_types
667 method expr_node fmt expr =
668 annotation_node_factory QmlAst.QAnnot.expr self#expr0 fmt expr
669 method pat_node fmt expr =
670 annotation_node_factory QmlAst.QAnnot.pat self#pat0 fmt expr
671 end
672
f0aca58 @fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
673
674
675 (* ************************************************************************** *)
676 (** {b Descr}: Prints an AST element and its source code location. Used by the
677 position printer below which is made available in opatrack via file
678 qmlTracker.ml.
679 {b Visibility}: Not exported outside this module. *)
680 (* ************************************************************************** *)
681 let position_node_factory pos pp fmt ast =
682 Format.fprintf fmt "(%a : § %a)" pp ast FilePos.pp (pos ast)
683
684
685
686 (* ************************************************************************** *)
687 (** {b Descr}: Printer decorating source code with positions of its elements.
688 {b Visibility}: Exported outside this module. *)
689 (* ************************************************************************** *)
690 class position_printer =
691 object(self)
692 inherit base_printer_with_sugared_types
693 method expr_node fmt expr =
694 position_node_factory QmlAst.Pos.expr self#expr0 fmt expr
695 method pat_node fmt expr =
696 position_node_factory QmlAst.Pos.pat self#pat0 fmt expr
697 end
698
699
700
fccc685 Initial open-source release
MLstate authored
701 exception Bad_printer
702
703 (* you cannot create instances of these two printers
704 * because you need an annotmap to do so *)
705 class printer_with_type annotmap =
706 object (self)
707 inherit base_printer
708 method expr_node fmt expr =
709 match QmlAnnotMap.find_ty_opt (QmlAst.QAnnot.expr expr) annotmap with
710 | None -> raise Bad_printer
711 | Some ty -> Format.fprintf fmt "(%a : %a)" self#expr0 expr self#ty ty
712
713 method pat_node fmt pat =
714 match QmlAnnotMap.find_ty_opt (QmlAst.QAnnot.pat pat) annotmap with
715 | None -> raise Bad_printer
716 | Some ty -> Format.fprintf fmt "(%a : %a)" self#pat0 pat self#ty ty
717
718 method code f l =
719 try
720 pp f "@[<v>%a@]" (pp_list "@ @ " self#code_elt) l
721 with Bad_printer -> pp f "Stupid! printer_with_type does not work on this pass"
722
723 end
724
725 class printer_for_ei annotmap =
726 object (self)
727 inherit base_printer as super
728 method expr_node f expr =
729 let annot = QmlAst.QAnnot.expr expr in
730 match QmlAnnotMap.find_tsc_opt annot annotmap with
731 | None -> (
732 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
733 | None -> super#expr_node f expr
734 | Some tsc -> pp f "(%a :- %a)" self#expr0 expr self#tsc tsc
735 )
736 | Some tsc ->
737 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
738 | None -> pp f "(%a :+ %a)" self#expr0 expr self#tsc tsc
739 | Some tsc_inst ->
740 pp f "(%a :- %a :+ %a)" self#expr0 expr self#tsc tsc_inst self#tsc tsc
741
742 method pat_node f pat =
743 let annot = QmlAst.QAnnot.pat pat in
744 match QmlAnnotMap.find_tsc_opt annot annotmap with
745 | None -> (
746 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
747 | None -> super#pat_node f pat
748 | Some tsc -> pp f "(%a :- %a)" self#pat0 pat self#tsc tsc
749 )
750 | Some tsc ->
751 match QmlAnnotMap.find_tsc_inst_opt annot annotmap with
752 | None -> pp f "(%a :+ %a)" self#pat0 pat self#tsc tsc
753 | Some tsc_inst ->
754 pp f "(%a :- %a :+ %a)" self#pat0 pat self#tsc tsc_inst self#tsc tsc
755
756 end
757
758 class pp_value_restriction =
759 object
760 inherit opa_printer as super
761 val bound_tyvs = QmlTypeVars.TypeVarSet.empty
762 val bound_cols = QmlTypeVars.ColVarSet.empty
763 val bound_rows = QmlTypeVars.RowVarSet.empty
764 method typevar f v =
765 if QmlTypeVars.TypeVarSet.mem v bound_tyvs then super#typevar f v
766 else pp f "@{<bright>%a@}" super#typevar v
767 method colvar f v =
768 if QmlTypeVars.ColVarSet.mem v bound_cols then super#colvar f v
769 else pp f "@{<bright>%a@}" super#colvar v
770 method rowvar f v =
771 if QmlTypeVars.RowVarSet.mem v bound_rows then super#rowvar f v
772 else pp f "@{<bright>%a@}" super#rowvar v
773 method ty f = function
774 | Q.TypeForall (tyvs, rows, cols, t) ->
775 let self =
776 {< bound_tyvs = List.fold_left (fun acc v -> QmlTypeVars.TypeVarSet.add v acc) bound_tyvs tyvs;
777 bound_rows = List.fold_left (fun acc v -> QmlTypeVars.RowVarSet.add v acc) bound_rows rows;
778 bound_cols = List.fold_left (fun acc v -> QmlTypeVars.ColVarSet.add v acc) bound_cols cols;
779 >} in
780 self#scheme f tyvs rows cols t
781 | ty -> super#ty f ty
782 end
783
784 (** {6 Exporting an instance of each printer} *)
785
786 let pp_base = new base_printer
787 let pp_base_with_sugared_types = new base_printer_with_sugared_types
788 let pp = new opa_printer
789 let pp_light_ident = new light_ident_printer
790 let pp_very_light_ident = new very_light_ident_printer
791 let pp_declaration = new declaration_printer
792 let pp_annotation = new annotation_printer
f0aca58 @fpessaux [feature] opatrack: Printer with source locations.
fpessaux authored
793 let pp_position = new position_printer
fccc685 Initial open-source release
MLstate authored
794 let pp_value_restriction = new pp_value_restriction
795
796 (**
797 {6 Not pretty printers}
798 *)
799
800 (**
801 Sexp printer
802 *)
803 let sexp_tyv f t = Format.pp_print_string f (QmlTypeVars.TypeVar.to_string t)
804 let sexp_rowv f t = Format.pp_print_string f (QmlTypeVars.RowVar.to_string t)
805 let sexp_colv f t = Format.pp_print_string f (QmlTypeVars.ColVar.to_string t)
806 let rec sexp_ty f = function
807 | Q.TypeConst Q.TyChar -> Format.fprintf f "C"
808 | Q.TypeConst Q.TyFloat -> Format.fprintf f "F"
809 | Q.TypeConst Q.TyInt -> Format.fprintf f "I"
810 | Q.TypeConst Q.TyNull -> Format.fprintf f "Null"
811 | Q.TypeConst Q.TyString -> Format.fprintf f "S"
812 | Q.TypeVar t -> Format.fprintf f "(V %a)" sexp_tyv t
813 | Q.TypeArrow (tyl,ty) ->
814 Format.fprintf f "(A ";
815 List.iter (fun ty -> sexp_ty f ty; Format.fprintf f " ") tyl;
816 sexp_ty f ty;
817 Format.fprintf f ")"
818 | Q.TypeRecord (Q.TyRow (fields,None)) ->
819 Format.fprintf f "(R1 ";
820 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
821 Format.fprintf f ")"
822 | Q.TypeRecord (Q.TyRow (fields,Some v)) ->
823 Format.fprintf f "(R2 ";
824 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
825 Format.fprintf f " %s)" (QmlTypeVars.RowVar.to_string v)
826 | Q.TypeSum (Q.TyCol (fieldss,None)) ->
827 Format.fprintf f "(S1";
828 List.iter
829 (fun fields ->
830 Format.fprintf f "(";
831 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
832 Format.fprintf f ")"
833 ) fieldss;
834 Format.fprintf f ")"
835 | Q.TypeSum (Q.TyCol (fieldss,Some v)) ->
836 Format.fprintf f "(S2";
837 List.iter
838 (fun fields ->
839 Format.fprintf f "(";
840 List.iter (fun (s,ty) -> Format.fprintf f "(%s " s; sexp_ty f ty; Format.fprintf f ")") fields;
841 Format.fprintf f ")"
842 ) fieldss;
843 Format.fprintf f " %s)" (QmlTypeVars.ColVar.to_string v)
844 | Q.TypeSumSugar _ ->
845 assert false
846 | Q.TypeName (tyl,ident) ->
847 Format.fprintf f "(N %s " (Q.TypeIdent.to_string ident);
848 List.iter (sexp_ty f) tyl;
849 Format.fprintf f ")"
850 | Q.TypeAbstract ->
851 Format.fprintf f "Abs"
852 | Q.TypeForall (tyvl,rowl,coll,ty) ->
853 sexp_scheme f tyvl rowl coll ty
854
855 and sexp_scheme ?(tag="Forall") f tyvl rowl coll ty =
856 Format.fprintf f "(%s (" tag;
857 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.TypeVar.to_string tyv)) tyvl;
858 Format.fprintf f ") (";
859 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.RowVar.to_string tyv)) rowl;
860 Format.fprintf f ") (";
861 List.iter (fun tyv -> Format.fprintf f "%s" (QmlTypeVars.ColVar.to_string tyv)) coll;
862 Format.fprintf f ") ";
863 sexp_ty f ty;
864 Format.fprintf f ")"
865
866 let sexp_tsc f tsc =
867 let (quant,ty,()) = QmlGenericScheme.export_unsafe tsc in
868 let (vars, rvars, cvars) = QmlTypeVars.FreeVars.export_as_lists quant in
869 sexp_scheme ~tag:"Tsc" f vars rvars cvars ty
870
871 (** {6 Backward Compatibility} *)
872 (**
873 Until we clean this up
874 *)
875
876 let bw_ty = Format.sprintf "%a" pp#ty
877 let bw_expr = Format.sprintf "%a" pp#expr
878
879
880
881 (* ************************************************************************** *)
882 (** {b Descr}: Function to dump the content of a [QmlAst.annotmap]. This is
883 mostly for debug purpose and is really very verbose.
884 {b Visibility}: Exported outside this module. *)
885 (* ************************************************************************** *)
886 let debug_QmlAst_annotmap annotmap =
887 QmlAnnotMap.iteri
888 ~f_for_key:
889 (fun key -> Format.printf "Key: %s@." (Annot.to_string key))
890 ~f_for_ty:
891 (function
892 | None -> Format.printf " Type: -@."
893 | Some t -> Format.printf "@[ Type: %a@]@." pp#ty t)
894 ~f_for_tsc:
895 (function
896 | None -> Format.printf " Sch gen: -@."
897 | Some sch -> Format.printf "@[ Sch gen: %a@]@." pp#tsc sch)
898 ~f_for_tsc_inst:
899 (function
900 | None -> Format.printf " Sch inst: -@."
901 | Some sch -> Format.printf "@[ Sch inst: %a@]@." pp#tsc sch)
902 annotmap
Something went wrong with that request. Please try again.