Protocol to allow ppx processors to report warnings to the compiler (…

…reported as warning 22).

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

parsing/ast_mapper.ml

@@ -618,6 +618,10 @@ let rec extension_of_error {loc; msg; if_highlight; sub} =
          Str.eval (Exp.constant (Asttypes.Const_string (if_highlight, None)))] @
         (List.map (fun ext -> Str.extension (extension_of_error ext)) sub))
 
+let attribute_of_warning loc s =
+  { loc; txt = "ocaml.ppwarning" },
+  PStr ([Str.eval ~loc (Exp.constant (Asttypes.Const_string (s, None)))])
+
 let apply ~source ~target mapper =
   let ic = open_in_bin source in
   let magic =

parsing/ast_mapper.mli

@@ -115,3 +115,8 @@ val extension_of_error: Location.error -> extension
 (** Encode an error into an 'ocaml.error' extension node which can be
     inserted in a generated Parsetree.  The compiler will be
     responsible for reporting the error. *)
+
+val attribute_of_warning: Location.t -> string -> attribute
+(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the warning. *)

parsing/location.ml

@@ -367,3 +367,13 @@ let report_exception ppf exn =
   match error_of_exn exn with
   | Some err -> fprintf ppf "@[%a@]@." report_error err
   | None -> raise exn
+
+
+exception Error of error
+
+let () =
+  register_error_of_exn
+    (function
+      | Error e -> Some e
+      | _ -> None
+    )

parsing/location.mli

@@ -89,6 +89,8 @@ type error =
     if_highlight: string; (* alternative message if locations are highlighted *)
   }
 
+exception Error of error
+
 val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
 
 val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string

typing/typemod.ml

@@ -1551,13 +1551,19 @@ let () =
   Typecore.type_package := type_package;
   type_module_type_of_fwd := type_module_type_of
 
+
 (* Typecheck an implementation file *)
 
 let type_implementation sourcefile outputprefix modulename initial_env ast =
   Cmt_format.clear ();
   try
   Typecore.reset_delayed_checks ();
   Env.reset_required_globals ();
+  begin
+    let map = Typetexp.emit_external_warnings in
+    ignore (map.Ast_mapper.structure map ast)
+  end;
+
   let (str, sg, finalenv) =
     type_structure initial_env ast (Location.in_file sourcefile) in
   let simple_sg = simplify_signature sg in
@@ -1618,8 +1624,12 @@ let save_signature modname tsg outputprefix source_file initial_env cmi =
   Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
     (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
 
-let type_interface env sg =
-  transl_signature env sg
+let type_interface env ast =
+  begin
+    let map = Typetexp.emit_external_warnings in
+    ignore (map.Ast_mapper.signature map ast)
+  end;
+  transl_signature env ast
 
 (* "Packaging" of several compilation units into one unit
    having them as sub-modules.  *)

typing/typetexp.ml

@@ -99,6 +99,24 @@ let check_deprecated loc attrs s =
     | _ ->  ())
     attrs
 
+let emit_external_warnings =
+  let open Ast_mapper in
+  {
+    default_mapper with
+    attribute = (fun _ a ->
+        begin match a with
+        | {txt="ocaml.ppwarning"|"ppwarning"},
+          PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
+                                         (Const_string (s, _))},_);
+                pstr_loc}] ->
+            Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
+        | _ -> ()
+        end;
+        a
+      )
+  }
+
+
 let warning_scope = ref []
 
 let warning_enter_scope () =

typing/typetexp.mli

@@ -116,4 +116,6 @@ val warning_enter_scope: unit -> unit
 val warning_leave_scope: unit -> unit
 val warning_attribute: Parsetree.attributes -> unit
 
-val error_of_extension : Parsetree.extension -> Location.error
+val error_of_extension: Parsetree.extension -> Location.error
+
+val emit_external_warnings: Ast_mapper.mapper

utils/warnings.ml

@@ -39,7 +39,7 @@ type t =
   | Without_principality of string          (* 19 *)
   | Unused_argument                         (* 20 *)
   | Nonreturning_statement                  (* 21 *)
-  | Camlp4 of string                        (* 22 *)
+  | Preprocessor of string                  (* 22 *)
   | Useless_record_with                     (* 23 *)
   | Bad_module_name of string               (* 24 *)
   | All_clauses_guarded                     (* 25 *)
@@ -97,7 +97,7 @@ let number = function
   | Without_principality _ -> 19
   | Unused_argument -> 20
   | Nonreturning_statement -> 21
-  | Camlp4 _ -> 22
+  | Preprocessor _ -> 22
   | Useless_record_with -> 23
   | Bad_module_name _ -> 24
   | All_clauses_guarded -> 25
@@ -288,7 +288,7 @@ let message = function
   | Unused_argument -> "this argument will not be used by the function."
   | Nonreturning_statement ->
       "this statement never returns (or has an unsound type.)"
-  | Camlp4 s -> s
+  | Preprocessor s -> s
   | Useless_record_with ->
       "all the fields are explicitly listed in this record:\n\
        the 'with' clause is useless."
@@ -433,7 +433,7 @@ let descriptions =
    19, "Type without principality.";
    20, "Unused function argument.";
    21, "Non-returning statement.";
-   22, "Camlp4 warning.";
+   22, "Proprocessor warning.";
    23, "Useless record \"with\" clause.";
    24, "Bad module name: the source file name is not a valid OCaml module \
         name.";

utils/warnings.mli

@@ -34,7 +34,7 @@ type t =
   | Without_principality of string          (* 19 *)
   | Unused_argument                         (* 20 *)
   | Nonreturning_statement                  (* 21 *)
-  | Camlp4 of string                        (* 22 *)
+  | Preprocessor of string                  (* 22 *)
   | Useless_record_with                     (* 23 *)
   | Bad_module_name of string               (* 24 *)
   | All_clauses_guarded                     (* 25 *)