diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index b91e715..90f9995 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -20,7 +20,7 @@ jobs: # Use ccl-bin/1.12.1 instead of 'ccl' because of # https://github.com/roswell/roswell/issues/534. # TODO: Revert when Roswell is functional again. - lisp: [sbcl-bin, ccl-bin/1.12.1] + lisp: [sbcl-bin, ccl-bin/1.12.1, ecl/21.2.1] rosargs: [dynamic-space-size=3072] os: [ubuntu-latest, macos-latest] # try windows-latest when we understand commands to install Roswell on it diff --git a/.gitmodules b/.gitmodules index 98df717..558526b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -10,14 +10,6 @@ path = _build/symbol-munger url = https://github.com/AccelerationNet/symbol-munger shallow = true -[submodule "_build/calispel"] - path = _build/calispel - url = https://github.com/hawkir/calispel - shallow = true -[submodule "_build/cl-jpl-util"] - path = _build/cl-jpl-util - url = https://github.com/hawkir/cl-jpl-util - shallow = true [submodule "_build/cl-containers"] path = _build/cl-containers url = https://github.com/gwkkwg/cl-containers @@ -170,11 +162,11 @@ path = _build/trivial-package-local-nicknames url = https://github.com/phoe/trivial-package-local-nicknames shallow = true -[submodule "_build/jpl-queues"] - path = _build/jpl-queues - url = https://gitlab.common-lisp.net/nyxt/jpl-queues.git - shallow = true [submodule "_build/mt19937"] path = _build/mt19937 url = https://gitlab.common-lisp.net/nyxt/mt19937 shallow = true +[submodule "_build/nhooks"] + path = _build/nhooks + url = https://github.com/atlas-engineer/nhooks + shallow = true diff --git a/README.org b/README.org index cd33f4a..836a291 100644 --- a/README.org +++ b/README.org @@ -56,3 +56,8 @@ Non-exhaustive list of features: - Marks actions (event-driven on marks change). - Current suggestion actions (event-driven on current suggestion change). - Automatically return the prompt when narrowed down to a single suggestion. + +* Roadmap + +- Benchmark. + See if setting task priorities with Lparallel helps performance. diff --git a/_build/calispel b/_build/calispel deleted file mode 160000 index e9f2f9c..0000000 --- a/_build/calispel +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e9f2f9c1af97f4d7bb4c8ac25fb2a8f3e8fada7a diff --git a/_build/cl-jpl-util b/_build/cl-jpl-util deleted file mode 160000 index 0311ed3..0000000 --- a/_build/cl-jpl-util +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 0311ed374e19a49d43318064d729fe3abd9a3b62 diff --git a/_build/jpl-queues b/_build/jpl-queues deleted file mode 160000 index b774d24..0000000 --- a/_build/jpl-queues +++ /dev/null @@ -1 +0,0 @@ -Subproject commit b774d24b3a2935b6e5ad17f83ff20ff359e2df81 diff --git a/_build/nhooks b/_build/nhooks new file mode 160000 index 0000000..8579085 --- /dev/null +++ b/_build/nhooks @@ -0,0 +1 @@ +Subproject commit 8579085542546a482ec0807cd8acf3819e383218 diff --git a/delayed-future.lisp b/delayed-future.lisp new file mode 100644 index 0000000..cd5f7cf --- /dev/null +++ b/delayed-future.lisp @@ -0,0 +1,99 @@ +;;;; SPDX-FileCopyrightText: Atlas Engineer LLC +;;;; SPDX-License-Identifier: BSD-3-Clause + +(in-package :prompter) + +(define-class delayed-future () + ((fn + nil + :reader t + :writer nil + :export nil) + (queue + (lpara.queue:make-queue) + :export nil) + (drained-p + nil + :accessor nil + :export nil) + (kernel ; REVIEW: Not needed? + lpara:*kernel* + :reader t + :writer nil + :export t) + (delay + 0.0 + :reader t + :writer nil ; REVIEW: Does it make sense to allow delay modification? + :export t + :documentation "The time in seconds to wait before starting to compute the result. +The computation is done over the argument last passed through `fulfill'. ") + (future + nil + :accessor nil + :export nil) ) + (:export-class-name-p t) + (:export-accessor-names-p t) + (:predicate-name-transformer 'nclasses:always-dashed-predicate-name-transformer) + (:documentation "A `delayed-future' is like an `lparallel:future' that only starts computing its +result after `delay' has passed since the last `fulfill' call. + +This allows to efficiently handle input spam by only processing the last received input every `delay'.")) + +(defun set-future (delayed-future) + (flet ((funcall-with-delay (fun queue delay) + "Call FUN over the last element of QUEUE after DELAY has expired since last pop." + (labels ((drain-queue (queue delay last-input) + (multiple-value-bind (input no-timeout) + (lpara.queue:try-pop-queue queue :timeout delay) + (if no-timeout + (drain-queue queue delay input) + ;; An item might be pushed to the queue between timeout when we check. + ;; + ;; If so, we loop again, because it's practically as + ;; if the item had arrived just in time. + ;; + ;; If not, then we return, marking as `drained-p' so + ;; that next time an item is pushed the future is + ;; re-created. + (let ((loop? nil)) + (serapeum:synchronized (queue) + (if (lpara.queue:queue-empty-p queue) + (setf (slot-value delayed-future 'drained-p) t) + (setf loop? t))) + (if loop? + (drain-queue queue delay (lpara.queue:pop-queue queue)) + last-input)))))) + ;; We call `lpara.queue:pop-queue' here so that calling `force' on + ;; an unfulfilled delayed-future blocks. + (funcall fun (drain-queue queue delay (lpara.queue:pop-queue queue)))))) + (let ((lpara:*kernel* (kernel delayed-future))) + (setf (slot-value delayed-future 'future) + (lpara:future (funcall-with-delay (fn delayed-future) + (queue delayed-future) + (delay delayed-future))))))) + +(defmethod initialize-instance :after ((delayed-future delayed-future) &key) + (set-future delayed-future)) + +(export-always 'fulfill) +(define-generic fulfill ((delayed-future delayed-future) arg) + "Pass ARG to DELAYED-FUTURE. +- Start computing over ARG after waiting for `delay' since last `fulfill' call. +- If `fulfill' is called while a result is being computed, the current + computation is discarded and a new one is started over ARG." + (sera:synchronized ((queue delayed-future)) + (lpara.queue:push-queue arg (queue delayed-future)) + (when (slot-value delayed-future 'drained-p) + (setf (slot-value delayed-future 'drained-p) nil) + (set-future delayed-future)))) + +(export-always 'force) +(define-generic force ((delayed-future delayed-future)) + "Like `lparallel:force'." + (lpara:force (slot-value delayed-future 'future))) + +(export-always 'fulfilledp) +(define-generic fulfilledp ((delayed-future delayed-future)) + "Like `lparallel:fulfilledp'." + (lpara:fulfilledp (slot-value delayed-future 'future))) diff --git a/package.lisp b/package.lisp index 8500032..ba0d88d 100644 --- a/package.lisp +++ b/package.lisp @@ -3,13 +3,15 @@ (uiop:define-package :prompter (:use :common-lisp) - (:import-from :nclasses #:define-class) + (:import-from :nclasses #:define-class #:define-generic) (: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)) + (trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum) + (trivial-package-local-nicknames:add-package-local-nickname :lpara :lparallel) + (trivial-package-local-nicknames:add-package-local-nickname :lpara.queue :lparallel.queue)) (defmacro define-function (name args &body body) "Eval ARGS then define function over the resulting lambda list. @@ -21,6 +23,13 @@ All ARGS are declared as `ignorable'." lambda-list-keywords))) ,@body))) +(defun slot-names (class-specifier) + ;; TODO: `slot-names' or `direct-slot-names'? + #-ecl + (mopu:slot-names class-specifier) + #+ecl + (mapcar #'c2mop:slot-definition-name (c2mop:class-slots (find-class class-specifier)))) + (defun initargs (class-specifier) "Return CLASS-SPECIFIER initargs as symbols (not keywords)." (delete nil @@ -29,11 +38,7 @@ All ARGS are declared as `ignorable'." (symbol-name (first (getf (mopu:slot-properties class-specifier slot) :initargs))) (symbol-package class-specifier))) - ;; TODO: `slot-names' or `direct-slot-names'? - #-ecl - (mopu:slot-names class-specifier) - #+ecl - (mapcar #'c2mop:slot-definition-name (c2mop:class-slots (find-class 'prompter)))))) + (slot-names class-specifier)))) (defun exported-p (sym) (eq :external @@ -46,4 +51,4 @@ All ARGS are declared as `ignorable'." (export-always '*debug-on-error*) (defvar *debug-on-error* nil "When non-nil, the Lisp debugger is invoked when a condition is raised. -Otherwise all errors occuring in threads are demoted to warnings.") +Otherwise all errors occurring in threads are demoted to warnings.") diff --git a/prompter-source.lisp b/prompter-source.lisp index c444b7d..0b6c862 100644 --- a/prompter-source.lisp +++ b/prompter-source.lisp @@ -16,41 +16,11 @@ (deftype function-symbol () `(and symbol (satisfies fboundp))) -(defmacro with-protect ((format-string &rest args) &body body) ; TODO: Inspired by Nyxt. Move to serapeum? - "Run body while capturing all conditions and echoing them as a warning. -The warning is reported to the user as per -FORMAT-STRING and ARGS. -As a special case, the first `:condition' keyword in ARGS is replaced with the -raised condition." - (alex:with-gensyms (c) - `(handler-case (progn ,@body) - (error (,c) - (declare (ignorable ,c)) - ,(let* ((condition-index (position :condition args)) - (new-args (if condition-index - (append (subseq args 0 condition-index) - `(,c) - (subseq args (1+ condition-index))) - args))) - `(warn ,format-string ,@new-args)))))) - -(defmacro run-thread (name &body body) ; TODO: Copied from Nyxt. Move to serapeum? - "Run body in a new protected new thread. -This is a \"safe\" wrapper around `bt:make-thread'." - `(bt:make-thread - (lambda () - (if *debug-on-error* - (progn - ,@body) - (with-protect ("Error on separate prompter thread: ~a" :condition) - ,@body))) - :name ,name)) - (defun object-public-slots (object-specifier) "Return the list of exported slots." (delete-if (complement #'exported-p) - (mopu:slot-names object-specifier))) + (slot-names object-specifier))) (define-class source () ((name @@ -58,6 +28,20 @@ This is a \"safe\" wrapper around `bt:make-thread'." :documentation "Name which can be used to differentiate sources from one another.") + (prompter + nil + :type (or null prompter) + :export nil ; TODO: Export? + :documentation "The parent prompter.") + + (kernel ; TODO: Can we somehow avoid this? + nil + :type (or null lpara:kernel) + :writer t + :reader nil + :export nil + :documentation "Lparallel fallback kernel in case there is no `prompter' for the source.") + (constructor nil :type (or list function) @@ -83,12 +67,12 @@ On initialization this list is transformed to a list of `suggestion's with `suggestion-maker'. This list is never modified after initialization.") - (initial-suggestions-lock - (bt:make-lock) - :type bt:lock + (initial-suggestions-channel + nil + :type (or null lpara:channel) :export nil :initarg nil - :documentation "Protect `initial-suggestions' access.") + :documentation "Synchronize `initial-suggestions' access.") (suggestions '() @@ -97,7 +81,7 @@ This list is never modified after initialization.") :documentation "The current list of suggestions. It's updated asynchronously every time the prompter input is changed. The slot is readable even when the computation hasn't finished. -See `ready-notifier' to know when the list is final. +See `ready-p' to know when the list is final. See `update-notifier' to know when it has been updated, to avoid polling the list.") @@ -217,14 +201,6 @@ function for the public interface. For convenience, it may be initialized with a single function or symbol, in which case it will be automatically turned into a list.") - (update-notifier - (make-channel) - :type calispel:channel - :documentation "A channel which is written to when `filter' commits a change -to `suggestion's. A notification is only sent if at least `notification-delay' -has passed. This is useful so that clients don't have to poll `suggestion's for -changes.") - (notification-delay 0.1 :type alex:non-negative-real @@ -235,44 +211,11 @@ changes.") nil :type boolean :export t + :reader t :initarg nil :documentation "Whether the source is done computing its suggestions. See also `next-ready-p' and `all-ready-p' to wait until ready.") - (ready-channel - nil - :type (or null calispel:channel) - :export nil - :initarg nil - :documentation "Notify listener that source is ready. -The source object is sent to the channel. -If update calculation is aborted, nil is sent instead.") - - (update-thread - nil - :type (or null bt:thread) - :export nil - :initarg nil - :documentation "Thread where the `filter-preprocessor', `filter' and -`filter-postprocessor' are run. We store it in a slot so that we can terminate -it.") - - (attribute-thread - nil - :type (or null bt:thread) - :export nil - :initarg nil - :documentation "Thread where the attributes get asynchronously computer. -See `attribute-channel'.") - - (attribute-channel - (make-channel) - :type (or null calispel:channel) - :export nil - :initarg nil - :documentation "Channel used to communicate attributes to `attribute-thread' -to compute asynchronously.") - (enable-marks-p nil :type boolean @@ -322,6 +265,18 @@ suggestions; they only set the `suggestion's once they are done. Conversely, `filter' is passed one `suggestion' at a time and it updates `suggestion's on each call.")) +(defmethod kernel ((source source)) + (if (prompter source) + (kernel (prompter source)) + (or (slot-value source 'kernel) + (setf (kernel source) + (lpara:make-kernel (cpu-count)))))) + +(defmacro with-kernel (holder &body body) + "Helper to to bind local kernel." + `(alex:when-let ((lpara:*kernel* (kernel ,holder))) + ,@body)) + (defun default-object-attributes (object) `(("Default" ,(princ-to-string object)))) @@ -329,8 +284,8 @@ call.")) (setf (slot-value source 'marks) value) (sera:and-let* ((action (alex:ensure-function (first (actions-on-marks source)))) (not (eq #'identity action))) - (run-thread "Prompter marks action thread" - (funcall action (marks source))))) + (with-kernel source + (lpara:future (funcall action (marks source)))))) (defmethod default-action-on-current-suggestion ((source prompter:source)) "Return the default action run on the newly selected suggestion. @@ -344,25 +299,32 @@ See `actions-on-current-suggestion'." (default-object-attributes object)) (:method :around ((object t) (source prompter:source)) (declare (ignorable source)) - (loop for pair in (call-next-method) - for key = (first pair) - for value = (second pair) - ;; NOTE: Duplicate keys are bad, because searching the alist by key - ;; will always return the first occurrence, and never the second. - when (member key keys :test #'string-equal) - do (warn "Duplicate attribute names found in ~a: ~a. + ;; TODO: New kernel to not overload the `prompter` threads busy with computing `update'? + (with-kernel source + (loop for attribute in (call-next-method) + for key = (first attribute) + for value = (second attribute) + ;; NOTE: Duplicate keys are bad, because searching the alist by key + ;; will always return the first occurrence, and never the second. + when (member key keys :test #'string-equal) + do (warn "Duplicate attribute names found in ~a: ~a. Attribute names should be unique for prompter to correctly filter those." - source key) - collect key into keys - ;; FIXME: Having six (string-t for keys and string-function-t for - ;; values) branches would be more correct, but does that matter enough - ;; to bother? - if (functionp value) - collect (list (princ-to-string key) value) - ;; REVIEW: Can keys actually be non-string? Maybe type those? - else if (and (stringp key) (stringp value)) - collect pair - else collect (list (princ-to-string key) (princ-to-string value)))) + source key) + collect key into keys + ;; FIXME: Having six (string-t for keys and string-function-t for + ;; values) branches would be more correct, but does that matter enough + ;; to bother? + if (functionp value) + collect (append (list (princ-to-string key) + (lpara:future + (handler-case (funcall (second attribute) object) + (error (c) + (format nil "keyword error: ~a" c))))) + (cddr attribute)) + ;; REVIEW: Can keys actually be non-string? Maybe type those? + else if (and (stringp key) (stringp value)) + collect attribute + else collect (append (list (princ-to-string key) (princ-to-string value)) (cddr attribute))))) (:method ((object hash-table) (source prompter:source)) (declare (ignorable source)) (let ((result)) @@ -399,9 +361,11 @@ Attribute names should be unique for prompter to correctly filter those." (nreverse result))) ((undotted-alist-p object) (mapcar (lambda (pair) - (list - (princ-to-string (first pair)) - (princ-to-string (second pair)))) + (append + (list + (princ-to-string (first pair)) + (princ-to-string (second pair))) + (cddr pair))) object)) ((alist-p object) (mapcar (lambda (pair) @@ -488,16 +452,48 @@ Suggestions are made with the `suggestion-maker' slot from `source'.")) :always (keywordp x)))) (defun object-attributes-p (object) - (undotted-alist-p object '(or string function))) + (and (listp object) + (every #'listp object) + (every #'listp (mapcar #'rest object)) + (every (lambda (e) (or (not (lpara:fulfilledp (first e))) + (typep (first e) '(or string function)))) + (mapcar #'rest object)))) -(defmethod attribute-key ((attribute t)) +(export-always 'attribute-key) +(define-generic attribute-key ((attribute t)) + "Return the attribute key." (first attribute)) -(defmethod attribute-value ((attribute t)) - (second attribute)) -(defmethod attributes-keys ((attributes t)) + +(export-always 'attribute-value) +(define-generic attribute-value ((attribute t) &key wait-p) + "Return value of ATTRIBUTE. +If WAIT-P, block until attribute is computed. +Otherwise return a `lparallel:future' it the attribute is not done calculating." + (if (or wait-p + (lpara:fulfilledp (second attribute))) + (lpara:force (second attribute)) + "")) + +(export-always 'attributes-keys) +(define-generic attributes-keys ((attributes t)) + "Return the list of ATTRIBUTES keys." (mapcar #'attribute-key attributes)) -(defmethod attributes-values ((attributes t)) - (mapcar #'attribute-value attributes)) + +(export-always 'attributes-values) +(define-generic attributes-values ((attributes t) &key wait-p) + "Return the list of ATTRIBUTES values. +See `attribute-value'." + (mapcar (lambda (a) (attribute-value a :wait-p wait-p)) attributes)) + +(export-always 'attribute-options) +(define-generic attribute-options ((attribute t)) + "Return the options of ATTRIBUTE, if any." + (cddr attribute)) + +(export-always 'attributes-options) +(define-generic attributes-options ((attributes t)) + "Return the options of ATTRIBUTE, if any." + (mapcar #'attribute-options attributes)) (defun ensure-string (object) "Return \"\" if OBJECT is not a string." @@ -604,43 +600,39 @@ If you are looking for a source that just returns its plain suggestions, use `so (:documentation "Prompt source for user input words.")) (export-always 'ensure-suggestions-list) -(defgeneric ensure-suggestions-list (source elements) - (:method ((source source) elements) - (lparallel:pmapcar +(define-generic ensure-suggestions-list ((source source) elements) + "Return ELEMENTS as a list of suggestions for use in SOURCE." + (with-kernel source + (lpara:pmapcar (lambda (suggestion-value) (if (suggestion-p suggestion-value) suggestion-value (funcall (suggestion-maker source) suggestion-value source))) - (uiop:ensure-list elements))) - (:documentation "Return ELEMENTS as a list of suggestions for use in SOURCE.")) + (uiop:ensure-list elements)))) (defmethod initialize-instance :after ((source source) &key) "See the `constructor' documentation of `source'." - (let ((wait-channel (make-channel))) - (run-thread "Prompter source init thread" - (bt:acquire-lock (initial-suggestions-lock source)) - ;; `initial-suggestions' initialization must be done before first input can be processed. - (etypecase (constructor source) - (list - (setf (slot-value source 'initial-suggestions) - (constructor source))) - (function - ;; Run constructor asynchronously. - (calispel:! wait-channel t) - (setf (slot-value source 'initial-suggestions) - (funcall (constructor source) source)))) - (setf (slot-value source 'initial-suggestions) - (ensure-suggestions-list source (initial-suggestions source))) - ;; TODO: Setting `suggestions' is not needed? - (setf (slot-value source 'suggestions) (initial-suggestions source)) - (bt:release-lock (initial-suggestions-lock source)) - (when (listp (constructor source)) - ;; Initial suggestions are set synchronously in this case. - (calispel:! wait-channel t))) - ;; Wait until above thread has acquired the `initial-suggestions-lock'. - (calispel:? wait-channel)) + (etypecase (constructor source) + (list + (setf (slot-value source 'initial-suggestions) (ensure-suggestions-list + source + (constructor source)) + ;; `suggestions' are in `update'. So if `update' hasn't run yet, the + ;; prompter would initially have no suggestion. It can be a problem + ;; if the preprocessor is slow, which is why we initialize + ;; `suggestions' here. + (slot-value source 'suggestions) (initial-suggestions source))) + (t ;; Async construction: + (with-kernel source + (setf (initial-suggestions-channel source) (lpara:make-channel)) + (lpara:submit-task (initial-suggestions-channel source) + (lambda () + (setf (slot-value source 'initial-suggestions) + (ensure-suggestions-list source + (funcall (constructor source) source))) + (setf (slot-value source 'suggestions) (initial-suggestions source))))))) (setf (actions-on-current-suggestion source) (uiop:ensure-list (or (actions-on-current-suggestion source) #'identity))) @@ -653,28 +645,24 @@ If you are looking for a source that just returns its plain suggestions, use `so source) (export-always 'attributes-keys-non-default) -(defgeneric attributes-keys-non-default (source) - (:method ((source source)) - (rest (attributes-keys source))) - (:documentation "Return SOURCE attributes except the default one.")) +(define-generic attributes-keys-non-default ((source source)) + "Return SOURCE attributes except the default one." + (rest (attributes-keys source))) (export-always 'attributes-keys-default) -(defgeneric attributes-keys-default (source) - (:method ((source source)) - (first (attributes-keys source))) - (:documentation "Return SOURCE default attribute as a non-dotted pair.")) +(define-generic attributes-keys-default ((source source)) + "Return SOURCE default attribute as a non-dotted pair." + (first (attributes-keys source))) (export-always 'attributes-default) -(defgeneric attributes-default (suggestion) - (:method ((suggestion suggestion)) - (second (first (attributes suggestion)))) - (:documentation "Return SUGGESTION default attribute value.")) +(define-generic attributes-default ((suggestion suggestion)) + "Return SUGGESTION default attribute value." + (attribute-value (first (attributes suggestion)))) (export-always 'attributes-non-default) -(defgeneric attributes-non-default (suggestion) - (:method ((suggestion suggestion)) - (rest (attributes suggestion))) - (:documentation "Return SUGGESTION non-default attributes.")) +(define-generic attributes-non-default ((suggestion suggestion)) + "Return SUGGESTION non-default attributes." + (rest (attributes suggestion))) (defmethod attributes-keys ((source source)) (attributes-keys @@ -682,12 +670,11 @@ If you are looking for a source that just returns its plain suggestions, use `so (attributes sugg) (default-object-attributes "")))) -(defgeneric active-attributes-keys (source) - (:method ((source source)) - (or (slot-value source 'active-attributes-keys) - (attributes-keys source))) - (:documentation "Return active attributes keys. -If the `active-attributes' slot is NIL, return all attributes keys.")) +(define-generic active-attributes-keys ((source source)) + "Return active attributes keys. +If the `active-attributes' slot is NIL, return all attributes keys." + (or (slot-value source 'active-attributes-keys) + (attributes-keys source))) (defmethod (setf active-attributes-keys) (value (source source)) "Set active attributes to the intersection of VALUE and SOURCE attributes." @@ -700,48 +687,19 @@ If the `active-attributes' slot is NIL, return all attributes keys.")) (apply #'remove-from-seq (attributes-keys-non-default source) value))))) (export-always 'active-attributes) -(defgeneric active-attributes (suggestion &key source &allow-other-keys) - (:method ((suggestion suggestion) - &key (source (error "Source required")) - &allow-other-keys) - (let ((inactive-keys (set-difference (attributes-keys (attributes suggestion)) - (active-attributes-keys source) - :test #'string=)) - (attribute-thread nil)) - (prog1 - (mapcar - (lambda (attribute) - (if (functionp (attribute-value attribute)) - (progn - (unless attribute-thread (setf attribute-thread (make-attribute-thread source))) - (calispel:! (attribute-channel source) (list suggestion attribute)) - (list (attribute-key attribute) "")) - attribute)) - (remove-if - (lambda (attr) - (find (attribute-key attr) inactive-keys :test #'string=)) - (attributes suggestion))) - (when attribute-thread - ;; Terminate thread: - (calispel:! (attribute-channel source) (list nil nil)))))) - (:documentation "Return the active attributes of SUGGESTION. -Active attributes are queried from SOURCE.")) - -(defun make-attribute-thread (source) - "Return a thread that is bound to SOURCE and used to compute its `suggestion' attributes asynchronously. -Asynchronous attributes have a string-returning function as a value." - ;; TODO: Notify when done updating, maybe using `update-notifier'? - (run-thread "Prompter attribute thread" - (sera:nlet lp ((sugg-attr-pair (calispel:? (attribute-channel source)))) - (destructuring-bind (sugg attr) sugg-attr-pair - ;; Recheck type here to protect against race conditions. - (when (functionp (attribute-value attr)) - (setf (alex:assoc-value (attributes sugg) (attribute-key attr)) - (list - (handler-case (funcall (attribute-value attr) (value sugg)) - (error (c) - (format nil "keyword error: ~a" c))))) - (lp (calispel:? (attribute-channel source)))))))) +(define-generic active-attributes ((suggestion suggestion) + &key (source (error "Source required")) + &allow-other-keys) + "Return the active attributes of SUGGESTION. +Active attributes are attributes whose keys are listed in the +`active-attributes-keys' slot of SOURCE." + (let ((inactive-keys (set-difference (attributes-keys (attributes suggestion)) + (active-attributes-keys source) + :test #'string=))) + (remove-if + (lambda (attr) + (find (attribute-key attr) inactive-keys :test #'string=)) + (attributes suggestion)))) (export-always 'marked-p) (defun marked-p (source value) @@ -768,19 +726,6 @@ non-nil." (subseq sequence item-pos))) (list item))) -(defun make-channel (&optional size) - "Return a channel of capacity SIZE. -If SIZE is NIL, capacity is infinite." - (cond - ((null size) - (make-instance 'calispel:channel - :buffer (make-instance 'jpl-queues:unbounded-fifo-queue))) - ((= 0 size) - (make-instance 'calispel:channel)) - ((< 0 size) - (make-instance 'calispel:channel - :buffer (make-instance 'jpl-queues:bounded-fifo-queue :capacity size))))) - (defun copy-object (object &rest slot-overrides) (let ((class-sym (class-name (class-of object)))) (apply #'make-instance class-sym @@ -790,18 +735,19 @@ If SIZE is NIL, capacity is infinite." (lambda (slot) (list (intern (symbol-name slot) "KEYWORD") (slot-value object slot))) - (mopu:slot-names class-sym)))))) - -(defgeneric destroy (source) - (:method ((source source)) - ;; Ignore errors in case thread is already terminated. - ;; REVIEW: Is there a cleaner way to do this? - (ignore-errors (bt:destroy-thread (update-thread source))) - (ignore-errors (bt:destroy-thread (attribute-thread source)))) - (:documentation "Clean up the source. -SOURCE should not be used once this has been run.")) - -(defun update (source input new-ready-channel) ; TODO: Store `input' in the source? + (slot-names class-sym)))))) + +(define-generic destroy ((source source)) + "Clean up the source. +SOURCE should not be used in a prompter once this has been run, but its +`suggestions' can still be accessed." + (maybe-funcall (destructor source) source) + (alex:when-let ((lpara:*kernel* (slot-value source 'kernel))) + (lpara:kill-tasks :default) + (lpara:end-kernel) + (setf (kernel source) nil))) + +(defun update (source input) ; TODO: Store `input' in the source? "Update SOURCE to narrow down the list of `suggestion's according to INPUT. If a previous `suggestion' computation was not finished, it is forcefully terminated. @@ -813,76 +759,71 @@ terminated. the last `suggestion' has been processed. - Last the `filter-postprocessor' is run the SOURCE and the INPUT. Its return value is assigned to the list of suggestions. -- Finally, `ready-notifier' is fired up. +- Finally, `ready-p' is set to T. The reason we filter in 3 stages is to allow both for asynchronous and synchronous filtering. The benefit of asynchronous filtering is that it sends feedback to the user while the list of suggestions is being computed." - (when (and (update-thread source) - ;; This is prone to a race condition, but worst case we destroy an - ;; already terminated thread. - (bt:thread-alive-p (update-thread source))) - ;; Note that we may be writing multiple times to this channel, but that's - ;; OK, only the first value is read, so worst case the caller sees that the - ;; source is terminated even though it just finished updating. - ;; TODO: Destroying threads breaks ECL. Use conditions instead to terminate - ;; threads properly. - (calispel:! (ready-channel source) nil) - (destroy source)) - (setf (ready-channel source) new-ready-channel) - (setf (update-thread source) - (run-thread "Prompter update thread" - (flet ((wait-for-initial-suggestions () - (bt:acquire-lock (initial-suggestions-lock source)) - (bt:release-lock (initial-suggestions-lock source))) - (preprocess (initial-suggestions-copy) - (if (filter-preprocessor source) - (ensure-suggestions-list - source - (funcall (filter-preprocessor source) - initial-suggestions-copy source input)) - initial-suggestions-copy)) - (process! (preprocessed-suggestions) - (let ((last-notification-time (get-internal-real-time))) - (setf (slot-value source 'suggestions) '()) - (if (or (str:empty? input) - (not (filter source))) - (setf (slot-value source 'suggestions) preprocessed-suggestions) - (dolist (suggestion preprocessed-suggestions) - (sera:and-let* ((processed-suggestion - (funcall (filter source) suggestion source input))) - (setf (slot-value source 'suggestions) - (insert-item-at suggestion (sort-predicate source) - (suggestions source))) - (let* ((now (get-internal-real-time)) - (duration (/ (- now last-notification-time) - internal-time-units-per-second))) - (when (or (> duration (notification-delay source)) - (= (length (slot-value source 'suggestions)) - (length preprocessed-suggestions))) - (calispel:! (update-notifier source) t) - (setf last-notification-time now)))))))) - (postprocess! () - (when (filter-postprocessor source) - (setf (slot-value source 'suggestions) - (ensure-suggestions-list - source - (maybe-funcall (filter-postprocessor source) - (slot-value source 'suggestions) - source - input)))))) - (unwind-protect - (progn - (setf (ready-p source) nil) - (wait-for-initial-suggestions) - (setf (last-input-downcase-p source) (current-input-downcase-p source)) - (setf (current-input-downcase-p source) (str:downcasep input)) - (process! - (preprocess - ;; We copy the list of initial-suggestions so that the - ;; preprocessor cannot modify them. - (mapcar #'copy-object (initial-suggestions source)))) - (postprocess!)) - (setf (ready-p source) t) - ;; Signal this source is done: - (calispel:! new-ready-channel source)))))) + (labels ((run-hook (source) + (lpara:future (funcall (update-hook (prompter source)) source))) + (wait-for-initial-suggestions () + (unless (or (initial-suggestions source) + (not (constructor source))) + (setf (slot-value source 'initial-suggestions) + (lpara:receive-result (initial-suggestions-channel source))))) + (preprocess (initial-suggestions-copy) + (if (filter-preprocessor source) + (ensure-suggestions-list + source + (funcall (filter-preprocessor source) + initial-suggestions-copy source input)) + initial-suggestions-copy)) + (process! (preprocessed-suggestions) + (let ((last-notification-time (get-internal-real-time))) + ;; `last-notification-time' is needed to check if + ;; `notification-delay' was exceeded, after which `update-notifier' + ;; is notified. + (setf (slot-value source 'suggestions) '()) + (if (or (str:empty? input) + (not (filter source))) + (setf (slot-value source 'suggestions) preprocessed-suggestions) + (dolist (suggestion preprocessed-suggestions) + (alex:when-let ((suggestion (funcall (filter source) suggestion source input))) + (setf (slot-value source 'suggestions) + (insert-item-at suggestion (sort-predicate source) + (suggestions source))) + (let* ((now (get-internal-real-time)) + (duration (/ (- now last-notification-time) + internal-time-units-per-second))) + (when (or (> duration (notification-delay source)) + (= (length (slot-value source 'suggestions)) + (length preprocessed-suggestions))) + (run-hook source) + (setf last-notification-time now)))))))) + (postprocess! () + (when (filter-postprocessor source) + (setf (slot-value source 'suggestions) + (ensure-suggestions-list + source + (maybe-funcall (filter-postprocessor source) + (slot-value source 'suggestions) + source + input)))))) + (unwind-protect + (progn + (setf (slot-value source 'ready-p) nil) + (wait-for-initial-suggestions) + (setf (last-input-downcase-p source) (current-input-downcase-p source)) + (setf (current-input-downcase-p source) (str:downcasep input)) + (run-hook source) + (process! + (preprocess + ;; We copy the list of initial-suggestions so that the + ;; preprocessor cannot modify them. + (mapcar #'copy-object (initial-suggestions source)))) + (postprocess!)) + (setf (slot-value source 'ready-p) t) + ;; Also run hook once SOURCE is ready, so that handlers can reliably check + ;; for `ready-p'. + (run-hook source))) + source) diff --git a/prompter.asd b/prompter.asd index ab8dd55..aa7429d 100644 --- a/prompter.asd +++ b/prompter.asd @@ -9,18 +9,19 @@ :version "0.1.0" :serial t :depends-on (alexandria - calispel cl-containers closer-mop lparallel moptilities nclasses + nhooks serapeum str trivial-package-local-nicknames) :components ((:file "package") (:file "filter-preprocessor") (:file "filter") + (:file "delayed-future") (:file "prompter-source") (:file "prompter")) :in-order-to ((test-op (test-op "prompter/tests") @@ -38,6 +39,7 @@ :serial t :pathname "tests/" :components ((:file "package") + (:file "delayed-future") (:file "tests") (:file "fuzzy") (:file "submatches"))) diff --git a/prompter.lisp b/prompter.lisp index 8c81433..7edf6b5 100644 --- a/prompter.lisp +++ b/prompter.lisp @@ -3,27 +3,6 @@ (in-package :prompter) -(define-class sync-queue () - ((ready-sources - '() - :type list - :export nil - :documentation "List of ready sources.") - (ready-channel - (make-channel nil) - :type calispel:channel - :export nil - :documentation "Communication channel with the `update' thread.") - (sync-interrupt-channel - (make-channel) - :type calispel:channel - :export nil - :documentation "This channel can be used to stop the queue listening.")) - (:predicate-name-transformer 'nclasses:always-dashed-predicate-name-transformer) - (:documentation "This object is used to memorize which sources are ready for a -given input. -A new object is created on every new input.")) - (defvar *default-history-size* 1000) ; TODO: Export? (declaim (ftype (function (&key (:size fixnum)) containers:ring-buffer-reverse) make-history)) @@ -32,6 +11,12 @@ A new object is created on every new input.")) (the (values cl-containers:ring-buffer-reverse &optional) (containers:make-ring-buffer size :last-in-first-out))) +(let ((count nil)) + (defun cpu-count () ; REVIEW: Not needed since Serapeum 2023-05-24. + (unless count + (setf count (or (serapeum:count-cpus) 1))) + count)) + ;; Eval at read-time because `make' is generated using the class' initargs. (sera:eval-always (define-class prompter () @@ -40,6 +25,22 @@ A new object is created on every new input.")) :accessor nil :reader input :documentation "User input.") + (input-delay + ;; Auto-repeat values on Xorg can be queried with + ;; xset q + ;; and set with + ;; xset r rate 240 50 + ;; A frequency of 50Hz means a delay of 0.020s between repeats. + ;; Defaults to 25 (0.040s). + 0.045 + :type float + :documentation "When input is changed, time after which the source is updated. +This is useful to avoid updating the sources during fast typing.") + (input-reader + nil + :export nil + :documentation "Thread that oversees input reading. +See `input-delay'.") (prompt "" @@ -98,23 +99,43 @@ automatically runs when the suggestions are narrowed down to just one item.") :documentation "History of inputs for the prompter. If nil, no history is used.") - (result-channel - (make-channel 1) - :type calispel:channel - :documentation "Channel to which the `current-suggestion' is sent on exit. -Caller should also listen to `interrupt-channel' to know if the prompter was cancelled.") + (result + (lpara:promise) + :accessor nil + :export t + :documentation "The `current-suggestion' returned on exit. Use the reader +to block until the prompter is returned. +Use `slot-value' to manipulate the low-level asynchronous structure; +beware the API may change. +Caller should handle the `prompter:canceled' condition.") + + (kernel + nil + :type (or null lpara:kernel) + :export nil + :documentation "Lparallel kernel for the current source calculation. +We use a new kernel for each update to avoid race conditions and useless waiting.") - (interrupt-channel - (make-channel 1) - :type calispel:channel - :documentation "Channel to which an arbitrary value is written on exit. -See also `result-channel'.") + (ready-sources + nil + :type (or null lpara.queue:queue) + :export nil) - (sync-queue + (source-updater nil - :type (or null sync-queue) :export nil - :documentation "See `sync-queue' class documentation.") + :documentation "Thread that oversees source updating.") + + (update-hook + (make-instance 'nhooks:hook-any) + :type nhooks:hook-any + :export t + :documentation "Hook run each time a change is seen in the prompter. +In particular, it is run when `filter' commits a change to `suggestion's after +`notification-delay' has passed. + +The handler are passed the source that saw a change. +The source object may have been `destroy'ed.") (returned-p nil @@ -131,21 +152,56 @@ Call `destroy' to the register termination functions of the prompter and its sources. `suggestion's are computed asynchronously when `input' is updated. -Use `all-ready-p' and `next-ready-p' to access whether the prompter is ready. +Use `all-ready-p' and `next-ready-p' to assess whether the prompter is ready. Sources' suggestions can be retrieved, possibly partially, even when the computation is not finished."))) -(defun update-sources (prompter &optional (text "")) - (setf (sync-queue prompter) (make-instance 'sync-queue)) - (mapc (lambda (source) (update source text (ready-channel (sync-queue prompter)))) - (sources prompter))) +(define-generic result ((prompter prompter)) + "Block and return PROMPTER's `result'." + (lpara:force (slot-value prompter 'result))) + +(defun update-sources (prompter) + ;; TODO: Add argment to bypass sleep? (May be useful on initialization.) + (sera:synchronized (prompter) + (when (or (not (input-reader prompter)) ; + (lpara:fulfilledp (input-reader prompter))) + (when (or (not (kernel prompter)) + (and (input-reader prompter) ; TODO: Move to initialization if we don't call `lpara:end-kernel' ? + (lpara:fulfilledp (input-reader prompter)) + (source-updater prompter) + (not (lpara:fulfilledp (source-updater prompter))))) + (with-kernel prompter + ;; Killing tasks is blocking and thus slow. + ;; Ending the kernel (with :WAIT NIL) is fast because it happens in a + ;; separate thread (the shutdown manager). + ;; TODO: What if the thread is hung? + (lpara:end-kernel)) + (setf (kernel prompter) (lpara:make-kernel + (cpu-count) + :name (format nil "prompter-~a-~a" + (let ((title (prompt prompter))) + (if (uiop:emptyp title) + "anonymous" + title)) + (gensym ""))))) + (setf (ready-sources prompter) (lpara.queue:make-queue)) + (with-kernel prompter + (setf (input-reader prompter) + (lpara:future + (sleep (input-delay prompter)) + (setf (source-updater prompter) + (lpara:future + (let ((text (slot-value prompter 'input))) + (prog1 (lpara:pmapcar + (lambda (source) + (update source text) + (lpara.queue:push-queue source (ready-sources prompter)) + source) + (sources prompter)) + (first-suggestion prompter))))))))))) (defmethod initialize-instance :after ((prompter prompter) &key sources &allow-other-keys) - (unless (stringp (prompt prompter)) - (setf (prompt prompter) (write-to-string (prompt prompter)))) - (unless (stringp (input prompter)) - (setf (input prompter) (write-to-string (input prompter)))) (flet ((ensure-sources (specifiers) (mapcar (lambda (source-specifier) (cond @@ -153,13 +209,19 @@ computation is not finished."))) source-specifier) ((and (symbolp source-specifier) (c2cl:subclassp source-specifier 'source)) - (make-instance source-specifier)) + (make-instance source-specifier :prompter prompter)) (t (error "Bad source specifier ~s." source-specifier)))) (uiop:ensure-list specifiers)))) (alex:appendf (sources prompter) (ensure-sources sources))) + (dolist (source (sources prompter)) + (setf (prompter source) prompter)) + (unless (stringp (prompt prompter)) + (setf (prompt prompter) (write-to-string (prompt prompter)))) + (unless (stringp (input prompter)) + (setf (input prompter) (write-to-string (input prompter)))) (first-suggestion prompter) (maybe-funcall (constructor prompter) prompter) - (update-sources prompter (input prompter)) + (update-sources prompter) prompter) (defmethod (setf current-suggestion) (value (prompter prompter)) @@ -178,7 +240,7 @@ computation is not finished."))) (suggestion (%current-suggestion prompter))) (let ((delay (actions-on-current-suggestion-delay source))) (if (plusp delay) - (run-thread "Prompter current suggestion action thread" + (lpara:future (sleep delay) (funcall action (value suggestion))) (funcall action (value suggestion)))))) @@ -196,27 +258,38 @@ See also `run-action-on-current-suggestion'.")) (export-always 'input) (defmethod (setf input) (text (prompter prompter)) - "Update PROMPTER sources and return TEXT." - (let ((old-input (slot-value prompter 'input))) - (unless (string= old-input text) - (setf (slot-value prompter 'input) text) - (update-sources prompter text) - (first-suggestion prompter))) + "Update PROMPTER sources and return TEXT. +This is non-blocking: the source update is done in parallel." + (unless (string= (slot-value prompter 'input) text) + (setf (slot-value prompter 'input) text) + (update-sources prompter)) text) +(export-always 'canceled) +(define-condition canceled (error) + () + (:documentation "Condition raised in the `result' listener when `destroy' is called.")) + (export-always 'destroy) (defmethod destroy ((prompter prompter)) "First call `before-destructor', then call all the source destructors, finally call `after-destructor'. -Signal destruction by sending a value to PROMPTER's `interrupt-channel'." +Signal destruction by transfering a `canceled' condition to the `result' listener." (maybe-funcall (before-destructor prompter)) - (mapc (lambda (source) (maybe-funcall (destructor source) prompter source)) - (sources prompter)) (mapc #'destroy (sources prompter)) (maybe-funcall (after-destructor prompter)) ;; TODO: Interrupt before or after destructor? - (calispel:! (sync-interrupt-channel (sync-queue prompter)) t) - (calispel:! (interrupt-channel prompter) t)) + (with-kernel prompter + (unless (lpara:fulfilledp (slot-value prompter 'result)) + (lpara:task-handler-bind ((error #'lpara:invoke-transfer-error)) + (lpara:fulfill (slot-value prompter 'result) + (lpara:chain (lpara:future (error 'canceled)))))) + ;; Wait for result, otherwise above future may not be ready before the + ;; kernel is killed. + (ignore-errors (lpara:force (slot-value prompter 'result))) + (lpara:kill-tasks :default) + (lpara:end-kernel)) ; TODO: Wait? + (setf (kernel prompter) nil)) (defun set-current-suggestion (prompter steps &key wrap-over-p) "Set PROMPTER's `current-suggestion' by jumping STEPS forward. @@ -416,14 +489,15 @@ If input is already in history, move to first position." (defun run-action-on-return (prompter &optional (action-on-return (default-action-on-return prompter))) "Call ACTION-ON-RETURN over `marks' and send the results to PROMPTER's -`result-channel'. +`result'. See `resolve-marks' for a reference on how `marks' are handled." (unless action-on-return (setf action-on-return #'identity)) (setf (returned-p prompter) t) (add-input-to-history prompter) (alex:when-let ((marks (resolve-marks prompter))) - (calispel:! (result-channel prompter) - (funcall action-on-return marks))) + ;; TODO: Wrap waiter in a function? + (lpara:fulfill (slot-value prompter 'result) + (funcall action-on-return marks))) (destroy prompter)) (export-always 'toggle-actions-on-current-suggestion-enabled) @@ -434,47 +508,44 @@ See `resolve-marks' for a reference on how `marks' are handled." (not (actions-on-current-suggestion-enabled-p source)))) (export-always 'next-ready-p) -(defun next-ready-p (prompter) +(defun next-ready-p (prompter &key (wait-p t)) "Block and return next PROMPTER ready source. It's the next source that's done updating. If all sources are done, return T. This is unblocked when the PROMPTER is `destroy'ed." (when prompter - ;; We let-bind `sync-queue' here so that it remains the same object throughout - ;; this function, since the slot is subject to be changed concurrently when - ;; the input is edited. - (alex:if-let ((sync-queue (sync-queue prompter))) - (if (= (length (ready-sources sync-queue)) - (length (sources prompter))) - t - (calispel:fair-alt - ((calispel:? (ready-channel sync-queue) next-source) - (cond - ((null next-source) - nil) - (t - (push next-source (ready-sources sync-queue)) - ;; Update current suggestion when update is done: - (first-suggestion prompter) - next-source))) - ((calispel:? (sync-interrupt-channel sync-queue)) - nil))) - ;; No sync-queue if no input was ever set. - t))) + (lpara:task-handler-bind ((lpara:task-killed-error (lambda (c) + (declare (ignore c)) + (return-from next-ready-p nil)))) + (cond + ((and (all-ready-p prompter :wait-p nil) + (lpara.queue:queue-empty-p (ready-sources prompter))) + t) + (wait-p + (lpara.queue:pop-queue (ready-sources prompter))) + (t + (lpara.queue:try-pop-queue (ready-sources prompter) + :timeout 0)))))) (export-always 'all-ready-p) -(defun all-ready-p (prompter) - "Return non-nil when all PROMPTER sources are ready." - (sera:nlet check ((next-source (next-ready-p prompter))) - (if (typep next-source 'boolean) - next-source - (check (next-ready-p prompter))))) +(defun all-ready-p (prompter &key (wait-p t)) + "Return non-nil when all PROMPTER sources are ready. +If WAIT-P, block until all sources are ready." + (or (null (kernel prompter)) + (null (input-reader prompter)) + (with-kernel prompter + (if wait-p + ;; TODO: Add `lpara:task-handler-bind' to catch destruction? + (and (lpara:force (input-reader prompter)) + (lpara:force (source-updater prompter))) + (and (lpara:fulfilledp (input-reader prompter)) + (lpara:fulfilledp (source-updater prompter))))))) (export-always 'make) (define-function make (append '(&rest args) `(&key sources ,@(public-initargs 'prompter))) - "Return `prompter' object. + "Return a new `prompter' object. The arguments are the initargs of the `prompter' class. As a special case, the `:sources' keyword argument not only accepts `source' diff --git a/tests/delayed-future.lisp b/tests/delayed-future.lisp new file mode 100644 index 0000000..61512e1 --- /dev/null +++ b/tests/delayed-future.lisp @@ -0,0 +1,25 @@ +;;;; SPDX-FileCopyrightText: Atlas Engineer LLC +;;;; SPDX-License-Identifier: BSD-3-Clause + +(in-package :prompter/tests) + +(define-test test-delayed-future () + (let ((lpara:*kernel* (lpara:make-kernel (prompter::cpu-count)))) + (let* ((df (make-instance 'prompter:delayed-future + :delay 0.1 + :fn #'identity)) + (f (lpara:future + (prompter:force df)))) + (prompter:fulfill df "a") + (sleep 0.01) + (prompter:fulfill df "b") + (sleep 0.02) + (prompter:fulfill df "c") + (sleep 0.03) + (prompter:fulfill df "d") + (sleep 0.12) + (let ((f2 (lpara:future (prompter:force df)))) + (prompter:fulfill df "e") + (sleep 0.1) + (assert-equal "d" (lpara:force f)) + (assert-equal "e" (lpara:force f2)))))) diff --git a/tests/fuzzy.lisp b/tests/fuzzy.lisp index b38509f..7e6fa5f 100644 --- a/tests/fuzzy.lisp +++ b/tests/fuzzy.lisp @@ -76,4 +76,5 @@ (match "foo" '("zzz" "FOO-BAR"))) ;; match regex meta-characters (assert-string= "http://[1:0:0:2::3:0.]/" - (match "[" '("test1" "http://[1:0:0:2::3:0.]/" "test2")))))) + (match "[" '("test1" "http://[1:0:0:2::3:0.]/" "test2")))) + (prompter:destroy source))) diff --git a/tests/package.lisp b/tests/package.lisp index 5bcd63f..c0a5a6e 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -6,5 +6,9 @@ (:import-from :nclasses #:define-class) (:import-from :prompter)) -(unless lparallel:*kernel* (setf lparallel:*kernel* - (lparallel:make-kernel (or (serapeum:count-cpus) 1)))) +(in-package prompter/tests) +(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) + (trivial-package-local-nicknames:add-package-local-nickname :lpara :lparallel) + (trivial-package-local-nicknames:add-package-local-nickname :lpara.queue :lparallel.queue)) diff --git a/tests/submatches.lisp b/tests/submatches.lisp index ca7eda6..6f31cbb 100644 --- a/tests/submatches.lisp +++ b/tests/submatches.lisp @@ -6,11 +6,13 @@ (define-test submatches-test () (flet ((submatch (input list) (let ((source (make-instance 'prompter:raw-source))) - (mapcar (lambda (suggestion) - (let ((res (prompter:submatches suggestion source input))) - (when res - (prompter:value res)))) - (prompter::ensure-suggestions-list source list))))) + (prog1 + (mapcar (lambda (suggestion) + (let ((res (prompter:submatches suggestion source input))) + (when res + (prompter:value res)))) + (prompter::ensure-suggestions-list source list)) + (prompter:destroy source))))) (assert-equal '(nil "category" nil) (submatch "cat" '("cstheory" "category" "candidate"))) (assert-equal '("care" nil nil) diff --git a/tests/tests.lisp b/tests/tests.lisp index 1d850fe..a3d3de9 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -3,10 +3,6 @@ (in-package :prompter/tests) -(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)) - (defun source1-suggestions (prompter) (mapcar #'prompter:value (prompter:suggestions (first (prompter:sources prompter))))) @@ -15,70 +11,39 @@ (mapcar #'prompter:value (alex:mappend #'prompter:suggestions (prompter:sources prompter)))) -(defun prompter-thread-p (thread) - (ignore-errors ; On ECL, thread-names may not be strings. - (str:starts-with-p "Prompter" (bt:thread-name thread)))) - -(defun all-live-prompter-threads () - (sera:filter (alex:conjoin #'prompter-thread-p #'bt:thread-alive-p) (bt:all-threads))) - -(defun join-thread* (thread) - "Like `bt:join-thread' but don't fail on already aborted threads." - ;; CCL's `join-thread' works with aborted threads, but SBCL emits a - ;; `join-thread-error' condition. - (handler-case (bt:join-thread thread) - #+sbcl - (sb-thread:join-thread-error () - nil))) - -#-ccl -(defmacro with-report-dangling-threads (&body body) - `(unwind-protect (progn ,@body) - (let ((remaining-threads (all-live-prompter-threads))) - ;; Time out should be correlated to the number of threads since it may - ;; take some time to destroy them on weak hardware. - (handler-case (bt:with-timeout ((* 2 (length remaining-threads))) - (mapc #'join-thread* remaining-threads)) - (t (c) - (error "Error when joining ~a: ~a" remaining-threads c)))) - ;; No dangling threads - (assert-false (all-live-prompter-threads)))) - -;; CCL randomly fails here. TODO: There may be a race condition. -#+ccl -(defmacro with-report-dangling-threads (&body body) - `(progn ,@body)) +(defmacro with-collected-prompter ((prompter-var definition) &body body) + `(let ((,prompter-var ,definition)) + (unwind-protect (progn ,@body) + (prompter:destroy ,prompter-var)))) (define-test prompter-init () - (with-report-dangling-threads - (let ((prompter (prompter:make :sources (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar"))))) - (when (prompter:all-ready-p prompter) - ;; Found suggestion in dummy prompter - (assert-true (find "foo" (prompter:suggestions - (first (prompter:sources prompter))) - :test #'string= - :key #'prompter:value)))))) + (with-collected-prompter (prompter (prompter:make :sources (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar")))) + (when (prompter:all-ready-p prompter) + ;; Found suggestion in dummy prompter + (assert-true (find "foo" (prompter:suggestions + (first (prompter:sources prompter))) + :test #'string= + :key #'prompter:value))))) (define-test prompter-matching () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar"))))) - (setf (prompter:input prompter) "foo") - (when (prompter:all-ready-p prompter) - (assert-equal '("foo") - (source1-suggestions prompter))) - (setf (prompter:input prompter) "bar") - (when (prompter:all-ready-p prompter) - (assert-equal '("bar") - (source1-suggestions prompter))) - (setf (prompter:input prompter) "") - (when (prompter:all-ready-p prompter) - (assert-equal '("foo" "bar") - (source1-suggestions prompter)))))) + (with-collected-prompter (prompter (prompter:make + :sources (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar")))) + (setf (prompter:input prompter) "foo") + (when (prompter:all-ready-p prompter) + (assert-equal '("foo") + (source1-suggestions prompter))) + (setf (prompter:input prompter) "bar") + (when (prompter:all-ready-p prompter) + (assert-equal '("bar") + (source1-suggestions prompter))) + (setf (prompter:input prompter) "") + (when (prompter:all-ready-p prompter) + (assert-equal '("foo" "bar") + (source1-suggestions prompter))))) (define-class url () ((url "") @@ -90,13 +55,12 @@ ("Title" ,(title url)))) (define-test multi-attribute-matching () - (with-report-dangling-threads - (let* ((url1 (make-instance 'url :url "http://example.org" :title "Example")) - (url2 (make-instance 'url :url "http://nyxt.atlas.engineer" :title "Nyxt homepage")) - (prompter (prompter:make - :sources (make-instance 'prompter:source - :name "Test source" - :constructor (list url1 url2))))) + (let* ((url1 (make-instance 'url :url "http://example.org" :title "Example")) + (url2 (make-instance 'url :url "http://nyxt.atlas.engineer" :title "Nyxt homepage"))) + (with-collected-prompter (prompter (prompter:make + :sources (make-instance 'prompter:source + :name "Test source" + :constructor (list url1 url2)))) (setf (prompter:input prompter) "nyxt") (when (prompter:all-ready-p prompter) (let ((filtered-suggestions (prompter:suggestions @@ -107,7 +71,7 @@ '("URL")) (assert-equal '("URL") (prompter:active-attributes-keys (prompter:current-source prompter))) - (assert-equal `(("URL" ,(url url2) )) + (assert-equal `(("URL" ,(url url2))) (prompter:active-attributes (prompter:%current-suggestion prompter) :source (prompter:current-source prompter)))))) @@ -120,62 +84,123 @@ suggestion) (define-test asynchronous-suggestion-computation () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar") - :filter #'slow-identity-match)))) - (setf (prompter:input prompter) "foo") - (when (prompter:all-ready-p prompter) - (let ((filtered-suggestions (prompter:suggestions - (first (prompter:sources prompter))))) - (assert-equal '("foo") - (mapcar #'prompter:value filtered-suggestions))))))) + (with-collected-prompter (prompter (prompter:make + :sources (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar") + :filter #'slow-identity-match))) + (setf (prompter:input prompter) "foo") + (when (prompter:all-ready-p prompter) + (let ((filtered-suggestions (prompter:suggestions + (first (prompter:sources prompter))))) + (assert-equal '("foo") + (mapcar #'prompter:value filtered-suggestions)))))) (define-test asynchronous-suggestion-notifications () - (with-report-dangling-threads - (let* ((suggestion-values '("foobar" "foobaz")) - (source (make-instance 'prompter:source - :name "Test source" - :constructor suggestion-values - :filter #'slow-identity-match)) - (prompter (prompter:make :sources source))) + (let* ((suggestion-values '("foobar" "foobaz")) + (source (make-instance 'prompter:source + :name "Test source" + :constructor suggestion-values + :filter #'slow-identity-match)) + (results (lparallel.queue:make-queue)) + (hook (make-instance + 'nhooks:hook-any + :handlers (list (make-instance 'nhooks:handler + :fn (lambda (source) (lpara.queue:push-queue (prompter:ready-p source) results)) + :name 'prompter-tester))))) + (with-collected-prompter (prompter (prompter:make :sources source + :update-hook hook)) (setf (prompter:input prompter) "foo") - (sera:nlet query-suggestions ((computed-count 1)) - (calispel:fair-alt - ((calispel:? (prompter::ready-channel source)) - (assert-eq (length suggestion-values) - (length (prompter:suggestions source)))) - ((calispel:? (prompter:update-notifier source)) - (assert-eq computed-count - (length (prompter:suggestions source))) - (query-suggestions (1+ computed-count)))))))) + (assert-equal '(nil nil t) (list + (lpara.queue:pop-queue results) + (lpara.queue:pop-queue results) + (lpara.queue:pop-queue results)))))) (define-test asynchronous-suggestion-interrupt () - (with-report-dangling-threads - (let* ((suggestion-values '("foobar" "foobaz")) - (source (make-instance 'prompter:source - :name "Test source" - :constructor suggestion-values - :filter #'slow-identity-match)) - (prompter (prompter:make :sources source))) + (let* ((suggestion-values '("foobar" "foobaz")) + (source (make-instance 'prompter:source + :name "Test source" + :constructor suggestion-values + :filter #'slow-identity-match))) + (with-collected-prompter (prompter (prompter:make :sources source)) (let ((before-input (get-internal-real-time))) (setf (prompter:input prompter) "foo") (setf (prompter:input prompter) "bar") (setf (prompter:input prompter) "baz") ;; Consecutive inputs happened fast enough (assert-equality #'< - 0.01 + 0.02 ; Slow ECL should be fine here even on a CI. (/ (- (get-internal-real-time) before-input) internal-time-units-per-second)) (prompter:all-ready-p prompter))))) +(define-test spam-input () + (let* ((suggestion-values '("foobar" "foobaz")) + (source (make-instance 'prompter:source + :name "Test source" + :constructor suggestion-values + ;; :filter #'slow-identity-match + ))) + (with-collected-prompter (prompter (prompter:make :sources source + :input-delay 0.005)) + (let ((inputs (mapcar (lambda (&rest _) + (declare (ignore _)) + (princ-to-string (random 100000))) + (alex:iota 100)))) + (prompter:all-ready-p prompter) + (let ((before-input (get-internal-real-time))) + (dolist (input inputs) + (setf (prompter:input prompter) input)) + ;; Consecutive inputs happened fast enough + (assert-equality #'< + 0.01 ; Slow ECL should be fine here even on a CI. + (/ (- (get-internal-real-time) before-input) + internal-time-units-per-second)) + (prompter:all-ready-p prompter)))))) + +(define-test spam-input2 () + (let* ((suggestion-values '("foobar" "foobaz")) + (source (make-instance 'prompter:source + :name "Test source" + :constructor suggestion-values + ;; :filter #'slow-identity-match + ))) + (with-collected-prompter (prompter (prompter:make :sources source + :input-delay 0.01)) + (let ((inputs (mapcar (lambda (&rest _) + (declare (ignore _)) + (princ-to-string (random 100000))) + (alex:iota 100)))) + (prompter:all-ready-p prompter) + (let ((before-input (get-internal-real-time))) + (dolist (input inputs) + (sleep 0.001) + (setf (prompter:input prompter) input)) + ;; Consecutive inputs happened fast enough + (assert-equality #'< + 0.01 ; Slow ECL should be fine here even on a CI. + (/ (- (get-internal-real-time) before-input) + internal-time-units-per-second)) + (prompter:all-ready-p prompter)))))) + +(define-test prompter-interrupt () + (let* ((suggestion-values '("foobar" "foobaz")) + (source (make-instance 'prompter:source + :name "Test source" + :constructor suggestion-values + :filter #'slow-identity-match))) + (let ((prompter (prompter:make :sources source))) + (setf (prompter:input prompter) "foo") + (bt:make-thread (lambda () + (sleep 0.5) + (prompter:destroy prompter))) + (assert-error 'prompter:canceled + (prompter:result prompter))))) + (define-test yes-no-prompt () - (with-report-dangling-threads - (let* ((source (make-instance 'prompter:yes-no-source - :constructor '("no" "yes"))) - (prompter (prompter:make :sources source))) + (let* ((source (make-instance 'prompter:yes-no-source + :constructor '("no" "yes")))) + (with-collected-prompter (prompter (prompter:make :sources source)) (assert-equal '("no" "yes") (mapcar #'prompter:value (prompter:suggestions (first (prompter:sources prompter))))) @@ -187,201 +212,194 @@ (mapcar #'prompter:value filtered-suggestions)))))) (define-test return-result () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar"))))) - (setf (prompter:input prompter) "bar") - (when (prompter:all-ready-p prompter) - (prompter:run-action-on-return prompter) - (assert-equal '("bar") - (calispel:? (prompter:result-channel prompter))))))) + (with-collected-prompter (prompter (prompter:make + :sources (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar")))) + (setf (prompter:input prompter) "bar") + (when (prompter:all-ready-p prompter) + (prompter:run-action-on-return prompter) + (assert-equal '("bar") + (prompter:result prompter))))) (define-test multi-sources () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (list (make-instance 'prompter:source - :name "Test source 1" - :constructor '("foo" "bar")) - (make-instance 'prompter:source - :name "Test source 2" - :constructor '("100 foo" "200")))))) - (setf (prompter:input prompter) "foo") - (when (prompter:all-ready-p prompter) - (assert-equal '("foo" "100 foo") - (all-source-suggestions prompter))) - (setf (prompter:input prompter) "200") - (let ((ready-source1 (prompter:next-ready-p prompter)) - (ready-source2 (prompter:next-ready-p prompter))) - ;; Found first ready source - (assert-true (find ready-source1 (prompter:sources prompter))) - ;; Found second ready source - (assert-true (find ready-source2 (prompter:sources prompter))) - ;; Ready sources are not the same - (assert-eq nil - (eq ready-source1 ready-source2)) - (assert-equal '("foo" "bar" "200") - (all-source-suggestions prompter)))))) + (with-collected-prompter (prompter (prompter:make + :sources (list (make-instance 'prompter:source + :name "Test source 1" + :constructor '("foo" "bar")) + (make-instance 'prompter:source + :name "Test source 2" + :constructor '("100 foo" "200"))))) + (setf (prompter:input prompter) "foo") + (when (prompter:all-ready-p prompter) + (assert-equal '("foo" "100 foo") + (all-source-suggestions prompter))) + (setf (prompter:input prompter) "200") + (let ((ready-source1 (prompter:next-ready-p prompter)) + (ready-source2 (prompter:next-ready-p prompter))) + ;; Found first ready source + (assert-true (find ready-source1 (prompter:sources prompter))) + ;; Found second ready source + (assert-true (find ready-source2 (prompter:sources prompter))) + ;; Ready sources are not the same + (assert-eq nil + (eq ready-source1 ready-source2)) + (assert-equal '("foo" "bar" "200") + (all-source-suggestions prompter))))) (define-test raw-source () - (with-report-dangling-threads - (let ((prompter (prompter:make :sources 'prompter:raw-source))) - (setf (prompter:input prompter) "foo") - (when (prompter:all-ready-p prompter) - (assert-equal '("foo") - (all-source-suggestions prompter)))) - (let ((prompter (prompter:make :input "foo" - :sources 'prompter:raw-source))) - (when (prompter:all-ready-p prompter) - (assert-equal '("foo") - (all-source-suggestions prompter)))))) + (with-collected-prompter (prompter (prompter:make :sources 'prompter:raw-source)) + (setf (prompter:input prompter) "foo") + (when (prompter:all-ready-p prompter) + (assert-equal '("foo") + (all-source-suggestions prompter)))) + (with-collected-prompter (prompter (prompter:make :input "foo" + :sources 'prompter:raw-source)) + (when (prompter:all-ready-p prompter) + (assert-equal '("foo") + (all-source-suggestions prompter))))) (define-test alist-plist-hash-source () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (list - (make-instance 'prompter:source - :name "Plist source" - :constructor '((:a 17 :b 18) - (:a "foo" :b "bar"))) - (make-instance 'prompter:source - :name "Alist source" - :constructor '(((key1 101) ("key2" 102)) - ((key1 "val1") ("key2" "val2")))) - (make-instance 'prompter:source - :name "Dotted alist source" - :constructor '(((key1 . 101) ("key2" . 102)) - ((key1 . "val1") ("key2" . "val2")))) - (make-instance 'prompter:source - :name "Hash table source" - :constructor (list (sera:dict :b 200 "a" 300 17 400) - (sera:dict :b 2000 "a" 3000 17 4000))))))) - (assert-eq 4 - (length (prompter:sources prompter))) - (assert-equal '(2 2 2 2) - (mapcar (lambda (s) (length (prompter:suggestions s))) (prompter:sources prompter))) - (assert-equal '((("A" "17") ("B" "18")) - (("A" "foo") ("B" "bar"))) - (mapcar #'prompter:attributes - (prompter:suggestions (first (prompter:sources prompter))))) - (assert-equal '((("KEY1" "101") ("key2" "102")) - (("KEY1" "val1") ("key2" "val2"))) - (mapcar #'prompter:attributes - (prompter:suggestions (second (prompter:sources prompter))))) - (assert-equal '((("KEY1" "101") ("key2" "102")) - (("KEY1" "val1") ("key2" "val2"))) - (mapcar #'prompter:attributes - (prompter:suggestions (third (prompter:sources prompter))))) - (assert-equal '((("17" "400") ("B" "200") ("a" "300")) - (("17" "4000") ("B" "2000") ("a" "3000"))) - (mapcar #'prompter:attributes - (prompter:suggestions (fourth (prompter:sources prompter))))) - (prompter:all-ready-p prompter)))) + (with-collected-prompter (prompter (prompter:make + :sources (list + (make-instance 'prompter:source + :name "Plist source" + :constructor '((:a 17 :b 18) + (:a "foo" :b "bar"))) + (make-instance 'prompter:source + :name "Alist source" + :constructor '(((key1 101) ("key2" 102)) + ((key1 "val1") ("key2" "val2")))) + (make-instance 'prompter:source + :name "Dotted alist source" + :constructor '(((key1 . 101) ("key2" . 102)) + ((key1 . "val1") ("key2" . "val2")))) + (make-instance 'prompter:source + :name "Hash table source" + :constructor (list (sera:dict :b 200 "a" 300 17 400) + (sera:dict :b 2000 "a" 3000 17 4000)))))) + (assert-eq 4 + (length (prompter:sources prompter))) + (assert-equal '(2 2 2 2) + (mapcar (lambda (s) (length (prompter:suggestions s))) (prompter:sources prompter))) + (assert-equal '((("A" "17") ("B" "18")) + (("A" "foo") ("B" "bar"))) + (mapcar #'prompter:attributes + (prompter:suggestions (first (prompter:sources prompter))))) + (assert-equal '((("KEY1" "101") ("key2" "102")) + (("KEY1" "val1") ("key2" "val2"))) + (mapcar #'prompter:attributes + (prompter:suggestions (second (prompter:sources prompter))))) + (assert-equal '((("KEY1" "101") ("key2" "102")) + (("KEY1" "val1") ("key2" "val2"))) + (mapcar #'prompter:attributes + (prompter:suggestions (third (prompter:sources prompter))))) + (assert-equal '((("17" "400") ("B" "200") ("a" "300")) + (("17" "4000") ("B" "2000") ("a" "3000"))) + (mapcar #'prompter:attributes + (prompter:suggestions (fourth (prompter:sources prompter))))) + (prompter:all-ready-p prompter))) (define-test history () - (with-report-dangling-threads - (let ((prompter (prompter:make :sources (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar"))))) - (flet ((history () - (containers:container->list (prompter:history prompter))) - (sync () - (prompter::add-input-to-history prompter))) - (setf (prompter:input prompter) "banana") - (sync) - (assert-equal '("banana") - (history)) - (setf (prompter:input prompter) "jackfruit") - (sync) - (assert-equal '("jackfruit" "banana") - (history)) - (assert-string= "jackfruit" - (containers:first-item (prompter:history prompter))) - (setf (prompter:input prompter) "banana") - (sync) - (assert-equal '("banana" "jackfruit") - (history)) - (prompter:all-ready-p prompter))))) + (with-collected-prompter (prompter (prompter:make :sources (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar")))) + (flet ((history () + (containers:container->list (prompter:history prompter))) + (sync () + (prompter::add-input-to-history prompter))) + (setf (prompter:input prompter) "banana") + (sync) + (assert-equal '("banana") + (history)) + (setf (prompter:input prompter) "jackfruit") + (sync) + (assert-equal '("jackfruit" "banana") + (history)) + (assert-string= "jackfruit" + (containers:first-item (prompter:history prompter))) + (setf (prompter:input prompter) "banana") + (sync) + (assert-equal '("banana" "jackfruit") + (history)) + (prompter:all-ready-p prompter)))) (define-test set-current-suggestion () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (list (make-instance 'prompter:source - :name "Test empty source") - (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar")) - (make-instance 'prompter:source - :name "Test empty source") - (make-instance 'prompter:source - :name "Test source 2" - :constructor '("100 foo" "200") - :filter-preprocessor #'prompter:filter-exact-matches) - (make-instance 'prompter:source - :name "Test empty source"))))) - (flet ((current-suggestion-value () - (prompter:value (prompter:%current-suggestion prompter)))) - (prompter:all-ready-p prompter) - (prompter:next-suggestion prompter) - (assert-string= "bar" - (current-suggestion-value)) - (prompter:next-suggestion prompter) - (assert-string= "100 foo" - (current-suggestion-value)) - (prompter:next-suggestion prompter) - (assert-string= "200" - (current-suggestion-value)) - (prompter:next-suggestion prompter) - (assert-string= "200" - (current-suggestion-value)) - (prompter:previous-suggestion prompter) - (assert-string= "100 foo" - (current-suggestion-value)) - (prompter:first-suggestion prompter) - (assert-string= "foo" - (current-suggestion-value)) - (prompter:previous-suggestion prompter) - (assert-string= "foo" - (current-suggestion-value)) - (prompter:last-suggestion prompter) - (assert-string= "200" - (current-suggestion-value)) - (prompter:previous-source prompter) - (assert-string= "foo" - (current-suggestion-value)) - (prompter:previous-source prompter) - (assert-string= "foo" - (current-suggestion-value)) - (prompter:next-source prompter) - (assert-string= "100 foo" - (current-suggestion-value)) - (prompter:next-source prompter) - (assert-string= "100 foo" - (current-suggestion-value)) + (with-collected-prompter (prompter (prompter:make + :sources (list (make-instance 'prompter:source + :name "Test empty source") + (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar")) + (make-instance 'prompter:source + :name "Test empty source") + (make-instance 'prompter:source + :name "Test source 2" + :constructor '("100 foo" "200") + :filter-preprocessor #'prompter:filter-exact-matches) + (make-instance 'prompter:source + :name "Test empty source")))) + (flet ((current-suggestion-value () + (prompter:value (prompter:%current-suggestion prompter)))) + (prompter:all-ready-p prompter) + (prompter:next-suggestion prompter) + (assert-string= "bar" + (current-suggestion-value)) + (prompter:next-suggestion prompter) + (assert-string= "100 foo" + (current-suggestion-value)) + (prompter:next-suggestion prompter) + (assert-string= "200" + (current-suggestion-value)) + (prompter:next-suggestion prompter) + (assert-string= "200" + (current-suggestion-value)) + (prompter:previous-suggestion prompter) + (assert-string= "100 foo" + (current-suggestion-value)) + (prompter:first-suggestion prompter) + (assert-string= "foo" + (current-suggestion-value)) + (prompter:previous-suggestion prompter) + (assert-string= "foo" + (current-suggestion-value)) + (prompter:last-suggestion prompter) + (assert-string= "200" + (current-suggestion-value)) + (prompter:previous-source prompter) + (assert-string= "foo" + (current-suggestion-value)) + (prompter:previous-source prompter) + (assert-string= "foo" + (current-suggestion-value)) + (prompter:next-source prompter) + (assert-string= "100 foo" + (current-suggestion-value)) + (prompter:next-source prompter) + (assert-string= "100 foo" + (current-suggestion-value)) - (setf (prompter:input prompter) "bar") - (prompter:all-ready-p prompter) - (assert-string= "bar" - (current-suggestion-value)) - (assert-equal '("bar") - (all-source-suggestions prompter)) - (prompter:next-suggestion prompter) - (assert-string= "bar" - (current-suggestion-value)) - (prompter:next-source prompter) - (assert-string= "bar" - (current-suggestion-value))) - (prompter:all-ready-p prompter)))) + (setf (prompter:input prompter) "bar") + (prompter:all-ready-p prompter) + (assert-string= "bar" + (current-suggestion-value)) + (assert-equal '("bar") + (all-source-suggestions prompter)) + (prompter:next-suggestion prompter) + (assert-string= "bar" + (current-suggestion-value)) + (prompter:next-source prompter) + (assert-string= "bar" + (current-suggestion-value))) + (prompter:all-ready-p prompter))) (define-test set-current-suggestion-all-empty-sources () - (with-report-dangling-threads - (let* ((first-empty-source (make-instance 'prompter:source - :name "Test empty source")) - (second-empty-source (make-instance 'prompter:source - :name "Test empty source")) - (prompter (prompter:make :sources (list first-empty-source - second-empty-source)))) + (let* ((first-empty-source (make-instance 'prompter:source + :name "Test empty source")) + (second-empty-source (make-instance 'prompter:source + :name "Test empty source"))) + (with-collected-prompter (prompter (prompter:make :sources (list first-empty-source + second-empty-source))) (prompter:all-ready-p prompter) (assert-eql (values nil first-empty-source) (prompter:%current-suggestion prompter)) @@ -426,73 +444,71 @@ (prompter:all-ready-p prompter)))) (define-test set-current-suggestion-with-steps () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (list (make-instance 'prompter:source - :name "Test empty source") - (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar")) - (make-instance 'prompter:source - :name "Test empty source") - (make-instance 'prompter:source - :name "Test source 2" - :constructor '("100 foo" "200") - :filter-preprocessor #'prompter:filter-exact-matches) - (make-instance 'prompter:source - :name "Test empty source"))))) - (flet ((current-suggestion-value () - (prompter:value (prompter:%current-suggestion prompter)))) - (prompter:all-ready-p prompter) - (prompter:next-suggestion prompter 2) - (assert-string= "100 foo" - (current-suggestion-value)) - (prompter:next-suggestion prompter -2) - (assert-string= "foo" - (current-suggestion-value)) - (prompter:next-suggestion prompter 99) - (assert-string= "200" - (current-suggestion-value))) - (prompter:all-ready-p prompter)))) + (with-collected-prompter (prompter (prompter:make + :sources (list (make-instance 'prompter:source + :name "Test empty source") + (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar")) + (make-instance 'prompter:source + :name "Test empty source") + (make-instance 'prompter:source + :name "Test source 2" + :constructor '("100 foo" "200") + :filter-preprocessor #'prompter:filter-exact-matches) + (make-instance 'prompter:source + :name "Test empty source")))) + (flet ((current-suggestion-value () + (prompter:value (prompter:%current-suggestion prompter)))) + (prompter:all-ready-p prompter) + (prompter:next-suggestion prompter 2) + (assert-string= "100 foo" + (current-suggestion-value)) + (prompter:next-suggestion prompter -2) + (assert-string= "foo" + (current-suggestion-value)) + (prompter:next-suggestion prompter 99) + (assert-string= "200" + (current-suggestion-value))) + (prompter:all-ready-p prompter))) (define-test set-current-suggestion-with-wrap-over () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (list (make-instance 'prompter:source - :name "Test empty source") - (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar")) - (make-instance 'prompter:source - :name "Test empty source") - (make-instance 'prompter:source - :name "Test source 2" - :constructor '("100 foo" "200") - :filter-preprocessor #'prompter:filter-exact-matches) - (make-instance 'prompter:source - :name "Test empty source"))))) - (flet ((current-suggestion-value () - (prompter:value (prompter:%current-suggestion prompter)))) - (prompter:all-ready-p prompter) - (prompter:last-suggestion prompter) - (assert-string= "200" - (current-suggestion-value)) - (prompter:next-suggestion prompter) - (assert-string= "200" - (current-suggestion-value)) - (prompter::set-current-suggestion prompter 1 :wrap-over-p t) - (assert-string= "foo" - (current-suggestion-value)) - (prompter::set-current-suggestion prompter -1 :wrap-over-p t) - (assert-string= "200" - (current-suggestion-value)) - (prompter::set-current-suggestion prompter 2 :wrap-over-p t) - (assert-string= "bar" - (current-suggestion-value)) - (prompter::set-current-suggestion prompter -3 :wrap-over-p t) - (assert-string= "100 foo" - (current-suggestion-value))) - (prompter:all-ready-p prompter)))) + (with-collected-prompter (prompter (prompter:make + :sources (list (make-instance 'prompter:source + :name "Test empty source") + (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar")) + (make-instance 'prompter:source + :name "Test empty source") + (make-instance 'prompter:source + :name "Test source 2" + :constructor '("100 foo" "200") + :filter-preprocessor #'prompter:filter-exact-matches) + (make-instance 'prompter:source + :name "Test empty source")))) + (flet ((current-suggestion-value () + (prompter:value (prompter:%current-suggestion prompter)))) + (prompter:all-ready-p prompter) + (prompter:last-suggestion prompter) + (assert-string= "200" + (current-suggestion-value)) + (prompter:next-suggestion prompter) + (assert-string= "200" + (current-suggestion-value)) + (prompter::set-current-suggestion prompter 1 :wrap-over-p t) + (assert-string= "foo" + (current-suggestion-value)) + (prompter::set-current-suggestion prompter -1 :wrap-over-p t) + (assert-string= "200" + (current-suggestion-value)) + (prompter::set-current-suggestion prompter 2 :wrap-over-p t) + (assert-string= "bar" + (current-suggestion-value)) + (prompter::set-current-suggestion prompter -3 :wrap-over-p t) + (assert-string= "100 foo" + (current-suggestion-value))) + (prompter:all-ready-p prompter))) (define-class buffer () ((title "") @@ -501,17 +517,16 @@ (defmethod prompter:object-attributes ((buffer buffer) (source prompter:source)) (declare (ignore source)) `(("Title" ,(title buffer)) - ("Keywords" ,(lambda (buffer) (sleep 1) (write-to-string (keywords buffer)))))) + ("Keywords" ,(lambda (buffer) (sleep 1) (write-to-string (keywords buffer))) :misc-option))) (define-test async-attribute-computation () - (with-report-dangling-threads - (let* ((buffer1 (make-instance 'buffer :title "buffer1" :keywords '("foo1" "bar1"))) - (buffer2 (make-instance 'buffer :title "buffer2" :keywords '("foo2" "bar2"))) - (prompter (prompter:make - :sources (make-instance 'prompter:source - :name "Test source" - :constructor (list buffer1 buffer2) - :active-attributes-keys '("Title"))))) + (let* ((buffer1 (make-instance 'buffer :title "buffer1" :keywords '("foo1" "bar1"))) + (buffer2 (make-instance 'buffer :title "buffer2" :keywords '("foo2" "bar2")))) + (with-collected-prompter (prompter (prompter:make + :sources (make-instance 'prompter:source + :name "Test source" + :constructor (list buffer1 buffer2) + :active-attributes-keys '("Title")))) (assert-equal `(("Title" ,(title buffer1))) (prompter:active-attributes (prompter:%current-suggestion prompter) @@ -519,29 +534,37 @@ (setf (prompter:active-attributes-keys (prompter:current-source prompter)) '("Title" "Keywords")) - (assert-string= "" - (first (alex:assoc-value (prompter:active-attributes - (prompter:%current-suggestion prompter) - :source (prompter:current-source prompter)) - "Keywords" :test 'equal))) - (sleep 2) - - (assert-equal `(("Title" ,(title buffer1)) - ("Keywords" ,(write-to-string (keywords buffer1)))) - (prompter:active-attributes - (prompter:%current-suggestion prompter) - :source (prompter:current-source prompter)))))) + (assert-false (typep + (first (alex:assoc-value (prompter:active-attributes + (prompter:%current-suggestion prompter) + :source (prompter:current-source prompter)) + "Keywords" :test 'equal)) + 'string)) + (assert-equal `(,(title buffer1) + ,(write-to-string (keywords buffer1))) + (prompter:attributes-values + (prompter:active-attributes + (prompter:%current-suggestion prompter) + :source (prompter:current-source prompter)) + :wait-p t)) + (assert-equal '(() + (:misc-option)) + (prompter:attributes-options + (prompter:active-attributes + (prompter:%current-suggestion prompter) + :source (prompter:current-source prompter))))))) (define-test error-handling () - (with-report-dangling-threads - (let ((prompter (prompter:make - :sources (make-instance 'prompter:source - :name "Test source" - :constructor '("foo" "bar") - :filter-postprocessor - (lambda (suggestions source input) - (declare (ignore suggestions source)) - (/ 1 input)))))) + (lpara:task-handler-bind ((error #'continue)) + (with-collected-prompter (prompter (prompter:make + :sources (make-instance 'prompter:source + :name "Test source" + :constructor '("foo" "bar") + :filter-postprocessor + (lambda (suggestions source input) + (declare (ignore source input)) + (cerror "dummy" "test should not stop here") + suggestions)))) (flet ((current-suggestion-value () (prompter:value (prompter:%current-suggestion prompter)))) (prompter:all-ready-p prompter)