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

split patterns into "value patterns" and "computation patterns" 

Value patterns match on a value (the result of computation), while
computation patterns handle the effects (hint hint) of
a computation. The only forms of computation patterns in OCaml today
are value patterns and exception patterns (exception p).

The sub-pattern `p` of the `lazy p` construction should be
a computation pattern, rather than a value pattern. This pull-request
does not make this change.

Most of the changes in this PR are boilerplate -- it really is a lot
of work now to add a new syntactic category to the typed-tree
syntax. This boilerplate is fairly automatic and should be easy to
review.

There is a subtle part to the patch, though: the implementation of the
pattern type-checking. It now has to reconstruct the value/computation
distinction (absent from the parse-tree), and return values from two
different types. Instead of splitting the type-checker in several
functions (which risked code duplications), I choose to use a GADT to
have the same [type_pat] function return two different types depending
on the caller. This is the least invasive way to adapt this part of
the codebase, whose inherent complexity is so large (unfortunately)
that adding a GADT to the mix barely makes a difference.
master
Gabriel Scherer 2019-09-20 15:23:07 +02:00
parent 03c33f5005
commit 312253ce82
25 changed files with 694 additions and 444 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Changes
View File

@ -29,6 +29,10 @@ Working version
### Internal/compiler-libs changes:
- #8970: separate value patterns (matching on values) from computation patterns
(matching on the effects of a copmutation) in the typedtree.
(Gabriel Scherer, review by Jacques Garrigue and Alain Frisch)
- #9078: make all compilerlibs/ available to ocamltest.
(Gabriel Scherer, review by Sébastien Hinderer)

4
file_formats/cmt_format.ml
View File

@ -39,7 +39,7 @@ and binary_part =
| Partial_structure of structure
| Partial_structure_item of structure_item
| Partial_expression of expression
| Partial_pattern of pattern
| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
| Partial_class_expr of class_expr
| Partial_signature of signature
| Partial_signature_item of signature_item
@ -81,7 +81,7 @@ let clear_part = function
| Partial_structure_item s ->
Partial_structure_item (cenv.structure_item cenv s)
| Partial_expression e -> Partial_expression (cenv.expr cenv e)
| Partial_pattern p -> Partial_pattern (cenv.pat cenv p)
| Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p)
| Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
| Partial_signature s -> Partial_signature (cenv.signature cenv s)
| Partial_signature_item s ->

2
file_formats/cmt_format.mli
View File

@ -44,7 +44,7 @@ and binary_part =
| Partial_structure of structure
| Partial_structure_item of structure_item
| Partial_expression of expression
| Partial_pattern of pattern
| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
| Partial_class_expr of class_expr
| Partial_signature of signature
| Partial_signature_item of signature_item

11
lambda/matching.ml
View File

@ -869,7 +869,7 @@ let half_simplify_cases args cls =
| Tpat_variant _
| Tpat_array _
| Tpat_lazy _
| Tpat_exception _ ->
->
cl
)
in
@ -3221,7 +3221,6 @@ let is_lazy_pat p = match p.pat_desc with
| Tpat_var _
| Tpat_any ->
false
| Tpat_exception _ -> assert false
let has_lazy p =
Typedtree.exists_pattern is_lazy_pat p
@ -3246,7 +3245,6 @@ let is_record_with_mutable_field p =
| Tpat_var _
| Tpat_any ->
false
| Tpat_exception _ -> assert false
let has_mutable p =
Typedtree.exists_pattern is_record_with_mutable_field p
@ -3271,10 +3269,13 @@ let check_partial has_mutable has_lazy pat_act_list = function
else
Total
let check_partial_list =
let check_partial_list pats_act_list =
check_partial (List.exists has_mutable) (List.exists has_lazy)
pats_act_list
let check_partial = check_partial has_mutable has_lazy
let check_partial pat_act_list =
check_partial has_mutable has_lazy
pat_act_list
(* have toplevel handler when appropriate *)

6
lambda/translcore.ml
View File

@ -131,6 +131,10 @@ let rec push_defaults loc bindings cases partial =
let env = Env.add_value param desc exp.exp_env in
let name = Ident.name param in
let exp =
let cases =
let pure_case ({c_lhs; _} as case) =
{case with c_lhs = {c_lhs with pat_desc = Tpat_value c_lhs}} in
List.map pure_case cases in
{ exp with exp_loc = loc; exp_env = env; exp_desc =
Texp_match
({exp with exp_type = pat.pat_type; exp_env = env; exp_desc =
@ -966,7 +970,7 @@ and transl_match e arg pat_expr_list partial =
assert (static_handlers = []);
Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial
| arg, _ :: _ ->
let val_id = Typecore.name_cases "val" pat_expr_list in
let val_id = Typecore.name_pattern "val" (List.map fst val_cases) in
let k = Typeopt.value_kind arg.exp_env arg.exp_type in
static_catch [transl_exp arg] [val_id, k]
(Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)

8
tools/cmt2annot.ml
View File

@ -21,7 +21,7 @@ open Tast_iterator
let variables_iterator scope =
let super = default_iterator in
let pat sub p =
let pat sub (type k) (p : k general_pattern) =
begin match p.pat_desc with
| Tpat_var (id, _) | Tpat_alias (_, id, _) ->
Stypes.record (Stypes.An_ident (p.pat_loc,
@ -113,8 +113,8 @@ let rec iterator ~scope rebuild_env =
Stypes.record (Stypes.Ti_expr exp);
super.expr sub exp
and pat sub p =
Stypes.record (Stypes.Ti_pat p);
and pat sub (type k) (p : k general_pattern) =
Stypes.record (Stypes.Ti_pat (classify_pattern p, p));
super.pat sub p
in
@ -163,7 +163,7 @@ let binary_part iter x =
| Partial_structure x -> iter.structure iter x
| Partial_structure_item x -> iter.structure_item iter x
| Partial_expression x -> iter.expr iter x
| Partial_pattern x -> iter.pat iter x
| Partial_pattern (_, x) -> iter.pat iter x
| Partial_class_expr x -> iter.class_expr iter x
| Partial_signature x -> iter.signature iter x
| Partial_signature_item x -> iter.signature_item iter x

19
typing/parmatch.ml
View File

@ -141,8 +141,6 @@ end = struct
| Tpat_lazy p ->
Lazy, [p]
| Tpat_or _ -> invalid_arg "Parmatch.Pattern_head.deconstruct: (P | Q)"
| Tpat_exception _ ->
invalid_arg "Parmatch.Pattern_head.deconstruct: (exception P)"
in
let desc, pats = deconstruct_desc q.pat_desc in
{ desc; typ = q.pat_type; loc = q.pat_loc;
@ -1229,8 +1227,6 @@ let rec has_instance p = match p.pat_desc with
| Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
| Tpat_lazy p
-> has_instance p
| Tpat_exception _ -> assert false
and has_instances = function
| [] -> true
@ -1955,10 +1951,15 @@ and lubs ps qs = match ps,qs with
(* Apply pressure to variants *)
let pressure_variants tdefs patl =
ignore (pressure_variants
(Some tdefs)
(List.map (fun p -> [p; omega]) patl))
let pressure_variants_in_computation_pattern tdefs patl =
let add_row pss p_opt =
match p_opt with
| None -> pss
| Some p -> [p; omega] :: pss
| Some p -> p :: pss
in
let val_pss, exn_pss =
List.fold_right (fun pat (vpss, epss)->
@ -1966,8 +1967,8 @@ let pressure_variants tdefs patl =
add_row vpss vp, add_row epss ep
) patl ([], [])
in
ignore (pressure_variants (Some tdefs) val_pss);
ignore (pressure_variants (Some tdefs) exn_pss)
pressure_variants tdefs val_pss;
pressure_variants tdefs exn_pss
(*****************************)
(* Utilities for diagnostics *)
@ -2055,8 +2056,6 @@ module Conv = struct
mkpat (Ppat_array (List.map loop lst))
| Tpat_lazy p ->
mkpat (Ppat_lazy (loop p))
| Tpat_exception _ ->
assert false
in
let ps = loop typed in
(ps, constrs, labels)
@ -2182,7 +2181,6 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
| Tpat_lazy p
->
collect_paths_from_pat r p
| Tpat_exception _ -> assert false
(*
@ -2314,7 +2312,6 @@ let inactive ~partial pat =
ldps
| Tpat_or (p,q,_) ->
loop p && loop q
| Tpat_exception _ -> assert false
in
loop pat
end

11
typing/parmatch.mli
View File

@ -90,7 +90,10 @@ val ppat_of_type :
(string, constructor_description) Hashtbl.t *
(string, label_description) Hashtbl.t
val pressure_variants: Env.t -> pattern list -> unit
val pressure_variants:
Env.t -> pattern list -> unit
val pressure_variants_in_computation_pattern:
Env.t -> computation general_pattern list -> unit
(** [check_partial pred loc caselist] and [check_unused refute pred caselist]
are called with a function [pred] which will be given counter-example
@ -103,13 +106,13 @@ val check_partial:
((string, constructor_description) Hashtbl.t ->
(string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
Location.t -> case list -> partial
Location.t -> value case list -> partial
val check_unused:
(bool ->
(string, constructor_description) Hashtbl.t ->
(string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
case list -> unit
value case list -> unit
(* Irrefutability tests *)
val irrefutable : pattern -> bool
@ -121,7 +124,7 @@ val irrefutable : pattern -> bool
val inactive : partial:partial -> pattern -> bool
(* Ambiguous bindings *)
val check_ambiguous_bindings : case list -> unit
val check_ambiguous_bindings : value case list -> unit
(* The tag used for open polymorphic variant types with an abstract row *)
val some_private_tag : label

51
typing/printpat.ml
View File

@ -33,19 +33,22 @@ let pretty_const c = match c with
| Const_int64 i -> Printf.sprintf "%LdL" i
| Const_nativeint i -> Printf.sprintf "%ndn" i
let rec pretty_val ppf v =
let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest =
match cstr with
| Tpat_unpack ->
fprintf ppf "@[(module %a)@]" pretty_rest rest
| Tpat_constraint _ ->
fprintf ppf "@[(%a : _)@]" pretty_rest rest
| Tpat_type _ ->
fprintf ppf "@[(# %a)@]" pretty_rest rest
| Tpat_open _ ->
fprintf ppf "@[(# %a)@]" pretty_rest rest
let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
match v.pat_extra with
(cstr, _loc, _attrs) :: rem ->
begin match cstr with
| Tpat_unpack ->
fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
| Tpat_constraint _ ->
fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
| Tpat_type _ ->
fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
| Tpat_open _ ->
fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
end
| extra :: rem ->
pretty_extra ppf extra
pretty_val { v with pat_extra = rem }
| [] ->
match v.pat_desc with
| Tpat_any -> fprintf ppf "_"
@ -89,12 +92,14 @@ let rec pretty_val ppf v =
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
| Tpat_lazy v ->
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
| Tpat_exception v ->
fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
| Tpat_alias (v, x,_) ->
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
| Tpat_or (v,w,_) ->
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
| Tpat_value v ->
fprintf ppf "%a" pretty_val v
| Tpat_exception v ->
fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
| Tpat_or _ ->
fprintf ppf "@[(%a)@]" pretty_or v
and pretty_car ppf v = match v.pat_desc with
| Tpat_construct (_,cstr, [_ ; _])
@ -113,10 +118,11 @@ and pretty_arg ppf v = match v.pat_desc with
| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_or ppf v = match v.pat_desc with
| Tpat_or (v,w,_) ->
fprintf ppf "%a|@,%a" pretty_or v pretty_or w
| _ -> pretty_val ppf v
and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v ->
match v.pat_desc with
| Tpat_or (v,w,_) ->
fprintf ppf "%a|@,%a" pretty_or v pretty_or w
| _ -> pretty_val ppf v
and pretty_vals sep ppf = function
| [] -> ()
@ -135,12 +141,11 @@ and pretty_lvals ppf = function
let top_pretty ppf v =
fprintf ppf "@[%a@]@?" pretty_val v
let pretty_pat p =
top_pretty Format.str_formatter p ;
prerr_string (Format.flush_str_formatter ())
type matrix = pattern list list
type 'k matrix = 'k general_pattern list list
let pretty_line fmt =
List.iter (fun p ->
@ -149,7 +154,7 @@ let pretty_line fmt =
Format.fprintf fmt ">";
)
let pretty_matrix fmt (pss : matrix) =
let pretty_matrix fmt (pss : 'k matrix) =
Format.fprintf fmt "begin matrix\n" ;
List.iter (fun ps ->
pretty_line fmt ps ;

15
typing/printpat.mli
View File

@ -15,8 +15,13 @@
val pretty_const : Asttypes.constant -> string
val top_pretty : Format.formatter -> Typedtree.pattern -> unit
val pretty_pat : Typedtree.pattern -> unit
val pretty_line : Format.formatter -> Typedtree.pattern list -> unit
val pretty_matrix : Format.formatter -> Typedtree.pattern list list -> unit
val pretty_const
: Asttypes.constant -> string
val top_pretty
: Format.formatter -> 'k Typedtree.general_pattern -> unit
val pretty_pat
: 'k Typedtree.general_pattern -> unit
val pretty_line
: Format.formatter -> 'k Typedtree.general_pattern list -> unit
val pretty_matrix
: Format.formatter -> 'k Typedtree.general_pattern list list -> unit

51
typing/printtyped.ml
View File

@ -222,27 +222,13 @@ and package_with i ppf (s, t) =
line i ppf "with type %a\n" fmt_longident s;
core_type i ppf t
and pattern i ppf x =
and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
line i ppf "pattern %a\n" fmt_location x.pat_loc;
attributes i ppf x.pat_attributes;
let i = i+1 in
match x.pat_extra with
| (Tpat_unpack, _, attrs) :: rem ->
line i ppf "Tpat_unpack\n";
attributes i ppf attrs;
pattern i ppf { x with pat_extra = rem }
| (Tpat_constraint cty, _, attrs) :: rem ->
line i ppf "Tpat_constraint\n";
attributes i ppf attrs;
core_type i ppf cty;
pattern i ppf { x with pat_extra = rem }
| (Tpat_type (id, _), _, attrs) :: rem ->
line i ppf "Tpat_type %a\n" fmt_path id;
attributes i ppf attrs;
pattern i ppf { x with pat_extra = rem }
| (Tpat_open (id,_,_), _, attrs)::rem ->
line i ppf "Tpat_open \"%a\"\n" fmt_path id;
attributes i ppf attrs;
| extra :: rem ->
pattern_extra i ppf extra;
pattern i ppf { x with pat_extra = rem }
| [] ->
match x.pat_desc with
@ -267,16 +253,35 @@ and pattern i ppf x =
| Tpat_array (l) ->
line i ppf "Tpat_array\n";
list i pattern ppf l;
| Tpat_or (p1, p2, _) ->
line i ppf "Tpat_or\n";
pattern i ppf p1;
pattern i ppf p2;
| Tpat_lazy p ->
line i ppf "Tpat_lazy\n";
pattern i ppf p;
| Tpat_exception p ->
line i ppf "Tpat_exception\n";
pattern i ppf p;
| Tpat_value p ->
line i ppf "Tpat_value\n";
pattern i ppf p;
| Tpat_or (p1, p2, _) ->
line i ppf "Tpat_or\n";
pattern i ppf p1;
pattern i ppf p2;
and pattern_extra i ppf (extra_pat, _, attrs) =
match extra_pat with
| Tpat_unpack ->
line i ppf "Tpat_extra_unpack\n";
attributes i ppf attrs;
| Tpat_constraint cty ->
line i ppf "Tpat_extra_constraint\n";
attributes i ppf attrs;
core_type i ppf cty;
| Tpat_type (id, _) ->
line i ppf "Tpat_extra_type %a\n" fmt_path id;
attributes i ppf attrs;
| Tpat_open (id,_,_) ->
line i ppf "Tpat_extra_open \"%a\"\n" fmt_path id;
attributes i ppf attrs;
and expression_extra i ppf x attrs =
match x with
@ -881,7 +886,9 @@ and longident_x_pattern i ppf (li, _, p) =
line i ppf "%a\n" fmt_longident li;
pattern (i+1) ppf p;
and case i ppf {c_lhs; c_guard; c_rhs} =
and case
: type k . _ -> _ -> k case -> unit
= fun i ppf {c_lhs; c_guard; c_rhs} ->
line i ppf "<case>\n";
pattern (i+1) ppf c_lhs;
begin match c_guard with

14
typing/rec_check.ml
View File

@ -1144,8 +1144,9 @@ and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg =
m' is the mode under which the scrutinee of p
(the value matched against p) is placed.
*)
and case : Typedtree.case -> mode -> Env.t * mode =
fun { Typedtree.c_lhs; c_guard; c_rhs } ->
and case
: 'k . 'k Typedtree.case -> mode -> Env.t * mode
= fun { Typedtree.c_lhs; c_guard; c_rhs } ->
(*
Ge |- e : m Gg |- g : m[Dereference]
G := Ge+Gg p : mp -| G
@ -1165,7 +1166,7 @@ and case : Typedtree.case -> mode -> Env.t * mode =
m is the mode under which the scrutinee of p is placed.
*)
and pattern : pattern -> Env.t -> mode = fun pat env ->
and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env ->
(*
mp := | Dereference if p is destructuring
| Guard otherwise
@ -1184,7 +1185,7 @@ and pattern : pattern -> Env.t -> mode = fun pat env ->
in
Mode.join m_pat m_env
and is_destructuring_pattern : Typedtree.pattern -> bool =
and is_destructuring_pattern : type k . k general_pattern -> bool =
fun pat -> match pat.pat_desc with
| Tpat_any -> false
| Tpat_var (_, _) -> false
@ -1195,10 +1196,11 @@ and is_destructuring_pattern : Typedtree.pattern -> bool =
| Tpat_variant _ -> true
| Tpat_record (_, _) -> true
| Tpat_array _ -> true
| Tpat_lazy _ -> true
| Tpat_value pat -> is_destructuring_pattern pat
| Tpat_exception _ -> false
| Tpat_or (l,r,_) ->
is_destructuring_pattern l || is_destructuring_pattern r
| Tpat_lazy _ -> true
| Tpat_exception _ -> false
let is_valid_recursive_expression idlist expr =
let ty = expression expr Return in

8
typing/stypes.ml
View File

@ -30,7 +30,7 @@ open Typedtree;;
let output_int oc i = output_string oc (Int.to_string i)
type annotation =
| Ti_pat of pattern
| Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
| Ti_expr of expression
| Ti_class of class_expr
| Ti_mod of module_expr
@ -40,7 +40,7 @@ type annotation =
let get_location ti =
match ti with
Ti_pat p -> p.pat_loc
| Ti_pat (_, p) -> p.pat_loc
| Ti_expr e -> e.exp_loc
| Ti_class c -> c.cl_loc
| Ti_mod m -> m.mod_loc
@ -149,8 +149,8 @@ let print_ident_annot pp str k =
let print_info pp prev_loc ti =
match ti with
| Ti_class _ | Ti_mod _ -> prev_loc
| Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env}
| Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} ->
| Ti_pat (_, {pat_loc = loc; pat_type = typ; pat_env = env})
| Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} ->
if loc <> prev_loc then begin
print_location pp loc;
output_char pp '\n'

2
typing/stypes.mli
View File

@ -20,7 +20,7 @@
open Typedtree;;
type annotation =
| Ti_pat of pattern
| Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
| Ti_expr of expression
| Ti_class of class_expr
| Ti_mod of module_expr

40
typing/tast_iterator.ml
View File

@ -19,8 +19,7 @@ open Typedtree
type iterator =
{
binding_op: iterator -> binding_op -> unit;
case: iterator -> case -> unit;
cases: iterator -> case list -> unit;
case: 'k . iterator -> 'k case -> unit;
class_declaration: iterator -> class_declaration -> unit;
class_description: iterator -> class_description -> unit;
class_expr: iterator -> class_expr -> unit;
@ -41,7 +40,7 @@ type iterator =
module_type: iterator -> module_type -> unit;
module_type_declaration: iterator -> module_type_declaration -> unit;
package_type: iterator -> package_type -> unit;
pat: iterator -> pattern -> unit;
pat: 'k . iterator -> 'k general_pattern -> unit;
row_field: iterator -> row_field -> unit;
object_field: iterator -> object_field -> unit;
open_declaration: iterator -> open_declaration -> unit;
@ -149,15 +148,17 @@ let extension_constructor sub {ext_kind; _} =
Option.iter (sub.typ sub) cto
| Text_rebind _ -> ()
let pat sub {pat_extra; pat_desc; pat_env; _} =
let extra = function
| Tpat_type _ -> ()
| Tpat_unpack -> ()
| Tpat_open (_, _, env) -> sub.env sub env
| Tpat_constraint ct -> sub.typ sub ct
in
let pat_extra sub (e, _loc, _attrs) = match e with
| Tpat_type _ -> ()
| Tpat_unpack -> ()
| Tpat_open (_, _, env) -> sub.env sub env
| Tpat_constraint ct -> sub.typ sub ct
let pat
: type k . iterator -> k general_pattern -> unit
= fun sub {pat_extra = extra; pat_desc; pat_env; _} ->
sub.env sub pat_env;
List.iter (fun (e, _, _) -> extra e) pat_extra;
List.iter (pat_extra sub) extra;
match pat_desc with
| Tpat_any -> ()
| Tpat_var _ -> ()
@ -167,12 +168,13 @@ let pat sub {pat_extra; pat_desc; pat_env; _} =
| Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po
| Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l
| Tpat_array l -> List.iter (sub.pat sub) l
| Tpat_alias (p, _, _) -> sub.pat sub p
| Tpat_lazy p -> sub.pat sub p
| Tpat_value p
| Tpat_exception p -> sub.pat sub p
| Tpat_or (p1, p2, _) ->
sub.pat sub p1;
sub.pat sub p2
| Tpat_alias (p, _, _) -> sub.pat sub p
| Tpat_lazy p -> sub.pat sub p
| Tpat_exception p -> sub.pat sub p
let expr sub {exp_extra; exp_desc; exp_env; _} =
let extra = function
@ -191,16 +193,17 @@ let expr sub {exp_extra; exp_desc; exp_env; _} =
| Texp_let (rec_flag, list, exp) ->
sub.value_bindings sub (rec_flag, list);
sub.expr sub exp
| Texp_function {cases; _} -> sub.cases sub cases
| Texp_function {cases; _} ->
List.iter (sub.case sub) cases
| Texp_apply (exp, list) ->
sub.expr sub exp;
List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list
| Texp_match (exp, cases, _) ->
sub.expr sub exp;
sub.cases sub cases
List.iter (sub.case sub) cases
| Texp_try (exp, cases) ->
sub.expr sub exp;
sub.cases sub cases
List.iter (sub.case sub) cases
| Texp_tuple list -> List.iter (sub.expr sub) list
| Texp_construct (_, _, args) -> List.iter (sub.expr sub) args
| Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo
@ -450,8 +453,6 @@ let class_field sub {cf_desc; _} = match cf_desc with
let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list
let cases sub l = List.iter (sub.case sub) l
let case sub {c_lhs; c_guard; c_rhs} =
sub.pat sub c_lhs;
Option.iter (sub.expr sub) c_guard;
@ -467,7 +468,6 @@ let default_iterator =
{
binding_op;
case;
cases;
class_declaration;
class_description;
class_expr;

5
typing/tast_iterator.mli
View File

@ -23,8 +23,7 @@ open Typedtree
type iterator =
{
binding_op: iterator -> binding_op -> unit;
case: iterator -> case -> unit;
cases: iterator -> case list -> unit;
case: 'k . iterator -> 'k case -> unit;
class_declaration: iterator -> class_declaration -> unit;
class_description: iterator -> class_description -> unit;
class_expr: iterator -> class_expr -> unit;
@ -45,7 +44,7 @@ type iterator =
module_type: iterator -> module_type -> unit;
module_type_declaration: iterator -> module_type_declaration -> unit;
package_type: iterator -> package_type -> unit;
pat: iterator -> pattern -> unit;
pat: 'k . iterator -> 'k general_pattern -> unit;
row_field: iterator -> row_field -> unit;
object_field: iterator -> object_field -> unit;
open_declaration: iterator -> open_declaration -> unit;

52
typing/tast_mapper.ml
View File

@ -22,8 +22,7 @@ open Typedtree
type mapper =
{
binding_op: mapper -> binding_op -> binding_op;
case: mapper -> case -> case;
cases: mapper -> case list -> case list;
case: 'k . mapper -> 'k case -> 'k case;
class_declaration: mapper -> class_declaration -> class_declaration;
class_description: mapper -> class_description -> class_description;
class_expr: mapper -> class_expr -> class_expr;
@ -47,7 +46,7 @@ type mapper =
module_type_declaration:
mapper -> module_type_declaration -> module_type_declaration;
package_type: mapper -> package_type -> package_type;
pat: mapper -> pattern -> pattern;
pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
row_field: mapper -> row_field -> row_field;
object_field: mapper -> object_field -> object_field;
open_declaration: mapper -> open_declaration -> open_declaration;
@ -195,20 +194,22 @@ let extension_constructor sub x =
in
{x with ext_kind}
let pat sub x =
let extra = function
| Tpat_type _
| Tpat_unpack as d -> d
| Tpat_open (path,loc,env) -> Tpat_open (path, loc, sub.env sub env)
| Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
in
let pat_extra sub = function
| Tpat_type _
| Tpat_unpack as d -> d
| Tpat_open (path,loc,env) -> Tpat_open (path, loc, sub.env sub env)
| Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
let pat
: type k . mapper -> k general_pattern -> k general_pattern
= fun sub x ->
let pat_env = sub.env sub x.pat_env in
let pat_extra = List.map (tuple3 extra id id) x.pat_extra in
let pat_desc =
let pat_extra = List.map (tuple3 (pat_extra sub) id id) x.pat_extra in
let pat_desc : k pattern_desc =
match x.pat_desc with
| Tpat_any
| Tpat_var _
| Tpat_constant _ as d -> d
| Tpat_constant _ -> x.pat_desc
| Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l)
| Tpat_construct (loc, cd, l) ->
Tpat_construct (loc, cd, List.map (sub.pat sub) l)
@ -217,11 +218,14 @@ let pat sub x =
| Tpat_record (l, closed) ->
Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
| Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
| Tpat_or (p1, p2, rd) ->
Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
| Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
| Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
| Tpat_exception p -> Tpat_exception (sub.pat sub p)
| Tpat_value p ->
Tpat_value (sub.pat sub p)
| Tpat_exception p ->
Tpat_exception (sub.pat sub p)
| Tpat_or (p1, p2, rd) ->
Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
in
{x with pat_extra; pat_desc; pat_env}
@ -244,8 +248,8 @@ let expr sub x =
let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
Texp_let (rec_flag, list, sub.expr sub exp)
| Texp_function { arg_label; param; cases; partial; } ->
Texp_function { arg_label; param; cases = sub.cases sub cases;
partial; }
let cases = List.map (sub.case sub) cases in
Texp_function { arg_label; param; cases; partial; }
| Texp_apply (exp, list) ->
Texp_apply (
sub.expr sub exp,
@ -254,13 +258,13 @@ let expr sub x =
| Texp_match (exp, cases, p) ->
Texp_match (
sub.expr sub exp,
sub.cases sub cases,
List.map (sub.case sub) cases,
p
)
| Texp_try (exp, cases) ->
Texp_try (
sub.expr sub exp,
sub.cases sub cases
List.map (sub.case sub) cases
)
| Texp_tuple list ->
Texp_tuple (List.map (sub.expr sub) list)
@ -678,10 +682,9 @@ let class_field sub x =
let value_bindings sub (rec_flag, list) =
(rec_flag, List.map (sub.value_binding sub) list)
let cases sub l =
List.map (sub.case sub) l
let case sub {c_lhs; c_guard; c_rhs} =
let case
: type k . mapper -> k case -> k case
= fun sub {c_lhs; c_guard; c_rhs} ->
{
c_lhs = sub.pat sub c_lhs;
c_guard = Option.map (sub.expr sub) c_guard;
@ -699,7 +702,6 @@ let default =
{
binding_op;
case;
cases;
class_declaration;
class_description;
class_expr;

5
typing/tast_mapper.mli
View File

@ -21,8 +21,7 @@ open Typedtree
type mapper =
{
binding_op: mapper -> binding_op -> binding_op;
case: mapper -> case -> case;
cases: mapper -> case list -> case list;
case: 'k . mapper -> 'k case -> 'k case;
class_declaration: mapper -> class_declaration -> class_declaration;
class_description: mapper -> class_description -> class_description;
class_expr: mapper -> class_expr -> class_expr;
@ -46,7 +45,7 @@ type mapper =
module_type_declaration:
mapper -> module_type_declaration -> module_type_declaration;
package_type: mapper -> package_type -> package_type;
pat: mapper -> pattern -> pattern;
pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
row_field: mapper -> row_field -> row_field;
object_field: mapper -> object_field -> object_field;
open_declaration: mapper -> open_declaration -> open_declaration;

3
typing/typeclass.ml
View File

@ -1023,7 +1023,8 @@ and class_expr_aux cl_num val_env met_env scl =
in
if !Clflags.principal then begin
Ctype.end_def ();
iter_pattern (fun {pat_type=ty} -> Ctype.generalize_structure ty) pat
let gen {pat_type = ty} = Ctype.generalize_structure ty in
iter_pattern gen pat
end;
let pv =
List.map

418
typing/typecore.ml
View File

@ -52,7 +52,8 @@ type existential_restriction =
type error =
| Constructor_arity_mismatch of Longident.t * int * int
| Label_mismatch of Longident.t * Ctype.Unification_trace.t
| Pattern_type_clash of Ctype.Unification_trace.t * pattern_desc option
| Pattern_type_clash :
Ctype.Unification_trace.t * _ pattern_desc option -> error
| Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t
| Multiply_bound_variable of string
| Orpat_vars of Ident.t * Ident.t list
@ -158,8 +159,13 @@ let re node =
node
;;
let rp node =
Cmt_format.add_saved_type (Cmt_format.Partial_pattern node);
Stypes.record (Stypes.Ti_pat node);
Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node));
Stypes.record (Stypes.Ti_pat (Value, node));
node
;;
let rcp node =
Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node));
Stypes.record (Stypes.Ti_pat (Computation, node));
node
;;
@ -308,37 +314,42 @@ let unify_pat env pat expected_ty =
raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc)))
(* make all Reither present in open variants *)
let finalize_variant pat =
match pat.pat_desc with
Tpat_variant(tag, opat, r) ->
let row =
match expand_head pat.pat_env pat.pat_type with
{desc = Tvariant row} -> r := row; row_repr row
| _ -> assert false
in
begin match row_field tag row with
| Rabsent -> () (* assert false *)
| Reither (true, [], _, e) when not row.row_closed ->
set_row_field e (Rpresent None)
| Reither (false, ty::tl, _, e) when not row.row_closed ->
set_row_field e (Rpresent (Some ty));
begin match opat with None -> assert false
| Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
end
| Reither (c, _l, true, e) when not (row_fixed row) ->
set_row_field e (Reither (c, [], false, ref None))
| _ -> ()
end;
(* Force check of well-formedness WHY? *)
(* unify_pat pat.pat_env pat
(newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
row_bound=(); row_fixed=false; row_name=None})); *)
let finalize_variant pat tag opat r =
let row =
match expand_head pat.pat_env pat.pat_type with
{desc = Tvariant row} -> r := row; row_repr row
| _ -> assert false
in
begin match row_field tag row with
| Rabsent -> () (* assert false *)
| Reither (true, [], _, e) when not row.row_closed ->
set_row_field e (Rpresent None)
| Reither (false, ty::tl, _, e) when not row.row_closed ->
set_row_field e (Rpresent (Some ty));
begin match opat with None -> assert false
| Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
end
| Reither (c, _l, true, e) when not (row_fixed row) ->
set_row_field e (Reither (c, [], false, ref None))
| _ -> ()
end
(* Force check of well-formedness WHY? *)
(* unify_pat pat.pat_env pat
(newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
row_bound=(); row_fixed=false; row_name=None})); *)
let has_variants p =
exists_pattern
(function {pat_desc=Tpat_variant _} -> true | _ -> false)
p
exists_general_pattern
{ f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
| (Tpat_variant _) -> true
| _ -> false } p
let finalize_variants p =
iter_general_pattern
{ f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
| Tpat_variant(tag, opat, r) ->
finalize_variant p tag opat r
| _ -> () } p
(* pattern environment *)
type pattern_variable =
@ -493,7 +504,7 @@ let rec build_as_type env p =
newty (Tvariant{row with row_closed=false; row_more=newvar()})
end
| Tpat_any | Tpat_var _ | Tpat_constant _
| Tpat_array _ | Tpat_lazy _ | Tpat_exception _ -> p.pat_type
| Tpat_array _ | Tpat_lazy _ -> p.pat_type
let build_or_pat env loc lid =
let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in
@ -931,8 +942,8 @@ let unify_head_only loc env ty constr =
the pattern but haven't type-checked the body yet.
At this point we might have added some type equalities to the environment,
but haven't yet added identifiers bound by the pattern. *)
type half_typed_case =
{ typed_pat: pattern;
type 'case_pattern half_typed_case =
{ typed_pat: 'case_pattern;
pat_type_for_unif: type_expr;
untyped_case: Parsetree.case;
branch_env: Env.t;
@ -1143,26 +1154,94 @@ let enter_nonsplit_or mode = match mode with
Refine_or {inside_nonsplit_or = true}
in Counter_example { info with splitting_mode }
let rec type_pat ?(exception_allowed=false) ~no_existentials ~mode
~env sp expected_ty k =
(** The typedtree has two distinct syntactic categories for patterns,
"value" patterns, matching on values, and "computation" patterns
that match on the effect of a computation -- typically, exception
patterns (exception p).
On the other hand, the parsetree has an unstructured representation
where all categories of patterns are mixed together. The
decomposition according to the value/computation structure has to
happen during type-checking.
We don't want to duplicate the type-checking logic in two different
functions, depending on the kind of pattern to be produced. In
particular, there are both value and computation or-patterns, and
the type-checking logic for or-patterns is horribly complex; having
it in two different places would be twice as horirble.
The solution is to pass a GADT tag to [type_pat] to indicate whether
a value or computation pattern is expected. This way, there is a single
place where [Ppat_or] nodes are type-checked, the checking logic is shared,
and only at the end do we inspect the tag to decide to produce a value
or computation pattern.
*)
let pure
: type k . k pattern_category -> value general_pattern -> k general_pattern
= fun category pat ->
match category with
| Value -> pat
| Computation -> { pat with pat_desc = Tpat_value pat }
let only_impure
: type k . k pattern_category ->
computation general_pattern -> k general_pattern
= fun category pat ->
match category with
| Value ->
(* LATER: this exception could be renamed/generalized *)
raise (Error (pat.pat_loc, pat.pat_env,
Exception_pattern_disallowed))
| Computation -> pat
let as_comp_pattern
: type k . k pattern_category ->
k general_pattern -> computation general_pattern
= fun category pat ->
match category with
| Value -> { pat with pat_desc = Tpat_value pat }
| Computation -> pat
(* type_pat propagates the expected type as well as maps for
constructors and labels.
Unification may update the typing environment. *)
(* constrs <> None => called from parmatch: backtrack on or-patterns
explode > 0 => explode Ppat_any for gadts *)
(* Need_backtrack exceptions are raised in the [Inside_or] mode to backtrack
to the outermost or-pattern *)
let rec type_pat
: type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
env:_ -> _ -> _ -> (k general_pattern -> r) -> r
= fun category ~no_existentials ~mode
~env sp expected_ty k ->
Builtin_attributes.warning_scope sp.ppat_attributes
(fun () ->
type_pat_aux ~exception_allowed ~no_existentials ~mode
type_pat_aux category ~no_existentials ~mode
~env sp expected_ty k
)
and type_pat_aux ~exception_allowed ~no_existentials ~mode
~env sp expected_ty k =
let type_pat ?(exception_allowed=false) ?(mode=mode) ?(env=env) =
type_pat ~exception_allowed ~no_existentials ~mode ~env
and type_pat_aux
: type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
env:_ -> _ -> _ -> (k general_pattern -> r) -> r
= fun category ~no_existentials ~mode
~env sp expected_ty k ->
let type_pat category ?(mode=mode) ?(env=env) =
type_pat category ~no_existentials ~mode ~env
in
let loc = sp.ppat_loc in
let rup k x =
if mode = Normal then (ignore (rp x));
let unif (x : pattern) : pattern =
unify_pat !env x (instance expected_ty);
k x
x
in
let rp k x : pattern = if mode = Normal then k (rp x) else k x in
let rp x =
let crp (x : k general_pattern) : k general_pattern =
match category with
| Value -> rp x
| Computation -> rcp x in
if mode = Normal then crp x else x in
let rp k x = k (rp x)
and rvp k x = k (rp (pure category x))
and rcp k x = k (rp (only_impure category x)) in
let construction_not_used_in_counterexamples = (mode = Normal) in
let must_backtrack_on_gadt = match get_splitting_mode mode with
| None -> false
@ -1171,7 +1250,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
in
match sp.ppat_desc with
Ppat_any ->
let k' d = rp k {
let k' d = rvp k {
pat_desc = d;
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
@ -1196,7 +1275,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
let mode =
Counter_example { info with explosion_fuel; constrs; labels }
in
type_pat ~mode sp expected_ty k
type_pat category ~mode sp expected_ty k
end
end
| Ppat_var name ->
@ -1207,7 +1286,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
else
enter_variable loc name ty sp.ppat_attributes
in
rp k {
rvp k {
pat_desc = Tpat_var (id, name);
pat_loc = loc; pat_extra=[];
pat_type = ty;
@ -1218,7 +1297,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
let t = instance expected_ty in
begin match name.txt with
| None ->
rp k {
rvp k {
pat_desc = Tpat_any;
pat_loc = sp.ppat_loc;
pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
@ -1228,7 +1307,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
| Some s ->
let v = { name with txt = s } in
let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
rp k {
rvp k {
pat_desc = Tpat_var (id, v);
pat_loc = sp.ppat_loc;
pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
@ -1252,7 +1331,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
end_def ();
generalize ty';
let id = enter_variable lloc name ty' attrs in
rp k {
rvp k {
pat_desc = Tpat_var (id, name);
pat_loc = lloc;
pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
@ -1264,7 +1343,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
end
| Ppat_alias(sq, name) ->
assert construction_not_used_in_counterexamples;
type_pat sq expected_ty (fun q ->
type_pat Value sq expected_ty (fun q ->
begin_def ();
let ty_var = build_as_type !env q in
end_def ();
@ -1272,7 +1351,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
let id =
enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
in
rp k {
rvp k {
pat_desc = Tpat_alias(q, id, name);
pat_loc = loc; pat_extra=[];
pat_type = q.pat_type;
@ -1280,7 +1359,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
pat_env = !env })
| Ppat_constant cst ->
let cst = constant_or_raise !env loc cst in
rup k {
rvp k @@ unif {
pat_desc = Tpat_constant cst;
pat_loc = loc; pat_extra=[];
pat_type = type_constant cst;
@ -1298,7 +1377,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
in
let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
let p = {p with ppat_loc=loc} in
type_pat ~mode:(no_explosion mode) p expected_ty k
type_pat category ~mode:(no_explosion mode) p expected_ty k
(* TODO: record 'extra' to remember about interval *)
| Ppat_interval _ ->
raise (Error (loc, !env, Invalid_interval))
@ -1311,8 +1390,8 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
end_def ();
generalize_structure expected_ty;
unify_pat_types loc !env ty expected_ty;
map_fold_cont (fun (p,t) -> type_pat p t) spl_ann (fun pl ->
rp k {
map_fold_cont (fun (p,t) -> type_pat Value p t) spl_ann (fun pl ->
rvp k {
pat_desc = Tpat_tuple pl;
pat_loc = loc; pat_extra=[];
pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
@ -1402,14 +1481,16 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
in
if constr.cstr_inlined <> None then List.iter check_non_escaping sargs;
map_fold_cont (fun (p,t) -> type_pat p t) (List.combine sargs ty_args)
(fun args ->
rp k {
pat_desc=Tpat_construct(lid, constr, args);
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env })
map_fold_cont
(fun (p,t) -> type_pat Value p t)
(List.combine sargs ty_args)
(fun args ->
rvp k {
pat_desc=Tpat_construct(lid, constr, args);
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env })
| Ppat_variant(l, sarg) ->
let arg_type = match sarg with None -> [] | Some _ -> [newgenvar()] in
let row = { row_fields =
@ -1429,7 +1510,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
then assert (match mode with Normal -> false | Counter_example _ -> true)
else unify_pat_types loc !env (newgenty (Tvariant row)) expected_ty;
let k arg =
rp k {
rvp k {
pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
@ -1438,7 +1519,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
in begin
(* PR#6235: propagate type information *)
match sarg, arg_type with
Some p, [ty] -> type_pat p ty (fun p -> k (Some p))
Some p, [ty] -> type_pat Value p ty (fun p -> k (Some p))
| _ -> k None
end
| Ppat_record(lid_sp_list, closed) ->
@ -1465,28 +1546,30 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
end_def ();
generalize_structure ty_res;
generalize_structure ty_arg;
type_pat sarg ty_arg (fun arg ->
type_pat Value sarg ty_arg (fun arg ->
k (label_lid, label, arg))
in
let k' k lbl_pat_list =
let make_record_pat lbl_pat_list =
check_recordpat_labels loc lbl_pat_list closed;
rup k {
pat_desc = Tpat_record (lbl_pat_list, closed);
pat_loc = loc; pat_extra=[];
pat_type = instance record_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
{
pat_desc = Tpat_record (lbl_pat_list, closed);
pat_loc = loc; pat_extra=[];
pat_type = instance record_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env;
}
in
let k' pat = rvp k (unif pat) in
begin match mode with
| Normal ->
k (wrap_disambiguate "This record pattern is expected to have"
k' (wrap_disambiguate "This record pattern is expected to have"
(mk_expected expected_ty)
(type_label_a_list loc false !env type_label_pat opath
lid_sp_list)
(k' (fun x -> x)))
make_record_pat)
| Counter_example {labels; _} ->
type_label_a_list ~labels loc false !env type_label_pat opath
lid_sp_list (k' k)
lid_sp_list (fun lbl_pat_list -> k' (make_record_pat lbl_pat_list))
end
| Ppat_array spl ->
let ty_elt = newgenvar() in
@ -1496,8 +1579,8 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
generalize_structure expected_ty;
unify_pat_types
loc !env (Predef.type_array ty_elt) expected_ty;
map_fold_cont (fun p -> type_pat p ty_elt) spl (fun pl ->
rp k {
map_fold_cont (fun p -> type_pat Value p ty_elt) spl (fun pl ->
rvp k {
pat_desc = Tpat_array pl;
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
@ -1512,7 +1595,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
let state = save_state env in
let split_or sp =
assert may_split;
let typ pat = type_pat ~exception_allowed pat expected_ty k in
let typ pat = type_pat category pat expected_ty k in
find_valid_alternative (fun pat -> set_state state env; typ pat) sp in
if must_split then split_or sp else begin
let initial_pattern_variables = !pattern_variables in
@ -1526,7 +1609,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
let env1 = ref !env in
let inside_or = enter_nonsplit_or mode in
let p1 =
try Some (type_pat ~exception_allowed ~mode:inside_or
try Some (type_pat category ~mode:inside_or
sp1 expected_ty ~env:env1 (fun x -> x))
with Need_backtrack -> None in
let p1_variables = !pattern_variables in
@ -1535,7 +1618,7 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
module_variables := initial_module_variables;
let env2 = ref !env in
let p2 =
try Some (type_pat ~exception_allowed ~mode:inside_or
try Some (type_pat category ~mode:inside_or
sp2 expected_ty ~env:env2 (fun x -> x))
with Need_backtrack -> None in
end_def ();
@ -1562,22 +1645,24 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
| Some p1, Some p2 ->
let alpha_env =
enter_orpat_variables loc !env p1_variables p2_variables in
let p2 = alpha_pat alpha_env p2 in
pattern_variables := p1_variables;
module_variables := p1_module_variables;
rp k { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
pat_loc = loc;
pat_extra=[];
pat_type = instance expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
let make_pat desc =
{ pat_desc = desc;
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } in
rp k (make_pat (Tpat_or(p1, p2, None)))
end
end
| Ppat_lazy sp1 ->
let nv = newgenvar () in
unify_pat_types loc !env (Predef.type_lazy_t nv) expected_ty;
(* do not explode under lazy: PR#7421 *)
type_pat ~mode:(no_explosion mode) sp1 nv (fun p1 ->
rp k {
type_pat Value ~mode:(no_explosion mode) sp1 nv (fun p1 ->
rvp k {
pat_desc = Tpat_lazy p1;
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
@ -1592,62 +1677,62 @@ and type_pat_aux ~exception_allowed ~no_existentials ~mode
generalize_structure ty;
let ty, expected_ty' = instance ty, ty in
unify_pat_types loc !env ty (instance expected_ty);
type_pat ~exception_allowed sp expected_ty' (fun p ->
type_pat category sp expected_ty' (fun p ->
(*Format.printf "%a@.%a@."
Printtyp.raw_type_expr ty
Printtyp.raw_type_expr p.pat_type;*)
pattern_force := force :: !pattern_force;
let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
let p =
match p.pat_desc with
Tpat_var (id,s) ->
{p with pat_type = ty;
pat_desc = Tpat_alias
({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
pat_extra = [extra];
}
| _ -> {p with pat_type = ty;
pat_extra = extra :: p.pat_extra}
let p : k general_pattern =
match category, (p : k general_pattern) with
| Value, {pat_desc = Tpat_var (id,s); _} ->
{p with
pat_type = ty;
pat_desc =
Tpat_alias
({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
pat_extra = [extra];
}
| _, p ->
{ p with pat_type = ty; pat_extra = extra::p.pat_extra }
in k p)
| Ppat_type lid ->
let (path, p,ty) = build_or_pat !env loc lid in
unify_pat_types loc !env ty (instance expected_ty);
k { p with pat_extra =
(Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
k @@ pure category @@ { p with pat_extra =
(Tpat_type (path, lid), loc, sp.ppat_attributes)
:: p.pat_extra }
| Ppat_open (lid,p) ->
let path, new_env =
!type_open Asttypes.Fresh !env sp.ppat_loc lid in
let new_env = ref new_env in
type_pat ~exception_allowed ~env:new_env p expected_ty ( fun p ->
type_pat category ~env:new_env p expected_ty ( fun p ->
env := Env.copy_local !env ~from:!new_env;
k { p with pat_extra =( Tpat_open (path,lid,!new_env),
loc, sp.ppat_attributes) :: p.pat_extra }
)
| Ppat_exception p ->
if not exception_allowed then
raise (Error (loc, !env, Exception_pattern_disallowed))
else begin
type_pat p Predef.type_exn (fun p_exn ->
rp k {
pat_desc = Tpat_exception p_exn;
pat_loc = sp.ppat_loc;
pat_extra = [];
pat_type = expected_ty;
pat_env = !env;
pat_attributes = sp.ppat_attributes;
})
end
type_pat Value p Predef.type_exn (fun p_exn ->
rcp k {
pat_desc = Tpat_exception p_exn;
pat_loc = sp.ppat_loc;
pat_extra = [];
pat_type = expected_ty;
pat_env = !env;
pat_attributes = sp.ppat_attributes;
})
| Ppat_extension ext ->
raise (Error_forward (Builtin_attributes.error_of_extension ext))
let type_pat ?exception_allowed ?no_existentials ?(mode=Normal)
let type_pat category ?no_existentials ?(mode=Normal)
?(lev=get_current_level()) env sp expected_ty =
Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->
let r =
type_pat ?exception_allowed ~no_existentials ~mode
type_pat category ~no_existentials ~mode
~env sp expected_ty (fun x -> x)
in
iter_pattern (fun p -> p.pat_env <- !env) r;
iter_general_pattern
{ f = fun p -> p.pat_env <- !env } r;
r
)
@ -1666,7 +1751,9 @@ let partial_pred ~lev ~splitting_mode ?(explode=0)
try
reset_pattern None true;
let typed_p =
Ctype.with_passive_variants (type_pat ~lev ~mode env p) expected_ty
Ctype.with_passive_variants
(type_pat Value ~lev ~mode env p)
expected_ty
in
set_state state env;
(* types are invalidated but we don't need them here *)
@ -1707,21 +1794,23 @@ let add_pattern_variables ?check ?check_as env pv =
)
pv env
let type_pattern ?exception_allowed ~lev env spat scope expected_ty =
let type_pattern category ~lev env spat scope expected_ty =
reset_pattern scope true;
let new_env = ref env in
let pat = type_pat ?exception_allowed ~lev new_env spat expected_ty in
let pat = type_pat category ~lev new_env spat expected_ty in
let pvs = get_ref pattern_variables in
let unpacks = get_ref module_variables in
(pat, !new_env, get_ref pattern_force, pvs, unpacks)
let type_pattern_list no_existentials env spatl scope expected_tys allow =
let type_pattern_list
category no_existentials env spatl scope expected_tys allow
=
reset_pattern scope allow;
let new_env = ref env in
let type_pat (attrs, pat) ty =
Builtin_attributes.warning_scope ~ppwarning:false attrs
(fun () ->
type_pat ~no_existentials new_env pat ty
type_pat category ~no_existentials new_env pat ty
)
in
let patl = List.map2 type_pat spatl expected_tys in
@ -1733,10 +1822,11 @@ let type_pattern_list no_existentials env spatl scope expected_tys allow =
let type_class_arg_pattern cl_num val_env met_env l spat =
reset_pattern None false;
let nv = newvar () in
let pat = type_pat ~no_existentials:In_class_args (ref val_env) spat nv in
let pat =
type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in
if has_variants pat then begin
Parmatch.pressure_variants val_env [pat];
iter_pattern finalize_variant pat
finalize_variants pat;
end;
List.iter (fun f -> f()) (get_ref pattern_force);
if is_optional l then unify_pat val_env pat (type_option (newvar ()));
@ -1767,7 +1857,8 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
in
reset_pattern None false;
let nv = newvar() in
let pat = type_pat ~no_existentials:In_self_pattern (ref val_env) spat nv in
let pat =
type_pat Value ~no_existentials:In_self_pattern (ref val_env) spat nv in
List.iter (fun f -> f()) (get_ref pattern_force);
let meths = ref Meths.empty in
let vars = ref Vars.empty in
@ -1840,14 +1931,11 @@ let rec is_nonexpansive exp =
(* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
care if there are exception patterns. But the previous version enforced
that there be none, so... *)
let contains_exception_pat p =
let res = ref false in
iter_pattern (fun p ->
let contains_exception_pat pat =
exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
match p.pat_desc with
| Tpat_exception _ -> res := true
| _ -> ()
) p;
!res
| Tpat_exception _ -> true
| _ -> false } pat
in
is_nonexpansive e &&
List.for_all
@ -2231,12 +2319,11 @@ let contains_polymorphic_variant p =
| _ -> false)
p
let contains_gadt cp =
exists_pattern
(function
| {pat_desc = Tpat_construct (_, cd, _)} when cd.cstr_generalized -> true
| _ -> false)
cp
let contains_gadt p =
exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
match p.pat_desc with
| Tpat_construct (_, cd, _) when cd.cstr_generalized -> true
| _ -> false } p
(* There are various things that we need to do in presence of GADT constructors
that aren't required if there are none.
@ -2251,8 +2338,9 @@ let may_contain_gadts p =
p
let check_absent_variant env =
iter_pattern
(function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
iter_general_pattern { f = fun (type k) (pat : k general_pattern) ->
match pat.pat_desc with
| Tpat_variant (s, arg, row) ->
let row = row_repr !row in
if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
row.row_fields
@ -2266,7 +2354,7 @@ let check_absent_variant env =
(* Should fail *)
unify_pat env {pat with pat_type = newty (Tvariant row')}
(correct_levels pat.pat_type)
| _ -> ())
| _ -> () }
(* Getting proper location of already typed expressions.
@ -2532,9 +2620,7 @@ and type_expect_
if maybe_expansive arg then lower_contravariant env arg.exp_type;
generalize arg.exp_type;
let cases, partial =
type_cases ~exception_allowed:true env arg.exp_type ty_expected true loc
caselist
in
type_cases Computation env arg.exp_type ty_expected true loc caselist in
re {
exp_desc = Texp_match(arg, cases, partial);
exp_loc = loc; exp_extra = [];
@ -2544,7 +2630,7 @@ and type_expect_
| Pexp_try(sbody, caselist) ->
let body = type_expect env sbody ty_expected_explained in
let cases, _ =
type_cases env Predef.type_exn ty_expected false loc caselist in
type_cases Value env Predef.type_exn ty_expected false loc caselist in
re {
exp_desc = Texp_try(body, cases);
exp_loc = loc; exp_extra = [];
@ -3399,7 +3485,7 @@ and type_expect_
let exp, ands = type_andops env slet.pbop_exp sands ty_andops in
let scase = Ast_helper.Exp.case spat_params sbody in
let cases, partial =
type_cases env ty_params ty_func_result true loc [scase]
type_cases Value env ty_params ty_func_result true loc [scase]
in
let body =
match cases with
@ -3539,7 +3625,7 @@ and type_function ?in_function loc attrs env ty_expected_explained l caselist =
generalize_structure ty_res
end;
let cases, partial =
type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
type_cases Value ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
true loc caselist in
let not_function ty =
let ls, tvar = list_labels env ty in
@ -4274,8 +4360,11 @@ and type_statement ?explanation env sexp =
end
(* Typing of match cases *)
and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
loc caselist =
and type_cases
: type k . k pattern_category ->
?in_function:_ -> _ -> _ -> _ -> _ -> _ -> Parsetree.case list ->
k case list * partial
= fun category ?in_function env ty_arg ty_res partial_flag loc caselist ->
(* ty_arg is _fully_ generalized *)
let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
let contains_polyvars = List.exists contains_polymorphic_variant patterns in
@ -4325,7 +4414,7 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
end_def ();
generalize_structure ty_arg;
let (pat, ext_env, force, pvs, unpacks) =
type_pattern ?exception_allowed ~lev env pc_lhs scope ty_arg
type_pattern category ~lev env pc_lhs scope ty_arg
in
pattern_force := force @ !pattern_force;
let pat =
@ -4343,7 +4432,7 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
branch_env = ext_env;
pat_vars = pvs;
unpacks;
contains_gadt = contains_gadt pat; }
contains_gadt = contains_gadt (as_comp_pattern category pat); }
)
caselist in
let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
@ -4365,8 +4454,9 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
unify_pats ty_arg';
(* Check for polymorphic variants to close *)
if List.exists has_variants patl then begin
Parmatch.pressure_variants env patl;
List.iter (iter_pattern finalize_variant) patl
Parmatch.pressure_variants_in_computation_pattern env
(List.map (as_comp_pattern category) patl);
List.iter finalize_variants patl
end;
(* `Contaminating' unifications start here *)
List.iter (fun f -> f()) !pattern_force;
@ -4444,7 +4534,10 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
else ty_arg'
in
let val_cases, exn_cases = split_cases env cases in
let val_cases, exn_cases =
match category with
| Value -> (cases : value case list), []
| Computation -> split_cases env cases in
if val_cases = [] && exn_cases <> [] then
raise (Error (loc, env, No_value_clauses));
let partial =
@ -4455,7 +4548,7 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
in
let unused_check delayed =
List.iter (fun { typed_pat; branch_env; _ } ->
check_absent_variant branch_env typed_pat
check_absent_variant branch_env (as_comp_pattern category typed_pat)
) half_typed_cases;
if delayed then (begin_def (); init_def lev);
check_unused ~lev env ty_arg_check val_cases ;
@ -4515,7 +4608,7 @@ and type_let
spat_sexp_list in
let nvs = List.map (fun _ -> newvar ()) spatl in
let (pat_list, new_env, force, pvs, unpacks) =
type_pattern_list existential_context env spatl scope nvs allow in
type_pattern_list Value existential_context env spatl scope nvs allow in
let attrs_list = List.map fst spatl in
let is_recursive = (rec_flag = Recursive) in
(* If recursive, first unify with an approximation of the expression *)
@ -4535,7 +4628,7 @@ and type_let
(fun pat ->
if has_variants pat then begin
Parmatch.pressure_variants env [pat];
iter_pattern finalize_variant pat
finalize_variants pat
end)
pat_list;
(* Generalize the structure *)
@ -4866,7 +4959,8 @@ let report_expr_type_clash_hints exp diff =
| Some (Texp_constant const) -> report_literal_type_constraint const diff
| _ -> []
let report_pattern_type_clash_hints pat diff =
let report_pattern_type_clash_hints
(type k) (pat : k pattern_desc option) diff =
match pat with
| Some (Tpat_constant const) -> report_literal_type_constraint const diff
| _ -> []

12
typing/typecore.mli
View File

@ -78,7 +78,8 @@ val type_expression:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_class_arg_pattern:
string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
Typedtree.pattern *
(Ident.t * Ident.t * type_expr) list *
Env.t * Env.t
val type_self_pattern:
string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
@ -89,7 +90,7 @@ val type_self_pattern:
Env.t * Env.t * Env.t
val check_partial:
?lev:int -> Env.t -> type_expr ->
Location.t -> Typedtree.case list -> Typedtree.partial
Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial
val type_expect:
?in_function:(Location.t * type_expr) ->
Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression
@ -109,16 +110,15 @@ val reset_delayed_checks: unit -> unit
val force_delayed_checks: unit -> unit
val name_pattern : string -> Typedtree.pattern list -> Ident.t
val name_cases : string -> Typedtree.case list -> Ident.t
val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t
val self_coercion : (Path.t * Location.t list ref) list ref
type error =
| Constructor_arity_mismatch of Longident.t * int * int
| Label_mismatch of Longident.t * Ctype.Unification_trace.t
| Pattern_type_clash of
Ctype.Unification_trace.t * Typedtree.pattern_desc option
| Pattern_type_clash :
Ctype.Unification_trace.t * _ Typedtree.pattern_desc option -> error
| Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t
| Multiply_bound_variable of string
| Orpat_vars of Ident.t * Ident.t list

256
typing/typedtree.ml
View File

@ -25,8 +25,18 @@ type partial = Partial | Total
type attribute = Parsetree.attribute
type attributes = attribute list
type pattern =
{ pat_desc: pattern_desc;
type value = Value_pattern
type computation = Computation_pattern
type _ pattern_category =
| Value : value pattern_category
| Computation : computation pattern_category
type pattern = value general_pattern
and 'k general_pattern = 'k pattern_desc pattern_data
and 'a pattern_data =
{ pat_desc: 'a;
pat_loc: Location.t;
pat_extra : (pat_extra * Location.t * attribute list) list;
pat_type: type_expr;
@ -40,22 +50,33 @@ and pat_extra =
| Tpat_open of Path.t * Longident.t loc * Env.t
| Tpat_unpack
and pattern_desc =
Tpat_any
| Tpat_var of Ident.t * string loc
| Tpat_alias of pattern * Ident.t * string loc
| Tpat_constant of constant
| Tpat_tuple of pattern list
| Tpat_construct of
Longident.t loc * constructor_description * pattern list
| Tpat_variant of label * pattern option * row_desc ref
| Tpat_record of
(Longident.t loc * label_description * pattern) list *
closed_flag
| Tpat_array of pattern list
| Tpat_or of pattern * pattern * row_desc option
| Tpat_lazy of pattern
| Tpat_exception of pattern
and 'k pattern_desc =
(* value patterns *)
| Tpat_any : value pattern_desc
| Tpat_var : Ident.t * string loc -> value pattern_desc
| Tpat_alias :
value general_pattern * Ident.t * string loc -> value pattern_desc
| Tpat_constant : constant -> value pattern_desc
| Tpat_tuple : value general_pattern list -> value pattern_desc
| Tpat_construct :
Longident.t loc * constructor_description * value general_pattern list ->
value pattern_desc
| Tpat_variant :
label * value general_pattern option * row_desc ref ->
value pattern_desc
| Tpat_record :
(Longident.t loc * label_description * value general_pattern) list *
closed_flag ->
value pattern_desc
| Tpat_array : value general_pattern list -> value pattern_desc
| Tpat_lazy : value general_pattern -> value pattern_desc
(* computation patterns *)
| Tpat_value : value general_pattern -> computation pattern_desc
| Tpat_exception : value general_pattern -> computation pattern_desc
(* generic constructions *)
| Tpat_or :
'k general_pattern * 'k general_pattern * row_desc option ->
'k pattern_desc
and expression =
{ exp_desc: expression_desc;
@ -77,10 +98,10 @@ and expression_desc =
| Texp_constant of constant
| Texp_let of rec_flag * value_binding list * expression
| Texp_function of { arg_label : arg_label; param : Ident.t;
cases : case list; partial : partial; }
cases : value case list; partial : partial; }
| Texp_apply of expression * (arg_label * expression option) list
| Texp_match of expression * case list * partial
| Texp_try of expression * case list
| Texp_match of expression * computation case list * partial
| Texp_try of expression * value case list
| Texp_tuple of expression list
| Texp_construct of
Longident.t loc * constructor_description * expression list
@ -117,7 +138,7 @@ and expression_desc =
let_ : binding_op;
ands : binding_op list;
param : Ident.t;
body : case;
body : value case;
partial : partial;
}
| Texp_unreachable
@ -128,9 +149,9 @@ and meth =
Tmeth_name of string
| Tmeth_val of Ident.t
and case =
and 'k case =
{
c_lhs: pattern;
c_lhs: 'k general_pattern;
c_guard: expression option;
c_rhs: expression;
}
@ -592,58 +613,119 @@ and 'a class_infos =
(* Auxiliary functions over the a.s.t. *)
let shallow_iter_pattern_desc f = function
| Tpat_alias(p, _, _) -> f p
| Tpat_tuple patl -> List.iter f patl
| Tpat_construct(_, _, patl) -> List.iter f patl
| Tpat_variant(_, pat, _) -> Option.iter f pat
let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category =
function
| Tpat_alias _ -> Value
| Tpat_tuple _ -> Value
| Tpat_construct _ -> Value
| Tpat_variant _ -> Value
| Tpat_record _ -> Value
| Tpat_array _ -> Value
| Tpat_lazy _ -> Value
| Tpat_any -> Value
| Tpat_var _ -> Value
| Tpat_constant _ -> Value
| Tpat_value _ -> Computation
| Tpat_exception _ -> Computation
| Tpat_or(p1, p2, _) ->
begin match classify_pattern p1, classify_pattern p2 with
| Value, Value -> Value
| Computation, Computation -> Computation
end
and classify_pattern
: type k . k general_pattern -> k pattern_category
= fun pat ->
classify_pattern_desc pat.pat_desc
type pattern_action =
{ f : 'k . 'k general_pattern -> unit }
let shallow_iter_pattern_desc
: type k . pattern_action -> k pattern_desc -> unit
= fun f -> function
| Tpat_alias(p, _, _) -> f.f p
| Tpat_tuple patl -> List.iter f.f patl
| Tpat_construct(_, _, patl) -> List.iter f.f patl
| Tpat_variant(_, pat, _) -> Option.iter f.f pat
| Tpat_record (lbl_pat_list, _) ->
List.iter (fun (_, _, pat) -> f pat) lbl_pat_list
| Tpat_array patl -> List.iter f patl
| Tpat_or(p1, p2, _) -> f p1; f p2
| Tpat_lazy p -> f p
| Tpat_exception p -> f p
List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list
| Tpat_array patl -> List.iter f.f patl
| Tpat_lazy p -> f.f p
| Tpat_any
| Tpat_var _
| Tpat_constant _ -> ()
| Tpat_value p -> f.f p
| Tpat_exception p -> f.f p
| Tpat_or(p1, p2, _) -> f.f p1; f.f p2
let shallow_map_pattern_desc f d =
match d with
type pattern_transformation =
{ f : 'k . 'k general_pattern -> 'k general_pattern }
let shallow_map_pattern_desc
: type k . pattern_transformation -> k pattern_desc -> k pattern_desc
= fun f d -> match d with
| Tpat_alias (p1, id, s) ->
Tpat_alias (f p1, id, s)
Tpat_alias (f.f p1, id, s)
| Tpat_tuple pats ->
Tpat_tuple (List.map f pats)
Tpat_tuple (List.map f.f pats)
| Tpat_record (lpats, closed) ->
Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed)
Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed)
| Tpat_construct (lid, c,pats) ->
Tpat_construct (lid, c, List.map f pats)
Tpat_construct (lid, c, List.map f.f pats)
| Tpat_array pats ->
Tpat_array (List.map f pats)
| Tpat_lazy p1 -> Tpat_lazy (f p1)
| Tpat_exception p1 -> Tpat_exception (f p1)
Tpat_array (List.map f.f pats)
| Tpat_lazy p1 -> Tpat_lazy (f.f p1)
| Tpat_variant (x1, Some p1, x2) ->
Tpat_variant (x1, Some (f p1), x2)
| Tpat_or (p1,p2,path) ->
Tpat_or (f p1, f p2, path)
Tpat_variant (x1, Some (f.f p1), x2)
| Tpat_var _
| Tpat_constant _
| Tpat_any
| Tpat_variant (_,None,_) -> d
| Tpat_value p -> Tpat_value (f.f p)
| Tpat_exception p -> Tpat_exception (f.f p)
| Tpat_or (p1,p2,path) ->
Tpat_or (f.f p1, f.f p2, path)
let rec iter_pattern f p =
f p;
shallow_iter_pattern_desc (iter_pattern f) p.pat_desc
let rec iter_general_pattern
: type k . pattern_action -> k general_pattern -> unit
= fun f p ->
f.f p;
shallow_iter_pattern_desc
{ f = fun p -> iter_general_pattern f p }
p.pat_desc
let exists_pattern f p =
let iter_pattern (f : pattern -> unit) =
iter_general_pattern
{ f = fun (type k) (p : k general_pattern) ->
match classify_pattern p with
| Value -> f p
| Computation -> () }
type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
let exists_general_pattern (f : pattern_predicate) p =
let exception Found in
let raiser f x = if (f x) then raise Found else () in
match iter_pattern (raiser f) p with
match
iter_general_pattern
{ f = fun p -> if f.f p then raise Found else () }
p
with
| exception Found -> true
| () -> false
let exists_pattern (f : pattern -> bool) =
exists_general_pattern
{ f = fun (type k) (p : k general_pattern) ->
match classify_pattern p with
| Value -> f p
| Computation -> false }
(* List the identifiers bound by a pattern or a let *)
let rec iter_bound_idents f pat =
let rec iter_bound_idents
: type k . _ -> k general_pattern -> _
= fun f pat ->
match pat.pat_desc with
| Tpat_var (id,s) ->
f (id,s,pat.pat_type)
@ -654,7 +736,9 @@ let rec iter_bound_idents f pat =
(* Invariant : both arguments bind the same variables *)
iter_bound_idents f p1
| d ->
shallow_iter_pattern_desc (iter_bound_idents f) d
shallow_iter_pattern_desc
{ f = fun p -> iter_bound_idents f p }
d
let rev_pat_bound_idents_full pat =
let idents_full = ref [] in
@ -683,48 +767,54 @@ let let_bound_idents pat =
let alpha_var env id = List.assoc id env
let rec alpha_pat env p = match p.pat_desc with
| Tpat_var (id, s) -> (* note the ``Not_found'' case *)
{p with pat_desc =
try Tpat_var (alpha_var env id, s) with
| Not_found -> Tpat_any}
| Tpat_alias (p1, id, s) ->
let new_p = alpha_pat env p1 in
begin try
{p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
with
| Not_found -> new_p
end
| d ->
{p with pat_desc = shallow_map_pattern_desc (alpha_pat env) d}
let rec alpha_pat
: type k . _ -> k general_pattern -> k general_pattern
= fun env p -> match p.pat_desc with
| Tpat_var (id, s) -> (* note the ``Not_found'' case *)
{p with pat_desc =
try Tpat_var (alpha_var env id, s) with
| Not_found -> Tpat_any}
| Tpat_alias (p1, id, s) ->
let new_p = alpha_pat env p1 in
begin try
{p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
with
| Not_found -> new_p
end
| d ->
let pat_desc =
shallow_map_pattern_desc { f = fun p -> alpha_pat env p } d in
{p with pat_desc}
let mkloc = Location.mkloc
let mknoloc = Location.mknoloc
let split_pattern pat =
let combine_pattern_desc_opts ~into p1 p2 =
let combine_opts merge p1 p2 =
match p1, p2 with
| None, None -> None
| Some p, None
| None, Some p ->
Some p
| Some p1, Some p2 ->
(* The third parameter of [Tpat_or] is [Some _] only for "#typ"
patterns, which we do *not* expand. Hence we can put [None] here. *)
Some { into with pat_desc = Tpat_or (p1, p2, None) }
Some (merge p1 p2)
in
let rec split_pattern pat =
match pat.pat_desc with
| Tpat_or (p1, p2, None) ->
let vals1, exns1 = split_pattern p1 in
let vals2, exns2 = split_pattern p2 in
combine_pattern_desc_opts ~into:pat vals1 vals2,
(* We could change the pattern type for exception patterns to
[Predef.exn], but it doesn't really matter. *)
combine_pattern_desc_opts ~into:pat exns1 exns2
let into pat p1 p2 =
(* The third parameter of [Tpat_or] is [Some _] only for "#typ"
patterns, which we do *not* expand. Hence we can put [None] here. *)
{ pat with pat_desc = Tpat_or (p1, p2, None) } in
let rec split_pattern cpat =
match cpat.pat_desc with
| Tpat_value p ->
Some p, None
| Tpat_exception p ->
None, Some p
| _ ->
Some pat, None
| Tpat_or (cp1, cp2, _) ->
let vals1, exns1 = split_pattern cp1 in
let vals2, exns2 = split_pattern cp2 in
combine_opts (into cpat) vals1 vals2,
(* We could change the pattern type for exception patterns to
[Predef.exn], but it doesn't really matter. *)
combine_opts (into cpat) exns1 exns2
in
split_pattern pat

107
typing/typedtree.mli
View File

@ -35,8 +35,18 @@ type attributes = attribute list
(** {1 Core language} *)
type pattern =
{ pat_desc: pattern_desc;
type value = Value_pattern
type computation = Computation_pattern
type _ pattern_category =
| Value : value pattern_category
| Computation : computation pattern_category
type pattern = value general_pattern
and 'k general_pattern = 'k pattern_desc pattern_data
and 'a pattern_data =
{ pat_desc: 'a;
pat_loc: Location.t;
pat_extra : (pat_extra * Location.t * attributes) list;
pat_type: type_expr;
@ -62,52 +72,67 @@ and pat_extra =
; pat_extra = (Tpat_unpack, _, _) :: ... }
*)
and pattern_desc =
Tpat_any
and 'k pattern_desc =
(* value patterns *)
| Tpat_any : value pattern_desc
(** _ *)
| Tpat_var of Ident.t * string loc
| Tpat_var : Ident.t * string loc -> value pattern_desc
(** x *)
| Tpat_alias of pattern * Ident.t * string loc
| Tpat_alias :
value general_pattern * Ident.t * string loc -> value pattern_desc
(** P as a *)
| Tpat_constant of constant
| Tpat_constant : constant -> value pattern_desc
(** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
| Tpat_tuple of pattern list
| Tpat_tuple : value general_pattern list -> value pattern_desc
(** (P1, ..., Pn)
Invariant: n >= 2
*)
| Tpat_construct of
Longident.t loc * constructor_description * pattern list
| Tpat_construct :
Longident.t loc * constructor_description * value general_pattern list ->
value pattern_desc
(** C []
C P [P]
C (P1, ..., Pn) [P1; ...; Pn]
*)
| Tpat_variant of label * pattern option * row_desc ref
| Tpat_variant :
label * value general_pattern option * row_desc ref ->
value pattern_desc
(** `A (None)
`A P (Some P)
See {!Types.row_desc} for an explanation of the last parameter.
*)
| Tpat_record of
(Longident.t loc * label_description * pattern) list *
closed_flag
| Tpat_record :
(Longident.t loc * label_description * value general_pattern) list *
closed_flag ->
value pattern_desc
(** { l1=P1; ...; ln=Pn } (flag = Closed)
{ l1=P1; ...; ln=Pn; _} (flag = Open)
Invariant: n > 0
*)
| Tpat_array of pattern list
| Tpat_array : value general_pattern list -> value pattern_desc
(** [| P1; ...; Pn |] *)
| Tpat_or of pattern * pattern * row_desc option
| Tpat_lazy : value general_pattern -> value pattern_desc
(** lazy P *)
(* computation patterns *)
| Tpat_value : value general_pattern -> computation pattern_desc
(** P
Invariant: TODO
*)
| Tpat_exception : value general_pattern -> computation pattern_desc
(** exception P *)
(* generic constructions *)
| Tpat_or :
'k general_pattern * 'k general_pattern * row_desc option ->
'k pattern_desc
(** P1 | P2
[row_desc] = [Some _] when translating [Ppat_type _],
[None] otherwise.
*)
| Tpat_lazy of pattern
(** lazy P *)
| Tpat_exception of pattern
(** exception P *)
and expression =
{ exp_desc: expression_desc;
@ -142,7 +167,7 @@ and expression_desc =
let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive)
*)
| Texp_function of { arg_label : arg_label; param : Ident.t;
cases : case list; partial : partial; }
cases : value case list; partial : partial; }
(** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
See {!Parsetree} for more details.
@ -169,7 +194,7 @@ and expression_desc =
(Labelled "y", Some (Texp_constant Const_int 3))
])
*)
| Texp_match of expression * case list * partial
| Texp_match of expression * computation case list * partial
(** match E0 with
| P1 -> E1
| P2 | exception P3 -> E2
@ -178,7 +203,7 @@ and expression_desc =
[Texp_match (E0, [(P1, E1); (P2 | exception P3, E2);
(exception P4, E3)], _)]
*)
| Texp_try of expression * case list
| Texp_try of expression * value case list
(** try E with P1 -> E1 | ... | PN -> EN *)
| Texp_tuple of expression list
(** (E1, ..., EN) *)
@ -232,7 +257,7 @@ and expression_desc =
let_ : binding_op;
ands : binding_op list;
param : Ident.t;
body : case;
body : value case;
partial : partial;
}
| Texp_unreachable
@ -244,9 +269,9 @@ and meth =
Tmeth_name of string
| Tmeth_val of Ident.t
and case =
and 'k case =
{
c_lhs: pattern;
c_lhs: 'k general_pattern;
c_guard: expression option;
c_rhs: expression;
}
@ -718,12 +743,24 @@ and 'a class_infos =
(* Auxiliary functions over the a.s.t. *)
val shallow_iter_pattern_desc:
(pattern -> unit) -> pattern_desc -> unit
val shallow_map_pattern_desc:
(pattern -> pattern) -> pattern_desc -> pattern_desc
val classify_pattern_desc: 'k pattern_desc -> 'k pattern_category
val classify_pattern: 'k general_pattern -> 'k pattern_category
type pattern_action =
{ f : 'k . 'k general_pattern -> unit }
val shallow_iter_pattern_desc:
pattern_action -> 'k pattern_desc -> unit
type pattern_transformation =
{ f : 'k . 'k general_pattern -> 'k general_pattern }
val shallow_map_pattern_desc:
pattern_transformation -> 'k pattern_desc -> 'k pattern_desc
val iter_general_pattern: pattern_action -> 'k general_pattern -> unit
val iter_pattern: (pattern -> unit) -> pattern -> unit
type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
val exists_general_pattern: pattern_predicate -> 'k general_pattern -> bool
val exists_pattern: (pattern -> bool) -> pattern -> bool
val let_bound_idents: value_binding list -> Ident.t list
@ -731,14 +768,16 @@ val let_bound_idents_full:
value_binding list -> (Ident.t * string loc * type_expr) list
(** Alpha conversion of patterns *)
val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern
val alpha_pat:
(Ident.t * Ident.t) list -> 'k general_pattern -> 'k general_pattern
val mknoloc: 'a -> 'a Asttypes.loc
val mkloc: 'a -> Location.t -> 'a Asttypes.loc
val pat_bound_idents: pattern -> Ident.t list
val pat_bound_idents: 'k general_pattern -> Ident.t list
val pat_bound_idents_full:
pattern -> (Ident.t * string loc * type_expr) list
'k general_pattern -> (Ident.t * string loc * type_expr) list
(** Splits an or pattern into its value (left) and exception (right) parts. *)
val split_pattern : pattern -> pattern option * pattern option
val split_pattern:
computation general_pattern -> pattern option * pattern option

24
typing/untypeast.ml
View File

@ -24,8 +24,7 @@ type mapper = {
attribute: mapper -> T.attribute -> attribute;
attributes: mapper -> T.attribute list -> attribute list;
binding_op: mapper -> T.binding_op -> T.pattern -> binding_op;
case: mapper -> T.case -> case;
cases: mapper -> T.case list -> case list;
case: 'k . mapper -> 'k T.case -> case;
class_declaration: mapper -> T.class_declaration -> class_declaration;
class_description: mapper -> T.class_description -> class_description;
class_expr: mapper -> T.class_expr -> class_expr;
@ -55,7 +54,7 @@ type mapper = {
package_type: mapper -> T.package_type -> package_type;
open_declaration: mapper -> T.open_declaration -> open_declaration;
open_description: mapper -> T.open_description -> open_description;
pat: mapper -> T.pattern -> pattern;
pat: 'k . mapper -> 'k T.general_pattern -> pattern;
row_field: mapper -> T.row_field -> row_field;
object_field: mapper -> T.object_field -> object_field;
signature: mapper -> T.signature -> signature;
@ -290,7 +289,7 @@ let extension_constructor sub ext =
| Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
)
let pattern sub pat =
let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
let loc = sub.location sub pat.pat_loc in
(* todo: fix attributes on extras *)
let attrs = sub.attributes sub pat.pat_attributes in
@ -347,9 +346,11 @@ let pattern sub pat =
Ppat_record (List.map (fun (lid, _, pat) ->
map_loc sub lid, sub.pat sub pat) list, closed)
| Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
| Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
| Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
| Tpat_exception p -> Ppat_exception (sub.pat sub p)
| Tpat_value p -> (sub.pat sub p).ppat_desc
| Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
in
Pat.mk ~loc ~attrs desc
@ -369,9 +370,7 @@ let exp_extra sub (extra, loc, attrs) sexp =
in
Exp.mk ~loc ~attrs desc
let cases sub l = List.map (sub.case sub) l
let case sub {c_lhs; c_guard; c_rhs} =
let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} ->
{
pc_lhs = sub.pat sub c_lhs;
pc_guard = Option.map (sub.expr sub) c_guard;
@ -404,14 +403,14 @@ let expression sub exp =
Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
(* No label: it's a function. *)
| Texp_function { arg_label = Nolabel; cases; _; } ->
Pexp_function (sub.cases sub cases)
Pexp_function (List.map (sub.case sub) cases)
(* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
| Texp_function { arg_label = Labelled s | Optional s as label; cases;
_ } ->
let name = fresh_name s exp.exp_env in
Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
(sub.cases sub cases))
(List.map (sub.case sub) cases))
| Texp_apply (exp, list) ->
Pexp_apply (sub.expr sub exp,
List.fold_right (fun (label, expo) list ->
@ -420,9 +419,9 @@ let expression sub exp =
| Some exp -> (label, sub.expr sub exp) :: list
) list [])
| Texp_match (exp, cases, _) ->
Pexp_match (sub.expr sub exp, sub.cases sub cases)
Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases)
| Texp_try (exp, cases) ->
Pexp_try (sub.expr sub exp, sub.cases sub cases)
Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases)
| Texp_tuple list ->
Pexp_tuple (List.map (sub.expr sub) list)
| Texp_construct (lid, _, args) ->
@ -877,7 +876,6 @@ let default_mapper =
value_binding = value_binding;
constructor_declaration = constructor_declaration;
label_declaration = label_declaration;
cases = cases;
case = case;
location = location;
row_field = row_field ;

10
typing/untypeast.mli
View File

@ -20,10 +20,10 @@ val lident_of_path : Path.t -> Longident.t
type mapper = {
attribute: mapper -> Typedtree.attribute -> attribute;
attributes: mapper -> Typedtree.attribute list -> attribute list;
binding_op: mapper -> Typedtree.binding_op -> Typedtree.pattern
-> binding_op;
case: mapper -> Typedtree.case -> case;
cases: mapper -> Typedtree.case list -> case list;
binding_op:
mapper ->
Typedtree.binding_op -> Typedtree.pattern -> binding_op;
case: 'k . mapper -> 'k Typedtree.case -> case;
class_declaration: mapper -> Typedtree.class_declaration -> class_declaration;
class_description: mapper -> Typedtree.class_description -> class_description;
class_expr: mapper -> Typedtree.class_expr -> class_expr;
@ -58,7 +58,7 @@ type mapper = {
package_type: mapper -> Typedtree.package_type -> package_type;
open_declaration: mapper -> Typedtree.open_declaration -> open_declaration;
open_description: mapper -> Typedtree.open_description -> open_description;
pat: mapper -> Typedtree.pattern -> pattern;
pat: 'k . mapper -> 'k Typedtree.general_pattern -> pattern;
row_field: mapper -> Typedtree.row_field -> row_field;
object_field: mapper -> Typedtree.object_field -> object_field;
signature: mapper -> Typedtree.signature -> signature;