l4/pkg/ocaml/contrib/camlp4/Camlp4Top/Rprint.ml

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