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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Dec 8 17:16:13 2000 UTC (13 years, 4 months ago) by cvs
Branch: MAIN
Changes since 1.7: +29 -28 lines
changed with-look-and-feel mechanism, execute-command just calls eval - still a kludge
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 (defclass standard-application-frame (application-frame)
110 ())
111
112 (defmethod (setf frame-manager) (fm (frame application-frame))
113 (let ((old-manager (frame-manager frame)))
114 (setf (slot-value frame 'manager) nil)
115 (when old-manager
116 (disown-frame old-manager frame)
117 (setf (slot-value frame 'panes) nil)
118 (setf (slot-value frame 'layouts) nil))
119 (setf (slot-value frame 'manager) fm)))
120
121 (defmethod (setf frame-current-layout) (name (frame application-frame))
122 (declare (ignore name))
123 (generate-panes (frame-manager frame) frame))
124
125 (defmethod generate-panes :before (fm (frame application-frame))
126 (declare (ignore fm))
127 (when (and (slot-boundp frame 'pane)
128 (frame-pane frame))
129 (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
130
131 (defmethod generate-panes :after (fm (frame application-frame))
132 (declare (ignore fm))
133 (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
134 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
135 (setf (sheet-transformation (frame-top-level-sheet frame))
136 (make-translation-transformation 100 100))
137 (let ((space (compose-space (frame-top-level-sheet frame))))
138 ;; automatically generates a window-configuation-event
139 ;; which then calls allocate-space
140 (setf (sheet-region (frame-top-level-sheet frame))
141 (make-bounding-rectangle 0 0
142 (space-requirement-width space)
143 (space-requirement-height space)))))
144
145 (defmethod find-pane-named ((frame application-frame) name)
146 (loop for pane in (frame-panes frame)
147 if (eq (pane-name pane) name)
148 return pane))
149
150 (defmethod layout-frame ((frame application-frame) &optional width height)
151 (let ((pane (frame-pane frame)))
152 (if (and width (not height))
153 (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
154 (if (and (null width) (null height))
155 (let ((space (compose-space pane)))
156 (setq width (space-requirement-width space))
157 (setq height (space-requirement-height space))))
158 (allocate-space pane width height)))
159
160 (defun find-pane-of-type (panes type)
161 (setq panes (copy-list panes))
162 (loop for pane in panes
163 if (typep pane type)
164 return pane
165 do (setq panes (nconc panes (copy-list (sheet-children pane))))
166 finally (return nil)))
167
168 (defmethod frame-standard-output ((frame application-frame))
169 (or (find-pane-of-type (frame-panes frame) 'application-pane)
170 (find-pane-of-type (frame-panes frame) 'interactor-pane)))
171
172 (defmethod frame-standard-input ((frame application-frame))
173 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
174 (frame-standard-output frame)))
175
176 (defmethod frame-query-io ((frame application-frame))
177 (or (frame-standard-input frame)
178 (frame-standard-output frame)))
179
180 (defmethod frame-error-output ((frame application-frame))
181 (frame-standard-output frame))
182
183 (defvar *pointer-documentation-output* nil)
184
185 (defmethod frame-pointer-documentation-output ((frame application-frame))
186 (loop for pane in (frame-panes frame)
187 if (typep pane 'pointer-documentation-pane)
188 return pane
189 finally (return nil)))
190
191 ;;; Command loop interface
192
193 (defmethod run-frame-top-level ((frame application-frame))
194 (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame))))
195
196 (defmethod run-frame-top-level :around ((frame application-frame))
197 (let ((*application-frame* frame)
198 (*input-context* nil)
199 (*input-wait-test* nil)
200 (*input-wait-handler* nil)
201 (*pointer-button-press-handler* nil))
202 (declare (special *input-context* *input-wait-test* *input-wait-handler*
203 *pointer-button-press-handler*))
204 (call-next-method)))
205
206 (defmethod default-frame-top-level
207 ((frame application-frame)
208 &key (command-parser 'command-line-command-parser)
209 (command-unparser 'command-line-command-unparser)
210 (partial-command-parser
211 'command-line-read-remaining-arguments-for-partial-command)
212 (prompt "Command: "))
213 (let ((*standard-input* (frame-standard-input frame))
214 (*standard-output* (frame-standard-output frame))
215 (*query-io* (frame-query-io frame))
216 ;; during development, don't alter *error-output*
217 ;(*error-output* (frame-error-output frame))
218 (*command-parser* command-parser)
219 (*command-unparser* command-unparser)
220 (*partial-command-parser* partial-command-parser)
221 (prompt-style (make-text-style :fixed :italic :normal))
222 results)
223 (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
224 (loop do
225 (with-text-style (*standard-input* prompt-style)
226 (if (stringp prompt)
227 (stream-write-string *standard-input* prompt)
228 (apply prompt (list *standard-input* frame))))
229 (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame *standard-input*))))
230 (loop for result in results
231 do (print result *standard-input*))
232 (terpri *standard-input*))
233 ))
234
235 (defmethod read-frame-command ((frame application-frame) stream)
236 (read-command (frame-command-table frame) :stream stream))
237
238 (defmethod execute-frame-command ((frame application-frame) command)
239 #+ignore (apply (command-name command) (command-arguments command))
240 (eval command))
241
242 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
243 `(make-pane-1 ,fm ,frame ',type ,@args))
244
245 (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
246 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
247 (setf (frame-manager frame) fm)
248 (let* ((*application-frame* frame)
249 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
250 :name 'top-level-sheet)))
251 (setf (slot-value frame 'top-level-sheet) t-l-s)
252 (generate-panes fm frame)))
253
254 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
255 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
256 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
257 (setf (frame-manager frame) nil))
258
259 (defvar *pane-realizer* nil)
260
261 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
262 `(let ((*pane-realizer* ,frame-manager)
263 (*application-frame* ,frame))
264 (progn
265 ,@body)))
266
267 (defun make-single-pane-generate-panes-form (class-name pane)
268 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
269 (let ((*application-frame* frame))
270 (let ((pane ,pane))
271 (setf (slot-value frame 'pane) pane)))))
272
273 (defun make-panes-generate-panes-form (class-name panes layouts)
274 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
275 (let ((*application-frame* frame))
276 (with-look-and-feel-realization (fm frame)
277 (let ,(loop for (name . form) in panes
278 collect `(,name (or (find-pane-named frame ',name)
279 (let ((pane
280 ,(cond
281 ((and (= (length form) 1)
282 (listp (first form)))
283 (first form))
284 ((keywordp (first form))
285 (let ((maker (intern (concatenate 'string
286 "MAKE-CLIM-"
287 (symbol-name (first form))
288 "-PANE") :clim)))
289 (if (fboundp maker)
290 `(,maker :name ',name ,@(cdr form))
291 `(make-pane ',(first form)
292 :name ',name ,@(cdr form)))))
293 (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
294 (push pane (slot-value frame 'panes))
295 pane))))
296 (setf (slot-value frame 'pane)
297 (ecase (frame-current-layout frame)
298 ,@layouts)))
299 ))))
300
301 (defmacro define-application-frame (name superclasses slots &rest options)
302 (if (null superclasses)
303 (setq superclasses '(standard-application-frame)))
304 (let ((pane nil)
305 (panes nil)
306 (layouts nil)
307 (current-layout nil)
308 (command-table nil)
309 (menu-bar t)
310 (disabled-commands nil)
311 (command-definer t)
312 (top-level '(default-frame-top-level))
313 (others nil)
314 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
315 (loop for (prop . values) in options
316 do (case prop
317 (:pane (setq pane (first values)))
318 (:panes (setq panes values))
319 (:layouts (setq layouts values))
320 (:command-table (setq command-table (first values)))
321 (:menu-bar (setq menu-bar (first values)))
322 (:disabled-commands (setq disabled-commands values))
323 (:command-definer (setq command-definer (first values)))
324 (:top-level (setq top-level (first values)))
325 (t (push (cons prop values) others))))
326 (if (or (and pane panes)
327 (and pane layouts))
328 (error ":pane cannot be specified along with either :panes or :layouts"))
329 (if pane
330 (setq panes (list 'single-pane pane)
331 layouts (list :default (first pane))))
332 (setq current-layout (first (first layouts)))
333 `(progn
334 (defclass ,name ,superclasses
335 ,slots
336 (:default-initargs
337 :name ',name
338 :pretty-name ,(string-capitalize name)
339 :command-table ,command-table
340 :disabled-commands ',disabled-commands
341 :menu-bar ,menu-bar
342 :current-layout ',current-layout
343 :layouts ',layouts
344 :top-level ',top-level
345 )
346 ,@others)
347 ,(if pane
348 (make-single-pane-generate-panes-form name pane)
349 (make-panes-generate-panes-form name panes layouts))
350 ,@(if command-definer
351 `((defmacro ,command-name (name-and-options arguements &rest body)
352 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
353 (options (if (listp name-and-options) (cdr name-and-options) nil)))
354 `(define-command ,name ,arguements ,@body))))))))
355
356 (defun make-application-frame (frame-name
357 &rest options
358 &key pretty-name frame-manager enable state
359 left top right bottom width height save-under
360 frame-class
361 &allow-other-keys)
362 (setq options (loop for (key value) on options by #'cddr
363 if (not (member key '(:pretty-name :frame-manager :enable :state
364 :left :top :right :bottom :width :height :save-under
365 :frame-class)
366 :key #'eq))
367 nconc (list key value)))
368 (if (null frame-class)
369 (setq frame-class frame-name))
370 (if (null pretty-name)
371 (setq pretty-name (string-capitalize frame-name)))
372 (if (null frame-manager)
373 (setq frame-manager (find-frame-manager)))
374 (let ((frame (apply #'make-instance frame-class
375 :port (frame-manager-port frame-manager)
376 :graft (find-graft :port (frame-manager-port frame-manager))
377 :name frame-name :pretty-name pretty-name options)))
378 (adopt-frame frame-manager frame)
379 frame))
380
381 ;;; Menu frame class
382
383 (defclass menu-frame ()
384 ((left :initform 0 :initarg :left)
385 (top :initform 0 :initarg :top)
386 (top-level-sheet :initform nil :reader frame-top-level-sheet)
387 (pane :reader frame-pane :initarg :pane)
388 (graft :initform nil :accessor graft)
389 (manager :initform nil :accessor frame-manager)))
390
391 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
392 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
393 (setf (slot-value frame 'manager) fm)
394 (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
395 :name 'top-level-sheet)))
396 (setf (slot-value frame 'top-level-sheet) t-l-s)
397 (sheet-adopt-child t-l-s (frame-pane frame))
398 (let ((graft (find-graft :port (frame-manager-port fm))))
399 (sheet-adopt-child graft t-l-s)
400 (setf (graft frame) graft))
401 (let ((space (compose-space t-l-s)))
402 (allocate-space (frame-pane frame)
403 (space-requirement-width space)
404 (space-requirement-height space))
405 (setf (sheet-region t-l-s)
406 (make-bounding-rectangle 0 0
407 (space-requirement-width space)
408 (space-requirement-height space))))
409 (setf (sheet-transformation t-l-s)
410 (make-translation-transformation (slot-value frame 'left)
411 (slot-value frame 'top)))))
412
413 (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
414 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
415 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
416 (setf (frame-manager frame) nil))
417
418 (defun make-menu-frame (pane &key (left 0) (top 0))
419 (make-instance 'menu-frame :pane pane :left left :top top))
420

  ViewVC Help
Powered by ViewVC 1.1.5