Merge pull request ocaml#9086 from wyn/8945_show_constructor

toplevel, show directive for constructors

Changes

@@ -30,6 +30,10 @@ Working version
 - #8938: Extend ocamlopt option "-stop-after" to handle "scheduling" argument.
   (Greta Yorsh, review by Florian Angeletti and Sébastien Hinderer)
 
+- #8945: Fix toplevel show directive to work with constructors
+  (Simon Parry, review by Gabriel Scherer, Jeremy Yallop,
+  Alain Frisch, Florian Angeletti)
+
 ### Internal/compiler-libs changes:
 
 - #8970: separate value patterns (matching on values) from computation patterns

testsuite/tests/tool-toplevel/show.ml

@@ -0,0 +1,106 @@
+(* TEST
+   * expect
+*)
+
+(* this is a set of tests to test the #show functionality
+ * of toplevel *)
+
+#show Foo;;
+[%%expect {|
+Unknown element.
+|}];;
+
+module type S = sig type t val x : t end;;
+module M : S = struct type t = int let x = 3 end;;
+
+[%%expect {|
+module type S = sig type t val x : t end
+module M : S
+|}];;
+
+#show M;;
+[%%expect {|
+module M : S
+|}];;
+
+#show S;;
+[%%expect {|
+module type S = sig type t val x : t end
+|}];;
+
+#show Invalid_argument;;
+[%%expect {|
+exception Invalid_argument of string
+|}];;
+
+#show Some;;
+[%%expect {|
+type 'a option = None | Some of 'a
+|}];;
+
+#show option;;
+[%%expect {|
+type 'a option = None | Some of 'a
+|}];;
+
+#show Open_binary;;
+[%%expect {|
+type Stdlib.open_flag =
+    Open_rdonly
+  | Open_wronly
+  | Open_append
+  | Open_creat
+  | Open_trunc
+  | Open_excl
+  | Open_binary
+  | Open_text
+  | Open_nonblock
+|}];;
+
+#show open_flag;;
+[%%expect {|
+type open_flag =
+    Open_rdonly
+  | Open_wronly
+  | Open_append
+  | Open_creat
+  | Open_trunc
+  | Open_excl
+  | Open_binary
+  | Open_text
+  | Open_nonblock
+|}];;
+
+type extensible = ..;;
+type extensible += A | B of int;;
+[%%expect {|
+type extensible = ..
+type extensible += A | B of int
+|}];;
+
+#show A;;
+[%%expect {|
+type extensible += A
+|}];;
+
+#show B;;
+[%%expect {|
+type extensible += B of int
+|}];;
+
+#show extensible;;
+[%%expect {|
+type extensible = ..
+|}];;
+
+type 'a t = ..;;
+type _ t += A : int t;;
+[%%expect{|
+type 'a t = ..
+type _ t += A : int t
+|}];;
+
+#show A;;
+[%%expect{|
+type 'a t += A : int t
+|}];;

toplevel/topdirs.ml

@@ -545,15 +545,66 @@ let () =
   reg_show_prim "show_type"
     (fun env loc id lid ->
        let _path, desc = Env.lookup_type ~loc lid env in
-       [ Sig_type (id, desc, Trec_not, Exported) ]
+       [ Sig_type (id, desc, Trec_first, Exported) ]
     )
     "Print the signature of the corresponding type constructor."
 
+(* Each registered show_prim function is called in turn
+ * and any output produced is sent to std_out.
+ * Two show_prim functions are needed for constructors,
+ * one for exception constructors and another for
+ * non-exception constructors (normal and extensible variants). *)
+let is_exception_constructor env type_expr =
+  Ctype.equal env true [type_expr] [Predef.type_exn]
+
+let is_extension_constructor = function
+  | Cstr_extension _ -> true
+  | _ -> false
+
+let () =
+  (* This show_prim function will only show constructor types
+   * that are not also exception types. *)
+  reg_show_prim "show_constructor"
+    (fun env loc id lid ->
+       let desc = Env.lookup_constructor ~loc Env.Positive lid env in
+       if is_exception_constructor env desc.cstr_res then
+         raise Not_found;
+       let path =
+         match Ctype.repr desc.cstr_res with
+         | {desc=Tconstr(path, _, _)} -> path
+         | _ -> raise Not_found
+       in
+       let type_decl = Env.find_type path env in
+       if is_extension_constructor desc.cstr_tag then
+         let ret_type =
+           if desc.cstr_generalized then Some desc.cstr_res
+           else None
+         in
+         let ext =
+           { ext_type_path = path;
+             ext_type_params = type_decl.type_params;
+             ext_args = Cstr_tuple desc.cstr_args;
+             ext_ret_type = ret_type;
+             ext_private = Asttypes.Public;
+             Types.ext_loc = desc.cstr_loc;
+             Types.ext_attributes = desc.cstr_attributes; }
+           in
+             [Sig_typext (id, ext, Text_first, Exported)]
+       else
+         (* make up a fake Ident.t as type_decl : Types.type_declaration
+          * does not have an Ident.t yet. Ident.create_presistent is a
+          * good choice because it has no side-effects.
+          * *)
+         let type_id = Ident.create_persistent (Path.name path) in
+         [ Sig_type (type_id, type_decl, Trec_first, Exported) ]
+    )
+    "Print the signature of the corresponding value constructor."
+
 let () =
   reg_show_prim "show_exception"
     (fun env loc id lid ->
        let desc = Env.lookup_constructor ~loc Env.Positive lid env in
-       if not (Ctype.equal env true [desc.cstr_res] [Predef.type_exn]) then
+       if not (is_exception_constructor env desc.cstr_res) then
          raise Not_found;
        let ret_type =
          if desc.cstr_generalized then Some Predef.type_exn