Unify further

testsuite/tests/tool-toplevel/topeval.compilers.reference

@@ -3,4 +3,8 @@ module A :
 - : ('foo, 'a) A.t -> 'foo option = <fun>
 val _bar : ('a, 'b) A.t -> 'a option = <fun>
 - : int = 42
+- : int = 42
+- : int = 42
+- : int = 42
+- : int = 42
 

testsuite/tests/tool-toplevel/topeval.ml

@@ -33,3 +33,15 @@ let _bar = A.get_foo
 (* PR 10849 *)
 let _ : int = 42
 ;;
+
+let (_ : int) : int = 42
+;;
+
+let List.(_) = 42
+;;
+
+let List.(String.(_)) = 42
+;;
+
+let List.(_) : int = 42
+;;

toplevel/byte/topeval.ml

@@ -135,23 +135,14 @@ let execute_phrase print_outcome ppf phr =
               if print_outcome then
                 Printtyp.wrap_printing_env ~error:false oldenv (fun () ->
                   match str.str_items with
-                  | [ { str_desc =
-                          (Tstr_eval (exp, _)
-                          |Tstr_value
-                              (Asttypes.Nonrecursive,
-                               [{vb_pat = {pat_desc=Tpat_any};
-                                 vb_expr = exp}
-                               ]
-                              )
-                          )
-                      }
-                    ] ->
-                      let outv = outval_of_value newenv v exp.exp_type in
-                      let ty = Printtyp.tree_of_type_scheme exp.exp_type in
-                      Ophr_eval (outv, ty)
-
                   | [] -> Ophr_signature []
-                  | _ -> Ophr_signature (pr_item oldenv sg'))
+                  | _ ->
+                      match find_eval_phrase str with
+                      | Some (exp, _, _) ->
+                        let outv = outval_of_value newenv v exp.exp_type in
+                        let ty = Printtyp.tree_of_type_scheme exp.exp_type in
+                        Ophr_eval (outv, ty)
+                      | None -> Ophr_signature (pr_item oldenv sg'))
               else Ophr_signature []
           | Exception exn ->
               toplevel_env := oldenv;

toplevel/native/topeval.ml

@@ -183,21 +183,11 @@ let execute_phrase print_outcome ppf phr =
          can create observable differences (e.g. in type variable names, see
          tool-toplevel/topeval.ml in the testsuite) *)
       let str, sg', rewritten =
-         match str.str_items with
-         | [ { str_desc = Tstr_eval (e, attrs) ; str_loc = loc } ]
-         | [ { str_desc = Tstr_value (Asttypes.Nonrecursive,
-                                       [{ vb_expr = e
-                                        ; vb_pat =
-                                            { pat_desc = Tpat_any
-                                            ; pat_extra =
-                                                ([] | [Tpat_constraint _, _, _])
-                                            ; _ }
-                                        ; vb_attributes = attrs }])
-             ; str_loc = loc }
-           ] ->
+         match find_eval_phrase str with
+         | Some (e, attrs, loc) ->
              let str, sg' = name_expression ~loc ~attrs e in
              str, sg', true
-         | _ -> str, sg', false
+         | None -> str, sg', false
       in
       let module_ident, res, required_globals, size =
         if Config.flambda then
@@ -228,21 +218,22 @@ let execute_phrase print_outcome ppf phr =
                 Compilenv.record_global_approx_toplevel ();
               if print_outcome then
                 Printtyp.wrap_printing_env ~error:false oldenv (fun () ->
-                match str.str_items with
-                | [] -> Ophr_signature []
-                | _ ->
-                    if rewritten then
-                      match sg' with
-                      | [ Sig_value (id, vd, _) ] ->
-                          let outv =
-                            outval_of_value newenv (toplevel_value id)
-                              vd.val_type
-                          in
-                          let ty = Printtyp.tree_of_type_scheme vd.val_type in
-                          Ophr_eval (outv, ty)
-                      | _ -> assert false
-                    else
-                      Ophr_signature (pr_item oldenv sg'))
+                  match str.str_items with
+                  | [] -> Ophr_signature []
+                  | _ ->
+                      if rewritten then
+                        match sg' with
+                        | [ Sig_value (id, vd, _) ] ->
+                            let outv =
+                              outval_of_value newenv (toplevel_value id)
+                                vd.val_type
+                            in
+                            let ty =
+                              Printtyp.tree_of_type_scheme vd.val_type in
+                            Ophr_eval (outv, ty)
+                        | _ -> assert false
+                      else
+                        Ophr_signature (pr_item oldenv sg'))
               else Ophr_signature []
           | Exception exn ->
               toplevel_env := oldenv;

toplevel/topcommon.ml

@@ -64,6 +64,18 @@ let print_out_sig_item = Oprint.out_sig_item
 let print_out_signature = Oprint.out_signature
 let print_out_phrase = Oprint.out_phrase
 
+let find_eval_phrase str =
+  let open Typedtree in
+  match str.str_items with
+  | [ { str_desc = Tstr_eval (e, attrs) ; str_loc = loc } ]
+  | [ { str_desc = Tstr_value (Asttypes.Nonrecursive,
+                                [{ vb_expr = e
+                                 ; vb_pat = { pat_desc = Tpat_any; _ }
+                                 ; vb_attributes = attrs }])
+      ; str_loc = loc }
+    ] ->
+      Some (e, attrs, loc)
+  | _ -> None
 
 (* The current typing environment for the toplevel *)
 

toplevel/topcommon.mli

@@ -65,6 +65,10 @@ val print_out_signature :
   (formatter -> Outcometree.out_sig_item list -> unit) ref
 val print_out_phrase :
   (formatter -> Outcometree.out_phrase -> unit) ref
+val find_eval_phrase :
+  Typedtree.structure ->
+    (Typedtree.expression * Typedtree.attributes * Location.t) option
+
 
 
 exception Undefined_global of string