ocamldoc/odoc_print.ml

   1 (***********************************************************************)
   2 (*                             OCamldoc                                *)
   3 (*                                                                     *)
   4 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
   5 (*                                                                     *)
   6 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13
  14 open Format
  15
  16 let new_fmt () =
  17   let buf = Buffer.create 512 in
  18   let fmt = formatter_of_buffer buf in
  19   let flush () =
  20     pp_print_flush fmt ();
  21     let s = Buffer.contents buf in
  22     Buffer.reset buf ;
  23     s
  24   in
  25   (fmt, flush)
  26
  27 let (type_fmt, flush_type_fmt) = new_fmt ()
  28 let _ =
  29   let (out, flush, outnewline, outspace) =
  30     pp_get_all_formatter_output_functions type_fmt ()
  31   in
  32   pp_set_all_formatter_output_functions type_fmt
  33     ~out ~flush
  34     ~newline: (fun () -> out "\n  " 0 3)
  35     ~spaces: outspace
  36
  37 let (modtype_fmt, flush_modtype_fmt) = new_fmt ()
  38
  39
  40
  41
  42 let string_of_type_expr t =
  43   Printtyp.mark_loops t;
  44   Printtyp.type_scheme_max ~b_reset_names: false type_fmt t;
  45   flush_type_fmt ()
  46
  47 exception Use_code of string
  48
  49 (** Return the given module type where methods and vals have been removed
  50    from the signatures. Used when we don't want to print a too long module type.
  51    @param code when the code is given, we raise the [Use_code] exception is we
  52    encouter a signature, to that the calling function can use the code rather
  53    than the "emptied" type.
  54 *)
  55 let simpl_module_type ?code t =
  56   let rec iter t =
  57     match t with
  58       Types.Tmty_ident p -> t
  59     | Types.Tmty_signature _ ->
  60         (
  61          match code with
  62            None -> Types.Tmty_signature []
  63          | Some s -> raise (Use_code s)
  64         )
  65     | Types.Tmty_functor (id, mt1, mt2) ->
  66         Types.Tmty_functor (id, iter mt1, iter mt2)
  67   in
  68   iter t
  69
  70 let string_of_module_type ?code ?(complete=false) t =
  71   try
  72     let t2 = if complete then t else simpl_module_type ?code t in
  73     Printtyp.modtype modtype_fmt t2;
  74     flush_modtype_fmt ()
  75   with
  76     Use_code s -> s
  77
  78 (** Return the given class type where methods and vals have been removed
  79    from the signatures. Used when we don't want to print a too long class type.*)
  80 let simpl_class_type t =
  81   let rec iter t =
  82     match t with
  83       Types.Tcty_constr (p,texp_list,ct) -> t
  84     | Types.Tcty_signature cs ->
  85         (* on vire les vals et methods pour ne pas qu'elles soient imprimées
  86            quand on affichera le type *)
  87         let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
  88         Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with
  89                                                   Types.desc = Types.Tobject (tnil, ref None) };
  90                                Types.cty_vars = Types.Vars.empty ;
  91                                Types.cty_concr = Types.Concr.empty ;
  92                                Types.cty_inher = []
  93                              }
  94     | Types.Tcty_fun (l, texp, ct) ->
  95         let new_ct = iter ct in
  96         Types.Tcty_fun (l, texp, new_ct)
  97   in
  98   iter t
  99
 100 let string_of_class_type ?(complete=false) t =
 101   let t2 = if complete then t else simpl_class_type t in
 102   (* A VOIR : ma propre version de Printtyp.class_type pour ne pas faire reset_names *)
 103   Printtyp.class_type modtype_fmt t2;
 104   flush_modtype_fmt ()