Commit 75f58353 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Do not try to print a sample for non-empty types that contain polymorphic variables.

parent 732a19d5
Pipeline #187 passed with stages
in 4 minutes and 21 seconds
......@@ -91,7 +91,7 @@ let rec print_exn ppf = function
Format.fprintf ppf "This expression should have type:@.%a@.%a@."
print_norm t print_protect msg
| Typer.ShouldHave2 (t1, msg, t2) ->
Format.fprintf ppf "This expression should have type:@.%a@.%a %a@."
Format.fprintf ppf "This expression should have type:@.%a@.%a@.%a@."
print_norm t1 print_protect msg print_norm t2
| Typer.Error s -> Format.fprintf ppf "%a@." print_protect s
| Typer.Constraint (s, t) ->
......
......@@ -525,12 +525,13 @@ module IType = struct
| Guard p -> mk_guard (derecurs env p)
| Seq
( (Elem { descr = PatVar ((id :: rest as ids), []); loc } as p1),
((Elem _| Seq (Elem _, _)) as p2)
) ->
let arg, make = match p2 with
Elem arg -> arg, fun x -> x
| Seq (Elem arg, pp2) -> arg, fun x -> mk_seq x (derecurs_regexp env pp2)
| _ -> assert false
((Elem _ | Seq (Elem _, _)) as p2) ) ->
let arg, make =
match p2 with
| Elem arg -> (arg, fun x -> x)
| Seq (Elem arg, pp2) ->
(arg, fun x -> mk_seq x (derecurs_regexp env pp2))
| _ -> assert false
in
let v = ident env.penv_tenv loc id in
let patch_arg =
......@@ -592,10 +593,9 @@ module IType = struct
| None ->
raise_loc_generic loc
(Printf.sprintf
"Wrong number of parameters for parametric type %s (%d, %d)"
(U.to_string id)
(List.length pargs) (List.length args)
)
"Wrong number of parameters for parametric type %s (%d, \
%d)"
(U.to_string id) (List.length pargs) (List.length args))
in
let sub = Types.Subst.from_list l in
let ti = mk_type (Types.Subst.apply_full sub t) in
......@@ -1216,19 +1216,26 @@ let localize loc f x =
warning loc s;
t
let constraint_exn t s =
if
Var.Set.is_empty (Types.Subst.vars t)
&& Var.Set.is_empty (Types.Subst.vars s)
then Constraint (t, s)
else ShouldHave2 (t, "but its inferred type is:", s)
let require loc t s =
if not (Types.subtype t s) then raise_loc loc (Constraint (t, s))
if not (Types.subtype t s) then raise_loc loc (constraint_exn t s)
let verify loc t s =
require loc t s;
t
let verify_noloc t s =
if not (Types.subtype t s) then raise (Constraint (t, s));
if not (Types.subtype t s) then raise (constraint_exn t s);
t
let check_str loc ofs t s =
if not (Types.subtype t s) then raise_loc_str loc ofs (Constraint (t, s));
if not (Types.subtype t s) then raise_loc_str loc ofs (constraint_exn t s);
t
let should_have loc constr s = raise_loc loc (ShouldHave (constr, s))
......@@ -1333,7 +1340,7 @@ and type_check' loc env e constr precise =
Types.Arrow.apply t1arrow t2
else
match Types.Tallying.squareapply env.mono_vars t1 t2 with
| None -> raise_loc loc (Constraint (t2, dom))
| None -> raise_loc loc (constraint_exn t2 dom)
| Some (_, res) -> res
(*
if Types.Arrow.need_arg t1 then
......@@ -1418,7 +1425,7 @@ and type_check_pair ?(kind = `Normal) loc env e1 e2 constr precise =
let t1 = type_check env e1 (Types.Product.pi1 rects) (precise || need_s) in
let c2 = Types.Product.constraint_on_2 rects t1 in
if Types.is_empty c2 then
raise_loc loc (ShouldHave2 (constr, "but the first component has type", t1));
raise_loc loc (ShouldHave2 (constr, "but the first component has type:", t1));
let t2 = type_check env e2 c2 precise in
if precise then
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment