File: odoc_print.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 (103 lines) | stat: -rw-r--r-- 3,923 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
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Maxence Guesdon, projet Cristal, INRIA Rocquencourt        *)
(*                                                                        *)
(*   Copyright 2001 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.          *)
(*                                                                        *)
(**************************************************************************)

open Format

let new_fmt () =
  let buf = Buffer.create 512 in
  let fmt = formatter_of_buffer buf in
  let flush () =
    pp_print_flush fmt ();
    let s = Buffer.contents buf in
    Buffer.reset buf ;
    s
  in
  (fmt, flush)

let (type_fmt, flush_type_fmt) = new_fmt ()
let _ =
  let outfuns = pp_get_formatter_out_functions type_fmt () in
  pp_set_formatter_out_functions type_fmt
    {outfuns with out_newline = fun () -> outfuns.out_string "\n  " 0 3}

let (modtype_fmt, flush_modtype_fmt) = new_fmt ()




let string_of_type_expr t =
  Printtyp.mark_loops t;
  Printtyp.type_scheme_max ~b_reset_names: false type_fmt t;
  flush_type_fmt ()

exception Use_code of string

(** Return the given module type where methods and vals have been removed
   from the signatures. Used when we don't want to print a too long module type.
   @param code when the code is given, we raise the [Use_code] exception is we
   encouter a signature, to that the calling function can use the code rather
   than the "emptied" type.
*)
let simpl_module_type ?code t =
  let rec iter t =
    match t with
      Types.Mty_ident _
    | Types.Mty_alias(_, _) -> t
    | Types.Mty_signature _ ->
        (
         match code with
           None -> Types.Mty_signature []
         | Some s -> raise (Use_code s)
        )
    | Types.Mty_functor (id, mt1, mt2) ->
        Types.Mty_functor (id, Misc.may_map iter mt1, iter mt2)
  in
  iter t

let string_of_module_type ?code ?(complete=false) t =
  try
    let t2 = if complete then t else simpl_module_type ?code t in
    Printtyp.modtype modtype_fmt t2;
    flush_modtype_fmt ()
  with
    Use_code s -> s

(** Return the given class type where methods and vals have been removed
   from the signatures. Used when we don't want to print a too long class type.*)
let simpl_class_type t =
  let rec iter t =
    match t with
      Types.Cty_constr _ -> t
    | Types.Cty_signature cs ->
        (* we delete vals and methods in order to not print them when
           displaying the type *)
        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
        Types.Cty_signature { Types.csig_self = { cs.Types.csig_self with
                                                  Types.desc = Types.Tobject (tnil, ref None) };
                              csig_vars = Types.Vars.empty ;
                              csig_concr = Types.Concr.empty ;
                              csig_inher = []
                             }
    | Types.Cty_arrow (l, texp, ct) ->
        let new_ct = iter ct in
        Types.Cty_arrow (l, texp, new_ct)
  in
  iter t

let string_of_class_type ?(complete=false) t =
  let t2 = if complete then t else simpl_class_type t in
  (* FIXME : my own Printtyp.class_type variant to avoid reset_names *)
  Printtyp.class_type modtype_fmt t2;
  flush_modtype_fmt ()