diff options
| -rwxr-xr-x | parsing/builtin_attributes.ml | 32 | ||||
| -rwxr-xr-x | parsing/builtin_attributes.mli | 6 | ||||
| -rw-r--r-- | typing/typecore.ml | 26 |
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 |