Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 876 lines (786 sloc) 31.353 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 | `expanded_bypass -> "@expanded_bypass"
122 | `restricted_bypass pass -> "@restricted_bypass["^ pass ^ "]"
123 | `fail -> "@fail"
124 | `create_lazy_record -> "@create_lazy_record"
125 | `warncoerce -> "@warncoerce"
126 | `apply_ty_arg _ -> "@apply_ty_arg _"
127 | `abstract_ty_arg _ -> "@abstract_ty_arg _"
128 | `closure_create _ -> "@closure_create"
129 | `closure_apply -> "@closure_apply"
130 | `closure_create_no_function _ -> "@closure_create_no_function"
131 | `closure_define_function _ -> "@closure_define_function"
132 | `ajax_publish b -> Printf.sprintf "@ajax_publish(%s)" (match b with `sync -> "`sync" | `async -> "`async")
133 | `ajax_call b -> Printf.sprintf "@ajax_call(%s)" (match b with `sync -> "`sync" | `async -> "`async")
134 | `comet_publish -> "@comet_publish"
135 | `comet_call -> "@comet_call"
136 | `insert_server_value i -> Printf.sprintf "@insert_server_value(%s)" (Ident.to_string i)
137 | `doctype _ -> "@doctype"
138 | `hybrid_value -> "@hybrid_value"
139 | `backend_ident s -> Printf.sprintf "@backend_ident[%s]" s
140 | `tracker _ -> "@track"
141 | `expand _ -> "@expand"
142 | `fun_action None -> "@fun_action"
143 | `fun_action (Some Q.Client_id) -> "@fun_action[Client_id]"
144 | `fun_action (Some Q.Deserialize) -> "@fun_action[Deserialize]"
145 | `cps_stack_lambda _ -> "@cps_stack_lambda"
146 | `cps_stack_apply _ -> "@cps_stack_apply"
147 | `asynchronous_toplevel -> "@asynchronous"
148 | `sliced_expr -> "@sliced_expr"
149 | `may_cps -> "@may_cps"
150 | `stringifier -> "@stringifier"
151 | `comparator -> "@comparator"
152 | `serializer -> "@serializer"
153 | `xmlizer -> "@xmlizer"
154 | `llarray -> "@llarray"
155 | `specialize variant -> Printf.sprintf "@specialize%s" (match variant with `strict -> "_strict" | `polymorphic -> "")
156 | `partial_apply None -> "@partial_apply"
157 | `partial_apply (Some i) -> Printf.sprintf "@partial_apply[misssing:%d]" i
158 | `full_apply n -> Printf.sprintf "@full_apply[env %d]" n
159 | `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))
160 | `tagged_string (s, kind) ->
161 Printf.sprintf "@tagged_string[%S, %s]" s
162 (match kind with
163 | Q.Rpc_use -> "rpc_use"
164 | Q.Rpc_def -> "rpc_def"
165 | Q.Type_def -> "type_def"
166 | Q.Type_use -> "type_use"
167 | Q.Client_closure_use -> "client_closure_use")
168 | `apply_cont -> "@apply_cont"
169 | `recval -> "@recval"
170 | `side_annotation a -> (
171 match a with
172 | `server -> "@server"
173 | `client -> "@client"
174 | `both -> "@both"
175 | `prefer_server -> "@prefer_server"
176 | `prefer_client -> "@prefer_client"
177 | `prefer_both -> "@prefer_both"
178 | `both_implem -> "@both_implem"
179 )
180 | `visibility_annotation `private_ -> "@server_private"
181 | `visibility_annotation (`public `sync) -> "@publish"
182 | `visibility_annotation (`public `async) -> "@publish_async"
183 | `visibility_annotation (`public `funaction) -> "@publish_funaction"
184
185 (* ************************************************************************** *)
186 (** {b Descr}: Returns the string corresponding to a type definition
187 visibility suitable to be printed *before* the "type" token of a type
188 definition pretty print string.
189 {b Visibility}: Not exported outside this module. *)
190 (* ************************************************************************** *)
191 let type_def_visibility = function
192 | Q.TDV_public -> ""
193 | Q.TDV_abstract _ -> "@abstract "
194 | Q.TDV_private _ -> "@private "
195
196
197
198 let pp = Format.fprintf
199 let pp_list = Format.pp_list
200
201 let regroup_patfield = function
202 | Q.PatRecord (_, fields, rowvar) ->
203 fields, rowvar = `open_
204 | _ -> assert false
205 let rec regroup_extend_record ?(acc=[]) = function
206 | Q.ExtendRecord (_, f, d, r) -> regroup_extend_record ~acc:((f,d) :: acc) r
207 | e -> e, List.rev acc
208 let is_infix s = Ident.is_operator s
209
210 class base_printer =
211 object (self)
212
213 (* handling of priorities
214 * when [op] is true, we are under an operator
215 * when [arrow] is true, we are on the lhs of an arrow
216 * when [amper] is true, we are just under a '&'
217 * when [comma] is true, we are just inside a tuple or a lambda binding
218 * when [record] is true, we are just under a record binding
219 *)
220 val op = false
221 val arrow = false
222 val amper = false
223 val comma = false
224 val record = false
225 val coerce = false
226
227 method reset =
228 {<
229 op = false;
230 arrow = false;
231 amper = false;
232 comma = false;
233 record = false;
234 coerce = false;
235 >}
236
237 method under_op = {< op = true >}
238 method under_arrow = {< arrow = true >}
239 method under_amper = {< amper = true >}
240 method under_comma = {< comma = true >}
241 method under_record = {< record = true >}
242 method under_coerce = {< coerce = true >}
243
244 (* annot printer *)
245 method expr_node fmt expr =
246 self#expr0 fmt expr
247
248 method pat_node fmt pat =
249 self#pat0 fmt pat
250
251 method ident_to_string i = Ident.opa_syntax i
252 method ident f i = Format.pp_print_string f (self#ident_to_string i)
253
254 (*--------------------*)
255 (*--- type printer ---*)
256 (*--------------------*)
257 method ty f = function
258 | Q.TypeArrow _ as t when comma -> pp f "(%a)" self#reset#ty t
259 | Q.TypeArrow _ as t when arrow -> pp f "(%a)" self#reset#ty t
260 | Q.TypeForall _ as t when arrow || comma -> pp f "(%a)" self#reset#ty t
261 | Q.TypeConst const -> Format.pp_print_string f (Q.Const.string_of_ty const)
262 | Q.TypeVar typevar -> self#typevar f typevar
263 | Q.TypeArrow (lty1, ty2) -> pp f "@[<2>%a ->@ %a@]" (pp_list ",@ " self#under_arrow#ty) lty1 self#under_arrow#ty ty2
264 | Q.TypeRecord row -> self#reset#tyrow f row
265 | Q.TypeSum ty_col -> self#tysum f ty_col
266 | Q.TypeSumSugar tyl -> pp f "@[%a@]" (pp_list "@ /@ " self#ty) tyl
267 | Q.TypeName ([],t) -> self#typeident f t
268 | Q.TypeName (tyl,t) -> pp f "@[<2>%a(%a)@]" self#typeident t (pp_list ",@ " self#reset#ty) tyl
269 | Q.TypeAbstract -> pp f "external"
270 | Q.TypeForall (tyvl,rowl,coll,ty) -> self#scheme f tyvl rowl coll ty
271 method typeident f t = pp f "%s" (Q.TypeIdent.to_printable_string t)
272 method typevar f t = Format.pp_print_string f (QmlTypeVars.TypeVar.to_string t)
273 method quant_colvar f t = Format.pp_print_string f (QmlTypeVars.ColVar.to_string t)
274 method quant_rowvar f t = Format.pp_print_string f (QmlTypeVars.RowVar.to_string t)
275 method colvar = self#quant_colvar
276 method rowvar = self#quant_rowvar
277 method tyrow f (Q.TyRow (fields,rowvar)) =
278 pp f "@[<hv2>{%a%t}@]"
279 (pp_list ";@ " self#tyrow_binding) fields
280 (fun f ->
281 match rowvar with
282 | None -> ()
283 | Some v -> Format.fprintf f "%s%a" (if fields = [] then "" else "; ") self#rowvar v)
284
285 (*
286 Can be overwritten in a class having a gamma, if needed
287 *)
288 method is_type_void ty =
289 match ty with
290 | Q.TypeRecord (Q.TyRow ([], None))
291 | Q.TypeSum (Q.TyCol ([ [ ] ], None)) ->
292 true
293 | _ -> false
294
295 method tyrow_binding f (s, ty) =
296 if self#is_type_void ty
297 then
298 Format.pp_print_string f s
299 else
300 pp f "@[<h>%s :@ %a@]" s self#ty ty
301
302 method tycol = self#tysum
303 method tysum f (Q.TyCol (fl, colvar)) =
304 (* Attention, if the sum type is closed and contains no row (i.e. a trivial
305 sum type with no possible cases), the printed type would be an empty
306 string, which would be very confusing ! So, manually take care of this
307 case. *)
308 if (List.length fl = 0) && colvar = None then
309 pp f "<empty sum type>"
310 else
311 pp f "@[<2>%a%t@]"
312 (pp_list "@ /@ " (fun f -> pp f "@[{%a}@]" (pp_list ";@ " self#tyrow_binding))) fl
313 (fun f ->
314 match colvar with
315 | None -> ()
316 | Some v -> pp f "@ /@ %a" self#colvar v)
317
318 method typedef f tdef =
319 let visibility_str = type_def_visibility tdef.Q.ty_def_visibility in
320 match tdef.Q.ty_def_params with
321 | [] ->
322 pp f "@[<2>%stype %a =@ %a@]"
323 visibility_str
324 self#typeident tdef.Q.ty_def_name self#ty tdef.Q.ty_def_body
325 | _ ->
326 pp f "@[<2>%stype %a(%a) =@ %a@]"
327 visibility_str
328 self#typeident tdef.Q.ty_def_name
329 (pp_list ",@ " self#typevar) tdef.Q.ty_def_params
330 self#ty tdef.Q.ty_def_body
331
332 method scheme f vars rvars cvars ty =
333 if rvars = [] && cvars = [] then
334 pp f "@[<2>forall(@[<h>%a@]).@ %a@]"
335 (pp_list ",@ " self#typevar) vars
336 self#ty ty
337 else
338 pp f "@[<2>forall(@[<h>%a,@ rows:%a,@ cols:%a@]).@ %a@]"
339 (pp_list ",@ " self#typevar) vars
340 (pp_list ",@ " self#rowvar) rvars
341 (pp_list ",@ " self#colvar) cvars
342 self#ty ty
343
344 method tsc f tsc =
345 let (quant,ty,()) = QmlGenericScheme.export_unsafe tsc in
346 let (vars, rvars, cvars) = QmlTypeVars.FreeVars.export_as_lists quant in
347 self#scheme f vars rvars cvars ty
348
349 (*---------------------*)
350 (*-- pattern printer --*)
351 (*---------------------*)
352 method is_tilde_field : 'a. ('a -> Ident.t option) -> string * 'a -> bool =
353 (fun getvar (field, pat) ->
354 match getvar pat with
355 | Some ident ->
356 let ident = self#ident_to_string ident in
357 String.compare field ident = 0
358 | None -> false
359 )
360
361 method pat_record_binding f ((s, p) as pat) =
362 match p with
363 | Q.PatRecord (_, [], `closed)
364 | Q.PatCoerce (_, Q.PatRecord (_, [], `closed), _)
365 ->
366 Format.pp_print_string f s
367 | _ ->
368 let getvar = function
369 | Q.PatVar (_, i) -> Some i
370 | _ -> None
371 in
372 if self#is_tilde_field getvar pat
373 then
374 pp f "~%s" s
375 else
376 pp f "@[<h>%s =@ %a@]" s self#pat p
377
378 method pat_record f fields rowvar =
379 match fields with
380 | [] ->
381 if rowvar = `open_
382 then
383 Format.pp_print_string f "{ ... }"
384 else
385 Format.pp_print_string f "{}"
386 | _ ->
387 let rowvar = if rowvar = `open_ then " ; ..." else "" in
388 let is_tilde_field field =
389 let getvar = function
390 | Q.PatVar (_, i) -> Some i
391 | _ -> None
392 in
393 self#is_tilde_field getvar field
394 in
395 if List.for_all is_tilde_field fields
396 then
397 let pp_field f (field, _) = Format.pp_print_string f field in
398 pp f "@[<hv2>~{ %a%s }@]"
399 (pp_list "@, " pp_field) fields
400 rowvar
401 else
402 pp f "@[<hv2>{ %a%s }@]"
403 (pp_list " ;@ " self#pat_record_binding) fields
404 rowvar
405
406 method pat0 f = function
407 | Q.PatRecord (_, fields, rowvar) -> self#pat_record f fields rowvar
408 | Q.PatConst (_, Q.String s) -> Format.fprintf f "\"%s\"" (escaped_string s)
409 | Q.PatConst (_, const) -> Format.pp_print_string f (Q.Const.string_of_expr const)
410 | Q.PatVar (_, i) -> self#ident f i
411 | Q.PatAny _ -> pp f "_"
412 | Q.PatCoerce (_, p, ty) -> pp f "(@[<2>%a :@ %a@])" self#pat p self#ty ty
413 | Q.PatAs (_, p, i) -> pp f "@[<2>%a as %a@]" self#pat p self#ident i
414 method pat f v =
415 self#pat_node f v
416
417 method const f = function
418 | Q.String s -> Format.fprintf f "\"%s\"" (escaped_string s)
419 | c -> Format.pp_print_string f (Q.Const.string_of_expr c)
420
421 method path f (el, knd) =
422 pp f "%s%a" (Q.Db.path_kind_to_string knd) (pp_list "" self#path_elt) el
423
424 method path_elts f el =
425 pp f "%a" (pp_list "" self#path_elt) el
426
427 (*---------------------*)
428 (*---- expr printer ---*)
429 (*---------------------*)
430 method expr0 f = function
431 | (Q.Lambda _ | Q.Coerce _) as e when coerce -> pp f "(%a)" self#reset#expr0 e
432 | (Q.Lambda _) as e when comma -> pp f "(%a)" self#reset#expr0 e
433 | Q.LetIn _ | Q.LetRecIn _ as e when record -> pp f "(%a)" self#reset#expr0 e
434 | Q.Match _ | Q.Lambda _ | Q.LetIn _ | Q.LetRecIn _ as e when op -> pp f "(%a)" self#reset#expr0 e
435 | Q.Const (_, c) -> self#const f c
436 | Q.Ident (_, i) -> self#ident f i
437 | Q.LetIn (_, b, e) ->
438 pp f "@[<v>%a@ %a@]" (pp_list "@ " self#binding) b self#expr e
439 | Q.LetRecIn (_, iel, e) -> pp f "@[<v>rec %a@ %a@]" (pp_list "@ and " self#binding) iel self#expr e
440 | Q.Lambda (_, il, e) ->
441 pp f "@[<2>@[<h>%a@] ->@ %a@]" (pp_list ",@ " self#ident) il self#expr e
442 | Q.Apply (_, Q.Ident (_, s), [e1; e2]) as e when is_infix s ->
443 if op then pp f "(%a)" self#reset#expr0 e else
444 let name = Ident.original_name s in
445 pp f "%a %s %a" self#under_op#expr e1 name self#under_op#expr e2
446 | Q.Apply (_, e, el) ->
447 pp f "@[<2>%a(@,%a)@]" self#apply_expr e (pp_list ",@ " self#reset#under_comma#expr) el
448 | Q.Match (_, e, pel) ->
449 pp f "@[<v>@[<2>match@ %a@ with@]@ | %a@ end@]" self#expr e (pp_list "@ | " self#rule_) pel
450 | Q.Record (_, [ s, Q.Coerce (_, Q.Record (_, []), Q.TypeRecord (Q.TyRow ([], None))) ] ) -> pp f "{%s}" s
451 | Q.Record (_, sel) -> self#reset#under_record#record f sel
452 | Q.Dot (_, e, s) -> pp f "%a.%s" self#apply_expr e s
453 | Q.ExtendRecord (_, s, e1, e2) ->
454 pp f "@[<2>{%s = %a} ::@ %a@]" s self#expr e1 self#expr e2
455 | Q.Bypass (_, s) -> Format.pp_print_string f ("%%" ^ (BslKey.to_string s) ^ "%%")
456 | Q.Coerce (_, e,ty) -> pp f "%a : %a" self#under_coerce#expr e self#ty ty
457 | Q.Path (_, el, knd) -> self#path f (el, knd)
458 | Q.Directive (_, `module_, [e], _) -> pp f "{%a}" self#reset#expr e
459 | Q.Directive (_, dir, exprs, tys) -> self#directive f dir exprs tys
460 method bind_field fmt (f, d) = pp fmt "%s = %a" f self#under_record#expr d
461 method binding f (i, e) =
462 pp f "@[<hv2>%a =@ %a@]" self#ident i self#expr e
463 method expr f e =
464 self#expr_node f e
465 method apply_expr f = function
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.