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@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)))))))))