typing/oprint.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*                  Projet Cristal, INRIA Rocquencourt                 *)
   6 (*                                                                     *)
   7 (*  Copyright 2002 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$ *)
  14
  15 open Format
  16 open Outcometree
  17
  18 exception Ellipsis
  19
  20 let cautious f ppf arg =
  21   try f ppf arg with
  22     Ellipsis -> fprintf ppf "..."
  23
  24 let rec print_ident ppf =
  25   function
  26     Oide_ident s -> fprintf ppf "%s" s
  27   | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s
  28   | Oide_apply (id1, id2) ->
  29       fprintf ppf "%a(%a)" print_ident id1 print_ident id2
  30
  31 let value_ident ppf name =
  32   if List.mem name
  33        ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] then
  34     fprintf ppf "( %s )" name
  35   else
  36     match name.[0] with
  37       'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' ->
  38         fprintf ppf "%s" name
  39     | _ -> fprintf ppf "( %s )" name
  40
  41 (* Values *)
  42
  43 let valid_float_lexeme s =
  44   let l = String.length s in
  45   let rec loop i =
  46     if i >= l then s ^ "." else
  47     match s.[i] with
  48     | '0' .. '9' | '-' -> loop (i+1)
  49     | _ -> s
  50   in loop 0
  51
  52 let float_repres f =
  53   match classify_float f with
  54     FP_nan -> "nan"
  55   | FP_infinite ->
  56       if f < 0.0 then "neg_infinity" else "infinity"
  57   | _ ->
  58       let s1 = Printf.sprintf "%.12g" f in
  59       if f = float_of_string s1 then valid_float_lexeme s1 else
  60       let s2 = Printf.sprintf "%.15g" f in
  61       if f = float_of_string s2 then valid_float_lexeme s2 else
  62       Printf.sprintf "%.18g" f
  63
  64 let parenthesize_if_neg ppf fmt v isneg =
  65   if isneg then pp_print_char ppf '(';
  66   fprintf ppf fmt v;
  67   if isneg then pp_print_char ppf ')'
  68
  69 let print_out_value ppf tree =
  70   let rec print_tree_1 ppf =
  71     function
  72     | Oval_constr (name, [param]) ->
  73         fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
  74     | Oval_constr (name, (_ :: _ as params)) ->
  75         fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
  76           (print_tree_list print_tree_1 ",") params
  77     | Oval_variant (name, Some param) ->
  78         fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
  79     | tree -> print_simple_tree ppf tree
  80   and print_constr_param ppf = function
  81     | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
  82     | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
  83     | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
  84     | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
  85     | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
  86     | tree -> print_simple_tree ppf tree
  87   and print_simple_tree ppf =
  88     function
  89       Oval_int i -> fprintf ppf "%i" i
  90     | Oval_int32 i -> fprintf ppf "%lil" i
  91     | Oval_int64 i -> fprintf ppf "%LiL" i
  92     | Oval_nativeint i -> fprintf ppf "%nin" i
  93     | Oval_float f -> fprintf ppf "%s" (float_repres f)
  94     | Oval_char c -> fprintf ppf "%C" c
  95     | Oval_string s ->
  96         begin try fprintf ppf "%S" s with
  97           Invalid_argument "String.create" -> fprintf ppf "<huge string>"
  98         end
  99     | Oval_list tl ->
 100         fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
 101     | Oval_array tl ->
 102         fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
 103     | Oval_constr (name, []) -> print_ident ppf name
 104     | Oval_variant (name, None) -> fprintf ppf "`%s" name
 105     | Oval_stuff s -> fprintf ppf "%s" s
 106     | Oval_record fel ->
 107         fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
 108     | Oval_ellipsis -> raise Ellipsis
 109     | Oval_printer f -> f ppf
 110     | Oval_tuple tree_list ->
 111         fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
 112     | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
 113   and print_fields first ppf =
 114     function
 115       [] -> ()
 116     | (name, tree) :: fields ->
 117         if not first then fprintf ppf ";@ ";
 118         fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
 119           tree;
 120         print_fields false ppf fields
 121   and print_tree_list print_item sep ppf tree_list =
 122     let rec print_list first ppf =
 123       function
 124         [] -> ()
 125       | tree :: tree_list ->
 126           if not first then fprintf ppf "%s@ " sep;
 127           print_item ppf tree;
 128           print_list false ppf tree_list
 129     in
 130     cautious (print_list true) ppf tree_list
 131   in
 132   cautious print_tree_1 ppf tree
 133
 134 let out_value = ref print_out_value
 135
 136 (* Types *)
 137
 138 let rec print_list_init pr sep ppf =
 139   function
 140     [] -> ()
 141   | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
 142
 143 let rec print_list pr sep ppf =
 144   function
 145     [] -> ()
 146   | [a] -> pr ppf a
 147   | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
 148
 149 let pr_present =
 150   print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
 151
 152 let pr_vars =
 153   print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")
 154
 155 let rec print_out_type ppf =
 156   function
 157   | Otyp_alias (ty, s) ->
 158       fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
 159   | Otyp_poly (sl, ty) ->
 160       fprintf ppf "@[<hov 2>%a.@ %a@]"
 161         pr_vars sl
 162         print_out_type ty
 163   | ty ->
 164       print_out_type_1 ppf ty
 165
 166 and print_out_type_1 ppf =
 167   function
 168     Otyp_arrow (lab, ty1, ty2) ->
 169       fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
 170         print_out_type_2 ty1 print_out_type_1 ty2
 171   | ty -> print_out_type_2 ppf ty
 172 and print_out_type_2 ppf =
 173   function
 174     Otyp_tuple tyl ->
 175       fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
 176   | ty -> print_simple_out_type ppf ty
 177 and print_simple_out_type ppf =
 178   function
 179     Otyp_class (ng, id, tyl) ->
 180       fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
 181         print_ident id
 182   | Otyp_constr (id, tyl) ->
 183       fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
 184   | Otyp_object (fields, rest) ->
 185       fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
 186   | Otyp_stuff s -> fprintf ppf "%s" s
 187   | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
 188   | Otyp_variant (non_gen, row_fields, closed, tags) ->
 189       let print_present ppf =
 190         function
 191           None | Some [] -> ()
 192         | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
 193       in
 194       let print_fields ppf =
 195         function
 196           Ovar_fields fields ->
 197             print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
 198               ppf fields
 199         | Ovar_name (id, tyl) ->
 200             fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
 201       in
 202       fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
 203         (if closed then if tags = None then " " else "< "
 204          else if tags = None then "> " else "? ")
 205         print_fields row_fields
 206         print_present tags
 207   | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
 208       fprintf ppf "@[<1>(%a)@]" print_out_type ty
 209   | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
 210 and print_fields rest ppf =
 211   function
 212     [] ->
 213       begin match rest with
 214         Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
 215       | None -> ()
 216       end
 217   | [s, t] ->
 218       fprintf ppf "%s : %a" s print_out_type t;
 219       begin match rest with
 220         Some _ -> fprintf ppf ";@ "
 221       | None -> ()
 222       end;
 223       print_fields rest ppf []
 224   | (s, t) :: l ->
 225       fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
 226 and print_row_field ppf (l, opt_amp, tyl) =
 227   let pr_of ppf =
 228     if opt_amp then fprintf ppf " of@ &@ "
 229     else if tyl <> [] then fprintf ppf " of@ "
 230     else fprintf ppf ""
 231   in
 232   fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
 233     tyl
 234 and print_typlist print_elem sep ppf =
 235   function
 236     [] -> ()
 237   | [ty] -> print_elem ppf ty
 238   | ty :: tyl ->
 239       fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep)
 240         tyl
 241 and print_typargs ppf =
 242   function
 243     [] -> ()
 244   | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
 245   | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl
 246
 247 let out_type = ref print_out_type
 248
 249 (* Class types *)
 250
 251 let type_parameter ppf (ty, (co, cn)) =
 252   fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
 253     (*if co then if cn then "!" else "+" else if cn then "-" else "?"*)
 254     ty
 255
 256 let print_out_class_params ppf =
 257   function
 258     [] -> ()
 259   | tyl ->
 260       fprintf ppf "@[<1>[%a]@]@ "
 261         (print_list type_parameter (fun ppf -> fprintf ppf ", "))
 262         tyl
 263
 264 let rec print_out_class_type ppf =
 265   function
 266     Octy_constr (id, tyl) ->
 267       let pr_tyl ppf =
 268         function
 269           [] -> ()
 270         | tyl ->
 271             fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
 272       in
 273       fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
 274   | Octy_fun (lab, ty, cty) ->
 275       fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
 276         print_out_type_2 ty print_out_class_type cty
 277   | Octy_signature (self_ty, csil) ->
 278       let pr_param ppf =
 279         function
 280           Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
 281         | None -> ()
 282       in
 283       fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
 284         (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
 285         csil
 286 and print_out_class_sig_item ppf =
 287   function
 288     Ocsg_constraint (ty1, ty2) ->
 289       fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
 290         !out_type ty2
 291   | Ocsg_method (name, priv, virt, ty) ->
 292       fprintf ppf "@[<2>method %s%s%s :@ %a@]"
 293         (if priv then "private " else "") (if virt then "virtual " else "")
 294         name !out_type ty
 295   | Ocsg_value (name, mut, vr, ty) ->
 296       fprintf ppf "@[<2>val %s%s%s :@ %a@]"
 297         (if mut then "mutable " else "")
 298         (if vr then "virtual " else "")
 299         name !out_type ty
 300
 301 let out_class_type = ref print_out_class_type
 302
 303 (* Signature *)
 304
 305 let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
 306 let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
 307 let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
 308
 309 let rec print_out_module_type ppf =
 310   function
 311     Omty_abstract -> ()
 312   | Omty_functor (name, mty_arg, mty_res) ->
 313       fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
 314         print_out_module_type mty_arg print_out_module_type mty_res
 315   | Omty_ident id -> fprintf ppf "%a" print_ident id
 316   | Omty_signature sg ->
 317       fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" !out_signature sg
 318 and print_out_signature ppf =
 319   function
 320     [] -> ()
 321   | [item] -> !out_sig_item ppf item
 322   | item :: items ->
 323       fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
 324 and print_out_sig_item ppf =
 325   function
 326     Osig_class (vir_flag, name, params, clt, rs) ->
 327       fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
 328         (if rs = Orec_next then "and" else "class")
 329         (if vir_flag then " virtual" else "") print_out_class_params params
 330         name !out_class_type clt
 331   | Osig_class_type (vir_flag, name, params, clt, rs) ->
 332       fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
 333         (if rs = Orec_next then "and" else "class type")
 334         (if vir_flag then " virtual" else "") print_out_class_params params
 335         name !out_class_type clt
 336   | Osig_exception (id, tyl) ->
 337       fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
 338   | Osig_modtype (name, Omty_abstract) ->
 339       fprintf ppf "@[<2>module type %s@]" name
 340   | Osig_modtype (name, mty) ->
 341       fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
 342   | Osig_module (name, mty, rs) ->
 343       fprintf ppf "@[<2>%s %s :@ %a@]"
 344         (match rs with Orec_not -> "module"
 345                      | Orec_first -> "module rec"
 346                      | Orec_next -> "and")
 347         name !out_module_type mty
 348   | Osig_type(td, rs) ->
 349         print_out_type_decl
 350           (if rs = Orec_next then "and" else "type")
 351           ppf td
 352   | Osig_value (name, ty, prims) ->
 353       let kwd = if prims = [] then "val" else "external" in
 354       let pr_prims ppf =
 355         function
 356           [] -> ()
 357         | s :: sl ->
 358             fprintf ppf "@ = \"%s\"" s;
 359             List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
 360       in
 361       fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type
 362         ty pr_prims prims
 363
 364 and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
 365   let print_constraints ppf params =
 366     List.iter
 367       (fun (ty1, ty2) ->
 368          fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
 369            !out_type ty2)
 370       params
 371   in
 372   let type_defined ppf =
 373     match args with
 374       [] -> fprintf ppf "%s" name
 375     | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
 376     | _ ->
 377         fprintf ppf "@[(@[%a)@]@ %s@]"
 378           (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args name
 379   in
 380   let print_manifest ppf =
 381     function
 382       Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
 383     | _ -> ()
 384   in
 385   let print_name_args ppf =
 386     fprintf ppf "%s %t%a" kwd type_defined print_manifest ty
 387   in
 388   let ty =
 389     match ty with
 390       Otyp_manifest (_, ty) -> ty
 391     | _ -> ty
 392   in
 393   let print_private ppf = function
 394     Asttypes.Private -> fprintf ppf " private"
 395   | Asttypes.Public -> () in
 396   let rec print_out_tkind ppf = function
 397   | Otyp_abstract -> ()
 398   | Otyp_record lbls ->
 399       fprintf ppf " =%a {%a@;<1 -2>}"
 400         print_private priv
 401         (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
 402   | Otyp_sum constrs ->
 403       fprintf ppf " =%a@;<1 2>%a"
 404         print_private priv
 405         (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
 406   | ty ->
 407       fprintf ppf " =%a@;<1 2>%a"
 408         print_private priv
 409         !out_type ty
 410   in
 411   fprintf ppf "@[<2>@[<hv 2>%t%a@]%a@]"
 412     print_name_args
 413     print_out_tkind ty
 414     print_constraints constraints
 415 and print_out_constr ppf (name, tyl) =
 416   match tyl with
 417     [] -> fprintf ppf "%s" name
 418   | _ ->
 419       fprintf ppf "@[<2>%s of@ %a@]" name
 420         (print_typlist print_simple_out_type " *") tyl
 421 and print_out_label ppf (name, mut, arg) =
 422   fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
 423     !out_type arg
 424
 425 let _ = out_module_type := print_out_module_type
 426 let _ = out_signature := print_out_signature
 427 let _ = out_sig_item := print_out_sig_item
 428
 429 (* Phrases *)
 430
 431 let print_out_exception ppf exn outv =
 432   match exn with
 433     Sys.Break -> fprintf ppf "Interrupted.@."
 434   | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
 435   | Stack_overflow ->
 436       fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
 437   | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
 438
 439 let rec print_items ppf =
 440   function
 441     [] -> ()
 442   | (tree, valopt) :: items ->
 443       begin match valopt with
 444         Some v ->
 445           fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
 446             !out_value v
 447       | None -> fprintf ppf "@[%a@]" !out_sig_item tree
 448       end;
 449       if items <> [] then fprintf ppf "@ %a" print_items items
 450
 451 let print_out_phrase ppf =
 452   function
 453     Ophr_eval (outv, ty) ->
 454       fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
 455   | Ophr_signature [] -> ()
 456   | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
 457   | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
 458
 459 let out_phrase = ref print_out_phrase