Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

#5377: add a #show directive to the toplevel.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14618 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit ec52baed6feff734f7e75070cbb1df9d58911c9a 1 parent cd5e18a
@alainfrisch alainfrisch authored
Showing with 93 additions and 1 deletion.
  1. +93 −1 toplevel/topdirs.ml
View
94 toplevel/topdirs.ml
@@ -318,6 +318,93 @@ let parse_warnings ppf iserr s =
try Warnings.parse_options iserr s
with Arg.Bad err -> fprintf ppf "%s.@." err
+(* Typing information *)
+
+let rec trim_modtype = function
+ Mty_signature _ -> Mty_signature []
+ | Mty_functor (id, mty, mty') ->
+ Mty_functor (id, mty, trim_modtype mty')
+ | Mty_ident _ | Mty_alias _ as mty -> mty
+
+let trim_signature = function
+ Mty_signature sg ->
+ Mty_signature
+ (List.map
+ (function
+ Sig_module (id, md, rs) ->
+ Sig_module (id, {md with md_type = trim_modtype md.md_type},
+ rs)
+ (*| Sig_modtype (id, Modtype_manifest mty) ->
+ Sig_modtype (id, Modtype_manifest (trim_modtype mty))*)
+ | item -> item)
+ sg)
+ | mty -> mty
+
+let dir_show ppf args =
+ let open Parsetree in
+ let id lid =
+ let s = match lid with
+ Longident.Lident s -> s
+ | Longident.Ldot (_,s) -> s
+ | Longident.Lapply _ ->
+ fprintf ppf "Invalid path %a@." Printtyp.longident lid;
+ raise Exit
+ in
+ Ident.create_persistent s
+ in
+ let env = !Toploop.toplevel_env in
+ try
+ let loc = Location.none in
+ let item =
+ match args with
+ | [ Pdir_keyword "val"; Pdir_ident lid ] ->
+ let id = id lid in
+ let path, desc = Typetexp.find_value env loc lid in
+ Sig_value (id, desc)
+ | [ Pdir_keyword "type"; Pdir_ident lid ] ->
+ let id = id lid in
+ let path, desc = Typetexp.find_type env loc lid in
+ Sig_type (id, desc, Trec_not)
+ | [ Pdir_keyword "exception"; Pdir_ident lid ] ->
+ let id = id lid in
+ let desc = Typetexp.find_constructor env loc lid in
+ begin match desc.cstr_tag with
+ | Cstr_constant _ | Cstr_block _ ->
+ fprintf ppf "@[This constructor is not an exception.@]@.";
+ raise Exit
+ | Cstr_exception _ ->
+ Sig_exception (id, {exn_args=desc.cstr_args;
+ exn_loc=desc.cstr_loc;
+ exn_attributes=desc.cstr_attributes;
+ })
+ end
+ | [ Pdir_keyword "module"; Pdir_ident lid ] ->
+ let id = id lid in
+ let path = Typetexp.find_module env loc lid in
+ let md = Env.find_module path env in
+ Sig_module (id, {md with md_type = trim_signature md.md_type},
+ Trec_not)
+ | [ Pdir_keyword "module"; Pdir_keyword "type"; Pdir_ident lid ] ->
+ let id = id lid in
+ let path, desc = Typetexp.find_modtype env loc lid in
+ Sig_modtype (id, desc)
+ | [ Pdir_keyword "class"; Pdir_ident lid ] ->
+ let id = id lid in
+ let path, desc = Typetexp.find_class env loc lid in
+ Sig_class (id, desc, Trec_not)
+ | [ Pdir_keyword "class"; Pdir_keyword "type"; Pdir_ident lid ] ->
+ let id = id lid in
+ let path, desc = Typetexp.find_class_type env loc lid in
+ Sig_class_type (id, desc, Trec_not)
+ | _ -> fprintf ppf "@[Bad usage for #show@]@."; raise Exit
+ in
+ fprintf ppf "@[%a@]@." Printtyp.signature [item]
+ with
+ | Not_found ->
+ fprintf ppf "@[Unknown element.@]@."
+ | Exit ->
+ ()
+
let _ =
Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
@@ -346,4 +433,9 @@ let _ =
(Directive_string (parse_warnings std_out false));
Hashtbl.add directive_table "warn_error"
- (Directive_string (parse_warnings std_out true))
+ (Directive_string (parse_warnings std_out true));
+
+ Hashtbl.add directive_table "show"
+ (Directive_generic (dir_show std_out));
+
+ ()
Please sign in to comment.
Something went wrong with that request. Please try again.