Skip to content

HTTPS clone URL

Subversion checkout URL

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