POC deprecated optional argumentsdeprecated_optional_arguments

3 files changed, 64 insertions, 0 deletions

diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
index 0d850f9803..d28afdf813 100755
--- a/parsing/builtin_attributes.ml
+++ b/parsing/builtin_attributes.ml
@@ -69,6 +69,38 @@ let error_of_extension ext =
 let cat s1 s2 =
   if s2 = "" then s1 else s1 ^ "\n" ^ s2
 
+let deprecated_argument_payload b  = function
+  | PStr[{pstr_desc=Pstr_eval(
+      {pexp_desc=Pexp_apply (
+           {pexp_desc = Pexp_ident {txt = Longident.Lident id}},
+           [Nolabel, {pexp_desc=Pexp_constant (Pconst_string (msg, _))}]
+         )
+      }, _)}] -> Some (b, id, msg)
+  | PStr[{pstr_desc=Pstr_eval(
+           {pexp_desc = Pexp_ident {txt = Longident.Lident id}}
+         , _)}] -> Some (b, id, "")
+  | _ -> None (* TODO: warning invalid payload *)
+
+let deprecated_argument_of_attr = function
+  | {attr_name = {txt = "ocaml.deprecated_argument"|
+                        "deprecated_argument"; _};
+     attr_payload;
+     _} ->
+      deprecated_argument_payload true attr_payload
+  | {attr_name = {txt = "ocaml.deprecated_missing_argument"|
+                        "deprecated_missing_argument"; _};
+     attr_payload;
+     _} ->
+      deprecated_argument_payload false attr_payload
+  | _ -> None
+
+let rec deprecated_arguments_of_attrs = function
+  | [] -> []
+  | hd :: tl ->
+      match deprecated_argument_of_attr hd with
+      | None -> deprecated_arguments_of_attrs tl
+      | Some x -> x :: deprecated_arguments_of_attrs tl
+
 let deprecated_attr x =
   match x with
   | {attr_name = {txt = "ocaml.deprecated"|"deprecated"; _};_} -> Some x
diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
index be0de631a7..89a5818700 100755
--- a/parsing/builtin_attributes.mli
+++ b/parsing/builtin_attributes.mli
@@ -35,6 +35,12 @@ val check_deprecated_inclusion:
 val deprecated_of_attrs: Parsetree.attributes -> string option
 val deprecated_of_sig: Parsetree.signature -> string option
 val deprecated_of_str: Parsetree.structure -> string option
+val deprecated_arguments_of_attrs:
+  Parsetree.attributes -> (bool * string * string) list
+    (* (b, label, message)
+       b = true -> warn if argument is passed
+       b = false -> warn if argument is missing
+    *)
 
 val check_deprecated_mutable:
     Location.t -> Parsetree.attributes -> string -> unit
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 303e9ca679..d028472305 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2355,6 +2355,32 @@ and type_expect_
       begin_def (); (* one more level for non-returning functions *)
       if !Clflags.principal then begin_def ();
       let funct = type_exp env sfunct in
+      begin match funct.exp_desc with
+      | Texp_ident (_, _, {val_attributes;_}) ->
+          let check (b, lab, msg) =
+            let warn loc =
+              Location.deprecated loc
+                (Printf.sprintf "%soptional argument %s\n%s"
+                   (if b then "" else "missing ") lab msg
+                )
+            in
+            let rec scan = function
+              | [] ->
+                  if not b then warn sexp.pexp_loc
+              | (Optional s, e) :: _ when s = lab ->
+                  warn e.pexp_loc
+              | (Labelled s, e) :: _ when s = lab ->
+                  if b then warn e.pexp_loc
+              | _ :: rest ->
+                  scan rest
+            in
+            scan sargs
+          in
+          List.iter check
+            (Builtin_attributes.deprecated_arguments_of_attrs val_attributes)
+      | _ ->
+          ()
+      end;
       if !Clflags.principal then begin
           end_def ();
           generalize_structure funct.exp_type