diff options
| -rw-r--r-- | typing/ctype.ml | 2 | ||||
| -rw-r--r-- | typing/printtyp.ml | 22 | ||||
| -rw-r--r-- | typing/printtyp.mli | 3 | ||||
| -rw-r--r-- | typing/typeclass.ml | 8 |
4 files changed, 14 insertions, 21 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml index 4710b80f2..478143c85 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -3684,7 +3684,7 @@ and subtype_fields env trace ty1 ty2 cstrs = let cstrs = if rest2.desc = Tnil then cstrs else if miss1 = [] then - subtype_rec env trace rest1 rest2 cstrs + subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs else (trace, build_fields (repr ty1).level miss1 rest1, rest2, !univar_pairs) :: cstrs diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 572873257..84c0d1942 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -936,12 +936,12 @@ let rec trace fst txt ppf = function (trace false txt) rem | _ -> () -let rec filter_trace keep_last = function +let rec filter_trace = function | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' -> [] | (t1, t1') :: (t2, t2') :: rem -> - let rem' = filter_trace keep_last rem in - if t1 == t1' && t2 == t2' && (rem' <> [] || not keep_last) + let rem' = filter_trace rem in + if t1 == t1' && t2 == t2' then rem' else (t1, t1') :: (t2, t2') :: rem' | _ -> [] @@ -1085,7 +1085,7 @@ let unification_error unif tr txt1 ppf txt2 = | [] | _ :: [] -> assert false | t1 :: t2 :: tr -> try - let tr = filter_trace false tr in + let tr = filter_trace tr in let t1, t1' = may_prepare_expansion (tr = []) t1 and t2, t2' = may_prepare_expansion (tr = []) t2 in print_labels := not !Clflags.classic; @@ -1108,13 +1108,13 @@ let unification_error unif tr txt1 ppf txt2 = let report_unification_error ppf tr txt1 txt2 = unification_error true tr txt1 ppf txt2;; -let trace fst txt keep_last ppf tr = +let trace fst txt ppf tr = print_labels := not !Clflags.classic; trace_same_names tr; try match tr with t1 :: t2 :: tr' -> - if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr') - else trace fst txt ppf (filter_trace keep_last tr); + if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr') + else trace fst txt ppf (filter_trace tr); print_labels := true | _ -> () with exn -> @@ -1123,12 +1123,10 @@ let trace fst txt keep_last ppf tr = let report_subtyping_error ppf tr1 txt1 tr2 = reset (); - fprintf ppf "@["; let tr1 = List.map prepare_expansion tr1 and tr2 = List.map prepare_expansion tr2 in - trace true txt1 true ppf tr1; + trace true txt1 ppf tr1; if tr2 = [] then () else let mis = mismatch true tr2 in - trace false "is not compatible with type" false ppf tr2; - explanation true mis ppf; - fprintf ppf "@]" + trace false "is not compatible with type" ppf tr2; + explanation true mis ppf diff --git a/typing/printtyp.mli b/typing/printtyp.mli index c9e509211..5417ebf41 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -54,8 +54,7 @@ val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> rec_status -> o val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit val type_expansion: type_expr -> Format.formatter -> type_expr -> unit val prepare_expansion: type_expr * type_expr -> type_expr * type_expr -val trace: bool -> string -> bool -> - formatter -> (type_expr * type_expr) list -> unit +val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit val unification_error: bool -> (type_expr * type_expr) list -> (formatter -> unit) -> formatter -> (formatter -> unit) -> diff --git a/typing/typeclass.ml b/typing/typeclass.ml index c6eb108cd..5610c3e94 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -675,12 +675,8 @@ and class_structure cl_num final val_env met_env loc (spat, str) = end; (* Typing of method bodies *) - if !Clflags.principal then begin - Ctype.raise_nongen_level (); - Ctype.init_def (Ctype.get_current_level () - 1); - List.iter (fun (_,_,ty) -> Ctype.generalize_structure ty) methods; - Ctype.end_def () - end; + if !Clflags.principal then + List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods; let fields = List.map Lazy.force (List.rev fields) in if !Clflags.principal then List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) |