/[mcclim]/mcclim/frames.lisp
ViewVC logotype

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65 - (show annotations)
Mon Jul 14 19:41:44 2003 UTC (10 years, 9 months ago) by hefner1
Branch: MAIN
Changes since 1.64: +2 -0 lines
Reworking of input focus handling - track keyboard focus per-frame rather
than per-port, and set appropriate WM hint/protocol to implement what the
ICCCM defines as "Locally Active" focus.

port-keyboard-input-focus is still around, but now changes the frame input
focus through clim:*application-frame*. This makes multiple application
frames play nice with each other.

You can also now move the pointer out of the window and still type to it, if
your WM allows that sort of thing.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6 ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8
9 ;;; This library is free software; you can redistribute it and/or
10 ;;; modify it under the terms of the GNU Library General Public
11 ;;; License as published by the Free Software Foundation; either
12 ;;; version 2 of the License, or (at your option) any later version.
13 ;;;
14 ;;; This library is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;;; Library General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU Library General Public
20 ;;; License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;;; Boston, MA 02111-1307 USA.
23
24 (in-package :clim-internals)
25
26 ;; *application-frame* is in decls.lisp
27 (defvar *default-frame-manager* nil)
28
29 ;;; Frame-Manager class
30
31 (define-protocol-class frame-manager ()
32 ((port :initarg :port
33 :reader frame-manager-port)
34 (frames :initform nil
35 :reader frame-manager-frames)))
36
37 (defun find-frame-manager (&rest options &key port &allow-other-keys)
38 (declare (special *frame-manager*))
39 (if (boundp '*frame-manager*)
40 *frame-manager*
41 (if (and *default-frame-manager*
42 (frame-manager-p *default-frame-manager*))
43 *default-frame-manager*
44 (first (frame-managers (or port (apply #'find-port options)))))))
45
46 (defmacro with-frame-manager ((frame-manager) &body body)
47 `(let ((*frame-manager* ,frame-manager))
48 (declare (special *frame-manager*))
49 (locally ,@body)))
50
51 ;;; Application-Frame class
52 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
53 ;;; -- moore
54
55 (define-protocol-class application-frame ()
56 ((port :initform nil
57 :initarg :port
58 :accessor port)
59 (graft :initform nil
60 :initarg :graft
61 :accessor graft)
62 (name :initarg :name
63 :reader frame-name)
64 (pretty-name :initarg :pretty-name
65 :accessor frame-pretty-name)
66 (command-table :initarg :command-table
67 :initform nil
68 :accessor frame-command-table)
69 (disabled-commands :initarg :disabled-commands
70 :initform nil
71 :accessor frame-disabled-commands)
72 (pane :reader frame-pane)
73 (panes :initform nil
74 :reader frame-panes)
75 (layouts :initform nil
76 :initarg :layouts
77 :reader frame-layouts)
78 (current-layout :initform nil
79 :initarg :current-layout
80 :reader frame-current-layout)
81 (top-level-sheet :initform nil
82 :reader frame-top-level-sheet)
83 (menu-bar :initarg :menu-bar
84 :initform nil)
85 (calling-frame :initarg :calling-frame
86 :initform nil)
87 (state :initarg :state
88 :initform :disowned
89 :reader frame-state)
90 (manager :initform nil
91 :reader frame-manager
92 :accessor %frame-manager)
93 (keyboard-input-focus :initform nil
94 :accessor keyboard-input-focus)
95 (properties :initarg :properties
96 :initform nil)
97 (top-level :initform '(default-frame-top-level)
98 :initarg :top-level
99 :reader frame-top-level)
100 (hilited-presentation :initform nil
101 :initarg :hilited-presentation
102 :accessor frame-hilited-presentation)))
103
104 ;;; Generic operations
105 ; (defgeneric frame-name (frame))
106 ; (defgeneric frame-pretty-name (frame))
107 ; (defgeneric (setf frame-pretty-name) (name frame))
108 ; (defgeneric frame-command-table (frame))
109 ; (defgeneric (setf frame-command-table) (command-table frame))
110 (defgeneric frame-standard-output (frame)
111 (:documentation
112 "Returns the stream that will be used for *standard-output* for the FRAME."))
113 (defgeneric frame-standard-input (frame)
114 (:documentation
115 "Returns the stream that will be used for *standard-input* for the FRAME."))
116 (defgeneric frame-query-io (frame)
117 (:documentation
118 "Returns the stream that will be used for *query-io* for the FRAME."))
119 (defgeneric frame-error-output (frame)
120 (:documentation
121 "Returns the stream that will be used for *error-output* for the FRAME."))
122 (defgeneric frame-pointer-documentation-output (frame)
123 (:documentation
124 "Returns the stream that will be used for *pointer-documentation-output*
125 for the FRAME."))
126 (defgeneric frame-calling-frame (frame)
127 (:documentation
128 "Returns the application frame that invoked the FRAME."))
129 (defgeneric frame-parent (frame)
130 (:documentation
131 "Returns the object that acts as the parent for the FRAME."))
132 ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
133 ; (:documentation
134 ; "Returns the pane that is the top-level pane in the current layout
135 ;of the FRAME's named panes."))
136 (defgeneric frame-top-level-sheet (frame)
137 (:documentation
138 "Returns the shhet that is the top-level sheet for the FRAME. This
139 is the sheet that has as its descendants all of the panes of the FRAME."))
140 (defgeneric frame-current-panes (frame)
141 (:documentation
142 "Returns a list of those named panes in the FRAME's current layout.
143 If there are no named panes, only the single, top level pane is returned."))
144 (defgeneric get-frame-pane (frame pane-name)
145 (:documentation
146 "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
147 (defgeneric find-pane-named (frame pane-name)
148 (:documentation
149 "Returns the pane in the FRAME whose name is PANE-NAME."))
150 ;(defgeneric frame-current-layout (frame))
151 ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
152 (defgeneric layout-frame (frame &optional width height))
153 (defgeneric frame-exit-frame (condition)
154 (:documentation
155 "Returns the frame that is being exited from associated with the
156 FRAME-EXIT condition."))
157 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
158 (:documentation
159 "Exits from the FRAME."))
160 (defgeneric pane-needs-redisplay (pane))
161 (defgeneric (setf pane-needs-redisplay) (value pane))
162 (defgeneric redisplay-frame-pane (frame pane &key force-p))
163 (defgeneric redisplay-frame-panes (frame &key force-p))
164 (defgeneric frame-replay (frame stream &optional region))
165 (defgeneric notify-user (frame message &key associated-window title
166 documentation exit-boxes name style text-style))
167 ;(defgeneric frame-properties (frame property))
168 ;(defgeneric (setf frame-properties) (value frame property))
169
170 ; extension
171 (defgeneric frame-schedule-timer-event (frame sheet delay token))
172
173 (defclass standard-application-frame (application-frame)
174 ((event-queue :initarg :frame-event-queue
175 :accessor frame-event-queue
176 :documentation "The event queue that, by default, will be
177 shared by all panes in the stream")
178 (documentation-state :accessor frame-documentation-state
179 :initform nil
180 :documentation "Used to keep of track of what
181 needs to be rendered in the pointer documentation frame.")))
182
183 ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
184
185 (defmethod initialize-instance :after ((obj standard-application-frame)
186 &key (input-buffer nil input-buffer-p))
187 (cond (input-buffer-p
188 (setf (frame-event-queue obj) input-buffer))
189 ((not (slot-boundp obj 'event-queue))
190 (setf (frame-event-queue obj) (make-instance 'standard-event-queue)))
191 (t nil)))
192
193
194 (defmethod (setf frame-manager) (fm (frame application-frame))
195 (let ((old-manager (frame-manager frame)))
196 (setf (%frame-manager frame) nil)
197 (when old-manager
198 (disown-frame old-manager frame)
199 (setf (slot-value frame 'panes) nil)
200 (setf (slot-value frame 'layouts) nil))
201 (setf (%frame-manager frame) fm)))
202
203 (defmethod (setf frame-current-layout) (name (frame application-frame))
204 (declare (ignore name))
205 (generate-panes (frame-manager frame) frame))
206
207 (defmethod generate-panes :before (fm (frame application-frame))
208 (declare (ignore fm))
209 (when (and (slot-boundp frame 'pane)
210 (frame-pane frame))
211 (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
212
213 (defmethod generate-panes :after (fm (frame application-frame))
214 (declare (ignore fm))
215 (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
216 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
217 (let ((space (compose-space (frame-top-level-sheet frame))))
218 ;; automatically generates a window-configuation-event
219 ;; which then calls allocate-space
220 ;;
221 ;; Not any longer, we turn of CONFIGURE-NOTIFY events until the
222 ;; window is mapped and do the space allocation now, so that all
223 ;; sheets will have their correct geometry at once. --GB
224 (setf (sheet-region (frame-top-level-sheet frame))
225 (make-bounding-rectangle 0 0
226 (space-requirement-width space)
227 (space-requirement-height space)))
228 (allocate-space (frame-top-level-sheet frame)
229 (space-requirement-width space)
230 (space-requirement-height space)) ))
231
232 (defmethod layout-frame ((frame application-frame) &optional width height)
233 (let ((pane (frame-pane frame)))
234 (if (and width (not height))
235 (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
236 (if (and (null width) (null height))
237 (let ((space (compose-space pane)))
238 (setq width (space-requirement-width space))
239 (setq height (space-requirement-height space))))
240 (let ((tpl-sheet (frame-top-level-sheet frame)))
241 (unless (and (= width (bounding-rectangle-width tpl-sheet))
242 (= height (bounding-rectangle-height tpl-sheet)))
243 (resize-sheet (frame-top-level-sheet frame) width height)))
244 (allocate-space pane width height)))
245
246 (defun find-pane-if (predicate panes)
247 "Returns a pane satisfying PREDICATE in the forest growing from PANES"
248 (loop for pane in panes
249 do (map-over-sheets #'(lambda (p)
250 (when (funcall predicate p)
251 (return-from find-pane-if p)))
252 pane)
253 finally (return nil)))
254
255 (defun find-pane-of-type (panes type)
256 (find-pane-if #'(lambda (pane) (typep pane type)) panes))
257
258 (defmethod frame-current-panes ((frame application-frame))
259 (find-pane-if #'(lambda (pane) (pane-name pane))
260 (frame-current-layout frame)))
261
262 (defmethod get-frame-pane ((frame application-frame) pane-name)
263 (find-pane-if #'(lambda (pane)
264 (and (typep pane 'clim-stream-pane)
265 (eq pane-name
266 (pane-name pane))))
267 (frame-panes frame)))
268
269 (defmethod find-pane-named ((frame application-frame) pane-name)
270 (find-pane-if #'(lambda (pane)
271 (eq pane-name
272 (pane-name pane)))
273 (frame-panes frame)))
274
275 (defmethod frame-standard-output ((frame application-frame))
276 (or (find-pane-of-type (frame-panes frame) 'application-pane)
277 (find-pane-of-type (frame-panes frame) 'interactor-pane)))
278
279 (defmethod frame-standard-input ((frame application-frame))
280 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
281 (frame-standard-output frame)))
282
283 (defmethod frame-query-io ((frame application-frame))
284 (or (frame-standard-input frame)
285 (frame-standard-output frame)))
286
287 (defmethod frame-error-output ((frame application-frame))
288 (frame-standard-output frame))
289
290 (defvar *pointer-documentation-output* nil)
291
292 (defmethod frame-pointer-documentation-output ((frame application-frame))
293 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
294
295 ;;; Command loop interface
296
297 (define-condition frame-exit (condition)
298 ((frame :initarg :frame :reader %frame-exit-frame)))
299
300 (defmethod frame-exit ((frame standard-application-frame))
301 (signal 'frame-exit :frame frame))
302
303 (defmethod frame-exit-frame ((c frame-exit))
304 (%frame-exit-frame c))
305
306 (defmethod redisplay-frame-pane ((frame application-frame) pane &key force-p)
307 (declare (ignore pane force-p))
308 nil)
309
310 (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys)
311 (handler-bind ((frame-exit #'(lambda (condition)
312 (declare (ignore condition))
313 (return-from run-frame-top-level nil))))
314 (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
315
316 (defmethod run-frame-top-level :around ((frame application-frame) &key)
317 (let ((*application-frame* frame)
318 (*input-context* nil)
319 (*input-wait-test* nil)
320 (*input-wait-handler* nil)
321 (*pointer-button-press-handler* nil)
322 (original-state (frame-state frame)))
323 (declare (special *input-context* *input-wait-test* *input-wait-handler*
324 *pointer-button-press-handler*))
325 (when (eq (frame-state frame) :disowned)
326 (adopt-frame (or (frame-manager frame) (find-frame-manager))
327 frame))
328 (unless (or (eq (frame-state frame) :enabled)
329 (eq (frame-state frame) :shrunk))
330 (enable-frame frame))
331 (let ((query-io (frame-query-io frame)))
332 (unwind-protect
333 (if query-io
334 (with-input-focus (query-io)
335 (call-next-method))
336 (call-next-method))
337 (case original-state
338 (:disabled
339 (disable-frame frame))
340 (:disowned
341 (disown-frame (frame-manager frame) frame)))))))
342
343 (defmethod default-frame-top-level
344 ((frame application-frame)
345 &key (command-parser 'command-line-command-parser)
346 (command-unparser 'command-line-command-unparser)
347 (partial-command-parser
348 'command-line-read-remaining-arguments-for-partial-command)
349 (prompt "Command: "))
350 (loop
351 (let ((*standard-input* (frame-standard-input frame))
352 (*standard-output* (frame-standard-output frame))
353 (*query-io* (frame-query-io frame))
354 (*pointer-documentation-output* (frame-pointer-documentation-output
355 frame))
356 ;; during development, don't alter *error-output*
357 ;; (*error-output* (frame-error-output frame))
358 (*command-parser* command-parser)
359 (*command-unparser* command-unparser)
360 (*partial-command-parser* partial-command-parser)
361 (prompt-style (make-text-style :fix :italic :normal)))
362 (map-over-sheets #'(lambda (pane)
363 (multiple-value-bind (redisplayp clearp)
364 (pane-needs-redisplay pane)
365 (when redisplayp
366 (when (and clearp
367 (or (not (pane-incremental-redisplay
368 pane))
369 (not *enable-updating-output*)))
370 (window-clear pane))
371 (redisplay-frame-pane frame pane)
372 (unless (eq redisplayp :command-loop)
373 (setf (pane-needs-redisplay pane) nil)))))
374 (frame-top-level-sheet frame))
375 (when *standard-input*
376 (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
377 (when prompt
378 (with-text-style (*standard-input* prompt-style)
379 (if (stringp prompt)
380 (write-string prompt *standard-input*)
381 (funcall prompt *standard-input* frame))
382 (finish-output *standard-input*)))
383 (let ((command (read-frame-command frame)))
384 (fresh-line *standard-input*)
385 (when command
386 (execute-frame-command frame command))
387 (fresh-line *standard-input*))))))
388
389
390 (defmethod read-frame-command ((frame application-frame)
391 &key (stream *standard-input*))
392 (with-input-context ('menu-item)
393 (object)
394 ;; Is this the intended behavior of interactor-panes
395 ;; (vs. application panes)?
396 (if (typep stream 'interactor-pane)
397 (read-command (frame-command-table frame) :stream stream)
398 (loop (read-gesture :stream stream)))
399 (menu-item
400 (let ((command (command-menu-item-value object)))
401 (if (listp command)
402 command
403 (list command))))))
404
405
406 (defmethod execute-frame-command ((frame application-frame) command)
407 (apply (command-name command) (command-arguments command)))
408
409 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
410 `(make-pane-1 ,fm ,frame ',type ,@args))
411
412 (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
413 &rest args
414 &key (input-buffer nil input-buffer-p)
415 &allow-other-keys)
416 "Default input-buffer to the frame event queue."
417 (if input-buffer-p
418 (call-next-method)
419 (apply #'call-next-method fm frame type
420 :input-buffer (frame-event-queue frame)
421 args)))
422
423 (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
424 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
425 (setf (frame-manager frame) fm)
426 (setf (port frame) (frame-manager-port fm))
427 (setf (graft frame) (find-graft :port (port frame)))
428 (let* ((*application-frame* frame)
429 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
430 :name 'top-level-sheet
431 ;; enabling should be left to enable-frame
432 :enabled-p nil)))
433 (setf (slot-value frame 'top-level-sheet) t-l-s)
434 (generate-panes fm frame)
435 (setf (slot-value frame 'state) :disabled)
436 frame))
437
438 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
439 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
440 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
441 (setf (%frame-manager frame) nil)
442 (setf (slot-value frame 'state) :disowned)
443 frame)
444
445 (defgeneric enable-frame (frame))
446 (defgeneric disable-frame (frame))
447
448 (defgeneric note-frame-enabled (frame-manager frame))
449 (defgeneric note-frame-disbled (frame-manager frame))
450
451 (defmethod enable-frame ((frame application-frame))
452 (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)
453 (setf (slot-value frame 'state) :enabled)
454 (note-frame-enabled (frame-manager frame) frame))
455
456 (defmethod disable-frame ((frame application-frame))
457 (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
458 (setf (slot-value frame 'state) :disabled)
459 (note-frame-disabled (frame-manager frame) frame))
460
461 (defmethod note-frame-enabled ((fm frame-manager) frame)
462 (declare (ignore frame))
463 t)
464
465 (defmethod note-frame-disabled ((fm frame-manager) frame)
466 t)
467
468 (defvar *pane-realizer* nil)
469
470 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
471 `(let ((*pane-realizer* ,frame-manager)
472 (*application-frame* ,frame))
473 (locally
474 ,@body)))
475
476 ; The menu-bar code in the following two functions is incorrect.
477 ; it needs to be moved to somewhere after the backend, since
478 ; it depends on the backend chosen.
479 ;
480 ; This hack slaps a menu-bar into the start of the application-frame,
481 ; in such a way that it is hard to find.
482 ;
483 ; FIXME
484 (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
485 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
486 ; v-- hey, how can this be?
487 (with-look-and-feel-realization (fm frame)
488 (let ((pane ,(cond
489 ((eq menu-bar t)
490 `(vertically () (clim-internals::make-menu-bar
491 ',class-name)
492 ,pane))
493 ((consp menu-bar)
494 `(vertically () (clim-internals::make-menu-bar
495 (make-command-table nil
496 :menu ',menu-bar))
497 ,pane))
498 (menu-bar
499 `(vertically () (clim-internals::make-menu-bar
500 ',menu-bar)
501 ,pane))
502 ;; The form below is unreachable with (listp
503 ;; menu-bar) instead of (consp menu-bar) above
504 ;; --GB
505 (t pane))))
506 (setf (slot-value frame 'pane) pane)))))
507
508 ; could do with some refactoring [BTS] FIXME
509 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
510 pointer-documentation)
511 (when pointer-documentation
512 (setf panes (append panes
513 '((%pointer-documentation%
514 pointer-documentation-pane)))))
515 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
516 (let ((*application-frame* frame))
517 (with-look-and-feel-realization (fm frame)
518 (let ,(loop for (name . form) in panes
519 collect `(,name (or (find-pane-named frame ',name)
520 (let ((pane
521 ,(cond
522 ((and (= (length form) 1)
523 (listp (first form)))
524 (first form))
525 ((keywordp (first form))
526 (let ((maker (intern (concatenate 'string
527 (symbol-name '#:make-clim-)
528 (symbol-name (first form))
529 (symbol-name '#:-pane))
530 :clim)))
531 (if (fboundp maker)
532 `(,maker :name ',name ,@(cdr form))
533 `(make-pane ',(first form)
534 :name ',name ,@(cdr form)))))
535 (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
536 ;; hmm?! --GB
537 (setf (slot-value pane 'name) ',name)
538 ;;
539 (push pane (slot-value frame 'panes))
540 pane))))
541 ; [BTS] added this, but is not sure that this is correct for adding
542 ; a menu-bar transparently, should also only be done where the
543 ; exterior window system does not support menus
544 ,(if (or menu-bar pointer-documentation)
545 `(setf (slot-value frame 'pane)
546 (ecase (frame-current-layout frame)
547 ,@(mapcar (lambda (layout)
548 `(,(first layout)
549 (vertically ()
550 ,@(cond
551 ((eq menu-bar t)
552 `((clim-internals::make-menu-bar
553 ',class-name)))
554 ((consp menu-bar)
555 `((clim-internals::make-menu-bar
556 (make-command-table
557 nil
558 :menu ',menu-bar))))
559 (menu-bar
560 `((clim-internals::make-menu-bar
561 ',menu-bar)))
562 (t nil))
563 ,@(rest layout)
564 ,@(when pointer-documentation
565 '(%pointer-documentation%)))))
566 layouts)))
567 `(setf (slot-value frame 'pane)
568 (ecase (frame-current-layout frame)
569 ,@layouts))))))))
570
571 (defmacro define-application-frame (name superclasses slots &rest options)
572 (if (null superclasses)
573 (setq superclasses '(standard-application-frame)))
574 (let ((pane nil)
575 (panes nil)
576 (layouts nil)
577 (current-layout nil)
578 (command-table (list name))
579 (menu-bar t)
580 (disabled-commands nil)
581 (command-definer t)
582 (top-level '(default-frame-top-level))
583 (others nil)
584 (command-name (intern (concatenate 'string
585 (symbol-name '#:define-)
586 (symbol-name name)
587 (symbol-name '#:-command))))
588 (pointer-documentation nil))
589 (loop for (prop . values) in options
590 do (case prop
591 (:pane (setq pane (first values)))
592 (:panes (setq panes values))
593 (:layouts (setq layouts values))
594 (:command-table (setq command-table (first values)))
595 (:menu-bar (setq menu-bar (if (listp values)
596 (first values)
597 values)))
598 (:disabled-commands (setq disabled-commands values))
599 (:command-definer (setq command-definer (first values)))
600 (:top-level (setq top-level (first values)))
601 (:pointer-documentation (setq pointer-documentation (car values)))
602 (t (push (cons prop values) others))))
603 (if (or (and pane panes)
604 (and pane layouts))
605 (error ":pane cannot be specified along with either :panes or :layouts"))
606 (if pane
607 (setq panes (list 'single-pane pane)
608 layouts `((:default ,(car pane)))))
609 (setq current-layout (first (first layouts)))
610 `(progn
611 (defclass ,name ,superclasses
612 ,slots
613 (:default-initargs
614 :name ',name
615 :pretty-name ,(string-capitalize name)
616 :command-table (find-command-table ',(first command-table))
617 :disabled-commands ',disabled-commands
618 :menu-bar ',menu-bar
619 :current-layout ',current-layout
620 :layouts ',layouts
621 :top-level ',top-level
622 )
623 ,@others)
624 ,(if pane
625 (make-single-pane-generate-panes-form name menu-bar pane)
626 (make-panes-generate-panes-form name menu-bar panes layouts
627 pointer-documentation))
628 ,@(if command-table
629 `((define-command-table ,@command-table)))
630 ,@(if command-definer
631 `((defmacro ,command-name (name-and-options arguements &rest body)
632 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
633 (options (if (listp name-and-options) (cdr name-and-options) nil))
634 (command-table ',(first command-table)))
635 `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
636
637 (defun make-application-frame (frame-name
638 &rest options
639 &key (pretty-name
640 (string-capitalize frame-name))
641 (frame-manager nil frame-manager-p)
642 enable
643 (state nil state-supplied-p)
644 left top right bottom width height
645 save-under (frame-class frame-name)
646 &allow-other-keys)
647 (declare (ignore left top right bottom width height save-under))
648 (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
649 :left :top :right :bottom :width :height
650 :save-under :frame-class))
651 (let ((frame (apply #'make-instance frame-class
652 :name frame-name :pretty-name pretty-name options)))
653 (when frame-manager-p
654 (adopt-frame frame-manager frame))
655 (cond ((or enable (eq state :enabled))
656 (enable-frame frame))
657 ((and (eq state :disowned)
658 (not (eq (frame-state frame) :disowned)))
659 (disown-frame (frame-manager frame) frame))
660 (state-supplied-p
661 (warn ":state ~S not supported yet." state)))
662 frame)))
663
664 ;;; Menu frame class
665
666 (defclass menu-frame ()
667 ((left :initform 0 :initarg :left)
668 (top :initform 0 :initarg :top)
669 (top-level-sheet :initform nil :reader frame-top-level-sheet)
670 (pane :reader frame-pane :initarg :pane)
671 (graft :initform nil :accessor graft)
672 (manager :initform nil :accessor frame-manager)))
673
674 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
675 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
676 (setf (frame-manager frame) fm)
677 (let* ((t-l-s (make-pane-1 fm *application-frame*
678 'unmanaged-top-level-sheet-pane
679 :name 'top-level-sheet)))
680 (setf (slot-value frame 'top-level-sheet) t-l-s)
681 (sheet-adopt-child t-l-s (frame-pane frame))
682 (let ((graft (find-graft :port (frame-manager-port fm))))
683 (sheet-adopt-child graft t-l-s)
684 (setf (graft frame) graft))
685 (let ((space (compose-space t-l-s)))
686 (allocate-space (frame-pane frame)
687 (space-requirement-width space)
688 (space-requirement-height space))
689 (setf (sheet-region t-l-s)
690 (make-bounding-rectangle 0 0
691 (space-requirement-width space)
692 (space-requirement-height space))))
693 (setf (sheet-transformation t-l-s)
694 (make-translation-transformation (slot-value frame 'left)
695 (slot-value frame 'top)))))
696
697 (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
698 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
699 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
700 (setf (frame-manager frame) nil))
701
702 (defun make-menu-frame (pane &key (left 0) (top 0))
703 (make-instance 'menu-frame :pane pane :left left :top top))
704
705 ;;; Frames and presentations
706
707 (defmethod frame-find-innermost-applicable-presentation
708 ((frame standard-application-frame) input-context stream x y
709 &key event)
710 (find-innermost-applicable-presentation input-context stream
711 x y
712 :frame frame :event event))
713
714 (defmethod frame-input-context-button-press-handler
715 ((frame standard-application-frame)
716 (stream output-recording-stream)
717 button-press-event)
718 (let ((presentation (find-innermost-applicable-presentation
719 *input-context*
720 stream
721 (pointer-event-x button-press-event)
722 (pointer-event-y button-press-event)
723 :frame frame
724 :event button-press-event)))
725 (when presentation
726 (throw-highlighted-presentation presentation
727 *input-context*
728 button-press-event))))
729
730 (defmethod frame-input-context-button-press-handler
731 ((frame standard-application-frame) stream button-press-event)
732 (declare (ignore stream button-press-event))
733 nil)
734
735 (defgeneric frame-update-pointer-documentation
736 (frame input-context stream event))
737
738 (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
739 (#.+pointer-middle-button+ "M")
740 (#.+pointer-right-button+ "R")))
741
742 (defconstant +modifier-documentation+
743 '((#.+shift-key+ "sh" "Shift")
744 (#.+control-key+ "c" "Control")
745 (#.+meta-key+ "m" "Meta")
746 (#.+super-key+ "s" "Super")
747 (#.+hyper-key+ "h" "Hyper")))
748
749 ;;; Give a coherent order to sets of modifier combinations. Multi-key combos
750 ;;; come after single keys.
751
752 (defun cmp-modifiers (a b)
753 (let ((cnt-a (logcount a))
754 (cnt-b (logcount b)))
755 (cond ((eql cnt-a cnt-b)
756 (< a b))
757 (t (< cnt-a cnt-b)))))
758
759 (defun print-modifiers (stream modifiers style)
760 (if (zerop modifiers)
761 (when (eq style :long)
762 (write-string "<nothing>" stream))
763 (loop with trailing = nil
764 for (bit short long) in +modifier-documentation+
765 when (logtest bit modifiers)
766 do (progn
767 (format stream "~:[~;-~]~A" trailing (if (eq style :short)
768 short
769 long))
770 (setq trailing t)))))
771
772
773 ;;; We don't actually want to print out the translator documentation and redraw
774 ;;; the pointer documentation window on every motion event. So, we compute a
775 ;;; state object (basically modifier state and a list of the applicable
776 ;;; presentation, translator and input context on each mouse button),
777 ;;; compare it to the previous state object, and only write out documentation
778 ;;; if they are different. I suppose it's possible that this state object
779 ;;; doesn't capture all possible documentation changes -- the doc generator is
780 ;;; a function, after all -- but that's just tough.
781 ;;;
782 ;;; It would be nice to evolve this into a protocol so that elements other than
783 ;;; presentations -- menu choices, for example -- could influence pointer
784 ;;; documentation window.
785
786 (defgeneric frame-compute-pointer-documentation-state
787 (frame input-context stream event)
788 (:documentation
789 "Compute a state object that will be used to generate pointer documentation."))
790
791 (defmethod frame-compute-pointer-documentation-state
792 ((frame standard-application-frame) input-context stream event)
793 (let* ((current-modifier (event-modifier-state event))
794 (x (device-event-x event))
795 (y (device-event-y event))
796 (new-translators
797 (loop for (button) in +button-documentation+
798 for context-list = (multiple-value-list
799 (find-innermost-presentation-context
800 input-context
801 stream
802 x y
803 :modifier-state current-modifier
804 :button button))
805 when (car context-list)
806 collect (cons button context-list))))
807 (list current-modifier new-translators)))
808
809 (defgeneric frame-compare-pointer-documentation-state
810 (frame input-context stream old-state new-state))
811
812 (defmethod frame-compare-pointer-documentation-state
813 ((frame standard-application-frame) input-context stream
814 old-state new-state)
815 (equal old-state new-state))
816
817 (defgeneric frame-print-pointer-documentation
818 (frame input-context stream state event))
819
820 (defmethod frame-print-pointer-documentation
821 ((frame standard-application-frame) input-context stream state event)
822 (unless state
823 (return-from frame-print-pointer-documentation nil))
824 (destructuring-bind (current-modifier new-translators)
825 state
826 (let ((x (device-event-x event))
827 (y (device-event-y event))
828 (pstream *pointer-documentation-output*))
829 (loop for (button presentation translator context)
830 in new-translators
831 for name = (cadr (assoc button +button-documentation+))
832 for first-one = t then nil
833 do (progn
834 (unless first-one
835 (write-string "; " pstream))
836 (unless (zerop current-modifier)
837 (print-modifiers pstream current-modifier :short)
838 (write-string "-" pstream))
839 (format pstream "~A: " name)
840 (document-presentation-translator translator
841 presentation
842 (input-context-type context)
843 *application-frame*
844 event
845 stream
846 x y
847 :stream pstream
848 :documentation-type
849 :pointer))
850 finally (when new-translators
851 (write-char #\. pstream)))
852 ;; Wasteful to do this after doing
853 ;; find-innermost-presentation-context above... look at doing this
854 ;; first and then doing the innermost test.
855 (let ((all-translators (find-applicable-translators
856 (stream-output-history stream)
857 input-context
858 *application-frame*
859 stream
860 x y
861 :for-menu t))
862 (other-modifiers nil))
863 (loop for (translator) in all-translators
864 for gesture = (gesture translator)
865 unless (eq gesture t)
866 do (loop for (name type modifier) in gesture
867 unless (eql modifier current-modifier)
868 do (pushnew modifier other-modifiers)))
869 (when other-modifiers
870 (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
871 (terpri pstream)
872 (write-string "To see other commands, press " pstream)
873 (loop for modifier-tail on other-modifiers
874 for (modifier) = modifier-tail
875 for count from 0
876 do (progn
877 (if (null (cdr modifier-tail))
878 (progn
879 (when (> count 1)
880 (write-char #\, pstream))
881 (when (> count 0)
882 (write-string " or " pstream)))
883 (when (> count 0)
884 (write-string ", " pstream)))
885 (print-modifiers pstream modifier :long)))
886 (write-char #\. pstream))))))
887
888 (defmethod frame-update-pointer-documentation
889 ((frame standard-application-frame) input-context stream event)
890 (when *pointer-documentation-output*
891 (with-accessors ((frame-documentation-state frame-documentation-state))
892 frame
893 (let ((new-state (frame-compute-pointer-documentation-state frame
894 input-context
895 stream
896 event)))
897 (unless (frame-compare-pointer-documentation-state
898 frame
899 input-context
900 stream
901 frame-documentation-state
902 new-state)
903 (window-clear *pointer-documentation-output*)
904 (frame-print-pointer-documentation frame
905 input-context
906 stream
907 new-state
908 event)
909 (setq frame-documentation-state new-state))))))
910
911 (defmethod frame-input-context-track-pointer
912 ((frame standard-application-frame)
913 input-context
914 (stream output-recording-stream) event)
915 (declare (ignore input-context event))
916 nil)
917
918 (defmethod frame-input-context-track-pointer
919 ((frame standard-application-frame) input-context stream event)
920 (declare (ignore input-context stream event))
921 nil)
922
923 (defmethod frame-input-context-track-pointer :before
924 ((frame standard-application-frame) input-context stream event)
925 (flet ((maybe-unhighlight (presentation)
926 (when (and (frame-hilited-presentation frame)
927 (not (eq presentation
928 (car (frame-hilited-presentation frame)))))
929 (highlight-presentation-1 (car (frame-hilited-presentation frame))
930 (cdr (frame-hilited-presentation frame))
931 :unhighlight))))
932 (if (output-recording-stream-p stream)
933 (let ((presentation (find-innermost-applicable-presentation
934 input-context
935 stream
936 (device-event-x event)
937 (device-event-y event)
938 :frame frame
939 :modifier-state (event-modifier-state event))))
940 (maybe-unhighlight presentation)
941 (if presentation
942 (when (not (eq presentation
943 (car (frame-hilited-presentation frame))))
944 (setf (frame-hilited-presentation frame)
945 (cons presentation stream))
946 (highlight-presentation-1 presentation stream :highlight))
947 (setf (frame-hilited-presentation frame) nil)))
948 (progn
949 (maybe-unhighlight nil)
950 (setf (frame-hilited-presentation frame) nil))))
951 (frame-update-pointer-documentation frame input-context stream event))
952
953 (defun simple-event-loop ()
954 "An simple event loop for applications that want all events to be handled by
955 handle-event methods"
956 (let ((queue (frame-event-queue *application-frame*)))
957 (loop for event = (event-queue-read queue)
958 ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself.
959 do (handle-event (event-sheet event) event))))
960
961 ;;; Am I missing something? Does this need to do more? - moore
962 (defmacro with-application-frame ((frame) &body body)
963 `(let ((,frame *application-frame*))
964 ,@body))

  ViewVC Help
Powered by ViewVC 1.1.5