? colors.fasl
? esa-buffer.fasl
? esa-io.fasl
? esa.fasl
? packages.fasl
Index: esa.lisp
===================================================================
RCS file: /project/climacs/cvsroot/esa/esa.lisp,v
retrieving revision 1.12
diff -u -r1.12 esa.lisp
--- esa.lisp	4 May 2006 18:32:38 -0000	1.12
+++ esa.lisp	9 May 2006 17:02:24 -0000
@@ -70,6 +70,160 @@
      (parse-error ()
        nil))))
 
+(defmethod stream-accept ((pane minibuffer-pane) type &rest args
+                          &key (view (stream-default-view pane))
+                          &allow-other-keys)
+  ;; default CLIM prompting is OK for now...
+  (apply #'prompt-for-accept pane type view args)
+  ;; but we need to turn some of ACCEPT-1 off.
+  (apply #'accept-1-for-minibuffer pane type args))
+
+;;; simpler version of McCLIM's internal operators of the same names:
+;;; HANDLE-EMPTY-INPUT to make default processing work, EMPTY-INPUT-P
+;;; and INVOKE-HANDLE-EMPTY-INPUT to support it.  We don't support
+;;; recursive bouncing to see who most wants to handle the empty
+;;; input, but that's OK, because we are always conceptually one-level
+;;; deep in accept (even if sometimes we call ACCEPT recursively for
+;;; e.g. command-names and arguments).
+(defmacro handle-empty-input ((stream) input-form &body handler-forms)
+  "see climi::handle-empty-input"
+  (let ((input-cont (gensym "INPUT-CONT"))
+        (handler-cont (gensym "HANDLER-CONT")))
+    `(flet ((,input-cont ()
+	      ,input-form)
+	    (,handler-cont ()
+	      ,@handler-forms))
+       (declare (dynamic-extent #',input-cont #',handler-cont))
+       (invoke-handle-empty-input ,stream #',input-cont #',handler-cont))))
+
+;;; The code that signalled the error might have consumed the gesture, or
+;;; not.
+;;; XXX Actually, it would be a violation of the `accept' protocol to consume
+;;; the gesture, but who knows what random accept methods are doing.
+(defun empty-input-p
+    (stream begin-scan-pointer activation-gestures delimiter-gestures)
+  (let ((scan-pointer (stream-scan-pointer stream))
+	(fill-pointer (fill-pointer (stream-input-buffer stream))))
+    ;; activated?
+    (cond ((and (eql begin-scan-pointer scan-pointer)
+		(eql scan-pointer fill-pointer))
+	   t)
+	  ((or (eql begin-scan-pointer scan-pointer)
+	       (eql begin-scan-pointer (1- scan-pointer)))
+	   (let ((gesture 
+                  (aref (stream-input-buffer stream) begin-scan-pointer)))
+	     (and (characterp gesture)
+                  (flet ((gesture-matches-p (g)
+                           (if (characterp g)
+                               (char= gesture g)
+                               ;; FIXME: not quite portable --
+                               ;; apparently
+                               ;; EVENT-MATCHES-GESTURE-NAME-P need
+                               ;; not work on raw characters
+                               (event-matches-gesture-name-p gesture g))))
+                    (or (some #'gesture-matches-p activation-gestures)
+                        (some #'gesture-matches-p delimiter-gestures))))))
+	  (t nil))))
+
+(defun invoke-handle-empty-input
+    (stream input-continuation handler-continuation)
+  (unless (input-editing-stream-p stream)
+    (return-from invoke-handle-empty-input (funcall input-continuation)))
+  (let ((begin-scan-pointer (stream-scan-pointer stream))
+	(activation-gestures *activation-gestures*)
+	(delimiter-gestures *delimiter-gestures*))
+    (block empty-input
+      (handler-bind 
+          ((parse-error
+            #'(lambda (c)
+                (when (empty-input-p stream begin-scan-pointer 
+                                     activation-gestures delimiter-gestures)
+                  (return-from empty-input nil)))))
+	(return-from invoke-handle-empty-input (funcall input-continuation))))
+    (funcall handler-continuation)))
+
+(defun accept-1-for-minibuffer
+    (stream type &key
+     (view (stream-default-view stream))
+     (default nil defaultp) (default-type nil default-type-p)
+     provide-default insert-default (replace-input t)
+     history active-p prompt prompt-mode display-default
+     query-identifier (activation-gestures nil activationsp)
+     (additional-activation-gestures nil additional-activations-p)
+     (delimiter-gestures nil delimitersp)
+     (additional-delimiter-gestures nil  additional-delimiters-p))
+  (declare (ignore provide-default history active-p
+		   prompt prompt-mode
+		   display-default query-identifier))
+  (when (and defaultp (not default-type-p))
+    (error ":default specified without :default-type"))
+  (when (and activationsp additional-activations-p)
+    (error "only one of :activation-gestures or ~
+            :additional-activation-gestures may be passed to accept."))
+  (unless (or activationsp additional-activations-p *activation-gestures*)
+    (setq activation-gestures *standard-activation-gestures*))
+  (with-input-editing 
+      ;; this is the main change from CLIM:ACCEPT-1 -- no sensitizer.
+      (stream :input-sensitizer nil)
+    ;; KLUDGE: no call to CLIMI::WITH-INPUT-POSITION here, but that's
+    ;; OK because we are always going to create a new editing stream
+    ;; for each call to accept/accept-1-for-minibuffer, so the default
+    ;; default for the BUFFER-START argument to REPLACE-INPUT is
+    ;; right.
+    (when insert-default
+      ;; Insert the default value to the input stream. It should
+      ;; become fully keyboard-editable.
+      (presentation-replace-input 
+       stream default default-type view))
+    (with-input-context (type)
+        (object object-type event options)
+        (with-activation-gestures ((if additional-activations-p
+                                       additional-activation-gestures
+                                       activation-gestures)
+                                   :override activationsp)
+          (with-delimiter-gestures ((if additional-delimiters-p
+                                        additional-delimiter-gestures
+                                        delimiter-gestures)
+                                    :override delimitersp)
+            (let ((accept-results nil))
+              (climi::handle-empty-input (stream)
+                  (setq accept-results
+                        (multiple-value-list
+                         (if defaultp
+                             (funcall-presentation-generic-function
+                              accept type stream view
+                              :default default :default-type default-type)
+                             (funcall-presentation-generic-function
+                              accept type stream view))))
+                ;; User entered activation or delimiter gesture
+                ;; without any input.
+                (if defaultp
+                    (presentation-replace-input
+                     stream default default-type view :rescan nil)
+                    (simple-parse-error
+                     "Empty input for type ~S with no supplied default"
+                     type))
+                (setq accept-results (list default default-type)))
+              ;; Eat trailing activation gesture
+              ;; XXX what about pointer gestures?
+              ;; XXX and delimiter gestures?
+              ;;
+              ;; deleted check for *RECURSIVE-ACCEPT-P*
+              (let ((ag (read-char-no-hang stream nil stream t)))
+                (unless (or (null ag) (eq ag stream))
+                  (unless (activation-gesture-p ag)
+                    (unread-char ag stream))))
+              (values (car accept-results) 
+                      (if (cdr accept-results) (cadr accept-results) type)))))
+      ;; A presentation was clicked on, or something.
+      (t
+       (when (and replace-input 
+                  (getf options :echo t)
+                  (not (stream-rescanning-p stream)))
+         (presentation-replace-input 
+          stream object object-type view :rescan nil))
+       (values object object-type)))))
+
 (defun display-minibuffer (frame pane)
   (declare (ignore frame))
   (when (message pane)
@@ -286,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))))))
@@ -295,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)))))
@@ -313,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)
@@ -332,15 +494,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)
@@ -804,14 +1070,15 @@
 (define-command (com-call-last-kbd-macro
 		 :name t
 		 :command-table keyboard-macro-table)
-    ()
+    ((count 'integer))
   "Run the last keyboard macro that was defined.
 Use C-x ( to start and C-x ) to finish recording a keyboard macro."
   (setf (remaining-keys *application-frame*)
-	(recorded-keys *application-frame*))
+	(loop repeat count append (recorded-keys *application-frame*)))
   (setf (executingp *application-frame*) t))
 
-(set-key 'com-call-last-kbd-macro 'keyboard-macro-table '((#\x :control) #\e))
+(set-key `(com-call-last-kbd-macro ,*numeric-argument-marker*)
+         'keyboard-macro-table '((#\x :control) #\e))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
