Index: esa.lisp
===================================================================
RCS file: /project/climacs/cvsroot/esa/esa.lisp,v
retrieving revision 1.7
diff -u -r1.7 esa.lisp
--- esa.lisp	24 Apr 2006 19:52:56 -0000	1.7
+++ esa.lisp	26 Apr 2006 14:07:34 -0000
@@ -275,6 +275,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))))))
@@ -284,10 +290,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)))))
@@ -321,15 +327,119 @@
 ;;; 
 ;;; Top level
 
+(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)
+	(command-args 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-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)))
+          (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)
+  (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)))
+          (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)))))))))
+
 (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)
+                      ;; FIXME: maybe delete PROMPT from this argument
+                      ;; list?
+                      (prompt "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)
           (*pointer-documentation-output*
            (frame-pointer-documentation-output frame)))
       (unless (eq (frame-state frame) :enabled)
@@ -510,8 +620,9 @@
 (defgeneric gesture-name (gesture))
 
 (defmethod gesture-name ((char character))
-  (or (char-name char)
-      char))
+  (if (graphic-char-p char)
+      char
+      (char-name char)))
 
 (defun translate-name-and-modifiers (key-name modifiers)
   (with-output-to-string (s)
@@ -525,8 +636,7 @@
 	    when (plusp (logand modifier modifiers))
 	      do (princ name s))
       (princ (if (typep key-name 'character)
-		 (or (char-name key-name)
-		     key-name)
+                 (gesture-name key-name)
 		 key-name) s)))
 
 (defmethod gesture-name ((ev keyboard-event))
@@ -596,7 +706,10 @@
     results))
 
 (defun sort-by-name (list)
-  (sort list #'string< :key (lambda (item) (symbol-name (second item)))))
+  (sort list #'string< :key (lambda (item) 
+                              (symbol-name (if (listp (cdr item)) 
+                                               (cadr item) 
+                                               (cdr item))))))
 
 (defun sort-by-keystrokes (list)
   (sort list (lambda (a b)
@@ -614,10 +727,11 @@
 (defun describe-bindings (stream command-table
 			  &optional (sort-function #'sort-by-name))
   (formatting-table (stream)
-    (loop for (keys command)
+    (loop for (keys . command)
 	  in (funcall sort-function
 		      (find-all-keystrokes-and-commands-with-inheritance
 			   command-table))
+          when (consp command) do (setq command (car command))
 	  do (formatting-row (stream) 
 	       (formatting-cell (stream :align-x :right)
 		 (with-text-style (stream '(:sans-serif nil nil))
