WIP: Minibuffer overhaul

libraries/class-star/patch.lisp

@@ -0,0 +1,113 @@
+;;;; SPDX-License-Identifier: Public Domain
+
+;; This is a hotpatch for hu.dwim.defclass-star which is under the public
+;; domain.
+
+(in-package hu.dwim.defclass-star)
+
+(defun process-slot-definition (definition)
+  (unless (consp definition)
+    (setf definition (list definition)))
+  (let ((name (pop definition))
+        (initform 'missing)
+        (entire-definition definition))
+    (assert name)
+    (push name *slot-names*)
+    (if (oddp (length definition))
+        (progn
+          (setf initform (pop definition))
+          (setf entire-definition definition)
+          (when (eq initform :unbound)
+            (setf initform 'missing)))
+        (setf initform (getf definition :initform 'missing)))
+    (assert (every #'keywordp (loop for el :in definition :by #'cddr
+                                    collect el))
+            () "Found non-keywords in ~S" definition)
+    (destructuring-bind (&key (accessor 'missing) (initarg 'missing)
+                              (reader 'missing) (writer 'missing)
+                              (export 'missing)
+                              &allow-other-keys)
+        definition
+      (remf-keywords definition :accessor :reader :writer :initform :initarg :export)
+      (let ((unknown-keywords (loop for el :in definition :by #'cddr
+                                    unless (or (member t *allowed-slot-definition-properties*)
+                                               (member el *allowed-slot-definition-properties*))
+                                    collect el))
+            (slot-name-warning-triggered? nil))
+        (when unknown-keywords
+          (style-warn "Unexpected properties in slot definition ~S.~%~
+                       The unexpected properties are ~S.~%~
+                       To avoid this warning (pushnew (or T :your-custom-keyword) hu.dwim.defclass-star:*allowed-slot-definition-properties*)"
+                      entire-definition unknown-keywords))
+        (flet ((provided-p (value)
+                 (and value
+                      (not (eq value 'missing))))
+               (transform-accessor ()
+                 (funcall *accessor-name-transformer* name entire-definition))
+               (maybe-warn-for-slot-name ()
+                 (unless (or slot-name-warning-triggered?
+                             (eq (symbol-package name) *package*))
+                   (setf slot-name-warning-triggered? t)
+                   #+nil ;; this generates too many warnings which makes it kinda pointless
+                   (style-warn "defclass* for a slot name ~A while its home package is not *package* (~A). Default generated names will be interned into *package*!"
+                               (fully-qualified-symbol-name name) *package*))))
+          (prog1
+              (funcall *slot-definition-transformer*
+                       (append (list name)
+                               (unless (eq initform 'missing)
+                                 (list :initform initform))
+                               (if (and (eq accessor 'missing)
+                                        (eq reader 'missing)
+                                        (eq writer 'missing))
+                                   (when *automatic-accessors-p*
+                                     (maybe-warn-for-slot-name)
+                                     (setf accessor (transform-accessor))
+                                     (list :accessor accessor))
+                                   (let ((transformed-accessor (transform-accessor)))
+                                     (append (progn
+                                               (when (eq accessor t)
+                                                 (setf accessor transformed-accessor))
+                                               (when (provided-p accessor)
+                                                 (list :accessor accessor)))
+                                             (progn
+                                               (when (eq reader t)
+                                                 (setf reader transformed-accessor))
+                                               (when (provided-p reader)
+                                                 (list :reader reader)))
+                                             (progn
+                                               (when (eq writer t)
+                                                 (setf writer `(setf ,transformed-accessor)))
+                                               (when (provided-p writer)
+                                                 (list :writer writer))))))
+                               (if (eq initarg 'missing)
+                                   (when *automatic-initargs-p*
+                                     (list :initarg (funcall *initarg-name-transformer* name entire-definition)))
+                                   (when initarg
+                                     (list :initarg initarg)))
+                               definition))
+            (when (provided-p accessor)
+              (pushnew accessor *accessor-names*))
+            (when (provided-p reader)
+              (pushnew reader *accessor-names*))
+            (when (provided-p writer)
+              (pushnew (second writer) *accessor-names*))
+            (if (not (eq export 'missing))
+                (ecase export
+                  (:accessor
+                   (when accessor
+                     (push accessor *symbols-to-export*)))
+                  ((:slot :name :slot-name)
+                   (push name *symbols-to-export*))
+                  ((t)
+                    ;; XXX: The `when' condition was just `accessor' and failed to account for missing accessors.
+                   (when (and accessor (not (eq accessor 'missing)))
+                     (push accessor *symbols-to-export*))
+                   (push name *symbols-to-export*))
+                  ((nil)))
+                (progn
+                  (when *export-accessor-names-p*
+                    ;; XXX: Same as above.
+                    (when (and accessor (not (eq accessor 'missing)))
+                      (push accessor *symbols-to-export*)))
+                  (when *export-slot-names-p*
+                    (push name *symbols-to-export*))))))))))

libraries/prompter/filter-preprocessor.lisp

@@ -0,0 +1,55 @@
+;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
+;;;; SPDX-License-Identifier: BSD-3-Clause
+
+(in-package :prompter)
+
+(defun find-exactly-matching-substrings (input suggestion-match-data
+                                         &key (substring-length 2))
+  "Return the list of input substrings that match at least one suggestion.
+The substrings must be SUBSTRING-LENGTH characters long or more."
+  (let ((input-strings (delete-if (lambda (s) (< (length s) substring-length))
+                                  (str:split " " input :omit-nulls t))))
+    (when input-strings
+      (delete-duplicates
+       (loop for match-datum in suggestion-match-data
+             append (remove-if
+                     (lambda (i)
+                       (not (search i match-datum)))
+                     input-strings))
+       :test #'string=))))
+
+(defun format-properties (properties &optional downcasedp)
+  (let ((result
+          (str:join " "
+                    (loop for i on properties by #'cddr
+                          collect (second i)))))
+    (if downcasedp
+        (string-downcase result)
+        result)))
+
+(export-always 'delete-inexact-matches)
+(defun delete-inexact-matches (suggestions source input)
+  "Destructively filter out non-exact matches from SUGGESTIONS.
+Return the resulting list.
+If any input substring matches exactly (but not necessarily a whole word),
+then all suggestions that are not exactly matched by at least one substring are removed.
+
+Suitable as a `prompter-source' `filter-preprocessor'."
+  ;; TODO: Compute match-data separately.  Make it customizable.
+  (dolist (suggestion suggestions)
+    (setf
+     (match-data suggestion)
+     (format-properties
+      (filtered-properties-suggestion suggestion (active-properties source))
+      (str:downcasep input))))
+  (unless (str:empty? input)
+    (let ((exactly-matching-substrings (find-exactly-matching-substrings
+                                        input
+                                        (mapcar #'match-data suggestions))))
+      (when exactly-matching-substrings
+        (setf suggestions
+              (delete-if (lambda (suggestion)
+                           (not (loop for i in exactly-matching-substrings
+                                      always (search i (match-data suggestion)))))
+                         suggestions)))))
+  suggestions)

libraries/prompter/filter.lisp

@@ -0,0 +1,70 @@
+;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
+;;;; SPDX-License-Identifier: BSD-3-Clause
+
+(in-package :prompter)
+
+(defun substring-norm (substrings string &key (substring-length 2))
+  "Return the norm of SUBSTRINGS with regard to STRING.
+The norm is closer to 1 if
+- substrings start near the beginning of STRING;
+- substrings length are closer to the length of STRING.
+
+Only substrings of SUBSTRING-LENGTH characters or more are considered."
+  ;; TODO: Remove duplicates in SUBSTRINGS?  Repeats could mean we insist more on it.
+  (let ((position-factor 1.0)
+        (length-factor 1.0)
+        (long-substrings (remove-if (lambda (s) (> substring-length (length s)))
+                                    substrings)))
+    (if long-substrings
+        (/ (apply #'+
+                  (mapcar (lambda (s)
+                            (let ((position (search s string)))
+                              (if (not position)
+                                  0
+                                  (/ (+
+                                      (* position-factor
+                                         (/ 1
+                                            ;; We use the sqrt to slow down the
+                                            ;; decrease rate, we want the a
+                                            ;; position of 10-15 still be >0.1.
+                                            (sqrt (1+ position))))
+                                      (* length-factor
+                                         (/ (min (length s) (length string))
+                                            (length string))))
+                                     (+ position-factor length-factor)))))
+                          long-substrings))
+           (length long-substrings))
+        0)))
+
+(defun to-unicode (input)
+  "Convert INPUT to (simple-array character) type."
+  (if (typep input 'base-string)
+      (coerce input `(simple-array character (,(length input))))
+      input))
+
+(defun score-suggestion-string (input suggestion-string)
+  "Return a SUGGESTION's score for INPUT.
+A higher score means the suggestion-string comes first."
+  ;; The Jaccard metric seems to provide much better results than, say,
+  ;; Damerau-Levensthein but it's much slower.
+  ;; TODO: Check out fzf for a possibly good scoring algorithm.
+  (+ (* 1.0 (mk-string-metrics:norm-damerau-levenshtein suggestion-string input))
+     (* 1.0 (substring-norm (str:split " " input) suggestion-string))))
+
+(defvar score-threshold 0.0             ; TODO: Learn good value and enable low-score filtering.
+  "The threshold under which suggestions are eleminated.")
+
+(export-always 'score>)
+(defun score> (suggestion1 suggestion2)
+  "Suitable as a `prompter-source' `sort-predicate'."
+  (> (score suggestion1)
+     (score suggestion2)))
+
+(export-always 'fuzzy-match)
+(defun fuzzy-match (input suggestion)
+  "Score the SUGGESTION according to a fuzzy string distance to the INPUT."
+  (setf input (to-unicode input))
+  (setf (match-data suggestion) (to-unicode (match-data suggestion)))
+  (setf (score suggestion)
+        (score-suggestion-string input (match-data suggestion)))
+  suggestion)

libraries/prompter/package.lisp

@@ -0,0 +1,34 @@
+;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
+;;;; SPDX-License-Identifier: BSD-3-Clause
+
+(in-package cl-user)
+
+(uiop:define-package prompter
+  (:use #:common-lisp)
+  (:import-from #:class* #:define-class)
+  (:import-from #:serapeum #:export-always))
+
+(in-package prompter)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
+  (trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum))
+
+(defmacro define-function (name args &body body)
+  "Eval ARGS then define function over the resulting lambda list.
+All ARGS are declared as `ignorable'."
+  (let ((evaluated-args (eval args)))
+    `(defun ,name  ,evaluated-args
+       (declare (ignorable ,@(set-difference (mapcar (lambda (arg) (if (listp arg) (first arg) arg))
+                                                     evaluated-args)
+                                             lambda-list-keywords)))
+       ,@body)))
+
+(defun initargs (class-specifier)
+  "Return CLASS-SPECIFIER initargs as symbols (not keywords)."
+  (mapcar (lambda (slot)
+            (intern
+             (symbol-name
+              (first (getf (mopu:slot-properties class-specifier slot) :initargs)))
+             (symbol-package class-specifier)))
+          (mopu:slot-names class-specifier)))