[movitz-cvs] CVS update: movitz/losp/lib/readline.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Wed Nov 24 16:23:46 UTC 2004
Update of /project/movitz/cvsroot/movitz/losp/lib
In directory common-lisp.net:/tmp/cvs-serv26507
Modified Files:
readline.lisp
Log Message:
Add an option to signal a keypress-condition at each keypress.
Date: Wed Nov 24 17:23:45 2004
Author: ffjeld
Index: movitz/losp/lib/readline.lisp
diff -u movitz/losp/lib/readline.lisp:1.5 movitz/losp/lib/readline.lisp:1.6
--- movitz/losp/lib/readline.lisp:1.5 Thu Jul 29 18:20:18 2004
+++ movitz/losp/lib/readline.lisp Wed Nov 24 17:23:45 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Fri Nov 2 13:58:58 2001
;;;;
-;;;; $Id: readline.lisp,v 1.5 2004/07/29 16:20:18 ffjeld Exp $
+;;;; $Id: readline.lisp,v 1.6 2004/11/24 16:23:45 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -22,6 +22,9 @@
(:use #:muerte.cl #:muerte.lib)
(:export #:readline
#:readline-buffer
+ #:readline-keypress
+ #:readline-keypress-key
+ #:*readline-signal-keypresses*
#:make-readline-buffer
#:readline-buffer-string
#:readline-buffer-cursor-position
@@ -32,6 +35,8 @@
(in-package muerte.readline)
+(defvar *readline-signal-keypresses* nil)
+
(defun complete-symbol-name (string &key (start 0) (end (length string)) (collect-matches nil)
filter-matches (package *package*))
"=> completion (a symbol), completion-count completion-start completion-end completion-collection.
@@ -108,7 +113,12 @@
(cursor-end 0)
string)
-(defun readline (readline-buffer console &optional (terminator-keys '(#\newline)))
+(define-condition readline-keypress ()
+ ((key
+ :accessor readline-keypress-key
+ :initarg :key)))
+
+(defun readline (readline-buffer console &key (terminators '(#\newline)))
(with-accessors ((buffer readline-buffer-string)
(pos readline-buffer-cursor-position)
(end readline-buffer-cursor-end))
@@ -118,113 +128,98 @@
(write-string buffer t :end end)
(setf (cursor-x console) (+ cursor-origin pos)))
(loop with previous-key-was-tab-p = nil
+ with keypress-condition = (when *readline-signal-keypresses*
+ (make-condition 'readline-keypress))
and displayed-completions-p = nil
- as key = (read-char console)
- do (when (integerp key)
- (with-saved-excursion (console)
- (warn "key: ~S" key)))
-;;; do (setf key
-;;; (case key
-;;; (#\^k :kill)
-;;; (#\^y :yank)
-;;; (#\^p :previous)
-;;; (#\^n :next)
-;;; (t key)))
- do (unless (char= key #\tab)
- (setf previous-key-was-tab-p nil))
- when (member key terminator-keys)
- do (when displayed-completions-p
- (do ((y (1+ (cursor-y console)) (1+ y)))
- ((>= y (console-height console)))
- (clear-line console 0 y)))
- and return key
- do (case key
- (#\tab
- (when (plusp pos)
- (let ((token-pos pos))
- (do () ; move to start of token
- ((or (zerop token-pos)
- (member (char buffer (1- token-pos))
- '(#\space #\( #\) #\newline #\'))))
- (decf token-pos))
- (multiple-value-bind (completion completion-count completion-start
- completion-end completion-collection)
- (complete-symbol-name
- buffer
- :start token-pos
- :end pos
- :collect-matches previous-key-was-tab-p
- :filter-matches (if (and (< 0 token-pos)
- (char= #\( (char buffer (1- token-pos)))
- (not (and (< 1 token-pos)
- (char= #\( (char buffer (- token-pos 2))))))
- #'fboundp
- nil))
- ;; (warn "comp: ~S" completion-collection)
- ;; move tail string forward
- (when completion
- (let ((completion-length (- completion-end completion-start)))
- (incf end completion-length)
- (dotimes (i (- end pos completion-length))
- (setf (char buffer (- end i 1))
- (char buffer (- end i 1 completion-length))))
- ;; insert completion
- (loop for i from completion-start below completion-end
- do (write-char
- (setf (char buffer pos) (char-downcase (char (symbol-name completion) i))))
- do (incf pos))
- (let ((x (cursor-x console)))
- (write-string buffer t :start pos :end end)
- (setf (cursor-x console) x))))
- (when displayed-completions-p
- (do ((y (1+ (cursor-y console)) (1+ y)))
- ((>= y (console-height console)))
- (clear-line console 0 y))
- (setf displayed-completions-p nil))
- (when previous-key-was-tab-p
- (with-saved-excursion (console)
- (cond
- ((null completion-collection)
- (format t "~%No completions."))
- ((< completion-count 20)
- (format t "~%Completions:~{ ~A~}." completion-collection))
- (t (format t "~%~D completions!" completion-count))))
- (setf displayed-completions-p t)))))
- (setf previous-key-was-tab-p (not previous-key-was-tab-p)))
- ((:left #\^b)
- (unless (zerop pos)
- (decf pos)
- (decf (cursor-x console))))
- (#\^a
- (decf (cursor-x console) pos)
- (setf pos 0))
- ((:right #\^f)
- (when (< pos end)
- (incf pos)
- (incf (cursor-x console))))
- (#\^e
- (incf (cursor-x console) (- end pos))
- (setf pos end))
- ((:kill #\^k)
- (let ((x (cursor-x console)))
- (dotimes (i (- end pos))
- (write-char #\space))
- (setf (cursor-x console) x
- end pos)))
- ((#\delete #\^d)
- (when (< pos end)
- (dotimes (i (- end pos))
- (setf (char buffer (+ pos i))
- (char buffer (+ pos i 1))))
- (decf end)
+ as key = (muerte:read-key console)
+ do (with-saved-excursion (console)
+ (when keypress-condition
+ (setf (readline-keypress-key keypress-condition) key)
+ (with-simple-restart (continue "Proceed with interactive READLINE.")
+ (signal keypress-condition))))
+ (when (characterp key)
+ (unless (char= key #\tab)
+ (setf previous-key-was-tab-p nil))
+ (when (member key terminators)
+ (when displayed-completions-p
+ (do ((y (1+ (cursor-y console)) (1+ y)))
+ ((>= y (console-height console)))
+ (clear-line console 0 y)))
+ (return key))
+ (case key
+ (#\tab
+ (when (plusp pos)
+ (let ((token-pos pos))
+ (do () ; move to start of token
+ ((or (zerop token-pos)
+ (member (char buffer (1- token-pos))
+ '(#\space #\( #\) #\newline #\'))))
+ (decf token-pos))
+ (multiple-value-bind (completion completion-count completion-start
+ completion-end completion-collection)
+ (complete-symbol-name
+ buffer
+ :start token-pos
+ :end pos
+ :collect-matches previous-key-was-tab-p
+ :filter-matches (if (and (< 0 token-pos)
+ (char= #\( (char buffer (1- token-pos)))
+ (not (and (< 1 token-pos)
+ (char= #\( (char buffer (- token-pos 2))))))
+ #'fboundp
+ nil))
+ ;; (warn "comp: ~S" completion-collection)
+ ;; move tail string forward
+ (when completion
+ (let ((completion-length (- completion-end completion-start)))
+ (incf end completion-length)
+ (dotimes (i (- end pos completion-length))
+ (setf (char buffer (- end i 1))
+ (char buffer (- end i 1 completion-length))))
+ ;; insert completion
+ (loop for i from completion-start below completion-end
+ do (write-char
+ (setf (char buffer pos) (char-downcase (char (symbol-name completion) i))))
+ do (incf pos))
+ (let ((x (cursor-x console)))
+ (write-string buffer t :start pos :end end)
+ (setf (cursor-x console) x))))
+ (when displayed-completions-p
+ (do ((y (1+ (cursor-y console)) (1+ y)))
+ ((>= y (console-height console)))
+ (clear-line console 0 y))
+ (setf displayed-completions-p nil))
+ (when previous-key-was-tab-p
+ (with-saved-excursion (console)
+ (cond
+ ((null completion-collection)
+ (format t "~%No completions."))
+ ((< completion-count 20)
+ (format t "~%Completions:~{ ~A~}." completion-collection))
+ (t (format t "~%~D completions!" completion-count))))
+ (setf displayed-completions-p t)))))
+ (setf previous-key-was-tab-p (not previous-key-was-tab-p)))
+ ((:left #\^b)
+ (unless (zerop pos)
+ (decf pos)
+ (decf (cursor-x console))))
+ (#\^a
+ (decf (cursor-x console) pos)
+ (setf pos 0))
+ ((:right #\^f)
+ (when (< pos end)
+ (incf pos)
+ (incf (cursor-x console))))
+ (#\^e
+ (incf (cursor-x console) (- end pos))
+ (setf pos end))
+ ((:kill #\^k)
(let ((x (cursor-x console)))
- (write-string buffer t :start pos :end end)
- (write-char #\space)
- (setf (cursor-x console) x))))
- (#\backspace
- (unless (zerop pos)
- (decf pos)
- (decf (cursor-x console))
+ (dotimes (i (- end pos))
+ (write-char #\space))
+ (setf (cursor-x console) x
+ end pos)))
+ ((#\delete #\^d)
(when (< pos end)
(dotimes (i (- end pos))
(setf (char buffer (+ pos i))
@@ -233,19 +228,32 @@
(let ((x (cursor-x console)))
(write-string buffer t :start pos :end end)
(write-char #\space)
- (setf (cursor-x console) x)))))
- (t (when (and (characterp key)
- (< 1 (- (console-width console)
- (cursor-x console))))
- (dotimes (i (- end pos))
- (setf (char buffer (- end i))
- (char buffer (- end i 1))))
- (setf (char buffer pos) key)
- (incf end)
- (let ((x (cursor-x console)))
- (write-string buffer t :start pos :end end)
- (setf (cursor-x console) (1+ x)))
- (incf pos)))))))
+ (setf (cursor-x console) x))))
+ (#\backspace
+ (unless (zerop pos)
+ (decf pos)
+ (decf (cursor-x console))
+ (when (< pos end)
+ (dotimes (i (- end pos))
+ (setf (char buffer (+ pos i))
+ (char buffer (+ pos i 1))))
+ (decf end)
+ (let ((x (cursor-x console)))
+ (write-string buffer t :start pos :end end)
+ (write-char #\space)
+ (setf (cursor-x console) x)))))
+ (t (when (and (characterp key)
+ (< 1 (- (console-width console)
+ (cursor-x console))))
+ (dotimes (i (- end pos))
+ (setf (char buffer (- end i))
+ (char buffer (- end i 1))))
+ (setf (char buffer pos) key)
+ (incf end)
+ (let ((x (cursor-x console)))
+ (write-string buffer t :start pos :end end)
+ (setf (cursor-x console) (1+ x)))
+ (incf pos))))))))
(defstruct readline-context-state
scratch
@@ -299,8 +307,8 @@
as terminator =
(readline (replace-buffer scratch (aref buffers edit-buffer))
*standard-output*
- (append break-characters
- '(#\^c #\newline #\^p #\^n :up :down)))
+ :terminators (append break-characters
+ '(#\^c #\newline #\^p #\^n :up :down)))
do (when (or (eql #\^c terminator)
(member terminator break-characters))
(signal 'readline-break :character terminator))
@@ -333,7 +341,8 @@
((#\^n :down)
(replace-buffer (aref buffers edit-buffer) scratch)
(setf (cursor-x *standard-output*) cursor-origin
- edit-buffer (mod (1+ edit-buffer) (length buffers)))))))))
+ edit-buffer (mod (1+ edit-buffer) (length buffers))))
+ (t (warn "unknown terminator: ~S" terminator)))))))
More information about the Movitz-cvs
mailing list