Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

matching: use pattern views in Parmatch as well

master
Gabriel Scherer 2019-09-10 09:15:13 +02:00
parent e19a3afcb4
commit 68dc87c9e9
5 changed files with 163 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
lambda/matching.ml
View File

@ -142,19 +142,13 @@ let all_record_args lbls =
List.iter (fun ((_, lbl, _) as x) -> t.(lbl.lbl_pos) <- x) lbls;
Array.to_list t
let rec expand_record p =
match p.pat_desc with
| Tpat_record (l, _) ->
{ p with pat_desc = Tpat_record (all_record_args l, Closed) }
| Tpat_alias (p, _, _) -> expand_record p
| _ -> p
let expand_record_head head =
match head.pat_desc with
| Patterns.Head.Record _ ->
head |> Patterns.Head.to_omega_pattern |> expand_record
|> Patterns.Head.deconstruct |> fst
| _ -> head
let expand_record_head h =
let open Patterns.Head in
match h.pat_desc with
| Record [] -> fatal_error "Matching.expand_record_head"
| Record ({ lbl_all } :: _) ->
{ h with pat_desc = Record (Array.to_list lbl_all) }
| _ -> h
let head_loc ~scopes head =
Scoped_location.of_location ~scopes head.pat_loc
@ -277,7 +271,7 @@ end = struct
type nonrec clause = pattern Non_empty_row.t clause
let head p = fst (Patterns.Head.deconstruct (Patterns.General.erase p))
let head p = fst (Patterns.Head.deconstruct p)
let alpha env (p : pattern) : pattern =
let alpha_pat env p = Typedtree.alpha_pat env p in
@ -359,7 +353,7 @@ let matcher discr (p : Simple.pattern) rem =
let discr = expand_record_head discr in
let p = expand_record_simple p in
let omegas = Patterns.(omegas (Head.arity discr)) in
let ph, args = Patterns.Head.deconstruct (General.erase p) in
let ph, args = Patterns.Head.deconstruct p in
let yes () = args @ rem in
let no () = raise NoMatch in
let yesif b =
@ -2505,8 +2499,9 @@ let rec list_as_pat = function
let complete_pats_constrs = function
| p :: _ as pats ->
let p_simple = General.(view p |> assert_simple) in
List.map (pat_of_constr p)
(complete_constrs p (List.map get_key_constr pats))
(complete_constrs p_simple (List.map get_key_constr pats))
| _ -> assert false
(*

246
typing/parmatch.ml
View File

@ -563,13 +563,10 @@ and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r
*)
let simplify_head_pat ~add_column p ps k =
let rec simplify_head_pat p ps k =
match p.pat_desc with
| Tpat_alias (p,_,_) ->
(* We have to handle aliases here, because there can be or-patterns
underneath, that [Patterns.Head.deconstruct] won't handle. *)
simplify_head_pat p ps k
| Tpat_or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
| _ -> add_column (Patterns.Head.deconstruct p) ps k
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
in simplify_head_pat p ps k
let rec simplify_first_col = function
@ -694,7 +691,7 @@ let build_specialized_submatrices ~extend_row discr rows =
let set_last a =
let rec loop = function
| [] -> assert false
| [_] -> [a]
| [_] -> [Patterns.General.erase a]
| x::l -> x :: loop l
in
function
@ -703,7 +700,7 @@ let set_last a =
(* mark constructor lines for failure when they are incomplete *)
let mark_partial =
let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty in
let zero = make_pat (`Constant (Const_int 0)) Ctype.none Env.empty in
List.map (fun ((hp, _), _ as ps) ->
match hp.pat_desc with
| Patterns.Head.Any -> ps
@ -1112,39 +1109,40 @@ let rec satisfiable pss qs = match pss with
| _ ->
match qs with
| [] -> false
| {pat_desc = Tpat_or(q1,q2,_)}::qs ->
satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
| {pat_desc = Tpat_alias(q,_,_)}::qs ->
satisfiable pss (q::qs)
| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
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 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
| {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
| q::qs ->
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
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
(* While [satisfiable] only checks whether the last row of [pss + qs] is
satisfiable, this function returns the (possibly empty) list of vectors [es]
@ -1162,53 +1160,54 @@ let rec list_satisfying_vectors pss qs =
| _ ->
match qs with
| [] -> []
| {pat_desc = Tpat_or(q1,q2,_)}::qs ->
list_satisfying_vectors pss (q1::qs) @
list_satisfying_vectors pss (q2::qs)
| {pat_desc = Tpat_alias(q,_,_)}::qs ->
list_satisfying_vectors pss (q::qs)
| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
let pss = simplify_first_col pss in
if not (all_coherent (first_column pss)) then
[]
else begin
let q0 = discr_pat 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 _ ->
(* activate this code for checking non-gadt constructors *)
wild default (build_other_constrs constrs p)
@ for_constrs ()
| _ ->
wild default Patterns.omega
end
| 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 _ ->
(* activate this code for checking non-gadt constructors *)
wild default (build_other_constrs constrs p)
@ for_constrs ()
| _ ->
wild default Patterns.omega
end
end
| {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
| q::qs ->
| `Variant (l, _, r) when is_absent l r -> []
| #Patterns.Simple.view as view ->
let q = { q with pat_desc = view } in
let hq, qargs = Patterns.Head.deconstruct q in
let pss = simplify_first_col pss in
if not (all_coherent (hq :: first_column pss)) then
@ -1237,19 +1236,17 @@ let rec do_match pss qs = match qs with
| []::_ -> true
| _ -> false
end
| q::qs -> match q with
| {pat_desc = Tpat_or (q1,q2,_)} ->
| q::qs -> match Patterns.General.(view q |> strip_vars).pat_desc with
| `Or (q1,q2,_) ->
do_match pss (q1::qs) || do_match pss (q2::qs)
| {pat_desc = Tpat_any} ->
| `Any ->
let rec remove_first_column = function
| (_::ps)::rem -> ps::remove_first_column rem
| _ -> []
in
do_match (remove_first_column pss) qs
| _ ->
(* [q] is generated by us, it doesn't come from the source. So we know
it's not of the form [P as name].
Therefore there is no risk of [deconstruct] raising. *)
| #Patterns.Simple.view as view ->
let q = { q with pat_desc = view } in
let q0, qargs = Patterns.Head.deconstruct q in
let pss = simplify_first_col pss in
(* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
@ -1323,7 +1320,7 @@ let rec exhaust (ext:Path.t option) pss n = match pss with
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 omega pss in
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 *)
@ -1403,7 +1400,7 @@ let rec pressure_variants tdefs = function
if not (all_coherent (first_column pss)) then
true
else begin
let q0 = discr_pat omega pss in
let q0 = discr_pat Patterns.Simple.omega pss in
match build_specialized_submatrices ~extend_row:(@) q0 pss with
| { default; constrs = [] } -> pressure_variants tdefs default
| { default; constrs } ->
@ -1494,15 +1491,10 @@ let make_row ps = {ors=[] ; no_ors=[]; active=ps}
let make_rows pss = List.map make_row pss
(* Useful to detect and expand or pats inside as pats *)
let rec unalias p = match p.pat_desc with
| Tpat_alias (p,_,_) -> unalias p
| _ -> p
let is_var p = match (unalias p).pat_desc with
| Tpat_any|Tpat_var _ -> true
| _ -> false
(* 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
let is_var_column rs =
List.for_all
@ -1616,41 +1608,41 @@ let rec every_satisfiables pss qs = match qs.active with
Used
end
| q::rem ->
let uq = unalias q in
begin match uq.pat_desc with
| Tpat_any | Tpat_var _ ->
begin match Patterns.General.(view q |> strip_vars).pat_desc with
| `Any ->
if is_var_column pss then
(* forget about ``all-variable'' columns now *)
(* forget about ``all-variable'' columns now *)
every_satisfiables (remove_column pss) (remove qs)
else
(* otherwise this is direct food for satisfiable *)
(* otherwise this is direct food for satisfiable *)
every_satisfiables (push_no_or_column pss) (push_no_or qs)
| Tpat_or (q1,q2,_) ->
| `Or (q1,q2,_) ->
if
q1.pat_loc.Location.loc_ghost &&
q2.pat_loc.Location.loc_ghost
then
(* syntactically generated or-pats should not be expanded *)
(* syntactically generated or-pats should not be expanded *)
every_satisfiables (push_no_or_column pss) (push_no_or qs)
else
(* this is a real or-pattern *)
(* this is a real or-pattern *)
every_satisfiables (push_or_column pss) (push_or qs)
| Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
| `Variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
Unused
| _ ->
(* standard case, filter matrix *)
| #Patterns.Simple.view as view ->
let q = { q with pat_desc = view } in
(* standard case, filter matrix *)
let pss = simplify_first_usefulness_col pss in
let huq, args = Patterns.Head.deconstruct uq in
let hq, args = Patterns.Head.deconstruct q in
(* The handling of incoherent matrices is kept in line with
[satisfiable] *)
if not (all_coherent (huq :: first_column pss)) then
if not (all_coherent (hq :: first_column pss)) then
Unused
else begin
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 }))
{qs with active=simple_match_args q0 huq args @ rem}
{qs with active=simple_match_args q0 hq args @ rem}
end
end
@ -2287,19 +2279,19 @@ type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
let rec simpl head_bound_variables varsets p ps k =
match p.pat_desc with
| Tpat_alias (p,x,_) ->
match (Patterns.General.view p).pat_desc with
| `Alias (p,x,_) ->
simpl (Ident.Set.add x head_bound_variables) varsets p ps k
| Tpat_var (x,_) ->
| `Var (x, _) ->
let rest_of_the_row =
{ row = ps; varsets = Ident.Set.add x head_bound_variables :: varsets; }
in
add_column (Patterns.Head.deconstruct omega) rest_of_the_row k
| Tpat_or (p1,p2,_) ->
add_column (Patterns.Head.deconstruct Patterns.Simple.omega) rest_of_the_row k
| `Or (p1,p2,_) ->
simpl head_bound_variables varsets p1 ps
(simpl head_bound_variables varsets p2 ps k)
| _ ->
add_column (Patterns.Head.deconstruct p)
| #Patterns.Simple.view as view ->
add_column (Patterns.Head.deconstruct { p with pat_desc = view })
{ row = ps; varsets = head_bound_variables :: varsets; } k
in simpl head_bound_variables varsets p ps k
@ -2401,7 +2393,7 @@ let rec matrix_stable_vars m = match m with
let extend_row columns = function
| Negative r -> Negative (columns @ r)
| Positive r -> Positive { r with row = columns @ r.row } in
let q0 = discr_pat omega m in
let q0 = discr_pat Patterns.Simple.omega m in
let { default; constrs } =
build_specialized_submatrices ~extend_row q0 m in
let non_default = List.map snd constrs in

2
typing/parmatch.mli
View File

@ -67,7 +67,7 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list
val pat_of_constr : pattern -> constructor_description -> pattern
val complete_constrs :
pattern -> constructor_tag list -> constructor_description list
Patterns.Simple.pattern -> constructor_tag list -> constructor_description list
(** [ppat_of_type] builds an untyped pattern from its expected type,
for explosion of wildcard patterns in Typecore.type_pat.

42
typing/patterns.ml
View File

@ -47,6 +47,8 @@ module Simple = struct
]
type pattern = view pattern_data
let omega = { omega with pat_desc = `Any }
end
module Half_simple = struct
@ -108,6 +110,17 @@ module General = struct
let erase p : Typedtree.pattern =
{ p with pat_desc = erase_desc p.pat_desc }
let rec strip_vars (p : pattern) : Half_simple.pattern =
match p.pat_desc with
| `Alias (p, _, _) -> strip_vars (view p)
| `Var _ -> { p with pat_desc = `Any }
| #Half_simple.view as view -> { p with pat_desc = view }
let assert_simple (p : pattern) : Simple.pattern =
match strip_vars p with
| {pat_desc = `Or _; _} -> failwith "Patterns.assert_simple"
| {pat_desc = #Simple.view; _} as p -> p
end
(* the head constructor of a simple pattern *)
@ -130,10 +143,8 @@ module Head : sig
val arity : t -> int
(** [deconstruct p] returns the head of [p] and the list of sub patterns.
@raises [Invalid_arg _] if [p] is an or-pattern. *)
val deconstruct : pattern -> t * pattern list
(** [deconstruct p] returns the head of [p] and the list of sub patterns. *)
val deconstruct : Simple.pattern -> t * pattern list
(** reconstructs a pattern, putting wildcards as sub-patterns. *)
val to_omega_pattern : t -> pattern
@ -157,17 +168,15 @@ end = struct
type t = desc pattern_data
let deconstruct q =
let rec deconstruct_desc = function
| Tpat_any
| Tpat_var _ -> Any, []
| Tpat_constant c -> Constant c, []
| Tpat_alias (p,_,_) -> deconstruct_desc p.pat_desc
| Tpat_tuple args ->
let deconstruct (q : Simple.pattern) =
let deconstruct_desc = function
| `Any -> Any, []
| `Constant c -> Constant c, []
| `Tuple args ->
Tuple (List.length args), args
| Tpat_construct (_, c, args) ->
| `Construct (_, c, args) ->
Construct c, args
| Tpat_variant (tag, arg, cstr_row) ->
| `Variant (tag, arg, cstr_row) ->
let has_arg, pats =
match arg with
| None -> false, []
@ -179,15 +188,14 @@ end = struct
| _ -> assert false
in
Variant {tag; has_arg; cstr_row; type_row}, pats
| Tpat_array args ->
| `Array args ->
Array (List.length args), args
| Tpat_record (largs, _) ->
| `Record (largs, _) ->
let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
let pats = List.map (fun (_,_,pat) -> pat) largs in
Record lbls, pats
| Tpat_lazy p ->
| `Lazy p ->
Lazy, [p]
| Tpat_or _ -> invalid_arg "Parmatch.Pattern_head.deconstruct: (P | Q)"
in
let desc, pats = deconstruct_desc q.pat_desc in
{ q with pat_desc = desc }, pats

8
typing/patterns.mli
View File

@ -34,6 +34,8 @@ module Simple : sig
| `Lazy of pattern
]
type pattern = view pattern_data
val omega : [> view ] pattern_data
end
module Half_simple : sig
@ -54,6 +56,10 @@ module General : sig
val view : Typedtree.pattern -> pattern
val erase : [< view ] pattern_data -> Typedtree.pattern
val strip_vars : pattern -> Half_simple.pattern
val assert_simple : pattern -> Simple.pattern
end
module Head : sig
@ -79,7 +85,7 @@ module Head : sig
(** [deconstruct p] returns the head of [p] and the list of sub patterns.
@raises [Invalid_arg _] if [p] is an or- or an exception-pattern. *)
val deconstruct : pattern -> t * pattern list
val deconstruct : Simple.pattern -> t * pattern list
(** reconstructs a pattern, putting wildcards as sub-patterns. *)
val to_omega_pattern : t -> pattern