2016-02-18 07:11:59 -08:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* 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. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
2004-03-05 06:57:52 -08:00
|
|
|
|
|
|
|
open Format
|
2018-06-26 13:03:45 -07:00
|
|
|
let () = Printtyp.Naming_context.enable false
|
2004-03-05 06:57:52 -08:00
|
|
|
|
|
|
|
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 ;
|
2010-01-22 04:48:24 -08:00
|
|
|
s
|
2004-03-05 06:57:52 -08:00
|
|
|
in
|
|
|
|
(fmt, flush)
|
|
|
|
|
|
|
|
let (type_fmt, flush_type_fmt) = new_fmt ()
|
|
|
|
let _ =
|
2014-08-22 06:45:02 -07:00
|
|
|
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}
|
2004-03-05 06:57:52 -08:00
|
|
|
|
|
|
|
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 ()
|
|
|
|
|
2004-03-26 01:09:50 -08:00
|
|
|
exception Use_code of string
|
|
|
|
|
2004-03-05 06:57:52 -08:00
|
|
|
(** Return the given module type where methods and vals have been removed
|
2004-03-26 01:09:50 -08:00
|
|
|
from the signatures. Used when we don't want to print a too long module type.
|
2017-08-10 03:59:23 -07:00
|
|
|
@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
|
2004-03-26 01:09:50 -08:00
|
|
|
than the "emptied" type.
|
|
|
|
*)
|
|
|
|
let simpl_module_type ?code t =
|
2019-10-09 06:15:37 -07:00
|
|
|
let open Types in
|
2004-03-05 06:57:52 -08:00
|
|
|
let rec iter t =
|
|
|
|
match t with
|
2019-10-09 06:15:37 -07:00
|
|
|
Mty_ident _
|
|
|
|
| Mty_alias _ -> t
|
|
|
|
| Mty_signature _ ->
|
2010-01-22 04:48:24 -08:00
|
|
|
(
|
|
|
|
match code with
|
2019-10-09 06:15:37 -07:00
|
|
|
None -> Mty_signature []
|
2010-01-22 04:48:24 -08:00
|
|
|
| Some s -> raise (Use_code s)
|
|
|
|
)
|
2019-10-09 06:15:37 -07:00
|
|
|
| Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
|
|
|
|
| Mty_functor (Named (name, mt1), mt2) ->
|
|
|
|
Mty_functor (Named (name, iter mt1), iter mt2)
|
2004-03-05 06:57:52 -08:00
|
|
|
in
|
|
|
|
iter t
|
|
|
|
|
2004-03-26 01:09:50 -08:00
|
|
|
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
|
2004-03-05 06:57:52 -08:00
|
|
|
|
|
|
|
(** 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
|
2016-03-09 15:21:42 -08:00
|
|
|
Types.Cty_constr _ -> t
|
2012-05-30 07:52:37 -07:00
|
|
|
| Types.Cty_signature cs ->
|
2016-02-16 04:23:31 -08:00
|
|
|
(* we delete vals and methods in order to not print them when
|
2015-10-09 13:41:51 -07:00
|
|
|
displaying the type *)
|
2018-02-12 08:37:34 -08:00
|
|
|
let tnil =
|
2018-09-26 15:14:43 -07:00
|
|
|
{ Types.desc = Types.Tnil ; Types.level = 0
|
|
|
|
; Types.scope = Btype.lowest_level ; Types.id = 0 }
|
2018-02-12 08:37:34 -08:00
|
|
|
in
|
2013-09-27 08:04:03 -07:00
|
|
|
Types.Cty_signature { Types.csig_self = { cs.Types.csig_self with
|
2004-03-05 06:57:52 -08:00
|
|
|
Types.desc = Types.Tobject (tnil, ref None) };
|
2013-09-27 08:04:03 -07:00
|
|
|
csig_vars = Types.Vars.empty ;
|
|
|
|
csig_concr = Types.Concr.empty ;
|
|
|
|
csig_inher = []
|
2004-03-05 06:57:52 -08:00
|
|
|
}
|
2013-04-16 01:59:09 -07:00
|
|
|
| Types.Cty_arrow (l, texp, ct) ->
|
2004-03-05 06:57:52 -08:00
|
|
|
let new_ct = iter ct in
|
2013-04-16 01:59:09 -07:00
|
|
|
Types.Cty_arrow (l, texp, new_ct)
|
2004-03-05 06:57:52 -08:00
|
|
|
in
|
|
|
|
iter t
|
|
|
|
|
2010-01-22 04:48:24 -08:00
|
|
|
let string_of_class_type ?(complete=false) t =
|
2004-03-05 06:57:52 -08:00
|
|
|
let t2 = if complete then t else simpl_class_type t in
|
2015-10-09 13:41:51 -07:00
|
|
|
(* FIXME : my own Printtyp.class_type variant to avoid reset_names *)
|
2004-03-05 06:57:52 -08:00
|
|
|
Printtyp.class_type modtype_fmt t2;
|
|
|
|
flush_modtype_fmt ()
|