[bug#45893] [PATCH 2/2] guix: scripts: Add hint for option typo.

[zimoun]

* guix/scripts.scm (levenshtein-distance): New procedure.
(options->long-names): New procedure.
(option-hint): New procedure.
---
 guix/scripts.scm | 58 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 58 insertions(+)

diff --git a/guix/scripts.scm b/guix/scripts.scm
index 34cba35401..f40eadfedd 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,6 +32,7 @@
   #:use-module ((guix profiles) #:select (%profile-directory))
   #:autoload   (guix describe) (current-profile-date)
   #:use-module (guix build syscalls)
+  #:use-module (guix memoization)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-37)
@@ -112,6 +114,61 @@ procedure, but both the category and synopsis are meant to 
be read (parsed) by
          doc
          body ...)))))
 
+(define (levenshtein-distance s1 s2)
+  "Compute the Levenshtein distance between two strings."
+  ;; Naive implemenation
+  (define loop
+    (memoize
+     (lambda (as bt)
+       (match as
+         ('() (length bt))
+         (_ (match bt
+              ('() (length as))
+              (_
+               (let ((a (car as))
+                     (s (cdr as))
+                     (b (car bt))
+                     (t (cdr bt)))
+                 (if (char=? a b)
+                     (loop s t)
+                     (1+ (min
+                          (loop as t)
+                          (loop s bt)
+                          (loop s t))))))))))))
+
+  (let ((c1 (string->list s1))
+        (c2 (string->list s2)))
+    (loop c1 c2)))
+
+(define (options->long-names options)
+  "Return long names from options."
+  (fold (lambda (name res)
+          (match name
+            ((? char?) res)
+            ((? string?) (cons name res))))
+        '()
+        (fold append '() (map option-names options))))
+
+(define (option-hint name options)
+  "Return the closest long-name from name based on Levenshtein distance."
+  (fold (lambda (name res)
+          (if (string-null? res)
+              name
+              (string-append name " or " res)))
+        ""
+        (cadr (fold (lambda (long-name res)
+                     (let ((dist (levenshtein-distance name long-name)))
+                       (match res
+                         ((val lst)
+                          (if (< dist val)
+                              (list dist (list long-name))
+                              (if (= dist val)
+                                  (list dist (cons long-name lst))
+                                  res)))
+                         (_ (list dist (list long-name))))))
+                   '()
+                   (options->long-names options)))))
+
 (define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
   "A wrapper on top of `args-fold' that does proper user-facing error
 reporting."
@@ -149,6 +206,7 @@ parameter of 'args-fold'."
     ;; Actual parsing takes place here.
     (apply args-fold* args options
            (lambda (opt name arg . rest)
+             (display-hint (format #f (G_ "Do you mean @code{~a}?~%") 
(option-hint name options)))
              (leave (G_ "~A: unrecognized option~%") name))
            argument-handler
            seeds))
-- 
2.29.2