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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5