Permalink
Browse files

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
  • Loading branch information...
1 parent bdeeab6 commit bfccd68eccb2d8369efa765106f843f228f6663c @alainfrisch alainfrisch committed May 7, 2014
Showing with 59 additions and 8 deletions.
  1. +4 −0 parsing/ast_mapper.ml
  2. +5 −0 parsing/ast_mapper.mli
  3. +10 −0 parsing/location.ml
  4. +2 −0 parsing/location.mli
  5. +12 −2 typing/typemod.ml
  6. +18 −0 typing/typetexp.ml
  7. +3 −1 typing/typetexp.mli
  8. +4 −4 utils/warnings.ml
  9. +1 −1 utils/warnings.mli
View
@@ -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 =
View
@@ -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. *)
View
@@ -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
+ )
View
@@ -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
View
@@ -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. *)
View
@@ -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 () =
View
@@ -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
View
@@ -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.";
View
@@ -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 *)

0 comments on commit bfccd68

Please sign in to comment.