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-0dff7051ff02master
parent
9c53766241
commit
843f152505
|
@ -614,10 +614,20 @@ end) = struct
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
|
|
||||||
let spellcheck ppf env p lid =
|
let spellcheck ppf env p lid =
|
||||||
Typetexp.spellcheck_simple ppf fold
|
let choices ~path name =
|
||||||
(fun d ->
|
let valid_names =
|
||||||
if compare_type_path env p (get_type_path env d)
|
fold (fun d acc ->
|
||||||
then get_name d else "") env lid
|
(* 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 lookup_from_type env tpath lid =
|
||||||
let descrs = get_descrs (Env.find_type_descrs tpath env) in
|
let descrs = get_descrs (Env.find_type_descrs tpath env) in
|
||||||
|
|
|
@ -859,60 +859,34 @@ open Format
|
||||||
open Printtyp
|
open Printtyp
|
||||||
|
|
||||||
let spellcheck ppf fold env lid =
|
let spellcheck ppf fold env lid =
|
||||||
let cutoff =
|
let choices ~path name =
|
||||||
match String.length (Longident.last lid) with
|
let env = fold (fun x xs -> x::xs) path env [] in
|
||||||
| 1 | 2 -> 0
|
Misc.spellcheck env name in
|
||||||
| 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 "@?";
|
|
||||||
match lid with
|
match lid with
|
||||||
| Longident.Lapply _ -> ()
|
| Longident.Lapply _ -> ()
|
||||||
| Longident.Lident s ->
|
| Longident.Lident s ->
|
||||||
handle (fold (compare s) None env init)
|
Misc.did_you_mean ppf (fun () -> choices ~path:None s)
|
||||||
| Longident.Ldot (r, 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 =
|
let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc)
|
||||||
spellcheck ppf (fun f -> fold (fun decl x -> f (extr decl) x))
|
let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc)
|
||||||
|
|
||||||
let spellcheck ppf fold =
|
let fold_values = fold_simple Env.fold_values
|
||||||
spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))
|
let fold_types = fold_simple Env.fold_types
|
||||||
|
let fold_modules = fold_simple Env.fold_modules
|
||||||
type cd = string list * int
|
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
|
let report_error env ppf = function
|
||||||
| Unbound_type_variable name ->
|
| Unbound_type_variable name ->
|
||||||
fprintf ppf "Unbound type parameter %s@." name
|
fprintf ppf "Unbound type parameter %s@." name
|
||||||
| Unbound_type_constructor lid ->
|
| Unbound_type_constructor lid ->
|
||||||
fprintf ppf "Unbound type constructor %a" longident 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 ->
|
| Unbound_type_constructor_2 p ->
|
||||||
fprintf ppf "The type constructor@ %a@ is not yet completely defined"
|
fprintf ppf "The type constructor@ %a@ is not yet completely defined"
|
||||||
path p
|
path p
|
||||||
|
@ -977,26 +951,25 @@ let report_error env ppf = function
|
||||||
s "Multiple occurences are not allowed."
|
s "Multiple occurences are not allowed."
|
||||||
| Unbound_value lid ->
|
| Unbound_value lid ->
|
||||||
fprintf ppf "Unbound value %a" longident lid;
|
fprintf ppf "Unbound value %a" longident lid;
|
||||||
spellcheck ppf Env.fold_values env lid;
|
spellcheck ppf fold_values env lid;
|
||||||
| Unbound_module lid ->
|
| Unbound_module lid ->
|
||||||
fprintf ppf "Unbound module %a" longident lid;
|
fprintf ppf "Unbound module %a" longident lid;
|
||||||
spellcheck ppf Env.fold_modules env lid;
|
spellcheck ppf fold_modules env lid;
|
||||||
| Unbound_constructor lid ->
|
| Unbound_constructor lid ->
|
||||||
fprintf ppf "Unbound constructor %a" longident lid;
|
fprintf ppf "Unbound constructor %a" longident lid;
|
||||||
spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name)
|
spellcheck ppf fold_constructors env lid;
|
||||||
env lid;
|
|
||||||
| Unbound_label lid ->
|
| Unbound_label lid ->
|
||||||
fprintf ppf "Unbound record field %a" longident 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 ->
|
| Unbound_class lid ->
|
||||||
fprintf ppf "Unbound class %a" longident lid;
|
fprintf ppf "Unbound class %a" longident lid;
|
||||||
spellcheck ppf Env.fold_classs env lid;
|
spellcheck ppf fold_classs env lid;
|
||||||
| Unbound_modtype lid ->
|
| Unbound_modtype lid ->
|
||||||
fprintf ppf "Unbound module type %a" longident 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 ->
|
| Unbound_cltype lid ->
|
||||||
fprintf ppf "Unbound class type %a" longident 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 ->
|
| Ill_typed_functor_application lid ->
|
||||||
fprintf ppf "Ill-typed functor application %a" longident lid
|
fprintf ppf "Ill-typed functor application %a" longident lid
|
||||||
| Illegal_reference_to_recursive_module ->
|
| Illegal_reference_to_recursive_module ->
|
||||||
|
|
|
@ -107,12 +107,6 @@ val find_class_type:
|
||||||
val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
|
val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
|
||||||
val unbound_label_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 check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
|
||||||
|
|
||||||
val warning_enter_scope: unit -> unit
|
val warning_enter_scope: unit -> unit
|
||||||
|
|
|
@ -321,6 +321,39 @@ let edit_distance a b cutoff =
|
||||||
else Some result
|
else Some result
|
||||||
end
|
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 *)
|
(* split a string [s] at every char [c], and return the list of sub-strings *)
|
||||||
let split s c =
|
let split s c =
|
||||||
|
|
|
@ -144,6 +144,25 @@ val edit_distance : string -> string -> int -> int option
|
||||||
other. The particular algorithm may change in the future.
|
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
|
val split : string -> char -> string list
|
||||||
(** [String.split string char] splits the string [string] at every char
|
(** [String.split string char] splits the string [string] at every char
|
||||||
[char], and returns the list of sub-strings between the chars.
|
[char], and returns the list of sub-strings between the chars.
|
||||||
|
|
Loading…
Reference in New Issue