diff options
| -rw-r--r-- | Changes | 1 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/coercions.ml | 5 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/coercions.ml.principal.reference | 13 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/coercions.ml.reference | 9 | ||||
| -rw-r--r-- | typing/typecore.ml | 19 |
5 files changed, 40 insertions, 7 deletions
@@ -94,6 +94,7 @@ Features wishes: - PR#5547: Enable the "-use-ocamlfind" option by default - PR#5650: Camlp4FoldGenerator doesn't handle well "abstract" types - PR#5808: allow simple patterns, not only identifiers, in "let p : t = ..." +- PR#6000: add a warning for non-principal coercions to format - PR#6054: add support for M.[ foo ], M.[| foo |] etc. (patch by Kaustuv Chaudhuri) - PR#6064: GADT representation for Bigarray.kind + CAML_BA_CHAR runtime kind diff --git a/testsuite/tests/typing-warnings/coercions.ml b/testsuite/tests/typing-warnings/coercions.ml new file mode 100644 index 000000000..1ca390b28 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml @@ -0,0 +1,5 @@ +(* comment 9644 of PR#6000 *) + +fun b -> if b then format_of_string "x" else "y";; +fun b -> if b then "x" else format_of_string "y";; +fun b -> (if b then "x" else "y" : (_,_,_) format);; diff --git a/testsuite/tests/typing-warnings/coercions.ml.principal.reference b/testsuite/tests/typing-warnings/coercions.ml.principal.reference new file mode 100644 index 000000000..d950e231f --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.principal.reference @@ -0,0 +1,13 @@ + +# Characters 76-79: + fun b -> if b then format_of_string "x" else "y";; + ^^^ +Warning 18: this coercion to format6 is not principal. +- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type ('a, 'b, 'c, 'd, 'd, 'a) format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# diff --git a/testsuite/tests/typing-warnings/coercions.ml.reference b/testsuite/tests/typing-warnings/coercions.ml.reference new file mode 100644 index 000000000..2ab458b68 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.reference @@ -0,0 +1,9 @@ + +# - : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type ('a, 'b, 'c, 'd, 'd, 'a) format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# diff --git a/typing/typecore.ml b/typing/typecore.ml index 9351572e2..b14aa291f 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1966,16 +1966,21 @@ and type_expect_ ?in_function env sexp ty_expected = exp_env = env } end | Pexp_constant(Const_string (s, _) as cst) -> + let ty_exp = expand_head env ty_expected in + let ty = + (* Terrible hack for format strings *) + match ty_exp.desc with + Tconstr(path, _, _) when Path.same path Predef.path_format6 -> + if !Clflags.principal && ty_exp.level <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this coercion to format6"); + type_format loc s + | _ -> instance_def Predef.type_string + in rue { exp_desc = Texp_constant cst; exp_loc = loc; exp_extra = []; - exp_type = - (* Terrible hack for format strings *) - begin match (repr (expand_head env ty_expected)).desc with - Tconstr(path, _, _) when Path.same path Predef.path_format6 -> - type_format loc s - | _ -> instance_def Predef.type_string - end; + exp_type = ty; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_constant cst -> |