Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Index: typing/typecore.ml
- ===================================================================
- --- typing/typecore.ml (revision 13871)
- +++ typing/typecore.ml (working copy)
- @@ -363,13 +363,18 @@
- let pattern_force = ref ([] : (unit -> unit) list)
- let pattern_scope = ref (None : Annot.ident option);;
- let allow_modules = ref false
- +let allow_gadts = ref false
- +let allow_existentials = ref false
- let module_variables = ref ([] : (string loc * Location.t) list)
- -let reset_pattern scope allow =
- +let reset_pattern ?scope ?(modules=false) ?(gadts=true) ?(existentials=false)
- + () =
- pattern_variables := [];
- pattern_force := [];
- pattern_scope := scope;
- - allow_modules := allow;
- + allow_modules := modules;
- module_variables := [];
- + allow_gadts := gadts;
- + allow_existentials := existentials;
- ;;
- let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
- @@ -858,12 +863,14 @@
- | Normal
- | Inside_or
- +exception Contains_gadt
- +
- (* type_pat propagates the expected type as well as maps for
- constructors and labels.
- Unification may update the typing environment. *)
- -let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
- +let rec type_pat ~constrs ~labels ~mode ~env sp expected_ty =
- let type_pat ?(mode=mode) ?(env=env) =
- - type_pat ~constrs ~labels ~no_existentials ~mode ~env in
- + type_pat ~constrs ~labels ~mode ~env in
- let loc = sp.ppat_loc in
- match sp.ppat_desc with
- Ppat_any ->
- @@ -952,15 +959,16 @@
- [Hashtbl.find constrs s, (fun () -> ())]
- | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt
- in
- - let check_lk tpath constr =
- - if constr.cstr_generalized then
- + (* let check_lk tpath constr =
- + if constr.cstr_generalized then
- raise (Error (lid.loc, !env,
- Unqualified_gadt_pattern (tpath, constr.cstr_name)))
- - in
- + in *)
- let constr =
- - Constructor.disambiguate lid !env opath constrs ~check_lk in
- + Constructor.disambiguate lid !env opath constrs in
- + if constr.cstr_generalized && not !allow_gadts then raise Contains_gadt;
- Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
- - if no_existentials && constr.cstr_existentials <> [] then
- + if not !allow_existentials && constr.cstr_existentials <> [] then
- raise (Error (loc, !env, Unexpected_existential));
- (* if constructor is gadt, we must verify that the expected type has the
- correct head *)
- @@ -1119,13 +1127,10 @@
- unify_pat_types loc !env ty expected_ty;
- { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
- -let type_pat ?(allow_existentials=false) ?constrs ?labels
- - ?(lev=get_current_level()) env sp expected_ty =
- +let type_pat ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty =
- newtype_level := Some lev;
- try
- - let r =
- - type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
- - ~mode:Normal ~env sp expected_ty in
- + let r = type_pat ~constrs ~labels ~mode:Normal ~env sp expected_ty in
- iter_pattern (fun p -> p.pat_env <- !env) r;
- newtype_level := None;
- r
- @@ -1139,11 +1144,8 @@
- let partial_pred ~lev env expected_ty constrs labels p =
- let snap = snapshot () in
- try
- - reset_pattern None true;
- - let typed_p =
- - type_pat ~allow_existentials:true ~lev
- - ~constrs ~labels (ref env) p expected_ty
- - in
- + reset_pattern ~modules:true ~existentials:true ();
- + let typed_p = type_pat ~lev ~constrs ~labels (ref env) p expected_ty in
- backtrack snap;
- (* types are invalidated but we don't need them here *)
- Some typed_p
- @@ -1172,25 +1174,25 @@
- pv env,
- get_ref module_variables)
- -let type_pattern ~lev env spat scope expected_ty =
- - reset_pattern scope true;
- +let type_pattern ~lev ~gadts env spat scope expected_ty =
- + reset_pattern ?scope ~modules:true ~existentials:true ~gadts ();
- let new_env = ref env in
- - let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
- + let pat = type_pat ~lev new_env spat expected_ty in
- let new_env, unpacks =
- add_pattern_variables !new_env
- ~check:(fun s -> Warnings.Unused_var_strict s)
- ~check_as:(fun s -> Warnings.Unused_var s) in
- (pat, new_env, get_ref pattern_force, unpacks)
- -let type_pattern_list env spatl scope expected_tys allow =
- - reset_pattern scope allow;
- +let type_pattern_list env spatl scope expected_tys modules =
- + reset_pattern ?scope ~modules ();
- let new_env = ref env in
- let patl = List.map2 (type_pat new_env) spatl expected_tys in
- let new_env, unpacks = add_pattern_variables !new_env in
- (patl, new_env, get_ref pattern_force, unpacks)
- let type_class_arg_pattern cl_num val_env met_env l spat =
- - reset_pattern None false;
- + reset_pattern ();
- let nv = newvar () in
- let pat = type_pat (ref val_env) spat nv in
- if has_variants pat then begin
- @@ -1224,7 +1226,7 @@
- mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")),
- mknoloc ("selfpat-" ^ cl_num)))
- in
- - reset_pattern None false;
- + reset_pattern ();
- let nv = newvar() in
- let pat = type_pat (ref val_env) spat nv in
- List.iter (fun f -> f()) (get_ref pattern_force);
- @@ -1776,8 +1778,6 @@
- (* 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.fold_left
- (fun env s ->
- @@ -3129,34 +3129,10 @@
- let erase_either =
- List.exists contains_polymorphic_variant patterns
- && contains_variant_either ty_arg
- - and has_gadts = List.exists (contains_gadt env) patterns in
- -(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
- - let ty_arg =
- - if (has_gadts || erase_either) && not !Clflags.principal
- - then correct_levels ty_arg else ty_arg
- - and ty_res, env =
- - if has_gadts && not !Clflags.principal then
- - correct_levels ty_res, duplicate_ident_types loc caselist env
- - else ty_res, env
- in
- - let lev, env =
- - if has_gadts then begin
- - (* raise level for existentials *)
- - begin_def ();
- - Ident.set_current_time (get_current_level ());
- - let lev = Ident.current_time () in
- - Ctype.init_def (lev+1000); (* up to 1000 existentials *)
- - (lev, Env.add_gadt_instance_level lev env)
- - end else (get_current_level (), env)
- - in
- -(* if has_gadts then
- - Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
- - begin_def (); (* propagation of the argument *)
- - let ty_arg' = newvar () in
- let pattern_force = ref [] in
- -(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
- - Printtyp.raw_type_expr ty_arg; *)
- - let pat_env_list =
- + let mk_pat_env_list lev gadts env ty_arg caselist =
- + let ty_arg' = newvar () in
- List.map
- (fun (spat, sexp) ->
- let loc = sexp.pexp_loc in
- @@ -3167,7 +3143,7 @@
- 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 ~gadts env spat scope ty_arg
- in
- pattern_force := force @ !pattern_force;
- let pat =
- @@ -3180,6 +3156,44 @@
- unify_pat env pat ty_arg';
- (pat, (ext_env, unpacks)))
- caselist in
- + let ty_arg =
- + if erase_either && not !Clflags.principal
- + then correct_levels ty_arg else ty_arg
- + and lev = get_current_level () in
- + let pat_env_list, has_gadts =
- + begin_def (); (* propagation of the argument *)
- + let snap = snapshot () in
- + try mk_pat_env_list lev false env ty_arg caselist, false
- + with Contains_gadt ->
- + backtrack snap; pattern_force := [];
- + end_def (); if !Clflags.principal then end_def ();
- + ([], true)
- + in
- +(* let has_gadts = List.exists (contains_gadt env) patterns in *)
- +(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
- + let ty_arg, ty_res, lev, env, pat_env_list =
- + if not has_gadts then (ty_arg, ty_res, lev, env, pat_env_list) else
- + (* Prepare for typing GADTs *)
- + let ty_arg =
- + if not erase_either && not !Clflags.principal
- + then correct_levels ty_arg else ty_arg
- + and ty_res, env =
- + if not !Clflags.principal then
- + correct_levels ty_res, duplicate_ident_types loc caselist env
- + else ty_res, env
- + in
- + (* raise level for existentials *)
- + begin_def ();
- + Ident.set_current_time (get_current_level ());
- + let lev = Ident.current_time () in
- + Ctype.init_def (lev+1000); (* up to 1000 existentials *)
- + let env = Env.add_gadt_instance_level lev env in
- + begin_def (); (* propagation of the argument *)
- + (ty_arg, ty_res, lev, env,
- + mk_pat_env_list lev true env ty_arg caselist)
- + in
- +(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
- + Printtyp.raw_type_expr ty_arg; *)
- (* Check for polymorphic variants to close *)
- let patl = List.map fst pat_env_list in
- if List.exists has_variants patl then begin
- @@ -3193,7 +3207,7 @@
- List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
- patl;
- List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl;
- - end_def ();
- + end_def (); (* propagation of the argument *)
- List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
- (* type bodies *)
- let in_function = if List.length caselist = 1 then in_function else None in
- @@ -3208,7 +3222,7 @@
- end_def ();
- generalize_structure ty; ty
- end
- - else if contains_gadt env spat then correct_levels ty_res
- + else if has_gadts 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'; *)
- Index: utils/warnings.ml
- ===================================================================
- --- utils/warnings.ml (revision 13871)
- +++ utils/warnings.ml (working copy)
- @@ -348,10 +348,12 @@
- ;;
- let nerrors = ref 0;;
- +let recent = ref [];;
- let print ppf w =
- let msg = message w in
- let num = number w in
- + recent := w :: !recent;
- let newlines = ref 0 in
- for i = 0 to String.length msg - 1 do
- if msg.[i] = '\n' then incr newlines;
- @@ -371,6 +373,7 @@
- exception Errors of int;;
- let check_fatal () =
- + recent := [];
- if !nerrors > 0 then begin
- let e = Errors !nerrors in
- nerrors := 0;
- Index: utils/warnings.mli
- ===================================================================
- --- utils/warnings.mli (revision 13871)
- +++ utils/warnings.mli (working copy)
- @@ -75,5 +75,5 @@
- exception Errors of int;;
- val check_fatal : unit -> unit;;
- -
- -val help_warnings: unit -> unit
- +val recent : t list ref;;
- +val help_warnings : unit -> unit;;
- Index: parsing/location.ml
- ===================================================================
- --- parsing/location.ml (revision 13871)
- +++ parsing/location.ml (working copy)
- @@ -261,7 +261,7 @@
- let print_error_cur_file ppf = print_error ppf (in_file !input_name);;
- let print_warning loc ppf w =
- - if Warnings.is_active w then begin
- + if Warnings.is_active w && not (List.mem w !Warnings.recent) then begin
- let printw ppf w =
- let n = Warnings.print ppf w in
- num_loc_lines := !num_loc_lines + n
Add Comment
Please, Sign In to add comment