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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Fri Jul 27 09:04:40 2001 UTC (12 years, 8 months ago) by adejneka
Branch: MAIN
Changes since 1.13: +2 -1 lines
* DEFAULT-FRAME-TOP-LEVEL (APPLICATION-FRAME): Do STREAM-FINISH-OUTPUT after
  printing a prompt.
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     (defvar *application-frame* nil)
27     (defvar *default-frame-manager* nil)
28    
29 cvs 1.5 ;;; 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 mikemac 1.1 ;;; 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 adejneka 1.13 ;;; 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 mikemac 1.1 (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 cvs 1.5 (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 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
205 cvs 1.5 ;; automatically generates a window-configuation-event
206     ;; which then calls allocate-space
207 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
208 cvs 1.5 (make-bounding-rectangle 0 0
209     (space-requirement-width space)
210     (space-requirement-height space)))))
211 mikemac 1.1
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 hatchond 1.11 (let ((space (compose-space pane)))
218 mikemac 1.1 (setq width (space-requirement-width space))
219     (setq height (space-requirement-height space))))
220     (allocate-space pane width height)))
221    
222 adejneka 1.13 (defun find-pane-if (predicate panes)
223     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
224 cvs 1.6 (setq panes (copy-list panes))
225 cvs 1.10 (do ((pane (pop panes)(pop panes)))
226     ((null pane) nil)
227 adejneka 1.13 (if (funcall predicate pane)
228 cvs 1.10 (return pane)
229     (setq panes (nconc panes (copy-list (sheet-children pane)))))))
230 adejneka 1.13
231     (defun find-pane-of-type (panes type)
232     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
233 cvs 1.6
234 adejneka 1.13 (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 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
252 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
253     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
254 mikemac 1.1
255     (defmethod frame-standard-input ((frame application-frame))
256 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
257 mikemac 1.1 (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 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
270 mikemac 1.1
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 cvs 1.2 ;; during development, don't alter *error-output*
297     ;(*error-output* (frame-error-output frame))
298 mikemac 1.1 (*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 cvs 1.10 (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 adejneka 1.14 (apply prompt (list *standard-input* frame)))
310     (stream-finish-output *standard-input*))
311 adejneka 1.12 (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame))))
312 cvs 1.10 (loop for result in results
313     do (print result *standard-input*))
314     (terpri *standard-input*))
315     )))
316 mikemac 1.1
317 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
318 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
319    
320     (defmethod execute-frame-command ((frame application-frame) command)
321 cvs 1.8 #+ignore (apply (command-name command) (command-arguments command))
322     (eval command))
323 mikemac 1.1
324     (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
325     `(make-pane-1 ,fm ,frame ',type ,@args))
326    
327     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
328     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
329     (setf (frame-manager frame) fm)
330     (let* ((*application-frame* frame)
331 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
332 mikemac 1.1 :name 'top-level-sheet)))
333     (setf (slot-value frame 'top-level-sheet) t-l-s)
334     (generate-panes fm frame)))
335    
336     (defmethod disown-frame ((fm frame-manager) (frame application-frame))
337     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
338     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
339     (setf (frame-manager frame) nil))
340    
341 cvs 1.8 (defvar *pane-realizer* nil)
342    
343 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
344 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
345     (*application-frame* ,frame))
346     (progn
347     ,@body)))
348 mikemac 1.1
349     (defun make-single-pane-generate-panes-form (class-name pane)
350     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
351     (let ((*application-frame* frame))
352     (let ((pane ,pane))
353     (setf (slot-value frame 'pane) pane)))))
354    
355     (defun make-panes-generate-panes-form (class-name panes layouts)
356     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
357     (let ((*application-frame* frame))
358 cvs 1.8 (with-look-and-feel-realization (fm frame)
359     (let ,(loop for (name . form) in panes
360     collect `(,name (or (find-pane-named frame ',name)
361     (let ((pane
362     ,(cond
363     ((and (= (length form) 1)
364     (listp (first form)))
365     (first form))
366     ((keywordp (first form))
367     (let ((maker (intern (concatenate 'string
368     "MAKE-CLIM-"
369     (symbol-name (first form))
370     "-PANE") :clim)))
371     (if (fboundp maker)
372     `(,maker :name ',name ,@(cdr form))
373     `(make-pane ',(first form)
374     :name ',name ,@(cdr form)))))
375     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
376     (push pane (slot-value frame 'panes))
377     pane))))
378     (setf (slot-value frame 'pane)
379 mikemac 1.1 (ecase (frame-current-layout frame)
380     ,@layouts)))
381     ))))
382    
383     (defmacro define-application-frame (name superclasses slots &rest options)
384     (if (null superclasses)
385     (setq superclasses '(standard-application-frame)))
386     (let ((pane nil)
387     (panes nil)
388     (layouts nil)
389     (current-layout nil)
390     (command-table nil)
391     (menu-bar t)
392     (disabled-commands nil)
393     (command-definer t)
394     (top-level '(default-frame-top-level))
395     (others nil)
396     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
397     (loop for (prop . values) in options
398     do (case prop
399     (:pane (setq pane (first values)))
400     (:panes (setq panes values))
401     (:layouts (setq layouts values))
402     (:command-table (setq command-table (first values)))
403     (:menu-bar (setq menu-bar (first values)))
404     (:disabled-commands (setq disabled-commands values))
405     (:command-definer (setq command-definer (first values)))
406     (:top-level (setq top-level (first values)))
407     (t (push (cons prop values) others))))
408     (if (or (and pane panes)
409     (and pane layouts))
410     (error ":pane cannot be specified along with either :panes or :layouts"))
411     (if pane
412     (setq panes (list 'single-pane pane)
413     layouts (list :default (first pane))))
414     (setq current-layout (first (first layouts)))
415     `(progn
416     (defclass ,name ,superclasses
417     ,slots
418     (:default-initargs
419     :name ',name
420     :pretty-name ,(string-capitalize name)
421     :command-table ,command-table
422     :disabled-commands ',disabled-commands
423     :menu-bar ,menu-bar
424     :current-layout ',current-layout
425     :layouts ',layouts
426     :top-level ',top-level
427     )
428     ,@others)
429     ,(if pane
430     (make-single-pane-generate-panes-form name pane)
431     (make-panes-generate-panes-form name panes layouts))
432     ,@(if command-definer
433     `((defmacro ,command-name (name-and-options arguements &rest body)
434     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
435     (options (if (listp name-and-options) (cdr name-and-options) nil)))
436     `(define-command ,name ,arguements ,@body))))))))
437    
438     (defun make-application-frame (frame-name
439     &rest options
440     &key pretty-name frame-manager enable state
441     left top right bottom width height save-under
442     frame-class
443     &allow-other-keys)
444     (setq options (loop for (key value) on options by #'cddr
445     if (not (member key '(:pretty-name :frame-manager :enable :state
446     :left :top :right :bottom :width :height :save-under
447     :frame-class)
448     :key #'eq))
449     nconc (list key value)))
450     (if (null frame-class)
451     (setq frame-class frame-name))
452     (if (null pretty-name)
453     (setq pretty-name (string-capitalize frame-name)))
454     (if (null frame-manager)
455     (setq frame-manager (find-frame-manager)))
456     (let ((frame (apply #'make-instance frame-class
457     :port (frame-manager-port frame-manager)
458     :graft (find-graft :port (frame-manager-port frame-manager))
459     :name frame-name :pretty-name pretty-name options)))
460     (adopt-frame frame-manager frame)
461     frame))
462 cvs 1.4
463 cvs 1.7 ;;; Menu frame class
464    
465     (defclass menu-frame ()
466     ((left :initform 0 :initarg :left)
467     (top :initform 0 :initarg :top)
468     (top-level-sheet :initform nil :reader frame-top-level-sheet)
469     (pane :reader frame-pane :initarg :pane)
470     (graft :initform nil :accessor graft)
471     (manager :initform nil :accessor frame-manager)))
472    
473     (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
474     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
475     (setf (slot-value frame 'manager) fm)
476     (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
477     :name 'top-level-sheet)))
478     (setf (slot-value frame 'top-level-sheet) t-l-s)
479     (sheet-adopt-child t-l-s (frame-pane frame))
480     (let ((graft (find-graft :port (frame-manager-port fm))))
481     (sheet-adopt-child graft t-l-s)
482     (setf (graft frame) graft))
483 hatchond 1.11 (let ((space (compose-space t-l-s)))
484 cvs 1.7 (allocate-space (frame-pane frame)
485     (space-requirement-width space)
486     (space-requirement-height space))
487     (setf (sheet-region t-l-s)
488     (make-bounding-rectangle 0 0
489     (space-requirement-width space)
490     (space-requirement-height space))))
491     (setf (sheet-transformation t-l-s)
492     (make-translation-transformation (slot-value frame 'left)
493     (slot-value frame 'top)))))
494    
495     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
496     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
497     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
498     (setf (frame-manager frame) nil))
499    
500     (defun make-menu-frame (pane &key (left 0) (top 0))
501     (make-instance 'menu-frame :pane pane :left left :top top))
502    

  ViewVC Help
Powered by ViewVC 1.1.5