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

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14618 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

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));
+
+  ()