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
104
105
106
107
108
109
110
111
112
113
|
(**************************************************************************)
(* *)
(* 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 () = Printtyp.Naming_context.enable false
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.shared_type_scheme 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 if we
encounter a signature, so that the calling function can use the code rather
than the "emptied" type.
*)
let simpl_module_type ?code t =
let open Types in
let rec iter t =
match t with
Mty_ident _
| Mty_alias _ -> t
| Mty_signature _ ->
(
match code with
None -> Mty_signature []
| Some s -> raise (Use_code s)
)
| Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
| Mty_functor (Named (name, mt1), mt2) ->
Mty_functor (Named (name, 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 =
let open Types in
match t with
Cty_constr _ -> t
| Cty_signature cs ->
(* we delete vals and methods in order to not print them when
displaying the type *)
let self_row =
Transient_expr.create Tnil
~level:0 ~scope:Btype.lowest_level ~id:0
in
let tself =
let t = cs.csig_self in
let desc = Tobject (Transient_expr.type_expr self_row, ref None) in
Transient_expr.create desc
~level:(get_level t) ~scope:(get_scope t) ~id:(get_id t)
in
Types.Cty_signature { csig_self = Transient_expr.type_expr tself;
csig_self_row = Transient_expr.type_expr self_row;
csig_vars = Vars.empty ;
csig_meths = Meths.empty ; }
| Types.Cty_arrow (l, texp, ct) ->
let new_ct = iter ct in
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 ()
|
