2016-02-18 07:11:59 -08:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* OCaml *)
|
|
|
|
(* *)
|
|
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
|
|
(* *)
|
|
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
|
|
(* en Automatique. *)
|
|
|
|
(* *)
|
|
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
1995-08-09 08:06:35 -07:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Detection of partial matches and unused match cases. *)
|
|
|
|
|
|
|
|
open Misc
|
|
|
|
open Asttypes
|
1996-09-23 04:33:27 -07:00
|
|
|
open Types
|
1995-05-04 03:15:53 -07:00
|
|
|
open Typedtree
|
|
|
|
|
2019-08-19 00:48:59 -07:00
|
|
|
|
2002-05-24 07:34:37 -07:00
|
|
|
(*************************************)
|
|
|
|
(* Utilities for building patterns *)
|
|
|
|
(*************************************)
|
|
|
|
|
|
|
|
let make_pat desc ty tenv =
|
2012-05-30 07:52:37 -07:00
|
|
|
{pat_desc = desc; pat_loc = Location.none; pat_extra = [];
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_type = ty ; pat_env = tenv;
|
|
|
|
pat_attributes = [];
|
|
|
|
}
|
2002-05-24 07:34:37 -07:00
|
|
|
|
2019-08-19 00:48:59 -07:00
|
|
|
let omega = Patterns.omega
|
|
|
|
let omegas = Patterns.omegas
|
|
|
|
let omega_list = Patterns.omega_list
|
2002-05-24 07:34:37 -07:00
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
let extra_pat =
|
2012-05-30 07:52:37 -07:00
|
|
|
make_pat
|
2018-08-28 09:07:01 -07:00
|
|
|
(Tpat_var (Ident.create_local "+", mknoloc "+"))
|
2012-05-30 07:52:37 -07:00
|
|
|
Ctype.none Env.empty
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
|
2017-12-07 10:33:01 -08:00
|
|
|
(*******************)
|
|
|
|
(* Coherence check *)
|
|
|
|
(*******************)
|
|
|
|
|
|
|
|
(* For some of the operations we do in this module, we would like (because it
|
|
|
|
simplifies matters) to assume that patterns appearing on a given column in a
|
|
|
|
pattern matrix are /coherent/ (think "of the same type").
|
|
|
|
Unfortunately that is not always true.
|
|
|
|
|
|
|
|
Consider the following (well-typed) example:
|
|
|
|
{[
|
|
|
|
type _ t = S : string t | U : unit t
|
|
|
|
|
|
|
|
let f (type a) (t1 : a t) (t2 : a t) (a : a) =
|
|
|
|
match t1, t2, a with
|
|
|
|
| U, _, () -> ()
|
|
|
|
| _, S, "" -> ()
|
|
|
|
]}
|
|
|
|
|
|
|
|
Clearly the 3rd column contains incoherent patterns.
|
|
|
|
|
|
|
|
On the example above, most of the algorithms will explore the pattern matrix
|
|
|
|
as illustrated by the following tree:
|
|
|
|
|
|
|
|
{v
|
|
|
|
S
|
|
|
|
-------> | "" |
|
|
|
|
U | S, "" | __/ | () |
|
2018-06-07 02:04:25 -07:00
|
|
|
--------> | _, () | \ not S
|
2017-12-07 10:33:01 -08:00
|
|
|
| U, _, () | __/ -------> | () |
|
|
|
|
| _, S, "" | \
|
|
|
|
---------> | S, "" | ----------> | "" |
|
2018-06-07 02:04:25 -07:00
|
|
|
not U S
|
2017-12-07 10:33:01 -08:00
|
|
|
v}
|
|
|
|
|
|
|
|
where following an edge labelled by a pattern P means "assuming the value I
|
|
|
|
am matching on is filtered by [P] on the column I am currently looking at,
|
|
|
|
then the following submatrix is still reachable".
|
|
|
|
|
|
|
|
Notice that at any point of that tree, if the first column of a matrix is
|
|
|
|
incoherent, then the branch leading to it can only be taken if the scrutinee
|
|
|
|
is ill-typed.
|
|
|
|
In the example above the only case where we have a matrix with an incoherent
|
|
|
|
first column is when we consider [t1, t2, a] to be [U, S, ...]. However such
|
|
|
|
a value would be ill-typed, so we can never actually get there.
|
|
|
|
|
|
|
|
Checking the first column at each step of the recursion and making the
|
Fixing typos in various files (#2246)
Note: Typos found with https://github.com/codespell-project/codespell
Here is the (semi-manual) command used to get (and correct) the typos:
$ codespell -i 3 -w --skip=".png,.gif,./ocaml/boot,./ocaml/.git,./ocaml/manual/styles,./ocaml/manual/manual/htmlman" -L minimise,instal,contructor,"o'caml",cristal,pres,clos,cmo,uint,iff,te,objext,nto,nd,mut,upto,larg,exten,leage,mthod,delte,tim,atleast,langage,hten,iwth,mke,contant,succint,methids,eles,valu,clas,modul,que,classe,missings,froms,defaut,correspondance,differents,configury,reachs,cas,approche,normale,dur,millon,amin,oje,transfert
2019-02-13 05:04:56 -08:00
|
|
|
conscious decision of "aborting" the algorithm whenever the first column
|
2017-12-07 10:33:01 -08:00
|
|
|
becomes incoherent, allows us to retain the initial assumption in later
|
|
|
|
stages of the algorithms.
|
|
|
|
|
|
|
|
---
|
|
|
|
|
|
|
|
N.B. two patterns can be considered coherent even though they might not be of
|
|
|
|
the same type.
|
|
|
|
|
|
|
|
That's in part because we only care about the "head" of patterns and leave
|
|
|
|
checking coherence of subpatterns for the next steps of the algorithm:
|
|
|
|
('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples
|
|
|
|
of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1).
|
|
|
|
|
|
|
|
But also because it can be hard/costly to determine exactly whether two
|
|
|
|
patterns are of the same type or not (eg. in the example above with _ and S,
|
|
|
|
but see also the module [Coherence_illustration] in
|
|
|
|
testsuite/tests/basic-more/robustmatch.ml).
|
|
|
|
|
|
|
|
For the moment our weak, loosely-syntactic, coherence check seems to be
|
|
|
|
enough and we leave it to each user to consider (and document!) what happens
|
|
|
|
when an "incoherence" is not detected by this check.
|
|
|
|
*)
|
|
|
|
|
|
|
|
(* Given the first column of a simplified matrix, this function first looks for
|
|
|
|
a "discriminating" pattern on that column (i.e. a non-omega one) and then
|
|
|
|
check that every other head pattern in the column is coherent with that one.
|
|
|
|
*)
|
|
|
|
let all_coherent column =
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
2017-12-07 10:33:01 -08:00
|
|
|
let coherent_heads hp1 hp2 =
|
2019-09-09 08:54:09 -07:00
|
|
|
match hp1.pat_desc, hp2.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Construct c, Construct c' ->
|
2017-12-07 10:33:01 -08:00
|
|
|
c.cstr_consts = c'.cstr_consts
|
|
|
|
&& c.cstr_nonconsts = c'.cstr_nonconsts
|
2019-06-13 10:25:10 -07:00
|
|
|
| Constant c1, Constant c2 -> begin
|
2017-12-07 10:33:01 -08:00
|
|
|
match c1, c2 with
|
|
|
|
| Const_char _, Const_char _
|
|
|
|
| Const_int _, Const_int _
|
|
|
|
| Const_int32 _, Const_int32 _
|
|
|
|
| Const_int64 _, Const_int64 _
|
|
|
|
| Const_nativeint _, Const_nativeint _
|
|
|
|
| Const_float _, Const_float _
|
|
|
|
| Const_string _, Const_string _ -> true
|
|
|
|
| ( Const_char _
|
|
|
|
| Const_int _
|
|
|
|
| Const_int32 _
|
|
|
|
| Const_int64 _
|
|
|
|
| Const_nativeint _
|
|
|
|
| Const_float _
|
|
|
|
| Const_string _), _ -> false
|
|
|
|
end
|
2019-06-13 10:25:10 -07:00
|
|
|
| Tuple l1, Tuple l2 -> l1 = l2
|
|
|
|
| Record (lbl1 :: _), Record (lbl2 :: _) ->
|
2017-12-07 10:33:01 -08:00
|
|
|
Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
|
2019-06-13 10:25:10 -07:00
|
|
|
| Any, _
|
|
|
|
| _, Any
|
|
|
|
| Record [], Record []
|
|
|
|
| Variant _, Variant _
|
|
|
|
| Array _, Array _
|
|
|
|
| Lazy, Lazy -> true
|
2017-12-07 10:33:01 -08:00
|
|
|
| _, _ -> false
|
|
|
|
in
|
|
|
|
match
|
2019-09-09 08:54:09 -07:00
|
|
|
List.find
|
|
|
|
(function
|
|
|
|
| { pat_desc = Any } -> false
|
|
|
|
| _ -> true)
|
|
|
|
column
|
2017-12-07 10:33:01 -08:00
|
|
|
with
|
|
|
|
| exception Not_found ->
|
|
|
|
(* only omegas on the column: the column is coherent. *)
|
|
|
|
true
|
|
|
|
| discr_pat ->
|
|
|
|
List.for_all (coherent_heads discr_pat) column
|
|
|
|
|
|
|
|
let first_column simplified_matrix =
|
2019-06-13 10:25:10 -07:00
|
|
|
List.map (fun ((head, _args), _rest) -> head) simplified_matrix
|
2017-12-07 10:33:01 -08:00
|
|
|
|
2002-05-24 07:34:37 -07:00
|
|
|
(***********************)
|
|
|
|
(* Compatibility check *)
|
|
|
|
(***********************)
|
|
|
|
|
2017-11-21 06:11:37 -08:00
|
|
|
(* Patterns p and q compatible means:
|
|
|
|
there exists value V that matches both, However....
|
|
|
|
|
|
|
|
The case of extension types is dubious, as constructor rebind permits
|
|
|
|
that different constructors are the same (and are thus compatible).
|
|
|
|
|
|
|
|
Compilation must take this into account, consider:
|
|
|
|
|
|
|
|
type t = ..
|
|
|
|
type t += A|B
|
|
|
|
type t += C=A
|
|
|
|
|
|
|
|
let f x y = match x,y with
|
|
|
|
| true,A -> '1'
|
|
|
|
| _,C -> '2'
|
|
|
|
| false,A -> '3'
|
|
|
|
| _,_ -> '_'
|
|
|
|
|
|
|
|
As C is bound to A the value of f false A is '2' (and not '3' as it would
|
|
|
|
be in the absence of rebinding).
|
|
|
|
|
|
|
|
Not considering rebinding, patterns "false,A" and "_,C" are incompatible
|
|
|
|
and the compiler can swap the second and third clause, resulting in the
|
|
|
|
(more efficiently compiled) matching
|
|
|
|
|
|
|
|
match x,y with
|
|
|
|
| true,A -> '1'
|
|
|
|
| false,A -> '3'
|
|
|
|
| _,C -> '2'
|
|
|
|
| _,_ -> '_'
|
|
|
|
|
|
|
|
This is not correct: when C is bound to A, "f false A" returns '2' (not '3')
|
|
|
|
|
|
|
|
|
|
|
|
However, diagnostics do not take constructor rebinding into account.
|
|
|
|
Notice, that due to module abstraction constructor rebinding is hidden.
|
|
|
|
|
|
|
|
module X : sig type t = .. type t += A|B end = struct
|
|
|
|
type t = ..
|
|
|
|
type t += A
|
|
|
|
type t += B=A
|
|
|
|
end
|
|
|
|
|
|
|
|
open X
|
|
|
|
|
|
|
|
let f x = match x with
|
|
|
|
| A -> '1'
|
|
|
|
| B -> '2'
|
|
|
|
| _ -> '_'
|
|
|
|
|
|
|
|
The second clause above will NOT (and cannot) be flagged as useless.
|
|
|
|
|
Fixing typos in various files (#2246)
Note: Typos found with https://github.com/codespell-project/codespell
Here is the (semi-manual) command used to get (and correct) the typos:
$ codespell -i 3 -w --skip=".png,.gif,./ocaml/boot,./ocaml/.git,./ocaml/manual/styles,./ocaml/manual/manual/htmlman" -L minimise,instal,contructor,"o'caml",cristal,pres,clos,cmo,uint,iff,te,objext,nto,nd,mut,upto,larg,exten,leage,mthod,delte,tim,atleast,langage,hten,iwth,mke,contant,succint,methids,eles,valu,clas,modul,que,classe,missings,froms,defaut,correspondance,differents,configury,reachs,cas,approche,normale,dur,millon,amin,oje,transfert
2019-02-13 05:04:56 -08:00
|
|
|
Finally, there are two compatibility functions:
|
2017-11-21 06:11:37 -08:00
|
|
|
compat p q ---> 'syntactic compatibility, used for diagnostics.
|
|
|
|
may_compat p q ---> a safe approximation of possible compat,
|
|
|
|
for compilation
|
|
|
|
|
|
|
|
*)
|
|
|
|
|
2002-05-24 07:34:37 -07:00
|
|
|
|
2008-01-11 08:13:18 -08:00
|
|
|
let is_absent tag row = Btype.row_field tag !row = Rabsent
|
2004-01-09 05:12:17 -08:00
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
let is_absent_pat d =
|
2019-09-09 08:54:09 -07:00
|
|
|
match d.pat_desc with
|
|
|
|
| Patterns.Head.Variant { tag; cstr_row; _ } -> is_absent tag cstr_row
|
2019-06-13 10:25:10 -07:00
|
|
|
| _ -> false
|
2002-05-24 07:34:37 -07:00
|
|
|
|
2012-09-18 23:57:17 -07:00
|
|
|
let const_compare x y =
|
|
|
|
match x,y with
|
|
|
|
| Const_float f1, Const_float f2 ->
|
2018-08-27 04:42:14 -07:00
|
|
|
Stdlib.compare (float_of_string f1) (float_of_string f2)
|
2019-07-22 09:21:26 -07:00
|
|
|
| Const_string (s1, _, _), Const_string (s2, _, _) ->
|
2014-03-21 10:02:44 -07:00
|
|
|
String.compare s1 s2
|
2017-11-22 21:00:19 -08:00
|
|
|
| (Const_int _
|
|
|
|
|Const_char _
|
2019-07-22 09:21:26 -07:00
|
|
|
|Const_string (_, _, _)
|
2017-11-22 21:00:19 -08:00
|
|
|
|Const_float _
|
|
|
|
|Const_int32 _
|
|
|
|
|Const_int64 _
|
|
|
|
|Const_nativeint _
|
2018-08-27 04:42:14 -07:00
|
|
|
), _ -> Stdlib.compare x y
|
2012-09-18 23:57:17 -07:00
|
|
|
|
2002-05-24 07:34:37 -07:00
|
|
|
let records_args l1 l2 =
|
2011-06-15 02:26:30 -07:00
|
|
|
(* Invariant: fields are already sorted by Typecore.type_label_a_list *)
|
2002-05-24 07:34:37 -07:00
|
|
|
let rec combine r1 r2 l1 l2 = match l1,l2 with
|
2011-06-15 02:26:30 -07:00
|
|
|
| [],[] -> List.rev r1, List.rev r2
|
2012-10-24 05:03:00 -07:00
|
|
|
| [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
|
|
|
|
| (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
|
|
|
|
| (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
|
2002-05-24 07:34:37 -07:00
|
|
|
if lbl1.lbl_pos < lbl2.lbl_pos then
|
|
|
|
combine (p1::r1) (omega::r2) rem1 l2
|
|
|
|
else if lbl1.lbl_pos > lbl2.lbl_pos then
|
|
|
|
combine (omega::r1) (p2::r2) l1 rem2
|
|
|
|
else (* same label on both sides *)
|
|
|
|
combine (p1::r1) (p2::r2) rem1 rem2 in
|
|
|
|
combine [] [] l1 l2
|
|
|
|
|
|
|
|
|
2017-11-21 06:11:37 -08:00
|
|
|
|
|
|
|
module Compat
|
|
|
|
(Constr:sig
|
|
|
|
val equal :
|
|
|
|
Types.constructor_description ->
|
|
|
|
Types.constructor_description ->
|
|
|
|
bool
|
|
|
|
end) = struct
|
|
|
|
|
|
|
|
let rec compat p q = match p.pat_desc,q.pat_desc with
|
|
|
|
(* Variables match any value *)
|
|
|
|
| ((Tpat_any|Tpat_var _),_)
|
|
|
|
| (_,(Tpat_any|Tpat_var _)) -> true
|
|
|
|
(* Structural induction *)
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_alias (p,_,_),_ -> compat p q
|
|
|
|
| _,Tpat_alias (q,_,_) -> compat p q
|
2017-11-21 06:11:37 -08:00
|
|
|
| Tpat_or (p1,p2,_),_ ->
|
|
|
|
(compat p1 q || compat p2 q)
|
|
|
|
| _,Tpat_or (q1,q2,_) ->
|
|
|
|
(compat p q1 || compat p q2)
|
|
|
|
(* Constructors, with special case for extension *)
|
|
|
|
| Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
|
|
|
|
Constr.equal c1 c2 && compats ps1 ps2
|
|
|
|
(* More standard stuff *)
|
|
|
|
| Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) ->
|
|
|
|
l1=l2 && ocompat op1 op2
|
|
|
|
| Tpat_constant c1, Tpat_constant c2 ->
|
|
|
|
const_compare c1 c2 = 0
|
2002-05-24 07:34:37 -07:00
|
|
|
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
|
2008-07-09 06:03:38 -07:00
|
|
|
| Tpat_lazy p, Tpat_lazy q -> compat p q
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_record (l1,_),Tpat_record (l2,_) ->
|
2002-05-24 07:34:37 -07:00
|
|
|
let ps,qs = records_args l1 l2 in
|
|
|
|
compats ps qs
|
|
|
|
| Tpat_array ps, Tpat_array qs ->
|
|
|
|
List.length ps = List.length qs &&
|
|
|
|
compats ps qs
|
2017-12-07 02:53:49 -08:00
|
|
|
| _,_ -> false
|
2017-11-21 06:11:37 -08:00
|
|
|
|
|
|
|
and ocompat op oq = match op,oq with
|
|
|
|
| None,None -> true
|
|
|
|
| Some p,Some q -> compat p q
|
|
|
|
| (None,Some _)|(Some _,None) -> false
|
|
|
|
|
|
|
|
and compats ps qs = match ps,qs with
|
|
|
|
| [], [] -> true
|
|
|
|
| p::ps, q::qs -> compat p q && compats ps qs
|
2017-12-07 02:53:49 -08:00
|
|
|
| _,_ -> false
|
2017-11-21 06:11:37 -08:00
|
|
|
|
|
|
|
end
|
|
|
|
|
|
|
|
module SyntacticCompat =
|
|
|
|
Compat
|
|
|
|
(struct
|
|
|
|
let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag
|
|
|
|
end)
|
|
|
|
|
|
|
|
let compat = SyntacticCompat.compat
|
|
|
|
and compats = SyntacticCompat.compats
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2017-11-21 06:11:37 -08:00
|
|
|
(* Due to (potential) rebinding, two extension constructors
|
|
|
|
of the same arity type may equal *)
|
2002-05-24 07:34:37 -07:00
|
|
|
|
2014-04-28 19:25:04 -07:00
|
|
|
exception Empty (* Empty pattern *)
|
|
|
|
|
1999-10-29 07:42:37 -07:00
|
|
|
(****************************************)
|
2014-04-28 19:25:04 -07:00
|
|
|
(* Utilities for retrieving type paths *)
|
1999-10-29 07:42:37 -07:00
|
|
|
(****************************************)
|
|
|
|
|
2009-05-20 04:52:42 -07:00
|
|
|
(* May need a clean copy, cf. PR#4745 *)
|
|
|
|
let clean_copy ty =
|
|
|
|
if ty.level = Btype.generic_level then ty
|
|
|
|
else Subst.type_expr Subst.identity ty
|
|
|
|
|
2017-02-23 10:24:36 -08:00
|
|
|
let get_constructor_type_path ty tenv =
|
2009-05-20 04:52:42 -07:00
|
|
|
let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
|
2003-05-02 02:57:53 -07:00
|
|
|
match ty.desc with
|
2017-11-03 11:23:20 -07:00
|
|
|
| Tconstr (path,_,_) -> path
|
|
|
|
| _ -> assert false
|
2003-05-02 02:57:53 -07:00
|
|
|
|
1999-10-29 07:42:37 -07:00
|
|
|
(****************************)
|
|
|
|
(* Utilities for matching *)
|
|
|
|
(****************************)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1999-10-29 07:42:37 -07:00
|
|
|
(* Check top matching *)
|
2019-06-13 10:25:10 -07:00
|
|
|
let simple_match d h =
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
|
|
|
match d.pat_desc, h.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Construct c1, Construct c2 ->
|
2017-04-28 07:31:52 -07:00
|
|
|
Types.equal_tag c1.cstr_tag c2.cstr_tag
|
2019-06-13 10:25:10 -07:00
|
|
|
| Variant { tag = t1; _ }, Variant { tag = t2 } ->
|
|
|
|
t1 = t2
|
|
|
|
| Constant c1, Constant c2 -> const_compare c1 c2 = 0
|
|
|
|
| Lazy, Lazy -> true
|
|
|
|
| Record _, Record _ -> true
|
|
|
|
| Tuple len1, Tuple len2
|
|
|
|
| Array len1, Array len2 -> len1 = len2
|
|
|
|
| _, Any -> true
|
1995-05-04 03:15:53 -07:00
|
|
|
| _, _ -> false
|
|
|
|
|
|
|
|
|
|
|
|
|
1999-10-29 07:42:37 -07:00
|
|
|
(* extract record fields as a whole *)
|
2019-09-09 08:54:09 -07:00
|
|
|
let record_arg ph =
|
|
|
|
let open Patterns.Head in
|
|
|
|
match ph.pat_desc with
|
|
|
|
| Any -> []
|
|
|
|
| Record args -> args
|
|
|
|
| _ -> fatal_error "Parmatch.as_record"
|
1999-10-29 07:42:37 -07:00
|
|
|
|
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
let extract_fields lbls arg =
|
2019-07-16 02:15:40 -07:00
|
|
|
let get_field pos arg =
|
|
|
|
match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with
|
|
|
|
| _, p -> p
|
|
|
|
| exception Not_found -> omega
|
|
|
|
in
|
|
|
|
List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls
|
1999-10-29 07:42:37 -07:00
|
|
|
|
|
|
|
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
|
2019-09-09 08:54:09 -07:00
|
|
|
let simple_match_args discr head args =
|
|
|
|
let open Patterns.Head in
|
|
|
|
match head.pat_desc with
|
|
|
|
| Constant _ -> []
|
|
|
|
| Construct _
|
|
|
|
| Variant _
|
|
|
|
| Tuple _
|
|
|
|
| Array _
|
|
|
|
| Lazy -> args
|
|
|
|
| Record lbls -> extract_fields (record_arg discr) (List.combine lbls args)
|
|
|
|
| Any ->
|
|
|
|
begin match discr.pat_desc with
|
|
|
|
| Construct cstr -> Patterns.omegas cstr.cstr_arity
|
|
|
|
| Variant { has_arg = true }
|
|
|
|
| Lazy -> [Patterns.omega]
|
|
|
|
| Record lbls -> omega_list lbls
|
|
|
|
| Array len
|
|
|
|
| Tuple len -> Patterns.omegas len
|
|
|
|
| Variant { has_arg = false }
|
|
|
|
| Any
|
|
|
|
| Constant _ -> []
|
|
|
|
end
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2017-12-07 10:33:01 -08:00
|
|
|
(* Consider a pattern matrix whose first column has been simplified to contain
|
|
|
|
only _ or a head constructor
|
2017-07-12 06:24:00 -07:00
|
|
|
| p1, r1...
|
|
|
|
| p2, r2...
|
|
|
|
| p3, r3...
|
|
|
|
| ...
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2017-07-12 06:24:00 -07:00
|
|
|
We build a normalized /discriminating/ pattern from a pattern [q] by folding
|
|
|
|
over the first column of the matrix, "refining" [q] as we go:
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
- when we encounter a row starting with [Tuple] or [Lazy] then we
|
|
|
|
can stop and return that head, as we cannot refine any further. Indeed,
|
2017-07-12 06:24:00 -07:00
|
|
|
these constructors are alone in their signature, so they will subsume
|
2019-06-13 10:25:10 -07:00
|
|
|
whatever other head we might find, as well as the head we're threading
|
2017-07-12 06:24:00 -07:00
|
|
|
along.
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
- when we find a [Record] then it is a bit more involved: it is also alone
|
|
|
|
in its signature, however it might only be matching a subset of the
|
2017-07-12 06:24:00 -07:00
|
|
|
record fields. We use these fields to refine our accumulator and keep going
|
|
|
|
as another row might match on different fields.
|
|
|
|
|
|
|
|
- rows starting with a wildcard do not bring any information, so we ignore
|
|
|
|
them and keep going
|
|
|
|
|
|
|
|
- if we encounter anything else (i.e. any other constructor), then we just
|
|
|
|
stop and return our accumulator.
|
|
|
|
*)
|
|
|
|
let discr_pat q pss =
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
2017-07-12 06:24:00 -07:00
|
|
|
let rec refine_pat acc = function
|
|
|
|
| [] -> acc
|
2019-06-13 10:25:10 -07:00
|
|
|
| ((head, _), _) :: rows ->
|
2019-09-09 08:54:09 -07:00
|
|
|
match head.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Any -> refine_pat acc rows
|
|
|
|
| Tuple _ | Lazy -> head
|
|
|
|
| Record lbls ->
|
2017-07-12 06:24:00 -07:00
|
|
|
(* N.B. we could make this case "simpler" by refining the record case
|
|
|
|
using [all_record_args].
|
|
|
|
In which case we wouldn't need to fold over the first column for
|
|
|
|
records.
|
|
|
|
However it makes the witness we generate for the exhaustivity warning
|
|
|
|
less pretty. *)
|
2019-06-13 10:25:10 -07:00
|
|
|
let fields =
|
|
|
|
List.fold_right (fun lbl r ->
|
|
|
|
if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then
|
|
|
|
r
|
|
|
|
else
|
|
|
|
lbl :: r
|
|
|
|
) lbls (record_arg acc)
|
2017-07-12 06:24:00 -07:00
|
|
|
in
|
2019-09-09 08:54:09 -07:00
|
|
|
let d = { head with pat_desc = Record fields } in
|
2019-06-13 10:25:10 -07:00
|
|
|
refine_pat d rows
|
2017-07-12 06:24:00 -07:00
|
|
|
| _ -> acc
|
|
|
|
in
|
2019-09-09 08:54:09 -07:00
|
|
|
let q, _ = deconstruct q in
|
|
|
|
match q.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
(* short-circuiting: clearly if we have anything other than [Record] or
|
|
|
|
[Any] to start with, we're not going to be able refine at all. So
|
2017-07-12 06:24:00 -07:00
|
|
|
there's no point going over the matrix. *)
|
2019-06-13 10:25:10 -07:00
|
|
|
| Any | Record _ -> refine_pat q pss
|
2017-07-12 06:24:00 -07:00
|
|
|
| _ -> q
|
1999-10-29 07:42:37 -07:00
|
|
|
|
|
|
|
(*
|
|
|
|
In case a matching value is found, set actual arguments
|
|
|
|
of the matching pattern.
|
|
|
|
*)
|
|
|
|
|
|
|
|
let rec read_args xs r = match xs,r with
|
|
|
|
| [],_ -> [],r
|
|
|
|
| _::xs, arg::rest ->
|
|
|
|
let args,rest = read_args xs rest in
|
|
|
|
arg::args,rest
|
2002-05-24 07:34:37 -07:00
|
|
|
| _,_ ->
|
|
|
|
fatal_error "Parmatch.read_args"
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2019-06-11 02:19:13 -07:00
|
|
|
let do_set_args ~erase_mutable q r = match q with
|
1999-10-29 07:42:37 -07:00
|
|
|
| {pat_desc = Tpat_tuple omegas} ->
|
|
|
|
let args,rest = read_args omegas r in
|
|
|
|
make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
|
2012-05-30 07:52:37 -07:00
|
|
|
| {pat_desc = Tpat_record (omegas,closed)} ->
|
1999-10-29 07:42:37 -07:00
|
|
|
let args,rest = read_args omegas r in
|
|
|
|
make_pat
|
|
|
|
(Tpat_record
|
2012-10-24 05:03:00 -07:00
|
|
|
(List.map2 (fun (lid, lbl,_) arg ->
|
2005-03-11 02:12:05 -08:00
|
|
|
if
|
|
|
|
erase_mutable &&
|
|
|
|
(match lbl.lbl_mut with
|
|
|
|
| Mutable -> true | Immutable -> false)
|
|
|
|
then
|
2012-10-24 05:03:00 -07:00
|
|
|
lid, lbl, omega
|
2005-03-11 02:12:05 -08:00
|
|
|
else
|
2012-10-24 05:03:00 -07:00
|
|
|
lid, lbl, arg)
|
2012-05-30 07:52:37 -07:00
|
|
|
omegas args, closed))
|
1999-10-29 07:42:37 -07:00
|
|
|
q.pat_type q.pat_env::
|
|
|
|
rest
|
2013-04-17 02:46:52 -07:00
|
|
|
| {pat_desc = Tpat_construct (lid, c,omegas)} ->
|
1999-10-29 07:42:37 -07:00
|
|
|
let args,rest = read_args omegas r in
|
|
|
|
make_pat
|
2013-04-17 02:46:52 -07:00
|
|
|
(Tpat_construct (lid, c,args))
|
2012-05-31 01:07:31 -07:00
|
|
|
q.pat_type q.pat_env::
|
1999-10-29 07:42:37 -07:00
|
|
|
rest
|
1999-11-30 08:07:38 -08:00
|
|
|
| {pat_desc = Tpat_variant (l, omega, row)} ->
|
|
|
|
let arg, rest =
|
|
|
|
match omega, r with
|
|
|
|
Some _, a::r -> Some a, r
|
|
|
|
| None, r -> None, r
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
|
|
|
make_pat
|
|
|
|
(Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
|
|
|
|
rest
|
2016-03-09 02:40:16 -08:00
|
|
|
| {pat_desc = Tpat_lazy _omega} ->
|
2008-07-09 06:03:38 -07:00
|
|
|
begin match r with
|
|
|
|
arg::rest ->
|
|
|
|
make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
|
|
|
|
| _ -> fatal_error "Parmatch.do_set_args (lazy)"
|
|
|
|
end
|
1999-10-29 07:42:37 -07:00
|
|
|
| {pat_desc = Tpat_array omegas} ->
|
|
|
|
let args,rest = read_args omegas r in
|
|
|
|
make_pat
|
|
|
|
(Tpat_array args) q.pat_type q.pat_env::
|
|
|
|
rest
|
2001-02-19 12:27:52 -08:00
|
|
|
| {pat_desc=Tpat_constant _|Tpat_any} ->
|
|
|
|
q::r (* case any is used in matching.ml *)
|
1999-10-29 07:42:37 -07:00
|
|
|
| _ -> fatal_error "Parmatch.set_args"
|
|
|
|
|
2019-06-11 02:19:13 -07:00
|
|
|
let set_args q r = do_set_args ~erase_mutable:false q r
|
|
|
|
and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2017-07-12 06:24:00 -07:00
|
|
|
(* Given a matrix of non-empty rows
|
|
|
|
p1 :: r1...
|
|
|
|
p2 :: r2...
|
|
|
|
p3 :: r3...
|
|
|
|
|
|
|
|
Simplify the first column [p1 p2 p3] by splitting all or-patterns.
|
2019-06-13 10:25:10 -07:00
|
|
|
The result is a list of pairs
|
|
|
|
((pattern head, arguments), rest of row)
|
2017-07-12 06:24:00 -07:00
|
|
|
|
|
|
|
For example,
|
|
|
|
x :: r1
|
|
|
|
(Some _) as y :: r2
|
|
|
|
(None as x) as y :: r3
|
|
|
|
(Some x | (None as x)) :: r4
|
|
|
|
becomes
|
2019-06-13 10:25:10 -07:00
|
|
|
(( _ , [ ] ), r1)
|
|
|
|
(( Some, [_] ), r2)
|
|
|
|
(( None, [ ] ), r3)
|
|
|
|
(( Some, [x] ), r4)
|
|
|
|
(( None, [ ] ), r4)
|
2017-07-12 06:24:00 -07:00
|
|
|
*)
|
2018-01-19 11:38:56 -08:00
|
|
|
let simplify_head_pat ~add_column p ps k =
|
|
|
|
let rec simplify_head_pat p ps k =
|
2019-09-10 00:15:13 -07:00
|
|
|
match Patterns.General.(view p |> strip_vars).pat_desc with
|
|
|
|
| `Or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
|
|
|
|
| #Patterns.Simple.view as view ->
|
|
|
|
add_column (Patterns.Head.deconstruct { p with pat_desc = view }) ps k
|
2018-01-19 11:38:56 -08:00
|
|
|
in simplify_head_pat p ps k
|
2017-07-12 06:24:00 -07:00
|
|
|
|
2018-01-03 07:55:28 -08:00
|
|
|
let rec simplify_first_col = function
|
|
|
|
| [] -> []
|
|
|
|
| [] :: _ -> assert false (* the rows are non-empty! *)
|
2018-01-19 11:38:56 -08:00
|
|
|
| (p::ps) :: rows ->
|
|
|
|
let add_column p ps k = (p, ps) :: k in
|
|
|
|
simplify_head_pat ~add_column p ps (simplify_first_col rows)
|
2018-01-03 07:55:28 -08:00
|
|
|
|
2017-07-12 06:24:00 -07:00
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
(* Builds the specialized matrix of [pss] according to the discriminating
|
|
|
|
pattern head [d].
|
2017-07-12 06:24:00 -07:00
|
|
|
See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
|
|
|
|
|
|
|
|
NOTES:
|
|
|
|
- we are polymorphic on the type of matrices we work on, in particular a row
|
|
|
|
might not simply be a [pattern list]. That's why we have the [extend_row]
|
|
|
|
parameter.
|
|
|
|
*)
|
2019-06-13 10:25:10 -07:00
|
|
|
let build_specialized_submatrix ~extend_row discr pss =
|
1995-05-04 03:15:53 -07:00
|
|
|
let rec filter_rec = function
|
2019-06-13 10:25:10 -07:00
|
|
|
| ((head, args), ps) :: pss ->
|
|
|
|
if simple_match discr head
|
|
|
|
then extend_row (simple_match_args discr head args) ps :: filter_rec pss
|
1995-05-04 03:15:53 -07:00
|
|
|
else filter_rec pss
|
|
|
|
| _ -> [] in
|
|
|
|
filter_rec pss
|
|
|
|
|
2017-11-22 19:28:07 -08:00
|
|
|
(* The "default" and "specialized" matrices of a given matrix.
|
|
|
|
See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf .
|
1999-10-29 07:42:37 -07:00
|
|
|
*)
|
2017-11-22 19:28:07 -08:00
|
|
|
type 'matrix specialized_matrices = {
|
|
|
|
default : 'matrix;
|
2019-08-19 00:48:59 -07:00
|
|
|
constrs : (Patterns.Head.t * 'matrix) list;
|
2017-11-22 19:28:07 -08:00
|
|
|
}
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2017-07-12 06:24:00 -07:00
|
|
|
(* Consider a pattern matrix whose first column has been simplified
|
|
|
|
to contain only _ or a head constructor
|
|
|
|
| p1, r1...
|
|
|
|
| p2, r2...
|
|
|
|
| p3, r3...
|
|
|
|
| ...
|
|
|
|
|
2017-11-22 19:28:07 -08:00
|
|
|
We split this matrix into a list of /specialized/ sub-matrices, one for
|
2017-07-12 06:24:00 -07:00
|
|
|
each head constructor appearing in the first column. For each row whose
|
|
|
|
first column starts with a head constructor, remove this head
|
|
|
|
column, prepend one column for each argument of the constructor,
|
|
|
|
and add the resulting row in the sub-matrix corresponding to this
|
|
|
|
head constructor.
|
|
|
|
|
|
|
|
Rows whose left column is omega (the Any pattern _) may match any
|
|
|
|
head constructor, so they are added to all sub-matrices.
|
|
|
|
|
|
|
|
In the case where all the rows in the matrix have an omega on their first
|
2017-11-22 19:28:07 -08:00
|
|
|
column, then there is only one /specialized/ sub-matrix, formed of all these
|
|
|
|
omega rows.
|
|
|
|
This matrix is also called the /default/ matrix.
|
2017-07-12 06:24:00 -07:00
|
|
|
|
|
|
|
See the documentation of [build_specialized_submatrix] for an explanation of
|
|
|
|
the [extend_row] parameter.
|
1999-10-29 07:42:37 -07:00
|
|
|
*)
|
2019-06-13 10:25:10 -07:00
|
|
|
let build_specialized_submatrices ~extend_row discr rows =
|
|
|
|
let extend_group discr p args r rs =
|
|
|
|
let r = extend_row (simple_match_args discr p args) r in
|
2017-11-22 19:28:07 -08:00
|
|
|
(discr, r :: rs)
|
|
|
|
in
|
2002-05-24 07:34:37 -07:00
|
|
|
|
parmatch: ensure specialized submatrices are in source order
We produce exhaustivity counter-example in the order of the
specialized submatrices. Having submatrices in source order gives the
nice behavior that the clause that would naturally been inserted first
in the source is given first as a counter-example.
Consider for example:
function
| true, true -> true
| false, false -> false
The two counter-examples are (true, false) and (false, true).
Before this patch, (false, true) would be shown first.
After this patch, (true, false) is shown first.
This corresponds to the following natural completion order:
function
| true, true -> true
| true, false -> ?
| false, false -> false
| false, true -> ?
On the other hand, the ordering of the default submatrix, with respect
to the specialized submatrices, is not preserved -- it is always
ordered last.
One could intuitively expect the default submatrix to appear in the
position of the first omega row in the source. We tried this, and
it is not a good idea:
- the change is much more invasive as the interface of
`build_specialized_submatrices` has to change
- the behavior of the result is in fact unpleasant; it is not
intuitive to order counter-examples in this way.
For example, consider:
function
| _, None -> false
| true, Some true -> false
The two exhaustivity counter-examples are (true, Some false)
and (false, Some _). The second comes from the default submatrix:
morally it is (_, Some _), with "some other constructor missing from
the column" instead of the first _. There is no reason to suppose that
the user would want to place this (_, Some _) or (false, Some _)
counter-example first in the completed code; indeed, this intuition
would suggest writing an exhaustive covering of patterns of the
form (_, foo), inserted after the first clause, but then the other
clauses below become unnecessary!
When an omega patterns appears high in the column like this, it is
usually because there is a very specific matching condition to the
rest of its row, that justifies some shortcutting behavior. The
program is typically *not* completed by adding more specific matching
conditions.
2020-05-24 09:43:36 -07:00
|
|
|
(* insert a row of head [p] and rest [r] into the right group
|
|
|
|
|
|
|
|
Note: with this implementation, the order of the groups
|
|
|
|
is the order of their first row in the source order.
|
|
|
|
This is a nice property to get exhaustivity counter-examples
|
|
|
|
in source order.
|
|
|
|
*)
|
2019-06-13 10:25:10 -07:00
|
|
|
let rec insert_constr head args r = function
|
2017-11-22 19:28:07 -08:00
|
|
|
| [] ->
|
2017-07-12 06:24:00 -07:00
|
|
|
(* if no group matched this row, it has a head constructor that
|
|
|
|
was never seen before; add a new sub-matrix for this head *)
|
2019-06-13 10:25:10 -07:00
|
|
|
[extend_group head head args r []]
|
2017-11-22 19:28:07 -08:00
|
|
|
| (q0,rs) as bd::env ->
|
2019-06-13 10:25:10 -07:00
|
|
|
if simple_match q0 head
|
|
|
|
then extend_group q0 head args r rs :: env
|
|
|
|
else bd :: insert_constr head args r env
|
2017-11-22 19:28:07 -08:00
|
|
|
in
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2017-07-12 06:24:00 -07:00
|
|
|
(* insert a row of head omega into all groups *)
|
|
|
|
let insert_omega r env =
|
2019-08-19 00:48:59 -07:00
|
|
|
List.map (fun (q0,rs) -> extend_group q0 Patterns.Head.omega [] r rs) env
|
2017-11-22 19:28:07 -08:00
|
|
|
in
|
2017-07-12 06:24:00 -07:00
|
|
|
|
|
|
|
let rec form_groups constr_groups omega_tails = function
|
|
|
|
| [] -> (constr_groups, omega_tails)
|
2019-06-13 10:25:10 -07:00
|
|
|
| ((head, args), tail) :: rest ->
|
2019-09-09 08:54:09 -07:00
|
|
|
match head.pat_desc with
|
|
|
|
| Patterns.Head.Any ->
|
2019-06-13 10:25:10 -07:00
|
|
|
(* note that calling insert_omega here would be wrong
|
|
|
|
as some groups may not have been formed yet, if the
|
|
|
|
first row with this head pattern comes after in the list *)
|
|
|
|
form_groups constr_groups (tail :: omega_tails) rest
|
|
|
|
| _ ->
|
|
|
|
form_groups
|
|
|
|
(insert_constr head args tail constr_groups) omega_tails rest
|
2017-11-22 19:28:07 -08:00
|
|
|
in
|
2017-07-12 06:24:00 -07:00
|
|
|
|
|
|
|
let constr_groups, omega_tails =
|
|
|
|
let initial_constr_group =
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
|
|
|
match discr.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Record _ | Tuple _ | Lazy ->
|
|
|
|
(* [discr] comes from [discr_pat], and in this case subsumes any of the
|
2017-07-12 06:24:00 -07:00
|
|
|
patterns we could find on the first column of [rows]. So it is better
|
|
|
|
to use it for our initial environment than any of the normalized
|
|
|
|
pattern we might obtain from the first column. *)
|
2019-06-13 10:25:10 -07:00
|
|
|
[discr,[]]
|
2017-07-12 06:24:00 -07:00
|
|
|
| _ -> []
|
|
|
|
in
|
|
|
|
form_groups initial_constr_group [] rows
|
2017-07-11 03:53:46 -07:00
|
|
|
in
|
parmatch: ensure specialized submatrices are in source order
We produce exhaustivity counter-example in the order of the
specialized submatrices. Having submatrices in source order gives the
nice behavior that the clause that would naturally been inserted first
in the source is given first as a counter-example.
Consider for example:
function
| true, true -> true
| false, false -> false
The two counter-examples are (true, false) and (false, true).
Before this patch, (false, true) would be shown first.
After this patch, (true, false) is shown first.
This corresponds to the following natural completion order:
function
| true, true -> true
| true, false -> ?
| false, false -> false
| false, true -> ?
On the other hand, the ordering of the default submatrix, with respect
to the specialized submatrices, is not preserved -- it is always
ordered last.
One could intuitively expect the default submatrix to appear in the
position of the first omega row in the source. We tried this, and
it is not a good idea:
- the change is much more invasive as the interface of
`build_specialized_submatrices` has to change
- the behavior of the result is in fact unpleasant; it is not
intuitive to order counter-examples in this way.
For example, consider:
function
| _, None -> false
| true, Some true -> false
The two exhaustivity counter-examples are (true, Some false)
and (false, Some _). The second comes from the default submatrix:
morally it is (_, Some _), with "some other constructor missing from
the column" instead of the first _. There is no reason to suppose that
the user would want to place this (_, Some _) or (false, Some _)
counter-example first in the completed code; indeed, this intuition
would suggest writing an exhaustive covering of patterns of the
form (_, foo), inserted after the first clause, but then the other
clauses below become unnecessary!
When an omega patterns appears high in the column like this, it is
usually because there is a very specific matching condition to the
rest of its row, that justifies some shortcutting behavior. The
program is typically *not* completed by adding more specific matching
conditions.
2020-05-24 09:43:36 -07:00
|
|
|
|
|
|
|
(* groups are accumulated in reverse order;
|
|
|
|
we restore the order of rows in the source code *)
|
|
|
|
let default = List.rev omega_tails in
|
|
|
|
let constrs =
|
|
|
|
List.fold_right insert_omega omega_tails constr_groups
|
|
|
|
|> List.map (fun (discr, rs) -> (discr, List.rev rs))
|
|
|
|
in
|
|
|
|
{ default; constrs; }
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2003-08-14 18:35:24 -07:00
|
|
|
(* Variant related functions *)
|
|
|
|
|
2017-07-14 08:47:02 -07:00
|
|
|
let set_last a =
|
|
|
|
let rec loop = function
|
|
|
|
| [] -> assert false
|
2019-09-10 00:15:13 -07:00
|
|
|
| [_] -> [Patterns.General.erase a]
|
2017-07-14 08:47:02 -07:00
|
|
|
| x::l -> x :: loop l
|
|
|
|
in
|
|
|
|
function
|
2019-08-19 00:48:59 -07:00
|
|
|
| (_, []) -> (Patterns.Head.deconstruct a, [])
|
2017-07-14 08:47:02 -07:00
|
|
|
| (first, row) -> (first, loop row)
|
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
(* mark constructor lines for failure when they are incomplete *)
|
2017-07-14 08:47:02 -07:00
|
|
|
let mark_partial =
|
2019-09-10 00:15:13 -07:00
|
|
|
let zero = make_pat (`Constant (Const_int 0)) Ctype.none Env.empty in
|
2019-06-13 10:25:10 -07:00
|
|
|
List.map (fun ((hp, _), _ as ps) ->
|
2019-09-09 08:54:09 -07:00
|
|
|
match hp.pat_desc with
|
|
|
|
| Patterns.Head.Any -> ps
|
2019-06-13 10:25:10 -07:00
|
|
|
| _ -> set_last zero ps
|
2017-07-14 08:47:02 -07:00
|
|
|
)
|
2003-08-14 18:35:24 -07:00
|
|
|
|
2003-08-14 02:04:43 -07:00
|
|
|
let close_variant env row =
|
|
|
|
let row = Btype.row_repr row in
|
|
|
|
let nm =
|
|
|
|
List.fold_left
|
2016-03-09 02:40:16 -08:00
|
|
|
(fun nm (_tag,f) ->
|
2003-08-14 02:04:43 -07:00
|
|
|
match Btype.row_field_repr f with
|
|
|
|
| Reither(_, _, false, e) ->
|
|
|
|
(* m=false means that this tag is not explicitly matched *)
|
|
|
|
Btype.set_row_field e Rabsent;
|
|
|
|
None
|
|
|
|
| Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
|
|
|
|
row.row_name row.row_fields in
|
|
|
|
if not row.row_closed || nm != row.row_name then begin
|
|
|
|
(* this unification cannot fail *)
|
|
|
|
Ctype.unify env row.row_more
|
|
|
|
(Btype.newgenty
|
|
|
|
(Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
|
|
|
|
row_closed = true; row_name = nm}))
|
|
|
|
end
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(*
|
1999-10-29 07:42:37 -07:00
|
|
|
Check whether the first column of env makes up a complete signature or
|
2019-06-13 10:25:10 -07:00
|
|
|
not. We work on the discriminating pattern heads of each sub-matrix: they
|
|
|
|
are not omega/Any.
|
2008-01-11 08:13:18 -08:00
|
|
|
*)
|
2015-05-19 15:52:21 -07:00
|
|
|
let full_match closing env = match env with
|
2018-01-05 10:48:32 -08:00
|
|
|
| [] -> false
|
2019-06-13 10:25:10 -07:00
|
|
|
| (discr, _) :: _ ->
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
|
|
|
match discr.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Any -> assert false
|
2019-06-21 02:23:18 -07:00
|
|
|
| Construct { cstr_tag = Cstr_extension _ ; _ } -> false
|
|
|
|
| Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts
|
2019-06-13 10:25:10 -07:00
|
|
|
| Variant { type_row; _ } ->
|
|
|
|
let fields =
|
|
|
|
List.map
|
|
|
|
(fun (d, _) ->
|
2019-09-09 08:54:09 -07:00
|
|
|
match d.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Variant { tag } -> tag
|
|
|
|
| _ -> assert false)
|
|
|
|
env
|
|
|
|
in
|
|
|
|
let row = type_row () in
|
|
|
|
if closing && not (Btype.row_fixed row) then
|
|
|
|
(* closing=true, we are considering the variant as closed *)
|
|
|
|
List.for_all
|
|
|
|
(fun (tag,f) ->
|
|
|
|
match Btype.row_field_repr f with
|
|
|
|
Rabsent | Reither(_, _, false, _) -> true
|
|
|
|
| Reither (_, _, true, _)
|
|
|
|
(* m=true, do not discard matched tags, rather warn *)
|
|
|
|
| Rpresent _ -> List.mem tag fields)
|
|
|
|
row.row_fields
|
|
|
|
else
|
|
|
|
row.row_closed &&
|
|
|
|
List.for_all
|
|
|
|
(fun (tag,f) ->
|
|
|
|
Btype.row_field_repr f = Rabsent || List.mem tag fields)
|
|
|
|
row.row_fields
|
|
|
|
| Constant Const_char _ ->
|
|
|
|
List.length env = 256
|
|
|
|
| Constant _
|
|
|
|
| Array _ -> false
|
|
|
|
| Tuple _
|
|
|
|
| Record _
|
|
|
|
| Lazy -> true
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2017-08-12 13:24:41 -07:00
|
|
|
(* Written as a non-fragile matching, PR#7451 originated from a fragile matching
|
|
|
|
below. *)
|
2006-09-21 07:54:54 -07:00
|
|
|
let should_extend ext env = match ext with
|
|
|
|
| None -> false
|
2017-01-05 02:26:22 -08:00
|
|
|
| Some ext -> begin match env with
|
|
|
|
| [] -> assert false
|
|
|
|
| (p,_)::_ ->
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
|
|
|
begin match p.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} ->
|
2019-09-09 08:54:09 -07:00
|
|
|
let path = get_constructor_type_path p.pat_type p.pat_env in
|
2019-06-13 10:25:10 -07:00
|
|
|
Path.same path ext
|
|
|
|
| Construct {cstr_tag=(Cstr_extension _)} -> false
|
|
|
|
| Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false
|
|
|
|
| Any -> assert false
|
2017-01-05 02:26:22 -08:00
|
|
|
end
|
|
|
|
end
|
2006-09-21 07:54:54 -07:00
|
|
|
|
2017-04-28 07:31:52 -07:00
|
|
|
module ConstructorTagHashtbl = Hashtbl.Make(
|
|
|
|
struct
|
|
|
|
type t = Types.constructor_tag
|
|
|
|
let hash = Hashtbl.hash
|
|
|
|
let equal = Types.equal_tag
|
|
|
|
end
|
|
|
|
)
|
|
|
|
|
2001-02-19 12:27:52 -08:00
|
|
|
(* complement constructor tags *)
|
1999-10-29 07:42:37 -07:00
|
|
|
let complete_tags nconsts nconstrs tags =
|
2014-08-22 06:45:02 -07:00
|
|
|
let seen_const = Array.make nconsts false
|
|
|
|
and seen_constr = Array.make nconstrs false in
|
1999-10-29 07:42:37 -07:00
|
|
|
List.iter
|
|
|
|
(function
|
|
|
|
| Cstr_constant i -> seen_const.(i) <- true
|
|
|
|
| Cstr_block i -> seen_constr.(i) <- true
|
|
|
|
| _ -> assert false)
|
|
|
|
tags ;
|
2017-04-28 07:31:52 -07:00
|
|
|
let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in
|
1999-10-29 07:42:37 -07:00
|
|
|
for i = 0 to nconsts-1 do
|
|
|
|
if not seen_const.(i) then
|
2017-04-28 07:31:52 -07:00
|
|
|
ConstructorTagHashtbl.add r (Cstr_constant i) ()
|
1999-10-29 07:42:37 -07:00
|
|
|
done ;
|
|
|
|
for i = 0 to nconstrs-1 do
|
|
|
|
if not seen_constr.(i) then
|
2017-04-28 07:31:52 -07:00
|
|
|
ConstructorTagHashtbl.add r (Cstr_block i) ()
|
2010-01-22 04:48:24 -08:00
|
|
|
done ;
|
2017-04-28 07:31:52 -07:00
|
|
|
r
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2017-07-15 09:03:49 -07:00
|
|
|
(* build a pattern from a constructor description *)
|
2001-02-19 12:27:52 -08:00
|
|
|
let pat_of_constr ex_pat cstr =
|
2015-05-19 15:52:21 -07:00
|
|
|
{ex_pat with pat_desc =
|
2019-10-30 06:27:01 -07:00
|
|
|
Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name),
|
2015-05-19 15:52:21 -07:00
|
|
|
cstr, omegas cstr.cstr_arity)}
|
|
|
|
|
2015-05-20 20:29:47 -07:00
|
|
|
let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
|
|
|
|
|
2015-05-19 15:52:21 -07:00
|
|
|
let rec orify_many = function
|
|
|
|
| [] -> assert false
|
|
|
|
| [x] -> x
|
2015-05-20 20:29:47 -07:00
|
|
|
| x :: xs -> orify x (orify_many xs)
|
2015-05-19 15:52:21 -07:00
|
|
|
|
2017-07-15 09:03:49 -07:00
|
|
|
(* build an or-pattern from a constructor list *)
|
2015-05-19 15:52:21 -07:00
|
|
|
let pat_of_constrs ex_pat cstrs =
|
2019-08-19 00:48:59 -07:00
|
|
|
let ex_pat = Patterns.Head.to_omega_pattern ex_pat in
|
2015-05-19 15:52:21 -07:00
|
|
|
if cstrs = [] then raise Empty else
|
|
|
|
orify_many (List.map (pat_of_constr ex_pat) cstrs)
|
|
|
|
|
2015-09-02 01:53:47 -07:00
|
|
|
let pats_of_type ?(always=false) env ty =
|
2015-05-19 15:52:21 -07:00
|
|
|
let ty' = Ctype.expand_head env ty in
|
|
|
|
match ty'.desc with
|
|
|
|
| Tconstr (path, _, _) ->
|
2015-10-25 05:40:31 -07:00
|
|
|
begin try match (Env.find_type path env).type_kind with
|
2019-10-30 06:32:48 -07:00
|
|
|
| Type_variant cl when always || List.length cl <= 1 ||
|
|
|
|
(* Only explode when all constructors are GADTs *)
|
2015-10-13 05:38:07 -07:00
|
|
|
List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
|
2015-05-19 15:52:21 -07:00
|
|
|
let cstrs = fst (Env.find_type_descrs path env) in
|
2015-10-13 05:38:07 -07:00
|
|
|
List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
|
2016-03-09 02:40:16 -08:00
|
|
|
| Type_record _ ->
|
2015-10-13 05:38:07 -07:00
|
|
|
let labels = snd (Env.find_type_descrs path env) in
|
|
|
|
let fields =
|
|
|
|
List.map (fun ld ->
|
2019-10-30 06:27:01 -07:00
|
|
|
mknoloc (Longident.Lident ld.lbl_name), ld, omega)
|
2015-10-13 05:38:07 -07:00
|
|
|
labels
|
|
|
|
in
|
|
|
|
[make_pat (Tpat_record (fields, Closed)) ty env]
|
2015-05-19 15:52:21 -07:00
|
|
|
| _ -> [omega]
|
2015-10-25 05:40:31 -07:00
|
|
|
with Not_found -> [omega]
|
2015-05-19 15:52:21 -07:00
|
|
|
end
|
2015-10-13 05:38:07 -07:00
|
|
|
| Ttuple tl ->
|
|
|
|
[make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
|
2015-05-19 15:52:21 -07:00
|
|
|
| _ -> [omega]
|
2001-02-19 12:27:52 -08:00
|
|
|
|
2014-04-28 19:25:04 -07:00
|
|
|
let rec get_variant_constructors env ty =
|
|
|
|
match (Ctype.repr ty).desc with
|
|
|
|
| Tconstr (path,_,_) -> begin
|
2015-10-25 05:40:31 -07:00
|
|
|
try match Env.find_type path env with
|
2014-04-28 19:25:04 -07:00
|
|
|
| {type_kind=Type_variant _} ->
|
|
|
|
fst (Env.find_type_descrs path env)
|
|
|
|
| {type_manifest = Some _} ->
|
|
|
|
get_variant_constructors env
|
|
|
|
(Ctype.expand_head_once env (clean_copy ty))
|
|
|
|
| _ -> fatal_error "Parmatch.get_variant_constructors"
|
2015-10-25 05:40:31 -07:00
|
|
|
with Not_found ->
|
|
|
|
fatal_error "Parmatch.get_variant_constructors"
|
2014-04-28 19:25:04 -07:00
|
|
|
end
|
|
|
|
| _ -> fatal_error "Parmatch.get_variant_constructors"
|
2010-11-15 22:01:59 -08:00
|
|
|
|
2001-02-19 12:27:52 -08:00
|
|
|
(* Sends back a pattern that complements constructor tags all_tag *)
|
2020-05-21 02:37:13 -07:00
|
|
|
let complete_constrs constr all_tags =
|
|
|
|
let c = constr.pat_desc in
|
2015-09-02 09:00:19 -07:00
|
|
|
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
|
2020-05-21 02:37:13 -07:00
|
|
|
let constrs = get_variant_constructors constr.pat_env c.cstr_res in
|
2015-09-02 09:00:19 -07:00
|
|
|
let others =
|
2017-04-28 07:31:52 -07:00
|
|
|
List.filter
|
2017-11-21 06:11:37 -08:00
|
|
|
(fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
|
2017-04-28 07:31:52 -07:00
|
|
|
constrs in
|
2015-09-02 09:00:19 -07:00
|
|
|
let const, nonconst =
|
|
|
|
List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
|
|
|
|
const @ nonconst
|
|
|
|
|
|
|
|
let build_other_constrs env p =
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
|
|
|
match p.pat_desc with
|
2020-05-21 02:37:13 -07:00
|
|
|
| Construct ({ cstr_tag = Cstr_constant _ | Cstr_block _ } as c) ->
|
|
|
|
let constr = { p with pat_desc = c } in
|
2019-06-13 10:25:10 -07:00
|
|
|
let get_tag q =
|
2019-09-09 08:54:09 -07:00
|
|
|
match q.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Construct c -> c.cstr_tag
|
2015-09-02 09:00:19 -07:00
|
|
|
| _ -> fatal_error "Parmatch.get_tag" in
|
|
|
|
let all_tags = List.map (fun (p,_) -> get_tag p) env in
|
2020-05-21 02:37:13 -07:00
|
|
|
pat_of_constrs p (complete_constrs constr all_tags)
|
2015-09-02 09:00:19 -07:00
|
|
|
| _ -> extra_pat
|
2001-02-19 12:27:52 -08:00
|
|
|
|
2003-04-25 05:27:31 -07:00
|
|
|
(* Auxiliary for build_other *)
|
|
|
|
|
|
|
|
let build_other_constant proj make first next p env =
|
2019-09-09 08:54:09 -07:00
|
|
|
let all = List.map (fun (p, _) -> proj p.pat_desc) env in
|
2003-04-25 05:27:31 -07:00
|
|
|
let rec try_const i =
|
|
|
|
if List.mem i all
|
|
|
|
then try_const (next i)
|
2019-09-09 08:54:09 -07:00
|
|
|
else make_pat (make i) p.pat_type p.pat_env
|
2003-04-25 05:27:31 -07:00
|
|
|
in try_const first
|
|
|
|
|
1999-10-29 07:42:37 -07:00
|
|
|
(*
|
|
|
|
Builds a pattern that is incompatible with all patterns in
|
2017-07-15 09:03:49 -07:00
|
|
|
the first column of env
|
1999-10-29 07:42:37 -07:00
|
|
|
*)
|
|
|
|
|
2018-01-17 20:01:31 -08:00
|
|
|
let some_private_tag = "<some private tag>"
|
2018-01-04 21:39:50 -08:00
|
|
|
|
2019-06-13 10:25:10 -07:00
|
|
|
let build_other ext env =
|
|
|
|
match env with
|
|
|
|
| [] -> omega
|
|
|
|
| (d, _) :: _ ->
|
2019-09-09 08:54:09 -07:00
|
|
|
let open Patterns.Head in
|
|
|
|
match d.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Construct { cstr_tag = Cstr_extension _ } ->
|
|
|
|
(* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
|
|
|
|
make_pat
|
|
|
|
(Tpat_var (Ident.create_local "*extension*",
|
2019-09-09 08:54:09 -07:00
|
|
|
{txt="*extension*"; loc = d.pat_loc}))
|
2019-06-13 10:25:10 -07:00
|
|
|
Ctype.none Env.empty
|
|
|
|
| Construct _ ->
|
|
|
|
begin match ext with
|
|
|
|
| Some ext ->
|
2019-09-09 08:54:09 -07:00
|
|
|
if Path.same ext (get_constructor_type_path d.pat_type d.pat_env)
|
2019-06-13 10:25:10 -07:00
|
|
|
then
|
|
|
|
extra_pat
|
|
|
|
else
|
|
|
|
build_other_constrs env d
|
|
|
|
| _ ->
|
|
|
|
build_other_constrs env d
|
|
|
|
end
|
|
|
|
| Variant { cstr_row; type_row } ->
|
|
|
|
let tags =
|
|
|
|
List.map
|
|
|
|
(fun (d, _) ->
|
2019-09-09 08:54:09 -07:00
|
|
|
match d.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Variant { tag } -> tag
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ -> assert false)
|
2019-06-13 10:25:10 -07:00
|
|
|
env
|
|
|
|
in
|
|
|
|
let make_other_pat tag const =
|
2019-09-09 08:54:09 -07:00
|
|
|
let arg = if const then None else Some Patterns.omega in
|
|
|
|
make_pat (Tpat_variant(tag, arg, cstr_row)) d.pat_type d.pat_env
|
2019-06-13 10:25:10 -07:00
|
|
|
in
|
|
|
|
let row = type_row () in
|
|
|
|
begin match
|
|
|
|
List.fold_left
|
|
|
|
(fun others (tag,f) ->
|
|
|
|
if List.mem tag tags then others else
|
|
|
|
match Btype.row_field_repr f with
|
|
|
|
Rabsent (* | Reither _ *) -> others
|
|
|
|
(* This one is called after erasing pattern info *)
|
|
|
|
| Reither (c, _, _, _) -> make_other_pat tag c :: others
|
|
|
|
| Rpresent arg -> make_other_pat tag (arg = None) :: others)
|
|
|
|
[] row.row_fields
|
|
|
|
with
|
|
|
|
[] ->
|
|
|
|
let tag =
|
|
|
|
if Btype.row_fixed row then some_private_tag else
|
|
|
|
let rec mktag tag =
|
|
|
|
if List.mem tag tags then mktag (tag ^ "'") else tag in
|
|
|
|
mktag "AnyOtherTag"
|
|
|
|
in make_other_pat tag true
|
|
|
|
| pat::other_pats ->
|
|
|
|
List.fold_left
|
|
|
|
(fun p_res pat ->
|
2019-09-09 08:54:09 -07:00
|
|
|
make_pat (Tpat_or (pat, p_res, None)) d.pat_type d.pat_env)
|
2019-06-13 10:25:10 -07:00
|
|
|
pat other_pats
|
|
|
|
end
|
|
|
|
| Constant Const_char _ ->
|
|
|
|
let all_chars =
|
|
|
|
List.map
|
2019-09-09 08:54:09 -07:00
|
|
|
(fun (p,_) -> match p.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Constant (Const_char c) -> c
|
2003-04-25 05:27:31 -07:00
|
|
|
| _ -> assert false)
|
2019-06-13 10:25:10 -07:00
|
|
|
env
|
|
|
|
in
|
|
|
|
let rec find_other i imax =
|
|
|
|
if i > imax then raise Not_found
|
|
|
|
else
|
|
|
|
let ci = Char.chr i in
|
|
|
|
if List.mem ci all_chars then
|
|
|
|
find_other (i+1) imax
|
|
|
|
else
|
2019-09-09 08:54:09 -07:00
|
|
|
make_pat (Tpat_constant (Const_char ci)) d.pat_type d.pat_env
|
2019-06-13 10:25:10 -07:00
|
|
|
in
|
|
|
|
let rec try_chars = function
|
2019-09-09 08:54:09 -07:00
|
|
|
| [] -> Patterns.omega
|
2019-06-13 10:25:10 -07:00
|
|
|
| (c1,c2) :: rest ->
|
|
|
|
try
|
|
|
|
find_other (Char.code c1) (Char.code c2)
|
|
|
|
with
|
|
|
|
| Not_found -> try_chars rest
|
|
|
|
in
|
|
|
|
try_chars
|
|
|
|
[ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
|
|
|
|
' ', '~' ; Char.chr 0 , Char.chr 255]
|
|
|
|
| Constant Const_int _ ->
|
|
|
|
build_other_constant
|
|
|
|
(function Constant(Const_int i) -> i | _ -> assert false)
|
|
|
|
(function i -> Tpat_constant(Const_int i))
|
|
|
|
0 succ d env
|
|
|
|
| Constant Const_int32 _ ->
|
|
|
|
build_other_constant
|
|
|
|
(function Constant(Const_int32 i) -> i | _ -> assert false)
|
|
|
|
(function i -> Tpat_constant(Const_int32 i))
|
|
|
|
0l Int32.succ d env
|
|
|
|
| Constant Const_int64 _ ->
|
|
|
|
build_other_constant
|
|
|
|
(function Constant(Const_int64 i) -> i | _ -> assert false)
|
|
|
|
(function i -> Tpat_constant(Const_int64 i))
|
|
|
|
0L Int64.succ d env
|
|
|
|
| Constant Const_nativeint _ ->
|
|
|
|
build_other_constant
|
|
|
|
(function Constant(Const_nativeint i) -> i | _ -> assert false)
|
|
|
|
(function i -> Tpat_constant(Const_nativeint i))
|
|
|
|
0n Nativeint.succ d env
|
|
|
|
| Constant Const_string _ ->
|
|
|
|
build_other_constant
|
2019-07-22 09:21:26 -07:00
|
|
|
(function Constant(Const_string (s, _, _)) -> String.length s
|
2019-06-13 10:25:10 -07:00
|
|
|
| _ -> assert false)
|
2019-07-22 09:21:26 -07:00
|
|
|
(function i ->
|
|
|
|
Tpat_constant
|
|
|
|
(Const_string(String.make i '*',Location.none,None)))
|
2019-06-13 10:25:10 -07:00
|
|
|
0 succ d env
|
|
|
|
| Constant Const_float _ ->
|
|
|
|
build_other_constant
|
|
|
|
(function Constant(Const_float f) -> float_of_string f
|
|
|
|
| _ -> assert false)
|
|
|
|
(function f -> Tpat_constant(Const_float (string_of_float f)))
|
|
|
|
0.0 (fun f -> f +. 1.0) d env
|
|
|
|
| Array _ ->
|
|
|
|
let all_lengths =
|
|
|
|
List.map
|
2019-09-09 08:54:09 -07:00
|
|
|
(fun (p,_) -> match p.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Array len -> len
|
2003-04-25 05:27:31 -07:00
|
|
|
| _ -> assert false)
|
2019-06-13 10:25:10 -07:00
|
|
|
env in
|
|
|
|
let rec try_arrays l =
|
|
|
|
if List.mem l all_lengths then try_arrays (l+1)
|
|
|
|
else
|
2019-09-09 08:54:09 -07:00
|
|
|
make_pat (Tpat_array (omegas l)) d.pat_type d.pat_env in
|
2019-06-13 10:25:10 -07:00
|
|
|
try_arrays 0
|
2019-09-09 08:54:09 -07:00
|
|
|
| _ -> Patterns.omega
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2002-05-27 01:04:03 -07:00
|
|
|
let rec has_instance p = match p.pat_desc with
|
|
|
|
| Tpat_variant (l,_,r) when is_absent l r -> false
|
Revert GPR#305 (exception patterns under or-patterns) from trunk
This week we merged several changes from Thomas Refis, to allow the
use of exception patterns under or-patterns, to write code such as
match foo x with
| None | exception Not_found -> ...
| Some -> ...
Unfortunately, I failed to properly assess the impact of this change,
and in particular to make sure that Luc Maranget had properly reviewed
this code -- any change to the pattern-matching machinery should be
reviewed by Luc.
The problem that I had not foreseen and that he would have immediately
realized is that, while adapting the pattern-matching *compiler* is
relatively easy (Thomas inserted a transformation at the right place
to separate exception patterns from the others and handle them
separately, using the staticraise construct used by the
pattern-matching compiler to avoid duplicating the
right-hand-side branch), adapting the pattern-matching warnings
machinery is both more subtle and easier to overlook (it may fail
silently and nobody notices, unlike wrong code production). This part
of the compiler is subtle and best understood by Luc, but he does not
have the time to do a proper review of those changes in the timeframe
for the 4.03 feature freeze (mid-December).
I believe the right move in this case, implemented in the present
commit, is to revert the change from trunk (this is not a feature that
we must *imperatively* have in 4.03), do a proper job of understanding
the changes, and integrate the change when we are confident it is
ready. I hope to do this in 2016, together with Luc Maranget and
Thomas Refis -- hopefully this would allow Thomas and I to be more
confident when changing the pattern-matching machinery in the future.
Revert "Merge pull request #343 from trefis/pr7083"
This reverts commit 22681b8d2a56b308673b58fba1a06781bfc6d4b6, reversing
changes made to a24e4edf0a37d78abc1046cc453b84625b1521b5.
Revert "Merge pull request #341 from trefis/or-exception"
This reverts commit f8f68bd329375fd61e33781f61deeaeec2733f4b, reversing
changes made to 1534fe8082f6edd68be3fb960606a0e2fa87a116.
Revert "Merge pull request #305 from trefis/or-exception"
This reverts commit cfeda89396c67656d61ee24509278e50cb6e36e6, reversing
changes made to 77cf36cf82e3fb87469138c5da8f4ca9774414ff.
2015-12-12 01:52:33 -08:00
|
|
|
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
|
2002-05-27 01:04:03 -07:00
|
|
|
| Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
|
2013-04-17 02:46:52 -07:00
|
|
|
| Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps ->
|
2012-05-31 01:07:31 -07:00
|
|
|
has_instances ps
|
2012-10-24 05:03:00 -07:00
|
|
|
| Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_lazy p
|
|
|
|
-> has_instance p
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2002-05-27 01:04:03 -07:00
|
|
|
and has_instances = function
|
|
|
|
| [] -> true
|
|
|
|
| q::rem -> has_instance q && has_instances rem
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2017-07-15 09:55:26 -07:00
|
|
|
(*
|
|
|
|
Core function :
|
|
|
|
Is the last row of pattern matrix pss + qs satisfiable ?
|
|
|
|
That is :
|
|
|
|
Does there exists at least one value vector, es such that :
|
|
|
|
1- for all ps in pss ps # es (ps and es are not compatible)
|
|
|
|
2- qs <= es (es matches qs)
|
2017-12-07 10:33:01 -08:00
|
|
|
|
|
|
|
---
|
|
|
|
|
|
|
|
In two places in the following function, we check the coherence of the first
|
|
|
|
column of (pss + qs).
|
|
|
|
If it is incoherent, then we exit early saying that (pss + qs) is not
|
|
|
|
satisfiable (which is equivalent to saying "oh, we shouldn't have considered
|
|
|
|
that branch, no good result came come from here").
|
|
|
|
|
|
|
|
But what happens if we have a coherent but ill-typed column?
|
|
|
|
- we might end up returning [false], which is equivalent to noticing the
|
|
|
|
incompatibility: clearly this is fine.
|
|
|
|
- if we end up returning [true] then we're saying that [qs] is useful while
|
|
|
|
it is not. This is sad but not the end of the world, we're just allowing dead
|
|
|
|
code to survive.
|
2017-07-15 09:55:26 -07:00
|
|
|
*)
|
2002-05-24 07:34:37 -07:00
|
|
|
let rec satisfiable pss qs = match pss with
|
2010-01-22 04:48:24 -08:00
|
|
|
| [] -> has_instances qs
|
2002-05-24 07:34:37 -07:00
|
|
|
| _ ->
|
2003-05-02 02:57:53 -07:00
|
|
|
match qs with
|
|
|
|
| [] -> false
|
|
|
|
| q::qs ->
|
2019-09-10 00:15:13 -07:00
|
|
|
match Patterns.General.(view q |> strip_vars).pat_desc with
|
|
|
|
| `Or(q1,q2,_) ->
|
|
|
|
satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
|
|
|
|
| `Any ->
|
|
|
|
let pss = simplify_first_col pss in
|
|
|
|
if not (all_coherent (first_column pss)) then
|
|
|
|
false
|
|
|
|
else begin
|
|
|
|
let { default; constrs } =
|
|
|
|
let q0 = discr_pat Patterns.Simple.omega pss in
|
|
|
|
build_specialized_submatrices ~extend_row:(@) q0 pss in
|
|
|
|
if not (full_match false constrs) then
|
|
|
|
satisfiable default qs
|
|
|
|
else
|
|
|
|
List.exists
|
|
|
|
(fun (p,pss) ->
|
|
|
|
not (is_absent_pat p) &&
|
|
|
|
satisfiable pss
|
|
|
|
(simple_match_args p Patterns.Head.omega [] @ qs))
|
|
|
|
constrs
|
|
|
|
end
|
|
|
|
| `Variant (l,_,r) when is_absent l r -> false
|
|
|
|
| #Patterns.Simple.view as view ->
|
|
|
|
let q = { q with pat_desc = view } in
|
|
|
|
let pss = simplify_first_col pss in
|
|
|
|
let hq, qargs = Patterns.Head.deconstruct q in
|
|
|
|
if not (all_coherent (hq :: first_column pss)) then
|
|
|
|
false
|
|
|
|
else begin
|
|
|
|
let q0 = discr_pat q pss in
|
|
|
|
satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss)
|
|
|
|
(simple_match_args q0 hq qargs @ qs)
|
|
|
|
end
|
2003-05-02 02:57:53 -07:00
|
|
|
|
2017-07-15 09:55:26 -07:00
|
|
|
(* While [satisfiable] only checks whether the last row of [pss + qs] is
|
|
|
|
satisfiable, this function returns the (possibly empty) list of vectors [es]
|
|
|
|
which verify:
|
|
|
|
1- for all ps in pss, ps # es (ps and es are not compatible)
|
|
|
|
2- qs <= es (es matches qs)
|
|
|
|
|
2017-12-07 10:33:01 -08:00
|
|
|
This is done to enable GADT handling
|
|
|
|
|
|
|
|
For considerations regarding the coherence check, see the comment on
|
|
|
|
[satisfiable] above. *)
|
2017-07-15 09:55:26 -07:00
|
|
|
let rec list_satisfying_vectors pss qs =
|
2017-11-22 19:28:07 -08:00
|
|
|
match pss with
|
|
|
|
| [] -> if has_instances qs then [qs] else []
|
|
|
|
| _ ->
|
|
|
|
match qs with
|
|
|
|
| [] -> []
|
2019-09-10 00:15:13 -07:00
|
|
|
| q :: qs ->
|
|
|
|
match Patterns.General.(view q |> strip_vars).pat_desc with
|
|
|
|
| `Or(q1,q2,_) ->
|
|
|
|
list_satisfying_vectors pss (q1::qs) @
|
|
|
|
list_satisfying_vectors pss (q2::qs)
|
|
|
|
| `Any ->
|
|
|
|
let pss = simplify_first_col pss in
|
|
|
|
if not (all_coherent (first_column pss)) then
|
|
|
|
[]
|
|
|
|
else begin
|
|
|
|
let q0 = discr_pat Patterns.Simple.omega pss in
|
|
|
|
let wild default_matrix p =
|
|
|
|
List.map (fun qs -> p::qs)
|
|
|
|
(list_satisfying_vectors default_matrix qs)
|
|
|
|
in
|
|
|
|
match build_specialized_submatrices ~extend_row:(@) q0 pss with
|
|
|
|
| { default; constrs = [] } ->
|
|
|
|
(* first column of pss is made of variables only *)
|
|
|
|
wild default omega
|
|
|
|
| { default; constrs = ((p,_)::_ as constrs) } ->
|
|
|
|
let for_constrs () =
|
|
|
|
List.flatten (
|
|
|
|
List.map (fun (p,pss) ->
|
|
|
|
if is_absent_pat p then
|
|
|
|
[]
|
|
|
|
else
|
|
|
|
let witnesses =
|
|
|
|
list_satisfying_vectors pss
|
|
|
|
(simple_match_args p Patterns.Head.omega [] @ qs)
|
|
|
|
in
|
|
|
|
let p = Patterns.Head.to_omega_pattern p in
|
|
|
|
List.map (set_args p) witnesses
|
|
|
|
) constrs
|
|
|
|
)
|
|
|
|
in
|
|
|
|
if full_match false constrs then for_constrs () else
|
|
|
|
begin match p.pat_desc with
|
|
|
|
| Construct _ ->
|
2020-05-15 12:16:19 -07:00
|
|
|
(* activate this code
|
|
|
|
for checking non-gadt constructors *)
|
2019-09-10 00:15:13 -07:00
|
|
|
wild default (build_other_constrs constrs p)
|
|
|
|
@ for_constrs ()
|
|
|
|
| _ ->
|
|
|
|
wild default Patterns.omega
|
|
|
|
end
|
2018-01-05 10:42:35 -08:00
|
|
|
end
|
2019-09-10 00:15:13 -07:00
|
|
|
| `Variant (l, _, r) when is_absent l r -> []
|
|
|
|
| #Patterns.Simple.view as view ->
|
|
|
|
let q = { q with pat_desc = view } in
|
2019-08-19 00:48:59 -07:00
|
|
|
let hq, qargs = Patterns.Head.deconstruct q in
|
2017-11-22 20:55:35 -08:00
|
|
|
let pss = simplify_first_col pss in
|
2019-06-13 10:25:10 -07:00
|
|
|
if not (all_coherent (hq :: first_column pss)) then
|
2017-12-07 10:33:01 -08:00
|
|
|
[]
|
2018-01-05 10:42:35 -08:00
|
|
|
else begin
|
2017-12-07 10:33:01 -08:00
|
|
|
let q0 = discr_pat q pss in
|
2019-08-19 00:48:59 -07:00
|
|
|
List.map (set_args (Patterns.Head.to_omega_pattern q0))
|
2017-12-07 10:33:01 -08:00
|
|
|
(list_satisfying_vectors
|
|
|
|
(build_specialized_submatrix ~extend_row:(@) q0 pss)
|
2019-06-13 10:25:10 -07:00
|
|
|
(simple_match_args q0 hq qargs @ qs))
|
2018-01-05 10:42:35 -08:00
|
|
|
end
|
2015-09-02 01:53:47 -07:00
|
|
|
|
2017-07-14 08:18:25 -07:00
|
|
|
(******************************************)
|
|
|
|
(* Look for a row that matches some value *)
|
|
|
|
(******************************************)
|
|
|
|
|
|
|
|
(*
|
|
|
|
Useful for seeing if the example of
|
|
|
|
non-matched value can indeed be matched
|
|
|
|
(by a guarded clause)
|
|
|
|
*)
|
|
|
|
|
|
|
|
let rec do_match pss qs = match qs with
|
|
|
|
| [] ->
|
|
|
|
begin match pss with
|
|
|
|
| []::_ -> true
|
|
|
|
| _ -> false
|
|
|
|
end
|
2019-09-10 00:15:13 -07:00
|
|
|
| q::qs -> match Patterns.General.(view q |> strip_vars).pat_desc with
|
|
|
|
| `Or (q1,q2,_) ->
|
2017-07-14 08:18:25 -07:00
|
|
|
do_match pss (q1::qs) || do_match pss (q2::qs)
|
2019-09-10 00:15:13 -07:00
|
|
|
| `Any ->
|
2017-07-14 08:23:18 -07:00
|
|
|
let rec remove_first_column = function
|
|
|
|
| (_::ps)::rem -> ps::remove_first_column rem
|
|
|
|
| _ -> []
|
|
|
|
in
|
|
|
|
do_match (remove_first_column pss) qs
|
2019-09-10 00:15:13 -07:00
|
|
|
| #Patterns.Simple.view as view ->
|
|
|
|
let q = { q with pat_desc = view } in
|
2019-08-19 00:48:59 -07:00
|
|
|
let q0, qargs = Patterns.Head.deconstruct q in
|
2017-12-07 10:33:01 -08:00
|
|
|
let pss = simplify_first_col pss in
|
|
|
|
(* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
|
|
|
|
its first column. *)
|
2017-07-14 08:23:18 -07:00
|
|
|
do_match
|
2017-12-07 10:33:01 -08:00
|
|
|
(build_specialized_submatrix ~extend_row:(@) q0 pss)
|
2019-06-13 10:25:10 -07:00
|
|
|
(qargs @ qs)
|
2017-07-14 08:18:25 -07:00
|
|
|
|
2012-05-30 07:52:37 -07:00
|
|
|
(*
|
|
|
|
let print_pat pat =
|
|
|
|
let rec string_of_pat pat =
|
|
|
|
match pat.pat_desc with
|
|
|
|
Tpat_var _ -> "v"
|
|
|
|
| Tpat_any -> "_"
|
|
|
|
| Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p)
|
|
|
|
| Tpat_constant n -> "0"
|
2013-04-17 02:46:52 -07:00
|
|
|
| Tpat_construct (_, lid, _) ->
|
2012-05-30 07:52:37 -07:00
|
|
|
Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
|
|
|
|
| Tpat_lazy p ->
|
|
|
|
Printf.sprintf "(lazy %s)" (string_of_pat p)
|
|
|
|
| Tpat_or (p1,p2,_) ->
|
|
|
|
Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2)
|
|
|
|
| Tpat_tuple list ->
|
|
|
|
Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list))
|
|
|
|
| Tpat_variant (_, _, _) -> "variant"
|
|
|
|
| Tpat_record (_, _) -> "record"
|
|
|
|
| Tpat_array _ -> "array"
|
|
|
|
in
|
|
|
|
Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
|
|
|
|
*)
|
|
|
|
|
2017-07-14 08:57:28 -07:00
|
|
|
(*
|
|
|
|
Now another satisfiable function that additionally
|
|
|
|
supplies an example of a matching value.
|
|
|
|
|
|
|
|
This function should be called for exhaustiveness check only.
|
|
|
|
*)
|
2017-07-07 05:11:15 -07:00
|
|
|
let rec exhaust (ext:Path.t option) pss n = match pss with
|
2020-04-26 00:37:24 -07:00
|
|
|
| [] -> Seq.return (omegas n)
|
|
|
|
| []::_ -> Seq.empty
|
2020-04-29 06:49:50 -07:00
|
|
|
| [(p :: ps)] -> exhaust_single_row ext p ps n
|
|
|
|
| pss -> specialize_and_exhaust ext pss n
|
|
|
|
|
|
|
|
and exhaust_single_row ext p ps n =
|
|
|
|
(* Shortcut: in the single-row case p :: ps we know that all
|
|
|
|
counter-examples are either of the form
|
|
|
|
counter-example(p) :: omegas
|
|
|
|
or
|
|
|
|
p :: counter-examples(ps)
|
|
|
|
|
|
|
|
This is very interesting in the case where p contains
|
|
|
|
or-patterns, as the non-shortcut path below would do a separate
|
|
|
|
search for each constructor of the or-pattern, which can lead to
|
|
|
|
an exponential blowup on examples such as
|
|
|
|
|
|
|
|
| (A|B), (A|B), (A|B), (A|B) -> foo
|
|
|
|
|
|
|
|
Note that this shortcut also applies to examples such as
|
|
|
|
|
|
|
|
| A, A, A, A -> foo | (A|B), (A|B), (A|B), (A|B) -> bar
|
|
|
|
|
|
|
|
thanks to the [get_mins] preprocessing step which will drop the
|
|
|
|
first row (subsumed by the second). Code with this shape does
|
|
|
|
occur naturally when people want to avoid fragile pattern
|
|
|
|
matches: if A and B are the only two constructors, this is the
|
|
|
|
best way to make a non-fragile distinction between "all As" and
|
|
|
|
"at least one B".
|
|
|
|
*)
|
|
|
|
List.to_seq [Some p; None] |> Seq.flat_map
|
|
|
|
(function
|
|
|
|
| Some p ->
|
|
|
|
let sub_witnesses = exhaust ext [ps] (n - 1) in
|
|
|
|
Seq.map (fun row -> p :: row) sub_witnesses
|
|
|
|
| None ->
|
|
|
|
(* note: calling [exhaust] recursively of p would
|
|
|
|
result in an infinite loop in the case n=1 *)
|
|
|
|
let p_witnesses = specialize_and_exhaust ext [[p]] 1 in
|
|
|
|
Seq.map (fun p_row -> p_row @ omegas (n - 1)) p_witnesses
|
|
|
|
)
|
|
|
|
|
|
|
|
and specialize_and_exhaust ext pss n =
|
|
|
|
let pss = simplify_first_col pss in
|
|
|
|
if not (all_coherent (first_column pss)) then
|
|
|
|
(* We're considering an ill-typed branch, we won't actually be able to
|
|
|
|
produce a well typed value taking that branch. *)
|
|
|
|
Seq.empty
|
|
|
|
else begin
|
|
|
|
(* Assuming the first column is ill-typed but considered coherent, we
|
|
|
|
might end up producing an ill-typed witness of non-exhaustivity
|
|
|
|
corresponding to the current branch.
|
|
|
|
|
|
|
|
If [exhaust] has been called by [do_check_partial], then the witnesses
|
|
|
|
produced get typechecked and the ill-typed ones are discarded.
|
|
|
|
|
|
|
|
If [exhaust] has been called by [do_check_fragile], then it is possible
|
|
|
|
we might fail to warn the user that the matching is fragile. See for
|
|
|
|
example testsuite/tests/warnings/w04_failure.ml. *)
|
|
|
|
let q0 = discr_pat Patterns.Simple.omega pss in
|
|
|
|
match build_specialized_submatrices ~extend_row:(@) q0 pss with
|
|
|
|
| { default; constrs = [] } ->
|
|
|
|
(* first column of pss is made of variables only *)
|
|
|
|
let sub_witnesses = exhaust ext default (n-1) in
|
|
|
|
let q0 = Patterns.Head.to_omega_pattern q0 in
|
|
|
|
Seq.map (fun row -> q0::row) sub_witnesses
|
|
|
|
| { default; constrs } ->
|
|
|
|
let try_non_omega (p,pss) =
|
|
|
|
if is_absent_pat p then
|
|
|
|
Seq.empty
|
|
|
|
else
|
|
|
|
let sub_witnesses =
|
|
|
|
exhaust
|
|
|
|
ext pss
|
|
|
|
(List.length (simple_match_args p Patterns.Head.omega [])
|
|
|
|
+ n - 1)
|
|
|
|
in
|
|
|
|
let p = Patterns.Head.to_omega_pattern p in
|
|
|
|
Seq.map (set_args p) sub_witnesses
|
|
|
|
in
|
|
|
|
let try_omega () =
|
|
|
|
if full_match false constrs && not (should_extend ext constrs) then
|
|
|
|
Seq.empty
|
|
|
|
else
|
|
|
|
let sub_witnesses = exhaust ext default (n-1) in
|
|
|
|
match build_other ext constrs with
|
|
|
|
| exception Empty ->
|
|
|
|
(* cannot occur, since constructors don't make
|
|
|
|
a full signature *)
|
|
|
|
fatal_error "Parmatch.exhaust"
|
|
|
|
| p ->
|
|
|
|
Seq.map (fun tail -> p :: tail) sub_witnesses
|
|
|
|
in
|
|
|
|
(* Lazily compute witnesses for all constructor submatrices
|
|
|
|
(Some constr_mat) then the wildcard/default submatrix (None).
|
|
|
|
Note that the call to [try_omega ()] is delayed to after
|
|
|
|
all constructor matrices have been traversed. *)
|
|
|
|
List.map (fun constr_mat -> Some constr_mat) constrs @ [None]
|
|
|
|
|> List.to_seq
|
|
|
|
|> Seq.flat_map
|
|
|
|
(function
|
|
|
|
| Some constr_mat -> try_non_omega constr_mat
|
|
|
|
| None -> try_omega ())
|
|
|
|
end
|
2010-11-07 23:34:09 -08:00
|
|
|
|
2017-07-07 05:11:15 -07:00
|
|
|
let exhaust ext pss n =
|
2020-04-26 00:37:24 -07:00
|
|
|
exhaust ext pss n
|
|
|
|
|> Seq.map (function
|
|
|
|
| [x] -> x
|
|
|
|
| _ -> assert false)
|
2010-11-07 23:34:09 -08:00
|
|
|
|
2003-08-18 01:26:18 -07:00
|
|
|
(*
|
|
|
|
Another exhaustiveness check, enforcing variant typing.
|
|
|
|
Note that it does not check exact exhaustiveness, but whether a
|
|
|
|
matching could be made exhaustive by closing all variant types.
|
|
|
|
When this is true of all other columns, the current column is left
|
|
|
|
open (even if it means that the whole matching is not exhaustive as
|
|
|
|
a result).
|
|
|
|
When this is false for the matrix minus the current column, and the
|
|
|
|
current column is composed of variant tags, we close the variant
|
|
|
|
(even if it doesn't help in making the matching exhaustive).
|
|
|
|
*)
|
|
|
|
|
2003-08-14 02:04:43 -07:00
|
|
|
let rec pressure_variants tdefs = function
|
|
|
|
| [] -> false
|
|
|
|
| []::_ -> true
|
|
|
|
| pss ->
|
2017-11-22 20:55:35 -08:00
|
|
|
let pss = simplify_first_col pss in
|
2017-12-07 10:33:01 -08:00
|
|
|
if not (all_coherent (first_column pss)) then
|
|
|
|
true
|
2018-01-05 10:42:35 -08:00
|
|
|
else begin
|
2019-09-10 00:15:13 -07:00
|
|
|
let q0 = discr_pat Patterns.Simple.omega pss in
|
2017-12-07 10:33:01 -08:00
|
|
|
match build_specialized_submatrices ~extend_row:(@) q0 pss with
|
|
|
|
| { default; constrs = [] } -> pressure_variants tdefs default
|
|
|
|
| { default; constrs } ->
|
|
|
|
let rec try_non_omega = function
|
|
|
|
| (_p,pss) :: rem ->
|
|
|
|
let ok = pressure_variants tdefs pss in
|
|
|
|
(* The order below matters : we want [pressure_variants] to be
|
|
|
|
called on all the specialized submatrices because we might
|
|
|
|
close some variant in any of them regardless of whether [ok]
|
|
|
|
is true for [pss] or not *)
|
|
|
|
try_non_omega rem && ok
|
|
|
|
| [] -> true
|
2003-08-18 01:26:18 -07:00
|
|
|
in
|
2017-12-07 10:33:01 -08:00
|
|
|
if full_match (tdefs=None) constrs then
|
|
|
|
try_non_omega constrs
|
|
|
|
else if tdefs = None then
|
|
|
|
pressure_variants None default
|
|
|
|
else
|
|
|
|
let full = full_match true constrs in
|
|
|
|
let ok =
|
|
|
|
if full then
|
|
|
|
try_non_omega constrs
|
2018-01-05 10:42:35 -08:00
|
|
|
else begin
|
2017-12-07 10:33:01 -08:00
|
|
|
let { constrs = partial_constrs; _ } =
|
|
|
|
build_specialized_submatrices ~extend_row:(@) q0
|
|
|
|
(mark_partial pss)
|
|
|
|
in
|
|
|
|
try_non_omega partial_constrs
|
2018-01-05 10:42:35 -08:00
|
|
|
end
|
2017-12-07 10:33:01 -08:00
|
|
|
in
|
|
|
|
begin match constrs, tdefs with
|
2019-06-13 10:25:10 -07:00
|
|
|
| [], _
|
|
|
|
| _, None -> ()
|
|
|
|
| (d, _) :: _, Some env ->
|
2019-09-09 08:54:09 -07:00
|
|
|
match d.pat_desc with
|
2019-06-13 10:25:10 -07:00
|
|
|
| Variant { type_row; _ } ->
|
|
|
|
let row = type_row () in
|
2017-12-07 10:33:01 -08:00
|
|
|
if Btype.row_fixed row
|
|
|
|
|| pressure_variants None default then ()
|
|
|
|
else close_variant env row
|
2019-06-13 10:25:10 -07:00
|
|
|
| _ -> ()
|
2017-12-07 10:33:01 -08:00
|
|
|
end;
|
|
|
|
ok
|
2018-01-05 10:42:35 -08:00
|
|
|
end
|
2003-08-14 02:04:43 -07:00
|
|
|
|
2002-05-24 07:34:37 -07:00
|
|
|
|
2017-08-10 03:59:23 -07:00
|
|
|
(* Yet another satisfiable function *)
|
2002-05-24 07:34:37 -07:00
|
|
|
|
|
|
|
(*
|
|
|
|
This time every_satisfiable pss qs checks the
|
|
|
|
utility of every expansion of qs.
|
|
|
|
Expansion means expansion of or-patterns inside qs
|
|
|
|
*)
|
|
|
|
|
|
|
|
type answer =
|
|
|
|
| Used (* Useful pattern *)
|
|
|
|
| Unused (* Useless pattern *)
|
2012-05-31 01:07:31 -07:00
|
|
|
| Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *)
|
2002-05-24 07:34:37 -07:00
|
|
|
|
|
|
|
|
2010-01-22 04:48:24 -08:00
|
|
|
|
|
|
|
(* this row type enable column processing inside the matrix
|
2002-09-23 01:36:46 -07:00
|
|
|
- left -> elements not to be processed,
|
|
|
|
- right -> elements to be processed
|
|
|
|
*)
|
2018-01-03 07:55:28 -08:00
|
|
|
type usefulness_row =
|
|
|
|
{no_ors : pattern list ; ors : pattern list ; active : pattern list}
|
2002-09-23 01:36:46 -07:00
|
|
|
|
2015-10-16 07:55:15 -07:00
|
|
|
(*
|
2002-09-25 09:37:04 -07:00
|
|
|
let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
|
|
|
|
pretty_line ors ; prerr_string " *" ;
|
|
|
|
pretty_line no_ors ; prerr_string " *" ;
|
|
|
|
pretty_line active
|
2002-09-23 01:36:46 -07:00
|
|
|
|
|
|
|
let pretty_rows rs =
|
|
|
|
prerr_endline "begin matrix" ;
|
|
|
|
List.iter
|
|
|
|
(fun r ->
|
|
|
|
pretty_row r ;
|
|
|
|
prerr_endline "")
|
|
|
|
rs ;
|
|
|
|
prerr_endline "end matrix"
|
2015-10-16 07:55:15 -07:00
|
|
|
*)
|
2002-09-23 01:36:46 -07:00
|
|
|
|
|
|
|
(* Initial build *)
|
2002-09-25 09:37:04 -07:00
|
|
|
let make_row ps = {ors=[] ; no_ors=[]; active=ps}
|
2002-09-23 01:36:46 -07:00
|
|
|
|
|
|
|
let make_rows pss = List.map make_row pss
|
|
|
|
|
|
|
|
|
2019-09-10 00:15:13 -07:00
|
|
|
(* Useful to detect and expand or pats inside as pats *)
|
|
|
|
let is_var p = match Patterns.General.(view p |> strip_vars).pat_desc with
|
|
|
|
| `Any -> true
|
|
|
|
| _ -> false
|
2002-09-23 01:36:46 -07:00
|
|
|
|
|
|
|
let is_var_column rs =
|
|
|
|
List.for_all
|
2002-09-25 09:37:04 -07:00
|
|
|
(fun r -> match r.active with
|
2002-09-23 01:36:46 -07:00
|
|
|
| p::_ -> is_var p
|
|
|
|
| [] -> assert false)
|
|
|
|
rs
|
|
|
|
|
2003-05-02 02:57:53 -07:00
|
|
|
(* Standard or-args for left-to-right matching *)
|
2002-09-25 09:37:04 -07:00
|
|
|
let rec or_args p = match p.pat_desc with
|
|
|
|
| Tpat_or (p1,p2,_) -> p1,p2
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_alias (p,_,_) -> or_args p
|
2002-09-25 09:37:04 -07:00
|
|
|
| _ -> assert false
|
|
|
|
|
2002-09-23 01:36:46 -07:00
|
|
|
(* Just remove current column *)
|
2002-09-25 09:37:04 -07:00
|
|
|
let remove r = match r.active with
|
|
|
|
| _::rem -> {r with active=rem}
|
2002-09-23 01:36:46 -07:00
|
|
|
| [] -> assert false
|
|
|
|
|
|
|
|
let remove_column rs = List.map remove rs
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2002-09-23 01:36:46 -07:00
|
|
|
(* Current column has been processed *)
|
2002-09-25 09:37:04 -07:00
|
|
|
let push_no_or r = match r.active with
|
|
|
|
| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
|
|
|
|
| [] -> assert false
|
|
|
|
|
|
|
|
let push_or r = match r.active with
|
|
|
|
| p::rem -> { r with ors = p::r.ors ; active=rem}
|
2002-09-23 01:36:46 -07:00
|
|
|
| [] -> assert false
|
|
|
|
|
2002-09-25 09:37:04 -07:00
|
|
|
let push_or_column rs = List.map push_or rs
|
|
|
|
and push_no_or_column rs = List.map push_no_or rs
|
2002-09-23 01:36:46 -07:00
|
|
|
|
2018-01-03 07:55:28 -08:00
|
|
|
let rec simplify_first_usefulness_col = function
|
2002-09-23 01:36:46 -07:00
|
|
|
| [] -> []
|
2017-07-12 06:24:00 -07:00
|
|
|
| row :: rows ->
|
|
|
|
match row.active with
|
|
|
|
| [] -> assert false (* the rows are non-empty! *)
|
|
|
|
| p :: ps ->
|
2018-01-19 11:38:56 -08:00
|
|
|
let add_column p ps k =
|
|
|
|
(p, { row with active = ps }) :: k in
|
|
|
|
simplify_head_pat ~add_column p ps
|
2018-01-03 07:55:28 -08:00
|
|
|
(simplify_first_usefulness_col rows)
|
2002-09-23 01:36:46 -07:00
|
|
|
|
|
|
|
(* Back to normal matrices *)
|
2017-12-07 10:33:01 -08:00
|
|
|
let make_vector r = List.rev r.no_ors
|
2002-09-23 01:36:46 -07:00
|
|
|
|
|
|
|
let make_matrix rs = List.map make_vector rs
|
|
|
|
|
|
|
|
|
|
|
|
(* Standard union on answers *)
|
|
|
|
let union_res r1 r2 = match r1, r2 with
|
2002-09-23 10:19:33 -07:00
|
|
|
| (Unused,_)
|
2002-09-25 09:37:04 -07:00
|
|
|
| (_, Unused) -> Unused
|
2002-09-23 01:36:46 -07:00
|
|
|
| Used,_ -> r2
|
|
|
|
| _, Used -> r1
|
|
|
|
| Upartial u1, Upartial u2 -> Upartial (u1@u2)
|
|
|
|
|
2002-09-25 09:37:04 -07:00
|
|
|
(* propose or pats for expansion *)
|
|
|
|
let extract_elements qs =
|
|
|
|
let rec do_rec seen = function
|
|
|
|
| [] -> []
|
|
|
|
| q::rem ->
|
|
|
|
{no_ors= List.rev_append seen rem @ qs.no_ors ;
|
|
|
|
ors=[] ;
|
|
|
|
active = [q]}::
|
|
|
|
do_rec (q::seen) rem in
|
|
|
|
do_rec [] qs.ors
|
|
|
|
|
|
|
|
(* idem for matrices *)
|
|
|
|
let transpose rs = match rs with
|
|
|
|
| [] -> assert false
|
|
|
|
| r::rem ->
|
|
|
|
let i = List.map (fun x -> [x]) r in
|
|
|
|
List.fold_left
|
|
|
|
(List.map2 (fun r x -> x::r))
|
|
|
|
i rem
|
|
|
|
|
|
|
|
let extract_columns pss qs = match pss with
|
|
|
|
| [] -> List.map (fun _ -> []) qs.ors
|
|
|
|
| _ ->
|
|
|
|
let rows = List.map extract_elements pss in
|
|
|
|
transpose rows
|
2002-09-23 01:36:46 -07:00
|
|
|
|
|
|
|
(* Core function
|
2002-09-25 09:37:04 -07:00
|
|
|
The idea is to first look for or patterns (recursive case), then
|
|
|
|
check or-patterns argument usefulness (terminal case)
|
2002-09-23 01:36:46 -07:00
|
|
|
*)
|
|
|
|
|
2002-09-25 09:37:04 -07:00
|
|
|
let rec every_satisfiables pss qs = match qs.active with
|
2002-09-23 01:36:46 -07:00
|
|
|
| [] ->
|
2002-09-25 09:37:04 -07:00
|
|
|
(* qs is now partitionned, check usefulness *)
|
|
|
|
begin match qs.ors with
|
|
|
|
| [] -> (* no or-patterns *)
|
|
|
|
if satisfiable (make_matrix pss) (make_vector qs) then
|
|
|
|
Used
|
|
|
|
else
|
|
|
|
Unused
|
|
|
|
| _ -> (* n or-patterns -> 2n expansions *)
|
|
|
|
List.fold_right2
|
|
|
|
(fun pss qs r -> match r with
|
|
|
|
| Unused -> Unused
|
|
|
|
| _ ->
|
|
|
|
match qs.active with
|
|
|
|
| [q] ->
|
|
|
|
let q1,q2 = or_args q in
|
|
|
|
let r_loc = every_both pss qs q1 q2 in
|
|
|
|
union_res r r_loc
|
|
|
|
| _ -> assert false)
|
|
|
|
(extract_columns pss qs) (extract_elements qs)
|
|
|
|
Used
|
|
|
|
end
|
2002-09-23 01:36:46 -07:00
|
|
|
| q::rem ->
|
2019-09-10 00:15:13 -07:00
|
|
|
begin match Patterns.General.(view q |> strip_vars).pat_desc with
|
|
|
|
| `Any ->
|
2002-09-23 01:36:46 -07:00
|
|
|
if is_var_column pss then
|
2019-09-10 00:15:13 -07:00
|
|
|
(* forget about ``all-variable'' columns now *)
|
2002-09-23 01:36:46 -07:00
|
|
|
every_satisfiables (remove_column pss) (remove qs)
|
2002-05-24 07:34:37 -07:00
|
|
|
else
|
2019-09-10 00:15:13 -07:00
|
|
|
(* otherwise this is direct food for satisfiable *)
|
2002-09-25 09:37:04 -07:00
|
|
|
every_satisfiables (push_no_or_column pss) (push_no_or qs)
|
2019-09-10 00:15:13 -07:00
|
|
|
| `Or (q1,q2,_) ->
|
2003-02-24 07:13:01 -08:00
|
|
|
if
|
|
|
|
q1.pat_loc.Location.loc_ghost &&
|
|
|
|
q2.pat_loc.Location.loc_ghost
|
|
|
|
then
|
2019-09-10 00:15:13 -07:00
|
|
|
(* syntactically generated or-pats should not be expanded *)
|
2002-09-25 09:37:04 -07:00
|
|
|
every_satisfiables (push_no_or_column pss) (push_no_or qs)
|
2010-01-22 04:48:24 -08:00
|
|
|
else
|
2019-09-10 00:15:13 -07:00
|
|
|
(* this is a real or-pattern *)
|
2002-09-25 09:37:04 -07:00
|
|
|
every_satisfiables (push_or_column pss) (push_or qs)
|
2019-09-10 00:15:13 -07:00
|
|
|
| `Variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
|
2002-09-23 01:36:46 -07:00
|
|
|
Unused
|
2019-09-10 00:15:13 -07:00
|
|
|
| #Patterns.Simple.view as view ->
|
|
|
|
let q = { q with pat_desc = view } in
|
|
|
|
(* standard case, filter matrix *)
|
2018-01-03 07:55:28 -08:00
|
|
|
let pss = simplify_first_usefulness_col pss in
|
2019-09-10 00:15:13 -07:00
|
|
|
let hq, args = Patterns.Head.deconstruct q in
|
2017-12-07 10:33:01 -08:00
|
|
|
(* The handling of incoherent matrices is kept in line with
|
|
|
|
[satisfiable] *)
|
2019-09-10 00:15:13 -07:00
|
|
|
if not (all_coherent (hq :: first_column pss)) then
|
2017-12-07 10:33:01 -08:00
|
|
|
Unused
|
2018-01-05 10:42:35 -08:00
|
|
|
else begin
|
2017-12-07 10:33:01 -08:00
|
|
|
let q0 = discr_pat q pss in
|
|
|
|
every_satisfiables
|
|
|
|
(build_specialized_submatrix q0 pss
|
|
|
|
~extend_row:(fun ps r -> { r with active = ps @ r.active }))
|
2019-09-10 00:15:13 -07:00
|
|
|
{qs with active=simple_match_args q0 hq args @ rem}
|
2018-01-05 10:42:35 -08:00
|
|
|
end
|
2002-05-24 07:34:37 -07:00
|
|
|
end
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2002-09-23 01:36:46 -07:00
|
|
|
(*
|
2002-09-23 10:19:33 -07:00
|
|
|
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,
|
2002-09-25 09:37:04 -07:00
|
|
|
- others orpats in qs.ors will not get expanded.
|
|
|
|
- all matching work performed on qs.no_ors is not performed again.
|
2002-09-23 10:19:33 -07:00
|
|
|
*)
|
2002-09-23 01:36:46 -07:00
|
|
|
and every_both pss qs q1 q2 =
|
2002-09-25 09:37:04 -07:00
|
|
|
let qs1 = {qs with active=[q1]}
|
|
|
|
and qs2 = {qs with active=[q2]} in
|
2002-09-23 01:36:46 -07:00
|
|
|
let r1 = every_satisfiables pss qs1
|
2002-09-23 10:19:33 -07:00
|
|
|
and r2 = every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
|
2002-09-23 01:36:46 -07:00
|
|
|
match r1 with
|
|
|
|
| Unused ->
|
|
|
|
begin match r2 with
|
|
|
|
| Unused -> Unused
|
|
|
|
| Used -> Upartial [q1]
|
|
|
|
| Upartial u2 -> Upartial (q1::u2)
|
|
|
|
end
|
|
|
|
| Used ->
|
|
|
|
begin match r2 with
|
|
|
|
| Unused -> Upartial [q2]
|
|
|
|
| _ -> r2
|
|
|
|
end
|
|
|
|
| Upartial u1 ->
|
|
|
|
begin match r2 with
|
|
|
|
| Unused -> Upartial (u1@[q2])
|
|
|
|
| Used -> r1
|
|
|
|
| Upartial u2 -> Upartial (u1 @ u2)
|
|
|
|
end
|
1999-10-29 07:42:37 -07:00
|
|
|
|
2010-01-22 04:48:24 -08:00
|
|
|
|
1999-10-29 07:42:37 -07:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2002-05-24 07:34:37 -07:00
|
|
|
(* le_pat p q means, forall V, V matches q implies V matches p *)
|
1995-05-04 03:15:53 -07:00
|
|
|
let rec le_pat p q =
|
|
|
|
match (p.pat_desc, q.pat_desc) with
|
2002-09-25 09:37:04 -07:00
|
|
|
| (Tpat_var _|Tpat_any),_ -> true
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_alias(p,_,_), _ -> le_pat p q
|
|
|
|
| _, Tpat_alias(q,_,_) -> le_pat p q
|
2012-09-18 23:57:17 -07:00
|
|
|
| Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
|
2013-04-17 02:46:52 -07:00
|
|
|
| Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) ->
|
2017-04-28 07:31:52 -07:00
|
|
|
Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
|
1999-11-30 08:07:38 -08:00
|
|
|
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
|
2002-05-24 07:34:37 -07:00
|
|
|
(l1 = l2 && le_pat p1 p2)
|
2016-03-09 02:40:16 -08:00
|
|
|
| Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
|
2002-05-24 07:34:37 -07:00
|
|
|
l1 = l2
|
2004-01-09 05:12:17 -08:00
|
|
|
| Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
|
1995-05-04 03:15:53 -07:00
|
|
|
| Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
|
2008-07-09 06:03:38 -07:00
|
|
|
| Tpat_lazy p, Tpat_lazy q -> le_pat p q
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_record (l1,_), Tpat_record (l2,_) ->
|
2001-02-19 12:27:52 -08:00
|
|
|
let ps,qs = records_args l1 l2 in
|
1999-10-29 07:42:37 -07:00
|
|
|
le_pats ps qs
|
1998-04-06 02:23:01 -07:00
|
|
|
| Tpat_array(ps), Tpat_array(qs) ->
|
2002-09-23 01:36:46 -07:00
|
|
|
List.length ps = List.length qs && le_pats ps qs
|
2001-02-19 12:27:52 -08:00
|
|
|
(* In all other cases, enumeration is performed *)
|
2004-01-16 06:09:30 -08:00
|
|
|
| _,_ -> not (satisfiable [[p]] [q])
|
2010-01-22 04:48:24 -08:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
and le_pats ps qs =
|
|
|
|
match ps,qs with
|
1998-04-06 02:23:01 -07:00
|
|
|
p::ps, q::qs -> le_pat p q && le_pats ps qs
|
1995-05-04 03:15:53 -07:00
|
|
|
| _, _ -> true
|
|
|
|
|
2001-02-19 12:27:52 -08:00
|
|
|
let get_mins le ps =
|
1995-05-04 03:15:53 -07:00
|
|
|
let rec select_rec r = function
|
2002-09-23 01:36:46 -07:00
|
|
|
[] -> r
|
|
|
|
| p::ps ->
|
|
|
|
if List.exists (fun p0 -> le p0 p) ps
|
|
|
|
then select_rec r ps
|
|
|
|
else select_rec (p::r) ps in
|
1995-05-04 03:15:53 -07:00
|
|
|
select_rec [] (select_rec [] ps)
|
|
|
|
|
2001-02-19 12:27:52 -08:00
|
|
|
(*
|
2002-09-23 01:36:46 -07:00
|
|
|
lub p q is a pattern that matches all values matched by p and q
|
2015-10-09 13:41:53 -07:00
|
|
|
may raise Empty, when p and q are not compatible
|
2002-09-25 09:37:04 -07:00
|
|
|
*)
|
2001-02-19 12:27:52 -08:00
|
|
|
|
|
|
|
let rec lub p q = match p.pat_desc,q.pat_desc with
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_alias (p,_,_),_ -> lub p q
|
|
|
|
| _,Tpat_alias (q,_,_) -> lub p q
|
2001-02-19 12:27:52 -08:00
|
|
|
| (Tpat_any|Tpat_var _),_ -> q
|
|
|
|
| _,(Tpat_any|Tpat_var _) -> p
|
2001-09-25 02:54:18 -07:00
|
|
|
| Tpat_or (p1,p2,_),_ -> orlub p1 p2 q
|
|
|
|
| _,Tpat_or (q1,q2,_) -> orlub q1 q2 p (* Thanks god, lub is commutative *)
|
2012-09-18 23:57:17 -07:00
|
|
|
| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
|
2001-02-19 12:27:52 -08:00
|
|
|
| Tpat_tuple ps, Tpat_tuple qs ->
|
|
|
|
let rs = lubs ps qs in
|
|
|
|
make_pat (Tpat_tuple rs) p.pat_type p.pat_env
|
2008-07-09 06:03:38 -07:00
|
|
|
| Tpat_lazy p, Tpat_lazy q ->
|
|
|
|
let r = lub p q in
|
|
|
|
make_pat (Tpat_lazy r) p.pat_type p.pat_env
|
2013-04-17 02:46:52 -07:00
|
|
|
| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2)
|
2017-04-28 07:31:52 -07:00
|
|
|
when Types.equal_tag c1.cstr_tag c2.cstr_tag ->
|
2001-02-19 12:27:52 -08:00
|
|
|
let rs = lubs ps1 ps2 in
|
2013-04-17 02:46:52 -07:00
|
|
|
make_pat (Tpat_construct (lid, c1,rs))
|
2012-05-31 01:07:31 -07:00
|
|
|
p.pat_type p.pat_env
|
2001-02-19 12:27:52 -08:00
|
|
|
| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
|
2004-01-09 05:12:17 -08:00
|
|
|
when l1=l2 ->
|
2002-09-23 01:36:46 -07:00
|
|
|
let r=lub p1 p2 in
|
|
|
|
make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
|
2016-03-09 02:40:16 -08:00
|
|
|
| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
|
2004-01-09 05:12:17 -08:00
|
|
|
when l1 = l2 -> p
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_record (l1,closed),Tpat_record (l2,_) ->
|
2001-02-19 12:27:52 -08:00
|
|
|
let rs = record_lubs l1 l2 in
|
2012-05-30 07:52:37 -07:00
|
|
|
make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
|
2001-02-19 12:27:52 -08:00
|
|
|
| Tpat_array ps, Tpat_array qs
|
2002-09-23 01:36:46 -07:00
|
|
|
when List.length ps = List.length qs ->
|
|
|
|
let rs = lubs ps qs in
|
|
|
|
make_pat (Tpat_array rs) p.pat_type p.pat_env
|
2001-02-19 12:27:52 -08:00
|
|
|
| _,_ ->
|
|
|
|
raise Empty
|
|
|
|
|
|
|
|
and orlub p1 p2 q =
|
2010-01-22 04:48:24 -08:00
|
|
|
try
|
2001-02-19 12:27:52 -08:00
|
|
|
let r1 = lub p1 q in
|
|
|
|
try
|
2001-09-25 02:54:18 -07:00
|
|
|
{q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
|
2001-02-19 12:27:52 -08:00
|
|
|
with
|
2002-09-23 01:36:46 -07:00
|
|
|
| Empty -> r1
|
|
|
|
with
|
|
|
|
| Empty -> lub p2 q
|
2001-02-19 12:27:52 -08:00
|
|
|
|
|
|
|
and record_lubs l1 l2 =
|
|
|
|
let rec lub_rec l1 l2 = match l1,l2 with
|
|
|
|
| [],_ -> l2
|
|
|
|
| _,[] -> l1
|
2012-10-24 05:03:00 -07:00
|
|
|
| (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
|
2001-02-19 12:27:52 -08:00
|
|
|
if lbl1.lbl_pos < lbl2.lbl_pos then
|
2012-10-24 05:03:00 -07:00
|
|
|
(lid1, lbl1,p1)::lub_rec rem1 l2
|
2001-02-19 12:27:52 -08:00
|
|
|
else if lbl2.lbl_pos < lbl1.lbl_pos then
|
2012-10-24 05:03:00 -07:00
|
|
|
(lid2, lbl2,p2)::lub_rec l1 rem2
|
2001-02-19 12:27:52 -08:00
|
|
|
else
|
2012-10-24 05:03:00 -07:00
|
|
|
(lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
|
2001-02-19 12:27:52 -08:00
|
|
|
lub_rec l1 l2
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2001-02-19 12:27:52 -08:00
|
|
|
and lubs ps qs = match ps,qs with
|
|
|
|
| p::ps, q::qs -> lub p q :: lubs ps qs
|
|
|
|
| _,_ -> []
|
2010-01-22 04:48:24 -08:00
|
|
|
|
|
|
|
|
1999-10-29 07:42:37 -07:00
|
|
|
(******************************)
|
2006-09-21 07:54:54 -07:00
|
|
|
(* Exported variant closing *)
|
1999-10-29 07:42:37 -07:00
|
|
|
(******************************)
|
|
|
|
|
2003-08-18 01:26:18 -07:00
|
|
|
(* Apply pressure to variants *)
|
|
|
|
|
|
|
|
let pressure_variants tdefs patl =
|
2019-09-20 06:23:07 -07:00
|
|
|
ignore (pressure_variants
|
|
|
|
(Some tdefs)
|
|
|
|
(List.map (fun p -> [p; omega]) patl))
|
|
|
|
|
|
|
|
let pressure_variants_in_computation_pattern tdefs patl =
|
2018-01-15 03:11:06 -08:00
|
|
|
let add_row pss p_opt =
|
|
|
|
match p_opt with
|
|
|
|
| None -> pss
|
2019-09-20 06:23:07 -07:00
|
|
|
| Some p -> p :: pss
|
2018-01-15 03:11:06 -08:00
|
|
|
in
|
|
|
|
let val_pss, exn_pss =
|
|
|
|
List.fold_right (fun pat (vpss, epss)->
|
|
|
|
let (vp, ep) = split_pattern pat in
|
|
|
|
add_row vpss vp, add_row epss ep
|
|
|
|
) patl ([], [])
|
|
|
|
in
|
2019-09-20 06:23:07 -07:00
|
|
|
pressure_variants tdefs val_pss;
|
|
|
|
pressure_variants tdefs exn_pss
|
2001-02-19 12:27:52 -08:00
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
(*****************************)
|
|
|
|
(* Utilities for diagnostics *)
|
|
|
|
(*****************************)
|
|
|
|
|
2001-10-04 02:03:44 -07:00
|
|
|
(*
|
2006-09-21 07:54:54 -07:00
|
|
|
Build up a working pattern matrix by forgetting
|
|
|
|
about guarded patterns
|
2002-09-25 09:37:04 -07:00
|
|
|
*)
|
|
|
|
|
2001-10-04 02:03:44 -07:00
|
|
|
let rec initial_matrix = function
|
|
|
|
[] -> []
|
2013-04-15 09:23:22 -07:00
|
|
|
| {c_guard=Some _} :: rem -> initial_matrix rem
|
|
|
|
| {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
|
2001-02-19 12:27:52 -08:00
|
|
|
|
2002-09-25 09:37:04 -07:00
|
|
|
(*
|
2017-07-14 08:18:25 -07:00
|
|
|
Build up a working pattern matrix by keeping
|
|
|
|
only the patterns which are guarded
|
2002-09-25 09:37:04 -07:00
|
|
|
*)
|
2017-07-12 07:15:04 -07:00
|
|
|
let rec initial_only_guarded = function
|
|
|
|
| [] -> []
|
|
|
|
| { c_guard = None; _} :: rem ->
|
|
|
|
initial_only_guarded rem
|
|
|
|
| { c_lhs = pat; _ } :: rem ->
|
2017-07-14 08:08:54 -07:00
|
|
|
[pat] :: initial_only_guarded rem
|
2001-10-04 09:06:31 -07:00
|
|
|
|
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
(************************)
|
|
|
|
(* Exhaustiveness check *)
|
|
|
|
(************************)
|
|
|
|
|
2010-11-07 23:34:09 -08:00
|
|
|
(* conversion from Typedtree.pattern to Parsetree.pattern list *)
|
2011-08-09 06:59:41 -07:00
|
|
|
module Conv = struct
|
2010-11-07 23:34:09 -08:00
|
|
|
open Parsetree
|
2013-03-08 06:59:45 -08:00
|
|
|
let mkpat desc = Ast_helper.Pat.mk desc
|
2010-11-07 23:34:09 -08:00
|
|
|
|
2012-05-30 07:52:37 -07:00
|
|
|
let name_counter = ref 0
|
2013-01-24 20:26:02 -08:00
|
|
|
let fresh name =
|
2012-05-30 07:52:37 -07:00
|
|
|
let current = !name_counter in
|
2011-08-09 06:59:41 -07:00
|
|
|
name_counter := !name_counter + 1;
|
2018-08-30 10:15:32 -07:00
|
|
|
"#$" ^ name ^ Int.to_string current
|
2010-11-15 22:01:59 -08:00
|
|
|
|
2015-05-19 15:52:21 -07:00
|
|
|
let conv typed =
|
|
|
|
let constrs = Hashtbl.create 7 in
|
|
|
|
let labels = Hashtbl.create 7 in
|
2012-05-30 07:52:37 -07:00
|
|
|
let rec loop pat =
|
2010-11-07 23:34:09 -08:00
|
|
|
match pat.pat_desc with
|
2015-05-19 15:52:21 -07:00
|
|
|
Tpat_or (pa,pb,_) ->
|
2016-02-16 04:23:31 -08:00
|
|
|
mkpat (Ppat_or (loop pa, loop pb))
|
2016-08-21 18:01:17 -07:00
|
|
|
| Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
|
|
|
|
mkpat (Ppat_var nm)
|
2015-05-19 15:52:21 -07:00
|
|
|
| Tpat_any
|
|
|
|
| Tpat_var _ ->
|
|
|
|
mkpat Ppat_any
|
|
|
|
| Tpat_constant c ->
|
2015-04-18 20:07:32 -07:00
|
|
|
mkpat (Ppat_constant (Untypeast.constant c))
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_alias (p,_,_) -> loop p
|
2010-11-07 23:34:09 -08:00
|
|
|
| Tpat_tuple lst ->
|
2016-02-16 04:23:31 -08:00
|
|
|
mkpat (Ppat_tuple (List.map loop lst))
|
2015-05-19 15:52:21 -07:00
|
|
|
| Tpat_construct (cstr_lid, cstr, lst) ->
|
2013-01-24 20:26:02 -08:00
|
|
|
let id = fresh cstr.cstr_name in
|
2012-05-30 07:52:37 -07:00
|
|
|
let lid = { cstr_lid with txt = Longident.Lident id } in
|
2012-10-24 05:03:00 -07:00
|
|
|
Hashtbl.add constrs id cstr;
|
2016-02-16 04:23:31 -08:00
|
|
|
let arg =
|
|
|
|
match List.map loop lst with
|
2015-05-19 15:52:21 -07:00
|
|
|
| [] -> None
|
|
|
|
| [p] -> Some p
|
2016-02-16 04:23:31 -08:00
|
|
|
| lst -> Some (mkpat (Ppat_tuple lst))
|
2015-05-19 15:52:21 -07:00
|
|
|
in
|
2016-02-16 04:23:31 -08:00
|
|
|
mkpat (Ppat_construct(lid, arg))
|
2016-03-09 02:40:16 -08:00
|
|
|
| Tpat_variant(label,p_opt,_row_desc) ->
|
2019-05-23 08:27:58 -07:00
|
|
|
let arg = Option.map loop p_opt in
|
2015-05-19 15:52:21 -07:00
|
|
|
mkpat (Ppat_variant(label, arg))
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_record (subpatterns, _closed_flag) ->
|
2016-02-16 04:23:31 -08:00
|
|
|
let fields =
|
|
|
|
List.map
|
|
|
|
(fun (_, lbl, p) ->
|
2013-01-24 20:26:02 -08:00
|
|
|
let id = fresh lbl.lbl_name in
|
2012-10-24 05:03:00 -07:00
|
|
|
Hashtbl.add labels id lbl;
|
2015-05-19 15:52:21 -07:00
|
|
|
(mknoloc (Longident.Lident id), loop p))
|
2016-02-16 04:23:31 -08:00
|
|
|
subpatterns
|
|
|
|
in
|
|
|
|
mkpat (Ppat_record (fields, Open))
|
2010-11-07 23:34:09 -08:00
|
|
|
| Tpat_array lst ->
|
2016-02-16 04:23:31 -08:00
|
|
|
mkpat (Ppat_array (List.map loop lst))
|
2010-11-07 23:34:09 -08:00
|
|
|
| Tpat_lazy p ->
|
2016-02-16 04:23:31 -08:00
|
|
|
mkpat (Ppat_lazy (loop p))
|
2010-11-07 23:34:09 -08:00
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
let ps = loop typed in
|
2010-11-15 22:01:59 -08:00
|
|
|
(ps, constrs, labels)
|
2010-11-07 23:34:09 -08:00
|
|
|
end
|
|
|
|
|
2015-10-23 01:33:44 -07:00
|
|
|
|
2015-06-17 04:09:49 -07:00
|
|
|
(* Whether the counter-example contains an extension pattern *)
|
|
|
|
let contains_extension pat =
|
2019-09-23 05:34:53 -07:00
|
|
|
exists_pattern
|
|
|
|
(function
|
|
|
|
| {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true
|
|
|
|
| _ -> false)
|
|
|
|
pat
|
2010-11-07 23:34:09 -08:00
|
|
|
|
2019-10-30 06:32:48 -07:00
|
|
|
(* Build a pattern from its expected type *)
|
|
|
|
type pat_explosion = PE_single | PE_gadt_cases
|
|
|
|
type ppat_of_type =
|
|
|
|
| PT_empty
|
|
|
|
| PT_any
|
|
|
|
| PT_pattern of
|
|
|
|
pat_explosion *
|
|
|
|
Parsetree.pattern *
|
|
|
|
(string, constructor_description) Hashtbl.t *
|
|
|
|
(string, label_description) Hashtbl.t
|
|
|
|
|
2015-05-19 15:52:21 -07:00
|
|
|
let ppat_of_type env ty =
|
|
|
|
match pats_of_type env ty with
|
2019-10-30 06:32:48 -07:00
|
|
|
| [] -> PT_empty
|
|
|
|
| [{pat_desc = Tpat_any}] -> PT_any
|
|
|
|
| [pat] ->
|
|
|
|
let (ppat, constrs, labels) = Conv.conv pat in
|
|
|
|
PT_pattern (PE_single, ppat, constrs, labels)
|
2015-05-19 15:52:21 -07:00
|
|
|
| pats ->
|
2019-10-30 06:32:48 -07:00
|
|
|
let (ppat, constrs, labels) = Conv.conv (orify_many pats) in
|
|
|
|
PT_pattern (PE_gadt_cases, ppat, constrs, labels)
|
2010-11-07 23:34:09 -08:00
|
|
|
|
2020-04-26 00:37:24 -07:00
|
|
|
let typecheck ~pred p =
|
|
|
|
let (pattern,constrs,labels) = Conv.conv p in
|
|
|
|
pred constrs labels pattern
|
|
|
|
|
2017-07-07 05:11:15 -07:00
|
|
|
let do_check_partial ~pred loc casel pss = match pss with
|
2006-09-21 07:54:54 -07:00
|
|
|
| [] ->
|
2000-08-11 12:58:52 -07:00
|
|
|
(*
|
|
|
|
This can occur
|
2001-10-04 02:03:44 -07:00
|
|
|
- For empty matches generated by ocamlp4 (no warning)
|
2002-05-24 07:34:37 -07:00
|
|
|
- when all patterns have guards (then, casel <> [])
|
2002-09-23 01:36:46 -07:00
|
|
|
(specific warning)
|
2002-05-24 07:34:37 -07:00
|
|
|
Then match MUST be considered non-exhaustive,
|
2001-10-04 02:03:44 -07:00
|
|
|
otherwise compilation of PM is broken.
|
|
|
|
*)
|
2006-09-21 07:54:54 -07:00
|
|
|
begin match casel with
|
|
|
|
| [] -> ()
|
2017-08-31 02:54:18 -07:00
|
|
|
| _ ->
|
|
|
|
if Warnings.is_active Warnings.All_clauses_guarded then
|
|
|
|
Location.prerr_warning loc Warnings.All_clauses_guarded
|
2006-09-21 07:54:54 -07:00
|
|
|
end ;
|
|
|
|
Partial
|
2010-01-22 04:48:24 -08:00
|
|
|
| ps::_ ->
|
2020-04-26 00:37:24 -07:00
|
|
|
let counter_examples =
|
|
|
|
exhaust None pss (List.length ps)
|
|
|
|
|> Seq.filter_map (typecheck ~pred) in
|
|
|
|
match counter_examples () with
|
|
|
|
| Seq.Nil -> Total
|
|
|
|
| Seq.Cons (v, _rest) ->
|
|
|
|
if Warnings.is_active (Warnings.Partial_match "") then begin
|
|
|
|
let errmsg =
|
|
|
|
try
|
|
|
|
let buf = Buffer.create 16 in
|
|
|
|
let fmt = Format.formatter_of_buffer buf in
|
|
|
|
Printpat.top_pretty fmt v;
|
|
|
|
if do_match (initial_only_guarded casel) [v] then
|
|
|
|
Buffer.add_string buf
|
|
|
|
"\n(However, some guarded clause may match this value.)";
|
|
|
|
if contains_extension v then
|
|
|
|
Buffer.add_string buf
|
|
|
|
"\nMatching over values of extensible variant types \
|
|
|
|
(the *extension* above)\n\
|
|
|
|
must include a wild card pattern in order to be exhaustive."
|
|
|
|
;
|
|
|
|
Buffer.contents buf
|
|
|
|
with _ ->
|
|
|
|
""
|
2012-07-30 11:04:46 -07:00
|
|
|
in
|
2020-04-26 00:37:24 -07:00
|
|
|
Location.prerr_warning loc (Warnings.Partial_match errmsg)
|
|
|
|
end;
|
|
|
|
Partial
|
2006-09-21 07:54:54 -07:00
|
|
|
|
|
|
|
(*****************)
|
|
|
|
(* Fragile check *)
|
|
|
|
(*****************)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
(* Collect all data types in a pattern *)
|
2002-09-30 07:23:00 -07:00
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
let rec add_path path = function
|
|
|
|
| [] -> [path]
|
|
|
|
| x::rem as paths ->
|
|
|
|
if Path.same path x then paths
|
|
|
|
else x::add_path path rem
|
2001-02-19 12:27:52 -08:00
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
let extendable_path path =
|
|
|
|
not
|
|
|
|
(Path.same path Predef.path_bool ||
|
|
|
|
Path.same path Predef.path_list ||
|
2011-07-20 08:37:36 -07:00
|
|
|
Path.same path Predef.path_unit ||
|
2006-09-21 07:54:54 -07:00
|
|
|
Path.same path Predef.path_option)
|
2002-09-30 07:23:00 -07:00
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
let rec collect_paths_from_pat r p = match p.pat_desc with
|
2016-05-25 07:29:05 -07:00
|
|
|
| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
|
|
|
|
->
|
2017-11-03 11:23:20 -07:00
|
|
|
let path = get_constructor_type_path p.pat_type p.pat_env in
|
|
|
|
List.fold_left
|
|
|
|
collect_paths_from_pat
|
|
|
|
(if extendable_path path then add_path path r else r)
|
|
|
|
ps
|
2006-09-21 07:54:54 -07:00
|
|
|
| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
|
|
|
|
| Tpat_tuple ps | Tpat_array ps
|
2014-05-04 16:08:45 -07:00
|
|
|
| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)->
|
2006-09-21 07:54:54 -07:00
|
|
|
List.fold_left collect_paths_from_pat r ps
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_record (lps,_) ->
|
2006-09-21 07:54:54 -07:00
|
|
|
List.fold_left
|
2012-10-24 05:03:00 -07:00
|
|
|
(fun r (_, _, p) -> collect_paths_from_pat r p)
|
2006-09-21 07:54:54 -07:00
|
|
|
r lps
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
|
2006-09-21 07:54:54 -07:00
|
|
|
| Tpat_or (p1,p2,_) ->
|
|
|
|
collect_paths_from_pat (collect_paths_from_pat r p1) p2
|
Revert GPR#305 (exception patterns under or-patterns) from trunk
This week we merged several changes from Thomas Refis, to allow the
use of exception patterns under or-patterns, to write code such as
match foo x with
| None | exception Not_found -> ...
| Some -> ...
Unfortunately, I failed to properly assess the impact of this change,
and in particular to make sure that Luc Maranget had properly reviewed
this code -- any change to the pattern-matching machinery should be
reviewed by Luc.
The problem that I had not foreseen and that he would have immediately
realized is that, while adapting the pattern-matching *compiler* is
relatively easy (Thomas inserted a transformation at the right place
to separate exception patterns from the others and handle them
separately, using the staticraise construct used by the
pattern-matching compiler to avoid duplicating the
right-hand-side branch), adapting the pattern-matching warnings
machinery is both more subtle and easier to overlook (it may fail
silently and nobody notices, unlike wrong code production). This part
of the compiler is subtle and best understood by Luc, but he does not
have the time to do a proper review of those changes in the timeframe
for the 4.03 feature freeze (mid-December).
I believe the right move in this case, implemented in the present
commit, is to revert the change from trunk (this is not a feature that
we must *imperatively* have in 4.03), do a proper job of understanding
the changes, and integrate the change when we are confident it is
ready. I hope to do this in 2016, together with Luc Maranget and
Thomas Refis -- hopefully this would allow Thomas and I to be more
confident when changing the pattern-matching machinery in the future.
Revert "Merge pull request #343 from trefis/pr7083"
This reverts commit 22681b8d2a56b308673b58fba1a06781bfc6d4b6, reversing
changes made to a24e4edf0a37d78abc1046cc453b84625b1521b5.
Revert "Merge pull request #341 from trefis/or-exception"
This reverts commit f8f68bd329375fd61e33781f61deeaeec2733f4b, reversing
changes made to 1534fe8082f6edd68be3fb960606a0e2fa87a116.
Revert "Merge pull request #305 from trefis/or-exception"
This reverts commit cfeda89396c67656d61ee24509278e50cb6e36e6, reversing
changes made to 77cf36cf82e3fb87469138c5da8f4ca9774414ff.
2015-12-12 01:52:33 -08:00
|
|
|
| Tpat_lazy p
|
2012-05-30 07:52:37 -07:00
|
|
|
->
|
2008-07-09 06:03:38 -07:00
|
|
|
collect_paths_from_pat r p
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2006-09-21 07:54:54 -07:00
|
|
|
|
|
|
|
(*
|
|
|
|
Actual fragile check
|
|
|
|
1. Collect data types in the patterns of the match.
|
2017-08-10 03:59:23 -07:00
|
|
|
2. One exhaustivity check per datatype, considering that
|
2006-09-21 07:54:54 -07:00
|
|
|
the type is extended.
|
2003-05-02 02:57:53 -07:00
|
|
|
*)
|
|
|
|
|
2017-07-07 05:11:15 -07:00
|
|
|
let do_check_fragile loc casel pss =
|
2006-09-21 07:54:54 -07:00
|
|
|
let exts =
|
|
|
|
List.fold_left
|
2013-04-15 09:23:22 -07:00
|
|
|
(fun r c -> collect_paths_from_pat r c.c_lhs)
|
2006-09-21 07:54:54 -07:00
|
|
|
[] casel in
|
|
|
|
match exts with
|
|
|
|
| [] -> ()
|
|
|
|
| _ -> match pss with
|
|
|
|
| [] -> ()
|
|
|
|
| ps::_ ->
|
|
|
|
List.iter
|
|
|
|
(fun ext ->
|
2020-04-26 00:37:24 -07:00
|
|
|
let witnesses = exhaust (Some ext) pss (List.length ps) in
|
|
|
|
match witnesses () with
|
|
|
|
| Seq.Nil ->
|
2006-09-21 07:54:54 -07:00
|
|
|
Location.prerr_warning
|
|
|
|
loc
|
|
|
|
(Warnings.Fragile_match (Path.name ext))
|
2020-04-26 00:37:24 -07:00
|
|
|
| Seq.Cons _ -> ())
|
2006-09-21 07:54:54 -07:00
|
|
|
exts
|
|
|
|
|
|
|
|
(********************************)
|
|
|
|
(* Exported unused clause check *)
|
|
|
|
(********************************)
|
2003-05-02 02:57:53 -07:00
|
|
|
|
2016-03-09 02:40:16 -08:00
|
|
|
let check_unused pred casel =
|
2020-07-10 11:00:02 -07:00
|
|
|
if Warnings.is_active Warnings.Redundant_case
|
2015-10-15 17:13:40 -07:00
|
|
|
|| List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
|
2002-09-30 07:23:00 -07:00
|
|
|
let rec do_rec pref = function
|
|
|
|
| [] -> ()
|
2015-10-14 18:55:52 -07:00
|
|
|
| {c_lhs=q; c_guard; c_rhs} :: rem ->
|
2002-09-30 07:23:00 -07:00
|
|
|
let qs = [q] in
|
|
|
|
begin try
|
2004-01-09 05:12:17 -08:00
|
|
|
let pss =
|
parmatch: ensure specialized submatrices are in source order
We produce exhaustivity counter-example in the order of the
specialized submatrices. Having submatrices in source order gives the
nice behavior that the clause that would naturally been inserted first
in the source is given first as a counter-example.
Consider for example:
function
| true, true -> true
| false, false -> false
The two counter-examples are (true, false) and (false, true).
Before this patch, (false, true) would be shown first.
After this patch, (true, false) is shown first.
This corresponds to the following natural completion order:
function
| true, true -> true
| true, false -> ?
| false, false -> false
| false, true -> ?
On the other hand, the ordering of the default submatrix, with respect
to the specialized submatrices, is not preserved -- it is always
ordered last.
One could intuitively expect the default submatrix to appear in the
position of the first omega row in the source. We tried this, and
it is not a good idea:
- the change is much more invasive as the interface of
`build_specialized_submatrices` has to change
- the behavior of the result is in fact unpleasant; it is not
intuitive to order counter-examples in this way.
For example, consider:
function
| _, None -> false
| true, Some true -> false
The two exhaustivity counter-examples are (true, Some false)
and (false, Some _). The second comes from the default submatrix:
morally it is (_, Some _), with "some other constructor missing from
the column" instead of the first _. There is no reason to suppose that
the user would want to place this (_, Some _) or (false, Some _)
counter-example first in the completed code; indeed, this intuition
would suggest writing an exhaustive covering of patterns of the
form (_, foo), inserted after the first clause, but then the other
clauses below become unnecessary!
When an omega patterns appears high in the column like this, it is
usually because there is a very specific matching condition to the
rest of its row, that justifies some shortcutting behavior. The
program is typically *not* completed by adding more specific matching
conditions.
2020-05-24 09:43:36 -07:00
|
|
|
(* prev was accumulated in reverse order;
|
|
|
|
restore source order to get ordered counter-examples *)
|
|
|
|
List.rev pref
|
|
|
|
|> List.filter (compats qs)
|
|
|
|
|> get_mins le_pats in
|
2015-09-02 01:53:47 -07:00
|
|
|
(* First look for redundant or partially redundant patterns *)
|
2002-09-30 07:23:00 -07:00
|
|
|
let r = every_satisfiables (make_rows pss) (make_row qs) in
|
2015-10-15 17:13:40 -07:00
|
|
|
let refute = (c_rhs.exp_desc = Texp_unreachable) in
|
2015-11-25 22:01:58 -08:00
|
|
|
(* Do not warn for unused [pat -> .] *)
|
|
|
|
if r = Unused && refute then () else
|
2015-09-02 01:53:47 -07:00
|
|
|
let r =
|
2017-07-15 10:11:59 -07:00
|
|
|
(* Do not refine if either:
|
|
|
|
- we already know the clause is unused
|
|
|
|
- the clause under consideration is not a refutation clause
|
|
|
|
and either:
|
|
|
|
+ there are no other lines
|
2017-08-12 13:24:41 -07:00
|
|
|
+ we do not care whether the types prevent this clause to
|
|
|
|
be reached.
|
2017-07-15 10:11:59 -07:00
|
|
|
If the clause under consideration *is* a refutation clause
|
|
|
|
then we do need to check more carefully whether it can be
|
|
|
|
refuted or not. *)
|
2015-10-15 08:39:59 -07:00
|
|
|
let skip =
|
2015-11-20 21:26:04 -08:00
|
|
|
r = Unused || (not refute && pref = []) ||
|
2015-10-15 08:39:59 -07:00
|
|
|
not(refute || Warnings.is_active Warnings.Unreachable_case) in
|
|
|
|
if skip then r else
|
2015-09-02 01:53:47 -07:00
|
|
|
(* Then look for empty patterns *)
|
2017-07-15 09:55:26 -07:00
|
|
|
let sfs = list_satisfying_vectors pss qs in
|
2015-09-02 01:53:47 -07:00
|
|
|
if sfs = [] then Unused else
|
|
|
|
let sfs =
|
|
|
|
List.map (function [u] -> u | _ -> assert false) sfs in
|
|
|
|
let u = orify_many sfs in
|
2015-09-02 03:03:02 -07:00
|
|
|
(*Format.eprintf "%a@." pretty_val u;*)
|
2015-09-02 01:53:47 -07:00
|
|
|
let (pattern,constrs,labels) = Conv.conv u in
|
2015-10-14 18:55:52 -07:00
|
|
|
let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in
|
2015-10-15 08:39:59 -07:00
|
|
|
match pred refute constrs labels pattern with
|
|
|
|
None when not refute ->
|
|
|
|
Location.prerr_warning q.pat_loc Warnings.Unreachable_case;
|
|
|
|
Used
|
|
|
|
| _ -> r
|
2015-09-02 01:53:47 -07:00
|
|
|
in
|
2002-09-30 07:23:00 -07:00
|
|
|
match r with
|
|
|
|
| Unused ->
|
|
|
|
Location.prerr_warning
|
2020-07-10 11:00:02 -07:00
|
|
|
q.pat_loc Warnings.Redundant_case
|
2002-09-30 07:23:00 -07:00
|
|
|
| Upartial ps ->
|
|
|
|
List.iter
|
|
|
|
(fun p ->
|
|
|
|
Location.prerr_warning
|
2020-07-10 11:00:56 -07:00
|
|
|
p.pat_loc Warnings.Redundant_subpat)
|
2002-09-30 07:23:00 -07:00
|
|
|
ps
|
2006-09-21 07:54:54 -07:00
|
|
|
| Used -> ()
|
2017-07-12 07:15:04 -07:00
|
|
|
with Empty | Not_found -> assert false
|
2002-09-30 07:23:00 -07:00
|
|
|
end ;
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2013-04-15 09:23:22 -07:00
|
|
|
if c_guard <> None then
|
2002-09-30 07:23:00 -07:00
|
|
|
do_rec pref rem
|
2002-09-25 09:37:04 -07:00
|
|
|
else
|
2006-09-21 07:54:54 -07:00
|
|
|
do_rec ([q]::pref) rem in
|
2002-09-30 07:23:00 -07:00
|
|
|
|
|
|
|
do_rec [] casel
|
2008-06-16 02:08:55 -07:00
|
|
|
|
2008-07-09 06:03:38 -07:00
|
|
|
(*********************************)
|
|
|
|
(* Exported irrefutability tests *)
|
|
|
|
(*********************************)
|
2008-06-16 02:08:55 -07:00
|
|
|
|
|
|
|
let irrefutable pat = le_pat pat omega
|
2008-07-09 06:03:38 -07:00
|
|
|
|
2017-08-25 11:07:18 -07:00
|
|
|
let inactive ~partial pat =
|
|
|
|
match partial with
|
|
|
|
| Partial -> false
|
|
|
|
| Total -> begin
|
|
|
|
let rec loop pat =
|
|
|
|
match pat.pat_desc with
|
|
|
|
| Tpat_lazy _ | Tpat_array _ ->
|
|
|
|
false
|
|
|
|
| Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) ->
|
|
|
|
true
|
|
|
|
| Tpat_constant c -> begin
|
|
|
|
match c with
|
|
|
|
| Const_string _ -> Config.safe_string
|
|
|
|
| Const_int _ | Const_char _ | Const_float _
|
|
|
|
| Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
|
|
|
|
end
|
|
|
|
| Tpat_tuple ps | Tpat_construct (_, _, ps) ->
|
|
|
|
List.for_all (fun p -> loop p) ps
|
|
|
|
| Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
|
|
|
|
loop p
|
|
|
|
| Tpat_record (ldps,_) ->
|
|
|
|
List.for_all
|
|
|
|
(fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p)
|
|
|
|
ldps
|
|
|
|
| Tpat_or (p,q,_) ->
|
|
|
|
loop p && loop q
|
|
|
|
in
|
|
|
|
loop pat
|
|
|
|
end
|
2012-05-30 07:52:37 -07:00
|
|
|
|
2010-10-15 23:09:25 -07:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2017-08-10 03:59:23 -07:00
|
|
|
(*********************************)
|
|
|
|
(* Exported exhaustiveness check *)
|
|
|
|
(*********************************)
|
2010-10-15 23:09:25 -07:00
|
|
|
|
|
|
|
(*
|
|
|
|
Fragile check is performed when required and
|
|
|
|
on exhaustive matches only.
|
|
|
|
*)
|
|
|
|
|
2017-07-07 05:11:15 -07:00
|
|
|
let check_partial pred loc casel =
|
|
|
|
let pss = initial_matrix casel in
|
|
|
|
let pss = get_mins le_pats pss in
|
|
|
|
let total = do_check_partial ~pred loc casel pss in
|
|
|
|
if
|
|
|
|
total = Total && Warnings.is_active (Warnings.Fragile_match "")
|
|
|
|
then begin
|
|
|
|
do_check_fragile loc casel pss
|
|
|
|
end ;
|
|
|
|
total
|
2015-12-04 06:44:53 -08:00
|
|
|
|
|
|
|
(*************************************)
|
|
|
|
(* Ambiguous variable in or-patterns *)
|
|
|
|
(*************************************)
|
|
|
|
|
2015-12-10 11:19:58 -08:00
|
|
|
(* Specification: ambiguous variables in or-patterns.
|
|
|
|
|
|
|
|
The semantics of or-patterns in OCaml is specified with
|
|
|
|
a left-to-right bias: a value [v] matches the pattern [p | q] if it
|
|
|
|
matches [p] or [q], but if it matches both, the environment
|
|
|
|
captured by the match is the environment captured by [p], never the
|
|
|
|
one captured by [q].
|
|
|
|
|
|
|
|
While this property is generally well-understood, one specific case
|
|
|
|
where users expect a different semantics is when a pattern is
|
|
|
|
followed by a when-guard: [| p when g -> e]. Consider for example:
|
|
|
|
|
|
|
|
| ((Const x, _) | (_, Const x)) when is_neutral x -> branch
|
|
|
|
|
|
|
|
The semantics is clear: match the scrutinee against the pattern, if
|
|
|
|
it matches, test the guard, and if the guard passes, take the
|
|
|
|
branch.
|
|
|
|
|
|
|
|
However, consider the input [(Const a, Const b)], where [a] fails
|
|
|
|
the test [is_neutral f], while [b] passes the test [is_neutral
|
|
|
|
b]. With the left-to-right semantics, the clause above is *not*
|
|
|
|
taken by its input: matching [(Const a, Const b)] against the
|
|
|
|
or-pattern succeeds in the left branch, it returns the environment
|
|
|
|
[x -> a], and then the guard [is_neutral a] is tested and fails,
|
|
|
|
the branch is not taken. Most users, however, intuitively expect
|
|
|
|
that any pair that has one side passing the test will take the
|
|
|
|
branch. They assume it is equivalent to the following:
|
|
|
|
|
|
|
|
| (Const x, _) when is_neutral x -> branch
|
|
|
|
| (_, Const x) when is_neutral x -> branch
|
|
|
|
|
|
|
|
while it is not.
|
|
|
|
|
|
|
|
The code below is dedicated to finding these confusing cases: the
|
|
|
|
cases where a guard uses "ambiguous" variables, that are bound to
|
|
|
|
different parts of the scrutinees by different sides of
|
|
|
|
a or-pattern. In other words, it finds the cases where the
|
|
|
|
specified left-to-right semantics is not equivalent to
|
|
|
|
a non-deterministic semantics (any branch can be taken) relatively
|
|
|
|
to a specific guard.
|
|
|
|
*)
|
|
|
|
|
2018-01-30 09:30:11 -08:00
|
|
|
let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p)
|
2015-12-04 06:44:53 -08:00
|
|
|
|
|
|
|
(* Row for ambiguous variable search,
|
2016-06-15 12:48:46 -07:00
|
|
|
row is the traditional pattern row,
|
|
|
|
varsets contain a list of head variable sets (varsets)
|
|
|
|
|
|
|
|
A given varset contains all the variables that appeared at the head
|
|
|
|
of a pattern in the row at some point during traversal: they would
|
|
|
|
all be bound to the same value at matching time. On the contrary,
|
|
|
|
two variables of different varsets appeared at different places in
|
|
|
|
the pattern and may be bound to distinct sub-parts of the matched
|
|
|
|
value.
|
|
|
|
|
|
|
|
All rows of a (sub)matrix have rows of the same length,
|
|
|
|
but also varsets of the same length.
|
|
|
|
|
2018-01-01 01:03:34 -08:00
|
|
|
Varsets are populated when simplifying the first column
|
|
|
|
-- the variables of the head pattern are collected in a new varset.
|
2016-06-15 12:48:46 -07:00
|
|
|
For example,
|
|
|
|
{ row = x :: r1; varsets = s1 }
|
|
|
|
{ row = (Some _) as y :: r2; varsets = s2 }
|
|
|
|
{ row = (None as x) as y :: r3; varsets = s3 }
|
|
|
|
{ row = (Some x | (None as x)) :: r4 with varsets = s4 }
|
|
|
|
becomes
|
|
|
|
(_, { row = r1; varsets = {x} :: s1 })
|
|
|
|
(Some _, { row = r2; varsets = {y} :: s2 })
|
2018-01-01 01:03:34 -08:00
|
|
|
(None, { row = r3; varsets = {x, y} :: s3 })
|
2016-06-15 12:48:46 -07:00
|
|
|
(Some x, { row = r4; varsets = {} :: s4 })
|
|
|
|
(None, { row = r4; varsets = {x} :: s4 })
|
2018-01-01 01:03:34 -08:00
|
|
|
*)
|
2018-01-30 09:30:11 -08:00
|
|
|
type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
|
2015-12-04 06:44:53 -08:00
|
|
|
|
2018-01-19 11:38:56 -08:00
|
|
|
let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
|
|
|
|
let rec simpl head_bound_variables varsets p ps k =
|
2019-09-10 00:15:13 -07:00
|
|
|
match (Patterns.General.view p).pat_desc with
|
|
|
|
| `Alias (p,x,_) ->
|
2018-01-30 09:30:11 -08:00
|
|
|
simpl (Ident.Set.add x head_bound_variables) varsets p ps k
|
2019-09-10 00:15:13 -07:00
|
|
|
| `Var (x, _) ->
|
2020-05-15 12:16:19 -07:00
|
|
|
simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k
|
2019-09-10 00:15:13 -07:00
|
|
|
| `Or (p1,p2,_) ->
|
2018-01-19 11:38:56 -08:00
|
|
|
simpl head_bound_variables varsets p1 ps
|
|
|
|
(simpl head_bound_variables varsets p2 ps k)
|
2019-09-10 00:15:13 -07:00
|
|
|
| #Patterns.Simple.view as view ->
|
|
|
|
add_column (Patterns.Head.deconstruct { p with pat_desc = view })
|
2019-06-13 10:25:10 -07:00
|
|
|
{ row = ps; varsets = head_bound_variables :: varsets; } k
|
2018-01-19 11:38:56 -08:00
|
|
|
in simpl head_bound_variables varsets p ps k
|
|
|
|
|
2018-01-01 01:03:34 -08:00
|
|
|
(*
|
|
|
|
To accurately report ambiguous variables, one must consider
|
|
|
|
that previous clauses have already matched some values.
|
|
|
|
Consider for example:
|
|
|
|
|
|
|
|
| (Foo x, Foo y) -> ...
|
|
|
|
| ((Foo x, _) | (_, Foo x)) when bar x -> ...
|
|
|
|
|
|
|
|
The second line taken in isolation uses an unstable variable,
|
|
|
|
but the discriminating values, of the shape [(Foo v1, Foo v2)],
|
|
|
|
would all be filtered by the line above.
|
|
|
|
|
|
|
|
To track this information, the matrices we analyze contain both
|
|
|
|
*positive* rows, that describe the rows currently being analyzed
|
|
|
|
(of type Varsets.row, so that their varsets are tracked) and
|
|
|
|
*negative rows*, that describe the cases already matched against.
|
|
|
|
|
|
|
|
The values matched by a signed matrix are the values matched by
|
|
|
|
some of the positive rows but none of the negative rows. In
|
|
|
|
particular, a variable is stable if, for any value not matched by
|
|
|
|
any of the negative rows, the environment captured by any of the
|
|
|
|
matching positive rows is identical.
|
|
|
|
*)
|
|
|
|
type ('a, 'b) signed = Positive of 'a | Negative of 'b
|
|
|
|
|
2018-01-03 07:55:28 -08:00
|
|
|
let rec simplify_first_amb_col = function
|
2016-06-15 12:48:46 -07:00
|
|
|
| [] -> []
|
2018-01-01 01:03:34 -08:00
|
|
|
| (Negative [] | Positive { row = []; _ }) :: _ -> assert false
|
|
|
|
| Negative (n :: ns) :: rem ->
|
2018-01-19 11:38:56 -08:00
|
|
|
let add_column n ns k = (n, Negative ns) :: k in
|
|
|
|
simplify_head_pat
|
|
|
|
~add_column n ns (simplify_first_amb_col rem)
|
2018-01-01 01:03:34 -08:00
|
|
|
| Positive { row = p::ps; varsets; }::rem ->
|
2018-01-19 11:38:56 -08:00
|
|
|
let add_column p ps k = (p, Positive ps) :: k in
|
|
|
|
simplify_head_amb_pat
|
2018-01-30 09:30:11 -08:00
|
|
|
Ident.Set.empty varsets
|
2018-01-19 11:38:56 -08:00
|
|
|
~add_column p ps (simplify_first_amb_col rem)
|
2015-12-04 06:44:53 -08:00
|
|
|
|
2017-12-18 09:02:39 -08:00
|
|
|
(* Compute stable bindings *)
|
2015-12-10 11:19:58 -08:00
|
|
|
|
2017-12-18 09:02:39 -08:00
|
|
|
type stable_vars =
|
|
|
|
| All
|
2018-01-30 09:30:11 -08:00
|
|
|
| Vars of Ident.Set.t
|
2017-12-18 09:02:39 -08:00
|
|
|
|
|
|
|
let stable_inter sv1 sv2 = match sv1, sv2 with
|
|
|
|
| All, sv | sv, All -> sv
|
2018-01-30 09:30:11 -08:00
|
|
|
| Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2)
|
2015-12-04 06:44:53 -08:00
|
|
|
|
2016-06-15 12:48:46 -07:00
|
|
|
let reduce f = function
|
|
|
|
| [] -> invalid_arg "reduce"
|
|
|
|
| x::xs -> List.fold_left f x xs
|
2015-12-04 06:44:53 -08:00
|
|
|
|
2018-01-01 01:03:34 -08:00
|
|
|
let rec matrix_stable_vars m = match m with
|
|
|
|
| [] -> All
|
|
|
|
| ((Positive {row = []; _} | Negative []) :: _) as empty_rows ->
|
|
|
|
let exception Negative_empty_row in
|
|
|
|
(* if at least one empty row is negative, the matrix matches no value *)
|
|
|
|
let get_varsets = function
|
|
|
|
| Negative n ->
|
|
|
|
(* All rows have the same number of columns;
|
|
|
|
if the first row is empty, they all are. *)
|
|
|
|
assert (n = []);
|
|
|
|
raise Negative_empty_row
|
|
|
|
| Positive p ->
|
|
|
|
assert (p.row = []);
|
|
|
|
p.varsets in
|
|
|
|
begin match List.map get_varsets empty_rows with
|
|
|
|
| exception Negative_empty_row -> All
|
|
|
|
| rows_varsets ->
|
|
|
|
let stables_in_varsets =
|
2018-01-30 09:30:11 -08:00
|
|
|
reduce (List.map2 Ident.Set.inter) rows_varsets in
|
2018-01-01 01:03:34 -08:00
|
|
|
(* The stable variables are those stable at any position *)
|
2018-01-30 09:30:11 -08:00
|
|
|
Vars
|
|
|
|
(List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets)
|
2018-01-01 01:03:34 -08:00
|
|
|
end
|
|
|
|
| m ->
|
2018-01-03 13:43:42 -08:00
|
|
|
let is_negative = function
|
|
|
|
| Negative _ -> true
|
|
|
|
| Positive _ -> false in
|
|
|
|
if List.for_all is_negative m then
|
|
|
|
(* optimization: quit early if there are no positive rows.
|
|
|
|
This may happen often when the initial matrix has many
|
|
|
|
negative cases and few positive cases (a small guarded
|
|
|
|
clause after a long list of clauses) *)
|
|
|
|
All
|
2018-01-01 01:03:34 -08:00
|
|
|
else begin
|
2018-01-03 13:43:42 -08:00
|
|
|
let m = simplify_first_amb_col m in
|
2018-01-05 10:42:35 -08:00
|
|
|
if not (all_coherent (first_column m)) then
|
|
|
|
All
|
2018-01-03 13:43:42 -08:00
|
|
|
else begin
|
|
|
|
(* If the column is ill-typed but deemed coherent, we might
|
|
|
|
spuriously warn about some variables being unstable.
|
|
|
|
As sad as that might be, the warning can be silenced by
|
|
|
|
splitting the or-pattern... *)
|
|
|
|
let submatrices =
|
|
|
|
let extend_row columns = function
|
|
|
|
| Negative r -> Negative (columns @ r)
|
|
|
|
| Positive r -> Positive { r with row = columns @ r.row } in
|
2019-09-10 00:15:13 -07:00
|
|
|
let q0 = discr_pat Patterns.Simple.omega m in
|
2018-01-03 13:43:42 -08:00
|
|
|
let { default; constrs } =
|
|
|
|
build_specialized_submatrices ~extend_row q0 m in
|
|
|
|
let non_default = List.map snd constrs in
|
2018-01-05 10:48:32 -08:00
|
|
|
if full_match false constrs
|
2018-01-03 13:43:42 -08:00
|
|
|
then non_default
|
|
|
|
else default :: non_default in
|
|
|
|
(* A stable variable must be stable in each submatrix. *)
|
2018-01-03 06:00:47 -08:00
|
|
|
let submat_stable = List.map matrix_stable_vars submatrices in
|
|
|
|
List.fold_left stable_inter All submat_stable
|
2018-01-03 13:43:42 -08:00
|
|
|
end
|
2018-01-01 01:03:34 -08:00
|
|
|
end
|
2016-06-15 12:48:46 -07:00
|
|
|
|
2018-01-01 01:03:34 -08:00
|
|
|
let pattern_stable_vars ns p =
|
|
|
|
matrix_stable_vars
|
|
|
|
(List.fold_left (fun m n -> Negative n :: m)
|
|
|
|
[Positive {varsets = []; row = [p]}] ns)
|
2015-12-04 06:44:53 -08:00
|
|
|
|
2015-12-10 07:27:28 -08:00
|
|
|
(* All identifier paths that appear in an expression that occurs
|
|
|
|
as a clause right hand side or guard.
|
2015-12-04 06:44:53 -08:00
|
|
|
|
2015-12-10 07:27:28 -08:00
|
|
|
The function is rather complex due to the compilation of
|
|
|
|
unpack patterns by introducing code in rhs expressions
|
|
|
|
and **guards**.
|
|
|
|
|
|
|
|
For pattern (module M:S) -> e the code is
|
|
|
|
let module M_mod = unpack M .. in e
|
|
|
|
|
|
|
|
Hence M is "free" in e iff M_mod is free in e.
|
|
|
|
|
|
|
|
Not doing so will yield excessive warning in
|
|
|
|
(module (M:S) } ...) when true -> ....
|
2016-01-19 14:40:09 -08:00
|
|
|
as M is always present in
|
|
|
|
let module M_mod = unpack M .. in true
|
2015-12-04 06:44:53 -08:00
|
|
|
*)
|
2015-12-10 07:27:28 -08:00
|
|
|
|
|
|
|
let all_rhs_idents exp =
|
2018-01-30 09:30:11 -08:00
|
|
|
let ids = ref Ident.Set.empty in
|
2015-12-10 07:27:28 -08:00
|
|
|
(* Very hackish, detect unpack pattern compilation
|
2017-08-10 03:59:23 -07:00
|
|
|
and perform "indirect check for them" *)
|
2019-03-23 19:12:12 -07:00
|
|
|
let is_unpack exp =
|
2015-12-10 07:27:28 -08:00
|
|
|
List.exists
|
2018-07-21 05:04:53 -07:00
|
|
|
(fun attr -> attr.Parsetree.attr_name.txt = "#modulepat")
|
2019-03-23 19:12:12 -07:00
|
|
|
exp.exp_attributes in
|
2019-03-24 10:05:49 -07:00
|
|
|
let open Tast_iterator in
|
2019-03-23 19:12:12 -07:00
|
|
|
let expr_iter iter exp =
|
|
|
|
(match exp.exp_desc with
|
|
|
|
| Texp_ident (path, _lid, _descr) ->
|
|
|
|
List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path)
|
|
|
|
(* Use default iterator methods for rest of match.*)
|
|
|
|
| _ -> Tast_iterator.default_iterator.expr iter exp);
|
|
|
|
|
|
|
|
if is_unpack exp then begin match exp.exp_desc with
|
|
|
|
| Texp_letmodule
|
|
|
|
(id_mod,_,_,
|
|
|
|
{mod_desc=
|
|
|
|
Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
|
|
|
|
_) ->
|
|
|
|
assert (Ident.Set.mem id_exp !ids) ;
|
2019-10-09 06:15:37 -07:00
|
|
|
begin match id_mod with
|
|
|
|
| Some id_mod when not (Ident.Set.mem id_mod !ids) ->
|
2019-03-23 19:12:12 -07:00
|
|
|
ids := Ident.Set.remove id_exp !ids
|
2019-10-09 06:15:37 -07:00
|
|
|
| _ -> ()
|
2019-03-23 19:12:12 -07:00
|
|
|
end
|
|
|
|
| _ -> assert false
|
2019-03-25 13:50:11 -07:00
|
|
|
end
|
2019-03-23 19:12:12 -07:00
|
|
|
in
|
|
|
|
let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in
|
2019-03-23 18:26:58 -07:00
|
|
|
iterator.expr iterator exp;
|
2015-12-04 06:44:53 -08:00
|
|
|
!ids
|
|
|
|
|
|
|
|
let check_ambiguous_bindings =
|
|
|
|
let open Warnings in
|
2020-07-10 09:07:16 -07:00
|
|
|
let warn0 = Ambiguous_var_in_pattern_guard [] in
|
2015-12-04 06:44:53 -08:00
|
|
|
fun cases ->
|
|
|
|
if is_active warn0 then
|
2018-01-01 01:03:34 -08:00
|
|
|
let check_case ns case = match case with
|
|
|
|
| { c_lhs = p; c_guard=None ; _} -> [p]::ns
|
2015-12-04 06:44:53 -08:00
|
|
|
| { c_lhs=p; c_guard=Some g; _} ->
|
|
|
|
let all =
|
2018-01-30 09:30:11 -08:00
|
|
|
Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in
|
|
|
|
if not (Ident.Set.is_empty all) then begin
|
2018-01-01 01:03:34 -08:00
|
|
|
match pattern_stable_vars ns p with
|
2017-12-18 09:02:39 -08:00
|
|
|
| All -> ()
|
|
|
|
| Vars stable ->
|
2018-01-30 09:30:11 -08:00
|
|
|
let ambiguous = Ident.Set.diff all stable in
|
|
|
|
if not (Ident.Set.is_empty ambiguous) then begin
|
|
|
|
let pps =
|
|
|
|
Ident.Set.elements ambiguous |> List.map Ident.name in
|
2020-07-10 09:07:16 -07:00
|
|
|
let warn = Ambiguous_var_in_pattern_guard pps in
|
2017-12-18 09:02:39 -08:00
|
|
|
Location.prerr_warning p.pat_loc warn
|
|
|
|
end
|
2018-01-01 01:03:34 -08:00
|
|
|
end;
|
|
|
|
ns
|
|
|
|
in
|
|
|
|
ignore (List.fold_left check_case [] cases)
|