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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (hide annotations)
Thu May 9 06:56:22 2002 UTC (11 years, 11 months ago) by moore
Branch: MAIN
Changes since 1.34: +12 -11 lines
Major new functionality: command processing with completion.  Check
out the address-book demo.  In it, all commands are available on the
command line.  Completion and editing work.  Prompts for input show up
on *debug-io* for now, but otherwise command input is accepted from
presentations.

2002-05-08  Tim Moore  <moore@bricoworks.com>

	* commands.lisp: Implemented the magic argument parser function
	for commands.  Defined presentation types for command-name and
	command, as well as present and accept methods for them.
	(command-line-parser, command-line-unparser): Implemented.
	(define-command): Changed the :name argument to define-command to
	default to t which goes against the spec; this gives us some
	interesting command line parsing in the address book demo.  I'll
	change it back when we have presentation translators.
	* frames.lisp (default-frame-top-level): changed default prompt to
	"Command: ".  Don't echo results of commands.
	(execute-frame-command): Apply command name to command arguments
	like the spec says.
	* input-editing.lisp (stream-read-gesture): set rescanning to nil
	after reading a new gesture from the underlaying stream.
	(with-delimiter-gestures): Implement.
	(input-editor-format): Direct output to *debug-io* for now.
	(read-token): Handle null gestures, which shouldn't happen, but
	might after a stream is activated.
	(simple-parse-error): Fix :format-control initarg.
	(*completion-gestures*, simple-completion-error, complete-input,
	complete-from-generator, complete-from-possibilities,
	completing-from-suggestions): Implement.
	* ports.lisp (distribute-event): Change sheet of keyboard events
	to the sheet with input focus.
	* presentations.lisp (fake-params-args): Generate dummy args for
	optional and keyword arguments so their defaults don't need to be
	evaluated at compile time.
	(define-presentation-method): Set up a block with the same name as
	the method around the method body.
	(method presentation-typep): default method.
	(method presentation-type-of (standard-object)): Don't fail if the
	presentation type has no parameters.
	(method description (standard-class)): Add.
	(highlight-applicable-presentation): Don't pass through button
	events to the stream; handle them here.
	(accept): Provide a default :default-type argument if :default is
	specified.
	(method stream-accept (standard-input-editing-stream)): add.
	(accept-1): Respect replace-input argument.
	(prompt-for-accept): Work on any stream.
	(prompt-for-accept-1): Tweak default prompt for recursive accept.
	(method present): Define default method.
	(accept-using-read): Take read-eval as an argument.
	(method accept): Define default method.
	(presentation-method presentation-type-of (string)): Return a more
	general result.
	* stream-input.lisp (gesture-name command-delimiter): Define.
	* system.lisp: Reenable the address book demo.

	* Backends/CLX/port.lisp (method realize-mirror (clx-port
	application-pane)): Add to register for pointer motion events.

	* Goatee/buffer.lisp: Added buffer pointers, which maintain their
	relative position across inserts and deletes.
	(bp-buffer-mixin, bp-buffer-line): Classes for buffer pointers.
	Added all the buffer protocol functions for buffer pointers.
	* Goatee/editing-stream.lisp
	(location*-offset*): Old offset-location* :)
	(offset-location*) New function to return a stream offset from a
	buffer location.
	(replace-input): Rewrite to preserve insertion pointer, using
	buffer pointers.
	* Goatee/goatee-command.lisp: Add #\tab as an insertable character.
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     (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 moore 1.18 (hilited-presentation :initform nil
101     :initarg :hilited-presentation
102     :accessor frame-hilited-presentation)
103 moore 1.27 (event-queue :initform (make-instance 'standard-event-queue)
104 moore 1.24 :initarg :intercept-event-queue
105 moore 1.27 :accessor frame-event-queue)))
106 mikemac 1.1
107     (defun application-frame-p (x)
108     (typep x 'application-frame))
109    
110     (defmethod initialize-instance :after ((frame application-frame) &rest args)
111 moore 1.24 (declare (ignore args)))
112    
113 adejneka 1.13 ;;; Generic operations
114     ; (defgeneric frame-name (frame))
115     ; (defgeneric frame-pretty-name (frame))
116     ; (defgeneric (setf frame-pretty-name) (name frame))
117     ; (defgeneric frame-command-table (frame))
118     ; (defgeneric (setf frame-command-table) (command-table frame))
119     (defgeneric frame-standard-output (frame)
120     (:documentation
121     "Returns the stream that will be used for *standard-output* for the FRAME."))
122     (defgeneric frame-standard-input (frame)
123     (:documentation
124     "Returns the stream that will be used for *standard-input* for the FRAME."))
125     (defgeneric frame-query-io (frame)
126     (:documentation
127     "Returns the stream that will be used for *query-io* for the FRAME."))
128     (defgeneric frame-error-output (frame)
129     (:documentation
130     "Returns the stream that will be used for *error-output* for the FRAME."))
131     (defgeneric frame-pointer-documentation-output (frame)
132     (:documentation
133     "Returns the stream that will be used for *pointer-documentation-output*
134     for the FRAME."))
135     (defgeneric frame-calling-frame (frame)
136     (:documentation
137     "Returns the application frame that invoked the FRAME."))
138     (defgeneric frame-parent (frame)
139     (:documentation
140     "Returns the object that acts as the parent for the FRAME."))
141     ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
142     ; (:documentation
143     ; "Returns the pane that is the top-level pane in the current layout
144     ;of the FRAME's named panes."))
145     (defgeneric frame-top-level-sheet (frame)
146     (:documentation
147     "Returns the shhet that is the top-level sheet for the FRAME. This
148     is the sheet that has as its descendants all of the panes of the FRAME."))
149     (defgeneric frame-current-panes (frame)
150     (:documentation
151     "Returns a list of those named panes in the FRAME's current layout.
152     If there are no named panes, only the single, top level pane is returned."))
153     (defgeneric get-frame-pane (frame pane-name)
154     (:documentation
155     "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
156     (defgeneric find-pane-named (frame pane-name)
157     (:documentation
158     "Returns the pane in the FRAME whose name is PANE-NAME."))
159     ;(defgeneric frame-current-layout (frame))
160     ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
161     (defgeneric layout-frame (frame &optional width height))
162 mikemac 1.22 (defgeneric frame-exit-frame (condition)
163     (:documentation
164     "Returns the frame that is being exited from associated with the
165     FRAME-EXIT condition."))
166 adejneka 1.13 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
167     (:documentation
168     "Exits from the FRAME."))
169     (defgeneric pane-needs-redisplay (pane))
170     (defgeneric (setf pane-needs-redisplay) (value pane))
171     (defgeneric redisplay-frame-pane (frame pane &key force-p))
172     (defgeneric redisplay-frame-panes (frame &key force-p))
173     (defgeneric frame-replay (frame stream &optional region))
174     (defgeneric notify-user (frame message &key associated-window title
175     documentation exit-boxes name style text-style))
176     ;(defgeneric frame-properties (frame property))
177     ;(defgeneric (setf frame-properties) (value frame property))
178    
179    
180 mikemac 1.1 (defclass standard-application-frame (application-frame)
181     ())
182    
183     (defmethod (setf frame-manager) (fm (frame application-frame))
184     (let ((old-manager (frame-manager frame)))
185     (setf (slot-value frame 'manager) nil)
186     (when old-manager
187     (disown-frame old-manager frame)
188     (setf (slot-value frame 'panes) nil)
189     (setf (slot-value frame 'layouts) nil))
190     (setf (slot-value frame 'manager) fm)))
191    
192     (defmethod (setf frame-current-layout) (name (frame application-frame))
193     (declare (ignore name))
194     (generate-panes (frame-manager frame) frame))
195    
196     (defmethod generate-panes :before (fm (frame application-frame))
197     (declare (ignore fm))
198     (when (and (slot-boundp frame 'pane)
199     (frame-pane frame))
200     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
201    
202     (defmethod generate-panes :after (fm (frame application-frame))
203     (declare (ignore fm))
204     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
205 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
206     (setf (sheet-transformation (frame-top-level-sheet frame))
207     (make-translation-transformation 100 100))
208 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
209 cvs 1.5 ;; automatically generates a window-configuation-event
210     ;; which then calls allocate-space
211 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
212 cvs 1.5 (make-bounding-rectangle 0 0
213     (space-requirement-width space)
214     (space-requirement-height space)))))
215 mikemac 1.1
216     (defmethod layout-frame ((frame application-frame) &optional width height)
217     (let ((pane (frame-pane frame)))
218     (if (and width (not height))
219     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
220     (if (and (null width) (null height))
221 hatchond 1.11 (let ((space (compose-space pane)))
222 mikemac 1.1 (setq width (space-requirement-width space))
223     (setq height (space-requirement-height space))))
224     (allocate-space pane width height)))
225    
226 adejneka 1.13 (defun find-pane-if (predicate panes)
227     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
228 cvs 1.6 (setq panes (copy-list panes))
229 cvs 1.10 (do ((pane (pop panes)(pop panes)))
230     ((null pane) nil)
231 adejneka 1.13 (if (funcall predicate pane)
232 cvs 1.10 (return pane)
233     (setq panes (nconc panes (copy-list (sheet-children pane)))))))
234 adejneka 1.13
235 moore 1.27 (defun find-pane-if (predicate panes)
236     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
237     (loop for pane in panes
238     do (map-over-sheets #'(lambda (p)
239     (when (funcall predicate p)
240     (return-from find-pane-if p)))
241     pane)
242     finally (return nil)))
243    
244 adejneka 1.13 (defun find-pane-of-type (panes type)
245     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
246 cvs 1.6
247 adejneka 1.13 (defmethod frame-current-panes ((frame application-frame))
248     (find-pane-if #'(lambda (pane) (pane-name pane))
249     (frame-current-layout frame)))
250    
251     (defmethod get-frame-pane ((frame application-frame) pane-name)
252     (find-pane-if #'(lambda (pane)
253     (and (typep pane 'clim-stream-pane)
254     (eq pane-name
255     (pane-name pane))))
256     (frame-panes frame)))
257    
258     (defmethod find-pane-named ((frame application-frame) pane-name)
259     (find-pane-if #'(lambda (pane)
260     (eq pane-name
261     (pane-name pane)))
262     (frame-panes frame)))
263    
264 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
265 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
266     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
267 mikemac 1.1
268     (defmethod frame-standard-input ((frame application-frame))
269 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
270 mikemac 1.1 (frame-standard-output frame)))
271    
272     (defmethod frame-query-io ((frame application-frame))
273     (or (frame-standard-input frame)
274     (frame-standard-output frame)))
275    
276     (defmethod frame-error-output ((frame application-frame))
277     (frame-standard-output frame))
278    
279     (defvar *pointer-documentation-output* nil)
280    
281     (defmethod frame-pointer-documentation-output ((frame application-frame))
282 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
283 mikemac 1.1
284     ;;; Command loop interface
285    
286 mikemac 1.22 (define-condition frame-exit (condition)
287 moore 1.26 ((frame :initarg :frame :reader %frame-exit-frame)))
288 mikemac 1.22
289     (defmethod frame-exit ((frame standard-application-frame))
290     (signal 'frame-exit :frame frame))
291 moore 1.26
292     (defmethod frame-exit-frame ((c frame-exit))
293     (%frame-exit-frame c))
294 mikemac 1.22
295 mikemac 1.1 (defmethod run-frame-top-level ((frame application-frame))
296 mikemac 1.22 (handler-bind ((frame-exit #'(lambda (condition)
297 gilbert 1.31 (declare (ignore condition))
298 mikemac 1.22 (return-from run-frame-top-level nil))))
299     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
300 mikemac 1.1
301     (defmethod run-frame-top-level :around ((frame application-frame))
302     (let ((*application-frame* frame)
303     (*input-context* nil)
304     (*input-wait-test* nil)
305     (*input-wait-handler* nil)
306     (*pointer-button-press-handler* nil))
307     (declare (special *input-context* *input-wait-test* *input-wait-handler*
308     *pointer-button-press-handler*))
309 moore 1.24 (let ((query-io (frame-query-io frame)))
310     (if query-io
311     (with-input-focus (query-io)
312     (call-next-method))
313     (call-next-method)))))
314 mikemac 1.1
315     (defmethod default-frame-top-level
316     ((frame application-frame)
317     &key (command-parser 'command-line-command-parser)
318     (command-unparser 'command-line-command-unparser)
319     (partial-command-parser
320     'command-line-read-remaining-arguments-for-partial-command)
321 moore 1.35 (prompt "Command: "))
322 pixel 1.30 (when *multiprocessing-p*
323 brian 1.28 (sleep 4)) ; wait for the panes to be finalized - KLUDGE!!! - mikemac
324 mikemac 1.20 (loop
325     (let ((*standard-input* (frame-standard-input frame))
326     (*standard-output* (frame-standard-output frame))
327     (*query-io* (frame-query-io frame))
328     ;; during development, don't alter *error-output*
329     ;(*error-output* (frame-error-output frame))
330     (*command-parser* command-parser)
331     (*command-unparser* command-unparser)
332     (*partial-command-parser* partial-command-parser)
333     (prompt-style (make-text-style :fixed :italic :normal))
334     results)
335     (map-over-sheets #'(lambda (pane)
336     (if (and (typep pane 'clim-stream-pane)
337     (eq (pane-display-time pane) :command-loop)
338     (pane-display-function pane))
339     (let ((func (pane-display-function pane)))
340     (window-clear pane)
341     (funcall func frame pane))))
342     (frame-top-level-sheet frame))
343     (when *standard-input*
344     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
345 mikemac 1.21 (when prompt
346     (with-text-style (*standard-input* prompt-style)
347     (if (stringp prompt)
348 moore 1.35 (write-string prompt *standard-input*)
349     (funcall prompt *standard-input* frame))
350     (finish-output *standard-input*)))
351     (let ((command (read-frame-command frame)))
352     (fresh-line *standard-input*)
353     (when command
354     (execute-frame-command frame command))
355     (fresh-line *standard-input*))))))
356    
357 mikemac 1.1
358 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
359 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
360    
361     (defmethod execute-frame-command ((frame application-frame) command)
362 moore 1.35 (apply (command-name command) (command-arguments command)))
363    
364 mikemac 1.1
365     (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
366     `(make-pane-1 ,fm ,frame ',type ,@args))
367    
368     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
369     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
370     (setf (frame-manager frame) fm)
371     (let* ((*application-frame* frame)
372 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
373 mikemac 1.1 :name 'top-level-sheet)))
374     (setf (slot-value frame 'top-level-sheet) t-l-s)
375     (generate-panes fm frame)))
376 brian 1.28
377 mikemac 1.1 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
378     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
379     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
380     (setf (frame-manager frame) nil))
381    
382 cvs 1.8 (defvar *pane-realizer* nil)
383    
384 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
385 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
386     (*application-frame* ,frame))
387     (progn
388     ,@body)))
389 mikemac 1.1
390 brian 1.28 ; The menu-bar code in the following two functions is incorrect.
391     ; it needs to be moved to somewhere after the backend, since
392     ; it depends on the backend chosen.
393     ;
394     ; This hack slaps a menu-bar into the start of the application-frame,
395     ; in such a way that it is hard to find.
396     ;
397     ; FIXME
398     (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
399 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
400 brian 1.28 ; v-- hey, how can this be?
401 moore 1.17 (with-look-and-feel-realization (fm frame)
402 brian 1.28 (let ((pane ,(cond
403     ((eq menu-bar t)
404     `(vertically () (clim-internals::make-menu-bar
405     ',class-name)
406     ,pane))
407 brian 1.32 ((consp menu-bar)
408 brian 1.28 `(vertically () (clim-internals::make-menu-bar
409     (make-command-table nil
410     :menu ',menu-bar))
411     ,pane))
412     (menu-bar
413     `(vertically () (clim-internals::make-menu-bar
414     ',menu-bar)
415     ,pane))
416 gilbert 1.31 ;; The form below is unreachable with (listp
417     ;; menu-bar) instead of (consp menu-bar) above
418     ;; --GB
419 brian 1.28 (t pane))))
420     (setf (slot-value frame 'pane) pane)))))
421 mikemac 1.1
422 brian 1.28 ; could do with some refactoring [BTS] FIXME
423     (defun make-panes-generate-panes-form (class-name menu-bar panes layouts)
424 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
425     (let ((*application-frame* frame))
426 cvs 1.8 (with-look-and-feel-realization (fm frame)
427     (let ,(loop for (name . form) in panes
428     collect `(,name (or (find-pane-named frame ',name)
429     (let ((pane
430     ,(cond
431     ((and (= (length form) 1)
432     (listp (first form)))
433     (first form))
434     ((keywordp (first form))
435     (let ((maker (intern (concatenate 'string
436     "MAKE-CLIM-"
437     (symbol-name (first form))
438     "-PANE") :clim)))
439     (if (fboundp maker)
440     `(,maker :name ',name ,@(cdr form))
441     `(make-pane ',(first form)
442     :name ',name ,@(cdr form)))))
443     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
444 gilbert 1.19 ;; hmm?! --GB
445     (setf (slot-value pane 'name) ',name)
446     ;;
447 cvs 1.8 (push pane (slot-value frame 'panes))
448     pane))))
449 brian 1.28 ; [BTS] added this, but is not sure that this is correct for adding
450     ; a menu-bar transparently, should also only be done where the
451     ; exterior window system does not support menus
452     ,(if menu-bar
453     `(setf (slot-value frame 'pane)
454     (ecase (frame-current-layout frame)
455     ,@(mapcar (lambda (layout)
456     `(,(first layout) (vertically ()
457     ,(cond
458     ((eq menu-bar t)
459     `(clim-internals::make-menu-bar
460     ',class-name))
461 brian 1.32 ((consp menu-bar)
462 brian 1.28 `(raising (:border-width 2 :background +Gray83+)
463     (clim-internals::make-menu-bar
464     (make-command-table nil
465     :menu ',menu-bar))))
466     (menu-bar
467     `(clim-internals::make-menu-bar
468     ',menu-bar)))
469     ,@(rest layout))))
470     layouts)))
471     `(setf (slot-value frame 'pane)
472     (ecase (frame-current-layout frame)
473     ,@layouts))))))))
474 mikemac 1.1
475     (defmacro define-application-frame (name superclasses slots &rest options)
476     (if (null superclasses)
477     (setq superclasses '(standard-application-frame)))
478     (let ((pane nil)
479     (panes nil)
480     (layouts nil)
481     (current-layout nil)
482 mikemac 1.23 (command-table (list name))
483 mikemac 1.1 (menu-bar t)
484     (disabled-commands nil)
485     (command-definer t)
486     (top-level '(default-frame-top-level))
487     (others nil)
488     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
489     (loop for (prop . values) in options
490     do (case prop
491     (:pane (setq pane (first values)))
492     (:panes (setq panes values))
493     (:layouts (setq layouts values))
494     (:command-table (setq command-table (first values)))
495 brian 1.28 (:menu-bar (setq menu-bar (if (listp values)
496     (first values)
497     values)))
498 mikemac 1.1 (:disabled-commands (setq disabled-commands values))
499     (:command-definer (setq command-definer (first values)))
500     (:top-level (setq top-level (first values)))
501     (t (push (cons prop values) others))))
502     (if (or (and pane panes)
503     (and pane layouts))
504     (error ":pane cannot be specified along with either :panes or :layouts"))
505     (if pane
506     (setq panes (list 'single-pane pane)
507 moore 1.17 layouts `((:default ,(car pane)))))
508 mikemac 1.1 (setq current-layout (first (first layouts)))
509     `(progn
510     (defclass ,name ,superclasses
511     ,slots
512     (:default-initargs
513     :name ',name
514     :pretty-name ,(string-capitalize name)
515 mikemac 1.23 :command-table (find-command-table ',(first command-table))
516 mikemac 1.1 :disabled-commands ',disabled-commands
517 brian 1.28 :menu-bar ',menu-bar
518 mikemac 1.1 :current-layout ',current-layout
519     :layouts ',layouts
520     :top-level ',top-level
521     )
522     ,@others)
523     ,(if pane
524 brian 1.28 (make-single-pane-generate-panes-form name menu-bar pane)
525     (make-panes-generate-panes-form name menu-bar panes layouts))
526 mikemac 1.23 ,@(if command-table
527     `((define-command-table ,@command-table)))
528 mikemac 1.1 ,@(if command-definer
529     `((defmacro ,command-name (name-and-options arguements &rest body)
530     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
531 mikemac 1.23 (options (if (listp name-and-options) (cdr name-and-options) nil))
532     (command-table ',(first command-table)))
533     `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
534 mikemac 1.1
535     (defun make-application-frame (frame-name
536     &rest options
537     &key pretty-name frame-manager enable state
538     left top right bottom width height save-under
539     frame-class
540     &allow-other-keys)
541 mikemac 1.16 (declare (ignore enable state left top right bottom width height save-under))
542 mikemac 1.1 (setq options (loop for (key value) on options by #'cddr
543     if (not (member key '(:pretty-name :frame-manager :enable :state
544     :left :top :right :bottom :width :height :save-under
545     :frame-class)
546 mikemac 1.15 :test #'eq))
547 mikemac 1.1 nconc (list key value)))
548     (if (null frame-class)
549     (setq frame-class frame-name))
550     (if (null pretty-name)
551     (setq pretty-name (string-capitalize frame-name)))
552     (if (null frame-manager)
553     (setq frame-manager (find-frame-manager)))
554     (let ((frame (apply #'make-instance frame-class
555     :port (frame-manager-port frame-manager)
556     :graft (find-graft :port (frame-manager-port frame-manager))
557     :name frame-name :pretty-name pretty-name options)))
558     (adopt-frame frame-manager frame)
559     frame))
560 cvs 1.4
561 cvs 1.7 ;;; Menu frame class
562    
563     (defclass menu-frame ()
564     ((left :initform 0 :initarg :left)
565     (top :initform 0 :initarg :top)
566     (top-level-sheet :initform nil :reader frame-top-level-sheet)
567     (pane :reader frame-pane :initarg :pane)
568     (graft :initform nil :accessor graft)
569     (manager :initform nil :accessor frame-manager)))
570    
571     (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
572     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
573     (setf (slot-value frame 'manager) fm)
574     (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
575     :name 'top-level-sheet)))
576     (setf (slot-value frame 'top-level-sheet) t-l-s)
577     (sheet-adopt-child t-l-s (frame-pane frame))
578     (let ((graft (find-graft :port (frame-manager-port fm))))
579     (sheet-adopt-child graft t-l-s)
580     (setf (graft frame) graft))
581 hatchond 1.11 (let ((space (compose-space t-l-s)))
582 cvs 1.7 (allocate-space (frame-pane frame)
583     (space-requirement-width space)
584     (space-requirement-height space))
585     (setf (sheet-region t-l-s)
586     (make-bounding-rectangle 0 0
587     (space-requirement-width space)
588     (space-requirement-height space))))
589     (setf (sheet-transformation t-l-s)
590     (make-translation-transformation (slot-value frame 'left)
591     (slot-value frame 'top)))))
592    
593     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
594     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
595     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
596     (setf (frame-manager frame) nil))
597    
598     (defun make-menu-frame (pane &key (left 0) (top 0))
599     (make-instance 'menu-frame :pane pane :left left :top top))
600 moore 1.18
601     ;;; Frames and presentations
602    
603     (defmethod frame-find-innermost-applicable-presentation
604     ((frame standard-application-frame) input-context stream x y
605     &key event)
606     (find-innermost-applicable-presentation input-context stream
607     x y
608     :frame frame :event event))
609    
610     (defmethod frame-input-context-button-press-handler
611     ((frame standard-application-frame)
612     (stream output-recording-stream)
613     button-press-event)
614     (format *debug-io* "frame button press event: ~D ~D in ~S~%"
615     (pointer-event-x button-press-event)
616     (pointer-event-y button-press-event)
617     stream)
618     (let ((presentation (find-innermost-applicable-presentation
619     *input-context*
620     stream
621     (pointer-event-x button-press-event)
622     (pointer-event-y button-press-event)
623     :frame frame)))
624     (when presentation
625     (format *debug-io* "presentation: ~S of type ~S~%"
626     (presentation-object presentation)
627     (presentation-type presentation))
628     (throw-highlighted-presentation presentation
629     *input-context*
630     button-press-event))))
631    
632     (defmethod frame-input-context-button-press-handler
633     ((frame standard-application-frame) stream button-press-event)
634 moore 1.27 nil)
635 moore 1.18
636     (defmethod frame-input-context-track-pointer
637     ((frame standard-application-frame)
638     input-context
639     (stream output-recording-stream) event)
640     (declare (ignore input-context event))
641     nil)
642    
643     (defmethod frame-input-context-track-pointer
644     ((frame standard-application-frame) input-context stream event)
645     (declare (ignore input-context))
646 moore 1.27 nil)
647 moore 1.18
648     (defmethod frame-input-context-track-pointer :before
649     ((frame standard-application-frame) input-context stream event)
650     (if (output-recording-stream-p stream)
651     (let ((presentation (find-innermost-applicable-presentation
652     input-context
653     stream
654     (pointer-event-x event)
655     (pointer-event-y event)
656     :frame frame)))
657     (when (and (frame-hilited-presentation frame)
658     (not (eq presentation
659     (car (frame-hilited-presentation frame)))))
660     (highlight-presentation-1 (car (frame-hilited-presentation frame))
661     (cdr (frame-hilited-presentation frame))
662     :unhighlight))
663 moore 1.34 (if presentation
664     (when (not (eq presentation
665     (car (frame-hilited-presentation frame))))
666     (setf (frame-hilited-presentation frame)
667     (cons presentation stream))
668     (highlight-presentation-1 presentation stream :highlight))
669     (setf (frame-hilited-presentation frame) nil)))))
670    
671 moore 1.27
672     (defun simple-event-loop ()
673     "An simple event loop for applications that want all events to be handled by
674     handle-event methods"
675     (if *multiprocessing-p*
676     (let ((queue (frame-event-queue *application-frame*)))
677     (loop for event = (event-queue-read queue)
678     do (handle-event (event-sheet event) event)))
679     (let ((port (port *application-frame*)))
680     (loop
681     (process-next-event port)))))

  ViewVC Help
Powered by ViewVC 1.1.5