stumpwm emacs style completion for colon command

emacs-esq-complete.lisp

(defun possible-potential-string-expansion (string expansion)
  "This takes a string and a possible expansion and checks to see if it could be, 
treating hyphens as delimiters between words. This attempts to emulate emacs. 
For example the string \"t-a-o\" would match any string whose first word begins
with t, second with a, and third with o."
  (let ((word-list-one (cl-ppcre:split "-" string))
	(word-list-two (cl-ppcre:split "-" expansion)))
    (when (<= (length word-list-one) (length word-list-two))
      (not (member :impossible (mapcar (lambda (w1 w2)
					 (if (uiop:string-prefix-p w1 w2)
					     :possible
					     :impossible))
				       word-list-one
				       word-list-two))))))

(defun emacs-style-complete (string completions)
  "this function takes a string to complete and a list of possible completions. 
These completions are looped over to see which are a candidate, returning those 
that are."
  (loop for completion in completions
	when (possible-potential-string-expansion string completion)
	  collect completion))

(defun get-completion-preview-list (input-line all-completions)
  (if (string= "" input-line)
      '()
      (multiple-value-bind (completions more)
          (take *maximum-completions*
                (remove-duplicates
		 (remove-if
		  (lambda (str)
		    (or (string= str "")
			(< (length str) (length input-line))
			(not (possible-potential-string-expansion input-line str))))
		  all-completions)
		 :test #'string=))
	(if more
            (append (butlast completions)
                    (list (format nil "... and ~D more" (1+ (length more)))))
            completions))))

(defun call-interactively (command &optional (input ""))
  "Parse the command's arguments from input given the command's
argument specifications then execute it. Returns a string or nil if
user aborted."
  (declare (type (or string symbol) command)
           (type (or string argument-line) input))
  ;; Catch parse errors
  (catch 'error
    (let* ((arg-line (if (stringp input)
                         (make-argument-line :string input
                                             :start 0)
                         input))
           (cmd-data (or (get-command-structure command)
			 (throw 'error
			   (format nil "Command '~a' not found." command))))
           (arg-specs (command-args cmd-data))
           (args (loop for spec in arg-specs
		       collect (let* ((type (if (listp spec)
						(first spec)
						spec))
				      (prompt (when (listp spec)
						(second spec)))
				      (fn (gethash type *command-type-hash*)))
				 (unless fn
				   (throw 'error (format nil "Bad argument type: ~s" type)))
				 ;; If the prompt is NIL then it's
				 ;; considered an optional argument and
				 ;; we shouldn't prompt for it if the
				 ;; arg line is empty.
				 (if (and (null prompt)
					  (argument-line-end-p arg-line))
				     (loop-finish)
				     (funcall fn arg-line prompt))))))
      ;; Did the whole string get parsed?
      (unless (or (argument-line-end-p arg-line)
                  (position-if 'alphanumericp (argument-line-string arg-line) :start (argument-line-start arg-line)))
        (throw 'error (format nil "Trailing garbage: ~{~A~^ ~}" (subseq (argument-line-string arg-line)
                                                                        (argument-line-start arg-line)))))
      ;; Success
      (prog1
          (apply (command-name cmd-data) args)
        (setf *last-command* command)))))

(defun eval-command (cmd &optional interactivep)
  "exec cmd and echo the result."
  (labels ((parse-and-run-command (input)
             (let* ((arg-line (make-argument-line :string input
                                                  :start 0))
                    (cmd (argument-pop arg-line)))
               (let ((*interactivep* interactivep))
                 (call-interactively cmd arg-line)))))
    (multiple-value-bind (result error-p)
        ;; this fancy footwork lets us grab the backtrace from where the
        ;; error actually happened.
        (restart-case
            (handler-bind
                ((error (lambda (c)
			  (invoke-restart 'eval-command-error
					  (format nil "^B^1*Error In Command '^b~a^B': ^n~A~a"
						  cmd c (if *show-command-backtrace*
							    (backtrace-string) ""))))))
              (parse-and-run-command cmd))
          (eval-command-error (err-text)
            :interactive (lambda () nil)
            (values err-text t)))
      ;; interactive commands update the modeline
      (update-all-mode-lines)
      (cond ((stringp result)
             (if error-p
                 (message-no-timeout "~a" result)
                 (message "~a" result)))
            ((eq result :abort)
             (unless *suppress-abort-messages*
               (message "Abort.")))))))

(defun input-insert-space (input key)
  (declare (ignore key))
  (let ((char (xlib:keysym->character *display* (key-keysym (kbd "SPC")))))
    (if (or (not (characterp char)) (null char))
	:error
	(input-insert-char input char))))

(defun input-complete-and-submit (input key)
  (declare (ignore key))
  (let ((c (emacs-style-complete (input-line-string input) (all-commands))))
    (when (= 1 (length c))
      (input-replace-line input (car c)))
    :done))

(defun input-replace-line (input new)
  (let ((replace-with (if (listp new) (coerce new 'string) new)))
    (setf (input-line-position input) 0) ; set position to kill from
    (input-kill-line input nil)
    (loop for c across replace-with
	  do (input-insert-char input c))))

(let (toggle)
  (defun input-insert-hyphen-or-space (input key &optional reset-toggle)
    (declare (ignore key))
    (if reset-toggle
	(setf toggle nil)
	(let ((completion
		(emacs-style-complete (input-line-string input) (all-commands))))
	  (if (and (= 1 (length completion)))
	      (progn
		(input-replace-line input (car completion))
		(input-insert-char input #\space)
		(setf toggle t))
	      (let ((char (if toggle #\space #\-)
			  ;; (xlib:keysym->character *display*
			  ;; 			  (key-keysym (if toggle (kbd "SPC")
			  ;; 					  (kbd "-"))))
			  ))
		(if (or (not (characterp char)) (null char))
		    :error
		    (input-insert-char input char))))))))

(defcommand colon (&optional initial-input) (:rest)
  "Read a command from the user. @var{initial-text} is optional. When
supplied, the text will appear in the prompt.

String arguments with spaces may be passed to the command by
delimiting them with double quotes. A backslash can be used to escape
double quotes or backslashes inside the string. This does not apply to
commands taking :REST or :SHELL type arguments."
  (input-insert-hyphen-or-space nil nil t) ; reset our hyphen thing... this is ugly. 
  (let ((*input-map* (copy-structure *input-map*)))
    (define-key *input-map* (kbd "SPC") 'input-insert-hyphen-or-space)
    (define-key *input-map* (kbd "M-SPC") 'input-insert-space)
    (define-key *input-map* (kbd "RET") 'input-complete-and-submit)
    (let ((cmd (completing-read (current-screen) ": " (all-commands) :initial-input (or initial-input ""))))
      (unless cmd
	(throw 'error :abort))
      (when (plusp (length cmd))
	(eval-command cmd t)))))