Revert 14616, 14617. Go back to the original syntax for toplevel directives, only allowing capitalized identifiers in addition to lowercase ones. Split #show into variants #show_val, #show_type, etc, and implement a generic #show which combines all the results.

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

8 files changed, 115 insertions, 104 deletions

diff --git a/Changes b/Changes
index 88f88e7753..f02100b975 100644
--- a/Changes
+++ b/Changes
@@ -59,8 +59,7 @@ Compilers:
 - PR#6260: Unnecessary boxing in let (patch by vbrankov)
 
 Toplevel interactive system:
-- Support for directive with multiple arguments
-- PR#5377: New "#show" directive
+- PR#5377: New "#show_*" directives
 
 Runtime system:
 - Fixed a major performance problem on large heaps (~1GB) by making heap
diff --git a/parsing/parser.mly b/parsing/parser.mly
index abe2b9ee33..55a7b5c513 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -522,9 +522,9 @@ use_file_tail:
   | SEMISEMI seq_expr post_item_attributes use_file_tail
                                               { Ptop_def[mkstrexp $2 $3] :: $4 }
   | SEMISEMI structure_item use_file_tail     { Ptop_def[$2] :: $3 }
-  | SEMISEMI toplevel_directive SEMISEMI use_file_tail { $2 :: $4 }
+  | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
   | structure_item use_file_tail              { Ptop_def[$1] :: $2 }
-  | toplevel_directive SEMISEMI use_file_tail          { $1 :: $3 }
+  | toplevel_directive use_file_tail          { $1 :: $2 }
 ;
 parse_core_type:
     core_type EOF { $1 }
@@ -1945,23 +1945,15 @@ class_longident:
 /* Toplevel directives */
 
 toplevel_directive:
-    SHARP ident toplevel_directive_args    { Ptop_dir($2, $3) }
-;
-toplevel_directive_arg:
-  | STRING          { Pdir_string (fst $1) }
-  | INT             { Pdir_int $1 }
-  | val_longident   { Pdir_ident $1 }
-  | mod_longident   { Pdir_ident $1 }
-  | keyword         {
-    match $1 with
-    | "true" -> Pdir_bool true
-    | "false" -> Pdir_bool false
-    | s -> Pdir_keyword s
-  }
-toplevel_directive_args:
-  | /*empty*/ { [] }
-  | toplevel_directive_arg toplevel_directive_args { $1 :: $2 }
+    SHARP ident                 { Ptop_dir($2, Pdir_none) }
+  | SHARP ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
+  | SHARP ident INT             { Ptop_dir($2, Pdir_int $3) }
+  | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
+  | SHARP ident mod_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) }
 ;
+
 /* Miscellaneous */
 
 name_tag:
@@ -2017,7 +2009,9 @@ additive:
 
 /* Attributes and extensions */
 
-keyword:
+single_attr_id:
+    LIDENT { $1 }
+  | UIDENT { $1 }
   | AND { "and" }
   | AS { "as" }
   | ASSERT { "assert" }
@@ -2068,11 +2062,6 @@ keyword:
   | WITH { "with" }
 /* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
 ;
-single_attr_id:
-    LIDENT { $1 }
-  | UIDENT { $1 }
-  | keyword { $1 }
-;
 
 attr_id:
     single_attr_id { mkloc $1 (symbol_rloc()) }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 5747f51eb3..ce938dd897 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -763,12 +763,12 @@ and module_binding =
 
 type toplevel_phrase =
   | Ptop_def of structure
-  | Ptop_dir of string * directive_argument list
+  | Ptop_dir of string * directive_argument
      (* #use, #load ... *)
 
 and directive_argument =
+  | Pdir_none
   | Pdir_string of string
   | Pdir_int of int
   | Pdir_ident of Longident.t
   | Pdir_bool of bool
-  | Pdir_keyword of string
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 28965bce3d..8b156bafd1 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -1224,12 +1224,12 @@ class printer  ()= object(self:'self)
             pp f "~%s:%a" lbl self#simple_expr e
 
   method directive_argument f x =
-    match x with
+    (match x with
+    | Pdir_none -> ()
     | Pdir_string (s) -> pp f "@ %S" s
     | Pdir_int (i) -> pp f "@ %d" i
     | Pdir_ident (li) -> pp f "@ %a" self#longident li
-    | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
-    | Pdir_keyword s -> pp f "@ %s" s
+    | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
 
   method toplevel_phrase f x =
     match x with
@@ -1238,8 +1238,7 @@ class printer  ()= object(self:'self)
         self#list self#structure_item f s ;
         pp_close_box f ();
     | Ptop_dir (s, da) ->
-        pp f "@[<hov2>#%s@ %a@]" s
-          (self#list ~sep:" " self#directive_argument) da
+        pp f "@[<hov2>#%s@ %a@]" s self#directive_argument da
 end;;
 
 
@@ -1253,8 +1252,7 @@ let toplevel_phrase f x =
    (* pp_print_list structure_item f s ; *)
    (* pp_close_box f (); *)
   | Ptop_dir (s, da) ->
-   pp f "@[<hov2>#%s@ %a@]" s
-     (default#list ~sep:" " default#directive_argument) da
+   pp f "@[<hov2>#%s@ %a@]" s default#directive_argument da
    (* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *)
 
 let expression f x =
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 15de289d54..a8a1671b96 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -838,15 +838,15 @@ let rec toplevel_phrase i ppf x =
       structure (i+1) ppf s;
   | Ptop_dir (s, da) ->
       line i ppf "Ptop_dir \"%s\"\n" s;
-      list i directive_argument ppf da;
+      directive_argument i ppf da;
 
 and directive_argument i ppf x =
   match x with
+  | Pdir_none -> line i ppf "Pdir_none\n"
   | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
   | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i;
   | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
   | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
-  | Pdir_keyword s -> line i ppf "Pdir_keyword %s\n" s;
 ;;
 
 let interface ppf x = list 0 signature_item ppf x;;
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index bdd08a9368..c8da35b21e 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));
-
   ()
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index ce73d6521d..0671fb3a9b 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -28,7 +28,6 @@ type directive_fun =
    | Directive_int of (int -> unit)
    | Directive_ident of (Longident.t -> unit)
    | Directive_bool of (bool -> unit)
-   | Directive_generic of (Parsetree.directive_argument list -> unit)
 
 (* The table of toplevel value bindings and its accessors *)
 
@@ -291,12 +290,11 @@ let execute_phrase print_outcome ppf phr =
           false
       | Some d ->
           match d, dir_arg with
-          | Directive_none f, [] -> f (); true
-          | Directive_string f, [Pdir_string s] -> f s; true
-          | Directive_int f, [Pdir_int n] -> f n; true
-          | Directive_ident f, [Pdir_ident lid] -> f lid; true
-          | Directive_bool f, [Pdir_bool b] -> f b; true
-          | Directive_generic f, l -> f l; true
+          | Directive_none f, Pdir_none -> f (); true
+          | Directive_string f, Pdir_string s -> f s; true
+          | Directive_int f, Pdir_int n -> f n; true
+          | Directive_ident f, Pdir_ident lid -> f lid; true
+          | Directive_bool f, Pdir_bool b -> f b; true
           | _ ->
               fprintf ppf "Wrong type of argument for directive `%s'.@."
                 dir_name;
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index b364a088e7..324857a835 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -39,7 +39,6 @@ type directive_fun =
    | Directive_int of (int -> unit)
    | Directive_ident of (Longident.t -> unit)
    | Directive_bool of (bool -> unit)
-   | Directive_generic of (Parsetree.directive_argument list -> unit)
 
 val directive_table : (string, directive_fun) Hashtbl.t
         (* Table of known directives, with their execution function *)