Commit 9733052e authored by Andrei Paskevich's avatar Andrei Paskevich

produce non-covered patterns correctly

parent b48d1573
......@@ -103,9 +103,8 @@ module Compile (X : Action) = struct
else begin
try compile constructors tl wilds
with NonExhaustive pl ->
let al = List.map pat_wild cs.ls_args in
let pat = pat_app cs al (of_option cs.ls_value) in
raise (NonExhaustive (pat::pl))
let al = List.map (fun t -> pat_wild t.t_ty) al in
raise (NonExhaustive (pat_app cs al ty :: pl))
end
| _ -> begin
let pw = pat_wild ty in
......@@ -115,8 +114,9 @@ module Compile (X : Action) = struct
let unused = Sls.filter test css in
if Sls.is_empty unused then None else
let cs = Sls.choose unused in
let pl = List.map pat_wild cs.ls_args in
Some (pat_app cs pl (of_option cs.ls_value))
let tm = ty_match Mtv.empty (of_option cs.ls_value) ty in
let wild ty = pat_wild (ty_inst tm ty) in
Some (pat_app cs (List.map wild cs.ls_args) ty)
in
let base = match nopat with
| None -> []
......
......@@ -199,15 +199,15 @@ and print_tnode pri fmt t = match t.t_node with
print_ls fs (print_list space (print_lterm 5)) tl
print_ty t.t_ty
| Tif (f,t1,t2) ->
fprintf fmt (protect_on (pri > 0) "if %a@ then %a@ else %a")
fprintf fmt (protect_on (pri > 0) "if @[%a@] then %a@ else %a")
print_fmla f print_term t1 print_term t2
| Tlet (t1,tb) ->
let v,t2 = t_open_bound tb in
fprintf fmt (protect_on (pri > 0) "let %a =@ %a in@ %a")
fprintf fmt (protect_on (pri > 0) "let %a = @[%a@] in@ %a")
print_vs v (print_lterm 4) t1 print_term t2;
forget_var v
| Tcase (t1,bl) ->
fprintf fmt "match %a with@\n@[<hov>%a@]@\nend"
fprintf fmt "match @[%a@] with@\n@[<hov>%a@]@\nend"
print_term t1 (print_list newline print_tbranch) bl
| Teps fb ->
let v,f = f_open_bound fb in
......@@ -240,15 +240,15 @@ and print_fnode pri fmt f = match f.f_node with
| Fnot f ->
fprintf fmt (protect_on (pri > 4) "not %a") (print_lfmla 4) f
| Fif (f1,f2,f3) ->
fprintf fmt (protect_on (pri > 0) "if %a@ then %a@ else %a")
fprintf fmt (protect_on (pri > 0) "if @[%a@] then %a@ else %a")
print_fmla f1 print_fmla f2 print_fmla f3
| Flet (t,f) ->
let v,f = f_open_bound f in
fprintf fmt (protect_on (pri > 0) "let %a =@ %a in@ %a")
fprintf fmt (protect_on (pri > 0) "let %a = @[%a@] in@ %a")
print_vs v (print_lterm 4) t print_fmla f;
forget_var v
| Fcase (t,bl) ->
fprintf fmt "match %a with@\n@[<hov>%a@]@\nend"
fprintf fmt "match @[%a@] with@\n@[<hov>%a@]@\nend"
print_term t (print_list newline print_fbranch) bl
and print_tbranch fmt br =
......@@ -487,9 +487,8 @@ let () = Exn_printer.register
fprintf fmt "Ident %s is already declared, with a different declaration"
id.id_string
| Decl.NonExhaustiveExpr (pl, e) ->
fprintf fmt
"Non-exhaustive pattern list:@\n@[<hov 2>%a@]@\nin expression %a"
(print_list newline print_pat) pl print_expr e
fprintf fmt "Pattern @[%a@] is not covered in expression:@\n @[%a@]"
(print_list comma print_pat) pl print_expr e
| _ -> raise exn
end
......@@ -31,19 +31,23 @@ let () =
exception Exit_loop
let exn_printer fmt exn =
let test f = try f fmt exn; raise Exit_loop
with Exit_loop -> raise Exit_loop
| _ -> () in
try
Stack.iter test exn_printers
let exn_printer fmt exn =
let test f =
try
Format.fprintf fmt "@[%a@]" f exn;
raise Exit_loop
with
| Exit_loop -> raise Exit_loop
| _ -> ()
in
try Stack.iter test exn_printers
with Exit_loop -> ()
(** For Config *)
let () = register
(fun fmt exn -> match exn with
| Config.Dynlink.Error error ->
Format.fprintf fmt "Dynlink: %s" (Config.Dynlink.error_message error)
| _ -> raise exn)
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