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

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

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)
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
 
-let spellcheck_simple ppf fold extr =
-  spellcheck ppf (fun f -> fold (fun decl x -> f (extr decl) 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)
 
-let spellcheck ppf fold =
-  spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))
-
-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 ->

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

utils/misc.ml

@@ -321,6 +321,39 @@ let edit_distance a b cutoff =
     else Some result
   end
 
+let spellcheck env name =
+  let cutoff =
+    match String.length name with
+      | 1 | 2 -> 0
+      | 3 | 4 -> 1
+      | 5 | 6 -> 2
+      | _ -> 3
+  in
+  let compare target acc head =
+    match edit_distance target head cutoff with
+      | None -> acc
+      | Some dist ->
+	 let (best_choice, best_dist) = acc in
+	 if dist < best_dist then ([head], dist)
+	 else if dist = best_dist then (head :: best_choice, dist)
+	 else acc
+  in
+  fst (List.fold_left (compare name) ([], max_int) env)
+
+let did_you_mean ppf get_choices =
+  (* flush now to get the error report early, in the (unheard of) case
+     where the search in the get_choices function 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. *)
+  Format.fprintf ppf "@?";
+  match get_choices () with
+  | [] -> ()
+  | choices ->
+     let rest, last = split_last choices in
+     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?"
+       (String.concat ", " rest)
+       (if rest = [] then "" else " or ")
+       last
 
 (* split a string [s] at every char [c], and return the list of sub-strings *)
 let split s c =

utils/misc.mli

@@ -144,6 +144,25 @@ val edit_distance : string -> string -> int -> int option
     other. The particular algorithm may change in the future.
 *)
 
+val spellcheck : string list -> string -> string list
+(** [spellcheck env name] takes a list of names [env] that exist in
+    the current environment and an erroneous [name], and returns a
+    list of suggestions taken from [env], that are close enough to
+    [name] that it may be a typo for one of them. *)
+
+val did_you_mean : Format.formatter -> (unit -> string list) -> unit
+(** [did_you_mean ppf get_choices] hints that the user may have meant
+    one of the option returned by calling [get_choices]. It does nothing
+    if the returned list is empty.
+
+    The [unit -> ...] thunking is meant to delay any potentially-slow
+    computation (typically computing edit-distance with many things
+    from the current environment) to when the hint message is to be
+    printed. You should print an understandable error message before
+    calling [did_you_mean], so that users get a clear notification of
+    the failure even if producing the hint is slow.
+*)
+
 val split : string -> char -> string list
 (** [String.split string char] splits the string [string] at every char
     [char], and returns the list of sub-strings between the chars.