summaryrefslogtreecommitdiff
path: root/typing
diff options
context:
space:
mode:
Diffstat (limited to 'typing')
-rw-r--r--typing/btype.ml2
-rw-r--r--typing/cmt_format.ml4
-rw-r--r--typing/ctype.ml18
-rw-r--r--typing/includeclass.ml2
-rw-r--r--typing/oprint.ml2
-rw-r--r--typing/outcometree.mli2
-rw-r--r--typing/parmatch.ml117
-rw-r--r--typing/parmatch.mli6
-rw-r--r--typing/printtyp.ml6
-rw-r--r--typing/printtyped.ml329
-rw-r--r--typing/subst.ml4
-rw-r--r--typing/typeclass.ml292
-rw-r--r--typing/typeclass.mli1
-rw-r--r--typing/typecore.ml620
-rw-r--r--typing/typecore.mli10
-rw-r--r--typing/typedecl.ml236
-rw-r--r--typing/typedecl.mli14
-rw-r--r--typing/typedtree.ml282
-rw-r--r--typing/typedtree.mli277
-rw-r--r--typing/typedtreeIter.ml198
-rw-r--r--typing/typedtreeIter.mli16
-rw-r--r--typing/typedtreeMap.ml263
-rw-r--r--typing/typedtreeMap.mli10
-rw-r--r--typing/typemod.ml335
-rw-r--r--typing/typemod.mli2
-rw-r--r--typing/types.ml2
-rw-r--r--typing/types.mli2
-rw-r--r--typing/typetexp.ml109
-rw-r--r--typing/typetexp.mli5
29 files changed, 1796 insertions, 1370 deletions
diff --git a/typing/btype.ml b/typing/btype.ml
index 4f24372fb0..e6458f6502 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -367,7 +367,7 @@ let rec unmark_class_type =
List.iter unmark_type tyl; unmark_class_type cty
| Cty_signature sign ->
unmark_class_signature sign
- | Cty_fun (_, ty, cty) ->
+ | Cty_arrow (_, ty, cty) ->
unmark_type ty; unmark_class_type cty
diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml
index 9a01744822..9d117cd3f7 100644
--- a/typing/cmt_format.ml
+++ b/typing/cmt_format.ml
@@ -75,8 +75,8 @@ module ClearEnv = TypedtreeMap.MakeMap (struct
let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env }
let leave_expression e =
let exp_extra = List.map (function
- (Texp_open (ovf, path, lloc, env), loc) ->
- (Texp_open (ovf, path, lloc, keep_only_summary env), loc)
+ (Texp_open (ovf, path, lloc, env), loc, attrs) ->
+ (Texp_open (ovf, path, lloc, keep_only_summary env), loc, attrs)
| exp_extra -> exp_extra) e.exp_extra in
{ e with
exp_env = keep_only_summary e.exp_env;
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 845b926bad..f62cb5546f 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -367,7 +367,7 @@ let rec signature_of_class_type =
function
Cty_constr (_, _, cty) -> signature_of_class_type cty
| Cty_signature sign -> sign
- | Cty_fun (_, ty, cty) -> signature_of_class_type cty
+ | Cty_arrow (_, ty, cty) -> signature_of_class_type cty
let self_type cty =
repr (signature_of_class_type cty).cty_self
@@ -376,7 +376,7 @@ let rec class_type_arity =
function
Cty_constr (_, _, cty) -> class_type_arity cty
| Cty_signature _ -> 0
- | Cty_fun (_, _, cty) -> 1 + class_type_arity cty
+ | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty
(*******************************************)
@@ -1141,8 +1141,8 @@ let instance_class params cty =
cty_concr = sign.cty_concr;
cty_inher =
List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
- | Cty_fun (l, ty, cty) ->
- Cty_fun (l, copy ty, copy_class_type cty)
+ | Cty_arrow (l, ty, cty) ->
+ Cty_arrow (l, copy ty, copy_class_type cty)
in
let params' = List.map copy params in
let cty' = copy_class_type cty in
@@ -3196,7 +3196,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
moregen_clty true type_pairs env cty1 cty2
| _, Cty_constr (_, _, cty2) ->
moregen_clty true type_pairs env cty1 cty2
- | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
+ | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
end;
@@ -3331,7 +3331,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
equal_clty true type_pairs subst env cty1 cty2
| _, Cty_constr (_, _, cty2) ->
equal_clty true type_pairs subst env cty1 cty2
- | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
+ | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
end;
@@ -3457,7 +3457,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
(* Use moregeneral for class parameters, need to recheck everything to
keeps relationships (PR#4824) *)
let clty_params =
- List.fold_right (fun ty cty -> Cty_fun ("*",ty,cty)) in
+ List.fold_right (fun ty cty -> Cty_arrow ("*",ty,cty)) in
match_class_types ~trace:false env
(clty_params patt_params patt_type)
(clty_params subj_params subj_type)
@@ -4180,8 +4180,8 @@ let rec nondep_class_type env id =
nondep_class_type env id cty)
| Cty_signature sign ->
Cty_signature (nondep_class_signature env id sign)
- | Cty_fun (l, ty, cty) ->
- Cty_fun (l, nondep_type_rec env id ty, nondep_class_type env id cty)
+ | Cty_arrow (l, ty, cty) ->
+ Cty_arrow (l, nondep_type_rec env id ty, nondep_class_type env id cty)
let nondep_class_declaration env id decl =
assert (not (Path.isfree id decl.cty_path));
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 2f5aac18b4..9e3564b172 100644
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -36,7 +36,7 @@ open Ctype
(*
let rec hide_params = function
- Tcty_fun ("*", _, cty) -> hide_params cty
+ Tcty_arrow ("*", _, cty) -> hide_params cty
| cty -> cty
*)
diff --git a/typing/oprint.ml b/typing/oprint.ml
index b61d266709..31c2ec405f 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -305,7 +305,7 @@ let rec print_out_class_type ppf =
fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
in
fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
- | Octy_fun (lab, ty, cty) ->
+ | Octy_arrow (lab, ty, cty) ->
fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
print_out_type_2 ty print_out_class_type cty
| Octy_signature (self_ty, csil) ->
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 13b0e6f93d..19fc1c7446 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -66,7 +66,7 @@ and out_variant =
type out_class_type =
| Octy_constr of out_ident * out_type list
- | Octy_fun of string * out_type * out_class_type
+ | Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item =
| Ocsg_constraint of out_type * out_type
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 5490e097d2..efca422034 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -23,7 +23,9 @@ open Typedtree
let make_pat desc ty tenv =
{pat_desc = desc; pat_loc = Location.none; pat_extra = [];
- pat_type = ty ; pat_env = tenv }
+ pat_type = ty ; pat_env = tenv;
+ pat_attributes = [];
+ }
let omega = make_pat Tpat_any Ctype.none Env.empty
@@ -55,6 +57,8 @@ let const_compare x y =
match x,y with
| Const_float f1, Const_float f2 ->
Pervasives.compare (float_of_string f1) (float_of_string f2)
+ | Const_string (s1, _), Const_string (s2, _) ->
+ Pervasives.compare s1 s2
| _, _ -> Pervasives.compare x y
let records_args l1 l2 =
@@ -84,7 +88,7 @@ let rec compat p q =
| Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0
| 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
@@ -173,7 +177,7 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with
let pretty_const c = match c with
| Const_int i -> Printf.sprintf "%d" i
| Const_char c -> Printf.sprintf "%C" c
-| Const_string s -> Printf.sprintf "%S" s
+| Const_string (s, _) -> Printf.sprintf "%S" s
| Const_float f -> Printf.sprintf "%s" f
| Const_int32 i -> Printf.sprintf "%ldl" i
| Const_int64 i -> Printf.sprintf "%LdL" i
@@ -181,7 +185,7 @@ let pretty_const c = match c with
let rec pretty_val ppf v =
match v.pat_extra with
- (cstr,_) :: rem ->
+ (cstr, _loc, _attrs) :: rem ->
begin match cstr with
| Tpat_unpack ->
fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
@@ -197,13 +201,13 @@ let rec pretty_val ppf v =
| Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
| 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]) ->
@@ -232,19 +236,19 @@ let rec pretty_val ppf v =
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
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
@@ -304,7 +308,7 @@ let pretty_matrix (pss : matrix) =
(* 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
@@ -355,7 +359,7 @@ 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
@@ -363,7 +367,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with
| 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
@@ -384,9 +388,9 @@ 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 (lid, c,args,explicit_arity) ->
+ | Tpat_construct (lid, c,args) ->
make_pat
- (Tpat_construct (lid, c,omega_list args, explicit_arity))
+ (Tpat_construct (lid, 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))
@@ -471,10 +475,10 @@ let do_set_args erase_mutable q r = match q with
omegas args, closed))
q.pat_type q.pat_env::
rest
-| {pat_desc = Tpat_construct (lid, c,omegas, explicit_arity)} ->
+| {pat_desc = Tpat_construct (lid, c,omegas)} ->
let args,rest = read_args omegas r in
make_pat
- (Tpat_construct (lid, c,args, explicit_arity))
+ (Tpat_construct (lid, c,args))
q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_variant (l, omega, row)} ->
@@ -643,7 +647,7 @@ let row_of_pat pat =
let generalized_constructor x =
match x with
- ({pat_desc = Tpat_construct(_,c,_, _);pat_env=env},_) ->
+ ({pat_desc = Tpat_construct(_,c,_);pat_env=env},_) ->
c.cstr_generalized
| _ -> assert false
@@ -657,9 +661,9 @@ 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 *)
@@ -702,12 +706,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 _)},_,_)}
+| ({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
@@ -721,7 +725,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 _)},_,_)}
+ 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
@@ -752,7 +756,7 @@ let complete_tags nconsts nconstrs tags =
let pat_of_constr ex_pat cstr =
{ex_pat with pat_desc =
Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"),
- cstr,omegas cstr.cstr_arity,false)}
+ cstr,omegas cstr.cstr_arity)}
let rec pat_of_constrs ex_pat = function
| [] -> raise Empty
@@ -789,7 +793,7 @@ let rec map_filter f =
(* Sends back a pattern that complements constructor tags all_tag *)
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, _) =
@@ -822,22 +826,22 @@ let build_other_constant proj make first next p env =
let build_other ext env = match env with
| ({pat_desc =
- Tpat_construct (lid, ({cstr_tag=Cstr_exception _} as c),_,_)},_)
+ Tpat_construct (lid, ({cstr_tag=Cstr_exception _} as c),_)},_)
::_ ->
make_pat
(Tpat_construct
(lid, {c with
cstr_tag=(Cstr_exception
(Path.Pident (Ident.create "*exception*"), Location.none))},
- [], false))
+ []))
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)
@@ -922,9 +926,9 @@ let build_other ext env = match env with
0n Nativeint.succ p env
| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
build_other_constant
- (function Tpat_constant(Const_string s) -> String.length s
+ (function Tpat_constant(Const_string (s, _)) -> String.length s
| _ -> assert false)
- (function i -> Tpat_constant(Const_string(String.make i '*')))
+ (function i -> Tpat_constant(Const_string(String.make i '*', None)))
0 succ p env
| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
build_other_constant
@@ -954,7 +958,7 @@ let build_other_gadt ext env =
match env with
| ({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
@@ -978,7 +982,7 @@ let rec has_instance p = match p.pat_desc with
| 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 ->
+ | 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
@@ -1125,7 +1129,7 @@ let print_pat pat =
| Tpat_any -> "_"
| Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p)
| Tpat_constant n -> "0"
- | Tpat_construct (_, lid, _, _) ->
+ | Tpat_construct (_, lid, _) ->
Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
| Tpat_lazy p ->
Printf.sprintf "(lazy %s)" (string_of_pat p)
@@ -1516,7 +1520,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) -> const_compare c1 c2 = 0
- | 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)
@@ -1566,10 +1570,10 @@ 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 (lid, c1,ps1,_), Tpat_construct (_,c2,ps2,_)
+| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2)
when c1.cstr_tag = c2.cstr_tag ->
let rs = lubs ps1 ps2 in
- make_pat (Tpat_construct (lid, c1,rs, false))
+ make_pat (Tpat_construct (lid, c1,rs))
p.pat_type p.pat_env
| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
when l1=l2 ->
@@ -1634,19 +1638,10 @@ let pressure_variants tdefs patl =
about guarded patterns
*)
-let has_guard act = match act.exp_desc with
-| Texp_when(_, _) -> true
-| _ -> false
-
-
let rec initial_matrix = function
[] -> []
- | (pat, act) :: rem ->
- if has_guard act
- then
- initial_matrix rem
- else
- [pat] :: initial_matrix rem
+ | {c_guard=Some _} :: rem -> initial_matrix rem
+ | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
(******************************************)
(* Look for a row that matches some value *)
@@ -1668,8 +1663,8 @@ let rec initial_all no_guard = function
raise NoGuard
else
[]
- | (pat, act) :: rem ->
- ([pat], pat.pat_loc) :: initial_all (no_guard && not (has_guard act)) rem
+ | {c_lhs=pat; c_guard; _} :: rem ->
+ ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem
let rec do_filter_var = function
@@ -1732,9 +1727,7 @@ let check_partial_all v casel =
(* conversion from Typedtree.pattern to Parsetree.pattern list *)
module Conv = struct
open Parsetree
- let mkpat desc =
- {ppat_desc = desc;
- ppat_loc = Location.none}
+ let mkpat desc = Ast_helper.Pat.mk desc
let rec select : 'a list list -> 'a list list =
function
@@ -1772,14 +1765,14 @@ module Conv = struct
List.map
(fun lst -> mkpat (Ppat_tuple lst))
results
- | Tpat_construct (cstr_lid, cstr,lst,_) ->
+ | Tpat_construct (cstr_lid, cstr,lst) ->
let id = fresh cstr.cstr_name in
let lid = { cstr_lid with txt = Longident.Lident id } in
Hashtbl.add constrs id cstr;
let results = select (List.map loop lst) in
begin match lst with
[] ->
- [mkpat (Ppat_construct(lid, None, false))]
+ [mkpat (Ppat_construct(lid, None))]
| _ ->
List.map
(fun lst ->
@@ -1789,7 +1782,7 @@ module Conv = struct
| [x] -> Some x
| _ -> Some (mkpat (Ppat_tuple lst))
in
- mkpat (Ppat_construct(lid, arg, false)))
+ mkpat (Ppat_construct(lid, arg)))
results
end
| Tpat_variant(label,p_opt,row_desc) ->
@@ -1920,7 +1913,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
@@ -1928,7 +1921,7 @@ 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,_) ->
List.fold_left
@@ -1952,7 +1945,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
let do_check_fragile_param exhaust loc casel pss =
let exts =
List.fold_left
- (fun r (p,_) -> collect_paths_from_pat r p)
+ (fun r c -> collect_paths_from_pat r c.c_lhs)
[] casel in
match exts with
| [] -> ()
@@ -1980,7 +1973,7 @@ let check_unused tdefs casel =
if Warnings.is_active Warnings.Unused_match then
let rec do_rec pref = function
| [] -> ()
- | (q,act)::rem ->
+ | {c_lhs=q; c_guard} :: rem ->
let qs = [q] in
begin try
let pss =
@@ -2000,7 +1993,7 @@ let check_unused tdefs casel =
with Empty | Not_an_adt | Not_found | NoGuard -> assert false
end ;
- if has_guard act then
+ if c_guard <> None then
do_rec pref rem
else
do_rec ([q]::pref) rem in
@@ -2022,7 +2015,7 @@ 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
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index ffb0b906fd..947f16fa2c 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -53,13 +53,13 @@ val complete_constrs :
pattern -> constructor_tag list -> constructor_description list
val pressure_variants: Env.t -> pattern list -> unit
-val check_partial: Location.t -> (pattern * expression) list -> partial
+val check_partial: Location.t -> case list -> partial
val check_partial_gadt:
((string, constructor_description) Hashtbl.t ->
(string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
- Location.t -> (pattern * expression) list -> partial
-val check_unused: Env.t -> (pattern * expression) list -> unit
+ Location.t -> case list -> partial
+val check_unused: Env.t -> case list -> unit
(* Irrefutability tests *)
val irrefutable : pattern -> bool
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index f8077264f4..e3a841f829 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -938,7 +938,7 @@ let rec prepare_class_type params = function
in
List.iter (fun met -> mark_loops (fst (method_type met))) fields;
Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
- | Cty_fun (_, ty, cty) ->
+ | Cty_arrow (_, ty, cty) ->
mark_loops ty;
prepare_class_type params cty
@@ -984,7 +984,7 @@ let rec tree_of_class_type sch params =
List.fold_left (tree_of_metho sch sign.cty_concr) csil fields
in
Octy_signature (self_ty, List.rev csil)
- | Cty_fun (l, ty, cty) ->
+ | Cty_arrow (l, ty, cty) ->
let lab = if !print_labels && l <> "" || is_optional l then l else "" in
let ty =
if is_optional l then
@@ -993,7 +993,7 @@ let rec tree_of_class_type sch params =
| _ -> newconstr (Path.Pident(Ident.create "<hidden>")) []
else ty in
let tr = tree_of_typexp sch ty in
- Octy_fun (lab, tr, tree_of_class_type sch params cty)
+ Octy_arrow (lab, tr, tree_of_class_type sch params cty)
let class_type ppf cty =
reset ();
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 840a767365..c45a7dae63 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -56,7 +56,9 @@ let fmt_constant f x =
match x with
| Const_int (i) -> fprintf f "Const_int %d" i;
| Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
- | Const_string (s) -> fprintf f "Const_string %S" s;
+ | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
+ | Const_string (s, Some delim) ->
+ fprintf f "Const_string (%S,Some %S)" s delim;
| Const_float (s) -> fprintf f "Const_float %s" s;
| Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
| Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
@@ -81,11 +83,15 @@ let fmt_override_flag f x =
| Fresh -> fprintf f "Fresh";
;;
+let fmt_closed_flag f x =
+ match x with
+ | Closed -> fprintf f "Closed"
+ | Open -> fprintf f "Open"
+
let fmt_rec_flag f x =
match x with
| Nonrecursive -> fprintf f "Nonrec";
| Recursive -> fprintf f "Rec";
- | Default -> fprintf f "Default";
;;
let fmt_direction_flag f x =
@@ -130,8 +136,18 @@ let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;;
let bool i ppf x = line i ppf "%s\n" (string_of_bool x);;
let label i ppf x = line i ppf "label=\"%s\"\n" x;;
+let attributes i ppf l =
+ let i = i + 1 in
+ List.iter
+ (fun (s, arg) ->
+ line i ppf "attribute \"%s\"\n" s.txt;
+ Printast.structure (i + 1) ppf arg;
+ )
+ l
+
let rec core_type i ppf x =
line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
+ attributes i ppf x.ctyp_attributes;
let i = i+1 in
match x.ctyp_desc with
| Ttyp_any -> line i ppf "Ptyp_any\n";
@@ -148,16 +164,21 @@ let rec core_type i ppf x =
line i ppf "Ptyp_constr %a\n" fmt_path li;
list i core_type ppf l;
| Ttyp_variant (l, closed, low) ->
- line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed);
+ line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
list i label_x_bool_x_core_type_list ppf l;
option i (fun i -> list i string) ppf low
- | Ttyp_object (l) ->
- line i ppf "Ptyp_object\n";
- list i core_field_type ppf l;
- | Ttyp_class (li, _, l, low) ->
+ | Ttyp_object (l, c) ->
+ line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
+ let i = i + 1 in
+ List.iter
+ (fun (s, t) ->
+ line i ppf "method %s" s;
+ core_type (i + 1) ppf t
+ )
+ l
+ | Ttyp_class (li, _, l) ->
line i ppf "Ptyp_class %a\n" fmt_path li;
list i core_type ppf l;
- list i string ppf low
| Ttyp_alias (ct, s) ->
line i ppf "Ptyp_alias \"%s\"\n" s;
core_type i ppf ct;
@@ -173,28 +194,23 @@ and package_with i ppf (s, t) =
line i ppf "with type %a\n" fmt_longident s;
core_type i ppf t
-and core_field_type i ppf x =
- line i ppf "core_field_type %a\n" fmt_location x.field_loc;
- let i = i+1 in
- match x.field_desc with
- | Tcfield (s, ct) ->
- line i ppf "Pfield \"%s\"\n" s;
- core_type i ppf ct;
- | Tcfield_var -> line i ppf "Pfield_var\n";
-
and pattern 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, _) :: rem ->
+ | (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, _) :: 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, _), _) :: 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 }
| [] ->
match x.pat_desc with
@@ -207,10 +223,9 @@ and pattern i ppf x =
| Tpat_tuple (l) ->
line i ppf "Ppat_tuple\n";
list i pattern ppf l;
- | Tpat_construct (li, _, po, explicity_arity) ->
+ | Tpat_construct (li, _, po) ->
line i ppf "Ppat_construct %a\n" fmt_longident li;
list i pattern ppf po;
- bool i ppf explicity_arity;
| Tpat_variant (l, po, _) ->
line i ppf "Ppat_variant \"%s\"\n" l;
option i pattern ppf po;
@@ -228,24 +243,33 @@ and pattern i ppf x =
line i ppf "Ppat_lazy\n";
pattern i ppf p;
-and expression_extra i ppf x =
+and expression_extra i ppf x attrs =
match x with
- | Texp_constraint (cto1, cto2) ->
+ | Texp_constraint ct ->
+ line i ppf "Pexp_constraint\n";
+ attributes i ppf attrs;
+ core_type i ppf ct;
+ | Texp_coerce (cto1, cto2) ->
line i ppf "Pexp_constraint\n";
+ attributes i ppf attrs;
option i core_type ppf cto1;
- option i core_type ppf cto2;
+ core_type i ppf cto2;
| Texp_open (ovf, m, _, _) ->
line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
+ attributes i ppf attrs;
| Texp_poly cto ->
line i ppf "Pexp_poly\n";
+ attributes i ppf attrs;
option i core_type ppf cto;
| Texp_newtype s ->
line i ppf "Pexp_newtype \"%s\"\n" s;
+ attributes i ppf attrs;
and expression i ppf x =
line i ppf "expression %a\n" fmt_location x.exp_loc;
+ attributes i ppf x.exp_attributes;
let i =
- List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1)
+ List.fold_left (fun i (extra,_,attrs) -> expression_extra i ppf extra attrs; i+1)
(i+1) x.exp_extra
in
match x.exp_desc with
@@ -254,12 +278,12 @@ and expression i ppf x =
| Texp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
| Texp_let (rf, l, e) ->
line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
- list i pattern_x_expression_def ppf l;
+ list i value_binding ppf l;
expression i ppf e;
| Texp_function (p, l, _partial) ->
line i ppf "Pexp_function \"%s\"\n" p;
(* option i expression ppf eo; *)
- list i pattern_x_expression_case ppf l;
+ list i case ppf l;
| Texp_apply (e, l) ->
line i ppf "Pexp_apply\n";
expression i ppf e;
@@ -267,18 +291,17 @@ and expression i ppf x =
| Texp_match (e, l, partial) ->
line i ppf "Pexp_match\n";
expression i ppf e;
- list i pattern_x_expression_case ppf l;
+ list i case ppf l;
| Texp_try (e, l) ->
line i ppf "Pexp_try\n";
expression i ppf e;
- list i pattern_x_expression_case ppf l;
+ list i case ppf l;
| Texp_tuple (l) ->
line i ppf "Pexp_tuple\n";
list i expression ppf l;
- | Texp_construct (li, _, eo, b) ->
+ | Texp_construct (li, _, eo) ->
line i ppf "Pexp_construct %a\n" fmt_longident li;
list i expression ppf eo;
- bool i ppf b;
| Texp_variant (l, eo) ->
line i ppf "Pexp_variant \"%s\"\n" l;
option i expression ppf eo;
@@ -316,10 +339,6 @@ and expression i ppf x =
expression i ppf e1;
expression i ppf e2;
expression i ppf e3;
- | Texp_when (e1, e2) ->
- line i ppf "Pexp_when\n";
- expression i ppf e1;
- expression i ppf e2;
| Texp_send (e, Tmeth_name s, eo) ->
line i ppf "Pexp_send \"%s\"\n" s;
expression i ppf e;
@@ -342,8 +361,6 @@ and expression i ppf x =
| Texp_assert (e) ->
line i ppf "Pexp_assert";
expression i ppf e;
- | Texp_assertfalse ->
- line i ppf "Pexp_assertfalse";
| Texp_lazy (e) ->
line i ppf "Pexp_lazy";
expression i ppf e;
@@ -355,22 +372,24 @@ and expression i ppf x =
module_expr i ppf me
and value_description i ppf x =
- line i ppf "value_description\n";
+ line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location x.val_loc;
+ attributes i ppf x.val_attributes;
core_type (i+1) ppf x.val_desc;
list (i+1) string ppf x.val_prim;
-and string_option_underscore i ppf =
- function
- | Some x ->
- string i ppf x.txt
- | None ->
- string i ppf "_"
+and type_parameter i ppf (x, _variance) =
+ match x with
+ | Some x ->
+ string i ppf x.txt
+ | None ->
+ string i ppf "_"
and type_declaration i ppf x =
- line i ppf "type_declaration %a\n" fmt_location x.typ_loc;
+ line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location x.typ_loc;
+ attributes i ppf x.typ_attributes;
let i = i+1 in
line i ppf "ptype_params =\n";
- list (i+1) string_option_underscore ppf x.typ_params;
+ list (i+1) type_parameter ppf x.typ_params;
line i ppf "ptype_cstrs =\n";
list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs;
line i ppf "ptype_kind =\n";
@@ -385,15 +404,14 @@ and type_kind i ppf x =
line i ppf "Ptype_abstract\n"
| Ttype_variant l ->
line i ppf "Ptype_variant\n";
- list (i+1) string_x_core_type_list_x_location ppf l;
+ list (i+1) constructor_decl ppf l;
| Ttype_record l ->
line i ppf "Ptype_record\n";
- list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l;
-
-and exception_declaration i ppf x = list i core_type ppf x
+ list (i+1) label_decl ppf l;
and class_type i ppf x =
line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+ attributes i ppf x.cltyp_attributes;
let i = i+1 in
match x.cltyp_desc with
| Tcty_constr (li, _, l) ->
@@ -402,8 +420,8 @@ and class_type i ppf x =
| Tcty_signature (cs) ->
line i ppf "Pcty_signature\n";
class_signature i ppf cs;
- | Tcty_fun (l, co, cl) ->
- line i ppf "Pcty_fun \"%s\"\n" l;
+ | Tcty_arrow (l, co, cl) ->
+ line i ppf "Pcty_arrow \"%s\"\n" l;
core_type i ppf co;
class_type i ppf cl;
@@ -413,35 +431,32 @@ and class_signature i ppf { csig_self = ct; csig_fields = l } =
list (i+1) class_type_field ppf l;
and class_type_field i ppf x =
- let loc = x.ctf_loc in
+ line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
+ let i = i+1 in
+ attributes i ppf x.ctf_attributes;
match x.ctf_desc with
- | Tctf_inher (ct) ->
- line i ppf "Pctf_inher\n";
+ | Tctf_inherit (ct) ->
+ line i ppf "Pctf_inherit\n";
class_type i ppf ct;
| Tctf_val (s, mf, vf, ct) ->
- line i ppf
- "Pctf_val \"%s\" %a %a %a\n" s
- fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
+ line i ppf "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+ fmt_virtual_flag vf;
core_type (i+1) ppf ct;
- | Tctf_virt (s, pf, ct) ->
- line i ppf
- "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+ | Tctf_method (s, pf, vf, ct) ->
+ line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf fmt_virtual_flag vf;
core_type (i+1) ppf ct;
- | Tctf_meth (s, pf, ct) ->
- line i ppf
- "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
- core_type (i+1) ppf ct;
- | Tctf_cstr (ct1, ct2) ->
- line i ppf "Pctf_cstr %a\n" fmt_location loc;
- core_type i ppf ct1;
- core_type i ppf ct2;
+ | Tctf_constraint (ct1, ct2) ->
+ line i ppf "Pctf_constraint\n";
+ core_type (i+1) ppf ct1;
+ core_type (i+1) ppf ct2;
and class_description i ppf x =
line i ppf "class_description %a\n" fmt_location x.ci_loc;
+ attributes i ppf x.ci_attributes;
let i = i+1 in
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
line i ppf "pci_params =\n";
- string_list_x_location (i+1) ppf x.ci_params;
+ cl_type_parameters (i+1) ppf x.ci_params;
line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
line i ppf "pci_expr =\n";
class_type (i+1) ppf x.ci_expr;
@@ -451,13 +466,14 @@ and class_type_declaration i ppf x =
let i = i+1 in
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
line i ppf "pci_params =\n";
- string_list_x_location (i+1) ppf x.ci_params;
+ cl_type_parameters (i+1) ppf x.ci_params;
line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
line i ppf "pci_expr =\n";
class_type (i+1) ppf x.ci_expr;
and class_expr i ppf x =
line i ppf "class_expr %a\n" fmt_location x.cl_loc;
+ attributes i ppf x.cl_attributes;
let i = i+1 in
match x.cl_desc with
| Tcl_ident (li, _, l) ->
@@ -478,7 +494,7 @@ and class_expr i ppf x =
list i label_x_expression ppf l;
| Tcl_let (rf, l1, l2, ce) ->
line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
- list i pattern_x_expression_def ppf l1;
+ list i value_binding ppf l1;
list i ident_x_loc_x_expression_def ppf l2;
class_expr i ppf ce;
| Tcl_constraint (ce, Some ct, _, _, _) ->
@@ -488,7 +504,7 @@ and class_expr i ppf x =
| Tcl_constraint (_, None, _, _, _) -> assert false
(* TODO : is it possible ? see parsetree *)
-and class_structure i ppf { cstr_pat = p; cstr_fields = l } =
+and class_structure i ppf { cstr_self = p; cstr_fields = l } =
line i ppf "class_structure\n";
pattern (i+1) ppf p;
list (i+1) class_field ppf l;
@@ -530,13 +546,14 @@ and class_declaration i ppf x =
let i = i+1 in
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
line i ppf "pci_params =\n";
- string_list_x_location (i+1) ppf x.ci_params;
+ cl_type_parameters (i+1) ppf x.ci_params;
line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
line i ppf "pci_expr =\n";
class_expr (i+1) ppf x.ci_expr;
and module_type i ppf x =
line i ppf "module_type %a\n" fmt_location x.mty_loc;
+ attributes i ppf x.mty_attributes;
let i = i+1 in
match x.mty_desc with
| Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li;
@@ -561,42 +578,56 @@ and signature_item i ppf x =
line i ppf "signature_item %a\n" fmt_location x.sig_loc;
let i = i+1 in
match x.sig_desc with
- | Tsig_value (s, _, vd) ->
- line i ppf "Psig_value \"%a\"\n" fmt_ident s;
+ | Tsig_value vd ->
+ line i ppf "Psig_value\n";
value_description i ppf vd;
- | Tsig_type (l) ->
+ | Tsig_type l ->
line i ppf "Psig_type\n";
- list i string_x_type_declaration ppf l;
- | Tsig_exception (s, _, ed) ->
- line i ppf "Psig_exception \"%a\"\n" fmt_ident s;
- exception_declaration i ppf ed.exn_params;
- | Tsig_module (s, _, mt) ->
- line i ppf "Psig_module \"%a\"\n" fmt_ident s;
- module_type i ppf mt;
+ list i type_declaration ppf l;
+ | Tsig_exception cd ->
+ line i ppf "Psig_exception\n";
+ constructor_decl i ppf cd
+ | Tsig_module md ->
+ line i ppf "Psig_module \"%a\"\n" fmt_ident md.md_id;
+ attributes i ppf md.md_attributes;
+ module_type i ppf md.md_type
| Tsig_recmodule decls ->
line i ppf "Psig_recmodule\n";
- list i string_x_module_type ppf decls;
- | Tsig_modtype (s, _, md) ->
- line i ppf "Psig_modtype \"%a\"\n" fmt_ident s;
- modtype_declaration i ppf md;
- | Tsig_open (ovf, li,_) ->
- line i ppf "Psig_open %a %a\n" fmt_override_flag ovf fmt_path li;
- | Tsig_include (mt, _) ->
+ list i module_declaration ppf decls;
+ | Tsig_modtype x ->
+ line i ppf "Psig_modtype \"%a\"\n" fmt_ident x.mtd_id;
+ attributes i ppf x.mtd_attributes;
+ modtype_declaration i ppf x.mtd_type
+ | Tsig_open (ovf, li,_,attrs) ->
+ line i ppf "Psig_open %a %a\n" fmt_override_flag ovf fmt_path li;
+ attributes i ppf attrs
+ | Tsig_include (mt, _, attrs) ->
line i ppf "Psig_include\n";
- module_type i ppf mt;
+ attributes i ppf attrs;
+ module_type i ppf mt
| Tsig_class (l) ->
line i ppf "Psig_class\n";
list i class_description ppf l;
| Tsig_class_type (l) ->
line i ppf "Psig_class_type\n";
list i class_type_declaration ppf l;
+ | Tsig_attribute (s, arg) ->
+ line i ppf "Psig_attribute \"%s\"\n" s.txt;
+ Printast.structure i ppf arg
-and modtype_declaration i ppf x =
- match x with
- | Tmodtype_abstract -> line i ppf "Pmodtype_abstract\n";
- | Tmodtype_manifest (mt) ->
- line i ppf "Pmodtype_manifest\n";
- module_type (i+1) ppf mt;
+and module_declaration i ppf md =
+ line i ppf "%a" fmt_ident md.md_id;
+ attributes i ppf md.md_attributes;
+ module_type (i+1) ppf md.md_type;
+
+and module_binding i ppf x =
+ line i ppf "%a\n" fmt_ident x.mb_id;
+ attributes i ppf x.mb_attributes;
+ module_expr (i+1) ppf x.mb_expr
+
+and modtype_declaration i ppf = function
+ | None -> line i ppf "#abstract"
+ | Some mt -> module_type (i + 1) ppf mt
and with_constraint i ppf x =
match x with
@@ -611,6 +642,7 @@ and with_constraint i ppf x =
and module_expr i ppf x =
line i ppf "module_expr %a\n" fmt_location x.mod_loc;
+ attributes i ppf x.mod_attributes;
let i = i+1 in
match x.mod_desc with
| Tmod_ident (li,_) -> line i ppf "Pmod_ident %a\n" fmt_path li;
@@ -643,47 +675,51 @@ and structure_item i ppf x =
line i ppf "structure_item %a\n" fmt_location x.str_loc;
let i = i+1 in
match x.str_desc with
- | Tstr_eval (e) ->
+ | Tstr_eval (e, attrs) ->
line i ppf "Pstr_eval\n";
+ attributes i ppf attrs;
expression i ppf e;
| Tstr_value (rf, l) ->
line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
- list i pattern_x_expression_def ppf l;
- | Tstr_primitive (s, _, vd) ->
- line i ppf "Pstr_primitive \"%a\"\n" fmt_ident s;
+ list i value_binding ppf l;
+ | Tstr_primitive vd ->
+ line i ppf "Pstr_primitive\n";
value_description i ppf vd;
| Tstr_type l ->
line i ppf "Pstr_type\n";
- list i string_x_type_declaration ppf l;
- | Tstr_exception (s, _, ed) ->
- line i ppf "Pstr_exception \"%a\"\n" fmt_ident s;
- exception_declaration i ppf ed.exn_params;
- | Tstr_exn_rebind (s, _, li, _) ->
+ list i type_declaration ppf l;
+ | Tstr_exception cd ->
+ line i ppf "Pstr_exception\n";
+ constructor_decl i ppf cd;
+ | Tstr_exn_rebind (s, _, li, _, attrs) ->
line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li;
- | Tstr_module (s, _, me) ->
- line i ppf "Pstr_module \"%a\"\n" fmt_ident s;
- module_expr i ppf me;
+ attributes i ppf attrs
+ | Tstr_module x ->
+ line i ppf "Pstr_module\n";
+ module_binding i ppf x
| Tstr_recmodule bindings ->
line i ppf "Pstr_recmodule\n";
- list i string_x_modtype_x_module ppf bindings;
- | Tstr_modtype (s, _, mt) ->
- line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s;
- module_type i ppf mt;
- | Tstr_open (ovf, li, _) ->
- line i ppf "Pstr_open %a %a\n" fmt_override_flag ovf fmt_path li;
+ list i module_binding ppf bindings
+ | Tstr_modtype x ->
+ line i ppf "Pstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
+ attributes i ppf x.mtd_attributes;
+ modtype_declaration i ppf x.mtd_type
+ | Tstr_open (ovf, li, _, attrs) ->
+ line i ppf "Pstr_open %a %a\n" fmt_override_flag ovf fmt_path li;
+ attributes i ppf attrs
| Tstr_class (l) ->
line i ppf "Pstr_class\n";
list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l);
| Tstr_class_type (l) ->
line i ppf "Pstr_class_type\n";
list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
- | Tstr_include (me, _) ->
+ | Tstr_include (me, _, attrs) ->
line i ppf "Pstr_include";
- module_expr i ppf me
-
-and string_x_type_declaration i ppf (s, _, td) =
- ident i ppf s;
- type_declaration (i+1) ppf td;
+ attributes i ppf attrs;
+ module_expr i ppf me;
+ | Tstr_attribute (s, arg) ->
+ line i ppf "Pstr_attribute \"%s\"\n" s.txt;
+ Printast.structure i ppf arg
and string_x_module_type i ppf (s, _, mty) =
ident i ppf s;
@@ -703,32 +739,45 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
-and string_x_core_type_list_x_location i ppf (s, _, l, r_opt) =
- line i ppf "\"%a\"\n" fmt_ident s;
- list (i+1) core_type ppf l;
-(* option (i+1) core_type ppf r_opt; *)
+and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attributes} =
+ line i ppf "%a\n" fmt_location cd_loc;
+ attributes i ppf cd_attributes;
+ line (i+1) ppf "%a\n" fmt_ident cd_id;
+ list (i+1) core_type ppf cd_args;
+ option (i+1) core_type ppf cd_res
-and string_x_mutable_flag_x_core_type_x_location i ppf (s, _, mf, ct, loc) =
- line i ppf "\"%a\" %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_location loc;
- core_type (i+1) ppf ct;
+and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} =
+ line i ppf "%a\n" fmt_location ld_loc;
+ attributes i ppf ld_attributes;
+ line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
+ line (i+1) ppf "%a" fmt_ident ld_id;
+ core_type (i+1) ppf ld_type
+
+and cl_type_parameters i ppf l =
+ line i ppf "<params>\n";
+ list (i+1) cl_type_parameter ppf l;
-and string_list_x_location i ppf (l, loc) =
- line i ppf "<params> %a\n" fmt_location loc;
- list (i+1) string_loc ppf l;
+and cl_type_parameter i ppf (x, _variance) =
+ string_loc i ppf x
and longident_x_pattern i ppf (li, _, p) =
line i ppf "%a\n" fmt_longident li;
pattern (i+1) ppf p;
-and pattern_x_expression_case i ppf (p, e) =
+and case i ppf {c_lhs; c_guard; c_rhs} =
line i ppf "<case>\n";
- pattern (i+1) ppf p;
- expression (i+1) ppf e;
-
-and pattern_x_expression_def i ppf (p, e) =
+ pattern (i+1) ppf c_lhs;
+ begin match c_guard with
+ | None -> ()
+ | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+ end;
+ expression (i+1) ppf c_rhs;
+
+and value_binding i ppf x =
line i ppf "<def>\n";
- pattern (i+1) ppf p;
- expression (i+1) ppf e;
+ attributes (i+1) ppf x.vb_attributes;
+ pattern (i+1) ppf x.vb_pat;
+ expression (i+1) ppf x.vb_expr
and string_x_expression i ppf (s, _, e) =
line i ppf "<override> \"%a\"\n" fmt_path s;
diff --git a/typing/subst.ml b/typing/subst.ml
index a8d25fb182..70919b60fc 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -212,8 +212,8 @@ let rec class_type s =
Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty)
| Cty_signature sign ->
Cty_signature (class_signature s sign)
- | Cty_fun (l, ty, cty) ->
- Cty_fun (l, typexp s ty, class_type s cty)
+ | Cty_arrow (l, ty, cty) ->
+ Cty_arrow (l, typexp s ty, class_type s cty)
let class_declaration s decl =
let decl =
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 707440ea06..fa9ba280f3 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -46,19 +46,14 @@ type error =
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
| Duplicate of string * string
+ | Extension of string
exception Error of Location.t * Env.t * error
open Typedtree
let ctyp desc typ env loc =
- { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env }
-let cltyp desc typ env loc =
- { cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env }
-let mkcf desc loc = { cf_desc = desc; cf_loc = loc }
-let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc }
-
-
+ { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] }
(**********************)
(* Useful constants *)
@@ -99,7 +94,7 @@ let rec generalize_class_type gen =
gen sty;
Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
List.iter (fun (_,tl) -> List.iter gen tl) inher
- | Cty_fun (_, ty, cty) ->
+ | Cty_arrow (_, ty, cty) ->
gen ty;
generalize_class_type gen cty
@@ -124,7 +119,7 @@ let rec constructor_type constr cty =
constructor_type constr cty
| Cty_signature sign ->
constr
- | Cty_fun (l, ty, cty) ->
+ | Cty_arrow (l, ty, cty) ->
Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
let rec class_body cty =
@@ -133,7 +128,7 @@ let rec class_body cty =
cty (* Only class bodies can be abbreviated *)
| Cty_signature sign ->
cty
- | Cty_fun (_, ty, cty) ->
+ | Cty_arrow (_, ty, cty) ->
class_body cty
let extract_constraints cty =
@@ -153,8 +148,8 @@ let rec abbreviate_class_type path params cty =
match cty with
Cty_constr (_, _, _) | Cty_signature _ ->
Cty_constr (path, params, cty)
- | Cty_fun (l, ty, cty) ->
- Cty_fun (l, ty, abbreviate_class_type path params cty)
+ | Cty_arrow (l, ty, cty) ->
+ Cty_arrow (l, ty, abbreviate_class_type path params cty)
let rec closed_class_type =
function
@@ -166,7 +161,7 @@ let rec closed_class_type =
Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
sign.cty_vars
true
- | Cty_fun (_, ty, cty) ->
+ | Cty_arrow (_, ty, cty) ->
Ctype.closed_schema ty
&&
closed_class_type cty
@@ -187,7 +182,7 @@ let rec limited_generalize rv =
sign.cty_vars;
List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
sign.cty_inher
- | Cty_fun (_, ty, cty) ->
+ | Cty_arrow (_, ty, cty) ->
Ctype.limited_generalize rv ty;
limited_generalize rv cty
@@ -297,6 +292,7 @@ let virtual_method val_env meths self_type lab priv sty loc =
let (_, ty') =
Ctype.filter_self_method val_env lab priv meths self_type
in
+ let sty = Ast_helper.Typ.force_poly sty in
let cty = transl_simple_type val_env false sty in
let ty = cty.ctyp_type in
begin
@@ -315,6 +311,7 @@ let declare_method val_env meths self_type lab priv sty loc =
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
in
+ let sty = Ast_helper.Typ.force_poly sty in
match sty.ptyp_desc, priv with
Ptyp_poly ([],sty'), Public ->
(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
@@ -347,15 +344,12 @@ let type_constraint val_env sty sty' loc =
end;
(cty, cty')
-let make_method self_loc cl_num expr =
- let mkpat d = { ppat_desc = d; ppat_loc = self_loc } in
- let mkid s = mkloc s self_loc in
- { pexp_desc =
- Pexp_function ("", None,
- [mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")),
- mkid ("self-" ^ cl_num))),
- expr]);
- pexp_loc = expr.pexp_loc }
+let make_method loc cl_num expr =
+ let open Ast_helper in
+ let mkid s = mkloc s loc in
+ Exp.fun_ ~loc:expr.pexp_loc "" None
+ (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
+ expr
(*******************************)
@@ -371,8 +365,9 @@ let add_val env loc lab (mut, virt, ty) val_sig =
let rec class_type_field env self_type meths
(fields, val_sig, concr_meths, inher) ctf =
let loc = ctf.pctf_loc in
+ let mkctf desc = { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } in
match ctf.pctf_desc with
- Pctf_inher sparent ->
+ Pctf_inherit sparent ->
let parent = class_type env sparent in
let inher =
match parent.cltyp_type with
@@ -385,34 +380,35 @@ let rec class_type_field env self_type meths
in
let val_sig =
Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
- (mkctf (Tctf_inher parent) loc :: fields,
+ (mkctf (Tctf_inherit parent) :: fields,
val_sig, concr_meths, inher)
| Pctf_val (lab, mut, virt, sty) ->
let cty = transl_simple_type env false sty in
let ty = cty.ctyp_type in
- (mkctf (Tctf_val (lab, mut, virt, cty)) loc :: fields,
+ (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher)
- | Pctf_virt (lab, priv, sty) ->
- let cty =
- declare_method env meths self_type lab priv sty ctf.pctf_loc
- in
- (mkctf (Tctf_virt (lab, priv, cty)) loc :: fields,
- val_sig, concr_meths, inher)
-
- | Pctf_meth (lab, priv, sty) ->
+ | Pctf_method (lab, priv, virt, sty) ->
let cty =
declare_method env meths self_type lab priv sty ctf.pctf_loc in
- (mkctf (Tctf_meth (lab, priv, cty)) loc :: fields,
- val_sig, Concr.add lab concr_meths, inher)
+ let concr_meths =
+ match virt with
+ | Concrete -> Concr.add lab concr_meths
+ | Virtual -> concr_meths
+ in
+ (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
+ val_sig, concr_meths, inher)
- | Pctf_cstr (sty, sty') ->
+ | Pctf_constraint (sty, sty') ->
let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in
- (mkctf (Tctf_cstr (cty, cty')) loc :: fields,
+ (mkctf (Tctf_constraint (cty, cty')) :: fields,
val_sig, concr_meths, inher)
-and class_signature env sty sign loc =
+ | Pctf_extension (s, _arg) ->
+ raise (Error (s.loc, env, Extension s.txt))
+
+and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
let meths = ref Meths.empty in
let self_cty = transl_simple_type env false sty in
let self_cty = { self_cty with
@@ -444,11 +440,18 @@ and class_signature env sty sign loc =
{ csig_self = self_cty;
csig_fields = fields;
csig_type = cty;
- csig_loc = loc;
}
and class_type env scty =
- let loc = scty.pcty_loc in
+ let cltyp desc typ =
+ {
+ cltyp_desc = desc;
+ cltyp_type = typ;
+ cltyp_loc = scty.pcty_loc;
+ cltyp_env = env;
+ cltyp_attributes = scty.pcty_attributes;
+ }
+ in
match scty.pcty_desc with
Pcty_constr (lid, styl) ->
let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
@@ -473,20 +476,21 @@ and class_type env scty =
) styl params
in
let typ = Cty_constr (path, params, clty) in
- cltyp (Tcty_constr ( path, lid , ctys)) typ env loc
+ cltyp (Tcty_constr ( path, lid , ctys)) typ
| Pcty_signature pcsig ->
- let clsig = class_signature env
- pcsig.pcsig_self pcsig.pcsig_fields pcsig.pcsig_loc in
+ let clsig = class_signature env pcsig in
let typ = Cty_signature clsig.csig_type in
- cltyp (Tcty_signature clsig) typ env loc
+ cltyp (Tcty_signature clsig) typ
- | Pcty_fun (l, sty, scty) ->
+ | Pcty_arrow (l, sty, scty) ->
let cty = transl_simple_type env false sty in
let ty = cty.ctyp_type in
let clty = class_type env scty in
- let typ = Cty_fun (l, ty, clty.cltyp_type) in
- cltyp (Tcty_fun (l, cty, clty)) typ env loc
+ let typ = Cty_arrow (l, ty, clty.cltyp_type) in
+ cltyp (Tcty_arrow (l, cty, clty)) typ
+ | Pcty_extension (s, _arg) ->
+ raise (Error (s.loc, env, Extension s.txt))
let class_type env scty =
delayed_meth_specs := [];
@@ -501,8 +505,9 @@ let rec class_field self_loc cl_num self_type meths vars
(val_env, met_env, par_env, fields, concr_meths, warn_vals, inher, local_meths, local_vals)
cf =
let loc = cf.pcf_loc in
+ let mkcf desc = { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes } in
match cf.pcf_desc with
- Pcf_inher (ovf, sparent, super) ->
+ Pcf_inherit (ovf, sparent, super) ->
let parent = class_expr cl_num val_env par_env sparent in
let inher =
match parent.cl_type with
@@ -544,11 +549,11 @@ let rec class_field self_loc cl_num self_type meths vars
(val_env, met_env, par_env)
in
(val_env, met_env, par_env,
- lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)) loc)
+ lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
:: fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
- | Pcf_valvirt (lab, mut, styp) ->
+ | Pcf_val (lab, mut, Cfk_virtual styp) ->
if !Clflags.principal then Ctype.begin_def ();
let cty = Typetexp.transl_simple_type val_env false styp in
let ty = cty.ctyp_type in
@@ -561,12 +566,12 @@ let rec class_field self_loc cl_num self_type meths vars
val_env met_env par_env loc
in
(val_env, met_env', par_env,
- lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty,
- met_env' == met_env)) loc)
- :: fields,
- concr_meths, warn_vals, inher, local_meths, local_vals)
+ lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
+ met_env == met_env')))
+ :: fields,
+ concr_meths, warn_vals, inher, local_meths, local_vals)
- | Pcf_val (lab, mut, ovf, sexp) ->
+ | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
if Concr.mem lab.txt local_vals then
raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
if Concr.mem lab.txt warn_vals then begin
@@ -592,20 +597,25 @@ let rec class_field self_loc cl_num self_type meths vars
val_env met_env par_env loc
in
(val_env, met_env', par_env,
- lazy (mkcf (Tcf_val (lab.txt, lab, mut, id,
- Tcfk_concrete exp, met_env' == met_env)) loc)
+ lazy (mkcf (Tcf_val (lab, mut, id,
+ Tcfk_concrete (ovf, exp), met_env == met_env')))
:: fields,
concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
Concr.add lab.txt local_vals)
- | Pcf_virt (lab, priv, sty) ->
+ | Pcf_method (lab, priv, Cfk_virtual sty) ->
let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
(val_env, met_env, par_env,
- lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)) loc)
+ lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
::fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
- | Pcf_meth (lab, priv, ovf, expr) ->
+ | Pcf_method (lab, priv, Cfk_concrete (ovf, expr)) ->
+ let expr =
+ match expr.pexp_desc with
+ | Pexp_poly _ -> expr
+ | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
+ in
if Concr.mem lab.txt local_meths then
raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
if Concr.mem lab.txt concr_meths then begin
@@ -622,6 +632,7 @@ let rec class_field self_loc cl_num self_type meths vars
Pexp_poly (sbody, sty) ->
begin match sty with None -> ()
| Some sty ->
+ let sty = Ast_helper.Typ.force_poly sty in
let cty' = Typetexp.transl_simple_type val_env false sty in
let ty' = cty'.ctyp_type in
Ctype.unify val_env ty' ty
@@ -654,22 +665,19 @@ let rec class_field self_loc cl_num self_type meths vars
vars := vars_local;
let texp = type_expect met_env meth_expr meth_type in
Ctype.end_def ();
- mkcf (Tcf_meth (lab.txt, lab, priv, Tcfk_concrete texp,
- match ovf with
- Override -> true
- | Fresh -> false)) loc
+ mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
end in
(val_env, met_env, par_env, field::fields,
Concr.add lab.txt concr_meths, warn_vals, inher,
Concr.add lab.txt local_meths, local_vals)
- | Pcf_constr (sty, sty') ->
+ | Pcf_constraint (sty, sty') ->
let (cty, cty') = type_constraint val_env sty sty' loc in
(val_env, met_env, par_env,
- lazy (mkcf (Tcf_constr (cty, cty')) loc) :: fields,
+ lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
- | Pcf_init expr ->
+ | Pcf_initializer expr ->
let expr = make_method self_loc cl_num expr in
let vars_local = !vars in
let field =
@@ -682,13 +690,16 @@ let rec class_field self_loc cl_num self_type meths vars
vars := vars_local;
let texp = type_expect met_env expr meth_type in
Ctype.end_def ();
- mkcf (Tcf_init texp) loc
+ mkcf (Tcf_initializer texp)
end in
(val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
inher, local_meths, local_vals)
+ | Pcf_extension (s, _arg) ->
+ raise (Error (s.loc, val_env, Extension s.txt))
+
and class_structure cl_num final val_env met_env loc
- { pcstr_pat = spat; pcstr_fields = str } =
+ { pcstr_self = spat; pcstr_fields = str } =
(* Environment for substructures *)
let par_env = met_env in
@@ -801,7 +812,7 @@ and class_structure cl_num final val_env met_env loc
let sign = if final then sign else
{sign with cty_self = Ctype.expand_head val_env public_self} in
{
- cstr_pat = pat;
+ cstr_self = pat;
cstr_fields = fields;
cstr_type = sign;
cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
@@ -834,44 +845,54 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_ident (path, lid, tyl);
cl_loc = scl.pcl_loc;
cl_type = clty';
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
in
let (vals, meths, concrs) = extract_constraints clty in
rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
cl_loc = scl.pcl_loc;
cl_type = clty';
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = []; (* attributes are kept on the inner cl node *)
+ }
| Pcl_structure cl_str ->
let (desc, ty) =
class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
rc {cl_desc = Tcl_structure desc;
cl_loc = scl.pcl_loc;
cl_type = Cty_signature ty;
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_fun (l, Some default, spat, sbody) ->
let loc = default.pexp_loc in
- let scases =
- [{ppat_loc = loc; ppat_desc = Ppat_construct (
- mknoloc (Longident.(Ldot (Lident"*predef*", "Some"))),
- Some{ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*sth*")},
- false)},
- {pexp_loc = loc; pexp_desc =
- Pexp_ident(mknoloc (Longident.Lident"*sth*"))};
- {ppat_loc = loc; ppat_desc =
- Ppat_construct(mknoloc (Longident.(Ldot (Lident"*predef*", "None"))),
- None, false)},
- default] in
+ let open Ast_helper in
+ let scases = [
+ Exp.case
+ (Pat.construct ~loc
+ (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+ (Some (Pat.var ~loc (mknoloc "*sth*"))))
+ (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
+
+ Exp.case
+ (Pat.construct ~loc
+ (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+ None)
+ default;
+ ]
+ in
let smatch =
- {pexp_loc = loc; pexp_desc =
- Pexp_match({pexp_loc = loc; pexp_desc =
- Pexp_ident(mknoloc (Longident.Lident"*opt*"))},
- scases)} in
+ Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+ scases
+ in
let sfun =
- {pcl_loc = scl.pcl_loc; pcl_desc =
- Pcl_fun(l, None,
- {ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*opt*")},
- {pcl_loc = scl.pcl_loc; pcl_desc =
- Pcl_let(Default, [spat, smatch], sbody)})}
+ Cl.fun_ ~loc:scl.pcl_loc
+ l None
+ (Pat.var ~loc (mknoloc "*opt*"))
+ (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
+ (* Note: we don't put the '#default' attribute, as it
+ is not detected for class-level let bindings. See #5975.*)
in
class_expr cl_num val_env met_env sfun
| Pcl_fun (l, None, spat, scl') ->
@@ -894,21 +915,25 @@ and class_expr cl_num val_env met_env scl =
Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.instance val_env' vd.val_type;
+ exp_attributes = []; (* check *)
exp_env = val_env'})
end
pv
in
let not_function = function
- Cty_fun _ -> false
+ Cty_arrow _ -> false
| _ -> true
in
let partial =
Parmatch.check_partial pat.pat_loc
- [pat, (* Dummy expression *)
- {exp_desc = Texp_constant (Asttypes.Const_int 1);
- exp_loc = Location.none; exp_extra = [];
- exp_type = Ctype.none;
- exp_env = Env.empty }]
+ [{c_lhs=pat;
+ c_guard=None;
+ c_rhs = (* Dummy expression *)
+ {exp_desc = Texp_constant (Asttypes.Const_int 1);
+ exp_loc = Location.none; exp_extra = [];
+ exp_type = Ctype.none;
+ exp_attributes = [];
+ exp_env = Env.empty }}]
in
Ctype.raise_nongen_level ();
let cl = class_expr cl_num val_env' met_env scl' in
@@ -918,9 +943,11 @@ and class_expr cl_num val_env met_env scl =
Warnings.Unerasable_optional_argument;
rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
cl_loc = scl.pcl_loc;
- cl_type = Cty_fun
+ cl_type = Cty_arrow
(l, Ctype.instance_def pat.pat_type, cl.cl_type);
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_apply (scl', sargs) ->
if !Clflags.principal then Ctype.begin_def ();
let cl = class_expr cl_num val_env met_env scl' in
@@ -930,7 +957,7 @@ and class_expr cl_num val_env met_env scl =
end;
let rec nonopt_labels ls ty_fun =
match ty_fun with
- | Cty_fun (l, _, ty_res) ->
+ | Cty_arrow (l, _, ty_res) ->
if Btype.is_optional l then nonopt_labels ls ty_res
else nonopt_labels (l::ls) ty_res
| _ -> ls
@@ -948,7 +975,7 @@ and class_expr cl_num val_env met_env scl =
in
let rec type_args args omitted ty_fun ty_fun0 sargs more_sargs =
match ty_fun, ty_fun0 with
- | Cty_fun (l, ty, ty_fun), Cty_fun (_, ty0, ty_fun0)
+ | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
when sargs <> [] || more_sargs <> [] ->
let name = Btype.label_name l
and optional =
@@ -1009,7 +1036,7 @@ and class_expr cl_num val_env met_env scl =
| [] ->
(List.rev args,
List.fold_left
- (fun ty_fun (l,ty) -> Cty_fun(l,ty,ty_fun))
+ (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
ty_fun0 omitted)
in
let (args, cty) =
@@ -1022,7 +1049,9 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_apply (cl, args);
cl_loc = scl.pcl_loc;
cl_type = cty;
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_let (rec_flag, sdefs, scl') ->
let (defs, val_env) =
try
@@ -1042,6 +1071,7 @@ and class_expr cl_num val_env met_env scl =
Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.instance val_env vd.val_type;
+ exp_attributes = [];
exp_env = val_env;
}
in
@@ -1064,7 +1094,9 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
cl_loc = scl.pcl_loc;
cl_type = cl.cl_type;
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_constraint (scl', scty) ->
Ctype.begin_class_def ();
let context = Typetexp.narrow () in
@@ -1090,7 +1122,11 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
cl_loc = scl.pcl_loc;
cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
+ | Pcl_extension (s, _arg) ->
+ raise (Error (s.loc, val_env, Extension s.txt))
(*******************************)
@@ -1114,7 +1150,7 @@ let rec approx_declaration cl =
let rec approx_description ct =
match ct.pcty_desc with
- Pcty_fun (l, _, ct) ->
+ Pcty_arrow (l, _, ct) ->
let arg =
if Btype.is_optional l then Ctype.instance_def var_option
else Ctype.newvar () in
@@ -1147,7 +1183,7 @@ let temp_abbrev loc env id arity =
let initial_env define_class approx
(res, env) (cl, id, ty_id, obj_id, cl_id) =
(* Temporary abbreviations *)
- let arity = List.length (fst cl.pci_params) in
+ let arity = List.length cl.pci_params in
let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in
let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in
@@ -1201,10 +1237,9 @@ let class_infos define_class kind
(* Introduce class parameters *)
let params =
try
- let params, loc = cl.pci_params in
- List.map (fun x -> enter_type_variable true loc x.txt) params
- with Already_bound ->
- raise(Error(snd cl.pci_params, env, Repeated_parameter))
+ List.map (fun (x, _v) -> enter_type_variable x) cl.pci_params
+ with Already_bound loc ->
+ raise(Error(loc, env, Repeated_parameter))
in
(* Allow self coercions (only for class declarations) *)
@@ -1410,19 +1445,19 @@ let final_decl env define_class
(id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr,
- { ci_variance = cl.pci_variance;
- ci_loc = cl.pci_loc;
+ { ci_loc = cl.pci_loc;
ci_virt = cl.pci_virt;
- ci_params = cl.pci_params;
+ ci_params = cl.pci_params;
(* TODO : check that we have the correct use of identifiers *)
- ci_id_name = cl.pci_name;
- ci_id_class = id;
- ci_id_class_type = ty_id;
- ci_id_object = obj_id;
- ci_id_typesharp = cl_id;
+ ci_id_name = cl.pci_name;
+ ci_id_class = id;
+ ci_id_class_type = ty_id;
+ ci_id_object = obj_id;
+ ci_id_typesharp = cl_id;
ci_expr = expr;
ci_decl = clty;
ci_type_decl = cltydef;
+ ci_attributes = cl.pci_attributes;
})
(* (cl.pci_variance, cl.pci_loc)) *)
@@ -1550,7 +1585,7 @@ let rec unify_parents env ty cl =
| Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
and unify_parents_struct env ty st =
List.iter
- (function {cf_desc = Tcf_inher (_, cl, _, _, _)} -> unify_parents env ty cl
+ (function {cf_desc = Tcf_inherit (_, cl, _, _, _)} -> unify_parents env ty cl
| _ -> ())
st.cstr_fields
@@ -1572,12 +1607,9 @@ let () =
(* Approximate the class declaration as class ['params] id = object end *)
let approx_class sdecl =
- let self' =
- { ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in
- let clty' =
- { pcty_desc = Pcty_signature { pcsig_self = self';
- pcsig_fields = []; pcsig_loc = Location.none };
- pcty_loc = sdecl.pci_expr.pcty_loc } in
+ let open Ast_helper in
+ let self' = Typ.any () in
+ let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
{ sdecl with pci_expr = clty' }
let approx_class_declarations env sdecls =
@@ -1743,6 +1775,8 @@ let report_error env ppf = function
| Duplicate (kind, name) ->
fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
kind name
+ | Extension s ->
+ fprintf ppf "Uninterpreted extension '%s'." s
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index 8ad2038821..abc8633bc3 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -104,6 +104,7 @@ type error =
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
| Duplicate of string * string
+ | Extension of string
exception Error of Location.t * Env.t * error
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 533b1d4ddd..c35cb162a6 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -63,6 +63,8 @@ type error =
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
| Unqualified_gadt_pattern of Path.t * string
+ | Invalid_interval
+ | Extension of string
exception Error of Location.t * Env.t * error
@@ -109,6 +111,9 @@ let rp node =
let fst3 (x, _, _) = x
let snd3 (_,x,_) = x
+let case lhs rhs =
+ {c_lhs = lhs; c_guard = None; c_rhs = rhs}
+
(* Upper approximation of free identifiers on the parse tree *)
let iter_expression f e =
@@ -116,19 +121,19 @@ let iter_expression f e =
let rec expr e =
f e;
match e.pexp_desc with
+ | Pexp_extension _ (* we don't iterate under extension point *)
| Pexp_ident _
- | Pexp_assertfalse
| Pexp_new _
| Pexp_constant _ -> ()
- | Pexp_function (_, eo, pel) ->
- may expr eo; List.iter (fun (_, e) -> expr e) pel
+ | Pexp_function pel -> List.iter case pel
+ | Pexp_fun (_, eo, _, e) -> may expr eo; expr e
| Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
- | Pexp_let (_, pel, e)
+ | Pexp_let (_, pel, e) -> expr e; List.iter binding pel
| Pexp_match (e, pel)
- | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
+ | Pexp_try (e, pel) -> expr e; List.iter case pel
| Pexp_array el
| Pexp_tuple el -> List.iter expr el
- | Pexp_construct (_, eo, _)
+ | Pexp_construct (_, eo)
| Pexp_variant (_, eo) -> may expr eo
| Pexp_record (iel, eo) ->
may expr eo; List.iter (fun (_, e) -> expr e) iel
@@ -139,9 +144,9 @@ let iter_expression f e =
| Pexp_assert e
| Pexp_setinstvar (_, e)
| Pexp_send (e, _)
- | Pexp_constraint (e, _, _)
+ | Pexp_constraint (e, _)
+ | Pexp_coerce (e, _, _)
| Pexp_field (e, _) -> expr e
- | Pexp_when (e1, e2)
| Pexp_while (e1, e2)
| Pexp_sequence (e1, e2)
| Pexp_setfield (e1, _, e2) -> expr e1; expr e2
@@ -152,8 +157,16 @@ let iter_expression f e =
| Pexp_object { pcstr_fields = fs } -> List.iter class_field fs
| Pexp_pack me -> module_expr me
+ and case {pc_lhs = _; pc_guard; pc_rhs} =
+ may expr pc_guard;
+ expr pc_rhs
+
+ and binding x =
+ expr x.pvb_expr
+
and module_expr me =
match me.pmod_desc with
+ | Pmod_extension _
| Pmod_ident _ -> ()
| Pmod_structure str -> List.iter structure_item str
| Pmod_constraint (me, _)
@@ -161,20 +174,23 @@ let iter_expression f e =
| Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
| Pmod_unpack e -> expr e
+
and structure_item str =
match str.pstr_desc with
- | Pstr_eval e -> expr e
- | Pstr_value (_, pel) -> List.iter (fun (_, e) -> expr e) pel
+ | Pstr_eval (e, _) -> expr e
+ | Pstr_value (_, pel) -> List.iter binding pel
| Pstr_primitive _
| Pstr_type _
| Pstr_exception _
| Pstr_modtype _
| Pstr_open _
| Pstr_class_type _
+ | Pstr_attribute _
+ | Pstr_extension _
| Pstr_exn_rebind _ -> ()
- | Pstr_include me
- | Pstr_module (_, me) -> module_expr me
- | Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
+ | Pstr_include (me, _)
+ | Pstr_module {pmb_expr = me} -> module_expr me
+ | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l
| Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
and class_expr ce =
@@ -185,28 +201,37 @@ let iter_expression f e =
| Pcl_apply (ce, lel) ->
class_expr ce; List.iter (fun (_, e) -> expr e) lel
| Pcl_let (_, pel, ce) ->
- List.iter (fun (_, e) -> expr e) pel; class_expr ce
+ List.iter binding pel; class_expr ce
| Pcl_constraint (ce, _) -> class_expr ce
+ | Pcl_extension _ -> ()
and class_field cf =
match cf.pcf_desc with
- | Pcf_inher (_, ce, _) -> class_expr ce
- | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> ()
- | Pcf_val (_,_,_,e) | Pcf_meth (_,_,_,e) -> expr e
- | Pcf_init e -> expr e
+ | Pcf_inherit (_, ce, _) -> class_expr ce
+ | Pcf_val (_, _, Cfk_virtual _)
+ | Pcf_method (_, _, Cfk_virtual _ ) | Pcf_constraint _ -> ()
+ | Pcf_val (_, _, Cfk_concrete (_, e))
+ | Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e
+ | Pcf_initializer e -> expr e
+ | Pcf_extension _ -> ()
in
expr e
-let all_idents el =
+let all_idents_cases el =
let idents = Hashtbl.create 8 in
let f = function
| {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} ->
Hashtbl.replace idents id ()
| _ -> ()
in
- List.iter (iter_expression f) el;
+ List.iter
+ (fun cp ->
+ may (iter_expression f) cp.pc_guard;
+ iter_expression f cp.pc_rhs
+ )
+ el;
Hashtbl.fold (fun x () rest -> x :: rest) idents []
@@ -227,18 +252,18 @@ let type_option ty =
newty (Tconstr(Predef.path_option,[ty], ref Mnil))
let mkexp exp_desc exp_type exp_loc exp_env =
- { exp_desc; exp_type; exp_loc; exp_env; exp_extra = [] }
+ { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
let option_none ty loc =
let lid = Longident.Lident "None" in
let cnone = Env.lookup_constructor lid Env.initial in
- mkexp (Texp_construct(mknoloc lid, cnone, [], false))
+ mkexp (Texp_construct(mknoloc lid, cnone, []))
ty loc Env.initial
let option_some texp =
let lid = Longident.Lident "Some" in
let csome = Env.lookup_constructor lid Env.initial in
- mkexp ( Texp_construct(mknoloc lid , csome, [texp],false) )
+ mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
(type_option texp.exp_type) texp.exp_loc texp.exp_env
let extract_option_type env ty =
@@ -432,7 +457,7 @@ let rec build_as_type env p =
| Tpat_tuple pl ->
let tyl = List.map (build_as_type env) pl in
newty (Ttuple tyl)
- | Tpat_construct(_, cstr, pl,_) ->
+ | Tpat_construct(_, cstr, pl) ->
let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
if keep then p.pat_type else
let tyl = List.map (build_as_type env) pl in
@@ -498,7 +523,7 @@ let build_or_pat env loc lid =
(l, Reither(true,[], true, ref None)) :: fields
| Rpresent (Some ty) ->
(l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
- pat_type=ty; pat_extra=[];})
+ pat_type=ty; pat_extra=[]; pat_attributes=[]})
:: pats,
(l, Reither(false, [ty], true, ref None)) :: fields
| _ -> pats, fields)
@@ -512,7 +537,7 @@ let build_or_pat env loc lid =
let row' = ref {row with row_more=newvar()} in
let pats =
List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
- pat_env=env; pat_type=ty; pat_extra=[];})
+ pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
pats
in
match pats with
@@ -521,7 +546,7 @@ let build_or_pat env loc lid =
let r =
List.fold_left
(fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
- pat_loc=gloc; pat_env=env; pat_type=ty})
+ pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
pat pats in
(path, rp { r with pat_loc = loc },ty)
@@ -872,6 +897,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_any;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_var name ->
let id = enter_variable loc name expected_ty in
@@ -879,14 +905,16 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_var (id, name);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_unpack name ->
let id = enter_variable loc name expected_ty ~is_module:true in
rp {
pat_desc = Tpat_var (id, name);
pat_loc = sp.ppat_loc;
- pat_extra=[Tpat_unpack, loc];
+ pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
pat_type = expected_ty;
+ pat_attributes = [];
pat_env = !env }
| Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
({ptyp_desc=Ptyp_poly _} as sty)) ->
@@ -905,8 +933,9 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
rp {
pat_desc = Tpat_var (id, name);
pat_loc = lloc;
- pat_extra = [Tpat_constraint cty, loc];
+ pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
pat_type = ty;
+ pat_attributes = [];
pat_env = !env
}
| _ -> assert false
@@ -922,6 +951,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_alias(q, id, name);
pat_loc = loc; pat_extra=[];
pat_type = q.pat_type;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_constant cst ->
unify_pat_types loc !env (type_constant cst) expected_ty;
@@ -929,7 +959,21 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_constant cst;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
+ | Ppat_interval (Const_char c1, Const_char c2) ->
+ let open Ast_helper.Pat in
+ let rec loop c1 c2 =
+ if c1 = c2 then constant ~loc (Const_char c1)
+ else
+ or_ ~loc
+ (constant ~loc (Const_char c1))
+ (loop (Char.chr(Char.code c1 + 1)) c2)
+ in
+ let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
+ type_pat p expected_ty (* TODO: record 'extra' to remember about interval *)
+ | Ppat_interval _ ->
+ raise (Error (loc, !env, Invalid_interval))
| Ppat_tuple spl ->
let spl_ann = List.map (fun p -> (p,newvar ())) spl in
let ty = newty (Ttuple(List.map snd spl_ann)) in
@@ -939,10 +983,11 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_tuple pl;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
- | Ppat_construct(lid, sarg, explicit_arity) ->
+ | Ppat_construct(lid, sarg) ->
let opath =
- try
+ try
let (p0, p, _) = extract_concrete_variant !env expected_ty in
Some (p0, p, true)
with Not_found -> None
@@ -970,7 +1015,6 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
let sargs =
match sarg with
None -> []
- | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl
| Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl
| Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
if constr.cstr_arity = 0 then
@@ -990,9 +1034,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
unify_pat_types loc !env ty_res expected_ty;
let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in
rp {
- pat_desc=Tpat_construct(lid, constr, args,explicit_arity);
+ pat_desc=Tpat_construct(lid, constr, args);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_variant(l, sarg) ->
let arg = may_map (fun p -> type_pat p (newvar())) sarg in
@@ -1009,6 +1054,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_record(lid_sp_list, closed) ->
let opath, record_ty =
@@ -1049,6 +1095,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_record (lbl_pat_list, closed);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_array spl ->
let ty_elt = newvar() in
@@ -1060,6 +1107,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_array pl;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_or(sp1, sp2) ->
let initial_pattern_variables = !pattern_variables in
@@ -1075,6 +1123,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_lazy sp1 ->
let nv = newvar () in
@@ -1085,6 +1134,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_lazy p1;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
+ pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_constraint(sp, sty) ->
(* Separate when not already separated by !principal *)
@@ -1105,20 +1155,23 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
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
if separate then
match p.pat_desc with
Tpat_var (id,s) ->
{p with pat_type = ty;
- pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id,s);
- pat_extra = [Tpat_constraint cty, loc];
+ pat_desc = Tpat_alias ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+ pat_extra = [extra];
}
| _ -> {p with pat_type = ty;
- pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra}
+ pat_extra = extra :: p.pat_extra}
else p
| Ppat_type lid ->
let (path, p,ty) = build_or_pat !env loc lid.txt in
unify_pat_types loc !env ty expected_ty;
- { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
+ { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
+ | Ppat_extension (s, _arg) ->
+ raise (Error (s.loc, !env, Extension s.txt))
let type_pat ?(allow_existentials=false) ?constrs ?labels
?(lev=get_current_level()) env sp expected_ty =
@@ -1218,12 +1271,11 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
let val_env, _ = add_pattern_variables val_env in
(pat, pv, val_env, met_env)
-let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
-
let type_self_pattern cl_num privty val_env met_env par_env spat =
+ let open Ast_helper in
let spat =
- mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")),
- mknoloc ("selfpat-" ^ cl_num)))
+ Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
+ mknoloc ("selfpat-" ^ cl_num)))
in
reset_pattern None false;
let nv = newvar() in
@@ -1270,7 +1322,7 @@ let rec final_subexpression sexp =
| Pexp_sequence (_, e)
| Pexp_try (e, _)
| Pexp_ifthenelse (_, e, _)
- | Pexp_match (_, (_, e) :: _)
+ | Pexp_match (_, {pc_rhs=e} :: _)
-> final_subexpression e
| _ -> sexp
@@ -1281,17 +1333,20 @@ let rec is_nonexpansive exp =
Texp_ident(_,_,_) -> true
| Texp_constant _ -> true
| Texp_let(rec_flag, pat_exp_list, body) ->
- List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &&
+ List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
is_nonexpansive body
| Texp_function _ -> true
| Texp_apply(e, (_,None,_)::el) ->
is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el)
- | Texp_match(e, pat_exp_list, _) ->
+ | Texp_match(e, cases, _) ->
is_nonexpansive e &&
- List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list
+ List.for_all
+ (fun {c_lhs = _; c_guard; c_rhs} ->
+ is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
+ ) cases
| Texp_tuple el ->
List.for_all is_nonexpansive el
- | Texp_construct( _, _, el,_) ->
+ | Texp_construct( _, _, el) ->
List.for_all is_nonexpansive el
| Texp_variant(_, arg) -> is_nonexpansive_opt arg
| Texp_record(lbl_exp_list, opt_init_exp) ->
@@ -1312,14 +1367,14 @@ let rec is_nonexpansive exp =
let count = ref 0 in
List.for_all
(fun field -> match field.cf_desc with
- Tcf_meth _ -> true
- | Tcf_val (_,_, _, _, Tcfk_concrete e,_) ->
+ Tcf_method _ -> true
+ | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
incr count; is_nonexpansive e
- | Tcf_val (_,_, _, _, Tcfk_virtual _,_) ->
+ | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
incr count; true
- | Tcf_init e -> is_nonexpansive e
- | Tcf_constr _ -> true
- | Tcf_inher _ -> false)
+ | Tcf_initializer e -> is_nonexpansive e
+ | Tcf_constraint _ -> true
+ | Tcf_inherit _ -> false)
fields &&
Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
vars true &&
@@ -1342,13 +1397,14 @@ and is_nonexpansive_mod mexp =
| Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _
| Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true
| Tstr_value (_, pat_exp_list) ->
- List.for_all (fun (_, exp) -> is_nonexpansive exp) pat_exp_list
- | Tstr_module (_, _, m) | Tstr_include (m, _) -> is_nonexpansive_mod m
+ List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
+ | Tstr_module {mb_expr=m;_} | Tstr_include (m, _, _) -> is_nonexpansive_mod m
| Tstr_recmodule id_mod_list ->
- List.for_all (fun (_, _, _, m) -> is_nonexpansive_mod m)
+ List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
id_mod_list
| Tstr_exception _ -> false (* true would be unsound *)
| Tstr_class _ -> false (* could be more precise *)
+ | Tstr_attribute _ -> true
)
str.str_items
| Tmod_apply _ -> false
@@ -1586,27 +1642,36 @@ let rec approx_type env sty =
let rec type_approx env sexp =
match sexp.pexp_desc with
Pexp_let (_, _, e) -> type_approx env e
- | Pexp_function (p,_,(_,e)::_) when is_optional p ->
+ | Pexp_fun (p, _, _, e) when is_optional p ->
newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
- | Pexp_function (p,_,(_,e)::_) ->
+ | Pexp_fun (p,_,_, e) ->
newty (Tarrow(p, newvar (), type_approx env e, Cok))
- | Pexp_match (_, (_,e)::_) -> type_approx env e
+ | Pexp_function ({pc_rhs=e}::_) ->
+ newty (Tarrow("", newvar (), type_approx env e, Cok))
+ | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
| Pexp_try (e, _) -> type_approx env e
| Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
| Pexp_ifthenelse (_,e,_) -> type_approx env e
| Pexp_sequence (_,e) -> type_approx env e
- | Pexp_constraint (e, sty1, sty2) ->
+ | Pexp_constraint (e, sty) ->
+ let ty = type_approx env e in
+ let ty1 = approx_type env sty in
+ begin try unify env ty ty1 with Unify trace ->
+ raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
+ end;
+ ty1
+ | Pexp_coerce (e, sty1, sty2) ->
let approx_ty_opt = function
| None -> newvar ()
| Some sty -> approx_type env sty
in
let ty = type_approx env e
and ty1 = approx_ty_opt sty1
- and ty2 = approx_ty_opt sty2 in
+ and ty2 = approx_type env sty2 in
begin try unify env ty ty1 with Unify trace ->
raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
end;
- if sty2 = None then ty1 else ty2
+ ty2
| _ -> newvar ()
(* List labels in a function type, and whether return type is a variable *)
@@ -1683,14 +1748,15 @@ let create_package_type loc env (p, l) =
(s, fields, ty)
let wrap_unpacks sexp unpacks =
+ let open Ast_helper in
List.fold_left
(fun sexp (name, loc) ->
- {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule (
- name,
- {pmod_loc = loc; pmod_desc = Pmod_unpack
- {pexp_desc=Pexp_ident(mkloc (Longident.Lident name.txt) name.loc);
- pexp_loc=name.loc}},
- sexp)})
+ Exp.letmodule ~loc:sexp.pexp_loc
+ name
+ (Mod.unpack ~loc
+ (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt) name.loc)))
+ sexp
+ )
sexp unpacks
(* Helpers for type_cases *)
@@ -1718,11 +1784,12 @@ let contains_variant_either ty =
let iter_ppat f p =
match p.ppat_desc with
- | Ppat_any | Ppat_var _ | Ppat_constant _
+ | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
+ | Ppat_extension _
| Ppat_type _ | Ppat_unpack _ -> ()
| Ppat_array pats -> List.iter f pats
| Ppat_or (p1,p2) -> f p1; f p2
- | Ppat_variant (_, arg) | Ppat_construct (_, arg, _) -> may f arg
+ | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg
| Ppat_tuple lst -> List.iter f lst
| Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p
| Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args
@@ -1738,7 +1805,7 @@ let contains_polymorphic_variant p =
let contains_gadt env p =
let rec loop p =
match p.ppat_desc with
- Ppat_construct (lid, _, _) ->
+ Ppat_construct (lid, _) ->
begin try
let cstrs = Env.lookup_all_constructors lid.txt env in
List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
@@ -1768,15 +1835,13 @@ let check_absent_variant env =
| _ -> ())
-let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
-
(* Duplicate types of values in the environment *)
(* XXX Should we do something about global type variables too? *)
let duplicate_ident_types loc caselist env =
let caselist =
- List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
- let idents = all_idents (List.map snd caselist) in
+ List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
+ let idents = all_idents_cases caselist in
List.fold_left
(fun env s ->
try
@@ -1857,9 +1922,10 @@ and type_expect_ ?in_function env sexp ty_expected =
end;
exp_loc = loc; exp_extra = [];
exp_type = instance env desc.val_type;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
- | Pexp_constant(Const_string s as cst) ->
+ | Pexp_constant(Const_string (s, _) as cst) ->
rue {
exp_desc = Texp_constant cst;
exp_loc = loc; exp_extra = [];
@@ -1870,23 +1936,26 @@ and type_expect_ ?in_function env sexp ty_expected =
type_format loc s
| _ -> instance_def Predef.type_string
end;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_constant cst ->
rue {
exp_desc = Texp_constant cst;
exp_loc = loc; exp_extra = [];
exp_type = type_constant cst;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
- | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
+ | Pexp_let(Nonrecursive, [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody) when contains_gadt env spat ->
+ (* TODO: allow non-empty attributes? *)
type_expect ?in_function env
- {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
+ {sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
ty_expected
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let scp =
- match rec_flag with
- | Recursive -> Some (Annot.Idef loc)
- | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
- | Default -> None
+ match sexp.pexp_attributes, rec_flag with
+ | [{txt="#default"},_], _ -> None
+ | _, Recursive -> Some (Annot.Idef loc)
+ | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
in
let (pat_exp_list, new_env, unpacks) =
type_let env rec_flag spat_sexp_list scp true in
@@ -1896,96 +1965,44 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
- | Pexp_function (l, Some default, [spat, sbody]) ->
+ | Pexp_fun (l, Some default, spat, sexp) ->
+ assert(is_optional l); (* default allowed only with optional argument *)
+ let open Ast_helper in
let default_loc = default.pexp_loc in
let scases = [
- {ppat_loc = default_loc;
- ppat_desc =
- Ppat_construct
- (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))),
- Some {ppat_loc = default_loc;
- ppat_desc = Ppat_var (mknoloc "*sth*")},
- false)},
- {pexp_loc = default_loc;
- pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))};
- {ppat_loc = default_loc;
- ppat_desc = Ppat_construct
- (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))),
- None, false)},
- default;
- ] in
- let smatch = {
- pexp_loc = loc;
- pexp_desc =
- Pexp_match ({
- pexp_loc = loc;
- pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*opt*"))
- },
- scases
- )
- } in
- let sfun = {
- pexp_loc = loc;
- pexp_desc =
- Pexp_function (
- l, None,
- [ {ppat_loc = loc;
- ppat_desc = Ppat_var (mknoloc "*opt*")},
- {pexp_loc = loc;
- pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
- }
- ]
- )
- } in
- type_expect ?in_function env sfun ty_expected
- | Pexp_function (l, _, caselist) ->
- let (loc_fun, ty_fun) =
- match in_function with Some p -> p
- | None -> (loc, instance env ty_expected)
+ Exp.case
+ (Pat.construct ~loc:default_loc
+ (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+ (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
+ (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+
+ Exp.case
+ (Pat.construct ~loc:default_loc
+ (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+ None)
+ default;
+ ]
in
- let separate = !Clflags.principal || Env.has_local_constraints env in
- if separate then begin_def ();
- let (ty_arg, ty_res) =
- try filter_arrow env (instance env ty_expected) l
- with Unify _ ->
- match expand_head env ty_expected with
- {desc = Tarrow _} as ty ->
- raise(Error(loc, env, Abstract_wrong_label(l, ty)))
- | _ ->
- raise(Error(loc_fun, env,
- Too_many_arguments (in_function <> None, ty_fun)))
+ let smatch =
+ Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+ scases
in
- let ty_arg =
- if is_optional l then
- let tv = newvar() in
- begin
- try unify env ty_arg (type_option tv)
- with Unify _ -> assert false
- end;
- type_option tv
- else ty_arg
- in
- if separate then begin
- end_def ();
- generalize_structure ty_arg;
- generalize_structure ty_res
- end;
- let cases, partial =
- type_cases ~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
- ls = [] && not tvar
+ let sfun =
+ Exp.fun_ ~loc
+ l None
+ (Pat.var ~loc (mknoloc "*opt*"))
+ (Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",[]] [Vb.mk spat smatch] sexp)
in
- if is_optional l && not_function ty_res then
- Location.prerr_warning (fst (List.hd cases)).pat_loc
- Warnings.Unerasable_optional_argument;
- re {
- exp_desc = Texp_function(l,cases, partial);
- exp_loc = loc; exp_extra = [];
- exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
- exp_env = env }
+ type_expect ?in_function env sfun ty_expected
+ (* TODO: keep attributes, call type_function directly *)
+ | Pexp_fun (l, None, spat, sexp) ->
+ type_function ?in_function loc sexp.pexp_attributes env ty_expected
+ l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp}]
+ | Pexp_function caselist ->
+ type_function ?in_function
+ loc sexp.pexp_attributes env ty_expected "" caselist
| Pexp_apply(sfunct, sargs) ->
begin_def (); (* one more level for non-returning functions *)
if !Clflags.principal then begin_def ();
@@ -2014,6 +2031,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_apply(funct, args);
exp_loc = loc; exp_extra = [];
exp_type = ty_res;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_match(sarg, caselist) ->
begin_def ();
@@ -2028,6 +2046,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_match(arg, cases, partial);
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_try(sbody, caselist) ->
let body = type_expect env sbody ty_expected in
@@ -2037,6 +2056,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_try(body, cases);
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_tuple sexpl ->
let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
@@ -2050,9 +2070,10 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_loc = loc; exp_extra = [];
(* Keep sharing *)
exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
- | Pexp_construct(lid, sarg, explicit_arity) ->
- type_construct env loc lid sarg explicit_arity ty_expected
+ | Pexp_construct(lid, sarg) ->
+ type_construct env loc lid sarg ty_expected sexp.pexp_attributes
| Pexp_variant(l, sarg) ->
(* Keep sharing *)
let ty_expected0 = instance env ty_expected in
@@ -2067,6 +2088,7 @@ and type_expect_ ?in_function env sexp ty_expected =
re { exp_desc = Texp_variant(l, Some arg);
exp_loc = loc; exp_extra = [];
exp_type = ty_expected0;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| _ -> raise Not_found
end
@@ -2083,6 +2105,7 @@ and type_expect_ ?in_function env sexp ty_expected =
row_closed = false;
row_fixed = false;
row_name = None});
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_record(lid_sexp_list, opt_sexp) ->
@@ -2177,6 +2200,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_record(lbl_exp_list, opt_exp);
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_field(srecord, lid) ->
let (record, label, _) = type_label_access env loc srecord lid in
@@ -2186,6 +2210,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_field(record, lid, label);
exp_loc = loc; exp_extra = [];
exp_type = ty_arg;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_setfield(srecord, lid, snewval) ->
let (record, label, opath) = type_label_access env loc srecord lid in
@@ -2199,6 +2224,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_setfield(record, label_loc, label, newval);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_array(sargl) ->
let ty = newgenvar() in
@@ -2209,6 +2235,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_array argl;
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_ifthenelse(scond, sifso, sifnot) ->
let cond = type_expect env scond Predef.type_bool in
@@ -2219,6 +2246,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_ifthenelse(cond, ifso, None);
exp_loc = loc; exp_extra = [];
exp_type = ifso.exp_type;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Some sifnot ->
let ifso = type_expect env sifso ty_expected in
@@ -2229,6 +2257,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
exp_loc = loc; exp_extra = [];
exp_type = ifso.exp_type;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_sequence(sexp1, sexp2) ->
@@ -2238,6 +2267,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_sequence(exp1, exp2);
exp_loc = loc; exp_extra = [];
exp_type = exp2.exp_type;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_while(scond, sbody) ->
let cond = type_expect env scond Predef.type_bool in
@@ -2246,6 +2276,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_while(cond, body);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_for(param, slow, shigh, dir, sbody) ->
let low = type_expect env slow Predef.type_int in
@@ -2260,27 +2291,35 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_for(id, param, low, high, dir, body);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
- | Pexp_constraint(sarg, sty, sty') ->
+ | Pexp_constraint (sarg, sty) ->
+ let separate = true in (* always separate, 1% slowdown for lablgtk *)
+ if separate then begin_def ();
+ let cty = Typetexp.transl_simple_type env false sty in
+ let ty = cty.ctyp_type in
+ let (arg, ty') =
+ if separate then begin
+ end_def ();
+ generalize_structure ty;
+ (type_argument env sarg ty (instance env ty), instance env ty)
+ end else
+ (type_argument env sarg ty ty, ty)
+ in
+ rue {
+ exp_desc = arg.exp_desc;
+ exp_loc = arg.exp_loc;
+ exp_type = ty';
+ exp_attributes = arg.exp_attributes;
+ exp_env = env;
+ exp_extra = (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
+ }
+ | Pexp_coerce(sarg, sty, sty') ->
let separate = true (* always separate, 1% slowdown for lablgtk *)
(* !Clflags.principal || Env.has_local_constraints env *) in
let (arg, ty',cty,cty') =
- match (sty, sty') with
- (None, None) -> (* Case actually unused *)
- let arg = type_exp env sarg in
- (arg, arg.exp_type,None,None)
- | (Some sty, None) ->
- if separate then begin_def ();
- let cty = Typetexp.transl_simple_type env false sty in
- let ty = cty.ctyp_type in
- if separate then begin
- end_def ();
- generalize_structure ty;
- (type_argument env sarg ty (instance env ty),
- instance env ty, Some cty, None)
- end else
- (type_argument env sarg ty ty, ty, Some cty, None)
- | (None, Some sty') ->
+ match sty with
+ | None ->
let (cty', force) =
Typetexp.transl_simple_type_delayed env sty'
in
@@ -2330,8 +2369,8 @@ and type_expect_ ?in_function env sexp ty_expected =
Coercion_failure(ty', full_expand env ty', trace, b)))
end
end;
- (arg, ty', None, Some cty')
- | (Some sty, Some sty') ->
+ (arg, ty', None, cty')
+ | Some sty ->
if separate then begin_def ();
let (cty, force) =
Typetexp.transl_simple_type_delayed env sty
@@ -2351,25 +2390,19 @@ and type_expect_ ?in_function env sexp ty_expected =
generalize_structure ty;
generalize_structure ty';
(type_argument env sarg ty (instance env ty),
- instance env ty', Some cty, Some cty')
+ instance env ty', Some cty, cty')
end else
- (type_argument env sarg ty ty, ty', Some cty, Some cty')
+ (type_argument env sarg ty ty, ty', Some cty, cty')
in
rue {
exp_desc = arg.exp_desc;
exp_loc = arg.exp_loc;
exp_type = ty';
+ exp_attributes = arg.exp_attributes;
exp_env = env;
- exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra;
+ exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
+ arg.exp_extra;
}
- | Pexp_when(scond, sbody) ->
- let cond = type_expect env scond Predef.type_bool in
- let body = type_expect env sbody ty_expected in
- re {
- exp_desc = Texp_when(cond, body);
- exp_loc = loc; exp_extra = [];
- exp_type = body.exp_type;
- exp_env = env }
| Pexp_send (e, met) ->
if !Clflags.principal then begin_def ();
let obj = type_exp env e in
@@ -2411,17 +2444,20 @@ and type_expect_ ?in_function env sexp ty_expected =
Types.val_loc = Location.none});
exp_loc = loc; exp_extra = [];
exp_type = method_type;
+ exp_attributes = []; (* check *)
exp_env = env},
["",
Some {exp_desc = Texp_ident(path, lid, desc);
exp_loc = obj.exp_loc; exp_extra = [];
exp_type = desc.val_type;
+ exp_attributes = []; (* check *)
exp_env = env},
Required])
in
(Tmeth_name met, Some (re {exp_desc = exp;
exp_loc = loc; exp_extra = [];
exp_type = typ;
+ exp_attributes = []; (* check *)
exp_env = env}), typ)
| _ ->
assert false
@@ -2456,6 +2492,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_send(obj, meth, exp);
exp_loc = loc; exp_extra = [];
exp_type = typ;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
with Unify _ ->
raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met)))
@@ -2470,6 +2507,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_new (cl_path, cl, cl_decl);
exp_loc = loc; exp_extra = [];
exp_type = instance_def ty;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_setinstvar (lab, snewval) ->
@@ -2486,6 +2524,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_setinstvar(path_self, path, lab, newval);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Val_ivar _ ->
raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt)))
@@ -2528,6 +2567,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_override(path_self, modifs);
exp_loc = loc; exp_extra = [];
exp_type = self_ty;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| _ ->
assert false
@@ -2559,20 +2599,22 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_letmodule(id, name, modl, body);
exp_loc = loc; exp_extra = [];
exp_type = ty;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_assert (e) ->
let cond = type_expect env e Predef.type_bool in
+ let exp_type =
+ match cond.exp_desc with
+ | Texp_construct(_, {cstr_name="false"}, _) ->
+ instance env ty_expected
+ | _ ->
+ instance_def Predef.type_unit
+ in
rue {
- exp_desc = Texp_assert (cond);
+ exp_desc = Texp_assert cond;
exp_loc = loc; exp_extra = [];
- exp_type = instance_def Predef.type_unit;
- exp_env = env;
- }
- | Pexp_assertfalse ->
- re {
- exp_desc = Texp_assertfalse;
- exp_loc = loc; exp_extra = [];
- exp_type = instance env ty_expected;
+ exp_type;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
| Pexp_lazy e ->
@@ -2584,6 +2626,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_lazy arg;
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
| Pexp_object s ->
@@ -2592,6 +2635,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_object (desc, (*sign,*) meths);
exp_loc = loc; exp_extra = [];
exp_type = sign.cty_self;
+ exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
| Pexp_poly(sbody, sty) ->
@@ -2599,6 +2643,7 @@ and type_expect_ ?in_function env sexp ty_expected =
let ty, cty =
match sty with None -> repr ty_expected, None
| Some sty ->
+ let sty = Ast_helper.Typ.force_poly sty in
let cty = Typetexp.transl_simple_type env false sty in
repr cty.ctyp_type, Some cty
in
@@ -2633,7 +2678,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp
| _ -> assert false
in
- re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra }
+ re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
| Pexp_newtype(name, sbody) ->
let ty = newvar () in
(* remember original level *)
@@ -2678,7 +2723,7 @@ and type_expect_ ?in_function env sexp ty_expected =
(* non-expansive if the body is non-expansive, so we don't introduce
any new extra node in the typed AST. *)
rue { body with exp_loc = loc; exp_type = ety;
- exp_extra = (Texp_newtype name, loc) :: body.exp_extra }
+ exp_extra = (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
| Pexp_pack m ->
let (p, nl, tl) =
match Ctype.expand_head env (instance env ty_expected) with
@@ -2699,14 +2744,68 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_pack modl;
exp_loc = loc; exp_extra = [];
exp_type = newty (Tpackage (p, nl, tl'));
+ exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_open (ovf, lid, e) ->
let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in
let exp = type_expect newenv e ty_expected in
{ exp with
- exp_extra = (Texp_open (ovf, path, lid, newenv), loc) ::
+ exp_extra = (Texp_open (ovf, path, lid, newenv), loc,
+ sexp.pexp_attributes) ::
exp.exp_extra;
}
+ | Pexp_extension (s, _arg) ->
+ raise (Error (s.loc, env, Extension s.txt))
+
+and type_function ?in_function loc attrs env ty_expected l caselist =
+ let (loc_fun, ty_fun) =
+ match in_function with Some p -> p
+ | None -> (loc, instance env ty_expected)
+ in
+ let separate = !Clflags.principal || Env.has_local_constraints env in
+ if separate then begin_def ();
+ let (ty_arg, ty_res) =
+ try filter_arrow env (instance env ty_expected) l
+ with Unify _ ->
+ match expand_head env ty_expected with
+ {desc = Tarrow _} as ty ->
+ raise(Error(loc, env, Abstract_wrong_label(l, ty)))
+ | _ ->
+ raise(Error(loc_fun, env,
+ Too_many_arguments (in_function <> None, ty_fun)))
+ in
+ let ty_arg =
+ if is_optional l then
+ let tv = newvar() in
+ begin
+ try unify env ty_arg (type_option tv)
+ with Unify _ -> assert false
+ end;
+ type_option tv
+ else ty_arg
+ in
+ if separate then begin
+ end_def ();
+ generalize_structure ty_arg;
+ generalize_structure ty_res
+ end;
+ let cases, partial =
+ type_cases ~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
+ ls = [] && not tvar
+ in
+ if is_optional l && not_function ty_res then
+ Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+ Warnings.Unerasable_optional_argument;
+ re {
+ exp_desc = Texp_function(l,cases, partial);
+ exp_loc = loc; exp_extra = [];
+ exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+ exp_attributes = attrs;
+ exp_env = env }
+
and type_label_access env loc srecord lid =
if !Clflags.principal then begin_def ();
@@ -2825,9 +2924,10 @@ and type_argument env sarg ty_expected' ty_expected =
let var_pair name ty =
let id = Ident.create name in
{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+ pat_attributes = [];
pat_loc = Location.none; pat_env = env},
{exp_type = ty; exp_loc = Location.none; exp_env = env;
- exp_extra = [];
+ exp_extra = []; exp_attributes = [];
exp_desc =
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
{val_type = ty; val_kind = Val_reg;
@@ -2835,18 +2935,22 @@ and type_argument env sarg ty_expected' ty_expected =
in
let eta_pat, eta_var = var_pair "eta" ty_arg in
let func texp =
+ let e =
+ {texp with exp_type = ty_res; exp_desc =
+ Texp_apply
+ (texp,
+ List.rev args @ ["", Some eta_var, Required])}
+ in
{ texp with exp_type = ty_fun; exp_desc =
- Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc =
- Texp_apply (texp,
- List.rev args @ ["", Some eta_var, Required])}],
- Total) } in
+ Texp_function("", [case eta_pat e], Total) }
+ in
if warn then Location.prerr_warning texp.exp_loc
(Warnings.Without_principality "eliminated optional argument");
if is_nonexpansive texp then func texp else
(* let-expand to have side effects *)
let let_pat, let_var = var_pair "let" texp.exp_type in
re { texp with exp_type = ty_fun; exp_desc =
- Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
+ Texp_let (Nonrecursive, [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]}], func let_var) }
end
| _ ->
let texp = type_expect env sarg ty_expected' in
@@ -3042,7 +3146,7 @@ and type_application env funct sargs =
else
type_args [] [] ty (instance env ty) ty sargs []
-and type_construct env loc lid sarg explicit_arity ty_expected =
+and type_construct env loc lid sarg ty_expected attrs =
let opath =
try
let (p0, p,_) = extract_concrete_variant env ty_expected in
@@ -3055,7 +3159,6 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
let sargs =
match sarg with
None -> []
- | Some {pexp_desc = Pexp_tuple sel} when explicit_arity -> sel
| Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
| Some se -> [se] in
if List.length sargs <> constr.cstr_arity then
@@ -3066,9 +3169,10 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
let (ty_args, ty_res) = instance_constructor constr in
let texp =
re {
- exp_desc = Texp_construct(lid, constr, [],explicit_arity);
+ exp_desc = Texp_construct(lid, constr, []);
exp_loc = loc; exp_extra = [];
exp_type = ty_res;
+ exp_attributes = attrs;
exp_env = env } in
if separate then begin
end_def ();
@@ -3090,8 +3194,9 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
(List.combine ty_args ty_args0) in
if constr.cstr_private = Private then
raise(Error(loc, env, Private_type ty_res));
+ (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
{ texp with
- exp_desc = Texp_construct(lid, constr, args, explicit_arity) }
+ exp_desc = Texp_construct(lid, constr, args) }
(* Typing of statements (expressions whose values are discarded) *)
@@ -3121,9 +3226,9 @@ and type_statement env sexp =
(* Typing of match cases *)
-and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
+and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedtree.case list * _ =
(* ty_arg is _fully_ generalized *)
- let patterns = List.map fst caselist in
+ let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
let erase_either =
List.exists contains_polymorphic_variant patterns
&& contains_variant_either ty_arg
@@ -3156,8 +3261,13 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
Printtyp.raw_type_expr ty_arg; *)
let pat_env_list =
List.map
- (fun (spat, sexp) ->
- let loc = sexp.pexp_loc in
+ (fun {pc_lhs; pc_guard; pc_rhs} ->
+ let loc =
+ let open Location in
+ match pc_guard with
+ | None -> pc_rhs.pexp_loc
+ | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
+ in
if !Clflags.principal then begin_def (); (* propagation of pattern *)
let scope = Some (Annot.Idef loc) in
let (pat, ext_env, force, unpacks) =
@@ -3165,7 +3275,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
if !Clflags.principal || erase_either
then Some false else None in
let ty_arg = instance ?partial env ty_arg in
- type_pattern ~lev env spat scope ty_arg
+ type_pattern ~lev env pc_lhs scope ty_arg
in
pattern_force := force @ !pattern_force;
let pat =
@@ -3197,8 +3307,8 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
let in_function = if List.length caselist = 1 then in_function else None in
let cases =
List.map2
- (fun (pat, (ext_env, unpacks)) (spat, sexp) ->
- let sexp = wrap_unpacks sexp unpacks in
+ (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
+ let sexp = wrap_unpacks pc_rhs unpacks in
let ty_res' =
if !Clflags.principal then begin
begin_def ();
@@ -3206,17 +3316,30 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
end_def ();
generalize_structure ty; ty
end
- else if contains_gadt env spat then correct_levels ty_res
+ else if contains_gadt env pc_lhs then correct_levels ty_res
else ty_res in
(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
Printtyp.raw_type_expr ty_res'; *)
+ let guard =
+ match pc_guard with
+ | None -> None
+ | Some scond ->
+ Some
+ (type_expect ext_env (wrap_unpacks scond unpacks)
+ Predef.type_bool)
+ in
let exp = type_expect ?in_function ext_env sexp ty_res' in
- (pat, {exp with exp_type = instance env ty_res'}))
+ {
+ c_lhs = pat;
+ c_guard = guard;
+ c_rhs = {exp with exp_type = instance env ty_res'}
+ }
+ )
pat_env_list caselist
in
if !Clflags.principal || has_gadts then begin
let ty_res' = instance env ty_res in
- List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases
+ List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
end;
let partial =
if partial_flag then
@@ -3241,13 +3364,14 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
and type_let ?(check = fun s -> Warnings.Unused_var s)
?(check_strict = fun s -> Warnings.Unused_var_strict s)
env rec_flag spat_sexp_list scope allow =
+ let open Ast_helper in
begin_def();
if !Clflags.principal then begin_def ();
let is_fake_let =
match spat_sexp_list with
- | [_, {pexp_desc=Pexp_match(
- {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}] ->
+ | [{pvb_expr={pexp_desc=Pexp_match(
+ {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
| _ ->
false
@@ -3256,15 +3380,17 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
let spatl =
List.map
- (fun (spat, sexp) ->
+ (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=_} ->
match spat.ppat_desc, sexp.pexp_desc with
(Ppat_any | Ppat_constraint _), _ -> spat
- | _, Pexp_constraint (_, _, Some sty)
- | _, Pexp_constraint (_, Some sty, None) when !Clflags.principal ->
+ | _, Pexp_coerce (_, _, sty)
+ | _, Pexp_constraint (_, sty) when !Clflags.principal ->
(* propagate type annotation to pattern,
to allow it to be generalized in -principal mode *)
- {ppat_desc = Ppat_constraint (spat, sty);
- ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}}
+ Pat.constraint_
+ ~loc:{spat.ppat_loc with Location.loc_ghost=true}
+ spat
+ sty
| _ -> spat)
spat_sexp_list in
let nvs = List.map (fun _ -> newvar ()) spatl in
@@ -3274,14 +3400,14 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
(* If recursive, first unify with an approximation of the expression *)
if is_recursive then
List.iter2
- (fun pat (_, sexp) ->
+ (fun pat binding ->
let pat =
match pat.pat_type.desc with
| Tpoly (ty, tl) ->
{pat with pat_type =
snd (instance_poly ~keep_names:true false tl ty)}
| _ -> pat
- in unify_pat env pat (type_approx env sexp))
+ in unify_pat env pat (type_approx env binding.pvb_expr))
pat_list spat_sexp_list;
(* Polymorphic variant processing *)
List.iter
@@ -3370,7 +3496,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
in
let exp_list =
List.map2
- (fun (spat, sexp) (pat, slot) ->
+ (fun {pvb_expr=sexp; _} (pat, slot) ->
let sexp =
if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
if is_recursive then current_slot := slot;
@@ -3392,10 +3518,10 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
current_slot := None;
if is_recursive && not !rec_needed
&& Warnings.is_active Warnings.Unused_rec_flag then
- Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc
+ Location.prerr_warning (List.hd spat_sexp_list).pvb_pat.ppat_loc
Warnings.Unused_rec_flag;
List.iter2
- (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
+ (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [case pat exp]))
pat_list exp_list;
end_def();
List.iter2
@@ -3406,7 +3532,13 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
List.iter
(fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
pat_list;
- (List.combine pat_list exp_list, new_env, unpacks)
+ let l = List.combine pat_list exp_list in
+ let l =
+ List.map2
+ (fun (p, e) pvb -> {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes})
+ l spat_sexp_list
+ in
+ (l, new_env, unpacks)
(* Typing of toplevel bindings *)
@@ -3638,6 +3770,10 @@ let report_error env ppf = function
fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]"
name path tpath
"must be qualified in this pattern"
+ | Invalid_interval ->
+ fprintf ppf "@[Only character intervals are supported in patterns.@]"
+ | Extension s ->
+ fprintf ppf "Uninterpreted extension '%s'." s
let report_error env ppf err =
wrap_printing_env env (fun () -> report_error env ppf err)
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 30093733a6..e5e8516da5 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -20,14 +20,14 @@ val is_nonexpansive: Typedtree.expression -> bool
val type_binding:
Env.t -> rec_flag ->
- (Parsetree.pattern * Parsetree.expression) list ->
+ Parsetree.value_binding list ->
Annot.ident option ->
- (Typedtree.pattern * Typedtree.expression) list * Env.t
+ Typedtree.value_binding list * Env.t
val type_let:
Env.t -> rec_flag ->
- (Parsetree.pattern * Parsetree.expression) list ->
+ Parsetree.value_binding list ->
Annot.ident option ->
- (Typedtree.pattern * Typedtree.expression) list * Env.t
+ Typedtree.value_binding list * Env.t
val type_expression:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_class_arg_pattern:
@@ -105,6 +105,8 @@ type error =
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
| Unqualified_gadt_pattern of Path.t * string
+ | Invalid_interval
+ | Extension of string
exception Error of Location.t * Env.t * error
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 1de7ac8571..c6c92ff2de 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -40,6 +40,7 @@ type error =
| Bad_fixed_type of string
| Unbound_type_var_exc of type_expr * type_expr
| Varying_anonymous
+ | Exception_constructor_with_result
open Typedtree
@@ -47,7 +48,7 @@ exception Error of Location.t * error
(* Enter all declared types in the environment as abstract types *)
-let enter_type env (name, sdecl) id =
+let enter_type env sdecl id =
let decl =
{ type_params =
List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
@@ -126,14 +127,15 @@ module StringSet =
let make_params sdecl =
try
List.map
- (function
- None -> Ctype.new_global_var ~name:"_" ()
- | Some x -> enter_type_variable true sdecl.ptype_loc x.txt)
+ (fun (x, _) ->
+ match x with
+ | None -> Ctype.new_global_var ~name:"_" ()
+ | Some x -> enter_type_variable x)
sdecl.ptype_params
- with Already_bound ->
- raise(Error(sdecl.ptype_loc, Repeated_parameter))
+ with Already_bound loc ->
+ raise(Error(loc, Repeated_parameter))
-let transl_declaration env (name, sdecl) id =
+let transl_declaration env sdecl id =
(* Bind type parameters *)
reset_type_variables();
Ctype.begin_def ();
@@ -150,29 +152,29 @@ let transl_declaration env (name, sdecl) id =
| Ptype_variant cstrs ->
let all_constrs = ref StringSet.empty in
List.iter
- (fun ({ txt = name}, _, _, loc) ->
+ (fun {pcd_name = {txt = name}} ->
if StringSet.mem name !all_constrs then
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
all_constrs := StringSet.add name !all_constrs)
cstrs;
if List.length
- (List.filter (fun (_, args, _, _) -> args <> []) cstrs)
+ (List.filter (fun cd -> cd.pcd_args <> []) cstrs)
> (Config.max_tag + 1) then
raise(Error(sdecl.ptype_loc, Too_many_constructors));
- let make_cstr (lid, args, ret_type, loc) =
+ let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} =
let name = Ident.create lid.txt in
match ret_type with
| None ->
(name, lid, List.map (transl_simple_type env true) args,
- None, loc)
+ None, None, loc, attrs)
| Some sty ->
(* if it's a generalized constructor we must first narrow and
then widen so as to not introduce any new constraints *)
let z = narrow () in
reset_type_variables ();
let args = List.map (transl_simple_type env false) args in
+ let cty = transl_simple_type env false sty in
let ret_type =
- let cty = transl_simple_type env false sty in
let ty = cty.ctyp_type in
let p = Path.Pident id in
match (Ctype.repr ty).desc with
@@ -182,32 +184,35 @@ let transl_declaration env (name, sdecl) id =
(ty, Ctype.newconstr p params)))
in
widen z;
- (name, lid, args, Some ret_type, loc)
+ (name, lid, args, Some cty, Some ret_type, loc, attrs)
in
let cstrs = List.map make_cstr cstrs in
- Ttype_variant (List.map (fun (name, lid, ctys, _, loc) ->
- name, lid, ctys, loc
+ Ttype_variant (List.map (fun (name, lid, ctys, res, _, loc, attrs) ->
+ {cd_id = name; cd_name = lid; cd_args = ctys; cd_res = res;
+ cd_loc = loc; cd_attributes = attrs}
) cstrs),
- Type_variant (List.map (fun (name, name_loc, ctys, option, loc) ->
+ Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, _attrs) ->
name, List.map (fun cty -> cty.ctyp_type) ctys, option) cstrs)
| Ptype_record lbls ->
let all_labels = ref StringSet.empty in
List.iter
- (fun ({ txt = name }, mut, arg, loc) ->
+ (fun {pld_name = {txt=name}} ->
if StringSet.mem name !all_labels then
raise(Error(sdecl.ptype_loc, Duplicate_label name));
all_labels := StringSet.add name !all_labels)
lbls;
- let lbls = List.map (fun (name, mut, arg, loc) ->
+ let lbls = List.map (fun {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;pld_attributes=attrs} ->
+ let arg = Ast_helper.Typ.force_poly arg in
let cty = transl_simple_type env true arg in
- (Ident.create name.txt, name, mut, cty, loc)
- ) lbls in
+ {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; ld_type = cty;
+ ld_loc = loc; ld_attributes = attrs}
+ ) lbls in
let lbls' =
List.map
- (fun (name, name_loc, mut, cty, loc) ->
- let ty = cty.ctyp_type in
- name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
+ (fun ld ->
+ let ty = ld.ld_type.ctyp_type in
+ ld.ld_id, ld.ld_mutable, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
lbls in
let rep =
if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls'
@@ -253,19 +258,20 @@ let transl_declaration env (name, sdecl) id =
begin match decl.type_manifest with None -> ()
| Some ty ->
if Ctype.cyclic_abbrev env id ty then
- raise(Error(sdecl.ptype_loc, Recursive_abbrev name.txt));
+ raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt));
end;
- let tdecl = {
+ {
+ typ_id = id;
+ typ_name = sdecl.ptype_name;
typ_params = sdecl.ptype_params;
typ_type = decl;
typ_cstrs = cstrs;
typ_loc = sdecl.ptype_loc;
typ_manifest = tman;
typ_kind = tkind;
- typ_variance = sdecl.ptype_variance;
typ_private = sdecl.ptype_private;
- } in
- (id, name, tdecl)
+ typ_attributes = sdecl.ptype_attributes;
+ }
(* Generalize a type declaration *)
@@ -316,7 +322,7 @@ let rec check_constraints_rec env loc visited ty =
module SMap = Map.Make(String)
-let check_constraints env (_, sdecl) (_, decl) =
+let check_constraints env sdecl (_, decl) =
let visited = ref TypeSet.empty in
begin match decl.type_kind with
| Type_abstract -> ()
@@ -327,14 +333,14 @@ let check_constraints env (_, sdecl) (_, decl) =
in
let pl = find_pl sdecl.ptype_kind in
let pl_index =
- let foldf acc (name, styl, sret_type, _) =
- SMap.add name.txt (styl, sret_type) acc
+ let foldf acc x =
+ SMap.add x.pcd_name.txt x acc
in
List.fold_left foldf SMap.empty pl
in
List.iter
(fun (name, tyl, ret_type) ->
- let (styl, sret_type) =
+ let {pcd_args = styl; pcd_res = sret_type; _} =
try SMap.find (Ident.name name) pl_index
with Not_found -> assert false in
List.iter2
@@ -355,8 +361,8 @@ let check_constraints env (_, sdecl) (_, decl) =
let pl = find_pl sdecl.ptype_kind in
let rec get_loc name = function
[] -> assert false
- | (name', _, sty, _) :: tl ->
- if name = name'.txt then sty.ptyp_loc else get_loc name tl
+ | pld :: tl ->
+ if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl
in
List.iter
(fun (name, _, ty) ->
@@ -406,7 +412,7 @@ let check_coherence env loc id decl =
end
| _ -> ()
-let check_abbrev env (_, sdecl) (id, decl) =
+let check_abbrev env sdecl (id, decl) =
check_coherence env sdecl.ptype_loc id decl
(* Check that recursion is well-founded *)
@@ -478,8 +484,9 @@ let check_recursion env loc path decl to_check =
check_regular path args [] body)
decl.type_manifest
-let check_abbrev_recursion env id_loc_list (id, _, tdecl) =
+let check_abbrev_recursion env id_loc_list tdecl =
let decl = tdecl.typ_type in
+ let id = tdecl.typ_id in
check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl
(function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false)
@@ -587,6 +594,15 @@ let make p n i =
let open Variance in
set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+let flags (v, i) =
+ let (c, n) =
+ match v with
+ | Covariant -> (true, false)
+ | Contravariant -> (false, true)
+ | Invariant -> (true, true)
+ in
+ (c, n, i)
+
let compute_variance_type env check (required, loc) decl tyl =
(* Requirements *)
let required =
@@ -786,15 +802,22 @@ let rec compute_variance_fixpoint env decls required variances =
let init_variance (id, decl) =
List.map (fun _ -> Variance.null) decl.type_params
-let add_injectivity = List.map (fun (cn,cv) -> (cn,cv,false))
+let add_injectivity =
+ List.map
+ (function
+ | Covariant -> (true, false, false)
+ | Contravariant -> (false, true, false)
+ | Invariant -> (false, false, false)
+ )
(* for typeclass.ml *)
let compute_variance_decls env cldecls =
let decls, required =
List.fold_right
(fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) ->
+ let variance = List.map snd ci.ci_params in
(obj_id, obj_abbr) :: decls,
- (add_injectivity ci.ci_variance, ci.ci_loc) :: req)
+ (add_injectivity variance, ci.ci_loc) :: req)
cldecls ([],[])
in
let variances = List.map init_variance decls in
@@ -809,32 +832,32 @@ let compute_variance_decls env cldecls =
(* Check multiple declarations of labels/constructors *)
-let check_duplicates name_sdecl_list =
+let check_duplicates sdecl_list =
let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
List.iter
- (fun (name, sdecl) -> match sdecl.ptype_kind with
+ (fun sdecl -> match sdecl.ptype_kind with
Ptype_variant cl ->
List.iter
- (fun (cname, _, _, loc) ->
+ (fun pcd ->
try
- let name' = Hashtbl.find constrs cname.txt in
- Location.prerr_warning loc
+ let name' = Hashtbl.find constrs pcd.pcd_name.txt in
+ Location.prerr_warning pcd.pcd_loc
(Warnings.Duplicate_definitions
- ("constructor", cname.txt, name', name.txt))
- with Not_found -> Hashtbl.add constrs cname.txt name.txt)
+ ("constructor", pcd.pcd_name.txt, name', sdecl.ptype_name.txt))
+ with Not_found -> Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
cl
| Ptype_record fl ->
List.iter
- (fun (cname, _, _, loc) ->
+ (fun {pld_name=cname;pld_loc=loc} ->
try
let name' = Hashtbl.find labels cname.txt in
Location.prerr_warning loc
(Warnings.Duplicate_definitions
- ("label", cname.txt, name', name.txt))
- with Not_found -> Hashtbl.add labels cname.txt name.txt)
+ ("label", cname.txt, name', sdecl.ptype_name.txt))
+ with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
fl
| Ptype_abstract -> ())
- name_sdecl_list
+ sdecl_list
(* Force recursion to go through id for private types*)
let name_recursion sdecl id decl =
@@ -852,22 +875,20 @@ let name_recursion sdecl id decl =
| _ -> decl
(* Translate a set of mutually recursive type declarations *)
-let transl_type_decl env name_sdecl_list =
+let transl_type_decl env sdecl_list =
(* Add dummy types for fixed rows *)
- let fixed_types =
- List.filter (fun (_, sd) -> is_fixed_type sd) name_sdecl_list
- in
- let name_sdecl_list =
+ let fixed_types = List.filter is_fixed_type sdecl_list in
+ let sdecl_list =
List.map
- (fun (name, sdecl) ->
- mkloc (name.txt ^"#row") name.loc,
- {sdecl with ptype_kind = Ptype_abstract; ptype_manifest = None})
+ (fun sdecl ->
+ let ptype_name = mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in
+ {sdecl with ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None})
fixed_types
- @ name_sdecl_list
+ @ sdecl_list
in
(* Create identifiers. *)
let id_list =
- List.map (fun (name, _) -> Ident.create name.txt) name_sdecl_list
+ List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list
in
(*
Since we've introduced fresh idents, make sure the definition
@@ -878,7 +899,7 @@ let transl_type_decl env name_sdecl_list =
Ctype.init_def(Ident.current_time());
Ctype.begin_def();
(* Enter types. *)
- let temp_env = List.fold_left2 enter_type env name_sdecl_list id_list in
+ let temp_env = List.fold_left2 enter_type env sdecl_list id_list in
(* Translate each declaration. *)
let current_slot = ref None in
let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
@@ -905,12 +926,12 @@ let transl_type_decl env name_sdecl_list =
let transl_declaration name_sdecl (id, slot) =
current_slot := slot; transl_declaration temp_env name_sdecl id in
let tdecls =
- List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in
+ List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
let decls =
- List.map (fun (id, name_loc, tdecl) -> (id, tdecl.typ_type)) tdecls in
+ List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
current_slot := None;
(* Check for duplicates *)
- check_duplicates name_sdecl_list;
+ check_duplicates sdecl_list;
(* Build the final env. *)
let newenv =
List.fold_right
@@ -919,15 +940,15 @@ let transl_type_decl env name_sdecl_list =
in
(* Update stubs *)
List.iter2
- (fun id (_, sdecl) -> update_type temp_env newenv id sdecl.ptype_loc)
- id_list name_sdecl_list;
+ (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc)
+ id_list sdecl_list;
(* Generalize type declarations. *)
Ctype.end_def();
List.iter (fun (_, decl) -> generalize_decl decl) decls;
(* Check for ill-formed abbrevs *)
let id_loc_list =
- List.map2 (fun id (_,sdecl) -> (id, sdecl.ptype_loc))
- id_list name_sdecl_list
+ List.map2 (fun id sdecl -> (id, sdecl.ptype_loc))
+ id_list sdecl_list
in
List.iter (fun (id, decl) ->
check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl)
@@ -935,35 +956,40 @@ let transl_type_decl env name_sdecl_list =
List.iter (check_abbrev_recursion newenv id_loc_list) tdecls;
(* Check that all type variable are closed *)
List.iter2
- (fun (_, sdecl) (id, _, tdecl) ->
+ (fun sdecl tdecl ->
let decl = tdecl.typ_type in
match Ctype.closed_type_decl decl with
Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
| None -> ())
- name_sdecl_list tdecls;
+ sdecl_list tdecls;
(* Check that constraints are enforced *)
- List.iter2 (check_constraints newenv) name_sdecl_list decls;
+ List.iter2 (check_constraints newenv) sdecl_list decls;
(* Name recursion *)
let decls =
- List.map2 (fun (_, sdecl) (id, decl) ->
- id, name_recursion sdecl id decl)
- name_sdecl_list decls
+ List.map2 (fun sdecl (id, decl) -> id, name_recursion sdecl id decl)
+ sdecl_list decls
in
(* Add variances to the environment *)
let required =
List.map
- (fun (_, sdecl) -> add_injectivity sdecl.ptype_variance, sdecl.ptype_loc)
- name_sdecl_list
+ (fun sdecl ->
+ add_injectivity (List.map snd sdecl.ptype_params),
+ sdecl.ptype_loc
+ )
+ sdecl_list
in
let final_decls, final_env =
compute_variance_fixpoint env decls required (List.map init_variance decls)
in
(* Check re-exportation *)
- List.iter2 (check_abbrev final_env) name_sdecl_list final_decls;
+ List.iter2 (check_abbrev final_env) sdecl_list final_decls;
(* Keep original declaration *)
- let final_decls = List.map2 (fun (id, name_loc, tdecl) (id2, decl) ->
- (id, name_loc, { tdecl with typ_type = decl })
- ) tdecls final_decls in
+ let final_decls =
+ List.map2
+ (fun tdecl (id2, decl) ->
+ { tdecl with typ_type = decl }
+ ) tdecls final_decls
+ in
(* Done *)
(final_decls, final_env)
@@ -978,15 +1004,27 @@ let transl_closed_type env sty =
in
{ cty with ctyp_type = ty }
-let transl_exception env loc excdecl =
+let transl_exception env excdecl =
+ let loc = excdecl.pcd_loc in
+ if excdecl.pcd_res <> None then raise (Error (loc, Exception_constructor_with_result));
reset_type_variables();
Ctype.begin_def();
- let ttypes = List.map (transl_closed_type env) excdecl in
+ let ttypes = List.map (transl_closed_type env) excdecl.pcd_args in
Ctype.end_def();
let types = List.map (fun cty -> cty.ctyp_type) ttypes in
List.iter Ctype.generalize types;
let exn_decl = { exn_args = types; Types.exn_loc = loc } in
- { exn_params = ttypes; exn_exn = exn_decl; Typedtree.exn_loc = loc }
+ let (id, newenv) = Env.enter_exception excdecl.pcd_name.txt exn_decl env in
+ let cd =
+ { cd_id = id;
+ cd_name = excdecl.pcd_name;
+ cd_args = ttypes;
+ cd_loc = loc;
+ cd_res = None;
+ cd_attributes = excdecl.pcd_attributes;
+ }
+ in
+ cd, exn_decl, newenv
(* Translate an exception rebinding *)
let transl_exn_rebind env loc lid =
@@ -1020,9 +1058,21 @@ let transl_value_decl env loc valdecl =
then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
{ val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc }
in
- { val_desc = cty; val_val = v;
- val_prim = valdecl.pval_prim;
- val_loc = valdecl.pval_loc; }
+ let (id, newenv) =
+ Env.enter_value valdecl.pval_name.txt v env
+ ~check:(fun s -> Warnings.Unused_value_declaration s)
+ in
+ let desc =
+ {
+ val_id = id;
+ val_name = valdecl.pval_name;
+ val_desc = cty; val_val = v;
+ val_prim = valdecl.pval_prim;
+ val_loc = valdecl.pval_loc;
+ val_attributes = valdecl.pval_attributes;
+ }
+ in
+ desc, newenv
(* Translate a "with" constraint -- much simplified version of
transl_type_decl. *)
@@ -1076,18 +1126,20 @@ let transl_with_constraint env id row_path orig_decl sdecl =
let decl =
{decl with type_variance =
compute_variance_decl env false decl
- (add_injectivity sdecl.ptype_variance, sdecl.ptype_loc)} in
+ (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)} in
Ctype.end_def();
generalize_decl decl;
{
+ typ_id = id;
+ typ_name = sdecl.ptype_name;
typ_params = sdecl.ptype_params;
typ_type = decl;
typ_cstrs = constraints;
typ_loc = sdecl.ptype_loc;
typ_manifest = tman;
typ_kind = Ttype_abstract;
- typ_variance = sdecl.ptype_variance;
typ_private = sdecl.ptype_private;
+ typ_attributes = sdecl.ptype_attributes;
}
(* Approximate a type declaration: just make all types abstract *)
@@ -1110,12 +1162,12 @@ let abstract_type_decl arity =
generalize_decl decl;
decl
-let approx_type_decl env name_sdecl_list =
+let approx_type_decl env sdecl_list =
List.map
- (fun (name, sdecl) ->
- (Ident.create name.txt,
+ (fun sdecl ->
+ (Ident.create sdecl.ptype_name.txt,
abstract_type_decl (List.length sdecl.ptype_params)))
- name_sdecl_list
+ sdecl_list
(* Variant of check_abbrev_recursion to check the well-formedness
conditions on type abbreviations defined within recursive modules. *)
@@ -1281,3 +1333,5 @@ let report_error ppf = function
fprintf ppf "@[%s@ %s@ %s@]"
"In this GADT definition," "the variance of some parameter"
"cannot be checked"
+ | Exception_constructor_with_result ->
+ fprintf ppf "Exception constructors cannot specify a result type"
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 869438e645..89eb07517e 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -12,24 +12,23 @@
(* Typing of type definitions and primitive definitions *)
-open Asttypes
open Types
open Format
val transl_type_decl:
- Env.t -> (string loc * Parsetree.type_declaration) list ->
- (Ident.t * string Asttypes.loc * Typedtree.type_declaration) list * Env.t
+ Env.t -> Parsetree.type_declaration list ->
+ Typedtree.type_declaration list * Env.t
val transl_exception:
- Env.t -> Location.t ->
- Parsetree.exception_declaration -> Typedtree.exception_declaration
+ Env.t ->
+ Parsetree.constructor_declaration -> Typedtree.constructor_declaration * exception_declaration * Env.t
val transl_exn_rebind:
Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
val transl_value_decl:
Env.t -> Location.t ->
- Parsetree.value_description -> Typedtree.value_description
+ Parsetree.value_description -> Typedtree.value_description * Env.t
val transl_with_constraint:
Env.t -> Ident.t -> Path.t option -> Types.type_declaration ->
@@ -37,7 +36,7 @@ val transl_with_constraint:
val abstract_type_decl: int -> type_declaration
val approx_type_decl:
- Env.t -> (string loc * Parsetree.type_declaration) list ->
+ Env.t -> Parsetree.type_declaration list ->
(Ident.t * type_declaration) list
val check_recmod_typedecl:
Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
@@ -77,6 +76,7 @@ type error =
| Bad_fixed_type of string
| Unbound_type_var_exc of type_expr * type_expr
| Varying_anonymous
+ | Exception_constructor_with_result
exception Error of Location.t * error
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 89ac52725d..90cd6198bb 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -21,12 +21,17 @@ open Types
type partial = Partial | Total
type optional = Required | Optional
+type attribute = string loc * Parsetree.structure
+type attributes = attribute list
+
type pattern =
{ pat_desc: pattern_desc;
pat_loc: Location.t;
- pat_extra : (pat_extra * Location.t) list;
+ pat_extra : (pat_extra * Location.t * attribute list) list;
pat_type: type_expr;
- mutable pat_env: Env.t }
+ mutable pat_env: Env.t;
+ pat_attributes: attribute list;
+ }
and pat_extra =
| Tpat_constraint of core_type
@@ -40,7 +45,7 @@ and pattern_desc =
| Tpat_constant of constant
| Tpat_tuple of pattern list
| Tpat_construct of
- Longident.t loc * constructor_description * pattern list * bool
+ 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 *
@@ -52,12 +57,15 @@ and pattern_desc =
and expression =
{ exp_desc: expression_desc;
exp_loc: Location.t;
- exp_extra : (exp_extra * Location.t) list;
+ exp_extra: (exp_extra * Location.t * attribute list) list;
exp_type: type_expr;
- exp_env: Env.t }
+ exp_env: Env.t;
+ exp_attributes: attribute list;
+ }
and exp_extra =
- | Texp_constraint of core_type option * core_type option
+ | Texp_constraint of core_type
+ | Texp_coerce of core_type option * core_type
| Texp_open of override_flag * Path.t * Longident.t loc * Env.t
| Texp_poly of core_type option
| Texp_newtype of string
@@ -65,15 +73,14 @@ and exp_extra =
and expression_desc =
Texp_ident of Path.t * Longident.t loc * Types.value_description
| Texp_constant of constant
- | Texp_let of rec_flag * (pattern * expression) list * expression
- | Texp_function of label * (pattern * expression) list * partial
+ | Texp_let of rec_flag * value_binding list * expression
+ | Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
- | Texp_match of expression * (pattern * expression) list * partial
- | Texp_try of expression * (pattern * expression) list
+ | Texp_match of expression * case list * partial
+ | Texp_try of expression * case list
| Texp_tuple of expression list
| Texp_construct of
- Longident.t loc * constructor_description * expression list *
- bool
+ Longident.t loc * constructor_description * expression list
| Texp_variant of label * expression option
| Texp_record of
(Longident.t loc * label_description * expression) list *
@@ -88,7 +95,6 @@ and expression_desc =
| Texp_for of
Ident.t * string loc * expression * expression * direction_flag *
expression
- | Texp_when of expression * expression
| Texp_send of expression * meth * expression option
| Texp_new of Path.t * Longident.t loc * Types.class_declaration
| Texp_instvar of Path.t * Path.t * string loc
@@ -96,7 +102,6 @@ and expression_desc =
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of Ident.t * string loc * module_expr * expression
| Texp_assert of expression
- | Texp_assertfalse
| Texp_lazy of expression
| Texp_object of class_structure * string list
| Texp_pack of module_expr
@@ -105,56 +110,65 @@ and meth =
Tmeth_name of string
| Tmeth_val of Ident.t
+and case =
+ {
+ c_lhs: pattern;
+ c_guard: expression option;
+ c_rhs: expression;
+ }
+
(* Value expressions for the class language *)
and class_expr =
- { cl_desc: class_expr_desc;
- cl_loc: Location.t;
- cl_type: Types.class_type;
- cl_env: Env.t }
+ {
+ cl_desc: class_expr_desc;
+ cl_loc: Location.t;
+ cl_type: Types.class_type;
+ cl_env: Env.t;
+ cl_attributes: attribute list;
+ }
and class_expr_desc =
- Tcl_ident of Path.t * Longident.t loc * core_type list (* Pcl_constr *)
+ Tcl_ident of Path.t * Longident.t loc * core_type list
| Tcl_structure of class_structure
| Tcl_fun of
label * pattern * (Ident.t * string loc * expression) list * class_expr *
partial
| Tcl_apply of class_expr * (label * expression option * optional) list
- | Tcl_let of rec_flag * (pattern * expression) list *
+ | Tcl_let of rec_flag * value_binding list *
(Ident.t * string loc * expression) list * class_expr
| Tcl_constraint of
class_expr * class_type option * string list * string list * Concr.t
(* Visible instance variables, methods and concretes methods *)
and class_structure =
- { cstr_pat : pattern;
- cstr_fields: class_field list;
- cstr_type : Types.class_signature;
- cstr_meths: Ident.t Meths.t }
+ {
+ cstr_self: pattern;
+ cstr_fields: class_field list;
+ cstr_type: Types.class_signature;
+ cstr_meths: Ident.t Meths.t;
+ }
and class_field =
{
- cf_desc : class_field_desc;
- cf_loc : Location.t;
+ cf_desc: class_field_desc;
+ cf_loc: Location.t;
+ cf_attributes: attribute list;
}
and class_field_kind =
- Tcfk_virtual of core_type
-| Tcfk_concrete of expression
+ | Tcfk_virtual of core_type
+ | Tcfk_concrete of override_flag * expression
and class_field_desc =
- Tcf_inher of
+ Tcf_inherit of
override_flag * class_expr * string option * (string * Ident.t) list *
(string * Ident.t) list
(* Inherited instance variables and concrete methods *)
- | Tcf_val of
- string * string loc * mutable_flag * Ident.t * class_field_kind * bool
- (* None = virtual, true = override *)
- | Tcf_meth of string * string loc * private_flag * class_field_kind * bool
- | Tcf_constr of core_type * core_type
-(* | Tcf_let of rec_flag * (pattern * expression) list *
- (Ident.t * string loc * expression) list *)
- | Tcf_init of expression
+ | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+ | Tcf_method of string loc * private_flag * class_field_kind
+ | Tcf_constraint of core_type * core_type
+ | Tcf_initializer of expression
(* Value expressions for the module language *)
@@ -162,7 +176,9 @@ and module_expr =
{ mod_desc: module_expr_desc;
mod_loc: Location.t;
mod_type: Types.module_type;
- mod_env: Env.t }
+ mod_env: Env.t;
+ mod_attributes: attribute list;
+ }
and module_type_constraint =
Tmodtype_implicit
@@ -190,19 +206,35 @@ and structure_item =
}
and structure_item_desc =
- Tstr_eval of expression
- | Tstr_value of rec_flag * (pattern * expression) list
- | Tstr_primitive of Ident.t * string loc * value_description
- | Tstr_type of (Ident.t * string loc * type_declaration) list
- | Tstr_exception of Ident.t * string loc * exception_declaration
- | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc
- | Tstr_module of Ident.t * string loc * module_expr
- | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
- | Tstr_modtype of Ident.t * string loc * module_type
- | Tstr_open of override_flag * Path.t * Longident.t loc
+ Tstr_eval of expression * attributes
+ | Tstr_value of rec_flag * value_binding list
+ | Tstr_primitive of value_description
+ | Tstr_type of type_declaration list
+ | Tstr_exception of constructor_declaration
+ | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attribute list
+ | Tstr_module of module_binding
+ | Tstr_recmodule of module_binding list
+ | Tstr_modtype of module_type_declaration
+ | Tstr_open of override_flag * Path.t * Longident.t loc * attribute list
| Tstr_class of (class_declaration * string list * virtual_flag) list
| Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
- | Tstr_include of module_expr * Ident.t list
+ | Tstr_include of module_expr * Ident.t list * attribute list
+ | Tstr_attribute of attribute
+
+and module_binding =
+ {
+ mb_id: Ident.t;
+ mb_name: string loc;
+ mb_expr: module_expr;
+ mb_attributes: attribute list;
+ }
+
+and value_binding =
+ {
+ vb_pat: pattern;
+ vb_expr: expression;
+ vb_attributes: attributes;
+ }
and module_coercion =
Tcoerce_none
@@ -213,8 +245,10 @@ and module_coercion =
and module_type =
{ mty_desc: module_type_desc;
mty_type : Types.module_type;
- mty_env : Env.t; (* BINANNOT ADDED *)
- mty_loc: Location.t }
+ mty_env : Env.t;
+ mty_loc: Location.t;
+ mty_attributes: attribute list;
+ }
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
@@ -235,20 +269,33 @@ and signature_item =
sig_loc: Location.t }
and signature_item_desc =
- Tsig_value of Ident.t * string loc * value_description
- | Tsig_type of (Ident.t * string loc * type_declaration) list
- | Tsig_exception of Ident.t * string loc * exception_declaration
- | Tsig_module of Ident.t * string loc * module_type
- | Tsig_recmodule of (Ident.t * string loc * module_type) list
- | Tsig_modtype of Ident.t * string loc * modtype_declaration
- | Tsig_open of override_flag * Path.t * Longident.t loc
- | Tsig_include of module_type * Types.signature
+ Tsig_value of value_description
+ | Tsig_type of type_declaration list
+ | Tsig_exception of constructor_declaration
+ | Tsig_module of module_declaration
+ | Tsig_recmodule of module_declaration list
+ | Tsig_modtype of module_type_declaration
+ | Tsig_open of override_flag * Path.t * Longident.t loc * attribute list
+ | Tsig_include of module_type * Types.signature * attribute list
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
+ | Tsig_attribute of attribute
+
+and module_declaration =
+ {
+ md_id: Ident.t;
+ md_name: string loc;
+ md_type: module_type;
+ md_attributes: attribute list;
+ }
-and modtype_declaration =
- Tmodtype_abstract
- | Tmodtype_manifest of module_type
+and module_type_declaration =
+ {
+ mtd_id: Ident.t;
+ mtd_name: string loc;
+ mtd_type: module_type option;
+ mtd_attributes: attribute list;
+ }
and with_constraint =
Twith_type of type_declaration
@@ -261,7 +308,9 @@ and core_type =
{ mutable ctyp_desc : core_type_desc;
mutable ctyp_type : type_expr;
ctyp_env : Env.t; (* BINANNOT ADDED *)
- ctyp_loc : Location.t }
+ ctyp_loc : Location.t;
+ ctyp_attributes: attribute list;
+ }
and core_type_desc =
Ttyp_any
@@ -269,10 +318,10 @@ and core_type_desc =
| Ttyp_arrow of label * core_type * core_type
| Ttyp_tuple of core_type list
| Ttyp_constr of Path.t * Longident.t loc * core_type list
- | Ttyp_object of core_field_type list
- | Ttyp_class of Path.t * Longident.t loc * core_type list * label list
+ | Ttyp_object of (string * core_type) list * closed_flag
+ | Ttyp_class of Path.t * Longident.t loc * core_type list
| Ttyp_alias of core_type * string
- | Ttyp_variant of row_field list * bool * label list option
+ | Ttyp_variant of row_field list * closed_flag * label list option
| Ttyp_poly of string list * core_type
| Ttyp_package of package_type
@@ -283,75 +332,89 @@ and package_type = {
pack_txt : Longident.t loc;
}
-and core_field_type =
- { field_desc: core_field_desc;
- field_loc: Location.t }
-
-and core_field_desc =
- Tcfield of string * core_type
- | Tcfield_var
-
and row_field =
Ttag of label * bool * core_type list
| Tinherit of core_type
and value_description =
- { val_desc : core_type;
- val_val : Types.value_description;
- val_prim : string list;
- val_loc : Location.t;
+ { val_id: Ident.t;
+ val_name: string loc;
+ val_desc: core_type;
+ val_val: Types.value_description;
+ val_prim: string list;
+ val_loc: Location.t;
+ val_attributes: attribute list;
}
and type_declaration =
- { typ_params: string loc option list;
- typ_type : Types.type_declaration;
+ { typ_id: Ident.t;
+ typ_name: string loc;
+ typ_params: (string loc option * variance) list;
+ typ_type: Types.type_declaration;
typ_cstrs: (core_type * core_type * Location.t) list;
typ_kind: type_kind;
typ_private: private_flag;
typ_manifest: core_type option;
- typ_variance: (bool * bool) list;
- typ_loc: Location.t }
+ typ_loc: Location.t;
+ typ_attributes: attribute list;
+ }
and type_kind =
Ttype_abstract
- | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
- | Ttype_record of
- (Ident.t * string loc * mutable_flag * core_type * Location.t) list
+ | Ttype_variant of constructor_declaration list
+ | Ttype_record of label_declaration list
+
+and label_declaration =
+ {
+ ld_id: Ident.t;
+ ld_name: string loc;
+ ld_mutable: mutable_flag;
+ ld_type: core_type;
+ ld_loc: Location.t;
+ ld_attributes: attribute list;
+ }
-and exception_declaration =
- { exn_params : core_type list;
- exn_exn : Types.exception_declaration;
- exn_loc : Location.t }
+and constructor_declaration =
+ {
+ cd_id: Ident.t;
+ cd_name: string loc;
+ cd_args: core_type list;
+ cd_res: core_type option;
+ cd_loc: Location.t;
+ cd_attributes: attribute list;
+ }
and class_type =
- { cltyp_desc: class_type_desc;
- cltyp_type : Types.class_type;
- cltyp_env : Env.t; (* BINANNOT ADDED *)
- cltyp_loc: Location.t }
+ {
+ cltyp_desc: class_type_desc;
+ cltyp_type: Types.class_type;
+ cltyp_env: Env.t;
+ cltyp_loc: Location.t;
+ cltyp_attributes: attribute list;
+ }
and class_type_desc =
Tcty_constr of Path.t * Longident.t loc * core_type list
| Tcty_signature of class_signature
- | Tcty_fun of label * core_type * class_type
+ | Tcty_arrow of label * core_type * class_type
and class_signature = {
csig_self : core_type;
csig_fields : class_type_field list;
csig_type : Types.class_signature;
- csig_loc : Location.t;
}
and class_type_field = {
- ctf_desc : class_type_field_desc;
- ctf_loc : Location.t;
+ ctf_desc: class_type_field_desc;
+ ctf_loc: Location.t;
+ ctf_attributes: attribute list;
}
and class_type_field_desc =
- Tctf_inher of class_type
+ | Tctf_inherit of class_type
| Tctf_val of (string * mutable_flag * virtual_flag * core_type)
- | Tctf_virt of (string * private_flag * core_type)
- | Tctf_meth of (string * private_flag * core_type)
- | Tctf_cstr of (core_type * core_type)
+ | Tctf_method of (string * private_flag * virtual_flag * core_type)
+ | Tctf_constraint of (core_type * core_type)
and class_declaration =
class_expr class_infos
@@ -364,7 +427,7 @@ and class_type_declaration =
and 'a class_infos =
{ ci_virt: virtual_flag;
- ci_params: string loc list * Location.t;
+ ci_params: (string loc * variance) list;
ci_id_name : string loc;
ci_id_class: Ident.t;
ci_id_class_type : Ident.t;
@@ -373,15 +436,16 @@ and 'a class_infos =
ci_expr: 'a;
ci_decl: Types.class_declaration;
ci_type_decl : Types.class_type_declaration;
- ci_variance: (bool * bool) list;
- ci_loc: Location.t }
+ ci_loc: Location.t;
+ ci_attributes: attribute list;
+ }
(* Auxiliary functions over the a.s.t. *)
let iter_pattern_desc f = function
| Tpat_alias(p, _, _) -> f p
| Tpat_tuple patl -> List.iter f patl
- | Tpat_construct(_, cstr, patl, _) -> List.iter f patl
+ | Tpat_construct(_, cstr, patl) -> List.iter f patl
| Tpat_variant(_, pat, _) -> may f pat
| Tpat_record (lbl_pat_list, _) ->
List.iter (fun (_, lbl, pat) -> f pat) lbl_pat_list
@@ -400,8 +464,8 @@ let map_pattern_desc f d =
Tpat_tuple (List.map f pats)
| Tpat_record (lpats, closed) ->
Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed)
- | Tpat_construct (lid, c,pats, arity) ->
- Tpat_construct (lid, c, List.map f pats, arity)
+ | Tpat_construct (lid, c,pats) ->
+ Tpat_construct (lid, c, List.map f pats)
| Tpat_array pats ->
Tpat_array (List.map f pats)
| Tpat_lazy p1 -> Tpat_lazy (f p1)
@@ -431,9 +495,9 @@ let rec bound_idents pat =
let pat_bound_idents pat =
idents := []; bound_idents pat; let res = !idents in idents := []; res
-let rev_let_bound_idents_with_loc pat_expr_list =
+let rev_let_bound_idents_with_loc bindings =
idents := [];
- List.iter (fun (pat, expr) -> bound_idents pat) pat_expr_list;
+ List.iter (fun vb -> bound_idents vb.vb_pat) bindings;
let res = !idents in idents := []; res
let let_bound_idents_with_loc pat_expr_list =
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 70e79b04cc..e55561d08c 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -20,12 +20,17 @@ open Types
type partial = Partial | Total
type optional = Required | Optional
+type attribute = string loc * Parsetree.structure
+type attributes = attribute list
+
type pattern =
{ pat_desc: pattern_desc;
pat_loc: Location.t;
- pat_extra : (pat_extra * Location.t) list;
+ pat_extra : (pat_extra * Location.t * attributes) list;
pat_type: type_expr;
- mutable pat_env: Env.t }
+ mutable pat_env: Env.t;
+ pat_attributes: attributes;
+ }
and pat_extra =
| Tpat_constraint of core_type
@@ -39,7 +44,7 @@ and pattern_desc =
| Tpat_constant of constant
| Tpat_tuple of pattern list
| Tpat_construct of
- Longident.t loc * constructor_description * pattern list * bool
+ 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 *
@@ -51,12 +56,15 @@ and pattern_desc =
and expression =
{ exp_desc: expression_desc;
exp_loc: Location.t;
- exp_extra : (exp_extra * Location.t) list;
+ exp_extra: (exp_extra * Location.t * attributes) list;
exp_type: type_expr;
- exp_env: Env.t }
+ exp_env: Env.t;
+ exp_attributes: attributes;
+ }
and exp_extra =
- | Texp_constraint of core_type option * core_type option
+ | Texp_constraint of core_type
+ | Texp_coerce of core_type option * core_type
| Texp_open of override_flag * Path.t * Longident.t loc * Env.t
| Texp_poly of core_type option
| Texp_newtype of string
@@ -64,15 +72,14 @@ and exp_extra =
and expression_desc =
Texp_ident of Path.t * Longident.t loc * Types.value_description
| Texp_constant of constant
- | Texp_let of rec_flag * (pattern * expression) list * expression
- | Texp_function of label * (pattern * expression) list * partial
+ | Texp_let of rec_flag * value_binding list * expression
+ | Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
- | Texp_match of expression * (pattern * expression) list * partial
- | Texp_try of expression * (pattern * expression) list
+ | Texp_match of expression * case list * partial
+ | Texp_try of expression * case list
| Texp_tuple of expression list
| Texp_construct of
- Longident.t loc * constructor_description * expression list *
- bool
+ Longident.t loc * constructor_description * expression list
| Texp_variant of label * expression option
| Texp_record of
(Longident.t loc * label_description * expression) list *
@@ -87,7 +94,6 @@ and expression_desc =
| Texp_for of
Ident.t * string loc * expression * expression * direction_flag *
expression
- | Texp_when of expression * expression
| Texp_send of expression * meth * expression option
| Texp_new of Path.t * Longident.t loc * Types.class_declaration
| Texp_instvar of Path.t * Path.t * string loc
@@ -95,7 +101,6 @@ and expression_desc =
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of Ident.t * string loc * module_expr * expression
| Texp_assert of expression
- | Texp_assertfalse
| Texp_lazy of expression
| Texp_object of class_structure * string list
| Texp_pack of module_expr
@@ -104,13 +109,23 @@ and meth =
Tmeth_name of string
| Tmeth_val of Ident.t
+and case =
+ {
+ c_lhs: pattern;
+ c_guard: expression option;
+ c_rhs: expression;
+ }
+
(* Value expressions for the class language *)
and class_expr =
- { cl_desc: class_expr_desc;
- cl_loc: Location.t;
- cl_type: Types.class_type;
- cl_env: Env.t }
+ {
+ cl_desc: class_expr_desc;
+ cl_loc: Location.t;
+ cl_type: Types.class_type;
+ cl_env: Env.t;
+ cl_attributes: attributes;
+ }
and class_expr_desc =
Tcl_ident of Path.t * Longident.t loc * core_type list
@@ -119,41 +134,40 @@ and class_expr_desc =
label * pattern * (Ident.t * string loc * expression) list * class_expr *
partial
| Tcl_apply of class_expr * (label * expression option * optional) list
- | Tcl_let of rec_flag * (pattern * expression) list *
+ | Tcl_let of rec_flag * value_binding list *
(Ident.t * string loc * expression) list * class_expr
| Tcl_constraint of
class_expr * class_type option * string list * string list * Concr.t
(* Visible instance variables, methods and concretes methods *)
and class_structure =
- { cstr_pat : pattern;
- cstr_fields: class_field list;
- cstr_type : Types.class_signature;
- cstr_meths: Ident.t Meths.t }
+ {
+ cstr_self: pattern;
+ cstr_fields: class_field list;
+ cstr_type: Types.class_signature;
+ cstr_meths: Ident.t Meths.t;
+ }
and class_field =
{
- cf_desc : class_field_desc;
- cf_loc : Location.t;
+ cf_desc: class_field_desc;
+ cf_loc: Location.t;
+ cf_attributes: attributes;
}
and class_field_kind =
- Tcfk_virtual of core_type
-| Tcfk_concrete of expression
+ | Tcfk_virtual of core_type
+ | Tcfk_concrete of override_flag * expression
and class_field_desc =
- Tcf_inher of
+ Tcf_inherit of
override_flag * class_expr * string option * (string * Ident.t) list *
(string * Ident.t) list
(* Inherited instance variables and concrete methods *)
- | Tcf_val of
- string * string loc * mutable_flag * Ident.t * class_field_kind * bool
- (* None = virtual, true = override *)
- | Tcf_meth of string * string loc * private_flag * class_field_kind * bool
- | Tcf_constr of core_type * core_type
-(* | Tcf_let of rec_flag * (pattern * expression) list *
- (Ident.t * string loc * expression) list *)
- | Tcf_init of expression
+ | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+ | Tcf_method of string loc * private_flag * class_field_kind
+ | Tcf_constraint of core_type * core_type
+ | Tcf_initializer of expression
(* Value expressions for the module language *)
@@ -161,7 +175,9 @@ and module_expr =
{ mod_desc: module_expr_desc;
mod_loc: Location.t;
mod_type: Types.module_type;
- mod_env: Env.t }
+ mod_env: Env.t;
+ mod_attributes: attributes;
+ }
and module_type_constraint =
Tmodtype_implicit
@@ -189,19 +205,35 @@ and structure_item =
}
and structure_item_desc =
- Tstr_eval of expression
- | Tstr_value of rec_flag * (pattern * expression) list
- | Tstr_primitive of Ident.t * string loc * value_description
- | Tstr_type of (Ident.t * string loc * type_declaration) list
- | Tstr_exception of Ident.t * string loc * exception_declaration
- | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc
- | Tstr_module of Ident.t * string loc * module_expr
- | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
- | Tstr_modtype of Ident.t * string loc * module_type
- | Tstr_open of override_flag * Path.t * Longident.t loc
+ Tstr_eval of expression * attributes
+ | Tstr_value of rec_flag * value_binding list
+ | Tstr_primitive of value_description
+ | Tstr_type of type_declaration list
+ | Tstr_exception of constructor_declaration
+ | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attributes
+ | Tstr_module of module_binding
+ | Tstr_recmodule of module_binding list
+ | Tstr_modtype of module_type_declaration
+ | Tstr_open of override_flag * Path.t * Longident.t loc * attributes
| Tstr_class of (class_declaration * string list * virtual_flag) list
| Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
- | Tstr_include of module_expr * Ident.t list
+ | Tstr_include of module_expr * Ident.t list * attributes
+ | Tstr_attribute of attribute
+
+and module_binding =
+ {
+ mb_id: Ident.t;
+ mb_name: string loc;
+ mb_expr: module_expr;
+ mb_attributes: attributes;
+ }
+
+and value_binding =
+ {
+ vb_pat: pattern;
+ vb_expr: expression;
+ vb_attributes: attributes;
+ }
and module_coercion =
Tcoerce_none
@@ -213,7 +245,9 @@ and module_type =
{ mty_desc: module_type_desc;
mty_type : Types.module_type;
mty_env : Env.t;
- mty_loc: Location.t }
+ mty_loc: Location.t;
+ mty_attributes: attributes;
+ }
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
@@ -234,20 +268,33 @@ and signature_item =
sig_loc: Location.t }
and signature_item_desc =
- Tsig_value of Ident.t * string loc * value_description
- | Tsig_type of (Ident.t * string loc * type_declaration) list
- | Tsig_exception of Ident.t * string loc * exception_declaration
- | Tsig_module of Ident.t * string loc * module_type
- | Tsig_recmodule of (Ident.t * string loc * module_type) list
- | Tsig_modtype of Ident.t * string loc * modtype_declaration
- | Tsig_open of override_flag * Path.t * Longident.t loc
- | Tsig_include of module_type * Types.signature
+ Tsig_value of value_description
+ | Tsig_type of type_declaration list
+ | Tsig_exception of constructor_declaration
+ | Tsig_module of module_declaration
+ | Tsig_recmodule of module_declaration list
+ | Tsig_modtype of module_type_declaration
+ | Tsig_open of override_flag * Path.t * Longident.t loc * attributes
+ | Tsig_include of module_type * Types.signature * attributes
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
+ | Tsig_attribute of attribute
+
+and module_declaration =
+ {
+ md_id: Ident.t;
+ md_name: string loc;
+ md_type: module_type;
+ md_attributes: attributes;
+ }
-and modtype_declaration =
- Tmodtype_abstract
- | Tmodtype_manifest of module_type
+and module_type_declaration =
+ {
+ mtd_id: Ident.t;
+ mtd_name: string loc;
+ mtd_type: module_type option;
+ mtd_attributes: attributes;
+ }
and with_constraint =
Twith_type of type_declaration
@@ -260,7 +307,9 @@ and core_type =
{ mutable ctyp_desc : core_type_desc;
mutable ctyp_type : type_expr;
ctyp_env : Env.t; (* BINANNOT ADDED *)
- ctyp_loc : Location.t }
+ ctyp_loc : Location.t;
+ ctyp_attributes: attributes;
+ }
and core_type_desc =
Ttyp_any
@@ -268,10 +317,10 @@ and core_type_desc =
| Ttyp_arrow of label * core_type * core_type
| Ttyp_tuple of core_type list
| Ttyp_constr of Path.t * Longident.t loc * core_type list
- | Ttyp_object of core_field_type list
- | Ttyp_class of Path.t * Longident.t loc * core_type list * label list
+ | Ttyp_object of (string * core_type) list * closed_flag
+ | Ttyp_class of Path.t * Longident.t loc * core_type list
| Ttyp_alias of core_type * string
- | Ttyp_variant of row_field list * bool * label list option
+ | Ttyp_variant of row_field list * closed_flag * label list option
| Ttyp_poly of string list * core_type
| Ttyp_package of package_type
@@ -282,75 +331,90 @@ and package_type = {
pack_txt : Longident.t loc;
}
-and core_field_type =
- { field_desc: core_field_desc;
- field_loc: Location.t }
-
-and core_field_desc =
- Tcfield of string * core_type
- | Tcfield_var
-
and row_field =
Ttag of label * bool * core_type list
| Tinherit of core_type
and value_description =
- { val_desc : core_type;
- val_val : Types.value_description;
- val_prim : string list;
- val_loc : Location.t;
+ { val_id: Ident.t;
+ val_name: string loc;
+ val_desc: core_type;
+ val_val: Types.value_description;
+ val_prim: string list;
+ val_loc: Location.t;
+ val_attributes: attributes;
}
and type_declaration =
- { typ_params: string loc option list;
- typ_type : Types.type_declaration;
+ {
+ typ_id: Ident.t;
+ typ_name: string loc;
+ typ_params: (string loc option * variance) list;
+ typ_type: Types.type_declaration;
typ_cstrs: (core_type * core_type * Location.t) list;
typ_kind: type_kind;
typ_private: private_flag;
typ_manifest: core_type option;
- typ_variance: (bool * bool) list;
- typ_loc: Location.t }
+ typ_loc: Location.t;
+ typ_attributes: attributes;
+ }
and type_kind =
Ttype_abstract
- | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
- | Ttype_record of
- (Ident.t * string loc * mutable_flag * core_type * Location.t) list
+ | Ttype_variant of constructor_declaration list
+ | Ttype_record of label_declaration list
+
+and label_declaration =
+ {
+ ld_id: Ident.t;
+ ld_name: string loc;
+ ld_mutable: mutable_flag;
+ ld_type: core_type;
+ ld_loc: Location.t;
+ ld_attributes: attributes;
+ }
-and exception_declaration =
- { exn_params : core_type list;
- exn_exn : Types.exception_declaration;
- exn_loc : Location.t }
+and constructor_declaration =
+ {
+ cd_id: Ident.t;
+ cd_name: string loc;
+ cd_args: core_type list;
+ cd_res: core_type option;
+ cd_loc: Location.t;
+ cd_attributes: attributes;
+ }
and class_type =
- { cltyp_desc: class_type_desc;
- cltyp_type : Types.class_type;
- cltyp_env : Env.t; (* BINANNOT ADDED *)
- cltyp_loc: Location.t }
+ {
+ cltyp_desc: class_type_desc;
+ cltyp_type: Types.class_type;
+ cltyp_env: Env.t;
+ cltyp_loc: Location.t;
+ cltyp_attributes: attributes;
+ }
and class_type_desc =
Tcty_constr of Path.t * Longident.t loc * core_type list
| Tcty_signature of class_signature
- | Tcty_fun of label * core_type * class_type
+ | Tcty_arrow of label * core_type * class_type
and class_signature = {
csig_self : core_type;
csig_fields : class_type_field list;
csig_type : Types.class_signature;
- csig_loc : Location.t;
}
and class_type_field = {
- ctf_desc : class_type_field_desc;
- ctf_loc : Location.t;
+ ctf_desc: class_type_field_desc;
+ ctf_loc: Location.t;
+ ctf_attributes: attributes;
}
and class_type_field_desc =
- Tctf_inher of class_type
+ | Tctf_inherit of class_type
| Tctf_val of (string * mutable_flag * virtual_flag * core_type)
- | Tctf_virt of (string * private_flag * core_type)
- | Tctf_meth of (string * private_flag * core_type)
- | Tctf_cstr of (core_type * core_type)
+ | Tctf_method of (string * private_flag * virtual_flag * core_type)
+ | Tctf_constraint of (core_type * core_type)
and class_declaration =
class_expr class_infos
@@ -363,7 +427,7 @@ and class_type_declaration =
and 'a class_infos =
{ ci_virt: virtual_flag;
- ci_params: string loc list * Location.t;
+ ci_params: (string loc * variance) list;
ci_id_name : string loc;
ci_id_class: Ident.t;
ci_id_class_type : Ident.t;
@@ -372,21 +436,20 @@ and 'a class_infos =
ci_expr: 'a;
ci_decl: Types.class_declaration;
ci_type_decl : Types.class_type_declaration;
- ci_variance: (bool * bool) list;
- ci_loc: Location.t }
+ ci_loc: Location.t;
+ ci_attributes: attributes;
+ }
(* Auxiliary functions over the a.s.t. *)
val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit
val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc
-val let_bound_idents: (pattern * expression) list -> Ident.t list
-val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
+val let_bound_idents: value_binding list -> Ident.t list
+val rev_let_bound_idents: value_binding list -> Ident.t list
val let_bound_idents_with_loc:
- (pattern * expression) list -> (Ident.t * string loc) list
-val rev_let_bound_idents_with_loc:
- (pattern * expression) list -> (Ident.t * string loc) list
+ value_binding list -> (Ident.t * string loc) list
(* Alpha conversion of patterns *)
val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 42808266a1..edb5587986 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -24,14 +24,12 @@ module type IteratorArgument = sig
val enter_structure : structure -> unit
val enter_value_description : value_description -> unit
val enter_type_declaration : type_declaration -> unit
- val enter_exception_declaration :
- exception_declaration -> unit
val enter_pattern : pattern -> unit
val enter_expression : expression -> unit
val enter_package_type : package_type -> unit
val enter_signature : signature -> unit
val enter_signature_item : signature_item -> unit
- val enter_modtype_declaration : modtype_declaration -> unit
+ val enter_module_type_declaration : module_type_declaration -> unit
val enter_module_type : module_type -> unit
val enter_module_expr : module_expr -> unit
val enter_with_constraint : with_constraint -> unit
@@ -43,7 +41,6 @@ module type IteratorArgument = sig
val enter_class_type : class_type -> unit
val enter_class_type_field : class_type_field -> unit
val enter_core_type : core_type -> unit
- val enter_core_field_type : core_field_type -> unit
val enter_class_structure : class_structure -> unit
val enter_class_field : class_field -> unit
val enter_structure_item : structure_item -> unit
@@ -52,14 +49,12 @@ module type IteratorArgument = sig
val leave_structure : structure -> unit
val leave_value_description : value_description -> unit
val leave_type_declaration : type_declaration -> unit
- val leave_exception_declaration :
- exception_declaration -> unit
val leave_pattern : pattern -> unit
val leave_expression : expression -> unit
val leave_package_type : package_type -> unit
val leave_signature : signature -> unit
val leave_signature_item : signature_item -> unit
- val leave_modtype_declaration : modtype_declaration -> unit
+ val leave_module_type_declaration : module_type_declaration -> unit
val leave_module_type : module_type -> unit
val leave_module_expr : module_expr -> unit
val leave_with_constraint : with_constraint -> unit
@@ -71,14 +66,13 @@ module type IteratorArgument = sig
val leave_class_type : class_type -> unit
val leave_class_type_field : class_type_field -> unit
val leave_core_type : core_type -> unit
- val leave_core_field_type : core_field_type -> unit
val leave_class_structure : class_structure -> unit
val leave_class_field : class_field -> unit
val leave_structure_item : structure_item -> unit
val enter_bindings : rec_flag -> unit
- val enter_binding : pattern -> expression -> unit
- val leave_binding : pattern -> expression -> unit
+ val enter_binding : value_binding -> unit
+ val leave_binding : value_binding -> unit
val leave_bindings : rec_flag -> unit
end
@@ -102,45 +96,45 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Some x -> f x
- open Asttypes
-
let rec iter_structure str =
Iter.enter_structure str;
List.iter iter_structure_item str.str_items;
Iter.leave_structure str
- and iter_binding (pat, exp) =
- Iter.enter_binding pat exp;
- iter_pattern pat;
- iter_expression exp;
- Iter.leave_binding pat exp
+ and iter_binding vb =
+ Iter.enter_binding vb;
+ iter_pattern vb.vb_pat;
+ iter_expression vb.vb_expr;
+ Iter.leave_binding vb
and iter_bindings rec_flag list =
Iter.enter_bindings rec_flag;
List.iter iter_binding list;
Iter.leave_bindings rec_flag
+ and iter_case {c_lhs; c_guard; c_rhs} =
+ iter_pattern c_lhs;
+ may_iter iter_expression c_guard;
+ iter_expression c_rhs
+
+ and iter_cases cases =
+ List.iter iter_case cases
+
and iter_structure_item item =
Iter.enter_structure_item item;
begin
match item.str_desc with
- Tstr_eval exp -> iter_expression exp
+ Tstr_eval (exp, _attrs) -> iter_expression exp
| Tstr_value (rec_flag, list) ->
iter_bindings rec_flag list
- | Tstr_primitive (id, _, v) -> iter_value_description v
- | Tstr_type list ->
- List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
- | Tstr_exception (id, _, decl) -> iter_exception_declaration decl
- | Tstr_exn_rebind (id, _, p, _) -> ()
- | Tstr_module (id, _, mexpr) ->
- iter_module_expr mexpr
- | Tstr_recmodule list ->
- List.iter (fun (id, _, mtype, mexpr) ->
- iter_module_type mtype;
- iter_module_expr mexpr) list
- | Tstr_modtype (id, _, mtype) ->
- iter_module_type mtype
+ | Tstr_primitive vd -> iter_value_description vd
+ | Tstr_type list -> List.iter iter_type_declaration list
+ | Tstr_exception cd -> iter_constructor_declaration cd
+ | Tstr_exn_rebind _ -> ()
+ | Tstr_module x -> iter_module_binding x
+ | Tstr_recmodule list -> List.iter iter_module_binding list
+ | Tstr_modtype mtd -> iter_module_type_declaration mtd
| Tstr_open _ -> ()
| Tstr_class list ->
List.iter (fun (ci, _, _) ->
@@ -154,16 +148,25 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_class_type ct.ci_expr;
Iter.leave_class_type_declaration ct;
) list
- | Tstr_include (mexpr, _) ->
+ | Tstr_include (mexpr, _, _attrs) ->
iter_module_expr mexpr
+ | Tstr_attribute _ ->
+ ()
end;
Iter.leave_structure_item item
+ and iter_module_binding x =
+ iter_module_expr x.mb_expr
+
and iter_value_description v =
Iter.enter_value_description v;
iter_core_type v.val_desc;
Iter.leave_value_description v
+ and iter_constructor_declaration cd =
+ List.iter iter_core_type cd.cd_args;
+ option iter_core_type cd.cd_res;
+
and iter_type_declaration decl =
Iter.enter_type_declaration decl;
List.iter (fun (ct1, ct2, loc) ->
@@ -173,12 +176,11 @@ module MakeIterator(Iter : IteratorArgument) : sig
begin match decl.typ_kind with
Ttype_abstract -> ()
| Ttype_variant list ->
- List.iter (fun (s, _, cts, loc) ->
- List.iter iter_core_type cts
- ) list
+ List.iter iter_constructor_declaration list
| Ttype_record list ->
- List.iter (fun (s, _, mut, ct, loc) ->
- iter_core_type ct
+ List.iter
+ (fun ld ->
+ iter_core_type ld.ld_type
) list
end;
begin match decl.typ_manifest with
@@ -187,14 +189,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
end;
Iter.leave_type_declaration decl
- and iter_exception_declaration decl =
- Iter.enter_exception_declaration decl;
- List.iter iter_core_type decl.exn_params;
- Iter.leave_exception_declaration decl;
-
and iter_pattern pat =
Iter.enter_pattern pat;
- List.iter (fun (cstr, _) -> match cstr with
+ List.iter (fun (cstr, _, _attrs) -> match cstr with
| Tpat_type _ -> ()
| Tpat_unpack -> ()
| Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
@@ -206,7 +203,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Tpat_constant cst -> ()
| Tpat_tuple list ->
List.iter iter_pattern list
- | Tpat_construct (_, _, args, _) ->
+ | Tpat_construct (_, _, args) ->
List.iter iter_pattern args
| Tpat_variant (label, pato, _) ->
begin match pato with
@@ -225,10 +222,12 @@ module MakeIterator(Iter : IteratorArgument) : sig
and iter_expression exp =
Iter.enter_expression exp;
- List.iter (function (cstr, _) ->
+ List.iter (function (cstr, _, _attrs) ->
match cstr with
- Texp_constraint (cty1, cty2) ->
- option iter_core_type cty1; option iter_core_type cty2
+ Texp_constraint ct ->
+ iter_core_type ct
+ | Texp_coerce (cty1, cty2) ->
+ option iter_core_type cty1; iter_core_type cty2
| Texp_open (_, path, _, _) -> ()
| Texp_poly cto -> option iter_core_type cto
| Texp_newtype s -> ())
@@ -241,7 +240,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_bindings rec_flag list;
iter_expression exp
| Texp_function (label, cases, _) ->
- iter_bindings Nonrecursive cases
+ iter_cases cases
| Texp_apply (exp, list) ->
iter_expression exp;
List.iter (fun (label, expo, _) ->
@@ -251,13 +250,13 @@ module MakeIterator(Iter : IteratorArgument) : sig
) list
| Texp_match (exp, list, _) ->
iter_expression exp;
- iter_bindings Nonrecursive list
+ iter_cases list
| Texp_try (exp, list) ->
iter_expression exp;
- iter_bindings Nonrecursive list
+ iter_cases list
| Texp_tuple list ->
List.iter iter_expression list
- | Texp_construct (_, _, args, _) ->
+ | Texp_construct (_, _, args) ->
List.iter iter_expression args
| Texp_variant (label, expo) ->
begin match expo with
@@ -294,9 +293,6 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_expression exp1;
iter_expression exp2;
iter_expression exp3
- | Texp_when (exp1, exp2) ->
- iter_expression exp1;
- iter_expression exp2
| Texp_send (exp, meth, expo) ->
iter_expression exp;
begin
@@ -316,7 +312,6 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_module_expr mexpr;
iter_expression exp
| Texp_assert exp -> iter_expression exp
- | Texp_assertfalse -> ()
| Texp_lazy exp -> iter_expression exp
| Texp_object (cl, _) ->
iter_class_structure cl
@@ -339,37 +334,36 @@ module MakeIterator(Iter : IteratorArgument) : sig
Iter.enter_signature_item item;
begin
match item.sig_desc with
- Tsig_value (id, _, v) ->
- iter_value_description v
+ Tsig_value vd ->
+ iter_value_description vd
| Tsig_type list ->
- List.iter (fun (id, _, decl) ->
- iter_type_declaration decl
- ) list
- | Tsig_exception (id, _, decl) ->
- iter_exception_declaration decl
- | Tsig_module (id, _, mtype) ->
- iter_module_type mtype
+ List.iter iter_type_declaration list
+ | Tsig_exception cd ->
+ iter_constructor_declaration cd
+ | Tsig_module md ->
+ iter_module_type md.md_type
| Tsig_recmodule list ->
- List.iter (fun (id, _, mtype) -> iter_module_type mtype) list
- | Tsig_modtype (id, _, mdecl) ->
- iter_modtype_declaration mdecl
+ List.iter (fun md -> iter_module_type md.md_type) list
+ | Tsig_modtype mtd ->
+ iter_module_type_declaration mtd
| Tsig_open _ -> ()
- | Tsig_include (mty,_) -> iter_module_type mty
+ | Tsig_include (mty, _, _attrs) -> iter_module_type mty
| Tsig_class list ->
List.iter iter_class_description list
| Tsig_class_type list ->
List.iter iter_class_type_declaration list
+ | Tsig_attribute _ -> ()
end;
Iter.leave_signature_item item;
- and iter_modtype_declaration mdecl =
- Iter.enter_modtype_declaration mdecl;
+ and iter_module_type_declaration mtd =
+ Iter.enter_module_type_declaration mtd;
begin
- match mdecl with
- Tmodtype_abstract -> ()
- | Tmodtype_manifest mtype -> iter_module_type mtype
+ match mtd.mtd_type with
+ | None -> ()
+ | Some mtype -> iter_module_type mtype
end;
- Iter.leave_modtype_declaration mdecl;
+ Iter.leave_module_type_declaration mtd
and iter_class_description cd =
@@ -475,7 +469,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
Tcty_signature csg -> iter_class_signature csg
| Tcty_constr (path, _, list) ->
List.iter iter_core_type list
- | Tcty_fun (label, ct, cl) ->
+ | Tcty_arrow (label, ct, cl) ->
iter_core_type ct;
iter_class_type cl
end;
@@ -492,14 +486,12 @@ module MakeIterator(Iter : IteratorArgument) : sig
Iter.enter_class_type_field ctf;
begin
match ctf.ctf_desc with
- Tctf_inher ct -> iter_class_type ct
- | Tctf_val (s, mut, virt, ct) ->
+ Tctf_inherit ct -> iter_class_type ct
+ | Tctf_val (s, _mut, _virt, ct) ->
iter_core_type ct
- | Tctf_virt (s, priv, ct) ->
+ | Tctf_method (s, _priv, _virt, ct) ->
iter_core_type ct
- | Tctf_meth (s, priv, ct) ->
- iter_core_type ct
- | Tctf_cstr (ct1, ct2) ->
+ | Tctf_constraint (ct1, ct2) ->
iter_core_type ct1;
iter_core_type ct2
end;
@@ -517,9 +509,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Ttyp_tuple list -> List.iter iter_core_type list
| Ttyp_constr (path, _, list) ->
List.iter iter_core_type list
- | Ttyp_object list ->
- List.iter iter_core_field_type list
- | Ttyp_class (path, _, list, labels) ->
+ | Ttyp_object (list, o) ->
+ List.iter (fun (_, t) -> iter_core_type t) list
+ | Ttyp_class (path, _, list) ->
List.iter iter_core_type list
| Ttyp_alias (ct, s) ->
iter_core_type ct
@@ -528,19 +520,11 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Ttyp_poly (list, ct) -> iter_core_type ct
| Ttyp_package pack -> iter_package_type pack
end;
- Iter.leave_core_type ct;
-
- and iter_core_field_type cft =
- Iter.enter_core_field_type cft;
- begin match cft.field_desc with
- Tcfield_var -> ()
- | Tcfield (s, ct) -> iter_core_type ct
- end;
- Iter.leave_core_field_type cft;
+ Iter.leave_core_type ct
and iter_class_structure cs =
Iter.enter_class_structure cs;
- iter_pattern cs.cstr_pat;
+ iter_pattern cs.cstr_self;
List.iter iter_class_field cs.cstr_fields;
Iter.leave_class_structure cs;
@@ -555,27 +539,23 @@ module MakeIterator(Iter : IteratorArgument) : sig
Iter.enter_class_field cf;
begin
match cf.cf_desc with
- Tcf_inher (ovf, cl, super, _vals, _meths) ->
+ Tcf_inherit (ovf, cl, super, _vals, _meths) ->
iter_class_expr cl
- | Tcf_constr (cty, cty') ->
+ | Tcf_constraint (cty, cty') ->
iter_core_type cty;
iter_core_type cty'
- | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) ->
+ | Tcf_val (lab, _, _, Tcfk_virtual cty, _) ->
iter_core_type cty
- | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) ->
+ | Tcf_val (lab, _, _, Tcfk_concrete (_, exp), _) ->
iter_expression exp
- | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) ->
+ | Tcf_method (lab, _, Tcfk_virtual cty) ->
iter_core_type cty
- | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) ->
+ | Tcf_method (lab, _, Tcfk_concrete (_, exp)) ->
iter_expression exp
-(* | Tcf_let (rec_flag, bindings, exps) ->
- iter_bindings rec_flag bindings;
- List.iter (fun (id, _, exp) -> iter_expression exp) exps; *)
- | Tcf_init exp ->
+ | Tcf_initializer exp ->
iter_expression exp
end;
Iter.leave_class_field cf;
-
end
module DefaultIteratorArgument = struct
@@ -589,7 +569,7 @@ module DefaultIteratorArgument = struct
let enter_package_type _ = ()
let enter_signature _ = ()
let enter_signature_item _ = ()
- let enter_modtype_declaration _ = ()
+ let enter_module_type_declaration _ = ()
let enter_module_type _ = ()
let enter_module_expr _ = ()
let enter_with_constraint _ = ()
@@ -616,7 +596,7 @@ module DefaultIteratorArgument = struct
let leave_package_type _ = ()
let leave_signature _ = ()
let leave_signature_item _ = ()
- let leave_modtype_declaration _ = ()
+ let leave_module_type_declaration _ = ()
let leave_module_type _ = ()
let leave_module_expr _ = ()
let leave_with_constraint _ = ()
@@ -633,8 +613,8 @@ module DefaultIteratorArgument = struct
let leave_class_field _ = ()
let leave_structure_item _ = ()
- let enter_binding _ _ = ()
- let leave_binding _ _ = ()
+ let enter_binding _ = ()
+ let leave_binding _ = ()
let enter_bindings _ = ()
let leave_bindings _ = ()
diff --git a/typing/typedtreeIter.mli b/typing/typedtreeIter.mli
index be9c6effb1..1582929803 100644
--- a/typing/typedtreeIter.mli
+++ b/typing/typedtreeIter.mli
@@ -18,14 +18,12 @@ module type IteratorArgument = sig
val enter_structure : structure -> unit
val enter_value_description : value_description -> unit
val enter_type_declaration : type_declaration -> unit
- val enter_exception_declaration :
- exception_declaration -> unit
val enter_pattern : pattern -> unit
val enter_expression : expression -> unit
val enter_package_type : package_type -> unit
val enter_signature : signature -> unit
val enter_signature_item : signature_item -> unit
- val enter_modtype_declaration : modtype_declaration -> unit
+ val enter_module_type_declaration : module_type_declaration -> unit
val enter_module_type : module_type -> unit
val enter_module_expr : module_expr -> unit
val enter_with_constraint : with_constraint -> unit
@@ -37,23 +35,20 @@ module type IteratorArgument = sig
val enter_class_type : class_type -> unit
val enter_class_type_field : class_type_field -> unit
val enter_core_type : core_type -> unit
- val enter_core_field_type : core_field_type -> unit
val enter_class_structure : class_structure -> unit
val enter_class_field : class_field -> unit
val enter_structure_item : structure_item -> unit
- val leave_structure : structure -> unit
+ val leave_structure : structure -> unit
val leave_value_description : value_description -> unit
val leave_type_declaration : type_declaration -> unit
- val leave_exception_declaration :
- exception_declaration -> unit
val leave_pattern : pattern -> unit
val leave_expression : expression -> unit
val leave_package_type : package_type -> unit
val leave_signature : signature -> unit
val leave_signature_item : signature_item -> unit
- val leave_modtype_declaration : modtype_declaration -> unit
+ val leave_module_type_declaration : module_type_declaration -> unit
val leave_module_type : module_type -> unit
val leave_module_expr : module_expr -> unit
val leave_with_constraint : with_constraint -> unit
@@ -65,14 +60,13 @@ module type IteratorArgument = sig
val leave_class_type : class_type -> unit
val leave_class_type_field : class_type_field -> unit
val leave_core_type : core_type -> unit
- val leave_core_field_type : core_field_type -> unit
val leave_class_structure : class_structure -> unit
val leave_class_field : class_field -> unit
val leave_structure_item : structure_item -> unit
val enter_bindings : rec_flag -> unit
- val enter_binding : pattern -> expression -> unit
- val leave_binding : pattern -> expression -> unit
+ val enter_binding : value_binding -> unit
+ val leave_binding : value_binding -> unit
val leave_bindings : rec_flag -> unit
end
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 2b6f641b88..a59b66c9a7 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -16,14 +16,12 @@ module type MapArgument = sig
val enter_structure : structure -> structure
val enter_value_description : value_description -> value_description
val enter_type_declaration : type_declaration -> type_declaration
- val enter_exception_declaration :
- exception_declaration -> exception_declaration
val enter_pattern : pattern -> pattern
val enter_expression : expression -> expression
val enter_package_type : package_type -> package_type
val enter_signature : signature -> signature
val enter_signature_item : signature_item -> signature_item
- val enter_modtype_declaration : modtype_declaration -> modtype_declaration
+ val enter_module_type_declaration : module_type_declaration -> module_type_declaration
val enter_module_type : module_type -> module_type
val enter_module_expr : module_expr -> module_expr
val enter_with_constraint : with_constraint -> with_constraint
@@ -36,7 +34,6 @@ module type MapArgument = sig
val enter_class_type : class_type -> class_type
val enter_class_type_field : class_type_field -> class_type_field
val enter_core_type : core_type -> core_type
- val enter_core_field_type : core_field_type -> core_field_type
val enter_class_structure : class_structure -> class_structure
val enter_class_field : class_field -> class_field
val enter_structure_item : structure_item -> structure_item
@@ -44,14 +41,12 @@ module type MapArgument = sig
val leave_structure : structure -> structure
val leave_value_description : value_description -> value_description
val leave_type_declaration : type_declaration -> type_declaration
- val leave_exception_declaration :
- exception_declaration -> exception_declaration
val leave_pattern : pattern -> pattern
val leave_expression : expression -> expression
val leave_package_type : package_type -> package_type
val leave_signature : signature -> signature
val leave_signature_item : signature_item -> signature_item
- val leave_modtype_declaration : modtype_declaration -> modtype_declaration
+ val leave_module_type_declaration : module_type_declaration -> module_type_declaration
val leave_module_type : module_type -> module_type
val leave_module_expr : module_expr -> module_expr
val leave_with_constraint : with_constraint -> with_constraint
@@ -64,7 +59,6 @@ module type MapArgument = sig
val leave_class_type : class_type -> class_type
val leave_class_type_field : class_type_field -> class_type_field
val leave_core_type : core_type -> core_type
- val leave_core_field_type : core_field_type -> core_field_type
val leave_class_structure : class_structure -> class_structure
val leave_class_field : class_field -> class_field
val leave_structure_item : structure_item -> structure_item
@@ -81,47 +75,55 @@ module MakeMap(Map : MapArgument) = struct
open Misc
- open Asttypes
let rec map_structure str =
let str = Map.enter_structure str in
let str_items = List.map map_structure_item str.str_items in
Map.leave_structure { str with str_items = str_items }
- and map_binding (pat, exp) = (map_pattern pat, map_expression exp)
+ and map_binding vb =
+ {
+ vb_pat = map_pattern vb.vb_pat;
+ vb_expr = map_expression vb.vb_expr;
+ vb_attributes = vb.vb_attributes;
+ }
and map_bindings rec_flag list =
List.map map_binding list
+ and map_case {c_lhs; c_guard; c_rhs} =
+ {
+ c_lhs = map_pattern c_lhs;
+ c_guard = may_map map_expression c_guard;
+ c_rhs = map_expression c_rhs;
+ }
+
+ and map_cases list =
+ List.map map_case list
+
and map_structure_item item =
let item = Map.enter_structure_item item in
let str_desc =
match item.str_desc with
- Tstr_eval exp -> Tstr_eval (map_expression exp)
+ Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs)
| Tstr_value (rec_flag, list) ->
Tstr_value (rec_flag, map_bindings rec_flag list)
- | Tstr_primitive (id, name, v) ->
- Tstr_primitive (id, name, map_value_description v)
+ | Tstr_primitive vd ->
+ Tstr_primitive (map_value_description vd)
| Tstr_type list ->
- Tstr_type (List.map (
- fun (id, name, decl) ->
- (id, name, map_type_declaration decl) ) list)
- | Tstr_exception (id, name, decl) ->
- Tstr_exception (id, name, map_exception_declaration decl)
- | Tstr_exn_rebind (id, name, path, lid) ->
- Tstr_exn_rebind (id, name, path, lid)
- | Tstr_module (id, name, mexpr) ->
- Tstr_module (id, name, map_module_expr mexpr)
+ Tstr_type (List.map map_type_declaration list)
+ | Tstr_exception cd ->
+ Tstr_exception (map_constructor_declaration cd)
+ | Tstr_exn_rebind (id, name, path, lid, attrs) ->
+ Tstr_exn_rebind (id, name, path, lid, attrs)
+ | Tstr_module x ->
+ Tstr_module (map_module_binding x)
| Tstr_recmodule list ->
- let list =
- List.map (fun (id, name, mtype, mexpr) ->
- (id, name, map_module_type mtype, map_module_expr mexpr)
- ) list
- in
+ let list = List.map map_module_binding list in
Tstr_recmodule list
- | Tstr_modtype (id, name, mtype) ->
- Tstr_modtype (id, name, map_module_type mtype)
- | Tstr_open (ovf, path, lid) -> Tstr_open (ovf, path, lid)
+ | Tstr_modtype mtd ->
+ Tstr_modtype (map_module_type_declaration mtd)
+ | Tstr_open (ovf, path, lid, attrs) -> Tstr_open (ovf, path, lid, attrs)
| Tstr_class list ->
let list =
List.map (fun (ci, string_list, virtual_flag) ->
@@ -139,11 +141,15 @@ module MakeMap(Map : MapArgument) = struct
(id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
) list in
Tstr_class_type list
- | Tstr_include (mexpr, idents) ->
- Tstr_include (map_module_expr mexpr, idents)
+ | Tstr_include (mexpr, idents, attrs) ->
+ Tstr_include (map_module_expr mexpr, idents, attrs)
+ | Tstr_attribute x -> Tstr_attribute x
in
Map.leave_structure_item { item with str_desc = str_desc}
+ and map_module_binding x =
+ {x with mb_expr = map_module_expr x.mb_expr}
+
and map_value_description v =
let v = Map.enter_value_description v in
let val_desc = map_core_type v.val_desc in
@@ -159,15 +165,15 @@ module MakeMap(Map : MapArgument) = struct
let typ_kind = match decl.typ_kind with
Ttype_abstract -> Ttype_abstract
| Ttype_variant list ->
- let list = List.map (fun (s, name, cts, loc) ->
- (s, name, List.map map_core_type cts, loc)
- ) list in
- Ttype_variant list
+ let list = List.map map_constructor_declaration list in
+ Ttype_variant list
| Ttype_record list ->
let list =
- List.map (fun (s, name, mut, ct, loc) ->
- (s, name, mut, map_core_type ct, loc)
- ) list in
+ List.map
+ (fun ld ->
+ {ld with ld_type = map_core_type ld.ld_type}
+ ) list
+ in
Ttype_record list
in
let typ_manifest =
@@ -178,13 +184,10 @@ module MakeMap(Map : MapArgument) = struct
Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs;
typ_kind = typ_kind; typ_manifest = typ_manifest }
- and map_exception_declaration decl =
- let decl = Map.enter_exception_declaration decl in
- let exn_params = List.map map_core_type decl.exn_params in
- let decl = { exn_params = exn_params;
- exn_exn = decl.exn_exn;
- exn_loc = decl.exn_loc } in
- Map.leave_exception_declaration decl;
+ and map_constructor_declaration cd =
+ {cd with cd_args = List.map map_core_type cd.cd_args;
+ cd_res = may_map map_core_type cd.cd_res
+ }
and map_pattern pat =
let pat = Map.enter_pattern pat in
@@ -194,9 +197,9 @@ module MakeMap(Map : MapArgument) = struct
let pat1 = map_pattern pat1 in
Tpat_alias (pat1, p, text)
| Tpat_tuple list -> Tpat_tuple (List.map map_pattern list)
- | Tpat_construct (lid, cstr_decl, args, arity) ->
+ | Tpat_construct (lid, cstr_decl, args) ->
Tpat_construct (lid, cstr_decl,
- List.map map_pattern args, arity)
+ List.map map_pattern args)
| Tpat_variant (label, pato, rowo) ->
let pato = match pato with
None -> pato
@@ -220,8 +223,8 @@ module MakeMap(Map : MapArgument) = struct
and map_pat_extra pat_extra =
match pat_extra with
- | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc)
- | (Tpat_type _ | Tpat_unpack), _ -> pat_extra
+ | Tpat_constraint ct, loc, attrs -> (Tpat_constraint (map_core_type ct), loc, attrs)
+ | (Tpat_type _ | Tpat_unpack), _, _ -> pat_extra
and map_expression exp =
let exp = Map.enter_expression exp in
@@ -234,7 +237,7 @@ module MakeMap(Map : MapArgument) = struct
map_bindings rec_flag list,
map_expression exp)
| Texp_function (label, cases, partial) ->
- Texp_function (label, map_bindings Nonrecursive cases, partial)
+ Texp_function (label, map_cases cases, partial)
| Texp_apply (exp, list) ->
Texp_apply (map_expression exp,
List.map (fun (label, expo, optional) ->
@@ -248,19 +251,19 @@ module MakeMap(Map : MapArgument) = struct
| Texp_match (exp, list, partial) ->
Texp_match (
map_expression exp,
- map_bindings Nonrecursive list,
+ map_cases list,
partial
)
| Texp_try (exp, list) ->
Texp_try (
map_expression exp,
- map_bindings Nonrecursive list
+ map_cases list
)
| Texp_tuple list ->
Texp_tuple (List.map map_expression list)
- | Texp_construct (lid, cstr_desc, args, arity) ->
+ | Texp_construct (lid, cstr_desc, args) ->
Texp_construct (lid, cstr_desc,
- List.map map_expression args, arity )
+ List.map map_expression args )
| Texp_variant (label, expo) ->
let expo =match expo with
None -> expo
@@ -313,11 +316,6 @@ module MakeMap(Map : MapArgument) = struct
dir,
map_expression exp3
)
- | Texp_when (exp1, exp2) ->
- Texp_when (
- map_expression exp1,
- map_expression exp2
- )
| Texp_send (exp, meth, expo) ->
Texp_send (map_expression exp, meth, may_map map_expression expo)
| Texp_new (path, lid, cl_decl) -> exp.exp_desc
@@ -338,7 +336,6 @@ module MakeMap(Map : MapArgument) = struct
map_expression exp
)
| Texp_assert exp -> Texp_assert (map_expression exp)
- | Texp_assertfalse -> exp.exp_desc
| Texp_lazy exp -> Texp_lazy (map_expression exp)
| Texp_object (cl, string_list) ->
Texp_object (map_class_structure cl, string_list)
@@ -349,22 +346,20 @@ module MakeMap(Map : MapArgument) = struct
Map.leave_expression {
exp with
exp_desc = exp_desc;
- exp_extra = exp_extra }
-
- and map_exp_extra exp_extra =
- let loc = snd exp_extra in
- match fst exp_extra with
- | Texp_constraint (Some ct, None) ->
- Texp_constraint (Some (map_core_type ct), None), loc
- | Texp_constraint (None, Some ct) ->
- Texp_constraint (None, Some (map_core_type ct)), loc
- | Texp_constraint (Some ct1, Some ct2) ->
- Texp_constraint (Some (map_core_type ct1),
- Some (map_core_type ct2)), loc
+ exp_extra = exp_extra; }
+
+ and map_exp_extra ((desc, loc, attrs) as exp_extra) =
+ match desc with
+ | Texp_constraint ct ->
+ Texp_constraint (map_core_type ct), loc, attrs
+ | Texp_coerce (None, ct) ->
+ Texp_coerce (None, map_core_type ct), loc, attrs
+ | Texp_coerce (Some ct1, ct2) ->
+ Texp_coerce (Some (map_core_type ct1),
+ map_core_type ct2), loc, attrs
| Texp_poly (Some ct) ->
- Texp_poly (Some ( map_core_type ct )), loc
+ Texp_poly (Some ( map_core_type ct )), loc, attrs
| Texp_newtype _
- | Texp_constraint (None, None)
| Texp_open _
| Texp_poly None -> exp_extra
@@ -384,40 +379,34 @@ module MakeMap(Map : MapArgument) = struct
let item = Map.enter_signature_item item in
let sig_desc =
match item.sig_desc with
- Tsig_value (id, name, v) ->
- Tsig_value (id, name, map_value_description v)
- | Tsig_type list -> Tsig_type (
- List.map (fun (id, name, decl) ->
- (id, name, map_type_declaration decl)
- ) list
- )
- | Tsig_exception (id, name, decl) ->
- Tsig_exception (id, name, map_exception_declaration decl)
- | Tsig_module (id, name, mtype) ->
- Tsig_module (id, name, map_module_type mtype)
+ Tsig_value vd ->
+ Tsig_value (map_value_description vd)
+ | Tsig_type list -> Tsig_type (List.map map_type_declaration list)
+ | Tsig_exception cd ->
+ Tsig_exception (map_constructor_declaration cd)
+ | Tsig_module md ->
+ Tsig_module {md with md_type = map_module_type md.md_type}
| Tsig_recmodule list ->
- Tsig_recmodule (List.map (
- fun (id, name, mtype) ->
- (id, name, map_module_type mtype) ) list)
- | Tsig_modtype (id, name, mdecl) ->
- Tsig_modtype (id, name, map_modtype_declaration mdecl)
+ Tsig_recmodule
+ (List.map
+ (fun md -> {md with md_type = map_module_type md.md_type})
+ list
+ )
+ | Tsig_modtype mtd ->
+ Tsig_modtype (map_module_type_declaration mtd)
| Tsig_open _ -> item.sig_desc
- | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid)
+ | Tsig_include (mty, lid, attrs) -> Tsig_include (map_module_type mty, lid, attrs)
| Tsig_class list -> Tsig_class (List.map map_class_description list)
| Tsig_class_type list ->
Tsig_class_type (List.map map_class_type_declaration list)
+ | Tsig_attribute _ as x -> x
in
Map.leave_signature_item { item with sig_desc = sig_desc }
- and map_modtype_declaration mdecl =
- let mdecl = Map.enter_modtype_declaration mdecl in
- let mdecl =
- match mdecl with
- Tmodtype_abstract -> Tmodtype_abstract
- | Tmodtype_manifest mtype ->
- Tmodtype_manifest (map_module_type mtype)
- in
- Map.leave_modtype_declaration mdecl
+ and map_module_type_declaration mtd =
+ let mtd = Map.enter_module_type_declaration mtd in
+ let mtd = {mtd with mtd_type = may_map map_module_type mtd.mtd_type} in
+ Map.leave_module_type_declaration mtd
and map_class_description cd =
@@ -526,8 +515,8 @@ module MakeMap(Map : MapArgument) = struct
Tcty_signature csg -> Tcty_signature (map_class_signature csg)
| Tcty_constr (path, lid, list) ->
Tcty_constr (path, lid, List.map map_core_type list)
- | Tcty_fun (label, ct, cl) ->
- Tcty_fun (label, map_core_type ct, map_class_type cl)
+ | Tcty_arrow (label, ct, cl) ->
+ Tcty_arrow (label, map_core_type ct, map_class_type cl)
in
Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
@@ -543,15 +532,13 @@ module MakeMap(Map : MapArgument) = struct
let ctf = Map.enter_class_type_field ctf in
let ctf_desc =
match ctf.ctf_desc with
- Tctf_inher ct -> Tctf_inher (map_class_type ct)
+ Tctf_inherit ct -> Tctf_inherit (map_class_type ct)
| Tctf_val (s, mut, virt, ct) ->
Tctf_val (s, mut, virt, map_core_type ct)
- | Tctf_virt (s, priv, ct) ->
- Tctf_virt (s, priv, map_core_type ct)
- | Tctf_meth (s, priv, ct) ->
- Tctf_meth (s, priv, map_core_type ct)
- | Tctf_cstr (ct1, ct2) ->
- Tctf_cstr (map_core_type ct1, map_core_type ct2)
+ | Tctf_method (s, priv, virt, ct) ->
+ Tctf_method (s, priv, virt, map_core_type ct)
+ | Tctf_constraint (ct1, ct2) ->
+ Tctf_constraint (map_core_type ct1, map_core_type ct2)
in
Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
@@ -566,9 +553,10 @@ module MakeMap(Map : MapArgument) = struct
| Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list)
| Ttyp_constr (path, lid, list) ->
Ttyp_constr (path, lid, List.map map_core_type list)
- | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list)
- | Ttyp_class (path, lid, list, labels) ->
- Ttyp_class (path, lid, List.map map_core_type list, labels)
+ | Ttyp_object (list, o) ->
+ Ttyp_object (List.map (fun (s, t) -> (s, map_core_type t)) list, o)
+ | Ttyp_class (path, lid, list) ->
+ Ttyp_class (path, lid, List.map map_core_type list)
| Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s)
| Ttyp_variant (list, bool, labels) ->
Ttyp_variant (List.map map_row_field list, bool, labels)
@@ -577,20 +565,11 @@ module MakeMap(Map : MapArgument) = struct
in
Map.leave_core_type { ct with ctyp_desc = ctyp_desc }
- and map_core_field_type cft =
- let cft = Map.enter_core_field_type cft in
- let field_desc = match cft.field_desc with
- Tcfield_var -> Tcfield_var
- | Tcfield (s, ct) -> Tcfield (s, map_core_type ct)
- in
- Map.leave_core_field_type { cft with field_desc = field_desc }
-
and map_class_structure cs =
let cs = Map.enter_class_structure cs in
- let cstr_pat = map_pattern cs.cstr_pat in
+ let cstr_self = map_pattern cs.cstr_self in
let cstr_fields = List.map map_class_field cs.cstr_fields in
- Map.leave_class_structure { cs with cstr_pat = cstr_pat;
- cstr_fields = cstr_fields }
+ Map.leave_class_structure { cs with cstr_self; cstr_fields }
and map_row_field rf =
match rf with
@@ -602,23 +581,19 @@ module MakeMap(Map : MapArgument) = struct
let cf = Map.enter_class_field cf in
let cf_desc =
match cf.cf_desc with
- Tcf_inher (ovf, cl, super, vals, meths) ->
- Tcf_inher (ovf, map_class_expr cl, super, vals, meths)
- | Tcf_constr (cty, cty') ->
- Tcf_constr (map_core_type cty, map_core_type cty')
- | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) ->
- Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty),
- override)
- | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) ->
- Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp),
- override)
- | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
- Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty),
- override)
- | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
- Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp),
- override)
- | Tcf_init exp -> Tcf_init (map_expression exp)
+ Tcf_inherit (ovf, cl, super, vals, meths) ->
+ Tcf_inherit (ovf, map_class_expr cl, super, vals, meths)
+ | Tcf_constraint (cty, cty') ->
+ Tcf_constraint (map_core_type cty, map_core_type cty')
+ | Tcf_val (lab, mut, ident, Tcfk_virtual cty, b) ->
+ Tcf_val (lab, mut, ident, Tcfk_virtual (map_core_type cty), b)
+ | Tcf_val (lab, mut, ident, Tcfk_concrete (o, exp), b) ->
+ Tcf_val (lab, mut, ident, Tcfk_concrete (o, map_expression exp), b)
+ | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+ Tcf_method (lab, priv, Tcfk_virtual (map_core_type cty))
+ | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+ Tcf_method (lab, priv, Tcfk_concrete (o, map_expression exp))
+ | Tcf_initializer exp -> Tcf_initializer (map_expression exp)
in
Map.leave_class_field { cf with cf_desc = cf_desc }
end
@@ -635,7 +610,7 @@ module DefaultMapArgument = struct
let enter_package_type t = t
let enter_signature t = t
let enter_signature_item t = t
- let enter_modtype_declaration t = t
+ let enter_module_type_declaration t = t
let enter_module_type t = t
let enter_module_expr t = t
let enter_with_constraint t = t
@@ -647,7 +622,6 @@ module DefaultMapArgument = struct
let enter_class_type t = t
let enter_class_type_field t = t
let enter_core_type t = t
- let enter_core_field_type t = t
let enter_class_structure t = t
let enter_class_field t = t
let enter_structure_item t = t
@@ -662,7 +636,7 @@ module DefaultMapArgument = struct
let leave_package_type t = t
let leave_signature t = t
let leave_signature_item t = t
- let leave_modtype_declaration t = t
+ let leave_module_type_declaration t = t
let leave_module_type t = t
let leave_module_expr t = t
let leave_with_constraint t = t
@@ -674,7 +648,6 @@ module DefaultMapArgument = struct
let leave_class_type t = t
let leave_class_type_field t = t
let leave_core_type t = t
- let leave_core_field_type t = t
let leave_class_structure t = t
let leave_class_field t = t
let leave_structure_item t = t
diff --git a/typing/typedtreeMap.mli b/typing/typedtreeMap.mli
index 0248f023aa..9ee2c8c4a5 100644
--- a/typing/typedtreeMap.mli
+++ b/typing/typedtreeMap.mli
@@ -16,14 +16,12 @@ module type MapArgument = sig
val enter_structure : structure -> structure
val enter_value_description : value_description -> value_description
val enter_type_declaration : type_declaration -> type_declaration
- val enter_exception_declaration :
- exception_declaration -> exception_declaration
val enter_pattern : pattern -> pattern
val enter_expression : expression -> expression
val enter_package_type : package_type -> package_type
val enter_signature : signature -> signature
val enter_signature_item : signature_item -> signature_item
- val enter_modtype_declaration : modtype_declaration -> modtype_declaration
+ val enter_module_type_declaration : module_type_declaration -> module_type_declaration
val enter_module_type : module_type -> module_type
val enter_module_expr : module_expr -> module_expr
val enter_with_constraint : with_constraint -> with_constraint
@@ -36,7 +34,6 @@ module type MapArgument = sig
val enter_class_type : class_type -> class_type
val enter_class_type_field : class_type_field -> class_type_field
val enter_core_type : core_type -> core_type
- val enter_core_field_type : core_field_type -> core_field_type
val enter_class_structure : class_structure -> class_structure
val enter_class_field : class_field -> class_field
val enter_structure_item : structure_item -> structure_item
@@ -44,14 +41,12 @@ module type MapArgument = sig
val leave_structure : structure -> structure
val leave_value_description : value_description -> value_description
val leave_type_declaration : type_declaration -> type_declaration
- val leave_exception_declaration :
- exception_declaration -> exception_declaration
val leave_pattern : pattern -> pattern
val leave_expression : expression -> expression
val leave_package_type : package_type -> package_type
val leave_signature : signature -> signature
val leave_signature_item : signature_item -> signature_item
- val leave_modtype_declaration : modtype_declaration -> modtype_declaration
+ val leave_module_type_declaration : module_type_declaration -> module_type_declaration
val leave_module_type : module_type -> module_type
val leave_module_expr : module_expr -> module_expr
val leave_with_constraint : with_constraint -> with_constraint
@@ -64,7 +59,6 @@ module type MapArgument = sig
val leave_class_type : class_type -> class_type
val leave_class_type_field : class_type_field -> class_type_field
val leave_core_type : core_type -> core_type
- val leave_core_field_type : core_field_type -> core_field_type
val leave_class_structure : class_structure -> class_structure
val leave_class_field : class_field -> class_field
val leave_structure_item : structure_item -> structure_item
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 475cb9b487..c281fdc77a 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -37,6 +37,8 @@ type error =
| Not_a_packed_module of type_expr
| Incomplete_packed_module of type_expr
| Scoping_pack of Longident.t * type_expr
+ | Extension of string
+ | Recursive_module_require_explicit_type
exception Error of Location.t * Env.t * error
@@ -99,8 +101,6 @@ let rec make_params n = function
[] -> []
| _ :: l -> ("a" ^ string_of_int n) :: make_params (n+1) l
-let wrap_param s = {ptyp_desc=Ptyp_var s; ptyp_loc=Location.none}
-
let make_next_first rs rem =
if rs = Trec_first then
match rem with
@@ -119,14 +119,20 @@ let make p n i =
let open Variance in
set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
-let merge_constraint initial_env loc sg lid constr =
+let merge_constraint initial_env loc sg constr =
+ let lid =
+ match constr with
+ | Pwith_type (lid, _) | Pwith_module (lid, _) -> lid
+ | Pwith_typesubst {ptype_name=s} | Pwith_modsubst (s, _) ->
+ {loc = s.loc; txt=Lident s.txt}
+ in
let real_id = ref None in
let rec merge env sg namelist row_id =
match (sg, namelist, constr) with
([], _, _) ->
raise(Error(loc, env, With_no_component lid.txt))
| (Sig_type(id, decl, rs) :: rem, [s],
- Pwith_type ({ptype_kind = Ptype_abstract} as sdecl))
+ Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)))
when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
let decl_row =
{ type_params =
@@ -136,8 +142,17 @@ let merge_constraint initial_env loc sg lid constr =
type_private = Private;
type_manifest = None;
type_variance =
- List.map (fun (c,n) -> make (not n) (not c) false)
- sdecl.ptype_variance;
+ List.map
+ (fun (_, v) ->
+ let (c, n) =
+ match v with
+ | Covariant -> true, false
+ | Contravariant -> false, true
+ | Invariant -> false, false
+ in
+ make (not n) (not c) false
+ )
+ sdecl.ptype_params;
type_loc = sdecl.ptype_loc;
type_newtype_level = None }
and id_row = Ident.create (s^"#row") in
@@ -150,7 +165,7 @@ let merge_constraint initial_env loc sg lid constr =
let rs' = if rs = Trec_first then Trec_not else rs in
(Pident id, lid, Twith_type tdecl),
Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem
- | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type sdecl)
+ | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type (_, sdecl))
when Ident.name id = s ->
let tdecl =
Typedecl.transl_with_constraint initial_env id None decl sdecl in
@@ -170,14 +185,14 @@ let merge_constraint initial_env loc sg lid constr =
real_id := Some id;
(Pident id, lid, Twith_typesubst tdecl),
make_next_first rs rem
- | (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (lid))
+ | (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (_, lid))
when Ident.name id = s ->
let (path, mty') = Typetexp.find_module initial_env loc lid.txt in
let newmty = Mtype.strengthen env mty' path in
ignore(Includemod.modtypes env newmty mty);
(Pident id, lid, Twith_module (path, lid)),
Sig_module(id, newmty, rs) :: rem
- | (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (lid))
+ | (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (_, lid))
when Ident.name id = s ->
let (path, mty') = Typetexp.find_module initial_env loc lid.txt in
let newmty = Mtype.strengthen env mty' path in
@@ -212,7 +227,7 @@ let merge_constraint initial_env loc sg lid constr =
List.map
(function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit)
stl in
- List.iter2 (fun x ox ->
+ List.iter2 (fun x (ox, _) ->
match ox with
Some y when x = y.txt -> ()
| _ -> raise Exit
@@ -227,7 +242,7 @@ let merge_constraint initial_env loc sg lid constr =
in
let sub = Subst.add_type id path Subst.identity in
Subst.signature sub sg
- | [s], Pwith_modsubst (lid) ->
+ | [s], Pwith_modsubst (_, lid) ->
let id =
match !real_id with None -> assert false | Some id -> id in
let (path, _) = Typetexp.find_module initial_env loc lid.txt in
@@ -259,7 +274,7 @@ let rec map_rec' fn decls rem =
let rec map_rec'' fn decls rem =
match decls with
- | (id, _,_ as d1) :: dl when Btype.is_row_name (Ident.name id) ->
+ | d1 :: dl when Btype.is_row_name (Ident.name d1.typ_id) ->
fn Trec_not d1 :: map_rec'' fn dl rem
| _ -> map_rec fn decls rem
@@ -286,6 +301,8 @@ let rec approx_modtype env smty =
| Pmty_typeof smod ->
let (_, mty) = !type_module_type_of_fwd env smod in
mty
+ | Pmty_extension (s, _arg) ->
+ raise (Error (s.loc, env, Extension s.txt))
and approx_sig env ssg =
match ssg with
@@ -296,29 +313,29 @@ and approx_sig env ssg =
let decls = Typedecl.approx_type_decl env sdecls in
let rem = approx_sig env srem in
map_rec' (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem
- | Psig_module(name, smty) ->
- let mty = approx_modtype env smty in
- let (id, newenv) = Env.enter_module name.txt mty env in
+ | Psig_module pmd ->
+ let mty = approx_modtype env pmd.pmd_type in
+ let (id, newenv) = Env.enter_module pmd.pmd_name.txt mty env in
Sig_module(id, mty, Trec_not) :: approx_sig newenv srem
| Psig_recmodule sdecls ->
let decls =
List.map
- (fun (name, smty) ->
- (Ident.create name.txt, approx_modtype env smty))
+ (fun pmd ->
+ (Ident.create pmd.pmd_name.txt, approx_modtype env pmd.pmd_type))
sdecls in
let newenv =
List.fold_left (fun env (id, mty) -> Env.add_module id mty env)
env decls in
map_rec (fun rs (id, mty) -> Sig_module(id, mty, rs)) decls
(approx_sig newenv srem)
- | Psig_modtype(name, sinfo) ->
- let info = approx_modtype_info env sinfo in
- let (id, newenv) = Env.enter_modtype name.txt info env in
+ | Psig_modtype d ->
+ let info = approx_modtype_info env d.pmtd_type in
+ let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
Sig_modtype(id, info) :: approx_sig newenv srem
- | Psig_open (ovf, lid) ->
+ | Psig_open (ovf, lid, _attrs) ->
let (path, mty) = type_open ovf env item.psig_loc lid in
approx_sig mty srem
- | Psig_include smty ->
+ | Psig_include (smty, _attrs) ->
let mty = approx_modtype env smty in
let sg = Subst.signature Subst.identity
(extract_sig env smty.pmty_loc mty) in
@@ -339,9 +356,9 @@ and approx_sig env ssg =
and approx_modtype_info env sinfo =
match sinfo with
- Pmodtype_abstract ->
+ None ->
Modtype_abstract
- | Pmodtype_manifest smty ->
+ | Some smty ->
Modtype_manifest(approx_modtype env smty)
(* Additional validity checks on type definitions arising from
@@ -350,11 +367,11 @@ and approx_modtype_info env sinfo =
let check_recmod_typedecls env sdecls decls =
let recmod_ids = List.map fst3 decls in
List.iter2
- (fun (_, smty) (id, _, mty) ->
+ (fun pmd (id, _, mty) ->
let mty = mty.mty_type in
List.iter
(fun path ->
- Typedecl.check_recmod_typedecl env smty.pmty_loc recmod_ids
+ Typedecl.check_recmod_typedecl env pmd.pmd_type.pmty_loc recmod_ids
path (Env.find_type path env))
(Mtype.type_paths env (Pident id) mty))
sdecls decls
@@ -403,12 +420,13 @@ let transl_modtype_longident loc env lid =
let (path, info) = Typetexp.find_modtype env loc lid in
path
-let mkmty desc typ env loc =
+let mkmty desc typ env loc attrs =
let mty = {
mty_desc = desc;
mty_type = typ;
mty_loc = loc;
mty_env = env;
+ mty_attributes = attrs;
} in
Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
mty
@@ -426,31 +444,37 @@ let rec transl_modtype env smty =
Pmty_ident lid ->
let path = transl_modtype_longident loc env lid.txt in
mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
+ smty.pmty_attributes
| Pmty_signature ssg ->
let sg = transl_signature env ssg in
mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
+ smty.pmty_attributes
| Pmty_functor(param, sarg, sres) ->
let arg = transl_modtype env sarg in
let (id, newenv) = Env.enter_module param.txt arg.mty_type env in
let res = transl_modtype newenv sres in
mkmty (Tmty_functor (id, param, arg, res))
(Mty_functor(id, arg.mty_type, res.mty_type)) env loc
+ smty.pmty_attributes
| Pmty_with(sbody, constraints) ->
let body = transl_modtype env sbody in
let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
let (tcstrs, final_sg) =
List.fold_left
- (fun (tcstrs,sg) (lid, sdecl) ->
- let (tcstr, sg) = merge_constraint env smty.pmty_loc sg lid sdecl
+ (fun (tcstrs,sg) sdecl ->
+ let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl
in
(tcstr :: tcstrs, sg)
)
([],init_sg) constraints in
mkmty (Tmty_with ( body, tcstrs))
- (Mtype.freshen (Mty_signature final_sg)) env loc
+ (Mtype.freshen (Mty_signature final_sg)) env loc
+ smty.pmty_attributes
| Pmty_typeof smod ->
let tmty, mty = !type_module_type_of_fwd env smod in
- mkmty (Tmty_typeof tmty) mty env loc
+ mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
+ | Pmty_extension (s, _arg) ->
+ raise (Error (s.loc, env, Extension s.txt))
and transl_signature env sg =
@@ -464,71 +488,67 @@ and transl_signature env sg =
| item :: srem ->
let loc = item.psig_loc in
match item.psig_desc with
- | Psig_value(name, sdesc) ->
- let tdesc = Typedecl.transl_value_decl env item.psig_loc sdesc in
- let desc = tdesc.val_val in
- let (id, newenv) =
- Env.enter_value name.txt desc env
- ~check:(fun s -> Warnings.Unused_value_declaration s) in
+ | Psig_value sdesc ->
+ let (tdesc, newenv) = Typedecl.transl_value_decl env item.psig_loc sdesc in
let (trem,rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_value (id, name, tdesc)) env loc :: trem,
- (if List.exists (Ident.equal id) (get_values rem) then rem
- else Sig_value(id, desc) :: rem),
+ mksig (Tsig_value tdesc) env loc :: trem,
+ (if List.exists (Ident.equal tdesc.val_id) (get_values rem) then rem
+ else Sig_value(tdesc.val_id, tdesc.val_val) :: rem),
final_env
| Psig_type sdecls ->
List.iter
- (fun (name, decl) ->
- check "type" item.psig_loc type_names name.txt)
+ (fun decl ->
+ check "type" item.psig_loc type_names decl.ptype_name.txt)
sdecls;
let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_type decls) env loc :: trem,
- map_rec'' (fun rs (id, _, info) ->
- Sig_type(id, info.typ_type, rs)) decls rem,
+ map_rec'' (fun rs td ->
+ Sig_type(td.typ_id, td.typ_type, rs)) decls rem,
final_env
- | Psig_exception(name, sarg) ->
- let arg = Typedecl.transl_exception env item.psig_loc sarg in
- let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in
+ | Psig_exception sarg ->
+ let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_exception (id, name, arg)) env loc :: trem,
+ let id = arg.cd_id in
+ mksig (Tsig_exception arg) env loc :: trem,
(if List.exists (Ident.equal id) (get_exceptions rem) then rem
- else Sig_exception(id, arg.exn_exn) :: rem),
+ else Sig_exception(id, decl) :: rem),
final_env
- | Psig_module(name, smty) ->
- check "module" item.psig_loc module_names name.txt;
- let tmty = transl_modtype env smty in
+ | Psig_module pmd ->
+ check "module" item.psig_loc module_names pmd.pmd_name.txt;
+ let tmty = transl_modtype env pmd.pmd_type in
let mty = tmty.mty_type in
- let (id, newenv) = Env.enter_module name.txt mty env in
+ let (id, newenv) = Env.enter_module pmd.pmd_name.txt mty env in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_module (id, name, tmty)) env loc :: trem,
+ mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_type=tmty; md_attributes=pmd.pmd_attributes}) env loc :: trem,
Sig_module(id, mty, Trec_not) :: rem,
final_env
| Psig_recmodule sdecls ->
List.iter
- (fun (name, smty) ->
- check "module" item.psig_loc module_names name.txt)
+ (fun pmd ->
+ check "module" item.psig_loc module_names pmd.pmd_name.txt)
sdecls;
let (decls, newenv) =
transl_recmodule_modtypes item.psig_loc env sdecls in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_recmodule decls) env loc :: trem,
- map_rec (fun rs (id, _, tmty) -> Sig_module(id, tmty.mty_type, rs))
+ map_rec (fun rs md -> Sig_module(md.md_id, md.md_type.mty_type, rs))
decls rem,
final_env
- | Psig_modtype(name, sinfo) ->
- check "module type" item.psig_loc modtype_names name.txt;
- let (tinfo, info) = transl_modtype_info env sinfo in
- let (id, newenv) = Env.enter_modtype name.txt info env in
+ | Psig_modtype pmtd ->
+ let newenv, mtd, sg =
+ transl_modtype_decl modtype_names env item.psig_loc pmtd
+ in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem,
- Sig_modtype(id, info) :: rem,
+ mksig (Tsig_modtype mtd) env loc :: trem,
+ sg :: rem,
final_env
- | Psig_open (ovf, lid) ->
+ | Psig_open (ovf, lid, attrs) ->
let (path, newenv) = type_open ovf env item.psig_loc lid in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_open (ovf, path,lid)) env loc :: trem,
+ mksig (Tsig_open (ovf, path,lid,attrs)) env loc :: trem,
rem, final_env
- | Psig_include smty ->
+ | Psig_include (smty, attrs) ->
let tmty = transl_modtype env smty in
let mty = tmty.mty_type in
let sg = Subst.signature Subst.identity
@@ -539,7 +559,7 @@ and transl_signature env sg =
sg;
let newenv = Env.add_signature sg env in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_include (tmty, sg)) env loc :: trem,
+ mksig (Tsig_include (tmty, sg, attrs)) env loc :: trem,
remove_duplicates (get_values rem) (get_exceptions rem) sg @ rem,
final_env
| Psig_class cl ->
@@ -584,6 +604,11 @@ and transl_signature env sg =
Sig_type(i'', d'', rs)])
classes [rem]),
final_env
+ | Psig_attribute x ->
+ let (trem,rem, final_env) = transl_sig env srem in
+ mksig (Tsig_attribute x) env loc :: trem, rem, final_env
+ | Psig_extension ((s, _), _) ->
+ raise (Error (s.loc, env, Extension s.txt))
in
let previous_saved_types = Cmt_format.get_saved_types () in
let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in
@@ -592,13 +617,28 @@ and transl_signature env sg =
((Cmt_format.Partial_signature sg) :: previous_saved_types);
sg
+and transl_modtype_decl modtype_names env loc
+ {pmtd_name; pmtd_type; pmtd_attributes} =
+ check "module type" loc modtype_names pmtd_name.txt;
+ let (tinfo, info) = transl_modtype_info env pmtd_type in
+ let (id, newenv) = Env.enter_modtype pmtd_name.txt info env in
+ let mtd =
+ {
+ mtd_id=id;
+ mtd_name=pmtd_name;
+ mtd_type=tinfo;
+ mtd_attributes=pmtd_attributes;
+ }
+ in
+ newenv, mtd, Sig_modtype(id, info)
+
and transl_modtype_info env sinfo =
match sinfo with
- Pmodtype_abstract ->
- Tmodtype_abstract, Modtype_abstract
- | Pmodtype_manifest smty ->
+ None ->
+ None, Modtype_abstract
+ | Some smty ->
let tmty = transl_modtype env smty in
- Tmodtype_manifest tmty, Modtype_manifest tmty.mty_type
+ Some tmty, Modtype_manifest tmty.mty_type
and transl_recmodule_modtypes loc env sdecls =
let make_env curr =
@@ -611,9 +651,9 @@ and transl_recmodule_modtypes loc env sdecls =
env curr in
let transition env_c curr =
List.map2
- (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty))
+ (fun pmd (id, id_loc, mty) -> (id, id_loc, transl_modtype env_c pmd.pmd_type))
sdecls curr in
- let ids = List.map (fun (name, _) -> Ident.create name.txt) sdecls in
+ let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in
let approx_env =
(*
cf #5965
@@ -630,8 +670,8 @@ and transl_recmodule_modtypes loc env sdecls =
in
let init =
List.map2
- (fun id (name, smty) ->
- (id, name, approx_modtype approx_env smty))
+ (fun id pmd ->
+ (id, pmd.pmd_name, approx_modtype approx_env pmd.pmd_type))
ids sdecls
in
let env0 = make_env init in
@@ -647,6 +687,12 @@ and transl_recmodule_modtypes loc env sdecls =
*)
let env2 = make_env2 dcl2 in
check_recmod_typedecls env2 sdecls dcl2;
+ let dcl2 =
+ List.map2
+ (fun pmd (id, id_loc, mty) ->
+ {md_id=id; md_name=id_loc; md_type=mty; md_attributes=pmd.pmd_attributes})
+ sdecls dcl2
+ in
(dcl2, env2)
(* Try to convert a module expression to a module path. *)
@@ -676,11 +722,11 @@ let check_nongen_scheme env str =
match str.str_desc with
Tstr_value(rec_flag, pat_exp_list) ->
List.iter
- (fun (pat, exp) ->
+ (fun {vb_expr=exp} ->
if not (Ctype.closed_schema exp.exp_type) then
raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type)))
pat_exp_list
- | Tstr_module(id, _, md) ->
+ | Tstr_module {mb_expr=md;_} ->
if not (closed_modtype md.mod_type) then
raise(Error(md.mod_loc, env, Non_generalizable_module md.mod_type))
| _ -> ()
@@ -714,7 +760,8 @@ let enrich_type_decls anchor decls oldenv newenv =
None -> newenv
| Some p ->
List.fold_left
- (fun e (id, _, info) ->
+ (fun e info ->
+ let id = info.typ_id in
let info' =
Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos))
info.typ_type
@@ -757,7 +804,7 @@ let check_recmodule_inclusion env bindings =
(* Generate fresh names Y_i for the rec. bound module idents X_i *)
let bindings1 =
List.map
- (fun (id, _, mty_decl, modl, mty_actual) ->
+ (fun (id, _, mty_decl, modl, mty_actual, _attrs) ->
(id, Ident.rename id, mty_actual))
bindings in
(* Enter the Y_i in the environment with their actual types substituted
@@ -782,7 +829,7 @@ let check_recmodule_inclusion env bindings =
end else begin
(* Base case: check inclusion of s(mty_actual) in s(mty_decl)
and insert coercion if needed *)
- let check_inclusion (id, id_loc, mty_decl, modl, mty_actual) =
+ let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs) =
let mty_decl' = Subst.modtype s mty_decl.mty_type
and mty_actual' = subst_and_strengthen env s id mty_actual in
let coercion =
@@ -793,10 +840,18 @@ let check_recmodule_inclusion env bindings =
let modl' =
{ mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
Tmodtype_explicit mty_decl, coercion);
- mod_type = mty_decl.mty_type;
- mod_env = env;
- mod_loc = modl.mod_loc } in
- (id, id_loc, mty_decl, modl') in
+ mod_type = mty_decl.mty_type;
+ mod_env = env;
+ mod_loc = modl.mod_loc;
+ mod_attributes = [];
+ } in
+ {
+ mb_id = id;
+ mb_name = id_loc;
+ mb_expr = modl';
+ mb_attributes = attrs;
+ }
+ in
List.map check_inclusion bindings
end
in check_incl true (List.length bindings) env Subst.identity
@@ -848,6 +903,7 @@ let wrap_constraint env arg mty explicit =
{ mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
mod_type = mty;
mod_env = env;
+ mod_attributes = [];
mod_loc = arg.mod_loc }
(* Type a module value expression *)
@@ -859,6 +915,7 @@ let rec type_module sttn funct_body anchor env smod =
rm { mod_desc = Tmod_ident (path, lid);
mod_type = if sttn then Mtype.strengthen env mty path else mty;
mod_env = env;
+ mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Pmod_structure sstr ->
let (str, sg, finalenv) =
@@ -866,6 +923,7 @@ let rec type_module sttn funct_body anchor env smod =
rm { mod_desc = Tmod_structure str;
mod_type = Mty_signature sg;
mod_env = env;
+ mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Pmod_functor(name, smty, sbody) ->
let mty = transl_modtype env smty in
@@ -874,6 +932,7 @@ let rec type_module sttn funct_body anchor env smod =
rm { mod_desc = Tmod_functor(id, name, mty, body);
mod_type = Mty_functor(id, mty.mty_type, body.mod_type);
mod_env = env;
+ mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Pmod_apply(sfunct, sarg) ->
let arg = type_module true funct_body None env sarg in
@@ -903,6 +962,7 @@ let rec type_module sttn funct_body anchor env smod =
rm { mod_desc = Tmod_apply(funct, arg, coercion);
mod_type = mty_appl;
mod_env = env;
+ mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| _ ->
raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
@@ -911,7 +971,9 @@ let rec type_module sttn funct_body anchor env smod =
let arg = type_module true funct_body anchor env sarg in
let mty = transl_modtype env smty in
rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with
- mod_loc = smod.pmod_loc}
+ mod_loc = smod.pmod_loc;
+ mod_attributes = smod.pmod_attributes;
+ }
| Pmod_unpack sexp ->
if funct_body then
@@ -943,7 +1005,10 @@ let rec type_module sttn funct_body anchor env smod =
rm { mod_desc = Tmod_unpack(exp, mty);
mod_type = mty;
mod_env = env;
+ mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
+ | Pmod_extension (s, _arg) ->
+ raise (Error (s.loc, env, Extension s.txt))
and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let type_names = ref StringSet.empty
@@ -963,9 +1028,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
str
in
match pstr.pstr_desc with
- | Pstr_eval sexpr ->
+ | Pstr_eval (sexpr, attrs) ->
let expr = Typecore.type_expression env sexpr in
- let item = mk (Tstr_eval expr) in
+ let item = mk (Tstr_eval (expr, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct env srem in
(item :: str_rem, sig_rem, final_env)
| Pstr_value(rec_flag, sdefs) ->
@@ -978,7 +1043,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
| [] -> loc.Location.loc_end
| {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
in Some (Annot.Idef {scope with Location.loc_start = start})
- | Default -> None
in
let (defs, newenv) =
Typecore.type_binding env rec_flag sdefs scope in
@@ -992,16 +1056,14 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem,
map_end make_sig_value bound_idents sig_rem,
final_env)
- | Pstr_primitive(name, sdesc) ->
- let desc = Typedecl.transl_value_decl env loc sdesc in
- let (id, newenv) = Env.enter_value name.txt desc.val_val env
- ~check:(fun s -> Warnings.Unused_value_declaration s) in
- let item = mk (Tstr_primitive(id, name, desc)) in
+ | Pstr_primitive sdesc ->
+ let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
+ let item = mk (Tstr_primitive desc) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (item :: str_rem, Sig_value(id, desc.val_val) :: sig_rem, final_env)
+ (item :: str_rem, Sig_value(desc.val_id, desc.val_val) :: sig_rem, final_env)
| Pstr_type sdecls ->
List.iter
- (fun (name, decl) -> check "type" loc type_names name.txt)
+ (fun decl -> check "type" loc type_names decl.ptype_name.txt)
sdecls;
let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
let item = mk (Tstr_type decls) in
@@ -1009,76 +1071,93 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
enrich_type_decls anchor decls env newenv in
let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
(item :: str_rem,
- map_rec'' (fun rs (id, _, info) -> Sig_type(id, info.typ_type, rs))
+ map_rec'' (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs))
decls sig_rem,
final_env)
- | Pstr_exception(name, sarg) ->
- let arg = Typedecl.transl_exception env loc sarg in
- let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in
- let item = mk (Tstr_exception(id, name, arg)) in
+ | Pstr_exception sarg ->
+ let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
+ let item = mk (Tstr_exception arg) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem,
- Sig_exception(id, arg.exn_exn) :: sig_rem,
+ Sig_exception(arg.cd_id, decl) :: sig_rem,
final_env)
- | Pstr_exn_rebind(name, longid) ->
+ | Pstr_exn_rebind(name, longid, attrs) ->
let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in
let (id, newenv) = Env.enter_exception name.txt arg env in
- let item = mk (Tstr_exn_rebind(id, name, path, longid)) in
+ let item = mk (Tstr_exn_rebind(id, name, path, longid, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem,
Sig_exception(id, arg) :: sig_rem,
final_env)
- | Pstr_module(name, smodl) ->
+ | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs} ->
check "module" loc module_names name.txt;
let modl =
type_module true funct_body (anchor_submodule name.txt anchor) env
smodl in
let mty = enrich_module_type anchor name.txt modl.mod_type env in
let (id, newenv) = Env.enter_module name.txt mty env in
- let item = mk (Tstr_module(id, name, modl)) in
+ let item = mk
+ (Tstr_module
+ {
+ mb_id=id;
+ mb_name=name;
+ mb_expr=modl;
+ mb_attributes=attrs;
+ }
+ )
+ in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem,
Sig_module(id, modl.mod_type, Trec_not) :: sig_rem,
final_env)
| Pstr_recmodule sbind ->
+ let sbind =
+ List.map
+ (function
+ | {pmb_name = name; pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; pmb_attributes = attrs} ->
+ name, typ, expr, attrs
+ | mb ->
+ raise (Error (mb.pmb_expr.pmod_loc, env, Recursive_module_require_explicit_type))
+ )
+ sbind
+ in
List.iter
- (fun (name, _, _) -> check "module" loc module_names name.txt)
+ (fun (name, _, _, _) -> check "module" loc module_names name.txt)
sbind;
let (decls, newenv) =
transl_recmodule_modtypes loc env
- (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in
+ (List.map (fun (name, smty, smodl, attrs) -> {pmd_name=name; pmd_type=smty; pmd_attributes=attrs}) sbind) in
let bindings1 =
List.map2
- (fun (id, _, mty) (name, _, smodl) ->
+ (fun {md_id=id; md_type=mty} (name, _, smodl, attrs) ->
let modl =
type_module true funct_body (anchor_recmodule id anchor) newenv
smodl in
let mty' =
enrich_module_type anchor (Ident.name id) modl.mod_type newenv
in
- (id, name, mty, modl, mty'))
+ (id, name, mty, modl, mty', attrs))
decls sbind in
let bindings2 =
check_recmodule_inclusion newenv bindings1 in
let item = mk (Tstr_recmodule bindings2) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem,
- map_rec (fun rs (id, _, _, modl) -> Sig_module(id, modl.mod_type, rs))
+ map_rec (fun rs mb -> Sig_module(mb.mb_id, mb.mb_expr.mod_type, rs))
bindings2 sig_rem,
final_env)
- | Pstr_modtype(name, smty) ->
- check "module type" loc modtype_names name.txt;
- let mty = transl_modtype env smty in
- let (id, newenv) =
- Env.enter_modtype name.txt (Modtype_manifest mty.mty_type) env in
- let item = mk (Tstr_modtype(id, name, mty)) in
+ | Pstr_modtype pmtd ->
+ (* check that it is non-abstract *)
+ let newenv, mtd, sg =
+ transl_modtype_decl modtype_names env loc pmtd
+ in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (item :: str_rem,
- Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem,
- final_env)
- | Pstr_open (ovf, lid) ->
+ mk (Tstr_modtype mtd) :: str_rem,
+ sg :: sig_rem,
+ final_env
+ | Pstr_open (ovf, lid, attrs) ->
let (path, newenv) = type_open ovf ~toplevel env loc lid in
- let item = mk (Tstr_open (ovf, path, lid)) in
+ let item = mk (Tstr_open (ovf, path, lid, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem, sig_rem, final_env)
| Pstr_class cl ->
@@ -1138,7 +1217,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
Sig_type(i'', d'', rs)])
classes [sig_rem]),
final_env)
- | Pstr_include smodl ->
+ | Pstr_include (smodl, attrs) ->
let modl = type_module true funct_body None env smodl in
(* Rename all identifiers bound by this signature to avoid clashes *)
let sg = Subst.signature Subst.identity
@@ -1146,11 +1225,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
List.iter
(check_sig_item type_names module_names modtype_names loc) sg;
let new_env = Env.add_signature sg env in
- let item = mk (Tstr_include (modl, bound_value_identifiers sg)) in
+ let item = mk (Tstr_include (modl, bound_value_identifiers sg, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct new_env srem in
(item :: str_rem,
sg @ sig_rem,
final_env)
+ | Pstr_extension ((s, _), _) ->
+ raise (Error (s.loc, env, Extension s.txt))
+ | Pstr_attribute x ->
+ let (str_rem, sig_rem, final_env) = type_struct env srem in
+ mk (Tstr_attribute x) :: str_rem, sig_rem, final_env
in
if !Clflags.annotations then
(* moved to genannot *)
@@ -1222,6 +1306,7 @@ let type_module_type_of env smod =
rm { mod_desc = Tmod_ident (path, lid);
mod_type = mty;
mod_env = env;
+ mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| _ -> type_module env smod in
let mty = tmty.mod_type in
@@ -1487,6 +1572,10 @@ let report_error ppf = function
"The type %a in this module cannot be exported.@ " longident lid;
fprintf ppf
"Its type contains local dependencies:@ %a" type_expr ty
+ | Extension s ->
+ fprintf ppf "Uninterpreted extension '%s'." s
+ | Recursive_module_require_explicit_type ->
+ fprintf ppf "Recursive modules require an explicit module type."
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
diff --git a/typing/typemod.mli b/typing/typemod.mli
index d34bde86ac..6e7433792c 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -60,6 +60,8 @@ type error =
| Not_a_packed_module of type_expr
| Incomplete_packed_module of type_expr
| Scoping_pack of Longident.t * type_expr
+ | Extension of string
+ | Recursive_module_require_explicit_type
exception Error of Location.t * Env.t * error
diff --git a/typing/types.ml b/typing/types.ml
index 4263116454..f5d9527641 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -202,7 +202,7 @@ module Concr = Set.Make(OrderedString)
type class_type =
Cty_constr of Path.t * type_expr list * class_type
| Cty_signature of class_signature
- | Cty_fun of label * type_expr * class_type
+ | Cty_arrow of label * type_expr * class_type
and class_signature =
{ cty_self: type_expr;
diff --git a/typing/types.mli b/typing/types.mli
index 2020e25827..94559e2e1e 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -190,7 +190,7 @@ module Concr : Set.S with type elt = string
type class_type =
Cty_constr of Path.t * type_expr list * class_type
| Cty_signature of class_signature
- | Cty_fun of label * type_expr * class_type
+ | Cty_arrow of label * type_expr * class_type
and class_signature =
{ cty_self: type_expr;
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index f9c0ecd7bc..7d6a9f864d 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -21,7 +21,7 @@ open Typedtree
open Types
open Ctype
-exception Already_bound
+exception Already_bound of Location.t
type error =
Unbound_type_variable of string
@@ -51,6 +51,7 @@ type error =
| Unbound_cltype of Longident.t
| Ill_typed_functor_application of Longident.t
| Illegal_reference_to_recursive_module
+ | Extension of string
exception Error of Location.t * Env.t * error
@@ -140,17 +141,17 @@ let create_package_mty fake loc env (p, l) =
l,
List.fold_left
(fun mty (s, t) ->
- let d = {ptype_params = [];
+ let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
+ ptype_params = [];
ptype_cstrs = [];
ptype_kind = Ptype_abstract;
ptype_private = Asttypes.Public;
ptype_manifest = if fake then None else Some t;
- ptype_variance = [];
+ ptype_attributes = [];
ptype_loc = loc} in
- {pmty_desc=Pmty_with (mty, [ { txt = s.txt; loc }, Pwith_type d ]);
- pmty_loc=loc}
+ Ast_helper.Mty.mk ~loc (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
)
- {pmty_desc=Pmty_ident p; pmty_loc=loc}
+ (Ast_helper.Mty.mk ~loc (Pmty_ident p))
l
(* Translation of type expressions *)
@@ -183,12 +184,12 @@ let new_global_var ?name () =
let newvar ?name () =
newvar ?name:(validate_name name) ()
-let enter_type_variable strict loc name =
+let enter_type_variable {Location.txt=name; loc} =
try
if name <> "" && name.[0] = '_' then
raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
let v = Tbl.find name !type_variables in
- if strict then raise Already_bound;
+ raise (Already_bound loc);
v
with Not_found ->
let v = new_global_var ~name () in
@@ -215,11 +216,11 @@ let rec swap_list = function
type policy = Fixed | Extensible | Univars
-let ctyp ctyp_desc ctyp_type ctyp_env ctyp_loc =
- { ctyp_desc; ctyp_type; ctyp_env; ctyp_loc }
-
let rec transl_type env policy styp =
let loc = styp.ptyp_loc in
+ let ctyp ctyp_desc ctyp_type =
+ { ctyp_desc; ctyp_type; ctyp_env = env; ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
+ in
match styp.ptyp_desc with
Ptyp_any ->
let ty =
@@ -228,7 +229,7 @@ let rec transl_type env policy styp =
raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
else newvar ()
in
- ctyp Ttyp_any ty env loc
+ ctyp Ttyp_any ty
| Ptyp_var name ->
let ty =
if name <> "" && name.[0] = '_' then
@@ -245,16 +246,16 @@ let rec transl_type env policy styp =
v
end
in
- ctyp (Ttyp_var name) ty env loc
+ ctyp (Ttyp_var name) ty
| Ptyp_arrow(l, st1, st2) ->
let cty1 = transl_type env policy st1 in
let cty2 = transl_type env policy st2 in
let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in
- ctyp (Ttyp_arrow (l, cty1, cty2)) ty env loc
+ ctyp (Ttyp_arrow (l, cty1, cty2)) ty
| Ptyp_tuple stl ->
let ctys = List.map (transl_type env policy) stl in
let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
- ctyp (Ttyp_tuple ctys) ty env loc
+ ctyp (Ttyp_tuple ctys) ty
| Ptyp_constr(lid, stl) ->
let (path, decl) = find_type env styp.ptyp_loc lid.txt in
if List.length stl <> decl.type_arity then
@@ -281,22 +282,15 @@ let rec transl_type env policy styp =
with Unify trace ->
raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
end;
- ctyp (Ttyp_constr (path, lid, args)) constr env loc
- | Ptyp_object fields ->
- let fields = List.map
- (fun pf ->
- let desc =
- match pf.pfield_desc with
- | Pfield_var -> Tcfield_var
- | Pfield (s,e) ->
- let ty1 = transl_type env policy e in
- Tcfield (s, ty1)
- in
- { field_desc = desc; field_loc = pf.pfield_loc })
- fields in
- let ty = newobj (transl_fields env policy [] fields) in
- ctyp (Ttyp_object fields) ty env loc
- | Ptyp_class(lid, stl, present) ->
+ ctyp (Ttyp_constr (path, lid, args)) constr
+ | Ptyp_object (fields, o) ->
+ let fields =
+ List.map (fun (s, t) -> (s, transl_poly_type env policy t))
+ fields
+ in
+ let ty = newobj (transl_fields loc env policy [] o fields) in
+ ctyp (Ttyp_object (fields, o)) ty
+ | Ptyp_class(lid, stl) ->
let (path, decl, is_variant) =
try
let (path, decl) = Env.lookup_type lid.txt env in
@@ -314,7 +308,6 @@ let rec transl_type env policy styp =
(Warnings.Deprecated "old syntax for polymorphic variant type");
(path, decl,true)
with Not_found -> try
- if present <> [] then raise Not_found;
let lid2 =
match lid.txt with
Longident.Lident s -> Longident.Lident ("#" ^ s)
@@ -346,14 +339,9 @@ let rec transl_type env policy styp =
let ty = match ty.desc with
Tvariant row ->
let row = Btype.row_repr row in
- List.iter
- (fun l -> if not (List.mem_assoc l row.row_fields) then
- raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
- present;
let fields =
List.map
(fun (l,f) -> l,
- if List.mem l present then f else
match Btype.row_field_repr f with
| Rpresent (Some ty) ->
Reither(false, [ty], false, ref None)
@@ -379,7 +367,7 @@ let rec transl_type env policy styp =
| _ ->
assert false
in
- ctyp (Ttyp_class (path, lid, args, present)) ty env loc
+ ctyp (Ttyp_class (path, lid, args)) ty
| Ptyp_alias(st, alias) ->
let cty =
try
@@ -416,7 +404,7 @@ let rec transl_type env policy styp =
end;
{ ty with ctyp_type = t }
in
- ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type env loc
+ ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
| Ptyp_variant(fields, closed, present) ->
let name = ref None in
let mkfield l f =
@@ -509,7 +497,7 @@ let rec transl_type env policy styp =
end;
let row =
{ row_fields = List.rev fields; row_more = newvar ();
- row_bound = (); row_closed = closed;
+ row_bound = (); row_closed = (closed = Closed);
row_fixed = false; row_name = !name } in
let static = Btype.static_row row in
let row =
@@ -518,7 +506,7 @@ let rec transl_type env policy styp =
else { row with row_more = new_pre_univar () }
in
let ty = newty (Tvariant row) in
- ctyp (Ttyp_variant (tfields, closed, present)) ty env loc
+ ctyp (Ttyp_variant (tfields, closed, present)) ty
| Ptyp_poly(vars, st) ->
begin_def();
let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
@@ -545,7 +533,7 @@ let rec transl_type env policy styp =
in
let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
unify_var env (newvar()) ty';
- ctyp (Ttyp_poly (vars, cty)) ty' env loc
+ ctyp (Ttyp_poly (vars, cty)) ty'
| Ptyp_package (p, l) ->
let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
let z = narrow () in
@@ -559,23 +547,30 @@ let rec transl_type env policy styp =
List.map (fun (s, pty) -> s.txt) l,
List.map (fun (_,cty) -> cty.ctyp_type) ptys))
in
- ctyp (Ttyp_package {
- pack_name = path;
- pack_type = mty.mty_type;
- pack_fields = ptys;
- pack_txt = p;
- }) ty env loc
-
-and transl_fields env policy seen =
+ ctyp (Ttyp_package {
+ pack_name = path;
+ pack_type = mty.mty_type;
+ pack_fields = ptys;
+ pack_txt = p;
+ }) ty
+ | Ptyp_extension (s, _arg) ->
+ raise (Error (s.loc, env, Extension s.txt))
+
+and transl_poly_type env policy t =
+ transl_type env policy (Ast_helper.Typ.force_poly t)
+
+and transl_fields loc env policy seen o =
function
[] ->
- newty Tnil
- | {field_desc = Tcfield_var}::_ ->
- if policy = Univars then new_pre_univar () else newvar ()
- | {field_desc = Tcfield(s, ty1); field_loc = loc}::l ->
+ begin match o, policy with
+ | Closed, _ -> newty Tnil
+ | Open, Univars -> new_pre_univar ()
+ | Open, _ -> newvar ()
+ end
+ | (s, ty1) :: l ->
if List.mem s seen then raise (Error (loc, env, Repeated_method_label s));
- let ty2 = transl_fields env policy (s::seen) l in
- newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2))
+ let ty2 = transl_fields loc env policy (s :: seen) o l in
+ newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2))
(* Make the rows "fixed" in this type, to make universal check easier *)
let rec make_fixed_univars ty =
@@ -827,3 +822,5 @@ let report_error env ppf = function
fprintf ppf "Ill-typed functor application %a" longident lid
| Illegal_reference_to_recursive_module ->
fprintf ppf "Illegal recursive module reference"
+ | Extension s ->
+ fprintf ppf "Uninterpreted extension '%s'." s
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index 66ffb7b8c4..eb78d1ae1b 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -25,14 +25,14 @@ val transl_simple_type_delayed:
val transl_type_scheme:
Env.t -> Parsetree.core_type -> Typedtree.core_type
val reset_type_variables: unit -> unit
-val enter_type_variable: bool -> Location.t -> string -> type_expr
+val enter_type_variable: string Location.loc -> type_expr
val type_variable: Location.t -> string -> type_expr
type variable_context
val narrow: unit -> variable_context
val widen: variable_context -> unit
-exception Already_bound
+exception Already_bound of Location.t
type error =
Unbound_type_variable of string
@@ -62,6 +62,7 @@ type error =
| Unbound_cltype of Longident.t
| Ill_typed_functor_application of Longident.t
| Illegal_reference_to_recursive_module
+ | Extension of string
exception Error of Location.t * Env.t * error
View Lorry Controller Status