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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.87 - (show annotations)
Mon Nov 24 22:13:03 2003 UTC (10 years, 4 months ago) by moore
Branch: MAIN
Changes since 1.86: +16 -12 lines
Implemented command-or-form presentation type. Fixed stupid-subtypep
so OR presentation types can be used in with-input-context. Changed
the subform reader stuff to use a presentation type option instead of
the presentation type subform. Got rid of subform altogether. Changed
the Lisp presentation types to be a subtype of expression, not form;
added a presentation translator from expression to form that does
necessary quoting.

Fixed passing of arguments to the frame-top-level function. Moved the
menu-item stuff in read-frame-command into an :around method so that
read-frame-command can be usefully overridden by users.

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

  ViewVC Help
Powered by ViewVC 1.1.5