| Message ID | 20210116002634.10401-2-zimon.toutoune@gmail.com |
|---|---|
| State | Accepted |
| Headers | show |
| Series | DRAFT: Hint command line typo | expand |
| Context | Check | Description |
|---|---|---|
| cbaines/comparison | success | View comparision |
| cbaines/git branch | success | View Git branch |
| cbaines/applying patch | success | View Laminar job |
| cbaines/issue | success | View issue |
zimoun <zimon.toutoune@gmail.com> skribis: > * guix/utils.scm (levenshtein-distance): New procedure. > (string-closest): New procedure. > * guix/scripts.scm (option-hint): New procedure. > (parse-command-line): Add 'option-hint'. Yay! > +(define (option-hint guess options) > + "Return the closest long-name from name based on Levenshtein distance." > + (define (options->long-names options) > + (fold (lambda (name res) > + (match name > + ((? char?) res) > + ((? string?) (cons name res)))) > + '() > + (fold append '() (map option-names options)))) I think this can be simplified a bit: options->long-names = (filter string? (append-map option-names options)) > + (fold (lambda (name res) > + (if (string-null? res) > + (string-append "@code{" name "}") > + (string-append "@code{" name "}, " res))) > + "" > + (string-closest guess (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 +167,9 @@ 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 ~a?~%") > + (option-hint name options))) > (leave (G_ "~A: unrecognized option~%") name)) > argument-handler > seeds)) [...] > +(define (levenshtein-distance s1 s2) > + "Compute the Levenshtein distance between two strings." Maybe call it ‘string-distance’? > + ;; Naive implemenation > + (define loop > + (memoize > + (lambda (as bt) Instead of (memoize (lambda …)), you can write: (mlambda (str1 str2) …) > + (match as > + ('() (length bt)) The pattern for the empty list is (), not '(). How about making this addition to (guix utils) a commit of its own, and to add a small test in tests/utils.scm? > +(define (string-closest trial tests) > + "Return the list from TESTS the closest from the string TRIAL based on > +Levenshtein distance." Maybe something like: “Return the string from TESTS that is the closest from TRIAL, according to 'string-distance'.” > + (match (fold (lambda (test res) > + (let ((dist (levenshtein-distance trial test))) > + (match res > + ((val lst) > + (if (< dist val) > + (list dist (list test)) > + (if (= dist val) > + (list dist (cons test lst)) > + res))) > + (_ (list dist (list test)))))) > + '() > + tests) > + ((_ rest ...) (match rest ((head _ ...) head))))) You can simplify this a bit by using ‘fold2’, which allows you to pass two seeds instead of one: (fold2 (lambda (test closest shortest-distance) …) "" +inf.0 tests) It returns two values and the first one is the string. Ludo’.
diff --git a/guix/scripts.scm b/guix/scripts.scm index 34cba35401..03d45c0888 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. ;;; @@ -112,6 +113,23 @@ procedure, but both the category and synopsis are meant to be read (parsed) by doc body ...))))) +(define (option-hint guess options) + "Return the closest long-name from name based on Levenshtein distance." + (define (options->long-names options) + (fold (lambda (name res) + (match name + ((? char?) res) + ((? string?) (cons name res)))) + '() + (fold append '() (map option-names options)))) + + (fold (lambda (name res) + (if (string-null? res) + (string-append "@code{" name "}") + (string-append "@code{" name "}, " res))) + "" + (string-closest guess (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 +167,9 @@ 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 ~a?~%") + (option-hint name options))) (leave (G_ "~A: unrecognized option~%") name)) argument-handler seeds)) diff --git a/guix/utils.scm b/guix/utils.scm index f8b05e7e80..2a0fb28917 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -114,7 +115,10 @@ call-with-decompressed-port compressed-output-port call-with-compressed-output-port - canonical-newline-port)) + canonical-newline-port + + levenshtein-distance + string-closest)) ;;; @@ -847,6 +851,51 @@ be determined." ;; raising an error would upset Geiser users #f)))))) + +;;; +;;; Hint based on Levenshtein distance +;;; + +(define (levenshtein-distance s1 s2) + "Compute the Levenshtein distance between two strings." + ;; Naive implemenation + (define loop + (memoize + (lambda (as bt) + (match as + ('() (length bt)) + ((a s ...) + (match bt + ('() (length as)) + ((b t ...) + (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 (string-closest trial tests) + "Return the list from TESTS the closest from the string TRIAL based on +Levenshtein distance." + (match (fold (lambda (test res) + (let ((dist (levenshtein-distance trial test))) + (match res + ((val lst) + (if (< dist val) + (list dist (list test)) + (if (= dist val) + (list dist (cons test lst)) + res))) + (_ (list dist (list test)))))) + '() + tests) + ((_ rest ...) (match rest ((head _ ...) head))))) + ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: