Simpler implementation of error narrowing. Factorization of lid finding code.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@10378 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 49 insertions, 58 deletions

diff --git a/typing/typecore.ml b/typing/typecore.ml
index 6043bff2c5..0f55bbab66 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -306,7 +306,7 @@ let rec build_as_type env p =
   | Tpat_array _ | Tpat_lazy _ -> p.pat_type
 
 (* Narrowing unbound identifier errors. *)
-let rec narrow_unbound_lid_error env loc lid make_error =
+let rec narrow_unbound_lid_error env lid make_error =
   let module_is_bound mlid =
     ignore (Env.lookup_module mlid env) in
   match lid with
@@ -316,7 +316,7 @@ let rec narrow_unbound_lid_error env loc lid make_error =
       try
         module_is_bound mlid;
         make_error lid with
-      | Not_found -> Error (loc, Unbound_module mlid)
+      | Not_found -> Unbound_module mlid
     end
   | Longident.Lapply (flid, mlid) ->
     begin
@@ -326,24 +326,53 @@ let rec narrow_unbound_lid_error env loc lid make_error =
           try
             module_is_bound mlid;
             make_error lid with
-          | Not_found -> Error (loc, Unbound_module mlid)
+          | Not_found -> Unbound_module mlid
         end with
-      | Not_found -> Error (loc, Unbound_functor flid)
+      | Not_found -> Unbound_functor flid
     end
 ;;
 
 let unbound_lid_error env loc lid make_error =
-  let err = narrow_unbound_lid_error env loc lid make_error in
-  raise err
+  let err = narrow_unbound_lid_error env lid make_error in
+  raise (Error (loc, err))
 ;;
 
-let build_or_pat env loc lid =
-  let path, decl =
-    try Env.lookup_type lid env
-    with Not_found ->
+let find_type env loc lid =
+  try Env.lookup_type lid env
+  with Not_found ->
+    unbound_lid_error env loc lid
+      (fun lid ->
+       raise (Typetexp.Error (loc, Typetexp.Unbound_type_constructor lid)))
+;;
+
+let find_constructor env loc lid =
+  try
+    match lid with
+    | Longident.Ldot (Longident.Lident "*predef*", s) ->
+        Env.lookup_constructor (Longident.Lident s) Env.initial
+    | _ -> Env.lookup_constructor lid env
+  with Not_found ->
+    unbound_lid_error env loc lid
+      (fun lid -> Unbound_constructor lid)
+;;
+
+let find_label env loc lid =
+  try
+    Env.lookup_label lid env
+  with Not_found ->
+    unbound_lid_error env loc lid
+      (fun lid -> Unbound_label lid)
+;;
+
+let find_class env loc lid =
+  try Env.lookup_class lid env with
+  | Not_found ->
       unbound_lid_error env loc lid
-        (fun lid ->
-         Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid))
+        (fun lid -> Unbound_class lid)
+;;
+
+let build_or_pat env loc lid =
+  let path, decl = find_type env loc lid
   in
   let tyl = List.map (fun _ -> newvar()) decl.type_params in
   let row0 =
@@ -495,15 +524,7 @@ let rec type_pat env sp =
         pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
         pat_env = env }
   | Ppat_construct(lid, sarg, explicit_arity) ->
-      let constr =
-        try
-          match lid with
-            Longident.Ldot (Longident.Lident "*predef*", s) ->
-              Env.lookup_constructor (Longident.Lident s) Env.initial
-          | _ -> Env.lookup_constructor lid env
-        with Not_found ->
-          unbound_lid_error env loc lid
-            (fun lid -> Error(loc, Unbound_constructor lid)) in
+      let constr = find_constructor env loc lid in
       let sargs =
         match sarg with
           None -> []
@@ -544,12 +565,7 @@ let rec type_pat env sp =
   | Ppat_record(lid_sp_list, closed) ->
       let ty = newvar() in
       let type_label_pat (lid, sarg) =
-        let label =
-          try
-            Env.lookup_label lid env
-          with Not_found ->
-            unbound_lid_error env loc lid
-              (fun lid -> Error(loc, Unbound_label lid)) in
+        let label = find_label env loc lid in
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
         if vars = [] then end_def ();
@@ -1089,7 +1105,7 @@ let rec type_exp env sexp =
           exp_env = env }
       with Not_found ->
         unbound_lid_error env loc lid
-          (fun lid -> Error (loc, Unbound_value lid))
+          (fun lid -> Unbound_value lid)
       end
   | Pexp_constant cst ->
       re {
@@ -1189,12 +1205,7 @@ let rec type_exp env sexp =
       let ty = newvar() in
       let num_fields = ref 0 in
       let type_label_exp (lid, sarg) =
-        let label =
-          try
-            Env.lookup_label lid env
-          with Not_found ->
-            unbound_lid_error env loc lid
-              (fun lid -> Error (loc, Unbound_label lid)) in
+        let label = find_label env loc lid in
         begin_def ();
         if !Clflags.principal then begin_def ();
         let (vars, ty_arg, ty_res) = instance_label true label in
@@ -1265,12 +1276,7 @@ let rec type_exp env sexp =
         exp_env = env }
   | Pexp_field(sarg, lid) ->
       let arg = type_exp env sarg in
-      let label =
-        try
-          Env.lookup_label lid env
-        with Not_found ->
-          unbound_lid_error env loc lid
-            (fun lid -> Error (loc, Unbound_label lid)) in
+      let label = find_label env loc lid in
       let (_, ty_arg, ty_res) = instance_label false label in
       unify_exp env arg ty_res;
       re {
@@ -1280,12 +1286,7 @@ let rec type_exp env sexp =
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
       let record = type_exp env srecord in
-      let label =
-        try
-          Env.lookup_label lid env
-        with Not_found ->
-          unbound_lid_error env loc lid
-            (fun lid -> Error (loc, Unbound_label lid)) in
+      let label = find_label env loc lid in
       if label.lbl_mut = Immutable then
         raise(Error(loc, Label_not_mutable lid));
       begin_def ();
@@ -1532,12 +1533,7 @@ let rec type_exp env sexp =
         raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
       end
   | Pexp_new cl ->
-      let (cl_path, cl_decl) =
-        try Env.lookup_class cl env with
-        | Not_found ->
-          unbound_lid_error env loc cl
-            (fun lid -> Error (loc, Unbound_class lid))
-      in
+      let (cl_path, cl_decl) = find_class env loc cl in
         begin match cl_decl.cty_new with
           None ->
             raise(Error(loc, Virtual_class cl))
@@ -1956,12 +1952,7 @@ and type_application env funct sargs =
         type_args [] [] ty ty sargs []
 
 and type_construct env loc lid sarg explicit_arity ty_expected =
-  let constr =
-    try
-      Env.lookup_constructor lid env
-    with Not_found ->
-      unbound_lid_error env loc lid
-        (fun lid -> Error (loc, Unbound_constructor lid)) in
+  let constr = find_constructor env loc lid in
   let sargs =
     match sarg with
       None -> []