retour sur les avertissements *unused pattern*
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5138 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Luc Maranget
parent
6b193ab37e
commit
987ce83e55
|
|
@ -187,7 +187,7 @@ let rec pretty_val ppf v = match v.pat_desc with
|
|||
(pretty_lvals (get_record_labels v.pat_type v.pat_env))
|
||||
(List.filter
|
||||
(function
|
||||
| (_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
|
||||
| (_,{pat_desc=Tpat_any}) -> true (* do not show lbl=_ *)
|
||||
| _ -> true) lvs)
|
||||
| Tpat_array vs ->
|
||||
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
|
||||
|
|
@ -309,9 +309,9 @@ let all_record_args lbls = match lbls with
|
|||
|
||||
|
||||
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
|
||||
let simple_match_args p1 p2 =
|
||||
match p2.pat_desc with
|
||||
Tpat_construct(cstr, args) -> args
|
||||
let rec simple_match_args p1 p2 = match p2.pat_desc with
|
||||
| Tpat_alias (p2,_) -> simple_match_args p1 p2
|
||||
| Tpat_construct(cstr, args) -> args
|
||||
| Tpat_variant(lab, Some arg, _) -> [arg]
|
||||
| Tpat_tuple(args) -> args
|
||||
| Tpat_record(args) -> extract_fields (record_arg p1) args
|
||||
|
|
@ -891,58 +891,6 @@ type answer =
|
|||
| Unused (* Useless pattern *)
|
||||
| Upartial of Typedtree.pattern list (* Neither, with list of useless pattern *)
|
||||
|
||||
(* Using location to spot supbatterns, strange hack ? *)
|
||||
|
||||
let sub_pat p1 p2 =
|
||||
let loc1 = p1.pat_loc and loc2 = p2.pat_loc in
|
||||
not (loc1.Location.loc_ghost || loc2.Location.loc_ghost) &&
|
||||
loc2.Location.loc_start <= loc1.Location.loc_start &&
|
||||
loc1.Location.loc_end <= loc2.Location.loc_end
|
||||
|
||||
(*
|
||||
Compute the ``unused pattern'' in qs=(p1|p2)::ps.
|
||||
Ie given a matrix pss compute the patterns that can be suppressed
|
||||
from qs, whitout changing values matching the last row of
|
||||
matrix pss@[qs]
|
||||
|
||||
ps1 and ps2 are the unused patterns in p1::ps and p2::ps respectively
|
||||
Hence p is unused in (p1|p2)::ps when
|
||||
- p is in ps1 and p occurs inside p1, or
|
||||
- p is in ps2 and p occurs inside p2, or
|
||||
- p is both in ps1 and ps2
|
||||
*)
|
||||
|
||||
let inter_almost ps1 ps2 =
|
||||
List.fold_left
|
||||
(fun r p ->
|
||||
if List.exists (fun q -> q.pat_loc = p.pat_loc) ps2 then
|
||||
p::r
|
||||
else
|
||||
r)
|
||||
[] ps1
|
||||
|
||||
let merge_almost p1 p2 ps1 ps2 =
|
||||
let keep1, check1 = List.partition (fun p -> sub_pat p p1) ps1
|
||||
and keep2, check2 = List.partition (fun p -> sub_pat p p2) ps2 in
|
||||
match keep1@keep2@inter_almost check1 check2 with
|
||||
| [] -> Used
|
||||
| l -> Upartial l
|
||||
|
||||
|
||||
let rec try_many r f = function
|
||||
| [] -> r
|
||||
| x::rem ->
|
||||
begin match f x, r with
|
||||
| Unused,_ -> try_many r f rem
|
||||
| Used,_ -> Used
|
||||
| _, Used -> Used
|
||||
| Upartial lnow, Unused -> try_many (Upartial lnow) f rem
|
||||
| Upartial lnow, Upartial lbef ->
|
||||
begin match inter_almost lnow lbef with
|
||||
| [] -> Used
|
||||
| l -> try_many (Upartial l) f rem
|
||||
end
|
||||
end
|
||||
|
||||
let pretty_pat p =
|
||||
top_pretty Format.str_formatter p ;
|
||||
|
|
@ -968,68 +916,202 @@ let pretty_matrix pss =
|
|||
pss ;
|
||||
prerr_endline "end matrix"
|
||||
|
||||
let rec every_satisfiable pss qs = match qs with
|
||||
| [] -> begin match pss with [] -> Used | _ -> Unused end
|
||||
| {pat_desc = Tpat_or(q1,q2,_); pat_loc = loc}::qs as all ->
|
||||
if loc.Location.loc_ghost then begin
|
||||
(* #t patterns, do not check unused pats *)
|
||||
if satisfiable pss all then Used else Unused
|
||||
end else if not (satisfiable pss (omega_list (omega::qs))) then
|
||||
Unused
|
||||
(* this row type enable column processing inside the matrix
|
||||
- left -> elements not to be processed,
|
||||
- right -> elements to be processed
|
||||
*)
|
||||
type 'a row = {left : 'a list ; right : 'a list}
|
||||
|
||||
|
||||
let pretty_row {left=ps ; right=qs} =
|
||||
pretty_line ps ; prerr_string " * " ;
|
||||
pretty_line qs
|
||||
|
||||
let pretty_rows rs =
|
||||
prerr_endline "begin matrix" ;
|
||||
List.iter
|
||||
(fun r ->
|
||||
pretty_row r ;
|
||||
prerr_endline "")
|
||||
rs ;
|
||||
prerr_endline "end matrix"
|
||||
|
||||
(* Initial build *)
|
||||
let make_row ps = {left=[] ; right=ps}
|
||||
|
||||
let make_rows pss = List.map make_row pss
|
||||
|
||||
|
||||
(* Useful to detect and expand or pats inside as pats *)
|
||||
let rec unalias p = match p.pat_desc with
|
||||
| Tpat_alias (p,_) -> unalias p
|
||||
| _ -> p
|
||||
|
||||
|
||||
let is_var p = match (unalias p).pat_desc with
|
||||
| Tpat_any|Tpat_var _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_var_column rs =
|
||||
List.for_all
|
||||
(fun r -> match r.right with
|
||||
| p::_ -> is_var p
|
||||
| [] -> assert false)
|
||||
rs
|
||||
|
||||
(* Just remove current column *)
|
||||
let remove r = match r.right with
|
||||
| _::rem -> {r with right=rem}
|
||||
| [] -> assert false
|
||||
|
||||
let remove_column rs = List.map remove rs
|
||||
|
||||
(* Current column has been processed *)
|
||||
let push r = match r.right with
|
||||
| p::rem -> {left = p::r.left ; right=rem}
|
||||
| [] -> assert false
|
||||
|
||||
let push_column rs = List.map push rs
|
||||
|
||||
(* Those are adaptations of the previous homonymous functions that
|
||||
work on the current column, instead of the first column
|
||||
*)
|
||||
|
||||
let discr_pat q rs =
|
||||
discr_pat q (List.map (fun r -> r.right) rs)
|
||||
|
||||
let filter_one q rs =
|
||||
let rec filter_rec rs = match rs with
|
||||
| [] -> []
|
||||
| r::rem ->
|
||||
match r.right with
|
||||
| [] -> assert false
|
||||
| {pat_desc = Tpat_alias(p,_)}::ps ->
|
||||
filter_rec ({r with right = p::ps}::rem)
|
||||
| {pat_desc = Tpat_or(p1,p2,_)}::ps ->
|
||||
filter_rec
|
||||
({r with right = p1::ps}::
|
||||
{r with right = p2::ps}::
|
||||
rem)
|
||||
| p::ps ->
|
||||
if simple_match q p then
|
||||
{r with right=simple_match_args q p @ ps} :: filter_rec rem
|
||||
else
|
||||
begin match every_satisfiable pss (q1::qs) with
|
||||
filter_rec rem in
|
||||
filter_rec rs
|
||||
|
||||
|
||||
(* Back to normal matrices *)
|
||||
let make_vector r = r.left @ r.right
|
||||
|
||||
let make_matrix rs = List.map make_vector rs
|
||||
|
||||
|
||||
(* consider every elements but the current one are processed *)
|
||||
let out_element r = match r.right with
|
||||
| p::rem -> {left = List.rev_append r.left rem ; right=[p]}
|
||||
| [] -> assert false
|
||||
|
||||
let out_column rs = List.map out_element rs
|
||||
|
||||
(* Standard union on answers *)
|
||||
let union_res r1 r2 = match r1, r2 with
|
||||
| Unused,_ -> Unused
|
||||
| _, Unused -> Unused
|
||||
| Used,_ -> r2
|
||||
| _, Used -> r1
|
||||
| Upartial u1, Upartial u2 -> Upartial (u1@u2)
|
||||
|
||||
let verb_satisfiable pss qs =
|
||||
prerr_endline "++++++++" ;
|
||||
pretty_matrix pss ;
|
||||
pretty_line qs ;
|
||||
let r = satisfiable pss qs in
|
||||
if r then
|
||||
prerr_endline "\nTRUE"
|
||||
else
|
||||
prerr_endline "\nFALSE" ;
|
||||
r
|
||||
|
||||
(* Core function
|
||||
The idea is to expand constructor pats and
|
||||
check or-patterns arguments at the same time.
|
||||
*)
|
||||
|
||||
let rec every_satisfiables pss qs = match qs.right with
|
||||
| [] ->
|
||||
(* qs is now a or-pattern expansion, check usefulness *)
|
||||
if satisfiable (make_matrix pss) (make_vector qs) then
|
||||
Used
|
||||
else
|
||||
Unused
|
||||
| q::rem ->
|
||||
let uq = unalias q in
|
||||
begin match uq.pat_desc with
|
||||
| Tpat_any | Tpat_var _ ->
|
||||
if is_var_column pss then
|
||||
(* forget about ``all-variable'' columns now *)
|
||||
every_satisfiables (remove_column pss) (remove qs)
|
||||
else
|
||||
(* otherwise this is direct food for satisfy *)
|
||||
every_satisfiables (push_column pss) (push qs)
|
||||
| Tpat_or (q1,q2,_) ->
|
||||
if uq.pat_loc.Location.loc_ghost then
|
||||
(* syntactically generated or-pats should not be expanded *)
|
||||
every_satisfiables (push_column pss) (push qs)
|
||||
else
|
||||
(* check usefulness of a or-pattern *)
|
||||
let r1 = every_both pss qs q1 q2
|
||||
and r2 = every_satisfiables (push_column pss) (push qs) in
|
||||
union_res r1 r2
|
||||
| Tpat_variant (l,_,r) when is_absent l r ->
|
||||
Unused
|
||||
| _ ->
|
||||
(* standard case, filter matrix *)
|
||||
let q0 = discr_pat q pss in
|
||||
every_satisfiables
|
||||
(filter_one q0 pss)
|
||||
{qs with right=simple_match_args q0 q @ rem}
|
||||
end
|
||||
|
||||
(*
|
||||
This function ``every_both'' performs the usefulness check
|
||||
of or-pat q1|q2.
|
||||
The trick is to call every_satisfied twice with
|
||||
current active columns restricted to q1 and q2,
|
||||
That way,
|
||||
- others orpats in qs.right will not get expanded.
|
||||
- all matching work performed on qs.left is not performed again.
|
||||
*)
|
||||
and every_both pss qs q1 q2 =
|
||||
let pss = out_column pss
|
||||
and qs = out_element qs in
|
||||
let qs1 = {qs with right=[q1]}
|
||||
and qs2 = {qs with right=[q2]} in
|
||||
let r1 = every_satisfiables pss qs1
|
||||
and r2 = every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
|
||||
match r1 with
|
||||
| Unused ->
|
||||
begin match every_satisfiable pss (q2::qs) with
|
||||
| Used -> Upartial [q1]
|
||||
| Upartial l2 -> Upartial (q1::l2)
|
||||
begin match r2 with
|
||||
| Unused -> Unused
|
||||
| Used -> Upartial [q1]
|
||||
| Upartial u2 -> Upartial (q1::u2)
|
||||
end
|
||||
| Used ->
|
||||
begin
|
||||
match
|
||||
every_satisfiable
|
||||
(if compat q1 q2 then (q1::qs)::pss else pss) (q2::qs)
|
||||
with
|
||||
| Used -> Used
|
||||
| Upartial l2 -> merge_almost q1 q2 [] l2
|
||||
begin match r2 with
|
||||
| Unused -> Upartial [q2]
|
||||
| _ -> r2
|
||||
end
|
||||
| Upartial l1 ->
|
||||
begin
|
||||
match
|
||||
every_satisfiable
|
||||
(if compat q1 q2 then (q1::qs)::pss else pss) (q2::qs)
|
||||
with
|
||||
| Used -> merge_almost q1 q2 l1 []
|
||||
| Upartial l2 -> merge_almost q1 q2 l1 l2
|
||||
| Unused -> Upartial (l1@[q2])
|
||||
| Upartial u1 ->
|
||||
begin match r2 with
|
||||
| Unused -> Upartial (u1@[q2])
|
||||
| Used -> r1
|
||||
| Upartial u2 -> Upartial (u1 @ u2)
|
||||
end
|
||||
end
|
||||
| {pat_desc = Tpat_alias(q,_)}::qs ->
|
||||
every_satisfiable pss (q::qs)
|
||||
| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
|
||||
let q0 = discr_pat omega pss in
|
||||
begin match filter_all q0 pss with
|
||||
(* first column of pss is made of variables only *)
|
||||
| [] -> every_satisfiable (filter_extra pss) qs
|
||||
| constrs ->
|
||||
let try_non_omega (p,pss) =
|
||||
every_satisfiable pss (simple_match_args p omega @ qs) in
|
||||
if full_match Env.empty false constrs
|
||||
then try_many Unused try_non_omega constrs
|
||||
else
|
||||
match every_satisfiable (filter_extra pss) qs with
|
||||
| Used -> Used
|
||||
| r -> try_many r try_non_omega constrs
|
||||
end
|
||||
| {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> Unused
|
||||
| q::qs ->
|
||||
let q0 = discr_pat q pss in
|
||||
every_satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
|
||||
|
||||
|
||||
let has_guard act =
|
||||
match act.exp_desc with
|
||||
(* Foo *)
|
||||
let has_guard act = match act.exp_desc with
|
||||
Texp_when(_, _) -> true
|
||||
| _ -> false
|
||||
|
||||
|
|
@ -1272,7 +1354,7 @@ let check_partial tdefs loc casel =
|
|||
(* This is ``Some l'', where l is the location of
|
||||
a possibly matching clause.
|
||||
I forget about l, because printing two locations
|
||||
is a plain in the top-level *)
|
||||
is a pain in the top-level *)
|
||||
Buffer.add_string buf
|
||||
"\n(However, some guarded clause may match this value.)"
|
||||
end ;
|
||||
|
|
@ -1287,16 +1369,6 @@ let check_partial tdefs loc casel =
|
|||
let location_of_clause = function
|
||||
pat :: _ -> pat.pat_loc
|
||||
| _ -> fatal_error "Parmatch.location_of_clause"
|
||||
(*
|
||||
let rec or_inside p = match p.pat_desc with
|
||||
| Tpat_or (_,_,_) -> true
|
||||
| Tpat_any | Tpat_var _ | Tpat_variant (_,None,_)|Tpat_constant _ -> false
|
||||
| Tpat_alias (q,_) | Tpat_variant (_,Some q,_) -> or_inside q
|
||||
| Tpat_tuple qs | Tpat_construct (_,qs) | Tpat_array qs -> or_insides qs
|
||||
| Tpat_record lqs -> or_insides (List.map snd lqs)
|
||||
|
||||
and or_insides ps = List.exists or_inside ps
|
||||
*)
|
||||
|
||||
let check_unused tdefs casel =
|
||||
if Warnings.is_active Warnings.Unused_match then
|
||||
|
|
@ -1311,7 +1383,8 @@ let check_unused tdefs casel =
|
|||
List.iter
|
||||
(fun (pss, ((qs, _) as clause)) ->
|
||||
try
|
||||
let r = every_satisfiable pss qs in
|
||||
let r = every_satisfiables
|
||||
(make_rows (get_mins le_pats pss)) (make_row qs) in
|
||||
match r with
|
||||
| Unused ->
|
||||
Location.prerr_warning
|
||||
|
|
@ -1323,12 +1396,8 @@ let check_unused tdefs casel =
|
|||
p.pat_loc Warnings.Unused_pat)
|
||||
ps
|
||||
| Used -> ()
|
||||
with e ->
|
||||
with e -> (* useless ? *)
|
||||
Location.prerr_warning (location_of_clause qs)
|
||||
(Warnings.Other "Fatal Error in Parmatch.check_unused") ;
|
||||
raise e)
|
||||
prefs
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue