diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index f9ebaeb4..de813281 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -120,7 +120,7 @@ module Content = struct type message_element = | MainMessage of message | Position of position - | Suggestion of message + | Suggestion of string list | Result of message type t = message_element list @@ -137,7 +137,7 @@ module Content = struct in prepend_message content internal_error_prefix - let add_suggestion (content : t) (suggestion : message) = + let add_suggestion (content : t) (suggestion : string list) = content @ [Suggestion suggestion] let of_string (s : string) : t = @@ -164,8 +164,8 @@ module Content = struct Pos.format_loc_text ppf pos.pos | MainMessage msg -> msg ppf | Result msg -> msg ppf - | Suggestion msg -> - Format.fprintf ppf "🔎 Maybe you wanted to write %t" msg) + | Suggestion suggestions_list -> + Suggestions.display suggestions_list ppf) ppf message_elements) content | Cli.GNU -> failwith "unimplemented until the message library stabilises" @@ -194,7 +194,7 @@ exception CompilerError of Content.t let raise_spanned_error ?(span_msg : Content.message option) - ?(suggestion : Content.message option) + ?(suggestion : string list option) (span : Pos.t) format = let continuation (message : Format.formatter -> unit) = @@ -206,7 +206,7 @@ let raise_spanned_error Format.kdprintf continuation format let raise_multispanned_error_full - ?(suggestion : Content.message option) + ?(suggestion : string list option) (spans : (Content.message option * Pos.t) list) format = Format.kdprintf @@ -221,7 +221,7 @@ let raise_multispanned_error_full format let raise_multispanned_error - ?(suggestion : Content.message option) + ?(suggestion : string list option) (spans : (string option * Pos.t) list) format = raise_multispanned_error_full ?suggestion diff --git a/compiler/catala_utils/message.mli b/compiler/catala_utils/message.mli index 3dd1889c..5248577e 100644 --- a/compiler/catala_utils/message.mli +++ b/compiler/catala_utils/message.mli @@ -49,7 +49,7 @@ module Content : sig (** {2 Content manipulation}*) val to_internal_error : t -> t - val add_suggestion : t -> message -> t + val add_suggestion : t -> string list -> t (** {2 Content emission}*) @@ -67,19 +67,19 @@ exception CompilerError of Content.t val raise_spanned_error : ?span_msg:Content.message -> - ?suggestion:Content.message -> + ?suggestion:string list -> Pos.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a val raise_multispanned_error_full : - ?suggestion:Content.message -> + ?suggestion:string list -> (Content.message option * Pos.t) list -> ('a, Format.formatter, unit, 'b) format4 -> 'a val raise_multispanned_error : - ?suggestion:Content.message -> + ?suggestion:string list -> (string option * Pos.t) list -> ('a, Format.formatter, unit, 'b) format4 -> 'a diff --git a/compiler/catala_utils/suggestions.ml b/compiler/catala_utils/suggestions.ml index 0f28ae8a..710b9600 100644 --- a/compiler/catala_utils/suggestions.ml +++ b/compiler/catala_utils/suggestions.ml @@ -18,7 +18,6 @@ (** Computes the levenshtein distance between two strings, used to provide error messages suggestions *) let levenshtein_distance (s : string) (t : string) : int = - (* Three-way minimum *) let three_way_minimum a b c = min a (min b c) in let m = String.length s and n = String.length t in (* for all i and j, d.(i).(j) will hold the Levenshtein distance between the @@ -49,34 +48,61 @@ let levenshtein_distance (s : string) (t : string) : int = d.(m).(n) -(*We're creating a string list composed by those who satisfy the following rule - : they share the same levenshtein distance, which is the minimal distance - found between the reference word "keyword" and all the strings in - "string_list".*) -let suggestion_minimum_levenshtein_distance_association +(*We create a list composed by strings that satisfy the following rule : they + have the same levenshtein distance, which is the minimum distance between the + reference word "keyword" and all the strings in "string_list" (with the + condition that this minimum is equal to or less than one third of the length + of keyword + 1, in order to get suggestions close to "keyword")*) +let rec suggestion_minimum_levenshtein_distance_association (string_list : string list) - (keyword : string) : string list = + (keyword : string) : string list option = let rec strings_minimum_levenshtein_distance (minimum : int) (result : string list) - (levenshtein_distance_association' : (string * int) list) : string list = - match levenshtein_distance_association' with - | (current_string, current_lev_dist) :: tail -> - if current_lev_dist < minimum then - strings_minimum_levenshtein_distance current_lev_dist [current_string] - tail - else if current_lev_dist = minimum then + (string_list' : string list) : string list = + (*As we iterate through the "string_list'" list, we create a list "result" + with all strings that have the last minimum levenshtein distance found + ("minimum").*) + match string_list' with + (*When a new minimum levenshtein distance is found, the new result list is + our new element "current_string" followed by strings that have the same + minimum distance. It will be the "result" list if there is no levenshtein + distance smaller than this new minimum.*) + | current_string :: tail -> + let current_levenshtein_distance = + levenshtein_distance current_string keyword + in + if current_levenshtein_distance < minimum then + strings_minimum_levenshtein_distance current_levenshtein_distance + [current_string] tail + (*The "result" list is updated (we append "current_string" to "result") + when a new string shares the same minimum levenshtein distance + "minimum"*) + else if current_levenshtein_distance = minimum then strings_minimum_levenshtein_distance minimum (result @ [current_string]) tail + (*If a levenshtein distance greater than the minimum is found, "result" + doesn't change*) else strings_minimum_levenshtein_distance minimum result tail - | _ -> result + (*The "result" list is returned at the end of the "string_list'" list.*) + | [] -> result in - let levenshtein_distance_association = - List.map (fun s -> s, levenshtein_distance keyword s) string_list + let suggestions = + strings_minimum_levenshtein_distance + (1 + (String.length keyword / 3)) + (*In order to select suggestions that are not too far away from the + keyword*) + [] string_list in - match levenshtein_distance_association with - | [] -> [] - | (_, first_levenshtein_distance) :: _ -> - strings_minimum_levenshtein_distance first_levenshtein_distance [] - levenshtein_distance_association + match suggestions with [] -> None | _ :: _ -> Some suggestions + +let display (suggestions_list : string list) (ppf : Format.formatter) = + match suggestions_list with + | [] -> () + | _ :: _ -> + Format.pp_print_string ppf "Maybe you wanted to write : "; + Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@,or ") + (fun ppf string -> Format.fprintf ppf "@{\"%s\"@}" string) + ppf suggestions_list diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 8e385abf..85844896 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -130,18 +130,11 @@ let raise_error_cons_not_found Suggestions.suggestion_minimum_levenshtein_distance_association constructors (Mark.remove constructor) in - let print_string_list (ppf : Format.formatter) (string_list : string list) = - Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf " or@ ") - (fun ppf str -> Format.fprintf ppf "\"@{%s@}\"" str) - ppf string_list - in Message.raise_spanned_error ~span_msg:(fun ppf -> Format.fprintf ppf "Here is your code :") - ~suggestion:(fun ppf -> print_string_list ppf closest_constructors) - (Mark.get constructor) - "The name of this constructor has not been defined before@,\ - (it's probably a typographical error)." + ?suggestion:closest_constructors (Mark.get constructor) + "The name of this constructor has not been defined before@ (it's probably \ + a typographical error)." let disambiguate_constructor (ctxt : Name_resolution.context) diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index f5853551..15c65856 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -60,9 +60,6 @@ let rec law_struct_list_to_tree (f : Ast.law_structure list) : let gobbled, rest_out = split_rest_tree rest_tree in LawHeading (heading, gobbled) :: rest_out)) -(** Style with which to display syntax hints in the terminal output *) -let pp_hint ppf s = Format.fprintf ppf "@{\"%s\"@}" s - (** Usage: [raise_parser_error error_loc last_good_loc token msg] Raises an error message featuring the [error_loc] position where the parser @@ -70,7 +67,7 @@ let pp_hint ppf s = Format.fprintf ppf "@{\"%s\"@}" s message [msg]. If available, displays [last_good_loc] the location of the last token correctly parsed. *) let raise_parser_error - ?(suggestion : Message.Content.message option) + ?(suggestion : string list option) (error_loc : Pos.t) (last_good_loc : Pos.t option) (token : string) @@ -85,7 +82,9 @@ let raise_parser_error ( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"), last_good_loc ); ])) - "@[Syntax error at token %a@,%t@]" pp_hint token msg + "@[Syntax error at token %a@,%t@]" + (fun ppf string -> Format.fprintf ppf "@{\"%s\"@}" string) + token msg module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct include Parser.Make (LocalisedLexer) @@ -126,33 +125,9 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct | None -> token_list, None in let similar_acceptable_tokens = - List.sort - (fun (x, _) (y, _) -> - let truncated_x = - if String.length wrong_token <= String.length x then - String.sub x 0 (String.length wrong_token) - else x - in - let truncated_y = - if String.length wrong_token <= String.length y then - String.sub y 0 (String.length wrong_token) - else y - in - let levx = Suggestions.levenshtein_distance truncated_x wrong_token in - let levy = Suggestions.levenshtein_distance truncated_y wrong_token in - if levx = levy then String.length x - String.length y else levx - levy) - acceptable_tokens - in - let similar_token_msg = - match similar_acceptable_tokens with - | [] -> None - | tokens -> - Some - (fun ppf -> - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@,or maybe ") - (fun ppf (ts, _) -> pp_hint ppf ts)) - ppf tokens) + Suggestions.suggestion_minimum_levenshtein_distance_association + (List.map (fun (s, _) -> s) acceptable_tokens) + wrong_token in (* The parser has suspended itself because of a syntax error. Stop. *) let custom_menhir_message ppf = @@ -163,7 +138,7 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct Format.fprintf ppf "Message: @{%s@}" (String.trim (String.uncapitalize_ascii msg)) in - raise_parser_error ?suggestion:similar_token_msg + raise_parser_error ?suggestion:similar_acceptable_tokens (Pos.from_lpos (lexing_positions lexbuf)) (Option.map Pos.from_lpos last_positions) (Utf8.lexeme lexbuf) custom_menhir_message