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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.58 - (hide annotations)
Thu Nov 21 03:54:48 2002 UTC (11 years, 4 months ago) by mikemac
Branch: MAIN
Changes since 1.57: +0 -3 lines
remove redundant declarations and definitions
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.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 mikemac 1.1
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 gilbert 1.33 ;; *application-frame* is in decls.lisp
27 mikemac 1.1 (defvar *default-frame-manager* nil)
28    
29 cvs 1.5 ;;; Frame-Manager class
30    
31 gilbert 1.56 (define-protocol-class frame-manager ()
32 cvs 1.5 ((port :initarg :port
33     :reader frame-manager-port)
34     (frames :initform nil
35 brian 1.54 :reader frame-manager-frames)))
36 cvs 1.5
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 adejneka 1.43 `(let ((*frame-manager* ,frame-manager))
48 cvs 1.5 (declare (special *frame-manager*))
49 adejneka 1.43 (locally ,@body)))
50    
51 mikemac 1.1 ;;; Application-Frame class
52 moore 1.38 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
53     ;;; -- moore
54 mikemac 1.1
55 gilbert 1.56 (define-protocol-class application-frame ()
56 mikemac 1.1 ((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 moore 1.52 :initform :disowned
89     :reader frame-state)
90 mikemac 1.1 (manager :initform nil
91 adejneka 1.46 :reader frame-manager
92     :accessor %frame-manager)
93 mikemac 1.1 (properties :initarg :properties
94     :initform nil)
95     (top-level :initform '(default-frame-top-level)
96     :initarg :top-level
97     :reader frame-top-level)
98 moore 1.18 (hilited-presentation :initform nil
99     :initarg :hilited-presentation
100 moore 1.38 :accessor frame-hilited-presentation)))
101 mikemac 1.1
102 adejneka 1.13 ;;; 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 mikemac 1.22 (defgeneric frame-exit-frame (condition)
152     (:documentation
153     "Returns the frame that is being exited from associated with the
154     FRAME-EXIT condition."))
155 adejneka 1.13 (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 brian 1.54 ; extension
169     (defgeneric frame-schedule-timer-event (frame sheet delay token))
170 adejneka 1.13
171 mikemac 1.1 (defclass standard-application-frame (application-frame)
172 moore 1.38 ((event-queue :initarg :frame-event-queue
173     :accessor frame-event-queue
174     :documentation "The event queue that, by default, will be
175 moore 1.47 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 moore 1.38
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 mikemac 1.1
192     (defmethod (setf frame-manager) (fm (frame application-frame))
193     (let ((old-manager (frame-manager frame)))
194 adejneka 1.46 (setf (%frame-manager frame) nil)
195 mikemac 1.1 (when old-manager
196     (disown-frame old-manager frame)
197     (setf (slot-value frame 'panes) nil)
198     (setf (slot-value frame 'layouts) nil))
199 adejneka 1.46 (setf (%frame-manager frame) fm)))
200 mikemac 1.1
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 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
215 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
216 cvs 1.5 ;; automatically generates a window-configuation-event
217     ;; which then calls allocate-space
218 gilbert 1.39 ;;
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 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
223 cvs 1.5 (make-bounding-rectangle 0 0
224     (space-requirement-width space)
225 gilbert 1.39 (space-requirement-height space)))
226     (allocate-space (frame-top-level-sheet frame)
227     (space-requirement-width space)
228     (space-requirement-height space)) ))
229 mikemac 1.1
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 hatchond 1.11 (let ((space (compose-space pane)))
236 mikemac 1.1 (setq width (space-requirement-width space))
237     (setq height (space-requirement-height space))))
238     (allocate-space pane width height)))
239    
240 adejneka 1.13 (defun find-pane-if (predicate panes)
241     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
242 moore 1.27 (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 adejneka 1.13 (defun find-pane-of-type (panes type)
250     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
251 adejneka 1.40
252 adejneka 1.13 (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 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
270 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
271     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
272 mikemac 1.1
273     (defmethod frame-standard-input ((frame application-frame))
274 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
275 mikemac 1.1 (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 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
288 mikemac 1.1
289     ;;; Command loop interface
290    
291 mikemac 1.22 (define-condition frame-exit (condition)
292 moore 1.26 ((frame :initarg :frame :reader %frame-exit-frame)))
293 mikemac 1.22
294     (defmethod frame-exit ((frame standard-application-frame))
295     (signal 'frame-exit :frame frame))
296 moore 1.26
297     (defmethod frame-exit-frame ((c frame-exit))
298     (%frame-exit-frame c))
299 mikemac 1.22
300 adejneka 1.44 (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys)
301 mikemac 1.22 (handler-bind ((frame-exit #'(lambda (condition)
302 gilbert 1.31 (declare (ignore condition))
303 mikemac 1.22 (return-from run-frame-top-level nil))))
304     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
305 mikemac 1.1
306 adejneka 1.44 (defmethod run-frame-top-level :around ((frame application-frame) &key)
307 mikemac 1.1 (let ((*application-frame* frame)
308     (*input-context* nil)
309     (*input-wait-test* nil)
310     (*input-wait-handler* nil)
311 moore 1.52 (*pointer-button-press-handler* nil)
312     (original-state (frame-state frame)))
313 mikemac 1.1 (declare (special *input-context* *input-wait-test* *input-wait-handler*
314     *pointer-button-press-handler*))
315 moore 1.52 (when (eq (frame-state frame) :disowned)
316     (adopt-frame (or (frame-manager frame) (find-frame-manager))
317     frame))
318     (unless (or (eq (frame-state frame) :enabled)
319     (eq (frame-state frame) :shrunk))
320     (enable-frame frame))
321 moore 1.24 (let ((query-io (frame-query-io frame)))
322 moore 1.52 (unwind-protect
323     (if query-io
324     (with-input-focus (query-io)
325     (call-next-method))
326     (call-next-method))
327     (case original-state
328     (:disabled
329     (disable-frame frame))
330     (:disowned
331     (disown-frame (frame-manager frame) frame)))))))
332 mikemac 1.1
333     (defmethod default-frame-top-level
334     ((frame application-frame)
335     &key (command-parser 'command-line-command-parser)
336     (command-unparser 'command-line-command-unparser)
337     (partial-command-parser
338     'command-line-read-remaining-arguments-for-partial-command)
339 moore 1.35 (prompt "Command: "))
340 mikemac 1.20 (loop
341     (let ((*standard-input* (frame-standard-input frame))
342     (*standard-output* (frame-standard-output frame))
343     (*query-io* (frame-query-io frame))
344 moore 1.47 (*pointer-documentation-output* (frame-pointer-documentation-output
345     frame))
346 mikemac 1.20 ;; during development, don't alter *error-output*
347 gilbert 1.39 ;; (*error-output* (frame-error-output frame))
348 mikemac 1.20 (*command-parser* command-parser)
349     (*command-unparser* command-unparser)
350     (*partial-command-parser* partial-command-parser)
351 gilbert 1.39 (prompt-style (make-text-style :fix :italic :normal)))
352 mikemac 1.20 (map-over-sheets #'(lambda (pane)
353     (if (and (typep pane 'clim-stream-pane)
354     (eq (pane-display-time pane) :command-loop)
355     (pane-display-function pane))
356     (let ((func (pane-display-function pane)))
357 adejneka 1.42 (window-clear pane)
358 adejneka 1.40 (funcall func frame pane) ; XXX other arguments
359     ; XXX incremental redisplay
360     )))
361 mikemac 1.20 (frame-top-level-sheet frame))
362     (when *standard-input*
363     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
364 mikemac 1.21 (when prompt
365     (with-text-style (*standard-input* prompt-style)
366     (if (stringp prompt)
367 moore 1.35 (write-string prompt *standard-input*)
368     (funcall prompt *standard-input* frame))
369 adejneka 1.40 (finish-output *standard-input*)))
370 moore 1.35 (let ((command (read-frame-command frame)))
371     (fresh-line *standard-input*)
372     (when command
373     (execute-frame-command frame command))
374     (fresh-line *standard-input*))))))
375    
376 mikemac 1.1
377 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
378 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
379    
380     (defmethod execute-frame-command ((frame application-frame) command)
381 moore 1.35 (apply (command-name command) (command-arguments command)))
382    
383 mikemac 1.1 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
384     `(make-pane-1 ,fm ,frame ',type ,@args))
385 moore 1.38
386     (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
387     &rest args
388 moore 1.51 &key (input-buffer nil input-buffer-p)
389     &allow-other-keys)
390 moore 1.38 "Default input-buffer to the frame event queue."
391     (if input-buffer-p
392     (call-next-method)
393     (apply #'call-next-method fm frame type
394     :input-buffer (frame-event-queue frame)
395     args)))
396 mikemac 1.1
397     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
398     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
399     (setf (frame-manager frame) fm)
400 moore 1.52 (setf (port frame) (frame-manager-port fm))
401     (setf (graft frame) (find-graft :port (port frame)))
402 mikemac 1.1 (let* ((*application-frame* frame)
403 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
404 moore 1.52 :name 'top-level-sheet
405     ;; enabling should be left to enable-frame
406     :enabled-p nil)))
407 mikemac 1.1 (setf (slot-value frame 'top-level-sheet) t-l-s)
408 moore 1.52 (generate-panes fm frame)
409     (setf (slot-value frame 'state) :disabled)
410     frame))
411 brian 1.28
412 mikemac 1.1 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
413     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
414     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
415 moore 1.52 (setf (%frame-manager frame) nil)
416     (setf (slot-value frame 'state) :disowned)
417     frame)
418    
419     (defgeneric enable-frame (frame))
420     (defgeneric disable-frame (frame))
421    
422     (defgeneric note-frame-enabled (frame-manager frame))
423     (defgeneric note-frame-disbled (frame-manager frame))
424    
425     (defmethod enable-frame ((frame application-frame))
426     (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)
427     (setf (slot-value frame 'state) :enabled)
428     (note-frame-enabled (frame-manager frame) frame))
429    
430     (defmethod disable-frame ((frame application-frame))
431     (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
432     (setf (slot-value frame 'state) :disabled)
433     (note-frame-disabled (frame-manager frame) frame))
434    
435     (defmethod note-frame-enabled ((fm frame-manager) frame)
436     (declare (ignore frame))
437     t)
438    
439     (defmethod note-frame-disabled ((fm frame-manager) frame)
440     t)
441 mikemac 1.1
442 cvs 1.8 (defvar *pane-realizer* nil)
443    
444 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
445 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
446     (*application-frame* ,frame))
447 adejneka 1.45 (locally
448     ,@body)))
449 mikemac 1.1
450 brian 1.28 ; The menu-bar code in the following two functions is incorrect.
451     ; it needs to be moved to somewhere after the backend, since
452     ; it depends on the backend chosen.
453     ;
454     ; This hack slaps a menu-bar into the start of the application-frame,
455     ; in such a way that it is hard to find.
456     ;
457     ; FIXME
458     (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
459 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
460 brian 1.28 ; v-- hey, how can this be?
461 moore 1.17 (with-look-and-feel-realization (fm frame)
462 brian 1.28 (let ((pane ,(cond
463     ((eq menu-bar t)
464     `(vertically () (clim-internals::make-menu-bar
465     ',class-name)
466     ,pane))
467 brian 1.32 ((consp menu-bar)
468 brian 1.28 `(vertically () (clim-internals::make-menu-bar
469     (make-command-table nil
470     :menu ',menu-bar))
471     ,pane))
472     (menu-bar
473     `(vertically () (clim-internals::make-menu-bar
474     ',menu-bar)
475     ,pane))
476 gilbert 1.31 ;; The form below is unreachable with (listp
477     ;; menu-bar) instead of (consp menu-bar) above
478     ;; --GB
479 brian 1.28 (t pane))))
480     (setf (slot-value frame 'pane) pane)))))
481 mikemac 1.1
482 brian 1.28 ; could do with some refactoring [BTS] FIXME
483 moore 1.47 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
484     pointer-documentation)
485     (when pointer-documentation
486     (setf panes (append panes
487     '((%pointer-documentation%
488     pointer-documentation-pane)))))
489 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
490     (let ((*application-frame* frame))
491 cvs 1.8 (with-look-and-feel-realization (fm frame)
492     (let ,(loop for (name . form) in panes
493     collect `(,name (or (find-pane-named frame ',name)
494     (let ((pane
495     ,(cond
496     ((and (= (length form) 1)
497     (listp (first form)))
498     (first form))
499     ((keywordp (first form))
500     (let ((maker (intern (concatenate 'string
501     "MAKE-CLIM-"
502     (symbol-name (first form))
503     "-PANE") :clim)))
504     (if (fboundp maker)
505     `(,maker :name ',name ,@(cdr form))
506     `(make-pane ',(first form)
507     :name ',name ,@(cdr form)))))
508     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
509 gilbert 1.19 ;; hmm?! --GB
510     (setf (slot-value pane 'name) ',name)
511     ;;
512 cvs 1.8 (push pane (slot-value frame 'panes))
513     pane))))
514 brian 1.28 ; [BTS] added this, but is not sure that this is correct for adding
515     ; a menu-bar transparently, should also only be done where the
516     ; exterior window system does not support menus
517 moore 1.47 ,(if (or menu-bar pointer-documentation)
518 brian 1.28 `(setf (slot-value frame 'pane)
519     (ecase (frame-current-layout frame)
520     ,@(mapcar (lambda (layout)
521 moore 1.47 `(,(first layout)
522     (vertically ()
523     ,@(cond
524     ((eq menu-bar t)
525     `((clim-internals::make-menu-bar
526     ',class-name)))
527     ((consp menu-bar)
528 gilbert 1.55 `((clim-internals::make-menu-bar
529 moore 1.47 (make-command-table
530     nil
531 gilbert 1.55 :menu ',menu-bar))))
532 moore 1.47 (menu-bar
533     `((clim-internals::make-menu-bar
534     ',menu-bar)))
535     (t nil))
536     ,@(rest layout)
537     ,@(when pointer-documentation
538     '(%pointer-documentation%)))))
539 brian 1.28 layouts)))
540     `(setf (slot-value frame 'pane)
541     (ecase (frame-current-layout frame)
542     ,@layouts))))))))
543 mikemac 1.1
544     (defmacro define-application-frame (name superclasses slots &rest options)
545     (if (null superclasses)
546     (setq superclasses '(standard-application-frame)))
547     (let ((pane nil)
548     (panes nil)
549     (layouts nil)
550     (current-layout nil)
551 mikemac 1.23 (command-table (list name))
552 mikemac 1.1 (menu-bar t)
553     (disabled-commands nil)
554     (command-definer t)
555     (top-level '(default-frame-top-level))
556     (others nil)
557 moore 1.47 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name)
558     "-COMMAND")))
559     (pointer-documentation nil))
560 mikemac 1.1 (loop for (prop . values) in options
561     do (case prop
562     (:pane (setq pane (first values)))
563     (:panes (setq panes values))
564     (:layouts (setq layouts values))
565     (:command-table (setq command-table (first values)))
566 brian 1.28 (:menu-bar (setq menu-bar (if (listp values)
567     (first values)
568     values)))
569 mikemac 1.1 (:disabled-commands (setq disabled-commands values))
570     (:command-definer (setq command-definer (first values)))
571     (:top-level (setq top-level (first values)))
572 moore 1.47 (:pointer-documentation (setq pointer-documentation (car values)))
573 mikemac 1.1 (t (push (cons prop values) others))))
574     (if (or (and pane panes)
575     (and pane layouts))
576     (error ":pane cannot be specified along with either :panes or :layouts"))
577     (if pane
578     (setq panes (list 'single-pane pane)
579 moore 1.17 layouts `((:default ,(car pane)))))
580 mikemac 1.1 (setq current-layout (first (first layouts)))
581     `(progn
582     (defclass ,name ,superclasses
583     ,slots
584     (:default-initargs
585     :name ',name
586     :pretty-name ,(string-capitalize name)
587 mikemac 1.23 :command-table (find-command-table ',(first command-table))
588 mikemac 1.1 :disabled-commands ',disabled-commands
589 brian 1.28 :menu-bar ',menu-bar
590 mikemac 1.1 :current-layout ',current-layout
591     :layouts ',layouts
592     :top-level ',top-level
593     )
594     ,@others)
595     ,(if pane
596 brian 1.28 (make-single-pane-generate-panes-form name menu-bar pane)
597 moore 1.47 (make-panes-generate-panes-form name menu-bar panes layouts
598     pointer-documentation))
599 mikemac 1.23 ,@(if command-table
600     `((define-command-table ,@command-table)))
601 mikemac 1.1 ,@(if command-definer
602     `((defmacro ,command-name (name-and-options arguements &rest body)
603     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
604 mikemac 1.23 (options (if (listp name-and-options) (cdr name-and-options) nil))
605     (command-table ',(first command-table)))
606     `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
607 mikemac 1.1
608     (defun make-application-frame (frame-name
609     &rest options
610 moore 1.52 &key (pretty-name
611     (string-capitalize frame-name))
612     (frame-manager nil frame-manager-p)
613     enable
614     (state nil state-supplied-p)
615     left top right bottom width height
616     save-under (frame-class frame-name)
617 mikemac 1.1 &allow-other-keys)
618 moore 1.52 (declare (ignore left top right bottom width height save-under))
619     (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
620     :left :top :right :bottom :width :height
621 moore 1.53 :save-under :frame-class))
622 moore 1.52 (let ((frame (apply #'make-instance frame-class
623     :name frame-name :pretty-name pretty-name options)))
624     (when frame-manager-p
625     (adopt-frame frame-manager frame))
626     (cond ((or enable (eq state :enabled))
627     (enable-frame frame))
628     ((and (eq state :disowned)
629     (not (eq (frame-state frame) :disowned)))
630     (disown-frame (frame-manager frame) frame))
631     (state-supplied-p
632     (warn ":state ~S not supported yet." state)))
633     frame)))
634 cvs 1.4
635 cvs 1.7 ;;; Menu frame class
636    
637     (defclass menu-frame ()
638     ((left :initform 0 :initarg :left)
639     (top :initform 0 :initarg :top)
640     (top-level-sheet :initform nil :reader frame-top-level-sheet)
641     (pane :reader frame-pane :initarg :pane)
642     (graft :initform nil :accessor graft)
643     (manager :initform nil :accessor frame-manager)))
644 adejneka 1.46
645 cvs 1.7 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
646     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
647 adejneka 1.46 (setf (frame-manager frame) fm)
648 brian 1.54 (let* ((t-l-s (make-pane-1 fm *application-frame*
649     'unmanaged-top-level-sheet-pane
650 cvs 1.7 :name 'top-level-sheet)))
651     (setf (slot-value frame 'top-level-sheet) t-l-s)
652     (sheet-adopt-child t-l-s (frame-pane frame))
653     (let ((graft (find-graft :port (frame-manager-port fm))))
654     (sheet-adopt-child graft t-l-s)
655     (setf (graft frame) graft))
656 hatchond 1.11 (let ((space (compose-space t-l-s)))
657 cvs 1.7 (allocate-space (frame-pane frame)
658     (space-requirement-width space)
659     (space-requirement-height space))
660     (setf (sheet-region t-l-s)
661     (make-bounding-rectangle 0 0
662     (space-requirement-width space)
663     (space-requirement-height space))))
664     (setf (sheet-transformation t-l-s)
665     (make-translation-transformation (slot-value frame 'left)
666     (slot-value frame 'top)))))
667    
668     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
669     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
670     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
671     (setf (frame-manager frame) nil))
672    
673     (defun make-menu-frame (pane &key (left 0) (top 0))
674     (make-instance 'menu-frame :pane pane :left left :top top))
675 moore 1.18
676     ;;; Frames and presentations
677    
678     (defmethod frame-find-innermost-applicable-presentation
679     ((frame standard-application-frame) input-context stream x y
680     &key event)
681     (find-innermost-applicable-presentation input-context stream
682     x y
683     :frame frame :event event))
684    
685 adejneka 1.41 (defmethod frame-input-context-button-press-handler
686 moore 1.18 ((frame standard-application-frame)
687     (stream output-recording-stream)
688     button-press-event)
689     (let ((presentation (find-innermost-applicable-presentation
690     *input-context*
691     stream
692     (pointer-event-x button-press-event)
693     (pointer-event-y button-press-event)
694 moore 1.37 :frame frame
695     :event button-press-event)))
696 moore 1.18 (when presentation
697     (throw-highlighted-presentation presentation
698     *input-context*
699     button-press-event))))
700    
701     (defmethod frame-input-context-button-press-handler
702     ((frame standard-application-frame) stream button-press-event)
703 mikemac 1.36 (declare (ignore stream button-press-event))
704 moore 1.27 nil)
705 moore 1.18
706 moore 1.47 (defgeneric frame-update-pointer-documentation
707     (frame input-context stream event))
708    
709     (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
710     (#.+pointer-middle-button+ "M")
711     (#.+pointer-right-button+ "R")))
712    
713 moore 1.48 (defconstant +modifier-documentation+
714     '((#.+shift-key+ "sh" "Shift")
715     (#.+control-key+ "c" "Control")
716     (#.+meta-key+ "m" "Meta")
717     (#.+super-key+ "s" "Super")
718     (#.+hyper-key+ "h" "Hyper")))
719    
720     ;;; Give a coherent order to sets of modifier combinations. Multi-key combos
721     ;;; come after single keys.
722    
723     (defun cmp-modifiers (a b)
724     (let ((cnt-a (logcount a))
725     (cnt-b (logcount b)))
726     (cond ((eql cnt-a cnt-b)
727     (< a b))
728     (t (< cnt-a cnt-b)))))
729    
730     (defun print-modifiers (stream modifiers style)
731 moore 1.49 (if (zerop modifiers)
732     (when (eq style :long)
733     (write-string "<nothing>" stream))
734     (loop with trailing = nil
735     for (bit short long) in +modifier-documentation+
736     when (logtest bit modifiers)
737     do (progn
738     (format stream "~:[~;-~]~A" trailing (if (eq style :short)
739     short
740     long))
741     (setq trailing t)))))
742 moore 1.48
743    
744     ;;; We don't actually want to print out the translator documentation and redraw
745     ;;; the pointer documentation window on every motion event. So, we compute a
746     ;;; state object (basically modifier state and a list of the applicable
747     ;;; presentation, translator and input context on each mouse button),
748     ;;; compare it to the previous state object, and only write out documentation
749     ;;; if they are different. I suppose it's possible that this state object
750     ;;; doesn't capture all possible documentation changes -- the doc generator is
751     ;;; a function, after all -- but that's just tough.
752     ;;;
753     ;;; It would be nice to evolve this into a protocol so that elements other than
754     ;;; presentations -- menu choices, for example -- could influence pointer
755     ;;; documentation window.
756    
757 moore 1.50 (defgeneric frame-compute-pointer-documentation-state
758     (frame input-context stream event)
759     (:documentation
760     "Compute a state object that will be used to generate pointer documentation."))
761    
762     (defmethod frame-compute-pointer-documentation-state
763     ((frame standard-application-frame) input-context stream event)
764     (let* ((current-modifier (event-modifier-state event))
765     (x (device-event-x event))
766     (y (device-event-y event))
767     (new-translators
768     (loop for (button) in +button-documentation+
769     for context-list = (multiple-value-list
770     (find-innermost-presentation-context
771     input-context
772     stream
773     x y
774     :modifier-state current-modifier
775     :button button))
776     when (car context-list)
777     collect (cons button context-list))))
778     (list current-modifier new-translators)))
779    
780     (defgeneric frame-compare-pointer-documentation-state
781     (frame input-context stream old-state new-state))
782    
783     (defmethod frame-compare-pointer-documentation-state
784     ((frame standard-application-frame) input-context stream
785     old-state new-state)
786     (equal old-state new-state))
787    
788     (defgeneric frame-print-pointer-documentation
789     (frame input-context stream state event))
790    
791     (defmethod frame-print-pointer-documentation
792     ((frame standard-application-frame) input-context stream state event)
793     (unless state
794     (return-from frame-print-pointer-documentation nil))
795     (destructuring-bind (current-modifier new-translators)
796     state
797     (let ((x (device-event-x event))
798     (y (device-event-y event))
799     (pstream *pointer-documentation-output*))
800     (loop for (button presentation translator context)
801     in new-translators
802     for name = (cadr (assoc button +button-documentation+))
803     for first-one = t then nil
804     do (progn
805     (unless first-one
806     (write-string "; " pstream))
807     (unless (zerop current-modifier)
808     (print-modifiers pstream current-modifier :short)
809     (write-string "-" pstream))
810     (format pstream "~A: " name)
811     (document-presentation-translator translator
812     presentation
813     (input-context-type context)
814     *application-frame*
815     event
816     stream
817     x y
818     :stream pstream
819     :documentation-type
820     :pointer))
821     finally (when new-translators
822     (write-char #\. pstream)))
823     ;; Wasteful to do this after doing
824     ;; find-innermost-presentation-context above... look at doing this
825     ;; first and then doing the innermost test.
826     (let ((all-translators (find-applicable-translators
827     (stream-output-history stream)
828     input-context
829     *application-frame*
830     stream
831     x y
832     :for-menu t))
833     (other-modifiers nil))
834     (loop for (translator) in all-translators
835     for gesture = (gesture translator)
836     unless (eq gesture t)
837     do (loop for (name type modifier) in gesture
838     unless (eql modifier current-modifier)
839     do (pushnew modifier other-modifiers)))
840     (when other-modifiers
841     (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
842     (terpri pstream)
843     (write-string "To see other commands, press " pstream)
844     (loop for modifier-tail on other-modifiers
845     for (modifier) = modifier-tail
846     for count from 0
847     do (progn
848     (if (null (cdr modifier-tail))
849     (progn
850     (when (> count 1)
851     (write-char #\, pstream))
852     (when (> count 0)
853     (write-string " or " pstream)))
854     (when (> count 0)
855     (write-string ", " pstream)))
856     (print-modifiers pstream modifier :long)))
857     (write-char #\. pstream))))))
858    
859 moore 1.47 (defmethod frame-update-pointer-documentation
860     ((frame standard-application-frame) input-context stream event)
861     (when *pointer-documentation-output*
862     (with-accessors ((frame-documentation-state frame-documentation-state))
863     frame
864 moore 1.50 (let ((new-state (frame-compute-pointer-documentation-state frame
865     input-context
866     stream
867     event)))
868     (unless (frame-compare-pointer-documentation-state
869     frame
870     input-context
871     stream
872     frame-documentation-state
873     new-state)
874     (window-clear *pointer-documentation-output*)
875     (frame-print-pointer-documentation frame
876     input-context
877     stream
878     new-state
879     event)
880     (setq frame-documentation-state new-state))))))
881 moore 1.47
882 moore 1.18 (defmethod frame-input-context-track-pointer
883     ((frame standard-application-frame)
884     input-context
885     (stream output-recording-stream) event)
886     (declare (ignore input-context event))
887     nil)
888    
889     (defmethod frame-input-context-track-pointer
890     ((frame standard-application-frame) input-context stream event)
891 mikemac 1.36 (declare (ignore input-context stream event))
892 moore 1.27 nil)
893 moore 1.18
894     (defmethod frame-input-context-track-pointer :before
895     ((frame standard-application-frame) input-context stream event)
896 moore 1.47 (flet ((maybe-unhighlight (presentation)
897     (when (and (frame-hilited-presentation frame)
898     (not (eq presentation
899     (car (frame-hilited-presentation frame)))))
900     (highlight-presentation-1 (car (frame-hilited-presentation frame))
901     (cdr (frame-hilited-presentation frame))
902     :unhighlight))))
903 moore 1.18 (if (output-recording-stream-p stream)
904     (let ((presentation (find-innermost-applicable-presentation
905     input-context
906     stream
907 moore 1.50 (device-event-x event)
908     (device-event-y event)
909 moore 1.37 :frame frame
910     :modifier-state (event-modifier-state event))))
911 moore 1.47 (maybe-unhighlight presentation)
912 moore 1.34 (if presentation
913     (when (not (eq presentation
914     (car (frame-hilited-presentation frame))))
915     (setf (frame-hilited-presentation frame)
916     (cons presentation stream))
917     (highlight-presentation-1 presentation stream :highlight))
918 moore 1.47 (setf (frame-hilited-presentation frame) nil)))
919     (progn
920     (maybe-unhighlight nil)
921     (setf (frame-hilited-presentation frame) nil))))
922     (frame-update-pointer-documentation frame input-context stream event))
923 moore 1.27
924     (defun simple-event-loop ()
925     "An simple event loop for applications that want all events to be handled by
926     handle-event methods"
927 adejneka 1.41 (let ((queue (frame-event-queue *application-frame*)))
928     (loop for event = (event-queue-read queue)
929     ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself.
930     do (handle-event (event-sheet event) event))))
931 moore 1.57
932     ;;; Am I missing something? Does this need to do more? - moore
933     (defmacro with-application-frame ((frame) &body body)
934     `(let ((,frame *application-frame*))
935     ,@body))

  ViewVC Help
Powered by ViewVC 1.1.5