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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Aug 22 10:38:36 2000 UTC (13 years, 8 months ago) by cvs
Branch: MAIN
Changes since 1.2: +3 -3 lines
Improved the way adopt-frame creates the panes.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 (in-package :CLIM-INTERNALS)
21
22 (defvar *application-frame* nil)
23 (defvar *default-frame-manager* nil)
24
25 ;;; Application-Frame class
26
27 (defclass application-frame ()
28 ((port :initform nil
29 :initarg :port
30 :accessor port)
31 (graft :initform nil
32 :initarg :graft
33 :accessor graft)
34 (name :initarg :name
35 :reader frame-name)
36 (pretty-name :initarg :pretty-name
37 :accessor frame-pretty-name)
38 (command-table :initarg :command-table
39 :initform nil
40 :accessor frame-command-table)
41 (disabled-commands :initarg :disabled-commands
42 :initform nil
43 :accessor frame-disabled-commands)
44 (pane :reader frame-pane)
45 (panes :initform nil
46 :reader frame-panes)
47 (layouts :initform nil
48 :initarg :layouts
49 :reader frame-layouts)
50 (current-layout :initform nil
51 :initarg :current-layout
52 :reader frame-current-layout)
53 (top-level-sheet :initform nil
54 :reader frame-top-level-sheet)
55 (menu-bar :initarg :menu-bar
56 :initform nil)
57 (calling-frame :initarg :calling-frame
58 :initform nil)
59 (state :initarg :state
60 :initform nil
61 :accessor frame-state)
62 (manager :initform nil
63 :reader frame-manager)
64 (properties :initarg :properties
65 :initform nil)
66 (top-level :initform '(default-frame-top-level)
67 :initarg :top-level
68 :reader frame-top-level)
69 ))
70
71 (defun application-frame-p (x)
72 (typep x 'application-frame))
73
74 (defmethod initialize-instance :after ((frame application-frame) &rest args)
75 (declare (ignore args))
76 )
77
78 (defclass standard-application-frame (application-frame)
79 ())
80
81 (defmethod (setf frame-manager) (fm (frame application-frame))
82 (let ((old-manager (frame-manager frame)))
83 (setf (slot-value frame 'manager) nil)
84 (when old-manager
85 (disown-frame old-manager frame)
86 (setf (slot-value frame 'panes) nil)
87 (setf (slot-value frame 'layouts) nil))
88 (setf (slot-value frame 'manager) fm)))
89
90 (defmethod calculate-standard-panes ((frame application-frame))
91 ;; Should find the panes for
92 )
93
94 (defmethod (setf frame-current-layout) (name (frame application-frame))
95 (declare (ignore name))
96 (generate-panes (frame-manager frame) frame))
97
98 (defmethod generate-panes :before (fm (frame application-frame))
99 (declare (ignore fm))
100 (when (and (slot-boundp frame 'pane)
101 (frame-pane frame))
102 (unrealize-mirror (port frame) (frame-pane frame))
103 (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
104
105 (defmethod generate-panes :after (fm (frame application-frame))
106 (declare (ignore fm))
107 (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
108 (let ((space (compose-space (frame-top-level-sheet frame))))
109 (setf (sheet-region (frame-top-level-sheet frame))
110 (make-bounding-rectangle 100 100
111 (+ 100 (space-requirement-width space))
112 (+ 100 (space-requirement-height space))))
113 (allocate-space (frame-top-level-sheet frame)
114 (space-requirement-width space) (space-requirement-height space)))
115 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame)))
116 ; (calculate-standard-panes frame))
117
118 (defmethod find-pane-named ((frame application-frame) name)
119 (loop for pane in (frame-panes frame)
120 if (eq (pane-name pane) name)
121 return pane))
122
123 (defmethod layout-frame ((frame application-frame) &optional width height)
124 (let ((pane (frame-pane frame)))
125 (if (and width (not height))
126 (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
127 (if (and (null width) (null height))
128 (let ((space (compose-space pane)))
129 (setq width (space-requirement-width space))
130 (setq height (space-requirement-height space))))
131 (allocate-space pane width height)))
132
133 (defmethod frame-standard-output ((frame application-frame))
134 (or (loop for pane in (frame-panes frame)
135 if (typep pane 'application-pane)
136 return pane
137 finally (return nil))
138 (loop for pane in (frame-panes frame)
139 if (typep pane 'interactor-pane)
140 return pane
141 finally (return nil))))
142
143 (defmethod frame-standard-input ((frame application-frame))
144 (or (loop for pane in (frame-panes frame)
145 if (typep pane 'interactor-pane)
146 return pane
147 finally (return nil))
148 (frame-standard-output frame)))
149
150 (defmethod frame-query-io ((frame application-frame))
151 (or (frame-standard-input frame)
152 (frame-standard-output frame)))
153
154 (defmethod frame-error-output ((frame application-frame))
155 (frame-standard-output frame))
156
157 (defvar *pointer-documentation-output* nil)
158
159 (defmethod frame-pointer-documentation-output ((frame application-frame))
160 (loop for pane in (frame-panes frame)
161 if (typep pane 'pointer-documentation-pane)
162 return pane
163 finally (return nil)))
164
165 ;;; Command loop interface
166
167 (defmethod run-frame-top-level ((frame application-frame))
168 (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame))))
169
170 (defmethod run-frame-top-level :around ((frame application-frame))
171 (let ((*application-frame* frame)
172 (*input-context* nil)
173 (*input-wait-test* nil)
174 (*input-wait-handler* nil)
175 (*pointer-button-press-handler* nil))
176 (declare (special *input-context* *input-wait-test* *input-wait-handler*
177 *pointer-button-press-handler*))
178 (call-next-method)))
179
180 (defmethod default-frame-top-level
181 ((frame application-frame)
182 &key (command-parser 'command-line-command-parser)
183 (command-unparser 'command-line-command-unparser)
184 (partial-command-parser
185 'command-line-read-remaining-arguments-for-partial-command)
186 (prompt "Command: "))
187 (let ((*standard-input* (frame-standard-input frame))
188 (*standard-output* (frame-standard-output frame))
189 (*query-io* (frame-query-io frame))
190 ;; during development, don't alter *error-output*
191 ;(*error-output* (frame-error-output frame))
192 (*command-parser* command-parser)
193 (*command-unparser* command-unparser)
194 (*partial-command-parser* partial-command-parser)
195 (prompt-style (make-text-style :fixed :italic :normal))
196 results)
197 (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
198 (loop do
199 (with-text-style (*standard-input* prompt-style)
200 (if (stringp prompt)
201 (stream-write-string *standard-input* prompt)
202 (apply prompt (list *standard-input* frame))))
203 (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame *standard-input*))))
204 (loop for result in results
205 do (print result *standard-input*))
206 (terpri *standard-input*))
207 ))
208
209 (defmethod read-frame-command ((frame application-frame) stream)
210 (read-command (frame-command-table frame) :stream stream))
211
212 (defmethod execute-frame-command ((frame application-frame) command)
213 (apply (command-name command) (command-arguments command)))
214
215 ;;; Frame-Manager class
216
217 (defclass frame-manager ()
218 ((port :initarg :port
219 :reader frame-manager-port)
220 (frames :initform nil
221 :reader frame-manager-frames)
222 )
223 )
224
225 (defun frame-manager-p (x)
226 (typep x 'frame-manager))
227
228 (defun find-frame-manager (&rest options &key port &allow-other-keys)
229 (declare (special *frame-manager*))
230 (if (boundp '*frame-manager*)
231 *frame-manager*
232 (if (and *default-frame-manager*
233 (frame-manager-p *default-frame-manager*))
234 *default-frame-manager*
235 (first (frame-managers (or port (apply #'find-port options)))))))
236
237 (defmacro with-frame-manager ((frame-manager) &body body)
238 `(let (('*frame-manager* ,frame-manager))
239 (declare (special *frame-manager*))
240 (block ,@body)))
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 'composite-pane
250 :name 'top-level-sheet)))
251 (setf (slot-value frame 'top-level-sheet) t-l-s)
252 ; (sheet-adopt-child (graft frame) t-l-s)
253 (generate-panes fm frame)))
254
255 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
256 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
257 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
258 (setf (frame-manager frame) nil))
259
260 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
261 (declare (ignore frame-manager frame))
262 `(progn
263 ,@body))
264
265 (defun make-single-pane-generate-panes-form (class-name pane)
266 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
267 (let ((*application-frame* frame))
268 (let ((pane ,pane))
269 (setf (slot-value frame 'pane) pane)))))
270
271 (defun make-panes-generate-panes-form (class-name panes layouts)
272 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
273 (let ((*application-frame* frame))
274 (let ,(loop for (name . form) in panes
275 collect `(,name (or (find-pane-named frame ',name)
276 (let ((pane
277 ,(cond
278 ((and (= (length form) 1)
279 (listp (first form)))
280 (first form))
281 ((keywordp (first form))
282 `(make-pane ',(intern (concatenate 'string
283 (symbol-name (first form))
284 "-PANE")
285 :clim)
286 :name ',name ,@(cdr form)))
287 (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
288 (push pane (slot-value frame 'panes))
289 pane))))
290 (setf (slot-value frame 'pane)
291 (with-look-and-feel-realization (fm frame)
292 (ecase (frame-current-layout frame)
293 ,@layouts)))
294 ))))
295
296 (defmacro define-application-frame (name superclasses slots &rest options)
297 (if (null superclasses)
298 (setq superclasses '(standard-application-frame)))
299 (let ((pane nil)
300 (panes nil)
301 (layouts nil)
302 (current-layout nil)
303 (command-table nil)
304 (menu-bar t)
305 (disabled-commands nil)
306 (command-definer t)
307 (top-level '(default-frame-top-level))
308 (others nil)
309 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
310 (loop for (prop . values) in options
311 do (case prop
312 (:pane (setq pane (first values)))
313 (:panes (setq panes values))
314 (:layouts (setq layouts values))
315 (:command-table (setq command-table (first values)))
316 (:menu-bar (setq menu-bar (first values)))
317 (:disabled-commands (setq disabled-commands values))
318 (:command-definer (setq command-definer (first values)))
319 (:top-level (setq top-level (first values)))
320 (t (push (cons prop values) others))))
321 (if (or (and pane panes)
322 (and pane layouts))
323 (error ":pane cannot be specified along with either :panes or :layouts"))
324 (if pane
325 (setq panes (list 'single-pane pane)
326 layouts (list :default (first pane))))
327 (setq current-layout (first (first layouts)))
328 `(progn
329 (defclass ,name ,superclasses
330 ,slots
331 (:default-initargs
332 :name ',name
333 :pretty-name ,(string-capitalize name)
334 :command-table ,command-table
335 :disabled-commands ',disabled-commands
336 :menu-bar ,menu-bar
337 :current-layout ',current-layout
338 :layouts ',layouts
339 :top-level ',top-level
340 )
341 ,@others)
342 ,(if pane
343 (make-single-pane-generate-panes-form name pane)
344 (make-panes-generate-panes-form name panes layouts))
345 ,@(if command-definer
346 `((defmacro ,command-name (name-and-options arguements &rest body)
347 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
348 (options (if (listp name-and-options) (cdr name-and-options) nil)))
349 `(define-command ,name ,arguements ,@body))))))))
350
351 (defun make-application-frame (frame-name
352 &rest options
353 &key pretty-name frame-manager enable state
354 left top right bottom width height save-under
355 frame-class
356 &allow-other-keys)
357 (setq options (loop for (key value) on options by #'cddr
358 if (not (member key '(:pretty-name :frame-manager :enable :state
359 :left :top :right :bottom :width :height :save-under
360 :frame-class)
361 :key #'eq))
362 nconc (list key value)))
363 (if (null frame-class)
364 (setq frame-class frame-name))
365 (if (null pretty-name)
366 (setq pretty-name (string-capitalize frame-name)))
367 (if (null frame-manager)
368 (setq frame-manager (find-frame-manager)))
369 (let ((frame (apply #'make-instance frame-class
370 :port (frame-manager-port frame-manager)
371 :graft (find-graft :port (frame-manager-port frame-manager))
372 :name frame-name :pretty-name pretty-name options)))
373 (adopt-frame frame-manager frame)
374 frame))

  ViewVC Help
Powered by ViewVC 1.1.5