Guest User

Untitled

a guest
Feb 16th, 2019
115
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 11.30 KB | None | 0 0
  1. Index: typing/typecore.ml
  2. ===================================================================
  3. --- typing/typecore.ml (revision 13871)
  4. +++ typing/typecore.ml (working copy)
  5. @@ -363,13 +363,18 @@
  6. let pattern_force = ref ([] : (unit -> unit) list)
  7. let pattern_scope = ref (None : Annot.ident option);;
  8. let allow_modules = ref false
  9. +let allow_gadts = ref false
  10. +let allow_existentials = ref false
  11. let module_variables = ref ([] : (string loc * Location.t) list)
  12. -let reset_pattern scope allow =
  13. +let reset_pattern ?scope ?(modules=false) ?(gadts=true) ?(existentials=false)
  14. + () =
  15. pattern_variables := [];
  16. pattern_force := [];
  17. pattern_scope := scope;
  18. - allow_modules := allow;
  19. + allow_modules := modules;
  20. module_variables := [];
  21. + allow_gadts := gadts;
  22. + allow_existentials := existentials;
  23. ;;
  24.  
  25. let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
  26. @@ -858,12 +863,14 @@
  27. | Normal
  28. | Inside_or
  29.  
  30. +exception Contains_gadt
  31. +
  32. (* type_pat propagates the expected type as well as maps for
  33. constructors and labels.
  34. Unification may update the typing environment. *)
  35. -let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
  36. +let rec type_pat ~constrs ~labels ~mode ~env sp expected_ty =
  37. let type_pat ?(mode=mode) ?(env=env) =
  38. - type_pat ~constrs ~labels ~no_existentials ~mode ~env in
  39. + type_pat ~constrs ~labels ~mode ~env in
  40. let loc = sp.ppat_loc in
  41. match sp.ppat_desc with
  42. Ppat_any ->
  43. @@ -952,15 +959,16 @@
  44. [Hashtbl.find constrs s, (fun () -> ())]
  45. | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt
  46. in
  47. - let check_lk tpath constr =
  48. - if constr.cstr_generalized then
  49. + (* let check_lk tpath constr =
  50. + if constr.cstr_generalized then
  51. raise (Error (lid.loc, !env,
  52. Unqualified_gadt_pattern (tpath, constr.cstr_name)))
  53. - in
  54. + in *)
  55. let constr =
  56. - Constructor.disambiguate lid !env opath constrs ~check_lk in
  57. + Constructor.disambiguate lid !env opath constrs in
  58. + if constr.cstr_generalized && not !allow_gadts then raise Contains_gadt;
  59. Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
  60. - if no_existentials && constr.cstr_existentials <> [] then
  61. + if not !allow_existentials && constr.cstr_existentials <> [] then
  62. raise (Error (loc, !env, Unexpected_existential));
  63. (* if constructor is gadt, we must verify that the expected type has the
  64. correct head *)
  65. @@ -1119,13 +1127,10 @@
  66. unify_pat_types loc !env ty expected_ty;
  67. { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
  68.  
  69. -let type_pat ?(allow_existentials=false) ?constrs ?labels
  70. - ?(lev=get_current_level()) env sp expected_ty =
  71. +let type_pat ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty =
  72. newtype_level := Some lev;
  73. try
  74. - let r =
  75. - type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
  76. - ~mode:Normal ~env sp expected_ty in
  77. + let r = type_pat ~constrs ~labels ~mode:Normal ~env sp expected_ty in
  78. iter_pattern (fun p -> p.pat_env <- !env) r;
  79. newtype_level := None;
  80. r
  81. @@ -1139,11 +1144,8 @@
  82. let partial_pred ~lev env expected_ty constrs labels p =
  83. let snap = snapshot () in
  84. try
  85. - reset_pattern None true;
  86. - let typed_p =
  87. - type_pat ~allow_existentials:true ~lev
  88. - ~constrs ~labels (ref env) p expected_ty
  89. - in
  90. + reset_pattern ~modules:true ~existentials:true ();
  91. + let typed_p = type_pat ~lev ~constrs ~labels (ref env) p expected_ty in
  92. backtrack snap;
  93. (* types are invalidated but we don't need them here *)
  94. Some typed_p
  95. @@ -1172,25 +1174,25 @@
  96. pv env,
  97. get_ref module_variables)
  98.  
  99. -let type_pattern ~lev env spat scope expected_ty =
  100. - reset_pattern scope true;
  101. +let type_pattern ~lev ~gadts env spat scope expected_ty =
  102. + reset_pattern ?scope ~modules:true ~existentials:true ~gadts ();
  103. let new_env = ref env in
  104. - let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
  105. + let pat = type_pat ~lev new_env spat expected_ty in
  106. let new_env, unpacks =
  107. add_pattern_variables !new_env
  108. ~check:(fun s -> Warnings.Unused_var_strict s)
  109. ~check_as:(fun s -> Warnings.Unused_var s) in
  110. (pat, new_env, get_ref pattern_force, unpacks)
  111.  
  112. -let type_pattern_list env spatl scope expected_tys allow =
  113. - reset_pattern scope allow;
  114. +let type_pattern_list env spatl scope expected_tys modules =
  115. + reset_pattern ?scope ~modules ();
  116. let new_env = ref env in
  117. let patl = List.map2 (type_pat new_env) spatl expected_tys in
  118. let new_env, unpacks = add_pattern_variables !new_env in
  119. (patl, new_env, get_ref pattern_force, unpacks)
  120.  
  121. let type_class_arg_pattern cl_num val_env met_env l spat =
  122. - reset_pattern None false;
  123. + reset_pattern ();
  124. let nv = newvar () in
  125. let pat = type_pat (ref val_env) spat nv in
  126. if has_variants pat then begin
  127. @@ -1224,7 +1226,7 @@
  128. mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")),
  129. mknoloc ("selfpat-" ^ cl_num)))
  130. in
  131. - reset_pattern None false;
  132. + reset_pattern ();
  133. let nv = newvar() in
  134. let pat = type_pat (ref val_env) spat nv in
  135. List.iter (fun f -> f()) (get_ref pattern_force);
  136. @@ -1776,8 +1778,6 @@
  137. (* XXX Should we do something about global type variables too? *)
  138.  
  139. let duplicate_ident_types loc caselist env =
  140. - let caselist =
  141. - List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
  142. let idents = all_idents (List.map snd caselist) in
  143. List.fold_left
  144. (fun env s ->
  145. @@ -3129,34 +3129,10 @@
  146. let erase_either =
  147. List.exists contains_polymorphic_variant patterns
  148. && contains_variant_either ty_arg
  149. - and has_gadts = List.exists (contains_gadt env) patterns in
  150. -(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
  151. - let ty_arg =
  152. - if (has_gadts || erase_either) && not !Clflags.principal
  153. - then correct_levels ty_arg else ty_arg
  154. - and ty_res, env =
  155. - if has_gadts && not !Clflags.principal then
  156. - correct_levels ty_res, duplicate_ident_types loc caselist env
  157. - else ty_res, env
  158. in
  159. - let lev, env =
  160. - if has_gadts then begin
  161. - (* raise level for existentials *)
  162. - begin_def ();
  163. - Ident.set_current_time (get_current_level ());
  164. - let lev = Ident.current_time () in
  165. - Ctype.init_def (lev+1000); (* up to 1000 existentials *)
  166. - (lev, Env.add_gadt_instance_level lev env)
  167. - end else (get_current_level (), env)
  168. - in
  169. -(* if has_gadts then
  170. - Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
  171. - begin_def (); (* propagation of the argument *)
  172. - let ty_arg' = newvar () in
  173. let pattern_force = ref [] in
  174. -(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
  175. - Printtyp.raw_type_expr ty_arg; *)
  176. - let pat_env_list =
  177. + let mk_pat_env_list lev gadts env ty_arg caselist =
  178. + let ty_arg' = newvar () in
  179. List.map
  180. (fun (spat, sexp) ->
  181. let loc = sexp.pexp_loc in
  182. @@ -3167,7 +3143,7 @@
  183. if !Clflags.principal || erase_either
  184. then Some false else None in
  185. let ty_arg = instance ?partial env ty_arg in
  186. - type_pattern ~lev env spat scope ty_arg
  187. + type_pattern ~lev ~gadts env spat scope ty_arg
  188. in
  189. pattern_force := force @ !pattern_force;
  190. let pat =
  191. @@ -3180,6 +3156,44 @@
  192. unify_pat env pat ty_arg';
  193. (pat, (ext_env, unpacks)))
  194. caselist in
  195. + let ty_arg =
  196. + if erase_either && not !Clflags.principal
  197. + then correct_levels ty_arg else ty_arg
  198. + and lev = get_current_level () in
  199. + let pat_env_list, has_gadts =
  200. + begin_def (); (* propagation of the argument *)
  201. + let snap = snapshot () in
  202. + try mk_pat_env_list lev false env ty_arg caselist, false
  203. + with Contains_gadt ->
  204. + backtrack snap; pattern_force := [];
  205. + end_def (); if !Clflags.principal then end_def ();
  206. + ([], true)
  207. + in
  208. +(* let has_gadts = List.exists (contains_gadt env) patterns in *)
  209. +(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
  210. + let ty_arg, ty_res, lev, env, pat_env_list =
  211. + if not has_gadts then (ty_arg, ty_res, lev, env, pat_env_list) else
  212. + (* Prepare for typing GADTs *)
  213. + let ty_arg =
  214. + if not erase_either && not !Clflags.principal
  215. + then correct_levels ty_arg else ty_arg
  216. + and ty_res, env =
  217. + if not !Clflags.principal then
  218. + correct_levels ty_res, duplicate_ident_types loc caselist env
  219. + else ty_res, env
  220. + in
  221. + (* raise level for existentials *)
  222. + begin_def ();
  223. + Ident.set_current_time (get_current_level ());
  224. + let lev = Ident.current_time () in
  225. + Ctype.init_def (lev+1000); (* up to 1000 existentials *)
  226. + let env = Env.add_gadt_instance_level lev env in
  227. + begin_def (); (* propagation of the argument *)
  228. + (ty_arg, ty_res, lev, env,
  229. + mk_pat_env_list lev true env ty_arg caselist)
  230. + in
  231. +(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
  232. + Printtyp.raw_type_expr ty_arg; *)
  233. (* Check for polymorphic variants to close *)
  234. let patl = List.map fst pat_env_list in
  235. if List.exists has_variants patl then begin
  236. @@ -3193,7 +3207,7 @@
  237. List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
  238. patl;
  239. List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl;
  240. - end_def ();
  241. + end_def (); (* propagation of the argument *)
  242. List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
  243. (* type bodies *)
  244. let in_function = if List.length caselist = 1 then in_function else None in
  245. @@ -3208,7 +3222,7 @@
  246. end_def ();
  247. generalize_structure ty; ty
  248. end
  249. - else if contains_gadt env spat then correct_levels ty_res
  250. + else if has_gadts then correct_levels ty_res
  251. else ty_res in
  252. (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
  253. Printtyp.raw_type_expr ty_res'; *)
  254. Index: utils/warnings.ml
  255. ===================================================================
  256. --- utils/warnings.ml (revision 13871)
  257. +++ utils/warnings.ml (working copy)
  258. @@ -348,10 +348,12 @@
  259. ;;
  260.  
  261. let nerrors = ref 0;;
  262. +let recent = ref [];;
  263.  
  264. let print ppf w =
  265. let msg = message w in
  266. let num = number w in
  267. + recent := w :: !recent;
  268. let newlines = ref 0 in
  269. for i = 0 to String.length msg - 1 do
  270. if msg.[i] = '\n' then incr newlines;
  271. @@ -371,6 +373,7 @@
  272. exception Errors of int;;
  273.  
  274. let check_fatal () =
  275. + recent := [];
  276. if !nerrors > 0 then begin
  277. let e = Errors !nerrors in
  278. nerrors := 0;
  279. Index: utils/warnings.mli
  280. ===================================================================
  281. --- utils/warnings.mli (revision 13871)
  282. +++ utils/warnings.mli (working copy)
  283. @@ -75,5 +75,5 @@
  284. exception Errors of int;;
  285.  
  286. val check_fatal : unit -> unit;;
  287. -
  288. -val help_warnings: unit -> unit
  289. +val recent : t list ref;;
  290. +val help_warnings : unit -> unit;;
  291. Index: parsing/location.ml
  292. ===================================================================
  293. --- parsing/location.ml (revision 13871)
  294. +++ parsing/location.ml (working copy)
  295. @@ -261,7 +261,7 @@
  296. let print_error_cur_file ppf = print_error ppf (in_file !input_name);;
  297.  
  298. let print_warning loc ppf w =
  299. - if Warnings.is_active w then begin
  300. + if Warnings.is_active w && not (List.mem w !Warnings.recent) then begin
  301. let printw ppf w =
  302. let n = Warnings.print ppf w in
  303. num_loc_lines := !num_loc_lines + n
Add Comment
Please, Sign In to add comment