A patch adding primitives to browse types in the toplevel

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

1 files changed, 141 insertions, 0 deletions

diff --git a/experimental/garrigue/show_types.diffs b/experimental/garrigue/show_types.diffs
new file mode 100644
index 0000000000..98c83e39a9
--- /dev/null
+++ b/experimental/garrigue/show_types.diffs
@@ -0,0 +1,141 @@
+Index: typing/printtyp.ml
+===================================================================
+--- typing/printtyp.ml	(revision 11316)
++++ typing/printtyp.ml	(working copy)
+@@ -894,8 +894,10 @@
+       tree_of_class_declaration id decl rs :: tree_of_signature rem
+   | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
+       tree_of_cltype_declaration id decl rs :: tree_of_signature rem
+-  | _ ->
+-      assert false
++  | Tsig_class(id, decl, rs) :: _ ->
++      tree_of_class_declaration id decl rs :: []
++  | Tsig_cltype(id, decl, rs) :: _ ->
++      tree_of_cltype_declaration id decl rs :: []
+ 
+ and tree_of_modtype_declaration id decl =
+   let mty =
+Index: toplevel/topdirs.ml
+===================================================================
+--- toplevel/topdirs.ml	(revision 11316)
++++ toplevel/topdirs.ml	(working copy)
+@@ -297,10 +297,73 @@
+     !traced_functions;
+   traced_functions := []
+ 
++(* Warnings *)
++
+ let parse_warnings ppf iserr s =
+   try Warnings.parse_options iserr s
+   with Arg.Bad err -> fprintf ppf "%s.@." err
+ 
++(* Typing information *)
++
++type pkind =
++    Pvalue
++  | Ptype
++  | Pexception
++  | Pmodule
++  | Pmodtype
++  | Pclass
++  | Pcltype
++
++let name_of_kind = function
++    Pvalue -> "value"
++  | Ptype -> "type"
++  | Pexception -> "exception"
++  | Pmodule -> "module"
++  | Pmodtype -> "module type"
++  | Pclass -> "class"
++  | Pcltype -> "class type"
++
++let show_type ppf kind lid =
++  let env = !Toploop.toplevel_env in
++  try
++    let id =
++      let s = match lid with
++        Longident.Lident s -> s
++      | Longident.Ldot (_,s) -> s
++      | Longident.Lapply _ -> failwith "invalid"
++      in Ident.create_persistent s
++    in
++    let item =
++      match kind with
++        Pvalue ->
++          let path, desc = Env.lookup_value lid env in
++          Tsig_value (id, desc)
++      | Ptype ->
++          let path, desc = Env.lookup_type lid env in
++          Tsig_type (id, desc, Trec_not)
++      | Pexception ->
++          let desc = Env.lookup_constructor lid env in
++          Tsig_exception (id, desc.cstr_args)
++      | Pmodule ->
++          let path, desc = Env.lookup_module lid env in
++          Tsig_module (id, desc, Trec_not)
++      | Pmodtype ->
++          let path, desc = Env.lookup_modtype lid env in
++          Tsig_modtype (id, desc)
++      | Pclass ->
++          let path, desc = Env.lookup_class lid env in
++          Tsig_class (id, desc, Trec_not)
++      | Pcltype ->
++          let path, desc = Env.lookup_cltype lid env in
++          Tsig_cltype (id, desc, Trec_not)
++    in
++    fprintf ppf "%a@." Printtyp.signature [item]
++  with
++    Not_found ->
++      fprintf ppf "Unknown %s.@." (name_of_kind kind)
++  | Failure "invalid" ->
++      fprintf ppf "Invalid path %a@." Printtyp.longident lid
++
+ let _ =
+   Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
+   Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
+@@ -329,4 +392,19 @@
+              (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_value"
++             (Directive_ident (show_type std_out Pvalue));
++  Hashtbl.add directive_table "show_type"
++             (Directive_ident (show_type std_out Ptype));
++  Hashtbl.add directive_table "show_exception"
++             (Directive_ident (show_type std_out Pexception));
++  Hashtbl.add directive_table "show_module"
++             (Directive_ident (show_type std_out Pmodule));
++  Hashtbl.add directive_table "show_module_type"
++             (Directive_ident (show_type std_out Pmodtype));
++  Hashtbl.add directive_table "show_class"
++             (Directive_ident (show_type std_out Pclass));
++  Hashtbl.add directive_table "show_class_type"
++             (Directive_ident (show_type std_out Pcltype))
+Index: parsing/parser.mly
+===================================================================
+--- parsing/parser.mly	(revision 11316)
++++ parsing/parser.mly	(working copy)
+@@ -1769,6 +1769,11 @@
+     LIDENT                                      { Lident $1 }
+   | mod_longident DOT LIDENT                    { Ldot($1, $3) }
+ ;
++any_longident:
++    val_ident                                   { Lident $1 }
++  | mod_longident DOT val_ident                 { Ldot($1, $3) }
++  | mod_longident                               { $1 }
++;
+ 
+ /* Toplevel directives */
+ 
+@@ -1776,7 +1781,7 @@
+     SHARP ident                 { Ptop_dir($2, Pdir_none) }
+   | SHARP ident STRING          { Ptop_dir($2, Pdir_string $3) }
+   | SHARP ident INT             { Ptop_dir($2, Pdir_int $3) }
+-  | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
++  | SHARP ident any_longident   { Ptop_dir($2, Pdir_ident $3) }
+   | SHARP ident FALSE           { Ptop_dir($2, Pdir_bool false) }
+   | SHARP ident TRUE            { Ptop_dir($2, Pdir_bool true) }
+ ;