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) + 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 -> 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 diff --git a/utils/misc.ml b/utils/misc.ml index e72d921bf..d3c0e1bc5 100644 --- a/utils/misc.ml +++ b/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 = diff --git a/utils/misc.mli b/utils/misc.mli index b7f040305..853e7cde6 100644 --- a/utils/misc.mli +++ b/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.