simplify the spellcheck functions

- expose the core spellchecking functionality in Misc rather than Typetexp
- remove the too high-order (yet insufficiently parametric)
  Typetexp.spellcheck from the public interface
- rewrite the spellchecking functions for variants and fields in
  Typecore from the Misc functions rather than reusing
  Typetexp.spellcheck

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

3 files changed, 37 insertions, 60 deletions

diff --git a/typing/typecore.ml b/typing/typecore.ml
index 243549340..52b12cff5 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -614,10 +614,20 @@ end) = struct
     | _ -> assert false
 
   let spellcheck ppf env p lid =
-    Typetexp.spellcheck_simple ppf fold
-      (fun d ->
-        if compare_type_path env p (get_type_path env d)
-        then get_name d else "") env lid
+    let choices ~path name =
+      let valid_names =
+	fold (fun d acc ->
+	  (* only consider the constructors/fields that are
+             in the expected type [p] *)
+	  if compare_type_path env p (get_type_path env d)
+	  then get_name d :: acc else acc) path env [] in
+      Misc.spellcheck valid_names name in
+    match lid with
+    | Longident.Lapply _ -> ()
+    | Longident.Lident s ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
+    | Longident.Ldot (r, s) ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
 
   let lookup_from_type env tpath lid =
     let descrs = get_descrs (Env.find_type_descrs tpath env) in
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 523d435bc..a4e87c113 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -859,60 +859,34 @@ open Format
 open Printtyp
 
 let spellcheck ppf fold env lid =
-  let cutoff =
-    match String.length (Longident.last lid) with
-      | 1 | 2 -> 0
-      | 3 | 4 -> 1
-      | 5 | 6 -> 2
-      | _ -> 3
-  in
-  let compare target head acc =
-    let (best_choice, best_dist) = acc in
-    match Misc.edit_distance target head cutoff with
-      | None -> (best_choice, best_dist)
-      | Some dist ->
-        let choice =
-          if dist < best_dist then [head]
-          else if dist = best_dist then head :: best_choice
-          else best_choice in
-        (choice, min dist best_dist)
-  in
-  let init = ([], max_int) in
-  let handle (choice, _dist) =
-    match List.rev choice with
-      | [] -> ()
-      | last :: rev_rest ->
-        fprintf ppf "@\nHint: Did you mean %s%s%s?"
-          (String.concat ", " (List.rev rev_rest))
-          (if rev_rest = [] then "" else " or ")
-          last
-  in
-  (* flush now to get the error report early, in the (unheard of) case
-     where the linear search would take a bit of time; in the worst
-     case, the user has seen the error, she can interrupt the process
-     before the spell-checking terminates. *)
-  fprintf ppf "@?";
+  let choices ~path name =
+    let env = fold (fun x xs -> x::xs) path env [] in
+    Misc.spellcheck env name in
   match lid with
     | Longident.Lapply _ -> ()
     | Longident.Lident s ->
-      handle (fold (compare s) None env init)
+       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
     | Longident.Ldot (r, s) ->
-      handle (fold (compare s) (Some r) env init)
-
-let spellcheck_simple ppf fold extr =
-  spellcheck ppf (fun f -> fold (fun decl x -> f (extr decl) x))
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
 
-let spellcheck ppf fold =
-  spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))
+let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc)
+let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc)
 
-type cd = string list * int
+let fold_values = fold_simple Env.fold_values
+let fold_types = fold_simple Env.fold_types
+let fold_modules = fold_simple Env.fold_modules
+let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name)
+let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name)
+let fold_classs = fold_simple Env.fold_classs
+let fold_modtypes = fold_simple Env.fold_modtypes
+let fold_cltypes = fold_simple Env.fold_cltypes
 
 let report_error env ppf = function
   | Unbound_type_variable name ->
     fprintf ppf "Unbound type parameter %s@." name
   | Unbound_type_constructor lid ->
     fprintf ppf "Unbound type constructor %a" longident lid;
-    spellcheck ppf Env.fold_types env lid;
+    spellcheck ppf fold_types env lid;
   | Unbound_type_constructor_2 p ->
     fprintf ppf "The type constructor@ %a@ is not yet completely defined"
       path p
@@ -977,26 +951,25 @@ let report_error env ppf = function
         s "Multiple occurences are not allowed."
   | Unbound_value lid ->
       fprintf ppf "Unbound value %a" longident lid;
-      spellcheck ppf Env.fold_values env lid;
+      spellcheck ppf fold_values env lid;
   | Unbound_module lid ->
       fprintf ppf "Unbound module %a" longident lid;
-      spellcheck ppf Env.fold_modules env lid;
+      spellcheck ppf fold_modules env lid;
   | Unbound_constructor lid ->
       fprintf ppf "Unbound constructor %a" longident lid;
-      spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name)
-        env lid;
+      spellcheck ppf fold_constructors env lid;
   | Unbound_label lid ->
       fprintf ppf "Unbound record field %a" longident lid;
-      spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid;
+      spellcheck ppf fold_labels env lid;
   | Unbound_class lid ->
       fprintf ppf "Unbound class %a" longident lid;
-      spellcheck ppf Env.fold_classs env lid;
+      spellcheck ppf fold_classs env lid;
   | Unbound_modtype lid ->
       fprintf ppf "Unbound module type %a" longident lid;
-      spellcheck ppf Env.fold_modtypes env lid;
+      spellcheck ppf fold_modtypes env lid;
   | Unbound_cltype lid ->
       fprintf ppf "Unbound class type %a" longident lid;
-      spellcheck ppf Env.fold_cltypes env lid;
+      spellcheck ppf fold_cltypes env lid;
   | Ill_typed_functor_application lid ->
       fprintf ppf "Ill-typed functor application %a" longident lid
   | Illegal_reference_to_recursive_module ->
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index 7bff403f0..b7a05dca9 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -107,12 +107,6 @@ val find_class_type:
 val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
 val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a
 
-type cd
-val spellcheck_simple:
-    Format.formatter ->
-    (('a -> cd -> cd) -> Longident.t option -> 'b -> cd -> cd) ->
-    ('a -> string) -> 'b -> Longident.t -> unit
-
 val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
 
 val warning_enter_scope: unit -> unit