File: genprintval.ml

package info (click to toggle)
ocaml 4.05.0-11
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 27,060 kB
  • sloc: ml: 199,255; ansic: 44,187; sh: 5,611; makefile: 4,958; lisp: 4,223; asm: 4,220; awk: 306; perl: 87; fortran: 21; cs: 9; sed: 9
file content (582 lines) | stat: -rw-r--r-- 23,198 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* To print values *)

open Misc
open Format
open Longident
open Path
open Types
open Outcometree

module type OBJ =
  sig
    type t
    val obj : t -> 'a
    val is_block : t -> bool
    val tag : t -> int
    val size : t -> int
    val field : t -> int -> t
  end

module type EVALPATH =
  sig
    type valu
    val eval_path: Env.t -> Path.t -> valu
    exception Error
    val same_value: valu -> valu -> bool
  end

type ('a, 'b) gen_printer =
  | Zero of 'b
  | Succ of ('a -> ('a, 'b) gen_printer)

module type S =
  sig
    type t
    val install_printer :
          Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
    val install_generic_printer :
           Path.t -> Path.t ->
           (int -> (int -> t -> Outcometree.out_value,
                    t -> Outcometree.out_value) gen_printer) ->
           unit
    val install_generic_printer' :
           Path.t -> Path.t ->
           (formatter -> t -> unit,
            formatter -> t -> unit) gen_printer ->
           unit
    val remove_printer : Path.t -> unit
    val outval_of_untyped_exception : t -> Outcometree.out_value
    val outval_of_value :
          int -> int ->
          (int -> t -> Types.type_expr -> Outcometree.out_value option) ->
          Env.t -> t -> type_expr -> Outcometree.out_value
  end

module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct

    type t = O.t

    module ObjTbl = Hashtbl.Make(struct
        type t = O.t
        let equal = (==)
        let hash x =
          try
            Hashtbl.hash x
          with _exn -> 0
      end)


    (* Given an exception value, we cannot recover its type,
       hence we cannot print its arguments in general.
       Here, we do a feeble attempt to print
       integer, string and float arguments... *)
    let outval_of_untyped_exception_args obj start_offset =
      if O.size obj > start_offset then begin
        let list = ref [] in
        for i = start_offset to O.size obj - 1 do
          let arg = O.field obj i in
          if not (O.is_block arg) then
            list := Oval_int (O.obj arg : int) :: !list
               (* Note: this could be a char or a constant constructor... *)
          else if O.tag arg = Obj.string_tag then
            list :=
              Oval_string (String.escaped (O.obj arg : string)) :: !list
          else if O.tag arg = Obj.double_tag then
            list := Oval_float (O.obj arg : float) :: !list
          else
            list := Oval_constr (Oide_ident "_", []) :: !list
        done;
        List.rev !list
      end
      else []

    let outval_of_untyped_exception bucket =
      if O.tag bucket <> 0 then
        Oval_constr (Oide_ident (O.obj (O.field bucket 0) : string), [])
      else
      let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
      let args =
        if (name = "Match_failure"
            || name = "Assert_failure"
            || name = "Undefined_recursive_module")
        && O.size bucket = 2
        && O.tag(O.field bucket 1) = 0
        then outval_of_untyped_exception_args (O.field bucket 1) 0
        else outval_of_untyped_exception_args bucket 1 in
      Oval_constr (Oide_ident name, args)

    (* The user-defined printers. Also used for some builtin types. *)

    type printer =
      | Simple of Types.type_expr * (O.t -> Outcometree.out_value)
      | Generic of Path.t * (int -> (int -> O.t -> Outcometree.out_value,
                                     O.t -> Outcometree.out_value) gen_printer)

    let printers = ref ([
      ( Pident(Ident.create "print_int"),
        Simple (Predef.type_int,
                (fun x -> Oval_int (O.obj x : int))) );
      ( Pident(Ident.create "print_float"),
        Simple (Predef.type_float,
                (fun x -> Oval_float (O.obj x : float))) );
      ( Pident(Ident.create "print_char"),
        Simple (Predef.type_char,
                (fun x -> Oval_char (O.obj x : char))) );
      ( Pident(Ident.create "print_string"),
        Simple (Predef.type_string,
                (fun x -> Oval_string (O.obj x : string))) );
      ( Pident(Ident.create "print_int32"),
        Simple (Predef.type_int32,
                (fun x -> Oval_int32 (O.obj x : int32))) );
      ( Pident(Ident.create "print_nativeint"),
        Simple (Predef.type_nativeint,
                (fun x -> Oval_nativeint (O.obj x : nativeint))) );
      ( Pident(Ident.create "print_int64"),
        Simple (Predef.type_int64,
                (fun x -> Oval_int64 (O.obj x : int64)) ))
    ] : (Path.t * printer) list)

    let exn_printer ppf path exn =
      fprintf ppf "<printer %a raised an exception: %s>" Printtyp.path path (Printexc.to_string exn)

    let out_exn path exn =
      Oval_printer (fun ppf -> exn_printer ppf path exn)

    let install_printer path ty fn =
      let print_val ppf obj =
        try fn ppf obj with exn -> exn_printer ppf path exn in
      let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
      printers := (path, Simple (ty, printer)) :: !printers

    let install_generic_printer function_path constr_path fn =
      printers := (function_path, Generic (constr_path, fn))  :: !printers

    let install_generic_printer' function_path ty_path fn =
      let rec build gp depth =
        match gp with
        | Zero fn ->
            let out_printer obj =
              let printer ppf =
                try fn ppf obj with exn -> exn_printer ppf function_path exn in
              Oval_printer printer in
            Zero out_printer
        | Succ fn ->
            let print_val fn_arg =
              let print_arg ppf o =
                !Oprint.out_value ppf (fn_arg (depth+1) o) in
              build (fn print_arg) depth in
            Succ print_val in
      printers := (function_path, Generic (ty_path, build fn)) :: !printers

    let remove_printer path =
      let rec remove = function
      | [] -> raise Not_found
      | ((p, _) as printer) :: rem ->
          if Path.same p path then rem else printer :: remove rem in
      printers := remove !printers

    (* Print a constructor or label, giving it the same prefix as the type
       it comes from. Attempt to omit the prefix if the type comes from
       a module that has been opened. *)

    let tree_of_qualified lookup_fun env ty_path name =
      match ty_path with
      | Pident _ ->
          Oide_ident name
      | Pdot(p, _s, _pos) ->
          if try
               match (lookup_fun (Lident name) env).desc with
               | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
               | _ -> false
             with Not_found -> false
          then Oide_ident name
          else Oide_dot (Printtyp.tree_of_path p, name)
      | Papply _ ->
          Printtyp.tree_of_path ty_path

    let tree_of_constr =
      tree_of_qualified
        (fun lid env -> (Env.lookup_constructor lid env).cstr_res)

    and tree_of_label =
      tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)

    (* An abstract type *)

    let abstract_type =
      Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil))

    (* The main printing function *)

    let outval_of_value max_steps max_depth check_depth env obj ty =

      let printer_steps = ref max_steps in

      let nested_values = ObjTbl.create 8 in
      let nest_gen err f depth obj ty =
        let repr = obj in
        if not (O.is_block repr) then
          f depth obj ty
        else
          if ObjTbl.mem nested_values repr then
            err
          else begin
            ObjTbl.add nested_values repr ();
            let ret = f depth obj ty in
            ObjTbl.remove nested_values repr;
            ret
          end
      in

      let nest f = nest_gen (Oval_stuff "<cycle>") f in

      let rec tree_of_val depth obj ty =
        decr printer_steps;
        if !printer_steps < 0 || depth < 0 then Oval_ellipsis
        else begin
        try
          find_printer depth env ty obj
        with Not_found ->
          match (Ctype.repr ty).desc with
          | Tvar _ | Tunivar _ ->
              Oval_stuff "<poly>"
          | Tarrow _ ->
              Oval_stuff "<fun>"
          | Ttuple(ty_list) ->
              Oval_tuple (tree_of_val_list 0 depth obj ty_list)
          | Tconstr(path, [ty_arg], _)
            when Path.same path Predef.path_list ->
              if O.is_block obj then
                match check_depth depth obj ty with
                  Some x -> x
                | None ->
                    let rec tree_of_conses tree_list depth obj ty_arg =
                      if !printer_steps < 0 || depth < 0 then
                        Oval_ellipsis :: tree_list
                      else if O.is_block obj then
                        let tree =
                          nest tree_of_val (depth - 1) (O.field obj 0) ty_arg
                        in
                        let next_obj = O.field obj 1 in
                        nest_gen (Oval_stuff "<cycle>" :: tree :: tree_list)
                          (tree_of_conses (tree :: tree_list))
                          depth next_obj ty_arg
                      else tree_list
                    in
                    Oval_list (List.rev (tree_of_conses [] depth obj ty_arg))
              else
                Oval_list []
          | Tconstr(path, [ty_arg], _)
            when Path.same path Predef.path_array ->
              let length = O.size obj in
              if length > 0 then
                match check_depth depth obj ty with
                  Some x -> x
                | None ->
                    let rec tree_of_items tree_list i =
                      if !printer_steps < 0 || depth < 0 then
                        Oval_ellipsis :: tree_list
                      else if i < length then
                        let tree =
                          nest tree_of_val (depth - 1) (O.field obj i) ty_arg
                        in
                        tree_of_items (tree :: tree_list) (i + 1)
                      else tree_list
                    in
                    Oval_array (List.rev (tree_of_items [] 0))
              else
                Oval_array []
          | Tconstr (path, [ty_arg], _)
            when Path.same path Predef.path_lazy_t ->
             let obj_tag = O.tag obj in
             (* Lazy values are represented in three possible ways:

                1. a lazy thunk that is not yet forced has tag
                   Obj.lazy_tag

                2. a lazy thunk that has just been forced has tag
                   Obj.forward_tag; its first field is the forced
                   result, which we can print

                3. when the GC moves a forced trunk with forward_tag,
                   or when a thunk is directly created from a value,
                   we get a third representation where the value is
                   directly exposed, without the Obj.forward_tag
                   (if its own tag is not ambiguous, that is neither
                   lazy_tag nor forward_tag)

                Note that using Lazy.is_val and Lazy.force would be
                unsafe, because they use the Obj.* functions rather
                than the O.* functions of the functor argument, and
                would thus crash if called from the toplevel
                (debugger/printval instantiates Genprintval.Make with
                an Obj module talking over a socket).
              *)
             if obj_tag = Obj.lazy_tag then Oval_stuff "<lazy>"
             else begin
                 let forced_obj =
                   if obj_tag = Obj.forward_tag then O.field obj 0 else obj
                 in
                 (* calling oneself recursively on forced_obj risks
                    having a false positive for cycle detection;
                    indeed, in case (3) above, the value is stored
                    as-is instead of being wrapped in a forward
                    pointer. It means that, for (lazy "foo"), we have
                      forced_obj == obj
                    and it is easy to wrongly print (lazy <cycle>) in such
                    a case (PR#6669).

                    Unfortunately, there is a corner-case that *is*
                    a real cycle: using -rectypes one can define
                      let rec x = lazy x
                    which creates a Forward_tagged block that points to
                    itself. For this reason, we still "nest"
                    (detect head cycles) on forward tags.
                  *)
                 let v =
                   if obj_tag = Obj.forward_tag
                   then nest tree_of_val depth forced_obj ty_arg
                   else      tree_of_val depth forced_obj ty_arg
                 in
                 Oval_constr (Oide_ident "lazy", [v])
               end
          | Tconstr(path, ty_list, _) -> begin
              try
                let decl = Env.find_type path env in
                match decl with
                | {type_kind = Type_abstract; type_manifest = None} ->
                    Oval_stuff "<abstr>"
                | {type_kind = Type_abstract; type_manifest = Some body} ->
                    tree_of_val depth obj
                      (try Ctype.apply env decl.type_params body ty_list with
                         Ctype.Cannot_apply -> abstract_type)
                | {type_kind = Type_variant constr_list; type_unboxed} ->
                    let unbx = type_unboxed.unboxed in
                    let tag =
                      if unbx then Cstr_unboxed
                      else if O.is_block obj
                      then Cstr_block(O.tag obj)
                      else Cstr_constant(O.obj obj) in
                    let {cd_id;cd_args;cd_res} =
                      Datarepr.find_constr_by_tag tag constr_list in
                    let type_params =
                      match cd_res with
                        Some t ->
                          begin match (Ctype.repr t).desc with
                            Tconstr (_,params,_) ->
                              params
                          | _ -> assert false end
                      | None -> decl.type_params
                    in
                    begin
                      match cd_args with
                      | Cstr_tuple l ->
                          let ty_args =
                            List.map
                              (function ty ->
                                try Ctype.apply env type_params ty ty_list with
                                  Ctype.Cannot_apply -> abstract_type)
                              l
                          in
                          tree_of_constr_with_args (tree_of_constr env path)
                            (Ident.name cd_id) false 0 depth obj
                            ty_args unbx
                      | Cstr_record lbls ->
                          let r =
                            tree_of_record_fields depth
                              env path type_params ty_list
                              lbls 0 obj unbx
                          in
                          Oval_constr(tree_of_constr env path
                                        (Ident.name cd_id),
                                      [ r ])
                    end
                | {type_kind = Type_record(lbl_list, rep)} ->
                    begin match check_depth depth obj ty with
                      Some x -> x
                    | None ->
                        let pos =
                          match rep with
                          | Record_extension -> 1
                          | _ -> 0
                        in
                        let unbx =
                          match rep with Record_unboxed _ -> true | _ -> false
                        in
                        tree_of_record_fields depth
                          env path decl.type_params ty_list
                          lbl_list pos obj unbx
                    end
                | {type_kind = Type_open} ->
                    tree_of_extension path depth obj
              with
                Not_found ->                (* raised by Env.find_type *)
                  Oval_stuff "<abstr>"
              | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
                  Oval_stuff "<unknown constructor>"
              end
          | Tvariant row ->
              let row = Btype.row_repr row in
              if O.is_block obj then
                let tag : int = O.obj (O.field obj 0) in
                let rec find = function
                  | (l, f) :: fields ->
                      if Btype.hash_variant l = tag then
                        match Btype.row_field_repr f with
                        | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
                            let args =
                              nest tree_of_val (depth - 1) (O.field obj 1) ty
                            in
                              Oval_variant (l, Some args)
                        | _ -> find fields
                      else find fields
                  | [] -> Oval_stuff "<variant>" in
                find row.row_fields
              else
                let tag : int = O.obj obj in
                let rec find = function
                  | (l, _) :: fields ->
                      if Btype.hash_variant l = tag then
                        Oval_variant (l, None)
                      else find fields
                  | [] -> Oval_stuff "<variant>" in
                find row.row_fields
          | Tobject (_, _) ->
              Oval_stuff "<obj>"
          | Tsubst ty ->
              tree_of_val (depth - 1) obj ty
          | Tfield(_, _, _, _) | Tnil | Tlink _ ->
              fatal_error "Printval.outval_of_value"
          | Tpoly (ty, _) ->
              tree_of_val (depth - 1) obj ty
          | Tpackage _ ->
              Oval_stuff "<module>"
        end

      and tree_of_record_fields depth env path type_params ty_list
          lbl_list pos obj unboxed =
        let rec tree_of_fields pos = function
          | [] -> []
          | {ld_id; ld_type} :: remainder ->
              let ty_arg =
                try
                  Ctype.apply env type_params ld_type
                    ty_list
                with
                  Ctype.Cannot_apply -> abstract_type in
              let name = Ident.name ld_id in
              (* PR#5722: print full module path only
                 for first record field *)
              let lid =
                if pos = 0 then tree_of_label env path name
                else Oide_ident name
              and v =
                if unboxed
                then tree_of_val (depth - 1) obj ty_arg
                else nest tree_of_val (depth - 1) (O.field obj pos) ty_arg
              in
              (lid, v) :: tree_of_fields (pos + 1) remainder
        in
        Oval_record (tree_of_fields pos lbl_list)

      and tree_of_val_list start depth obj ty_list =
        let rec tree_list i = function
          | [] -> []
          | ty :: ty_list ->
              let tree = nest tree_of_val (depth - 1) (O.field obj i) ty in
              tree :: tree_list (i + 1) ty_list in
      tree_list start ty_list

      and tree_of_constr_with_args
             tree_of_cstr cstr_name inlined start depth obj ty_args unboxed =
        let lid = tree_of_cstr cstr_name in
        let args =
          if inlined || unboxed then
            match ty_args with
            | [ty] -> [ tree_of_val (depth - 1) obj ty ]
            | _ -> assert false
          else
            tree_of_val_list start depth obj ty_args
        in
        Oval_constr (lid, args)

    and tree_of_extension type_path depth bucket =
      let slot =
        if O.tag bucket <> 0 then bucket
        else O.field bucket 0
      in
      let name = (O.obj(O.field slot 0) : string) in
      let lid = Longident.parse name in
      try
        (* Attempt to recover the constructor description for the exn
           from its name *)
        let cstr = Env.lookup_constructor lid env in
        let path =
          match cstr.cstr_tag with
            Cstr_extension(p, _) -> p
            | _ -> raise Not_found
        in
        (* Make sure this is the right exception and not an homonym,
           by evaluating the exception found and comparing with the
           identifier contained in the exception bucket *)
        if not (EVP.same_value slot (EVP.eval_path env path))
        then raise Not_found;
        tree_of_constr_with_args
           (fun x -> Oide_ident x) name (cstr.cstr_inlined <> None)
           1 depth bucket
           cstr.cstr_args false
      with Not_found | EVP.Error ->
        match check_depth depth bucket ty with
          Some x -> x
        | None when Path.same type_path Predef.path_exn->
            outval_of_untyped_exception bucket
        | None ->
            Oval_stuff "<extension>"

    and find_printer depth env ty =
      let rec find = function
      | [] -> raise Not_found
      | (_name, Simple (sch, printer)) :: remainder ->
          if Ctype.moregeneral env false sch ty
          then printer
          else find remainder
      | (_name, Generic (path, fn)) :: remainder ->
          begin match (Ctype.expand_head env ty).desc with
          | Tconstr (p, args, _) when Path.same p path ->
              begin try apply_generic_printer path (fn depth) args
              with exn -> (fun _obj -> out_exn path exn) end
          | _ -> find remainder end in
      find !printers

    and apply_generic_printer path printer args =
      match (printer, args) with
      | (Zero fn, []) -> (fun (obj : O.t)-> try fn obj with exn -> out_exn path exn)
      | (Succ fn, arg :: args) ->
          let printer = fn (fun depth obj -> tree_of_val depth obj arg) in
          apply_generic_printer path printer args
      | _ ->
          (fun _obj ->
            let printer ppf =
              fprintf ppf "<internal error: incorrect arity for '%a'>"
                Printtyp.path path in
            Oval_printer printer)


    in nest tree_of_val max_depth obj ty

end