diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/printtyped.ml | 32 | ||||
| -rw-r--r-- | typing/typecore.ml | 14 | ||||
| -rw-r--r-- | typing/typedtree.ml | 4 | ||||
| -rw-r--r-- | typing/typedtree.mli | 4 |
4 files changed, 26 insertions, 28 deletions
diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 28969ff14..55a0e2eca 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -230,19 +230,26 @@ and pattern i ppf x = line i ppf "Ppat_lazy\n"; pattern i ppf p; -and expression i ppf x = - line i ppf "expression %a\n" fmt_location x.exp_loc; - let i = i+1 in - match x.exp_extra with - | (Texp_constraint (cto1, cto2), _) :: rem -> +and expression_extra i ppf x = + match x with + | Texp_constraint (cto1, cto2) -> line i ppf "Pexp_constraint\n"; option i core_type ppf cto1; option i core_type ppf cto2; - expression i ppf { x with exp_extra = rem } - | (Texp_open (m, _,_), _) :: rem -> + | Texp_open (m, _, _) -> line i ppf "Pexp_open \"%a\"\n" fmt_path m; - expression i ppf { x with exp_extra = rem } - | [] -> + | Texp_poly cto -> + line i ppf "Pexp_poly\n"; + option i core_type ppf cto; + | Texp_newtype s -> + line i ppf "Pexp_newtype \"%s\"\n" s; + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.exp_loc; + let i = + List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1) + (i+1) x.exp_extra + in match x.exp_desc with | Texp_ident (li,_,_) -> line i ppf "Pexp_ident %a\n" fmt_path li; | Texp_instvar (_, li,_) -> line i ppf "Pexp_instvar %a\n" fmt_path li; @@ -342,16 +349,9 @@ and expression i ppf x = | Texp_lazy (e) -> line i ppf "Pexp_lazy"; expression i ppf e; - | Texp_poly (e, cto) -> - line i ppf "Pexp_poly\n"; - expression i ppf e; - option i core_type ppf cto; | Texp_object (s, _) -> line i ppf "Pexp_object"; class_structure i ppf s - | Texp_newtype (s, e) -> - line i ppf "Pexp_newtype \"%s\"\n" s; - expression i ppf e | Texp_pack me -> line i ppf "Pexp_pack"; module_expr i ppf me diff --git a/typing/typecore.ml b/typing/typecore.ml index 8cbfae52f..a13eb5498 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -994,9 +994,6 @@ let rec is_nonexpansive exp = match exp.exp_desc with Texp_ident(_,_,_) -> true | Texp_constant _ -> true - | Texp_poly (e, _) - | Texp_newtype (_, e) - -> is_nonexpansive e | Texp_let(rec_flag, pat_exp_list, body) -> List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list && is_nonexpansive body @@ -2247,7 +2244,7 @@ and type_expect ?in_function env sexp ty_expected = match (expand_head env ty).desc with Tpoly (ty', []) -> let exp = type_expect env sbody ty' in - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tpoly (ty', tl) -> (* One more level to generalize locally *) begin_def (); @@ -2260,15 +2257,15 @@ and type_expect ?in_function env sexp ty_expected = let exp = type_expect env sbody ty'' in end_def (); check_univars env false "method" exp ty_expected vars; - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tvar _ -> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp env exp ty; - re exp + exp | _ -> assert false in - re { exp with exp_desc = Texp_poly(exp, cty) } + re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra } | Pexp_newtype(name, sbody) -> let ty = newvar () in (* remember original level *) @@ -2312,7 +2309,8 @@ 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 = sexp.pexp_loc; exp_type = ety } + rue { body with exp_loc = loc; exp_type = ety; + exp_extra = (Texp_newtype name, loc) :: body.exp_extra } | Pexp_pack m -> let (p, nl, tl) = match Ctype.expand_head env (instance env ty_expected) with diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 08ab35e4c..fda05b041 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -61,6 +61,8 @@ and expression = and exp_extra = | Texp_constraint of core_type option * core_type option | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description @@ -98,9 +100,7 @@ and expression_desc = | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_poly of expression * core_type option | Texp_object of class_structure * string list - | Texp_newtype of string * expression | Texp_pack of module_expr and meth = diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 436576d7a..81242993d 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -60,6 +60,8 @@ and expression = and exp_extra = | Texp_constraint of core_type option * core_type option | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description @@ -97,9 +99,7 @@ and expression_desc = | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_poly of expression * core_type option | Texp_object of class_structure * string list - | Texp_newtype of string * expression | Texp_pack of module_expr and meth = |