remove coercion warning, add it only on error

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

typing/ctype.ml

@@ -2440,7 +2440,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
    [posi] true if the current variance is positive
    [level] number of expansions/enlargement allowed on this branch *)
 
-let warn = ref false
+let warn = ref false  (* whether double coercion might do better *)
 let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
 let pred_enlarge n = if n mod 2 = 1 then pred n else n
 
@@ -2452,19 +2452,24 @@ let rec filter_visited = function
   | {desc=Tobject _|Tvariant _} :: _ as l -> l
   | _ :: l -> filter_visited l
 
+let memq_warn t visited =
+  if List.memq t visited then (warn := true; true) else false
+
 let rec build_subtype env visited loops posi level t =
   let t = repr t in
   match t.desc with
     Tvar ->
       if posi then
         try
+          let t' = List.assq t loops in
+          warn := true;
           (List.assq t loops, Equiv)
         with Not_found ->
           (t, Unchanged)
       else
         (t, Unchanged)
   | Tarrow(l, t1, t2, _) ->
-      if List.memq t visited then (t, Unchanged) else
+      if memq_warn t visited then (t, Unchanged) else
       let visited = t :: visited in
       let (t1', c1) = build_subtype env visited loops (not posi) level t1 in
       let (t2', c2) = build_subtype env visited loops posi level t2 in
@@ -2472,7 +2477,7 @@ let rec build_subtype env visited loops posi level t =
       if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c)
       else (t, Unchanged)
   | Ttuple tlist ->
-      if List.memq t visited then (t, Unchanged) else
+      if memq_warn t visited then (t, Unchanged) else
       let visited = t :: visited in
       let tlist' =
         List.map (build_subtype env visited loops posi level) tlist
@@ -2527,7 +2532,7 @@ let rec build_subtype env visited loops posi level t =
   | Tconstr(p, tl, abbrev) ->
       (* Must check recursion on constructors, since we do not always
          expand them *)
-      if List.memq t visited then (t, Unchanged) else
+      if memq_warn t visited then (t, Unchanged) else
       let visited = t :: visited in
       begin try
         let decl = Env.find_type p env in
@@ -2551,7 +2556,7 @@ let rec build_subtype env visited loops posi level t =
       end
   | Tvariant row ->
       let row = row_repr row in
-      if List.memq t visited || not (static_row row) then (t, Unchanged) else
+      if memq_warn t visited || not (static_row row) then (t, Unchanged) else
       let level' = pred_enlarge level in
       let visited =
         t :: if level' < level then [] else filter_visited visited in
@@ -2585,7 +2590,7 @@ let rec build_subtype env visited loops posi level t =
       in
       (newty (Tvariant row), Changed)
   | Tobject (t1, _) ->
-      if List.memq t visited || opened_object t1 then (t, Unchanged) else
+      if memq_warn t visited || opened_object t1 then (t, Unchanged) else
       let level' = pred_enlarge level in
       let visited =
         t :: if level' < level then [] else filter_visited visited in
@@ -2602,8 +2607,10 @@ let rec build_subtype env visited loops posi level t =
       if posi then
         let v = newvar () in
         (v, Changed)
-      else
+      else begin
+        warn := true;
         (t, Unchanged)
+      end
   | Tsubst _ | Tlink _ ->
       assert false
   | Tpoly(t1, tl) ->

typing/printtyp.ml

@@ -743,8 +743,9 @@ let signature ppf sg =
 (* Print an unification error *)
 
 let type_expansion t ppf t' =
-  if t == t' then type_expr ppf t
-  else fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
+  if t == t' then type_expr ppf t else
+  let t' = if proxy t = proxy t' then unalias t' else t' in
+  fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
 
 let rec trace fst txt ppf = function
   | (t1, t1') :: (t2, t2') :: rem ->

typing/typecore.ml

@@ -48,7 +48,8 @@ type error =
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
   | Outside_class
   | Value_multiply_overridden of string
-  | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list
+  | Coercion_failure of
+      type_expr * type_expr * (type_expr * type_expr) list * bool
   | Too_many_arguments of bool * type_expr
   | Abstract_wrong_label of label * type_expr
   | Scoping_let_module of string * type_expr
@@ -1016,14 +1017,10 @@ let rec type_exp env sexp =
                 force ()
             | _ ->
                 let ty, b = enlarge_type env ty' in
-		if b then Location.prerr_warning sexp.pexp_loc
-		    (Warnings.Other "Simple coercions only expand up to 2 \
-		       levels of abbreviations\ninvolving objects/variants. \
-                       Consider using double coercions.");
                 force ();
                 begin try Ctype.unify env arg.exp_type ty with Unify trace ->
                   raise(Error(sarg.pexp_loc,
-                        Coercion_failure(ty', full_expand env ty', trace)))
+                        Coercion_failure(ty', full_expand env ty', trace, b)))
                 end
             end;
             (arg, ty')
@@ -1860,7 +1857,7 @@ let report_error ppf = function
       fprintf ppf "This object duplication occurs outside a method definition"
   | Value_multiply_overridden v ->
       fprintf ppf "The instance variable %s is overridden several times" v
-  | Coercion_failure (ty, ty', trace) ->
+  | Coercion_failure (ty, ty', trace, b) ->
       report_unification_error ppf trace
         (function ppf ->
            let ty, ty' = prepare_expansion (ty, ty') in
@@ -1869,9 +1866,10 @@ let report_error ppf = function
            (type_expansion ty) ty')
         (function ppf ->
            fprintf ppf "but is here used with type");
-      fprintf ppf ".@.@[<hov>%s@ %s@]"
-        "Simple coercions are not complete."
-        "Consider using a double coercion."
+      if b then
+        fprintf ppf ".@.@[<hov>%s@ %s@]"
+          "This simple coercion was not fully general."
+          "Consider using a double coercion."
   | Too_many_arguments (in_function, ty) ->
       reset_and_mark_loops ty;
       if in_function then begin

typing/typecore.mli

@@ -84,7 +84,8 @@ type error =
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
   | Outside_class
   | Value_multiply_overridden of string
-  | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list
+  | Coercion_failure of
+      type_expr * type_expr * (type_expr * type_expr) list * bool
   | Too_many_arguments of bool * type_expr
   | Abstract_wrong_label of label * type_expr
   | Scoping_let_module of string * type_expr

typing/typedecl.ml

@@ -587,6 +587,8 @@ let transl_with_constraint env sdecl =
       type_variance = [];
     }
   in
+  if Ctype.closed_type_decl decl <> None then
+    raise(Error(sdecl.ptype_loc, Unbound_type_var));
   let decl =
     {decl with type_variance =
      compute_variance_decl env decl (sdecl.ptype_variance, sdecl.ptype_loc)} in