1 files changed, 87 insertions, 59 deletions

diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index fe5e393714..f9d383380e 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -340,70 +340,101 @@ let trim_signature = function
            sg)
   | mty -> mty
 
-let dir_show ppf args =
-  let open Parsetree in
-  let id lid =
-    let s = match lid with
-        Longident.Lident s -> s
+let show_prim to_sig ppf lid =
+  let env = !Toploop.toplevel_env in
+  let loc = Location.none in
+  try
+    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]
+    let id = Ident.create_persistent s in
+    let sg = to_sig env loc id lid in
+    fprintf ppf "@[%a@]@." Printtyp.signature sg
   with
   | Not_found ->
       fprintf ppf "@[Unknown element.@]@."
-  | Exit ->
-      ()
+  | Exit -> ()
+
+let all_show_funs = ref []
+
+let reg_show_prim name to_sig =
+  all_show_funs := to_sig :: !all_show_funs;
+  Hashtbl.add directive_table name (Directive_ident (show_prim to_sig std_out))
+
+let () =
+  reg_show_prim "show_val"
+    (fun env loc id lid ->
+       let path, desc = Typetexp.find_value env loc lid in
+       [ Sig_value (id, desc) ]
+    )
+
+let () =
+  reg_show_prim "show_type"
+    (fun env loc id lid ->
+       let path, desc = Typetexp.find_type env loc lid in
+       [ Sig_type (id, desc, Trec_not) ]
+    )
+
+let () =
+  reg_show_prim "show_exception"
+    (fun env loc id lid ->
+       let desc = Typetexp.find_constructor env loc lid in
+       match desc.cstr_tag with
+       | Cstr_constant _ | Cstr_block _ ->
+           raise Not_found
+       | Cstr_exception _ ->
+           [ Sig_exception (id, {exn_args=desc.cstr_args;
+                                 exn_loc=desc.cstr_loc;
+                                 exn_attributes=desc.cstr_attributes;
+                                }) ]
+    )
+
+let () =
+  reg_show_prim "show_module"
+    (fun env loc id lid ->
+       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) ]
+    )
+
+let () =
+  reg_show_prim "show_module_type"
+    (fun env loc id lid ->
+       let path, desc = Typetexp.find_modtype env loc lid in
+       [ Sig_modtype (id, desc) ]
+    )
+
+let () =
+  reg_show_prim "show_class"
+    (fun env loc id lid ->
+       let path, desc = Typetexp.find_class env loc lid in
+       [ Sig_class (id, desc, Trec_not) ]
+    )
+
+let () =
+  reg_show_prim "show_class_type"
+    (fun env loc id lid ->
+       let path, desc = Typetexp.find_class_type env loc lid in
+       [ Sig_class_type (id, desc, Trec_not) ]
+    )
+
+
+let show env loc id lid =
+  let sg =
+    List.fold_left
+      (fun sg f -> try (f env loc id lid) @ sg with _ -> sg)
+      [] !all_show_funs
+  in
+  if sg = [] then raise Not_found else sg
+
+let () =
+  Hashtbl.add directive_table "show" (Directive_ident (show_prim show std_out))
 
 let _ =
   Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
@@ -435,7 +466,4 @@ let _ =
   Hashtbl.add directive_table "warn_error"
              (Directive_string (parse_warnings std_out true));
 
-  Hashtbl.add directive_table "show"
-     (Directive_generic (dir_show std_out));
-
   ()