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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Fri Jul 20 07:01:02 2001 UTC (12 years, 9 months ago) by adejneka
Branch: MAIN
Changes since 1.12: +91 -9 lines
* Generic function descriptions added

* FIND-PANE-IF: New function

* FIND-PANE-OF-TYPE: Use FIND-PANE-IF

* FRAME-CURRENT-PANES, GET-FRAME-PANE: New functions

* FIND-PANE-NAMED, FRAME-POINTER-DOCUMENTATION-OUTPUT: Search through
  the whole tree of panes
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 (defvar *application-frame* nil)
27 (defvar *default-frame-manager* nil)
28
29 ;;; Frame-Manager class
30
31 (defclass frame-manager ()
32 ((port :initarg :port
33 :reader frame-manager-port)
34 (frames :initform nil
35 :reader frame-manager-frames)
36 )
37 )
38
39 (defun frame-manager-p (x)
40 (typep x 'frame-manager))
41
42 (defun find-frame-manager (&rest options &key port &allow-other-keys)
43 (declare (special *frame-manager*))
44 (if (boundp '*frame-manager*)
45 *frame-manager*
46 (if (and *default-frame-manager*
47 (frame-manager-p *default-frame-manager*))
48 *default-frame-manager*
49 (first (frame-managers (or port (apply #'find-port options)))))))
50
51 (defmacro with-frame-manager ((frame-manager) &body body)
52 `(let (('*frame-manager* ,frame-manager))
53 (declare (special *frame-manager*))
54 (block ,@body)))
55
56 ;;; Application-Frame class
57
58 (defclass application-frame ()
59 ((port :initform nil
60 :initarg :port
61 :accessor port)
62 (graft :initform nil
63 :initarg :graft
64 :accessor graft)
65 (name :initarg :name
66 :reader frame-name)
67 (pretty-name :initarg :pretty-name
68 :accessor frame-pretty-name)
69 (command-table :initarg :command-table
70 :initform nil
71 :accessor frame-command-table)
72 (disabled-commands :initarg :disabled-commands
73 :initform nil
74 :accessor frame-disabled-commands)
75 (pane :reader frame-pane)
76 (panes :initform nil
77 :reader frame-panes)
78 (layouts :initform nil
79 :initarg :layouts
80 :reader frame-layouts)
81 (current-layout :initform nil
82 :initarg :current-layout
83 :reader frame-current-layout)
84 (top-level-sheet :initform nil
85 :reader frame-top-level-sheet)
86 (menu-bar :initarg :menu-bar
87 :initform nil)
88 (calling-frame :initarg :calling-frame
89 :initform nil)
90 (state :initarg :state
91 :initform nil
92 :accessor frame-state)
93 (manager :initform nil
94 :reader frame-manager)
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 ))
101
102 (defun application-frame-p (x)
103 (typep x 'application-frame))
104
105 (defmethod initialize-instance :after ((frame application-frame) &rest args)
106 (declare (ignore args))
107 )
108
109 ;;; Generic operations
110 ; (defgeneric frame-name (frame))
111 ; (defgeneric frame-pretty-name (frame))
112 ; (defgeneric (setf frame-pretty-name) (name frame))
113 ; (defgeneric frame-command-table (frame))
114 ; (defgeneric (setf frame-command-table) (command-table frame))
115 (defgeneric frame-standard-output (frame)
116 (:documentation
117 "Returns the stream that will be used for *standard-output* for the FRAME."))
118 (defgeneric frame-standard-input (frame)
119 (:documentation
120 "Returns the stream that will be used for *standard-input* for the FRAME."))
121 (defgeneric frame-query-io (frame)
122 (:documentation
123 "Returns the stream that will be used for *query-io* for the FRAME."))
124 (defgeneric frame-error-output (frame)
125 (:documentation
126 "Returns the stream that will be used for *error-output* for the FRAME."))
127 (defgeneric frame-pointer-documentation-output (frame)
128 (:documentation
129 "Returns the stream that will be used for *pointer-documentation-output*
130 for the FRAME."))
131 (defgeneric frame-calling-frame (frame)
132 (:documentation
133 "Returns the application frame that invoked the FRAME."))
134 (defgeneric frame-parent (frame)
135 (:documentation
136 "Returns the object that acts as the parent for the FRAME."))
137 ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
138 ; (:documentation
139 ; "Returns the pane that is the top-level pane in the current layout
140 ;of the FRAME's named panes."))
141 (defgeneric frame-top-level-sheet (frame)
142 (:documentation
143 "Returns the shhet that is the top-level sheet for the FRAME. This
144 is the sheet that has as its descendants all of the panes of the FRAME."))
145 (defgeneric frame-current-panes (frame)
146 (:documentation
147 "Returns a list of those named panes in the FRAME's current layout.
148 If there are no named panes, only the single, top level pane is returned."))
149 (defgeneric get-frame-pane (frame pane-name)
150 (:documentation
151 "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
152 (defgeneric find-pane-named (frame pane-name)
153 (:documentation
154 "Returns the pane in the FRAME whose name is PANE-NAME."))
155 ;(defgeneric frame-current-layout (frame))
156 ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
157 (defgeneric layout-frame (frame &optional width height))
158 ;(defgeneric frame-exit-frame (condition) ; XXX Is it in Spec?
159 ; (:documentation
160 ; "Returns the frame that is being exited from associated with the
161 ;FRAME-EXIT condition."))
162 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
163 (:documentation
164 "Exits from the FRAME."))
165 (defgeneric pane-needs-redisplay (pane))
166 (defgeneric (setf pane-needs-redisplay) (value pane))
167 (defgeneric redisplay-frame-pane (frame pane &key force-p))
168 (defgeneric redisplay-frame-panes (frame &key force-p))
169 (defgeneric frame-replay (frame stream &optional region))
170 (defgeneric notify-user (frame message &key associated-window title
171 documentation exit-boxes name style text-style))
172 ;(defgeneric frame-properties (frame property))
173 ;(defgeneric (setf frame-properties) (value frame property))
174
175
176 (defclass standard-application-frame (application-frame)
177 ())
178
179 (defmethod (setf frame-manager) (fm (frame application-frame))
180 (let ((old-manager (frame-manager frame)))
181 (setf (slot-value frame 'manager) nil)
182 (when old-manager
183 (disown-frame old-manager frame)
184 (setf (slot-value frame 'panes) nil)
185 (setf (slot-value frame 'layouts) nil))
186 (setf (slot-value frame 'manager) fm)))
187
188 (defmethod (setf frame-current-layout) (name (frame application-frame))
189 (declare (ignore name))
190 (generate-panes (frame-manager frame) frame))
191
192 (defmethod generate-panes :before (fm (frame application-frame))
193 (declare (ignore fm))
194 (when (and (slot-boundp frame 'pane)
195 (frame-pane frame))
196 (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
197
198 (defmethod generate-panes :after (fm (frame application-frame))
199 (declare (ignore fm))
200 (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
201 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
202 (setf (sheet-transformation (frame-top-level-sheet frame))
203 (make-translation-transformation 100 100))
204 (let ((space (compose-space (frame-top-level-sheet frame))))
205 ;; automatically generates a window-configuation-event
206 ;; which then calls allocate-space
207 (setf (sheet-region (frame-top-level-sheet frame))
208 (make-bounding-rectangle 0 0
209 (space-requirement-width space)
210 (space-requirement-height space)))))
211
212 (defmethod layout-frame ((frame application-frame) &optional width height)
213 (let ((pane (frame-pane frame)))
214 (if (and width (not height))
215 (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
216 (if (and (null width) (null height))
217 (let ((space (compose-space pane)))
218 (setq width (space-requirement-width space))
219 (setq height (space-requirement-height space))))
220 (allocate-space pane width height)))
221
222 (defun find-pane-if (predicate panes)
223 "Returns a pane satisfying PREDICATE in the forest growing from PANES"
224 (setq panes (copy-list panes))
225 (do ((pane (pop panes)(pop panes)))
226 ((null pane) nil)
227 (if (funcall predicate pane)
228 (return pane)
229 (setq panes (nconc panes (copy-list (sheet-children pane)))))))
230
231 (defun find-pane-of-type (panes type)
232 (find-pane-if #'(lambda (pane) (typep pane type)) panes))
233
234 (defmethod frame-current-panes ((frame application-frame))
235 (find-pane-if #'(lambda (pane) (pane-name pane))
236 (frame-current-layout frame)))
237
238 (defmethod get-frame-pane ((frame application-frame) pane-name)
239 (find-pane-if #'(lambda (pane)
240 (and (typep pane 'clim-stream-pane)
241 (eq pane-name
242 (pane-name pane))))
243 (frame-panes frame)))
244
245 (defmethod find-pane-named ((frame application-frame) pane-name)
246 (find-pane-if #'(lambda (pane)
247 (eq pane-name
248 (pane-name pane)))
249 (frame-panes frame)))
250
251 (defmethod frame-standard-output ((frame application-frame))
252 (or (find-pane-of-type (frame-panes frame) 'application-pane)
253 (find-pane-of-type (frame-panes frame) 'interactor-pane)))
254
255 (defmethod frame-standard-input ((frame application-frame))
256 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
257 (frame-standard-output frame)))
258
259 (defmethod frame-query-io ((frame application-frame))
260 (or (frame-standard-input frame)
261 (frame-standard-output frame)))
262
263 (defmethod frame-error-output ((frame application-frame))
264 (frame-standard-output frame))
265
266 (defvar *pointer-documentation-output* nil)
267
268 (defmethod frame-pointer-documentation-output ((frame application-frame))
269 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
270
271 ;;; Command loop interface
272
273 (defmethod run-frame-top-level ((frame application-frame))
274 (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame))))
275
276 (defmethod run-frame-top-level :around ((frame application-frame))
277 (let ((*application-frame* frame)
278 (*input-context* nil)
279 (*input-wait-test* nil)
280 (*input-wait-handler* nil)
281 (*pointer-button-press-handler* nil))
282 (declare (special *input-context* *input-wait-test* *input-wait-handler*
283 *pointer-button-press-handler*))
284 (call-next-method)))
285
286 (defmethod default-frame-top-level
287 ((frame application-frame)
288 &key (command-parser 'command-line-command-parser)
289 (command-unparser 'command-line-command-unparser)
290 (partial-command-parser
291 'command-line-read-remaining-arguments-for-partial-command)
292 (prompt "Command: "))
293 (let ((*standard-input* (frame-standard-input frame))
294 (*standard-output* (frame-standard-output frame))
295 (*query-io* (frame-query-io frame))
296 ;; during development, don't alter *error-output*
297 ;(*error-output* (frame-error-output frame))
298 (*command-parser* command-parser)
299 (*command-unparser* command-unparser)
300 (*partial-command-parser* partial-command-parser)
301 (prompt-style (make-text-style :fixed :italic :normal))
302 results)
303 (when *standard-input*
304 (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
305 (loop do
306 (with-text-style (*standard-input* prompt-style)
307 (if (stringp prompt)
308 (stream-write-string *standard-input* prompt)
309 (apply prompt (list *standard-input* frame))))
310 (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame))))
311 (loop for result in results
312 do (print result *standard-input*))
313 (terpri *standard-input*))
314 )))
315
316 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
317 (read-command (frame-command-table frame) :stream stream))
318
319 (defmethod execute-frame-command ((frame application-frame) command)
320 #+ignore (apply (command-name command) (command-arguments command))
321 (eval command))
322
323 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
324 `(make-pane-1 ,fm ,frame ',type ,@args))
325
326 (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
327 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
328 (setf (frame-manager frame) fm)
329 (let* ((*application-frame* frame)
330 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
331 :name 'top-level-sheet)))
332 (setf (slot-value frame 'top-level-sheet) t-l-s)
333 (generate-panes fm frame)))
334
335 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
336 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
337 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
338 (setf (frame-manager frame) nil))
339
340 (defvar *pane-realizer* nil)
341
342 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
343 `(let ((*pane-realizer* ,frame-manager)
344 (*application-frame* ,frame))
345 (progn
346 ,@body)))
347
348 (defun make-single-pane-generate-panes-form (class-name pane)
349 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
350 (let ((*application-frame* frame))
351 (let ((pane ,pane))
352 (setf (slot-value frame 'pane) pane)))))
353
354 (defun make-panes-generate-panes-form (class-name panes layouts)
355 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
356 (let ((*application-frame* frame))
357 (with-look-and-feel-realization (fm frame)
358 (let ,(loop for (name . form) in panes
359 collect `(,name (or (find-pane-named frame ',name)
360 (let ((pane
361 ,(cond
362 ((and (= (length form) 1)
363 (listp (first form)))
364 (first form))
365 ((keywordp (first form))
366 (let ((maker (intern (concatenate 'string
367 "MAKE-CLIM-"
368 (symbol-name (first form))
369 "-PANE") :clim)))
370 (if (fboundp maker)
371 `(,maker :name ',name ,@(cdr form))
372 `(make-pane ',(first form)
373 :name ',name ,@(cdr form)))))
374 (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
375 (push pane (slot-value frame 'panes))
376 pane))))
377 (setf (slot-value frame 'pane)
378 (ecase (frame-current-layout frame)
379 ,@layouts)))
380 ))))
381
382 (defmacro define-application-frame (name superclasses slots &rest options)
383 (if (null superclasses)
384 (setq superclasses '(standard-application-frame)))
385 (let ((pane nil)
386 (panes nil)
387 (layouts nil)
388 (current-layout nil)
389 (command-table nil)
390 (menu-bar t)
391 (disabled-commands nil)
392 (command-definer t)
393 (top-level '(default-frame-top-level))
394 (others nil)
395 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
396 (loop for (prop . values) in options
397 do (case prop
398 (:pane (setq pane (first values)))
399 (:panes (setq panes values))
400 (:layouts (setq layouts values))
401 (:command-table (setq command-table (first values)))
402 (:menu-bar (setq menu-bar (first values)))
403 (:disabled-commands (setq disabled-commands values))
404 (:command-definer (setq command-definer (first values)))
405 (:top-level (setq top-level (first values)))
406 (t (push (cons prop values) others))))
407 (if (or (and pane panes)
408 (and pane layouts))
409 (error ":pane cannot be specified along with either :panes or :layouts"))
410 (if pane
411 (setq panes (list 'single-pane pane)
412 layouts (list :default (first pane))))
413 (setq current-layout (first (first layouts)))
414 `(progn
415 (defclass ,name ,superclasses
416 ,slots
417 (:default-initargs
418 :name ',name
419 :pretty-name ,(string-capitalize name)
420 :command-table ,command-table
421 :disabled-commands ',disabled-commands
422 :menu-bar ,menu-bar
423 :current-layout ',current-layout
424 :layouts ',layouts
425 :top-level ',top-level
426 )
427 ,@others)
428 ,(if pane
429 (make-single-pane-generate-panes-form name pane)
430 (make-panes-generate-panes-form name panes layouts))
431 ,@(if command-definer
432 `((defmacro ,command-name (name-and-options arguements &rest body)
433 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
434 (options (if (listp name-and-options) (cdr name-and-options) nil)))
435 `(define-command ,name ,arguements ,@body))))))))
436
437 (defun make-application-frame (frame-name
438 &rest options
439 &key pretty-name frame-manager enable state
440 left top right bottom width height save-under
441 frame-class
442 &allow-other-keys)
443 (setq options (loop for (key value) on options by #'cddr
444 if (not (member key '(:pretty-name :frame-manager :enable :state
445 :left :top :right :bottom :width :height :save-under
446 :frame-class)
447 :key #'eq))
448 nconc (list key value)))
449 (if (null frame-class)
450 (setq frame-class frame-name))
451 (if (null pretty-name)
452 (setq pretty-name (string-capitalize frame-name)))
453 (if (null frame-manager)
454 (setq frame-manager (find-frame-manager)))
455 (let ((frame (apply #'make-instance frame-class
456 :port (frame-manager-port frame-manager)
457 :graft (find-graft :port (frame-manager-port frame-manager))
458 :name frame-name :pretty-name pretty-name options)))
459 (adopt-frame frame-manager frame)
460 frame))
461
462 ;;; Menu frame class
463
464 (defclass menu-frame ()
465 ((left :initform 0 :initarg :left)
466 (top :initform 0 :initarg :top)
467 (top-level-sheet :initform nil :reader frame-top-level-sheet)
468 (pane :reader frame-pane :initarg :pane)
469 (graft :initform nil :accessor graft)
470 (manager :initform nil :accessor frame-manager)))
471
472 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
473 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
474 (setf (slot-value frame 'manager) fm)
475 (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
476 :name 'top-level-sheet)))
477 (setf (slot-value frame 'top-level-sheet) t-l-s)
478 (sheet-adopt-child t-l-s (frame-pane frame))
479 (let ((graft (find-graft :port (frame-manager-port fm))))
480 (sheet-adopt-child graft t-l-s)
481 (setf (graft frame) graft))
482 (let ((space (compose-space t-l-s)))
483 (allocate-space (frame-pane frame)
484 (space-requirement-width space)
485 (space-requirement-height space))
486 (setf (sheet-region t-l-s)
487 (make-bounding-rectangle 0 0
488 (space-requirement-width space)
489 (space-requirement-height space))))
490 (setf (sheet-transformation t-l-s)
491 (make-translation-transformation (slot-value frame 'left)
492 (slot-value frame 'top)))))
493
494 (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
495 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
496 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
497 (setf (frame-manager frame) nil))
498
499 (defun make-menu-frame (pane &key (left 0) (top 0))
500 (make-instance 'menu-frame :pane pane :left left :top top))
501

  ViewVC Help
Powered by ViewVC 1.1.5