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