summaryrefslogtreecommitdiff
path: root/typing/parmatch.ml
diff options
context:
space:
mode:
Diffstat (limited to 'typing/parmatch.ml')
-rw-r--r--typing/parmatch.ml380
1 files changed, 211 insertions, 169 deletions
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 99bb5afe93..939d244bad 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -30,7 +30,9 @@ let make_pat desc ty tenv =
let omega = make_pat Tpat_any Ctype.none Env.empty
let extra_pat =
- make_pat (Tpat_var (Ident.create "+")) Ctype.none Env.empty
+ make_pat
+ (Tpat_var (Ident.create "+", mknoloc "+"))
+ Ctype.none Env.empty
let rec omegas i =
if i <= 0 then [] else omega :: omegas (i-1)
@@ -55,9 +57,9 @@ let records_args l1 l2 =
(* Invariant: fields are already sorted by Typecore.type_label_a_list *)
let rec combine r1 r2 l1 l2 = match l1,l2 with
| [],[] -> List.rev r1, List.rev r2
- | [],(_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
- | (_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
- | (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
+ | [],(_,_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+ | (_,_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+ | (_,_,lbl1,p1)::rem1, (_, _,lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
combine (p1::r1) (omega::r2) rem1 l2
else if lbl1.lbl_pos > lbl2.lbl_pos then
@@ -78,7 +80,7 @@ let rec compat p q =
| Tpat_constant c1, Tpat_constant c2 -> c1=c2
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
| Tpat_lazy p, Tpat_lazy q -> compat p q
- | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
+ | Tpat_construct (_, _, c1,ps1), Tpat_construct (_, _, c2,ps2) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
l1=l2 && compat p1 p2
@@ -86,7 +88,7 @@ let rec compat p q =
l1 = l2
| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
- | Tpat_record l1,Tpat_record l2 ->
+ | Tpat_record (l1,_),Tpat_record (l2,_) ->
let ps,qs = records_args l1 l2 in
compats ps qs
| Tpat_array ps, Tpat_array qs ->
@@ -135,7 +137,7 @@ let find_label lbl lbls =
try
let name,_,_ = List.nth lbls lbl.lbl_pos in
name
- with Failure "nth" -> "*Unkown label*"
+ with Failure "nth" -> Ident.create "*Unknown label*"
let rec get_record_labels ty tenv =
match get_type_descr ty tenv with
@@ -156,7 +158,7 @@ let get_constr_name tag ty tenv = match tag with
| Cstr_exception (path, _) -> Path.name path
| _ ->
try
- let name,_,_ = get_constr tag ty tenv in name
+ let name,_,_ = get_constr tag ty tenv in Ident.name name
with
| Datarepr.Constr_not_found -> "*Unknown constructor*"
@@ -167,7 +169,7 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with
let rec pretty_val ppf v = match v.pat_desc with
| Tpat_any -> fprintf ppf "_"
- | Tpat_var x -> Ident.print ppf x
+ | Tpat_var (x,_) -> Ident.print ppf x
| Tpat_constant (Const_int i) -> fprintf ppf "%d" i
| Tpat_constant (Const_char c) -> fprintf ppf "%C" c
| Tpat_constant (Const_string s) -> fprintf ppf "%S" s
@@ -177,13 +179,13 @@ let rec pretty_val ppf v = match v.pat_desc with
| Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i
| Tpat_tuple vs ->
fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
- | Tpat_construct ({cstr_tag=tag},[]) ->
+ | Tpat_construct (_, _, {cstr_tag=tag},[]) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "%s" name
- | Tpat_construct ({cstr_tag=tag},[w]) ->
+ | Tpat_construct (_, _, {cstr_tag=tag},[w]) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w
- | Tpat_construct ({cstr_tag=tag},vs) ->
+ | Tpat_construct (_, _, {cstr_tag=tag},vs) ->
let name = get_constr_name tag v.pat_type v.pat_env in
begin match (name, vs) with
("::", [v1;v2]) ->
@@ -195,36 +197,42 @@ let rec pretty_val ppf v = match v.pat_desc with
fprintf ppf "`%s" l
| Tpat_variant (l, Some w, _) ->
fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
- | Tpat_record lvs ->
+ | Tpat_record (lvs,_) ->
fprintf ppf "@[{%a}@]"
(pretty_lvals (get_record_labels v.pat_type v.pat_env))
(List.filter
(function
- | (_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+ | (_,_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
| _ -> true) lvs)
| Tpat_array vs ->
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
| Tpat_lazy v ->
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
- | Tpat_alias (v,x) ->
+ | Tpat_alias (v, TPat_alias (x,_)) ->
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
+ | Tpat_alias (v, TPat_unpack) ->
+ fprintf ppf "@[(module %a@)@]" pretty_val v
| Tpat_or (v,w,_) ->
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
+ | Tpat_alias (v, TPat_constraint ctyp) -> (* TODO *)
+ pretty_val ppf v
+ | Tpat_alias (v, TPat_type _) -> (* TODO *)
+ pretty_val ppf v
and pretty_car ppf v = match v.pat_desc with
-| Tpat_construct ({cstr_tag=tag}, [_ ; _])
+| Tpat_construct (_,_,{cstr_tag=tag}, [_ ; _])
when is_cons tag v ->
fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_cdr ppf v = match v.pat_desc with
-| Tpat_construct ({cstr_tag=tag}, [v1 ; v2])
+| Tpat_construct (_,_,{cstr_tag=tag}, [v1 ; v2])
when is_cons tag v ->
fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
| _ -> pretty_val ppf v
and pretty_arg ppf v = match v.pat_desc with
-| Tpat_construct (_,_::_) -> fprintf ppf "(%a)" pretty_val v
+| Tpat_construct (_,_,_,_::_) -> fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_or ppf v = match v.pat_desc with
@@ -240,12 +248,12 @@ and pretty_vals sep ppf = function
and pretty_lvals lbls ppf = function
| [] -> ()
- | [lbl,v] ->
+ | [_, _,lbl,v] ->
let name = find_label lbl lbls in
- fprintf ppf "%s=%a" name pretty_val v
- | (lbl,v)::rest ->
+ fprintf ppf "%a=%a" Ident.print name pretty_val v
+ | (_, _, lbl,v)::rest ->
let name = find_label lbl lbls in
- fprintf ppf "%s=%a;@ %a" name pretty_val v (pretty_lvals lbls) rest
+ fprintf ppf "%a=%a;@ %a" Ident.print name pretty_val v (pretty_lvals lbls) rest
let top_pretty ppf v =
fprintf ppf "@[%a@]@?" pretty_val v
@@ -263,7 +271,7 @@ let prerr_pat v =
(* Check top matching *)
let simple_match p1 p2 =
match p1.pat_desc, p2.pat_desc with
- | Tpat_construct(c1, _), Tpat_construct(c2, _) ->
+ | Tpat_construct(_, _, c1, _), Tpat_construct(_,_, c2, _) ->
c1.cstr_tag = c2.cstr_tag
| Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
l1 = l2
@@ -283,30 +291,30 @@ let simple_match p1 p2 =
(* extract record fields as a whole *)
let record_arg p = match p.pat_desc with
| Tpat_any -> []
-| Tpat_record args -> args
+| Tpat_record (args,_) -> args
| _ -> fatal_error "Parmatch.as_record"
(* Raise Not_found when pos is not present in arg *)
let get_field pos arg =
- let _,p = List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg in
+ let _,_,_, p = List.find (fun (_,_,lbl,_) -> pos = lbl.lbl_pos) arg in
p
let extract_fields omegas arg =
List.map
- (fun (lbl,_) ->
+ (fun (_,_,lbl,_) ->
try
get_field lbl.lbl_pos arg
with Not_found -> omega)
omegas
let all_record_args lbls = match lbls with
-| ({lbl_all=lbl_all},_)::_ ->
+| (_,_,{lbl_all=lbl_all},_)::_ ->
let t =
Array.map
- (fun lbl -> lbl,omega) lbl_all in
+ (fun lbl -> Path.Pident (Ident.create "?temp?"), mknoloc (Longident.Lident "?temp?"), lbl,omega) lbl_all in
List.iter
- (fun ((lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
+ (fun ((_,_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
lbls ;
Array.to_list t
| _ -> fatal_error "Parmatch.all_record_args"
@@ -315,18 +323,18 @@ let all_record_args lbls = match lbls with
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_alias (p2,_) -> simple_match_args p1 p2
-| Tpat_construct(cstr, args) -> args
+| Tpat_construct(_,_, cstr, args) -> args
| Tpat_variant(lab, Some arg, _) -> [arg]
| Tpat_tuple(args) -> args
-| Tpat_record(args) -> extract_fields (record_arg p1) args
+| Tpat_record(args,_) -> extract_fields (record_arg p1) args
| Tpat_array(args) -> args
| Tpat_lazy arg -> [arg]
| (Tpat_any | Tpat_var(_)) ->
begin match p1.pat_desc with
- Tpat_construct(_, args) -> omega_list args
+ Tpat_construct(_,_, _,args) -> omega_list args
| Tpat_variant(_, Some _, _) -> [omega]
| Tpat_tuple(args) -> omega_list args
- | Tpat_record(args) -> omega_list args
+ | Tpat_record(args,_) -> omega_list args
| Tpat_array(args) -> omega_list args
| Tpat_lazy _ -> [omega]
| _ -> []
@@ -344,21 +352,20 @@ let rec normalize_pat q = match q.pat_desc with
| Tpat_alias (p,_) -> normalize_pat p
| Tpat_tuple (args) ->
make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
- | Tpat_construct (c,args) ->
- make_pat (Tpat_construct (c,omega_list args)) q.pat_type q.pat_env
+ | Tpat_construct (lid, lid_loc, c,args) ->
+ make_pat (Tpat_construct (lid, lid_loc, c,omega_list args)) q.pat_type q.pat_env
| Tpat_variant (l, arg, row) ->
make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
q.pat_type q.pat_env
| Tpat_array (args) ->
make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env
- | Tpat_record (largs) ->
- make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs))
+ | Tpat_record (largs, closed) ->
+ make_pat (Tpat_record (List.map (fun (lid,lid_loc,lbl,_) -> lid, lid_loc, lbl,omega) largs, closed))
q.pat_type q.pat_env
| Tpat_lazy _ ->
make_pat (Tpat_lazy omega) q.pat_type q.pat_env
| Tpat_or _ -> fatal_error "Parmatch.normalize_pat"
-
(*
Build normalized (cf. supra) discriminating pattern,
in the non-data type case
@@ -375,19 +382,19 @@ let discr_pat q pss =
acc_pat acc pss
| (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p
| (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
- | (({pat_desc = Tpat_record largs} as p)::_)::pss ->
+ | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss ->
let new_omegas =
List.fold_right
- (fun (lbl,_) r ->
+ (fun (lid, lid_loc, lbl,_) r ->
try
let _ = get_field lbl.lbl_pos r in
r
with Not_found ->
- (lbl,omega)::r)
+ (lid, lid_loc, lbl,omega)::r)
largs (record_arg acc)
in
acc_pat
- (make_pat (Tpat_record new_omegas) p.pat_type p.pat_env)
+ (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env)
pss
| _ -> acc in
@@ -412,26 +419,26 @@ let do_set_args erase_mutable q r = match q with
| {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
-| {pat_desc = Tpat_record omegas} ->
+| {pat_desc = Tpat_record (omegas,closed)} ->
let args,rest = read_args omegas r in
make_pat
(Tpat_record
- (List.map2 (fun (lbl,_) arg ->
+ (List.map2 (fun (lid, lid_loc, lbl,_) arg ->
if
erase_mutable &&
(match lbl.lbl_mut with
| Mutable -> true | Immutable -> false)
then
- lbl, omega
+ lid, lid_loc, lbl, omega
else
- lbl,arg)
- omegas args))
+ lid, lid_loc, lbl, arg)
+ omegas args, closed))
q.pat_type q.pat_env::
rest
-| {pat_desc = Tpat_construct (c,omegas)} ->
+| {pat_desc = Tpat_construct (lid, lid_loc, c,omegas)} ->
let args,rest = read_args omegas r in
make_pat
- (Tpat_construct (c,args)) q.pat_type q.pat_env::
+ (Tpat_construct (lid, lid_loc, c,args)) q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_variant (l, omega, row)} ->
let arg, rest =
@@ -596,14 +603,14 @@ let row_of_pat pat =
not.
*)
-let generalized_constructor x =
- match x with
- ({pat_desc = Tpat_construct(c,_);pat_env=env},_) ->
+let generalized_constructor x =
+ match x with
+ ({pat_desc = Tpat_construct(_,_,c,_);pat_env=env},_) ->
c.cstr_generalized
| _ -> assert false
-let clean_env env =
- let rec loop =
+let clean_env env =
+ let rec loop =
function
| [] -> []
| x :: xs ->
@@ -612,12 +619,12 @@ let clean_env env =
loop env
let full_match ignore_generalized closing env = match env with
-| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ ->
+| ({pat_desc = Tpat_construct (_,_,{cstr_tag=Cstr_exception _},_)},_)::_ ->
false
-| ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ ->
+| ({pat_desc = Tpat_construct(_,_,c,_);pat_type=typ},_) :: _ ->
if ignore_generalized then
(* remove generalized constructors; those cases will be handled separately *)
- let env = clean_env env in
+ let env = clean_env env in
List.length env = c.cstr_normal
else
List.length env = c.cstr_consts + c.cstr_nonconsts
@@ -656,12 +663,12 @@ let full_match ignore_generalized closing env = match env with
| _ -> fatal_error "Parmatch.full_match"
let full_match_gadt env = match env with
- | ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ ->
+ | ({pat_desc = Tpat_construct(_,_,c,_);pat_type=typ},_) :: _ ->
List.length env = c.cstr_consts + c.cstr_nonconsts
| _ -> true
let extendable_match env = match env with
-| ({pat_desc = Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) :: _ ->
+| ({pat_desc = Tpat_construct(_,_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) :: _ ->
let path = get_type_path p.pat_type p.pat_env in
not
(Path.same path Predef.path_bool ||
@@ -674,7 +681,7 @@ let should_extend ext env = match ext with
| None -> false
| Some ext -> match env with
| ({pat_desc =
- Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_)
+ Tpat_construct(_, _,{cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_)
:: _ ->
let path = get_type_path p.pat_type p.pat_env in
Path.same path ext
@@ -703,7 +710,9 @@ let complete_tags nconsts nconstrs tags =
(* build a pattern from a constructor list *)
let pat_of_constr ex_pat cstr =
- {ex_pat with pat_desc = Tpat_construct (cstr,omegas cstr.cstr_arity)}
+ {ex_pat with pat_desc = Tpat_construct (
+ Path.Pident (Ident.create "?pat_of_constr?"), mknoloc (Longident.Lident "?pat_of_constr?"),
+ cstr,omegas cstr.cstr_arity)}
let rec pat_of_constrs ex_pat = function
| [] -> raise Empty
@@ -729,7 +738,7 @@ let rec adt_path env ty =
| _ -> raise Not_an_adt
;;
-let rec map_filter f =
+let rec map_filter f =
function
[] -> []
| x :: xs ->
@@ -738,9 +747,9 @@ let rec map_filter f =
| Some y -> y :: map_filter f xs
(* Sends back a pattern that complements constructor tags all_tag *)
-let complete_constrs p all_tags =
+let complete_constrs p all_tags =
match p.pat_desc with
- | Tpat_construct (c,_) ->
+ | Tpat_construct (_,_,c,_) ->
begin try
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
let constrs = Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in
@@ -771,22 +780,22 @@ let build_other_constant proj make first next p env =
*)
let build_other ext env = match env with
-| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_)
+| ({pat_desc = Tpat_construct (lid, lid_loc, ({cstr_tag=Cstr_exception _} as c),_)},_)
::_ ->
make_pat
(Tpat_construct
- ({c with
+ (lid, lid_loc, {c with
cstr_tag=(Cstr_exception
(Path.Pident (Ident.create "*exception*"), Location.none))},
[]))
Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
+| ({pat_desc = Tpat_construct (_,_, _,_)} as p,_) :: _ ->
begin match ext with
| Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
extra_pat
| _ ->
let get_tag = function
- | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag
+ | {pat_desc = Tpat_construct (_,_,c,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
let all_tags = List.map (fun (p,_) -> get_tag p) env in
pat_of_constrs p (complete_constrs p all_tags)
@@ -899,11 +908,11 @@ let build_other ext env = match env with
| [] -> omega
| _ -> omega
-let build_other_gadt ext env =
+let build_other_gadt ext env =
match env with
- | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
+ | ({pat_desc = Tpat_construct _} as p,_) :: _ ->
let get_tag = function
- | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag
+ | {pat_desc = Tpat_construct (_,_,c,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
let all_tags = List.map (fun (p,_) -> get_tag p) env in
let cnstrs = complete_constrs p all_tags in
@@ -912,7 +921,7 @@ let build_other_gadt ext env =
Format.eprintf "@.@."; *)
pats
| _ -> assert false
-
+
(*
Core function :
Is the last row of pattern matrix pss + qs satisfiable ?
@@ -922,14 +931,19 @@ let build_other_gadt ext env =
2- qs <= es (es matches qs)
*)
+let snd3 (_,x,_) = x
+let thd4 (_,_,x,_) = x
+
let rec has_instance p = match p.pat_desc with
| Tpat_variant (l,_,r) when is_absent l r -> false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
| Tpat_alias (p,_) | Tpat_variant (_,Some p,_) -> has_instance p
| Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
- | Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps
- | Tpat_record lps -> has_instances (List.map snd lps)
- | Tpat_lazy p -> has_instance p
+ | Tpat_construct (_, _,_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps
+ | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,_,x) -> x) lps)
+ | Tpat_lazy p
+ -> has_instance p
+
and has_instances = function
| [] -> true
@@ -976,14 +990,14 @@ type 'a result =
| Rsome of 'a (* This matching value *)
let rec orify_many =
- let rec orify x y =
- make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
+ let rec orify x y =
+ make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
in
function
| [] -> assert false
| [x] -> x
| x :: xs -> orify x (orify_many xs)
-
+
let rec try_many f = function
| [] -> Rnone
| (p,pss)::rest ->
@@ -997,13 +1011,13 @@ let rec try_many_gadt f = function
| (p,pss)::rest ->
match f (p,pss) with
| Rnone -> try_many f rest
- | Rsome sofar ->
- let others = try_many f rest in
+ | Rsome sofar ->
+ let others = try_many f rest in
match others with
Rnone -> Rsome sofar
| Rsome sofar' ->
Rsome (sofar @ sofar')
-
+
let rec exhaust ext pss n = match pss with
@@ -1053,8 +1067,8 @@ let rec exhaust ext pss n = match pss with
| Empty -> fatal_error "Parmatch.exhaust"
end
-let combinations f lst lst' =
- let rec iter2 x =
+let combinations f lst lst' =
+ let rec iter2 x =
function
[] -> []
| y :: ys ->
@@ -1066,10 +1080,33 @@ let combinations f lst lst' =
| x :: xs -> iter2 x lst' @ iter xs
in
iter lst
-
+
+(*
+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"
+ | Tpat_construct (_, lid, _, _) ->
+ 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)
+*)
+
(* strictly more powerful than exhaust; however, exhaust
was kept for backwards compatibility *)
-let rec exhaust_gadt ext pss n = match pss with
+let rec exhaust_gadt (ext:Path.t option) (pss:Typedtree.pattern list list) (n:int) = match pss with
| [] -> Rsome [omegas n]
| []::_ -> Rnone
| pss ->
@@ -1112,34 +1149,33 @@ let rec exhaust_gadt ext pss n = match pss with
| Rsome r ->
try
let missing_trailing = build_other_gadt ext constrs in
- let before =
- match before with
- Rnone -> []
- | Rsome lst -> lst
+ let before =
+ match before with
+ Rnone -> []
+ | Rsome lst -> lst
in
- let dug =
+ let dug =
combinations
- (fun head tail ->
- head :: tail)
+ (fun head tail -> head :: tail)
missing_trailing
r
in
- Rsome (dug @ before)
+ Rsome (dug @ before)
with
(* cannot occur, since constructors don't make a full signature *)
| Empty -> fatal_error "Parmatch.exhaust"
end
-let exhaust_gadt ext pss n =
- let ret = exhaust_gadt ext pss n in
+let exhaust_gadt ext pss n =
+ let ret = exhaust_gadt ext pss n in
match ret with
Rnone -> Rnone
| Rsome lst ->
(* The following line is needed to compile stdlib/printf.ml *)
if lst = [] then Rsome (omegas n) else
- let singletons =
- List.map
- (function
+ let singletons =
+ List.map
+ (function
[x] -> x
| _ -> assert false)
lst
@@ -1470,7 +1506,7 @@ let rec le_pat p q =
| Tpat_alias(p,_), _ -> le_pat p q
| _, Tpat_alias(q,_) -> le_pat p q
| Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
- | Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
+ | Tpat_construct(_,_,c1,ps), Tpat_construct(_,_,c2,qs) ->
c1.cstr_tag = c2.cstr_tag && le_pats ps qs
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
(l1 = l2 && le_pat p1 p2)
@@ -1479,7 +1515,7 @@ let rec le_pat p q =
| Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
| Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
| Tpat_lazy p, Tpat_lazy q -> le_pat p q
- | Tpat_record l1, Tpat_record l2 ->
+ | Tpat_record (l1,_), Tpat_record (l2,_) ->
let ps,qs = records_args l1 l2 in
le_pats ps qs
| Tpat_array(ps), Tpat_array(qs) ->
@@ -1520,19 +1556,19 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
| Tpat_lazy p, Tpat_lazy q ->
let r = lub p q in
make_pat (Tpat_lazy r) p.pat_type p.pat_env
-| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2)
+| Tpat_construct (lid, lid_loc, c1,ps1), Tpat_construct (_, _,c2,ps2)
when c1.cstr_tag = c2.cstr_tag ->
let rs = lubs ps1 ps2 in
- make_pat (Tpat_construct (c1,rs)) p.pat_type p.pat_env
+ make_pat (Tpat_construct (lid, lid_loc, c1,rs)) p.pat_type p.pat_env
| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
when l1=l2 ->
let r=lub p1 p2 in
make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
| Tpat_variant (l1,None,row), Tpat_variant(l2,None,_)
when l1 = l2 -> p
-| Tpat_record l1,Tpat_record l2 ->
+| Tpat_record (l1,closed),Tpat_record (l2,_) ->
let rs = record_lubs l1 l2 in
- make_pat (Tpat_record rs) p.pat_type p.pat_env
+ make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
| Tpat_array ps, Tpat_array qs
when List.length ps = List.length qs ->
let rs = lubs ps qs in
@@ -1554,13 +1590,13 @@ and record_lubs l1 l2 =
let rec lub_rec l1 l2 = match l1,l2 with
| [],_ -> l2
| _,[] -> l1
- | (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
+ | (lid1, lid1_loc, lbl1,p1)::rem1, (lid2, lid2_loc, lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
- (lbl1,p1)::lub_rec rem1 l2
+ (lid1, lid1_loc, lbl1,p1)::lub_rec rem1 l2
else if lbl2.lbl_pos < lbl1.lbl_pos then
- (lbl2,p2)::lub_rec l1 rem2
+ (lid2, lid2_loc, lbl2,p2)::lub_rec l1 rem2
else
- (lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+ (lid1, lid1_loc, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
lub_rec l1 l2
and lubs ps qs = match ps,qs with
@@ -1673,11 +1709,11 @@ let check_partial_all v casel =
(************************)
- let rec get_first f =
+ let rec get_first f =
function
| [] -> None
- | x :: xs ->
- match f x with
+ | x :: xs ->
+ match f x with
| None -> get_first f xs
| x -> x
@@ -1685,11 +1721,11 @@ let check_partial_all v casel =
(* conversion from Typedtree.pattern to Parsetree.pattern list *)
module Conv = struct
open Parsetree
- let mkpat desc =
+ let mkpat desc =
{ppat_desc = desc;
ppat_loc = Location.none}
- let rec select : 'a list list -> 'a list list =
+ let rec select : 'a list list -> 'a list list =
function
| xs :: [] -> List.map (fun y -> [y]) xs
| (x::xs)::ys ->
@@ -1700,20 +1736,20 @@ module Conv = struct
select (xs::ys)
| _ -> []
- let name_counter = ref 0
- let fresh () =
- let current = !name_counter in
+ let name_counter = ref 0
+ let fresh () =
+ let current = !name_counter in
name_counter := !name_counter + 1;
"#$%^@*@" ^ string_of_int current
- let conv (typed: Typedtree.pattern) :
- Parsetree.pattern list *
- (string,Types.constructor_description) Hashtbl.t *
- (string,Types.label_description) Hashtbl.t
- =
- let constrs = Hashtbl.create 0 in
- let labels = Hashtbl.create 0 in
- let rec loop pat =
+ let conv (typed: Typedtree.pattern) :
+ Parsetree.pattern list *
+ (string,Path.t * Types.constructor_description) Hashtbl.t *
+ (string,Path.t * Types.label_description) Hashtbl.t
+ =
+ let constrs = Hashtbl.create 0 in
+ let labels = Hashtbl.create 0 in
+ let rec loop pat =
match pat.pat_desc with
Tpat_or (a,b,_) ->
loop a @ loop b
@@ -1721,27 +1757,28 @@ module Conv = struct
[mkpat Ppat_any]
| Tpat_alias (p,_) -> loop p
| Tpat_tuple lst ->
- let results = select (List.map loop lst) in
+ let results = select (List.map loop lst) in
List.map
(fun lst -> mkpat (Ppat_tuple lst))
results
- | Tpat_construct (cstr,lst) ->
- let id = fresh () in
- Hashtbl.add constrs id cstr;
+ | Tpat_construct (cstr_path, cstr_lid, cstr,lst) ->
+ let id = fresh () in
+ let lid = { cstr_lid with txt = Longident.Lident id } in
+ Hashtbl.add constrs id (cstr_path,cstr);
let results = select (List.map loop lst) in
begin match lst with
[] ->
- [mkpat (Ppat_construct(Longident.Lident id, None, false))]
+ [mkpat (Ppat_construct(lid, None, false))]
| _ ->
- List.map
+ List.map
(fun lst ->
- let arg =
+ let arg =
match lst with
[] -> assert false
| [x] -> Some x
| _ -> Some (mkpat (Ppat_tuple lst))
in
- mkpat (Ppat_construct(Longident.Lident id, arg, false)))
+ mkpat (Ppat_construct(lid, arg, false)))
results
end
| Tpat_variant(label,p_opt,row_desc) ->
@@ -1749,38 +1786,40 @@ module Conv = struct
| None ->
[mkpat (Ppat_variant(label, None))]
| Some p ->
- let results = loop p in
+ let results = loop p in
List.map
(fun p ->
mkpat (Ppat_variant(label, Some p)))
results
end
- | Tpat_record subpatterns ->
- let pats =
+ | Tpat_record (subpatterns, _closed_flag) ->
+ let pats =
select
- (List.map (fun (_,x) -> (loop x)) subpatterns)
+ (List.map (fun (_,_,_,x) -> (loop x)) subpatterns)
in
- let label_idents =
- List.map
- (fun (lbl,_) ->
- let id = fresh () in
- Hashtbl.add labels id lbl;
- Longident.Lident id)
+ let label_idents =
+ List.map
+ (fun (lbl_path,_,lbl,_) ->
+ let id = fresh () in
+ Hashtbl.add labels id (lbl_path, lbl);
+ Longident.Lident id)
subpatterns
- in
+ in
List.map
(fun lst ->
- let lst = List.combine label_idents lst in
- mkpat (Ppat_record (lst, Open)))
+ let lst = List.map2 (fun lid pat ->
+ (mknoloc lid, pat)
+ ) label_idents lst in
+ mkpat (Ppat_record (lst, Open)))
pats
| Tpat_array lst ->
- let results = select (List.map loop lst) in
+ let results = select (List.map loop lst) in
List.map (fun lst -> mkpat (Ppat_array lst)) results
| Tpat_lazy p ->
- let results = loop p in
+ let results = loop p in
List.map (fun p -> mkpat (Ppat_lazy p)) results
in
- let ps = loop typed in
+ let ps = loop typed in
(ps, constrs, labels)
end
@@ -1804,10 +1843,13 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
begin match exhaust None pss (List.length ps) with
| Rnone -> Total
| Rsome [u] ->
- let v =
- match pred with
+ let v =
+ match pred with
| Some pred ->
- let (patterns,constrs,labels) = Conv.conv u in
+ let (patterns,constrs,labels) = Conv.conv u in
+(* Hashtbl.iter (fun s (path, _) ->
+ Printf.fprintf stderr "CONV: %s -> %s \n%!" s (Path.name path)) constrs
+ ; *)
get_first (pred constrs labels) patterns
| None -> Some u
in
@@ -1838,10 +1880,10 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
fatal_error "Parmatch.check_partial"
end
-let do_check_partial_normal loc casel pss =
+let do_check_partial_normal loc casel pss =
do_check_partial exhaust loc casel pss
-let do_check_partial_gadt pred loc casel pss =
+let do_check_partial_gadt pred loc casel pss =
do_check_partial ~pred exhaust_gadt loc casel pss
@@ -1866,7 +1908,7 @@ let extendable_path path =
Path.same path Predef.path_option)
let rec collect_paths_from_pat r p = match p.pat_desc with
-| Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},ps) ->
+| Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps) ->
let path = get_type_path p.pat_type p.pat_env in
List.fold_left
collect_paths_from_pat
@@ -1874,16 +1916,17 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
ps
| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
| Tpat_tuple ps | Tpat_array ps
-| Tpat_construct ({cstr_tag=Cstr_exception _}, ps)->
+| Tpat_construct (_, _, {cstr_tag=Cstr_exception _}, ps)->
List.fold_left collect_paths_from_pat r ps
-| Tpat_record lps ->
+| Tpat_record (lps,_) ->
List.fold_left
- (fun r (_,p) -> collect_paths_from_pat r p)
+ (fun r (_, _, _, p) -> collect_paths_from_pat r p)
r lps
| Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p
| Tpat_or (p1,p2,_) ->
collect_paths_from_pat (collect_paths_from_pat r p1) p2
-| Tpat_lazy p ->
+| Tpat_lazy p
+ ->
collect_paths_from_pat r p
@@ -1967,16 +2010,15 @@ let rec inactive pat = match pat with
false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
true
-| Tpat_tuple ps | Tpat_construct (_, ps) | Tpat_array ps ->
+| Tpat_tuple ps | Tpat_construct (_, _, _, ps) | Tpat_array ps ->
List.for_all (fun p -> inactive p.pat_desc) ps
| Tpat_alias (p,_) | Tpat_variant (_, Some p, _) ->
inactive p.pat_desc
-| Tpat_record ldps ->
- List.exists (fun (_, p) -> inactive p.pat_desc) ldps
+| Tpat_record (ldps,_) ->
+ List.exists (fun (_, _, _, p) -> inactive p.pat_desc) ldps
| Tpat_or (p,q,_) ->
inactive p.pat_desc && inactive q.pat_desc
-
(* A `fluid' pattern is both irrefutable and inactive *)
let fluid pat = irrefutable pat && inactive pat.pat_desc
@@ -1986,7 +2028,7 @@ let fluid pat = irrefutable pat && inactive pat.pat_desc
-
+
(********************************)
(* Exported exhustiveness check *)
(********************************)
@@ -1996,7 +2038,7 @@ let fluid pat = irrefutable pat && inactive pat.pat_desc
on exhaustive matches only.
*)
-let check_partial_param do_check_partial do_check_fragile loc casel =
+let check_partial_param do_check_partial do_check_fragile loc casel =
if Warnings.is_active (Warnings.Partial_match "") then begin
let pss = initial_matrix casel in
let pss = get_mins le_pats pss in
@@ -2008,11 +2050,11 @@ let check_partial_param do_check_partial do_check_fragile loc casel =
end ;
total
end else
- Partial
+ Partial
-let check_partial =
- check_partial_param
- do_check_partial_normal
+let check_partial =
+ check_partial_param
+ do_check_partial_normal
do_check_fragile_normal
let check_partial_gadt pred loc casel =
@@ -2020,7 +2062,7 @@ let check_partial_gadt pred loc casel =
let first_check = check_partial loc casel in
match first_check with
| Partial -> Partial
- | Total ->
+ | Total ->
(* checks for missing GADT constructors *)
check_partial_param (do_check_partial_gadt pred)
do_check_fragile_gadt loc casel
View Lorry Controller Status