l4/pkg/ocaml/contrib/toplevel/genprintval.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: genprintval.ml 8418 2007-10-09 10:29:37Z weis $ *)
  14
  15 (* To print values *)
  16
  17 open Misc
  18 open Format
  19 open Longident
  20 open Path
  21 open Types
  22 open Outcometree
  23
  24 module type OBJ =
  25   sig
  26     type t
  27     val obj : t -> 'a
  28     val is_block : t -> bool
  29     val tag : t -> int
  30     val size : t -> int
  31     val field : t -> int -> t
  32   end
  33
  34 module type EVALPATH =
  35   sig
  36     type value
  37     val eval_path: Path.t -> value
  38     exception Error
  39     val same_value: value -> value -> bool
  40   end
  41
  42 module type S =
  43   sig
  44     type t
  45     val install_printer :
  46           Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
  47     val remove_printer : Path.t -> unit
  48     val outval_of_untyped_exception : t -> Outcometree.out_value
  49     val outval_of_value :
  50           int -> int ->
  51           (int -> t -> Types.type_expr -> Outcometree.out_value option) ->
  52           Env.t -> t -> type_expr -> Outcometree.out_value
  53   end
  54
  55 module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
  56
  57     type t = O.t
  58
  59     (* Given an exception value, we cannot recover its type,
  60        hence we cannot print its arguments in general.
  61        Here, we do a feeble attempt to print
  62        integer, string and float arguments... *)
  63     let outval_of_untyped_exception_args obj start_offset =
  64       if O.size obj > start_offset then begin
  65         let list = ref [] in
  66         for i = start_offset to O.size obj - 1 do
  67           let arg = O.field obj i in
  68           if not (O.is_block arg) then
  69             list := Oval_int (O.obj arg : int) :: !list
  70                (* Note: this could be a char or a constant constructor... *)
  71           else if O.tag arg = Obj.string_tag then
  72             list :=
  73               Oval_string (String.escaped (O.obj arg : string)) :: !list
  74           else if O.tag arg = Obj.double_tag then
  75             list := Oval_float (O.obj arg : float) :: !list
  76           else
  77             list := Oval_constr (Oide_ident "_", []) :: !list
  78         done;
  79         List.rev !list
  80       end
  81       else []
  82
  83     let outval_of_untyped_exception bucket =
  84       let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
  85       let args =
  86         if (name = "Match_failure"
  87             || name = "Assert_failure"
  88             || name = "Undefined_recursive_module")
  89         && O.size bucket = 2
  90         && O.tag(O.field bucket 1) = 0
  91         then outval_of_untyped_exception_args (O.field bucket 1) 0
  92         else outval_of_untyped_exception_args bucket 1 in
  93       Oval_constr (Oide_ident name, args)
  94
  95     (* The user-defined printers. Also used for some builtin types. *)
  96
  97     let printers = ref ([
  98       Pident(Ident.create "print_int"), Predef.type_int,
  99         (fun x -> Oval_int (O.obj x : int));
 100       Pident(Ident.create "print_float"), Predef.type_float,
 101         (fun x -> Oval_float (O.obj x : float));
 102       Pident(Ident.create "print_char"), Predef.type_char,
 103         (fun x -> Oval_char (O.obj x : char));
 104       Pident(Ident.create "print_string"), Predef.type_string,
 105         (fun x -> Oval_string (O.obj x : string));
 106       Pident(Ident.create "print_int32"), Predef.type_int32,
 107         (fun x -> Oval_int32 (O.obj x : int32));
 108       Pident(Ident.create "print_nativeint"), Predef.type_nativeint,
 109         (fun x -> Oval_nativeint (O.obj x : nativeint));
 110       Pident(Ident.create "print_int64"), Predef.type_int64,
 111         (fun x -> Oval_int64 (O.obj x : int64))
 112     ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list)
 113
 114     let install_printer path ty fn =
 115       let print_val ppf obj =
 116         try fn ppf obj with
 117         | exn ->
 118            fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
 119       let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
 120       printers := (path, ty, printer) :: !printers
 121
 122     let remove_printer path =
 123       let rec remove = function
 124       | [] -> raise Not_found
 125       | (p, ty, fn as printer) :: rem ->
 126           if Path.same p path then rem else printer :: remove rem in
 127       printers := remove !printers
 128
 129     let find_printer env ty =
 130       let rec find = function
 131       | [] -> raise Not_found
 132       | (name, sch, printer) :: remainder ->
 133           if Ctype.moregeneral env false sch ty
 134           then printer
 135           else find remainder
 136       in find !printers
 137
 138     (* Print a constructor or label, giving it the same prefix as the type
 139        it comes from. Attempt to omit the prefix if the type comes from
 140        a module that has been opened. *)
 141
 142     let tree_of_qualified lookup_fun env ty_path name =
 143       match ty_path with
 144       | Pident id ->
 145           Oide_ident name
 146       | Pdot(p, s, pos) ->
 147           if try
 148                match (lookup_fun (Lident name) env).desc with
 149                | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
 150                | _ -> false
 151              with Not_found -> false
 152           then Oide_ident name
 153           else Oide_dot (Printtyp.tree_of_path p, name)
 154       | Papply(p1, p2) ->
 155           Printtyp.tree_of_path ty_path
 156
 157     let tree_of_constr =
 158       tree_of_qualified
 159         (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
 160
 161     and tree_of_label =
 162       tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
 163
 164     (* An abstract type *)
 165
 166     let abstract_type =
 167       Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil))
 168
 169     (* The main printing function *)
 170
 171     let outval_of_value max_steps max_depth check_depth env obj ty =
 172
 173       let printer_steps = ref max_steps in
 174
 175       let rec tree_of_val depth obj ty =
 176         decr printer_steps;
 177         if !printer_steps < 0 || depth < 0 then Oval_ellipsis
 178         else begin
 179         try
 180           find_printer env ty obj
 181         with Not_found ->
 182           match (Ctype.repr ty).desc with
 183           | Tvar ->
 184               Oval_stuff "<poly>"
 185           | Tarrow(_, ty1, ty2, _) ->
 186               Oval_stuff "<fun>"
 187           | Ttuple(ty_list) ->
 188               Oval_tuple (tree_of_val_list 0 depth obj ty_list)
 189           | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
 190               tree_of_exception depth obj
 191           | Tconstr(path, [ty_arg], _)
 192             when Path.same path Predef.path_list ->
 193               if O.is_block obj then
 194                 match check_depth depth obj ty with
 195                   Some x -> x
 196                 | None ->
 197                     let rec tree_of_conses tree_list obj =
 198                       if !printer_steps < 0 || depth < 0 then
 199                         Oval_ellipsis :: tree_list
 200                       else if O.is_block obj then
 201                         let tree =
 202                           tree_of_val (depth - 1) (O.field obj 0) ty_arg in
 203                         let next_obj = O.field obj 1 in
 204                         tree_of_conses (tree :: tree_list) next_obj
 205                       else tree_list
 206                     in
 207                     Oval_list (List.rev (tree_of_conses [] obj))
 208               else
 209                 Oval_list []
 210           | Tconstr(path, [ty_arg], _)
 211             when Path.same path Predef.path_array ->
 212               let length = O.size obj in
 213               if length > 0 then
 214                 match check_depth depth obj ty with
 215                   Some x -> x
 216                 | None ->
 217                     let rec tree_of_items tree_list i =
 218                       if !printer_steps < 0 || depth < 0 then
 219                         Oval_ellipsis :: tree_list
 220                       else if i < length then
 221                         let tree =
 222                           tree_of_val (depth - 1) (O.field obj i) ty_arg in
 223                         tree_of_items (tree :: tree_list) (i + 1)
 224                       else tree_list
 225                     in
 226                     Oval_array (List.rev (tree_of_items [] 0))
 227               else
 228                 Oval_array []
 229           | Tconstr (path, [ty_arg], _)
 230             when Path.same path Predef.path_lazy_t ->
 231               if Lazy.lazy_is_val (O.obj obj)
 232               then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
 233                    Oval_constr (Oide_ident "lazy", [v])
 234               else Oval_stuff "<lazy>"
 235           | Tconstr(path, ty_list, _) ->
 236               begin try
 237                 let decl = Env.find_type path env in
 238                 match decl with
 239                 | {type_kind = Type_abstract; type_manifest = None} ->
 240                     Oval_stuff "<abstr>"
 241                 | {type_kind = Type_abstract; type_manifest = Some body} ->
 242                     tree_of_val depth obj
 243                       (try Ctype.apply env decl.type_params body ty_list with
 244                          Ctype.Cannot_apply -> abstract_type)
 245                 | {type_kind = Type_variant constr_list} ->
 246                     let tag =
 247                       if O.is_block obj
 248                       then Cstr_block(O.tag obj)
 249                       else Cstr_constant(O.obj obj) in
 250                     let (constr_name, constr_args) =
 251                       Datarepr.find_constr_by_tag tag constr_list in
 252                     let ty_args =
 253                       List.map
 254                         (function ty ->
 255                            try Ctype.apply env decl.type_params ty ty_list with
 256                              Ctype.Cannot_apply -> abstract_type)
 257                         constr_args in
 258                     tree_of_constr_with_args (tree_of_constr env path)
 259                                            constr_name 0 depth obj ty_args
 260                 | {type_kind = Type_record(lbl_list, rep)} ->
 261                     begin match check_depth depth obj ty with
 262                       Some x -> x
 263                     | None ->
 264                         let rec tree_of_fields pos = function
 265                           | [] -> []
 266                           | (lbl_name, _, lbl_arg) :: remainder ->
 267                               let ty_arg =
 268                                 try
 269                                   Ctype.apply env decl.type_params lbl_arg
 270                                     ty_list
 271                                 with
 272                                   Ctype.Cannot_apply -> abstract_type in
 273                               let lid = tree_of_label env path lbl_name in
 274                               let v =
 275                                 tree_of_val (depth - 1) (O.field obj pos)
 276                                   ty_arg
 277                               in
 278                               (lid, v) :: tree_of_fields (pos + 1) remainder
 279                         in
 280                         Oval_record (tree_of_fields 0 lbl_list)
 281                     end
 282               with
 283                 Not_found ->                (* raised by Env.find_type *)
 284                   Oval_stuff "<abstr>"
 285               | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
 286                   Oval_stuff "<unknown constructor>"
 287               end
 288           | Tvariant row ->
 289               let row = Btype.row_repr row in
 290               if O.is_block obj then
 291                 let tag : int = O.obj (O.field obj 0) in
 292                 let rec find = function
 293                   | (l, f) :: fields ->
 294                       if Btype.hash_variant l = tag then
 295                         match Btype.row_field_repr f with
 296                         | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
 297                             let args =
 298                               tree_of_val (depth - 1) (O.field obj 1) ty in
 299                             Oval_variant (l, Some args)
 300                         | _ -> find fields
 301                       else find fields
 302                   | [] -> Oval_stuff "<variant>" in
 303                 find row.row_fields
 304               else
 305                 let tag : int = O.obj obj in
 306                 let rec find = function
 307                   | (l, _) :: fields ->
 308                       if Btype.hash_variant l = tag then
 309                         Oval_variant (l, None)
 310                       else find fields
 311                   | [] -> Oval_stuff "<variant>" in
 312                 find row.row_fields
 313           | Tobject (_, _) ->
 314               Oval_stuff "<obj>"
 315           | Tsubst ty ->
 316               tree_of_val (depth - 1) obj ty
 317           | Tfield(_, _, _, _) | Tnil | Tlink _ ->
 318               fatal_error "Printval.outval_of_value"
 319           | Tpoly (ty, _) ->
 320               tree_of_val (depth - 1) obj ty
 321           | Tunivar ->
 322               Oval_stuff "<poly>"
 323         end
 324
 325       and tree_of_val_list start depth obj ty_list =
 326         let rec tree_list i = function
 327           | [] -> []
 328           | ty :: ty_list ->
 329               let tree = tree_of_val (depth - 1) (O.field obj i) ty in
 330               tree :: tree_list (i + 1) ty_list in
 331       tree_list start ty_list
 332
 333       and tree_of_constr_with_args
 334              tree_of_cstr cstr_name start depth obj ty_args =
 335         let lid = tree_of_cstr cstr_name in
 336         let args = tree_of_val_list start depth obj ty_args in
 337         Oval_constr (lid, args)
 338
 339     and tree_of_exception depth bucket =
 340       let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
 341       let lid = Longident.parse name in
 342       try
 343         (* Attempt to recover the constructor description for the exn
 344            from its name *)
 345         let cstr = Env.lookup_constructor lid env in
 346         let path =
 347           match cstr.cstr_tag with
 348             Cstr_exception p -> p | _ -> raise Not_found in
 349         (* Make sure this is the right exception and not an homonym,
 350            by evaluating the exception found and comparing with the
 351            identifier contained in the exception bucket *)
 352         if not (EVP.same_value (O.field bucket 0) (EVP.eval_path path))
 353         then raise Not_found;
 354         tree_of_constr_with_args
 355            (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args
 356       with Not_found | EVP.Error ->
 357         match check_depth depth bucket ty with
 358           Some x -> x
 359         | None -> outval_of_untyped_exception bucket
 360
 361     in tree_of_val max_depth obj ty
 362
 363 end