[climacs-cvs] CVS esa
crhodes
crhodes at common-lisp.net
Wed May 10 09:52:05 UTC 2006
Update of /project/climacs/cvsroot/esa
In directory clnet:/tmp/cvs-serv31073
Modified Files:
esa.asd esa.lisp packages.lisp
Added Files:
esa-command-parser.lisp
Log Message:
New command parser.
Make it the default for frames running esa-top-level.
Use the prompt argument to esa-top-level to determing
com-extended-command's prompt.
export esa:esa-command-parser and esa:esa-partial-command-parser.
rewrite some other bits of the top-level loop to use the partial command
parser where appropriate.
--- /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:38:57 1.4
+++ /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:52:05 1.5
@@ -4,4 +4,5 @@
(:file "colors" :depends-on ("packages"))
(:file "esa" :depends-on ("colors" "packages"))
(:file "esa-buffer" :depends-on ("packages" "esa"))
- (:file "esa-io" :depends-on ("packages" "esa"))))
+ (:file "esa-io" :depends-on ("packages" "esa"))
+ (:file "esa-command-parser" :depends-on ("packages" "esa"))))
--- /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:41:42 1.14
+++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:52:05 1.15
@@ -440,6 +440,12 @@
(setf command (list command)))
(setf command (substitute-numeric-argument-marker command numarg))
(setf command (substitute-numeric-argument-p command numargp))
+ (when (member *unsupplied-argument-marker* command :test #'eq)
+ (setq command
+ (funcall
+ *partial-command-parser*
+ (frame-command-table frame)
+ (frame-standard-input frame) command 0)))
(execute-frame-command frame command)
(return)))
(t nil))))))
@@ -449,10 +455,10 @@
(let ((command (command-menu-item-value object)))
(unless (listp command)
(setq command (list command)))
- (when (and (typep (frame-standard-input frame) 'interactor-pane)
- (member *unsupplied-argument-marker* command :test #'eq))
+ (when (member *unsupplied-argument-marker* command :test #'eq)
(setq command
- (command-line-read-remaining-arguments-for-partial-command
+ (funcall
+ *partial-command-parser*
(frame-command-table frame) (frame-standard-input frame)
command 0)))
(execute-frame-command frame command)))))
@@ -467,6 +473,8 @@
;; FIXME: I'm not sure that we want to do this for commands sent
;; from other threads; we almost certainly don't want to do it twice
;; in such cases...
+ ;;
+ ;; FIXME: also, um, throwing away the arguments is likely to be bad.
(setf (previous-command (car (windows frame)))
(if (consp command)
(car command)
@@ -486,15 +494,26 @@
;;;
;;; Top level
+(defvar *extended-command-prompt*)
+
(defun esa-top-level (frame &key
- command-parser command-unparser
- partial-command-parser prompt)
- (declare (ignore command-parser command-unparser partial-command-parser prompt))
+ (command-parser 'esa-command-parser)
+ ;; FIXME: maybe customize this? Under what
+ ;; circumstances would it be used? Maybe try
+ ;; turning the clim listener into an ESA?
+ (command-unparser 'command-line-command-unparser)
+ (partial-command-parser 'esa-partial-command-parser)
+ (prompt "Extended Command: "))
+ (declare (ignore prompt))
(with-slots (windows) frame
(let ((*standard-output* (car windows))
(*standard-input* (frame-standard-input frame))
(*print-pretty* nil)
(*abort-gestures* `((:keyboard #\g ,(make-modifier-state :control))))
+ (*command-parser* command-parser)
+ (*command-unparser* command-unparser)
+ (*partial-command-parser* partial-command-parser)
+ (*extended-command-prompt* prompt)
(*pointer-documentation-output*
(frame-pointer-documentation-output frame)))
(unless (eq (frame-state frame) :enabled)
@@ -632,23 +651,25 @@
(set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control)))
(define-command (com-extended-command
+ ;; FIXME: I don't think it makes any sense for
+ ;; Extended Command to be named.
:name t
:command-table global-esa-table)
()
"Prompt for a command name and arguments, then run it."
(let ((item (handler-case
- (accept
- `(command :command-table ,(find-applicable-command-table *application-frame*))
- :prompt "Extended Command")
- ((or command-not-accessible command-not-present) ()
- (beep)
+ (accept
+ `(command :command-table ,(find-applicable-command-table *application-frame*))
+ ;; this gets erased immediately anyway
+ :prompt "" :prompt-mode :raw)
+ ((or command-not-accessible command-not-present) ()
+ (beep)
(display-message "No such command")
(return-from com-extended-command nil)))))
(execute-frame-command *application-frame* item)))
(set-key 'com-extended-command 'global-esa-table '((#\x :meta)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Help
--- /project/climacs/cvsroot/esa/packages.lisp 2006/05/02 18:01:49 1.3
+++ /project/climacs/cvsroot/esa/packages.lisp 2006/05/10 09:52:05 1.4
@@ -13,7 +13,9 @@
#:describe-command-to-stream
#:gesture-name
#:set-key
- #:find-applicable-command-table))
+ #:find-applicable-command-table
+ #:esa-command-parser
+ #:esa-partial-command-parser))
(defpackage :esa-buffer
(:use :clim-lisp :clim :esa)
--- /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/10 09:52:05 NONE
+++ /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/10 09:52:05 1.1
;;; -*- Mode: Lisp; Package: ESA -*-
;;; (c) copyright 2006 by
;;; Christophe Rhodes (c.rhodes at gold.ac.uk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :esa)
(defun esa-parse-one-arg (stream name ptype accept-args
&optional (default *unsupplied-argument-marker*))
(declare (ignore name))
;; this conditional doesn't feel entirely happy. The issue is that
;; we could be called either recursively from an outer call to
;; (accept 'command), in which case we want our inner accept to
;; occur on the minibuffer stream not the input-editing-stream, or
;; from the toplevel when handed a partial command. Maybe the
;; toplevel should establish an input editing context for partial
;; commands anyway? Then ESA-PARSE-ONE-ARG would always be called
;; with an input-editing-stream.
(let ((stream (if (encapsulating-stream-p stream)
(encapsulating-stream-stream stream)
stream)))
(apply #'accept (eval ptype)
:stream stream
(append
(unless (eq default *unsupplied-argument-marker*)
;; adjust to taste.
`(:default ,default :insert-default nil :display-default t))
;; This is fucking nuts. FIXME: the clim spec says
;; ":GESTURE is not evaluated at all". Um, but how are
;; you meant to tell if a keyword argument is :GESTURE,
;; then? The following does not actually allow variable
;; keys: anyone who writes (DEFINE-COMMAND FOO ((BAR
;; 'PATHNAME *RANDOM-ARG* ""))) and expects it to work
;; deserves to lose.
;;
;; FIXME: this will do the wrong thing on malformed accept
;; arguments, such improper lists or those with an odd
;; number of keyword arguments. I doubt that
;; DEFINE-COMMAND is checking the syntax, so we probably
;; should.
(loop for (key val) on accept-args by #'cddr
unless (eq key :gesture)
collect key and collect (eval val))))))
(defun esa-command-parser (command-table stream)
(let ((command-name nil))
(flet ((maybe-clear-input ()
(let ((gesture (read-gesture :stream stream
:peek-p t :timeout 0)))
(when (and gesture (or (delimiter-gesture-p gesture)
(activation-gesture-p gesture)))
(read-gesture :stream stream)))))
(with-delimiter-gestures (*command-name-delimiters* :override t)
;; While reading the command name we want use the history of
;; the (accept 'command ...) that's calling this function.
;;
;; FIXME: does this :history nil actually achieve the above?
(setq command-name (accept `(command-name :command-table ,command-table)
:stream (encapsulating-stream-stream stream)
:prompt *extended-command-prompt*
:prompt-mode :raw :history nil))
(maybe-clear-input))
(with-delimiter-gestures (*command-argument-delimiters* :override t)
;; FIXME, except we can't: use of CLIM-INTERNALS.
(let* ((info (gethash command-name climi::*command-parser-table*))
(required-args (climi::required-args info))
(keyword-args (climi::keyword-args info)))
(declare (ignore keyword-args))
(let (result)
;; only required args for now.
(dolist (arg required-args (cons command-name (nreverse result)))
(destructuring-bind (name ptype &rest args) arg
(push (esa-parse-one-arg stream name ptype args) result)
(maybe-clear-input)))))))))
(defun esa-partial-command-parser (command-table stream command position)
(declare (ignore command-table position))
(let ((command-name (car command))
(command-args (cdr command)))
(flet ((maybe-clear-input ()
(let ((gesture (read-gesture :stream stream
:peek-p t :timeout 0)))
(when (and gesture (or (delimiter-gesture-p gesture)
(activation-gesture-p gesture)))
(read-gesture :stream stream)))))
(with-delimiter-gestures (*command-argument-delimiters* :override t)
;; FIXME, except we can't: use of CLIM-INTERNALS.
(let* ((info (gethash command-name climi::*command-parser-table*))
(required-args (climi::required-args info))
(keyword-args (climi::keyword-args info)))
;; keyword arguments not yet supported
(declare (ignore keyword-args))
(let (result)
;; only required args for now.
(do ((required-args required-args (cdr required-args))
(arg (car required-args) (car required-args))
(command-args command-args (cdr command-args))
(command-arg (car command-args) (car command-args)))
((null required-args) (cons command-name (nreverse result)))
(destructuring-bind (name ptype &rest args) arg
(push (esa-parse-one-arg stream name ptype args command-arg)
result)
(maybe-clear-input)))))))))
More information about the Climacs-cvs
mailing list