Newer
Older
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: frames.lisp,v 1.7 92/02/05 21:45:39 cer Exp $
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved.
Portions copyright (c) 1989, 1990 International Lisp Associates.
Portions copyright (c) 1991, 1992 Franz, Inc. All rights reserved."
;;--- We should add an input event-queue to frames, so that other
;;--- processes can queue up requests. This queue should be managed
;;--- like other event queues. It can contains "command" events, too.
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
;;--- Is it right for these to be SHEET accessors??
((name :initarg :name :accessor frame-name)
(pretty-name :initarg :pretty-name :accessor frame-pretty-name)
(command-table :initarg :command-table
:initform (find-command-table 'user-command-table)
:accessor frame-command-table)
(disabled-commands :initarg :disabled-commands :initform nil)
;;--- One of T, NIL, or a command-table; used by the menu-bar
(menu-bar :initarg :menu-bar :initform nil)
(histories :initform nil)
(frame-manager :reader frame-manager :initarg :frame-manager)
(calling-frame :reader frame-calling-frame :initarg :calling-frame)
;;--- How does ALL-PANES differ from PANES?
(panes :initarg :panes :accessor frame-panes)
(all-panes :initform nil)
(current-panes :initform nil :accessor frame-current-panes)
(initialized-panes :initform nil)
(pane-constructors :initarg :pane-constructors)
(top-level-sheet :accessor frame-top-level-sheet :initform nil)
(state :initform :disowned :accessor frame-state
:type (member :disowned :disabled :enabled :shrunk))
(top-level :initarg :top-level :accessor frame-top-level)
(current-layout :initarg :default-layout :reader frame-current-layout)
(default-size :initform nil :initarg :default-size)
(shell :accessor frame-shell)
(port :reader sheet-port :initarg :port)
(graft :reader sheet-graft :initarg :graft)
(properties :initform nil :initarg :properties
:accessor frame-properties))
(:default-initargs :top-level 'default-frame-top-level
:frame-manager (find-frame-manager)
:port (find-port)
:graft (find-graft)))
#+CLIM-1-compatibility
(define-compatibility-function (frame-top-level-window frame-top-level-sheet)
(frame)
(frame-top-level-sheet frame))
(defmethod initialize-instance :after ((frame standard-application-frame)
&rest args &key frame-manager)
(declare (ignore args))
;; Default method does nothing
(defmethod generate-panes ((framem standard-frame-manager)
(frame standard-application-frame))
(eval-when (eval compile load)
(defun define-application-frame-1 (name state-variables pane-descriptions
&key top-level layout
command-table disabled-commands)
(let* ((command-table-name (first command-table)))
;; If we're going to be defining commands for this application frame,
;; make sure there's an command table lying around so that all other
;; code doesn't have to be defensive against its absence.
(when command-table
(apply #'define-command-table-1 command-table))))
) ;eval-when
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
#+Genera (declare (zwei:indentation 1 25 2 3 3 1))
(with-warnings-for-definition name define-application-frame
(let (pane panes layout top-level menu-bar
command-definer command-table disabled-commands)
(macrolet ((extract (name keyword default &optional (pair t))
`(let ((entry (assoc ',keyword options)))
(cond ((null entry)
(setq ,name ,default))
(t
,@(if pair
`((assert (= (length entry) 2) (entry)
"The length of the option ~S must be 2" entry)
(setq ,name (second entry)
options (delete entry options)))
`((assert (listp (rest entry)) (entry)
"The remainder of ~S must be a list" entry)
(setq ,name (rest entry)
options (delete entry options)))))))))
(extract pane :pane nil)
(extract panes :panes nil nil)
(extract layout :layout nil nil)
(extract top-level :top-level '(default-frame-top-level))
(extract menu-bar :menu-bar t)
(extract command-definer :command-definer t)
(extract command-table :command-table t)
(extract disabled-commands :disabled-commands nil))
(check-type name symbol)
(check-type superclasses list)
(check-type slots list)
(check-type pane list)
(check-type panes list)
(check-type layout list)
(check-type top-level list)
(check-type disabled-commands list)
(when (and pane panes)
(error "The ~S and ~S options cannot be used together" :pane :panes))
(when (and pane layout)
(error "The ~S and ~S options cannot be used together" :pane :layout))
(when (or (and panes (null layout))
(and layout (null panes)))
(error "The ~S and ~S options must be used together" :panes :layout))
(when (null superclasses)
(setq superclasses '(standard-application-frame)))
(when (eq command-definer 't)
(setq command-definer (fintern "~A-~A-~A" 'define name 'command)))
(check-type command-definer symbol)
(cond ((null command-table))
((symbolp command-table)
(setq command-table (list command-table)))
(t (warn-if-command-table-invalid name command-table)))
(when (eq (first command-table) 't)
(setq command-table (list* name (rest command-table))))
#-Silica (warn-if-pane-descriptions-invalid name pane-descriptions)
#-Silica (warn-if-layout-invalid name layout pane-descriptions)
(let ((pane-constructors
(cond (panes
(compute-pane-constructor-code panes))
(pane
(compute-pane-constructor-code `((,name ,pane)))))))
`(progn
(eval-when (compile)
(when ',command-table
(setf (compile-time-property ',(first command-table) 'command-table-name) t))
(define-application-frame-1 ',name ',slots ,pane-constructors
:layout ',layout
:top-level ',top-level
:command-table ',command-table))
(define-group ,name define-application-frame
(defclass ,name ,superclasses ,slots
,@options
(:default-initargs
:menu-bar ',menu-bar
,@(and command-table `(:command-table ',(car command-table)))
,@(and top-level `(:top-level ',top-level))
,@(and panes `(:pane-constructors ,pane-constructors))
,@(and layout `(:default-layout ',(caar layout)))))
,@(when command-definer
`((defmacro ,command-definer (command-name arguments &body body)
#+Genera (declare (zwei:indentation 1 3 2 1))
`(define-frame-command ,',(first command-table)
,command-name ,arguments ,@body))
#+Genera (scl:defprop ,command-definer
define-command
zwei:definition-function-spec-type)
#+Genera (scl:defprop ,command-definer
remove-command
zwei:kill-definition)
#+Genera (scl:defprop ,command-definer
zwei:defselect-function-spec-finder
zwei:definition-function-spec-finder)))
;;--- Need to handle DISABLED-COMMANDS properly,
;;--- which entails doing a COPY-LIST
(define-application-frame-1 ',name ',slots ,pane-constructors
:layout ',layout
:top-level ',top-level
:command-table ',command-table
:disabled-commands ',disabled-commands)
#+Cloe-Runtime
(cloe:define-program ,name ()
:main ,name
:debugger-hook cloe-debugger-hook)
,@(compute-generate-panes-code name pane panes layout)))))))
#+Genera
(scl:defprop define-application-frame "CLIM Application Frame" si:definition-type-name)
;; For now each application frame has its own command table named after the application
(defmacro define-frame-command (command-table-name name-and-options arguments &body body)
(multiple-value-bind (command-name command-options)
(decode-name-and-options name-and-options command-table-name)
`(define-command (,command-name :command-table ,command-table-name ,@command-options)
,arguments
,@body)))
#+Genera
(scl::defprop define-frame-command define-command zwei:definition-function-spec-type)
#+Genera
(scl:defun (:property define-frame-command zwei:definition-function-spec-finder) (bp)
(zwei:defselect-function-spec-finder (zwei:forward-sexp bp 1 t)))
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
#+CLIM-1-compatibility
(defmacro with-frame-state-variables
((frame-name &optional (frame '*application-frame*)) &body body)
;; frame descriptor must be findable at compile-time
(let* ((descriptor (find-frame-descriptor frame-name))
(state-variables (frame-descriptor-state-variable-names descriptor)))
`(with-slots ,state-variables ,frame ,@body)))
(defun warn-if-command-table-invalid (frame-name command-table)
(cond ((not (and (listp command-table)
(symbolp (first command-table))
(oddp (length command-table))))
(warn "The ~S option for frame ~S, ~S, is invalid.~@
It is supposed to be a list of a command table name followed by ~
keyword/value pairs."
:command-table frame-name command-table))
(t
(do* ((options (cdr command-table) (cddr options))
(keyword (first options) (first options))
(value (second options) (second options)))
((null options))
(case keyword
(:inherit-from
(if (listp value)
(dolist (item value)
(unless (typep item '(or symbol command-table))
(warn "The ~S keyword in the ~S option for frame ~S~@
is followed by a list containing ~S, which is not a ~
command table nor a command table name."
:inherit-from :command-table frame-name item)))
(warn "The ~S keyword in the ~S option for frame ~S~@
is followed by ~S, which is not a list of command tables ~
or command table names."
:inherit-from :command-table frame-name value)))
(:menu
(if (listp value)
(dolist (clause value)
(unless (and (listp clause)
(>= (length clause) 3)
(oddp (length clause))
(stringp (first clause))
(member (second clause)
'(:command :function :menu :divider)))
(warn "The ~S keyword in the ~S option for frame ~S~@
is followed by a list of menu clauses containing~@
an invalid clause ~S."
:menu :command-table frame-name clause)))
(warn "The ~S keyword in the ~S option for frame ~S~@
is followed by ~S, which is not a list of menu clauses."
:menu :command-table frame-name value)))
(otherwise
(warn "The keyword ~S in the ~S option for frame ~S is invalid.~@
The valid keywords are ~S and ~S."
keyword :command-table frame-name :inherit-from :menu)))))))
(defun compute-generate-panes-code (name code panes layouts)
(if panes
(compute-complex-generate-panes-code name panes layouts)
(let ((frame '#:frame)
(framem '#:framem))
`((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
(let ((*application-frame* ,frame))
(setf (frame-panes ,frame)
(frame-wrapper ,framem ,frame
(with-look-and-feel-realization (,framem ,frame)
,code)))))))))
(let ((frame '#:frame)
(framem '#:framem))
`((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
,(mapcar #'(lambda (pane-spec)
(destructuring-bind (name code) pane-spec
`(,name (find-or-make-pane-named ,frame ',name))))
panes)
(let ((*application-frame* ,frame))
(setf (frame-panes ,frame)
(frame-wrapper ,framem ,frame
(with-look-and-feel-realization (,framem ,frame)
(ecase (frame-current-layout ,frame)
,@(mapcar #'(lambda (layout-spec)
(destructuring-bind (name panes) layout-spec
`(,name ,panes)))
layouts)))))))))))
(defun compute-pane-constructor-code (panes)
`(list ,@(mapcar #'(lambda (pane-spec)
(destructuring-bind (name code) pane-spec
`(list ',name
#'(lambda (frame framem)
(with-look-and-feel-realization (framem frame)
,code)))))
panes)))
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
(defmethod find-or-make-pane-named ((frame standard-application-frame) name)
(with-slots (all-panes pane-constructors) frame
(second (or (assoc name all-panes)
(car (push (list name
(funcall (second (assoc name pane-constructors))
frame (frame-manager frame)))
all-panes))))))
(defmethod layout-frame ((frame standard-application-frame) &optional width height)
(let ((panes (frame-panes frame)))
(when panes
(silica::clear-space-requirement-caches-in-tree panes)
(unless (and width height)
(let ((sr (compose-space panes)))
(setq width (space-requirement-width sr)
height (space-requirement-height sr))))
;;--- Don't bother with this if the size didn't change?
(allocate-space panes width height)
;; This is quite likely not going to work
(when (frame-top-level-sheet frame)
(resize-sheet* (frame-top-level-sheet frame) width height)))))
(defmethod (setf frame-current-layout) (nv (frame standard-application-frame))
(unless (eq (frame-current-layout frame) nv)
(setf (slot-value frame 'current-layout) nv)
;; First disown all the children
(dolist (name-and-pane (slot-value frame 'all-panes))
(let ((sheet (second name-and-pane)))
(when (sheet-parent sheet)
(sheet-disown-child (sheet-parent sheet) sheet))))
(dolist (child (sheet-children (frame-top-level-sheet frame)))
(sheet-disown-child (frame-top-level-sheet frame) child))
;; Now we want to give it some new ones
(generate-panes (frame-manager frame) frame)
(sheet-adopt-child (frame-top-level-sheet frame) (frame-panes frame))
(silica::clear-space-requirement-caches-in-tree (frame-panes frame))
(multiple-value-call #'layout-frame
frame (bounding-rectangle-size (frame-top-level-sheet frame)))
(throw 'layout-changed nil)))
#+CLIM-1-compatibility
(define-compatibility-function (set-frame-layout (setf frame-current-layout))
(frame new-layout)
(setf (frame-current-layout frame) new-layout))
(defun make-application-frame (frame-name &rest options
&key frame-class
enable pretty-name
width height
save-under
&allow-other-keys)
(declare (dynamic-extent options))
(check-type pretty-name (or null string))
(when (null frame-class)
(setq frame-class frame-name))
(with-keywords-removed (options options
'(:frame-class :pretty-name
:enable :width :height :save-under))
(let ((frame (apply #'make-instance frame-class
:name frame-name
:pretty-name (or pretty-name
(title-capitalize (string frame-name)))
:default-size (when (or width height)
(list width height))
:properties `(:save-under ,save-under)
options)))
(when enable
(enable-frame frame))
frame)))
(defun title-capitalize (string)
(let ((new-string (substitute #\Space #\- string)))
(when (eq new-string string)
(setq new-string (copy-seq new-string)))
(nstring-capitalize new-string)))
(defmethod enable-frame ((frame standard-application-frame))
(with-slots (default-size) frame
(ecase (frame-state frame)
(:enabled)
((:disabled :disowned)
(let ((old (frame-state frame)))
(setf (frame-state frame) :enabled)
;; IF this is a new frame then if the user specified a width
;; then we should be using that
;; IF the frame already exists then we probably should be using
;; the top level sheet size
(multiple-value-call
#'layout-frame
frame
(ecase old
(:disowned
(if default-size
(values (first default-size) (second default-size))
(values)))
(:disabled
(bounding-rectangle-size
(frame-top-level-sheet frame)))))
(note-frame-enabled (frame-manager frame) frame))))))
(defmethod disable-frame ((frame standard-application-frame))
((:enabled :shrunk)
(setf (frame-state frame) :disabled)
(note-frame-disabled (frame-manager frame) frame))))
(defmethod reset-frame ((frame standard-application-frame) &rest ignore)
(declare (ignore ignore))
nil)
(defmethod note-frame-enabled ((framem standard-frame-manager)
(frame standard-application-frame))
(defmethod note-frame-disabled ((framem standard-frame-manager)
(frame standard-application-frame))
)
(defmethod run-frame-top-level :around ((frame standard-application-frame))
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
(unwind-protect
(let (#-Silica (*frame-layout-changing-p* *frame-layout-changing-p*)
;; Reset the state of the input editor and the presentation
;; type system, etc., in case there is an entry into another
;; application from inside the input editor, such as a Debugger
;; written using CLIM.
;;--- This should be done in a more modular way
;;--- If you change this, change MENU-CHOOSE-FROM-DRAWER
(*original-stream* nil)
(*input-wait-test* nil)
(*input-wait-handler* nil)
(*pointer-button-press-handler* nil)
(*generate-button-release-events* nil)
(*numeric-argument* nil)
(*delimiter-gestures* nil)
(*activation-gestures* nil)
(*accelerator-gestures* nil)
(*input-context* nil)
(*accept-help* nil)
(*assume-all-commands-enabled* nil)
#-Silica (*sizing-application-frame* nil)
(*command-parser* 'command-line-command-parser)
(*command-unparser* 'command-line-command-unparser)
(*partial-command-parser*
'command-line-read-remaining-arguments-for-partial-command)
(*application-frame* frame))
(loop
(with-simple-restart (nil "~A top level" (frame-pretty-name frame))
(loop
(catch 'layout-changed
(let ((*application-frame* frame)
(*pointer-documentation-output*
(frame-pointer-documentation-output frame)))
;; We must return the values from CALL-NEXT-METHOD,
;; or else ACCEPTING-VALUES will return NIL
#-CCL-2
(return-from run-frame-top-level (call-next-method))
;; The (RETURN-FROM FOO (CALL-NEXT-METHOD)) form above
;; doesn't work in Coral. If the "top level" restart
;; above is taken, the CALL-NEXT-METHOD form blows out
;; the second time through this code, claiming that it
;; can't find the next method. Hoisting the
;; CALL-NEXT-METHOD out of the RETURN-FROM form seems
;; to fix it... So it conses, big deal.
#+CCL-2
(let ((results (multiple-value-list (call-next-method))))
(return-from run-frame-top-level (values-list results)))))))))
(disable-frame frame))))
(let ((top-level (frame-top-level frame)))
(if (atom top-level)
(funcall top-level frame)
(apply (first top-level) frame (rest top-level)))))
(defmethod default-frame-top-level ((frame standard-application-frame)
&key command-parser command-unparser
partial-command-parser
(let* ((*standard-output*
(or (frame-standard-output frame) *standard-output*))
(*standard-input*
(or (frame-standard-input frame) *standard-output*))
(*query-io*
(or (frame-query-io frame) *standard-input*))
(*error-output*
(or (frame-error-output frame) *standard-output*))
(interactor
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(or command-parser
(if interactor
#'command-line-command-parser
#'menu-command-parser)))
(or command-unparser
#'command-line-command-unparser))
(*partial-command-parser*
(or partial-command-parser
(if interactor
#'command-line-read-remaining-arguments-for-partial-command
#'menu-read-remaining-arguments-for-partial-command))))
#+Allegro
(assert (sheet-port *query-io*)))
;; The read-eval-print loop for applications...
(catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
(redisplay-frame-panes frame)
(when interactor
(fresh-line *standard-input*)
(if (stringp prompt)
(write-string prompt *standard-input*)
(let ((command (read-frame-command frame :stream *standard-input*)))
(when interactor
(terpri *standard-input*))
;; Need this check in case the user aborted out of a command menu
(when command
(execute-frame-command frame command)))))))))
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
;; Generic because someone might want :BEFORE or :AFTER
(defmethod frame-exit ((frame standard-application-frame))
(invoke-restart 'frame-exit))
#-Silica
(defun display-title (frame stream)
(multiple-value-bind (pane desc) (get-frame-pane frame stream)
(when (and pane (eq pane stream))
(let ((title (getf (pane-descriptor-options desc) :display-string)))
(when (and (stringp title)
(not (string-equal title (frame-pretty-name frame))))
;; On some hosts this will update the title bar
(setf (frame-pretty-name frame) title))
(when (and (eq stream pane) (not (dummy-pane-p pane)))
(multiple-value-bind (width height)
(window-inside-size stream)
(draw-string* stream (or title (frame-pretty-name frame))
(/ width 2) (/ height 2)
:align-x :center :align-y :center))
(force-output stream))
(values)))))
#-Silica
(defun display-command-menu (frame stream &rest keys
&key command-table &allow-other-keys)
(declare (dynamic-extent keys))
(declare (arglist frame stream &rest keys
&key command-table
;; Defaults for these provided by DISPLAY-COMMAND-TABLE-MENU
max-width max-height n-rows n-columns
(cell-align-x ':left) (cell-align-y ':top)
(initial-spacing t)))
;;--- This really wants to get the information from some other place
;;--- than having to find the descriptor each time, which is kludgy at best.
(multiple-value-bind (descriptor pane)
(do ((panes (frame-panes frame) (cdr panes))
(descriptions (frame-descriptor-pane-descriptions
(find-frame-descriptor frame))
(cdr descriptions)))
((null panes) nil)
(when (eq (first panes) stream)
(return (values (first descriptions) (first panes)))))
(when pane
(let ((command-table
(find-command-table (or command-table (frame-command-table frame))))
(incremental-redisplay
(getf (pane-descriptor-options descriptor) :incremental-redisplay))
(*application-frame* frame))
(with-keywords-removed (keys keys '(:command-table))
(if incremental-redisplay
(apply #'display-command-menu-1 stream command-table keys)
(apply #'display-command-table-menu command-table stream keys)))))))
;; Split out to avoid consing unnecessary closure environments.
#-Silica
(defun display-command-menu-1 (stream command-table &rest keys)
(declare (dynamic-extent keys))
(updating-output (stream :unique-id stream
:cache-value (slot-value command-table 'menu-tick))
(apply #'display-command-table-menu command-table stream keys)))
;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal
;; I/O operations, that is, a CLIM stream pane
(defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t))
(with-slots (all-panes) frame
(let ((pane (assoc pane-name all-panes)))
(when pane
(map-over-sheets #'(lambda (sheet)
(when (typep sheet 'clim-stream-pane)
(return-from get-frame-pane sheet)))
(second pane)))
(when errorp
(error "There is no pane named ~S in frame ~S" pane-name frame)))))
(defmethod redisplay-frame-panes (frame &key force-p)
(map-over-sheets #'(lambda (sheet)
(redisplay-frame-pane frame sheet :force-p
force-p)))
(frame-top-level-sheet frame)))
;;--- This needs to be more beefy, like in CLIM 1.0
;;--- And what about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc?
(record (and history
(> (output-record-count history) 0)
(output-record-element history 0))))
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
(with-simple-restart (nil "Skip redisplaying pane ~S" pane)
(loop
(with-simple-restart (nil "Retry displaying pane ~S" pane)
(return
(cond ((and ird (or force-p (null record)))
(when force-p
(window-clear pane))
(updating-output (pane)
(invoke-pane-redisplay-function frame pane)))
(ird
(redisplay record pane))
(t
(invoke-pane-redisplay-function frame pane))))))))))
(defun invoke-pane-redisplay-function (frame pane &rest args)
(declare (dynamic-extent args))
(let* ((df (pane-display-function pane))
(display-args (if (listp df) (rest df) nil))
(display-function (if (listp df) (first df) df)))
;; Cons as little as possible...
(cond ((and (null args) (null display-args))
(funcall display-function frame pane))
((null display-args)
(apply display-function frame pane args))
((null args)
(apply display-function frame pane display-args))
(t
(apply display-function frame pane (append args display-args))))))
(defmethod read-frame-command ((frame standard-application-frame)
&key (stream *query-io*) ;frame-query-io?
;; should the rest of the *command-parser*
;; etc. variables be passed as keywords or bound?
)
(read-command (frame-command-table frame) :stream stream))
(defmethod execute-frame-command ((frame standard-application-frame) command)
(apply (command-name command) (command-arguments command)))
(defmethod command-enabled (command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(or *assume-all-commands-enabled*
(and (not (member command-name disabled-commands))
(command-accessible-in-command-table-p
command-name (frame-command-table frame))))))
(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(cond (enabled
(setf disabled-commands (delete command-name disabled-commands))
(note-command-enabled (frame-manager frame) frame command-name))
(t
(push command-name disabled-commands)
(note-command-enabled (frame-manager frame) frame command-name)))))
#+CLIM-1-compatibility
(progn
(define-compatibility-function (command-enabled-p command-enabled)
(command-name frame)
(command-enabled command-name frame))
(define-compatibility-function (enable-command (setf command-enabled))
(command-name frame)
(setf (command-enabled command-name frame) t))
(define-compatibility-function (disable-command (setf command-enabled))
(setf (command-enabled command-name frame) nil))
) ;#+CLIM-1-compatibility
(defmethod note-command-enabled ((framem standard-frame-manager)
(frame standard-application-frame) command)
(defmethod note-command-disabled ((framem standard-frame-manager)
(frame standard-application-frame) command)
(declare (ignore command)))
;;; The contract of this is to replay the contents of STREAM within the region.
(defmethod frame-replay ((frame standard-application-frame) stream &optional region)
(stream-replay stream region)
(force-output stream))
;;; The contract of this is to find an "appropriate" presentation; i.e., one
;;; satisfying the input context specified by TYPE. Everything that looks for a
;;; presentation goes through this so that applications can specialize it.
(defmethod frame-find-innermost-applicable-presentation
((frame standard-application-frame) input-context stream x y)
(find-innermost-applicable-presentation input-context stream x y))
(declare (ignore stream))
(let* ((window (event-sheet button-press-event))
(x (pointer-event-x button-press-event))
(y (pointer-event-y button-press-event))
(highlighted-presentation (highlighted-presentation window nil))
(input-context *input-context*))
(when (and *click-outside-menu-handler*
(output-recording-stream-p window)
(funcall *click-outside-menu-handler*))
(when highlighted-presentation
;; Unhighlight on the way out.
;; But only unhighlight the window that the click is from.
(unhighlight-highlighted-presentation window nil))
(throw-highlighted-presentation
(or (and (output-recording-stream-p window)
(frame-find-innermost-applicable-presentation
*null-presentation*)
input-context
button-press-event)))
(defun find-frame-pane-of-type (frame type)
(map-over-sheets
#'(lambda (sheet)
(when (typep sheet type)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(defun map-over-sheets (fn sheet)
(funcall fn sheet)
(when (typep sheet 'silica::sheet-parent-mixin)
(dolist (child (sheet-children sheet))
(map-over-sheets fn child))))
(defmethod frame-standard-output ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'application-pane)
(find-frame-pane-of-type frame 'interactor-pane)))
(defmethod frame-standard-input ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'interactor-pane)
(frame-standard-output frame)))
(defmethod frame-error-output ((frame standard-application-frame))
(frame-standard-output frame))
;;--- Get this right
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
nil)
;;--- This causes direct-manipulation and menu-driven applications not to
;;--- maintain histories. Is there a better heuristic?
(defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(defvar *pointer-documentation-interval*
(max (floor (* 1/10 internal-time-units-per-second)) 1))
(defvar *last-pointer-documentation-time* 0)
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
#+Genera
(defvar *pointer-documentation-buffer*
(make-array 80 :element-type 'string-char :fill-pointer 0 :adjustable t))
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
((frame standard-application-frame) presentation input-context window x y stream)
(let (#+Genera (documentation-window (mouse-documentation-window window)))
;; The documentation should never say anything if we're not over a presentation
(when (null presentation)
#+Genera (if documentation-window
(scl:send documentation-window :clear-window)
(window-clear stream))
#-Genera (window-clear stream))
;; Cheap test to not do this work too often
(let ((old-modifier-state *last-pointer-documentation-modifier-state*)
(modifier-state (window-modifier-state window))
(last-time *last-pointer-documentation-time*)
(time (get-internal-real-time)))
(setq *last-pointer-documentation-modifier-state* modifier-state)
(when (and (< time (+ last-time *pointer-documentation-interval*))
(= modifier-state old-modifier-state))
(return-from frame-document-highlighted-presentation nil))
(setq *last-pointer-documentation-time* time))
(when presentation
#+Genera
(when documentation-window
(setf (fill-pointer *pointer-documentation-buffer*) 0)
(with-output-to-string (stream *pointer-documentation-buffer*)
(scl:send documentation-window :clear-window)
(when (null (frame-document-highlighted-presentation-1
frame presentation input-context window x y stream))
(setq *last-pointer-documentation-time* 0))
(scl:send documentation-window :string-out *pointer-documentation-buffer*))
(return-from frame-document-highlighted-presentation nil))
(with-output-recording-options (stream :record nil)
(with-end-of-line-action (stream :allow)
(with-end-of-page-action (stream :allow)
(window-clear stream)
(when (null (frame-document-highlighted-presentation-1
frame presentation input-context window x y stream))
(setq *last-pointer-documentation-time* 0))
(force-output stream)))))))
(defun frame-document-highlighted-presentation-1
(frame presentation input-context window x y stream)
(let ((modifier-state (window-modifier-state window)))
(declare (fixnum modifier-state))
(multiple-value-bind (left left-context middle middle-context right right-context)
(find-applicable-translators-for-documentation presentation input-context
frame window x y modifier-state)
(let* ((*print-length* 3)
(*print-level* 2)
(*print-circle* nil)
(*print-array* nil)
(*print-readably* nil)
(*print-pretty* nil))
(flet ((document-translator (translator context-type button-name separator)
;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
(let ((bit #o20)
(shift-name '("h-" "s-" "m-" "c-" "sh-")))
(declare (fixnum bit))
(dotimes (i 5)
#-(or Allegro Minima) (declare (ignore i))
(unless (zerop (logand bit modifier-state))
(write-string (car shift-name) stream))
(pop shift-name)
(setq bit (the fixnum (ash bit -1)))))
(write-string button-name stream)
(document-presentation-translator translator presentation context-type
frame nil window x y
:stream stream
:documentation-type :pointer)
(write-string separator stream)))
(declare (dynamic-extent #'document-translator))
(when left
(let ((button-name (cond ((and (eql left middle)
(eql left right))
(setq middle nil
right nil)
"L,M,R: ")
((eql left middle)
(setq middle nil)
"L,M: ")
(t "L: "))))
(document-translator left left-context button-name
(if (or middle right) "; " "."))))
(when middle
(let ((button-name (cond ((eql middle right)
(setq right nil)
"M,R: ")
(t "M: "))))
(document-translator middle middle-context button-name
(if right "; " "."))))
(when right
(document-translator right right-context "R: " "."))
;; Return non-NIL if any pointer documentation was produced
(or left middle right))))))
;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
(defun find-applicable-translators-for-documentation
(presentation input-context frame window x y modifier-state)
;; Assume a maximum of three pointer buttons
(let ((left nil) (left-context nil)
(middle nil) (middle-context nil)
(right nil) (right-context nil))
(macrolet ((match (translator context-type button)
(let ((button-translator (intern (symbol-name button)))
(button-context (fintern "~A-~A" (symbol-name button) 'context)))
`(when (and (or (null ,button-translator)
(> (presentation-translator-priority ,translator)
(presentation-translator-priority ,button-translator)))
(button-and-modifier-state-matches-gesture-name-p
(button-index ,button) modifier-state
(presentation-translator-gesture-name ,translator)))
(setq ,button-translator ,translator
,button-context ,context-type)))))
(do ((presentation presentation
(parent-presentation-with-shared-box presentation window)))
((null presentation))
(let ((from-type (presentation-type presentation)))
(dolist (context input-context)
(let ((context-type (pop context))) ;input-context-type = first
(let ((translators (find-presentation-translators
from-type context-type (frame-command-table frame))))
(when translators
(dolist (translator translators)
(when (test-presentation-translator translator
presentation context-type
frame window x y
:modifier-state modifier-state)
(match translator context-type :left)
(match translator context-type :middle)
(match translator context-type :right)))))
(when (and (or left middle right)
*presentation-menu-translator*
(test-presentation-translator *presentation-menu-translator*
presentation context-type
frame window x y
:modifier-state modifier-state))
(match *presentation-menu-translator* context-type :left)
(match *presentation-menu-translator* context-type :middle)
(match *presentation-menu-translator* context-type :right)))))))
(values left left-context
middle middle-context
right right-context)))
#+Genera
(defmethod mouse-documentation-window ((window window-stream)) nil)