Improve the implementation of suggestions

- suggestions.ml : improve details + algorithm implementation (see @Altgr reviews) + comments
- suggestions implementation : since we want to keep the same structure to display suggestion messages, Suggestion is no longer a formatted string but a string list. The goal is to have a similar formatted string for each suggestion, no matter what the error message is.
--> This involves changes to suggestions.mli, compiler/desugared/from_surface.ml (most important one) and compiler/surface/parser_driver.ml

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

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

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 "@{<yellow>\"%s\"@}" string)
+      ppf suggestions_list

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 "\"@{<yellow>%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)

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 "@{<yellow>\"%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 "@{<yellow>\"%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 );
       ]))
-    "@[<v>Syntax error at token %a@,%t@]" pp_hint token msg
+    "@[<v>Syntax error at token %a@,%t@]"
+    (fun ppf string -> Format.fprintf ppf "@{<yellow>\"%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: @{<yellow>%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