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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5