Merge pull request #10524 from wiktorkuchta/directive-error

Refactor duplicate code and improve directive wrong argument type error message

Changes

@@ -32,6 +32,9 @@ Working version
   (`#use "missing_file";;`) use stderr and exit with an error.
   (Florian Angeletti, review by Gabriel Scherer)
 
+- #10524: Directive argument type error now shows expected and received type.
+  (Wiktor Kuchta, review by Gabriel Scherer)
+
 ### Manual and documentation:
 
 - #7812, #10475: reworded the description of the behaviors of

toplevel/byte/topeval.ml

@@ -176,38 +176,7 @@ let execute_phrase print_outcome ppf phr =
         toplevel_env := oldenv; raise x
       end
   | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
-      begin match Topcommon.get_directive dir_name with
-      | None ->
-          fprintf ppf "Unknown directive `%s'." dir_name;
-          let directives = Topcommon.all_directive_names () in
-          Misc.did_you_mean ppf
-            (fun () -> Misc.spellcheck directives dir_name);
-          fprintf ppf "@.";
-          false
-      | Some d ->
-          match d, pdir_arg with
-          | Directive_none f, None -> f (); true
-          | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
-          | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } ->
-             begin match Int_literal_converter.int n with
-             | n -> f n; true
-             | exception _ ->
-               fprintf ppf "Integer literal exceeds the range of \
-                            representable integers for directive `%s'.@."
-                       dir_name;
-               false
-             end
-          | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
-              fprintf ppf "Wrong integer literal for directive `%s'.@."
-                dir_name;
-              false
-          | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
-          | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
-          | _ ->
-              fprintf ppf "Wrong type of argument for directive `%s'.@."
-                dir_name;
-              false
-      end
+      try_run_directive ppf dir_name pdir_arg
 
 let execute_phrase print_outcome ppf phr =
   try execute_phrase print_outcome ppf phr

toplevel/native/topeval.ml

@@ -279,34 +279,7 @@ let execute_phrase print_outcome ppf phr =
         toplevel_env := oldenv; raise x
       end
   | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
-      begin match get_directive dir_name with
-      | None ->
-          fprintf ppf "Unknown directive `%s'.@." dir_name;
-          false
-      | Some d ->
-          match d, pdir_arg with
-          | Directive_none f, None -> f (); true
-          | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
-          | Directive_int f, Some {pdira_desc = Pdir_int (n,None)} ->
-             begin match Int_literal_converter.int n with
-             | n -> f n; true
-             | exception _ ->
-               fprintf ppf "Integer literal exceeds the range of \
-                            representable integers for directive `%s'.@."
-                       dir_name;
-               false
-             end
-          | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
-              fprintf ppf "Wrong integer literal for directive `%s'.@."
-                dir_name;
-              false
-          | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
-          | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
-          | _ ->
-              fprintf ppf "Wrong type of argument for directive `%s'.@."
-                dir_name;
-              false
-      end
+      try_run_directive ppf dir_name pdir_arg
 
 
 (* API compat *)

toplevel/topcommon.ml

@@ -308,3 +308,51 @@ let get_directive_info name =
 
 let all_directive_names () =
   Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table []
+
+let try_run_directive ppf dir_name pdir_arg =
+  begin match get_directive dir_name with
+  | None ->
+      fprintf ppf "Unknown directive `%s'." dir_name;
+      let directives = all_directive_names () in
+      Misc.did_you_mean ppf
+        (fun () -> Misc.spellcheck directives dir_name);
+      fprintf ppf "@.";
+      false
+  | Some d ->
+      match d, pdir_arg with
+      | Directive_none f, None -> f (); true
+      | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
+      | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } ->
+         begin match Misc.Int_literal_converter.int n with
+         | n -> f n; true
+         | exception _ ->
+           fprintf ppf "Integer literal exceeds the range of \
+                        representable integers for directive `%s'.@."
+                   dir_name;
+           false
+         end
+      | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
+          fprintf ppf "Wrong integer literal for directive `%s'.@."
+            dir_name;
+          false
+      | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
+      | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
+      | _ ->
+          let dir_type = match d with
+          | Directive_none _   -> "no argument"
+          | Directive_string _ -> "a `string' literal"
+          | Directive_int _    -> "an `int' literal"
+          | Directive_ident _  -> "an identifier"
+          | Directive_bool _   -> "a `bool' literal"
+          in
+          let arg_type = match pdir_arg with
+          | None                              -> "no argument"
+          | Some {pdira_desc = Pdir_string _} -> "a `string' literal"
+          | Some {pdira_desc = Pdir_int _}    -> "an `int' literal"
+          | Some {pdira_desc = Pdir_ident _}  -> "an identifier"
+          | Some {pdira_desc = Pdir_bool _}   -> "a `bool' literal"
+          in
+          fprintf ppf "Directive `%s' expects %s, got %s.@."
+            dir_name dir_type arg_type;
+          false
+  end

toplevel/topcommon.mli

@@ -143,6 +143,9 @@ val get_directive_info : string -> directive_info option
 
 val all_directive_names : unit -> string list
 
+val try_run_directive :
+  formatter -> string -> Parsetree.directive_argument option -> bool
+
 val[@deprecated] directive_table : (string, directive_fun) Hashtbl.t
   (* @deprecated please use [add_directive] instead of inserting
      in this table directly. *)